OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_pcg.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "remesh_c.inc"
#include "scr03_c.inc"
#include "scr07_c.inc"
#include "sms_c.inc"
#include "task_c.inc"
#include "timeri_c.inc"
#include "units_c.inc"
#include "lockon.inc"
#include "lockoff.inc"
#include "warn_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sms_pcg (timers, nodft, nodlt, nnz, iadk, jdik, diag_sms, lt_k, r, isp, x_sms, p_sms, z_sms, y_sms, prec_sms, nodft1_sms, nodlt1_sms, indx1_sms, icodt, icodr, iskew, skew, itask, nodnx_sms, iad_elem, fr_elem, weight, ibfv, vel, npc, tf, v, x, d, sensor_tab, iframe, xframe, jadi_sms, jdii_sms, nsensor, lti_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, iskyi_sms, mskyi_sms, res_sms, ilink, llink, fr_rl, frl6, nnlink, lnlink, fr_ll, fnl6, ms, tag_lnk_sms, itab, fsav, ljoint, iadcj, fr_cj, cjwork, frl, fnl, nprw, lprw, rwbuf, rwsav, fopt, fr_wall, irwl_work, nrwl_sms, frea, intstamp, imv, mv, mv6, mw6, kinet, ixc, ixtg, sh4tree, sh3tree, cptreac, nodreac, fthreac, frwl6, am, vr, dr, in, rby, npby, lpby, tagmsr_rby_sms, irbe2, lrbe2, iad_rbe2, fr_rbe2m, nmrbe2, r2size, irbe3, lrbe3, frbe3, iad_rbe3m, fr_rbe3m, fr_rbe3mp, rrbe3, rrbe3_pon, prec_sms3, diag_sms3, iad_rby, fr_rby6, rby6, tagslv_rby_sms, r3size, nodft2_sms, nodlt2_sms, indx2_sms, nodii_sms, ibcscyc, lbcscyc, wfext, ams_work)
subroutine sms_mav_lt (timers, nodft, nodlt, numnod, iadl, jdil, itask, diag_k, lt_k, v, w, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, nodft2_sms, nodlt2_sms, indx2_sms, nodii_sms)
subroutine sms_mav_lt2 (timers, nodft, nodlt, numnod, iadl, jdil, itask, diag_k, lt_k, v, w, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6)

Function/Subroutine Documentation

◆ sms_mav_lt()

subroutine sms_mav_lt ( type(timer_), intent(inout) timers,
integer nodft,
integer nodlt,
integer numnod,
integer, dimension(*) iadl,
integer, dimension(*) jdil,
integer itask,
diag_k,
lt_k,
v,
w,
integer nodft1_sms,
integer nodlt1_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) nodnx_sms,
integer, dimension(2,nspmd+1) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) weight,
integer, dimension(*) jadi_sms,
integer, dimension(*) jdii_sms,
lti_sms,
integer, dimension(lskyi_sms,*) iskyi_sms,
mskyi_sms,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
mskyi_fi_sms,
vfi,
integer, dimension(*) imv,
mv,
double precision, dimension(6,3,*) mv6,
double precision, dimension(6,3,*) mw6,
integer nodft2_sms,
integer nodlt2_sms,
integer, dimension(*) indx2_sms,
integer, dimension(*) nodii_sms )

Definition at line 1698 of file sms_pcg.F.

1706C-----------------------------------------------
1707C M o d u l e s
1708C-----------------------------------------------
1709 USE timer_mod
1710 USE my_alloc_mod
1711C-----------------------------------------------
1712C I m p l i c i t T y p e s
1713C-----------------------------------------------
1714#include "implicit_f.inc"
1715C-----------------------------------------------
1716C C o m m o n B l o c k s
1717C-----------------------------------------------
1718#include "com01_c.inc"
1719#include "parit_c.inc"
1720#include "sms_c.inc"
1721#include "task_c.inc"
1722#include "timeri_c.inc"
1723#include "warn_c.inc"
1724C-----------------------------------------------
1725C D u m m y A r g u m e n t s
1726C-----------------------------------------------
1727 TYPE(TIMER_) , INTENT(INOUT) :: TIMERS
1728 INTEGER NODFT, NODLT, ITASK, NUMNOD, IADL(*) ,JDIL(*),
1729 . NODFT1_SMS,NODLT1_SMS,INDX1_SMS(*), NODNX_SMS(*),
1730 . NODFT2_SMS,NODLT2_SMS,INDX2_SMS(*), NODII_SMS(*),
1731 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),WEIGHT(*),
1732 . JADI_SMS(*),JDII_SMS(*),
1733 . ISKYI_SMS(LSKYI_SMS,*),FR_SMS(NSPMD+1),FR_RMS(NSPMD+1),
1734 . LIST_SMS(*), LIST_RMS(*), IMV(*)
1735C REAL
1736 my_real
1737 . diag_k(*), w(*), lt_k(*) ,v(*), lti_sms(*), mskyi_sms(*),
1738 . mskyi_fi_sms(*), vfi(*), mv(*)
1739 DOUBLE PRECISION MV6(6,3,*), MW6(6,3,*)
1740C-----------------------------------------------
1741C L o c a l V a r i a b l e s
1742C-----------------------------------------------
1743 INTEGER I,J,K,I3,I2,I1,K3,K2,K1,N, LOC_PROC, M, KK,
1744 . KMV,KMV3,KMV2,KMV1
1745 INTEGER SIZE, LENR, JAD, DIR, L, LLT,
1746 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1747 . REQ_R(NSPMD),REQ_S(NSPMD)
1748 my_real
1749 . l_k
1750 my_real, DIMENSION(:),ALLOCATABLE :: rbuf
1751 my_real, DIMENSION(:),ALLOCATABLE :: sbuf
1752C-----------------------------------------------
1753 IF (itask == 0)THEN
1754 CALL my_alloc(rbuf,3*(fr_rms(nspmd+1)+fr_sms(nspmd+1)))
1755 CALL my_alloc(sbuf,3*(fr_rms(nspmd+1)+fr_sms(nspmd+1)))
1756 ENDIF
1757C-----------------------------
1758
1759C
1760 IF(idtmins==2.OR.idtmins_int/=0)THEN
1761C
1762 IF(nspmd>1) THEN
1763C
1764 CALL my_barrier
1765C
1766 IF(itask==0)THEN ! comm sur 1er thread
1767C
1768 SIZE = 3
1769 IF(imonm>0) CALL startime(timers,65)
1770 CALL spmd_vfi_sms(v,SIZE,vfi,fr_rms,
1771 . fr_sms,list_rms,list_sms,1,
1772 . iad_send,iad_recv,req_r,req_s,rbuf,sbuf)
1773 IF(imonm>0) CALL stoptime(timers,65)
1774
1775 END IF
1776 END IF
1777 END IF
1778C
1779 IF(imonm>0.AND.itask==0)CALL startime(timers,64)
1780 IF(imonm>0.AND.itask==0)CALL startime(timers,74)
1781C
1782 kmv= 0
1783 IF(iparit==0.OR.debug(9)==0)THEN
1784C
1785 DO n=nodft1_sms,nodlt1_sms
1786 i=indx1_sms(n)
1787 i3=3*i
1788 i2=i3-1
1789 i1=i2-1
1790 w(i3)=diag_k(i)*v(i3)*weight(i)
1791 w(i2)=diag_k(i)*v(i2)*weight(i)
1792 w(i1)=diag_k(i)*v(i1)*weight(i)
1793 ENDDO
1794C
1795 IF(idtmins/=0)THEN
1796 DO n=nodft1_sms,nodlt1_sms
1797 i=indx1_sms(n)
1798 i3=3*i
1799 i2=i3-1
1800 i1=i2-1
1801 DO j =iadl(i),iadl(i+1)-1
1802 k =abs(jdil(j))
1803 k3=3*k
1804 k2=k3-1
1805 k1=k2-1
1806 l_k = lt_k(j)
1807 w(i3) = w(i3) + l_k*v(k3)
1808 w(i2) = w(i2) + l_k*v(k2)
1809 w(i1) = w(i1) + l_k*v(k1)
1810c W(K3) = W(K3) + L_K*V(I3)
1811c W(K2) = W(K2) + L_K*V(I2)
1812c W(K1) = W(K1) + L_K*V(I1)
1813 ENDDO
1814 ENDDO
1815 END IF
1816C
1817 ELSE
1818C---------------------------------------------------------------------
1819C Parith/ON is ensured when changing n of threads and/or n of domains
1820C---------------------------------------------------------------------
1821 DO n=nodft1_sms,nodlt1_sms
1822 i=indx1_sms(n)
1823 i3=3*i
1824 i2=i3-1
1825 i1=i2-1
1826 w(i3)=zero
1827 w(i2)=zero
1828 w(i1)=zero
1829 ENDDO
1830C
1831 IF(idtmins/=0)THEN
1832 DO n=nodft1_sms,nodlt1_sms
1833 i=indx1_sms(n)
1834 i3=3*i
1835 i2=i3-1
1836 i1=i2-1
1837 kmv =kmv + 1
1838 kmv3=3*kmv
1839 kmv2=kmv3-1
1840 kmv1=kmv2-1
1841 imv(kmv)=i
1842 mv(kmv3)=diag_k(i)*v(i3)*weight(i)
1843 mv(kmv2)=diag_k(i)*v(i2)*weight(i)
1844 mv(kmv1)=diag_k(i)*v(i1)*weight(i)
1845 DO j =iadl(i),iadl(i+1)-1
1846 k =abs(jdil(j))
1847 l_k = lt_k(j)
1848 k3=3*k
1849 k2=k3-1
1850 k1=k2-1
1851 kmv =kmv + 1
1852 kmv3=3*kmv
1853 kmv2=kmv3-1
1854 kmv1=kmv2-1
1855 imv(kmv)=i
1856 mv(kmv3)=l_k*v(k3)
1857 mv(kmv2)=l_k*v(k2)
1858 mv(kmv1)=l_k*v(k1)
1859 END DO
1860 END DO
1861 END IF
1862 END IF
1863C
1864 CALL my_barrier ! barriere avt NODFT2_SMS,NODLT2_SMS
1865C
1866 IF(itask==0)THEN
1867 IF(imonm>0)CALL stoptime(timers,74)
1868 END IF
1869C
1870 IF(idtmins==2.OR.idtmins_int/=0)THEN
1871C
1872 IF(iparit==0)THEN
1873 DO n=nodft2_sms,nodlt2_sms
1874 i=indx2_sms(n)
1875 i3=3*i
1876 i2=i3-1
1877 i1=i2-1
1878 DO j =jadi_sms(i),jadi_sms(i+1)-1
1879 k =jdii_sms(j)
1880 k3=3*k
1881 k2=k3-1
1882 k1=k2-1
1883 l_k = lti_sms(j)
1884 w(i3) = w(i3) +l_k*v(k3)
1885 w(i2) = w(i2) +l_k*v(k2)
1886 w(i1) = w(i1) +l_k*v(k1)
1887c W(K3) = W(K3) +L_K*V(I3)
1888c W(K2) = W(K2) +L_K*V(I2)
1889c W(K1) = W(K1) +L_K*V(I1)
1890 END DO
1891 END DO
1892 END IF
1893C
1894 IF(nspmd>1) THEN
1895C
1896 IF(itask==0)THEN ! comm sur 1er thread
1897 IF(imonm>0)CALL stoptime(timers,64)
1898C
1899 SIZE = 3
1900 IF(imonm>0) CALL startime(timers,65)
1901 CALL spmd_vfi_sms(v,SIZE,vfi,fr_rms,
1902 . fr_sms,list_rms,list_sms,2,
1903 . iad_send,iad_recv,req_r,req_s,rbuf,sbuf)
1904 IF(imonm>0) CALL stoptime(timers,65)
1905
1906 END IF
1907C
1908 CALL my_barrier
1909C
1910 ELSE
1911C
1912 CALL my_barrier
1913C
1914 IF(imonm>0.AND.itask==0)CALL stoptime(timers,64)
1915 END IF
1916C
1917 IF(imonm>0.AND.itask==0)CALL startime(timers,64)
1918C
1919 IF(iparit==0)THEN
1920 IF(nspmd>1) THEN
1921 IF(itask==0)THEN
1922 kk = 0
1923 loc_proc=ispmd+1
1924 m = 1
1925 DO l = 1, nspmd
1926C
1927 DO k=fr_rms(l),fr_rms(l+1)-1
1928 i=list_rms(k)
1929 kk = kk + 1
1930 IF(i==0)cycle
1931 i3=3*i
1932 i2=i3-1
1933 i1=i2-1
1934 k3=3*kk
1935 k2=k3-1
1936 k1=k2-1
1937 w(i3) = w(i3) -mskyi_fi_sms(k)*vfi(k3)
1938 w(i2) = w(i2) -mskyi_fi_sms(k)*vfi(k2)
1939 w(i1) = w(i1) -mskyi_fi_sms(k)*vfi(k1)
1940 END DO
1941C
1942 IF(l/=loc_proc)THEN
1943 DO k=fr_sms(l),fr_sms(l+1)-1
1944 i=list_sms(m)
1945 kk= kk + 1
1946 m = m + 1
1947 IF(i==0)cycle
1948 i3=3*i
1949 i2=i3-1
1950 i1=i2-1
1951 k3=3*kk
1952 k2=k3-1
1953 k1=k2-1
1954 w(i3) = w(i3) -mskyi_sms(k)*vfi(k3)
1955 w(i2) = w(i2) -mskyi_sms(k)*vfi(k2)
1956 w(i1) = w(i1) -mskyi_sms(k)*vfi(k1)
1957 END DO
1958 END IF
1959C
1960 END DO
1961 END IF
1962C
1963 CALL my_barrier
1964C
1965 IF(itask==0)THEN ! comm sur 1er thread
1966 IF(imonm>0)CALL stoptime(timers,64)
1967C
1968 SIZE = 3
1969 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
1970 IF(imonm>0) CALL startime(timers,80)
1971 CALL spmd_exch_sms(w,nodnx_sms,iad_elem,fr_elem,SIZE,
1972 . lenr)
1973 IF(imonm>0) CALL stoptime(timers,80)
1974 END IF
1975C
1976C BARRIER before RETURN
1977 CALL my_barrier
1978C
1979 ELSE
1980C
1981C BARRIER before RETURN
1982 CALL my_barrier
1983C
1984 IF(imonm>0.AND.itask==0)CALL stoptime(timers,64)
1985C
1986 END IF
1987C
1988 ELSEIF(debug(9)==0)THEN ! IPARIT==1.AND.DEBUG(9)==0) !
1989C---------------------------------------------------------------------
1990C Parith/ON is ensured when changing n of threads, not n of domains
1991C---------------------------------------------------------------------
1992 DO n=nodft2_sms,nodlt2_sms
1993 i=indx2_sms(n)
1994 DO j =jadi_sms(i),jadi_sms(i+1)-1
1995 k =jdii_sms(j)
1996 l_k = lti_sms(j)
1997 k3=3*k
1998 k2=k3-1
1999 k1=k2-1
2000 kmv =kmv + 1
2001 kmv3=3*kmv
2002 kmv2=kmv3-1
2003 kmv1=kmv2-1
2004 imv(kmv)=i
2005 mv(kmv3)=l_k*v(k3)
2006 mv(kmv2)=l_k*v(k2)
2007 mv(kmv1)=l_k*v(k1)
2008 END DO
2009 END DO
2010C
2011 IF(nspmd>1) THEN
2012C
2013Cafter gather VFI
2014 CALL my_barrier
2015C
2016 kk = 0
2017 loc_proc=ispmd+1
2018 m = 1
2019 DO l = 1, nspmd
2020C
2021 DO k=fr_rms(l),fr_rms(l+1)-1
2022 i=list_rms(k)
2023 kk = kk + 1
2024 IF(i == 0 .OR. nodii_sms(i) < nodft2_sms .OR.
2025 . nodlt2_sms < nodii_sms(i))cycle
2026 k3=3*kk
2027 k2=k3-1
2028 k1=k2-1
2029 kmv =kmv + 1
2030 kmv3=3*kmv
2031 kmv2=kmv3-1
2032 kmv1=kmv2-1
2033 imv(kmv)=i
2034 mv(kmv3) = -mskyi_fi_sms(k)*vfi(k3)
2035 mv(kmv2) = -mskyi_fi_sms(k)*vfi(k2)
2036 mv(kmv1) = -mskyi_fi_sms(k)*vfi(k1)
2037 END DO
2038C
2039 IF(l/=loc_proc)THEN
2040 DO k=fr_sms(l),fr_sms(l+1)-1
2041 i=list_sms(m)
2042 kk= kk + 1
2043 m = m + 1
2044 IF(i == 0 .OR. nodii_sms(i) < nodft2_sms .OR.
2045 . nodlt2_sms < nodii_sms(i))cycle
2046 k3=3*kk
2047 k2=k3-1
2048 k1=k2-1
2049 kmv =kmv + 1
2050 kmv3=3*kmv
2051 kmv2=kmv3-1
2052 kmv1=kmv2-1
2053 imv(kmv)=i
2054 mv(kmv3) = -mskyi_sms(k)*vfi(k3)
2055 mv(kmv2) = -mskyi_sms(k)*vfi(k2)
2056 mv(kmv1) = -mskyi_sms(k)*vfi(k1)
2057 END DO
2058 END IF
2059C
2060 END DO
2061C
2062 END IF
2063C
2064 CALL foat_to_6_float(1,3*kmv,mv,mv6)
2065C
2066 DO n=nodft2_sms,nodlt2_sms
2067 i=indx2_sms(n)
2068 DO j=1,6
2069 mw6(j,1,i)=zero
2070 mw6(j,2,i)=zero
2071 mw6(j,3,i)=zero
2072 END DO
2073 END DO
2074C
2075 DO k=1,kmv
2076 i=imv(k)
2077 DO j=1,6
2078 mw6(j,1,i) = mw6(j,1,i)+mv6(j,1,k)
2079 mw6(j,2,i) = mw6(j,2,i)+mv6(j,2,k)
2080 mw6(j,3,i) = mw6(j,3,i)+mv6(j,3,k)
2081 END DO
2082 END DO
2083C
2084 DO n=nodft2_sms,nodlt2_sms
2085 i=indx2_sms(n)
2086 i3=3*i
2087 i2=i3-1
2088 i1=i2-1
2089 w(i3) = w(i3)
2090 . +mw6(1,3,i)+mw6(2,3,i)+mw6(3,3,i)
2091 . +mw6(4,3,i)+mw6(5,3,i)+mw6(6,3,i)
2092 w(i2) = w(i2)
2093 . +mw6(1,2,i)+mw6(2,2,i)+mw6(3,2,i)
2094 . +mw6(4,2,i)+mw6(5,2,i)+mw6(6,2,i)
2095 w(i1) = w(i1)
2096 . +mw6(1,1,i)+mw6(2,1,i)+mw6(3,1,i)
2097 . +mw6(4,1,i)+mw6(5,1,i)+mw6(6,1,i)
2098 END DO
2099C
2100 IF(nspmd>1) THEN
2101C
2102 CALL my_barrier
2103C
2104 IF(itask==0)THEN ! comm sur 1er thread
2105 IF(imonm>0)CALL stoptime(timers,64)
2106C
2107 SIZE = 3
2108 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2109 IF(imonm>0) CALL startime(timers,80)
2110 CALL spmd_exch_sms(w,nodnx_sms,iad_elem,fr_elem,SIZE,
2111 . lenr)
2112 IF(imonm>0) CALL stoptime(timers,80)
2113 END IF
2114C
2115C BARRIER before RETURN
2116 CALL my_barrier
2117C
2118 ELSE
2119C
2120C BARRIER before RETURN
2121 CALL my_barrier
2122C
2123 IF(imonm>0.AND.itask==0)CALL stoptime(timers,64)
2124C
2125 END IF
2126C
2127 ELSE ! IF(IPARIT==1.AND.DEBUG(9)==1)
2128C---------------------------------------------------------------------
2129C Parith/ON is ensured when changing n of threads and/or n of domains
2130C---------------------------------------------------------------------
2131 DO n=nodft1_sms,nodlt1_sms
2132 i=indx1_sms(n)
2133 DO j =jadi_sms(i),jadi_sms(i+1)-1
2134 k =jdii_sms(j)
2135 l_k = lti_sms(j)
2136 k3=3*k
2137 k2=k3-1
2138 k1=k2-1
2139 kmv =kmv + 1
2140 kmv3=3*kmv
2141 kmv2=kmv3-1
2142 kmv1=kmv2-1
2143 imv(kmv)=i
2144 mv(kmv3)=l_k*v(k3)
2145 mv(kmv2)=l_k*v(k2)
2146 mv(kmv1)=l_k*v(k1)
2147 END DO
2148 END DO
2149C
2150 IF(nspmd>1) THEN
2151C
2152Cafter gather VFI
2153 CALL my_barrier
2154C
2155 kk = 0
2156 loc_proc=ispmd+1
2157 m = 1
2158 DO l = 1, nspmd
2159C
2160 DO k=fr_rms(l),fr_rms(l+1)-1
2161 i=list_rms(k)
2162 kk = kk + 1
2163 IF(i == 0 .OR. nodnx_sms(i) < nodft1_sms .OR.
2164 . nodlt1_sms < nodnx_sms(i))cycle
2165 k3=3*kk
2166 k2=k3-1
2167 k1=k2-1
2168 kmv =kmv + 1
2169 kmv3=3*kmv
2170 kmv2=kmv3-1
2171 kmv1=kmv2-1
2172 imv(kmv)=i
2173 mv(kmv3) = -mskyi_fi_sms(k)*vfi(k3)
2174 mv(kmv2) = -mskyi_fi_sms(k)*vfi(k2)
2175 mv(kmv1) = -mskyi_fi_sms(k)*vfi(k1)
2176 END DO
2177C
2178 IF(l/=loc_proc)THEN
2179 DO k=fr_sms(l),fr_sms(l+1)-1
2180 i=list_sms(m)
2181 kk= kk + 1
2182 m = m + 1
2183 IF(i == 0 .OR. nodnx_sms(i) < nodft1_sms .OR.
2184 . nodlt1_sms < nodnx_sms(i))cycle
2185 k3=3*kk
2186 k2=k3-1
2187 k1=k2-1
2188 kmv =kmv + 1
2189 kmv3=3*kmv
2190 kmv2=kmv3-1
2191 kmv1=kmv2-1
2192 imv(kmv)=i
2193 mv(kmv3) = -mskyi_sms(k)*vfi(k3)
2194 mv(kmv2) = -mskyi_sms(k)*vfi(k2)
2195 mv(kmv1) = -mskyi_sms(k)*vfi(k1)
2196 END DO
2197 END IF
2198C
2199 END DO
2200C
2201 END IF
2202C
2203 CALL foat_to_6_float(1,3*kmv,mv,mv6)
2204C
2205 DO n=nodft1_sms,nodlt1_sms
2206 i=indx1_sms(n)
2207 DO j=1,6
2208 mw6(j,1,i)=zero
2209 mw6(j,2,i)=zero
2210 mw6(j,3,i)=zero
2211 END DO
2212 END DO
2213C
2214 DO k=1,kmv
2215 i=imv(k)
2216 DO j=1,6
2217 mw6(j,1,i) = mw6(j,1,i)+mv6(j,1,k)
2218 mw6(j,2,i) = mw6(j,2,i)+mv6(j,2,k)
2219 mw6(j,3,i) = mw6(j,3,i)+mv6(j,3,k)
2220 END DO
2221 END DO
2222C
2223 IF(nspmd>1) THEN
2224C
2225 CALL my_barrier
2226C
2227 IF(itask==0)THEN ! comm sur 1er thread
2228 IF(imonm>0)CALL stoptime(timers,64)
2229C
2230 SIZE = 3
2231 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2232 IF(imonm>0) CALL startime(timers,80)
2233 CALL spmd_exch_sms6(mw6,nodnx_sms,iad_elem,fr_elem,SIZE,
2234 . lenr)
2235 IF(imonm>0) CALL stoptime(timers,80)
2236 END IF
2237C
2238 CALL my_barrier
2239C
2240 END IF
2241C
2242 IF(imonm>0.AND.itask==0)CALL startime(timers,64)
2243C
2244 DO n=nodft1_sms,nodlt1_sms
2245 i=indx1_sms(n)
2246 i3=3*i
2247 i2=i3-1
2248 i1=i2-1
2249 w(i3) = mw6(1,3,i)+mw6(2,3,i)+mw6(3,3,i)
2250 . +mw6(4,3,i)+mw6(5,3,i)+mw6(6,3,i)
2251 w(i2) = mw6(1,2,i)+mw6(2,2,i)+mw6(3,2,i)
2252 . +mw6(4,2,i)+mw6(5,2,i)+mw6(6,2,i)
2253 w(i1) = mw6(1,1,i)+mw6(2,1,i)+mw6(3,1,i)
2254 . +mw6(4,1,i)+mw6(5,1,i)+mw6(6,1,i)
2255 END DO
2256C
2257C BARRIER before RETURN
2258 CALL my_barrier
2259C
2260 IF(imonm>0.AND.itask==0)CALL stoptime(timers,64)
2261C
2262 END IF
2263
2264 ELSE ! IF(IDTMINS==2.OR.IDTMINS_INT/=0) <=> IDMINS==1
2265C
2266 CALL my_barrier
2267C
2268 IF(itask==0)THEN ! comm sur 1er thread
2269 IF(imonm>0)CALL stoptime(timers,64)
2270C
2271 IF(nspmd > 1)THEN
2272 SIZE = 3
2273 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2274 IF(imonm>0) CALL startime(timers,65)
2275 CALL spmd_exch_sms(w,nodnx_sms,iad_elem,fr_elem,SIZE,
2276 . lenr)
2277 IF(imonm>0) CALL stoptime(timers,65)
2278 END IF
2279 END IF
2280C BARRIER before RETURN
2281 CALL my_barrier
2282C
2283 END IF
2284
2285 IF (itask==0)THEN
2286 DEALLOCATE(rbuf)
2287 DEALLOCATE(sbuf)
2288 ENDIF
2289C--------------------------------------------
2290 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
foat_to_6_float
subroutine foat_to_6_float(jft, jlt, f, f6)
Definition parit.F:225
spmd_exch_sms6
subroutine spmd_exch_sms6(v, nodnx_sms, iad_elem, fr_elem, size, lenr)
Definition spmd_exch_sms6.F:34
spmd_exch_sms
subroutine spmd_exch_sms(v, nodnx_sms, iad_elem, fr_elem, size, lenr)
Definition spmd_exch_sms.F:36
spmd_vfi_sms
subroutine spmd_vfi_sms(v, size, vfi, fr_rms, fr_sms, list_rms, list_sms, iflag, iad_send, iad_recv, req_r, req_s, rbuf, sbuf)
Definition spmd_vfi_sms.F:34
my_barrier
subroutine my_barrier
Definition machine.F:31
startime
subroutine startime(event, itask)
Definition timer.F:93
stoptime
subroutine stoptime(event, itask)
Definition timer.F:135

◆ sms_mav_lt2()

subroutine sms_mav_lt2 ( type(timer_), intent(inout) timers,
integer nodft,
integer nodlt,
integer numnod,
integer, dimension(*) iadl,
integer, dimension(*) jdil,
integer itask,
diag_k,
lt_k,
v,
w,
integer nodft1_sms,
integer nodlt1_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) nodnx_sms,
integer, dimension(2,nspmd+1) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) weight,
integer, dimension(*) jadi_sms,
integer, dimension(*) jdii_sms,
lti_sms,
integer, dimension(lskyi_sms,*) iskyi_sms,
mskyi_sms,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
mskyi_fi_sms,
vfi,
integer, dimension(*) imv,
mv,
double precision, dimension(6,*) mv6,
double precision, dimension(6,*) mw6 )

Definition at line 2524 of file sms_pcg.F.

2531 USE timer_mod
2532C-----------------------------------------------
2533C I m p l i c i t T y p e s
2534C-----------------------------------------------
2535#include "implicit_f.inc"
2536C-----------------------------------------------
2537C C o m m o n B l o c k s
2538C-----------------------------------------------
2539#include "com01_c.inc"
2540#include "parit_c.inc"
2541#include "sms_c.inc"
2542#include "task_c.inc"
2543#include "timeri_c.inc"
2544C-----------------------------------------------
2545C D u m m y A r g u m e n t s
2546C-----------------------------------------------
2547 TYPE(TIMER_), intent(inout) :: TIMERS
2548 INTEGER NODFT, NODLT, ITASK, NUMNOD, IADL(*) ,JDIL(*),
2549 . NODFT1_SMS,NODLT1_SMS,INDX1_SMS(*), NODNX_SMS(*),
2550 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),WEIGHT(*),
2551 . JADI_SMS(*),JDII_SMS(*),
2552 . ISKYI_SMS(LSKYI_SMS,*),FR_SMS(NSPMD+1),FR_RMS(NSPMD+1),
2553 . LIST_SMS(*), LIST_RMS(*), IMV(*)
2554C REAL
2555 my_real
2556 . diag_k(*), w(*), lt_k(*) ,v(*), lti_sms(*), mskyi_sms(*),
2557 . mskyi_fi_sms(*), vfi(*), mv(*)
2558 DOUBLE PRECISION MV6(6,*), MW6(6,*)
2559C-----------------------------------------------
2560C L o c a l V a r i a b l e s
2561C-----------------------------------------------
2562 INTEGER I,J,K,N, LOC_PROC, M, KK, KMV
2563 INTEGER SIZE, LENR, JAD, DIR, L, LLT
2564 my_real
2565 . l_k
2566C-----------------------------
2567C
2568 DO n=nodft1_sms,nodlt1_sms
2569 i=indx1_sms(n)
2570 w(i)=v(i)*weight(i)
2571 ENDDO
2572C
2573 IF(idtmins/=0)THEN
2574 DO n=nodft1_sms,nodlt1_sms
2575 i=indx1_sms(n)
2576 IF(diag_k(i)/=zero)THEN
2577 DO j =iadl(i),iadl(i+1)-1
2578 k =abs(jdil(j))
2579 IF(diag_k(k)/=zero)THEN
2580 l_k = lt_k(j)/sqrt(diag_k(i)*diag_k(k))
2581 w(i) = w(i) + l_k*v(k)
2582 END IF
2583 ENDDO
2584 END IF
2585 ENDDO
2586 END IF
2587C
2588 IF(idtmins==2.OR.idtmins_int/=0)THEN
2589C
2590 IF(iparit==0)THEN
2591 DO n=nodft1_sms,nodlt1_sms
2592 i=indx1_sms(n)
2593 IF(diag_k(i)/=zero)THEN
2594 DO j =jadi_sms(i),jadi_sms(i+1)-1
2595 k =jdii_sms(j)
2596 IF(diag_k(k)/=zero)THEN
2597 l_k = lti_sms(j)/sqrt(diag_k(i)*diag_k(k))
2598 w(i) = w(i) +l_k*v(k)
2599 END IF
2600c W(K) = W(K) +L_K*V(I)
2601 END DO
2602 END IF
2603 END DO
2604 END IF
2605C
2606 IF(nspmd>1) THEN
2607C
2608 CALL my_barrier
2609C
2610 IF(itask==0)THEN ! comm sur 1er thread
2611C
2612 SIZE = 1
2613 IF(imonm>0) CALL startime(timers,65)
2614 CALL spmd_fi_sms(v,nodnx_sms,SIZE,vfi,fr_rms,
2615 . fr_sms,list_rms,list_sms)
2616 IF(imonm>0) CALL stoptime(timers,65)
2617
2618 END IF
2619 END IF
2620C
2621 IF(iparit==0)THEN
2622 IF(nspmd>1) THEN
2623 IF(itask==0)THEN
2624 kk = 0
2625 loc_proc=ispmd+1
2626 m = 1
2627 DO l = 1, nspmd
2628C
2629 DO k=fr_rms(l),fr_rms(l+1)-1
2630 i=list_rms(k)
2631 kk = kk + 1
2632 IF(i==0)cycle
2633 w(i) = w(i) -mskyi_fi_sms(k)*vfi(kk)
2634 END DO
2635C
2636 IF(l/=loc_proc)THEN
2637 DO k=fr_sms(l),fr_sms(l+1)-1
2638 i=list_sms(m)
2639 kk= kk + 1
2640 m = m + 1
2641 IF(i==0)cycle
2642 w(i) = w(i) -mskyi_sms(k)*vfi(kk)
2643 END DO
2644 END IF
2645C
2646 END DO
2647 END IF
2648 END IF
2649C
2650 ELSE
2651C
2652 kmv= 0
2653 DO n=nodft1_sms,nodlt1_sms
2654 i=indx1_sms(n)
2655 DO j =jadi_sms(i),jadi_sms(i+1)-1
2656 k =jdii_sms(j)
2657 IF(diag_k(i)/=zero.AND.diag_k(k)/=zero)THEN
2658 l_k = lti_sms(j)/sqrt(diag_k(i)*diag_k(k))
2659 ELSE
2660 l_k = zero
2661 END IF
2662 kmv =kmv + 1
2663 imv(kmv)=i
2664 mv(kmv) =l_k*v(k)
2665 END DO
2666 END DO
2667C
2668 IF(nspmd>1) THEN
2669C
2670Cafter gather VFI
2671 CALL my_barrier
2672C
2673 kk = 0
2674 loc_proc=ispmd+1
2675 m = 1
2676 DO l = 1, nspmd
2677C
2678 DO k=fr_rms(l),fr_rms(l+1)-1
2679 i=list_rms(k)
2680 kk = kk + 1
2681 IF(i == 0 .OR. nodnx_sms(i) < nodft1_sms .OR.
2682 . nodlt1_sms < nodnx_sms(i))cycle
2683 kmv =kmv + 1
2684 imv(kmv)=i
2685 mv(kmv) = -mskyi_fi_sms(k)*vfi(kk)
2686 END DO
2687C
2688 IF(l/=loc_proc)THEN
2689 DO k=fr_sms(l),fr_sms(l+1)-1
2690 i=list_sms(m)
2691 kk= kk + 1
2692 m = m + 1
2693 IF(i == 0 .OR. nodnx_sms(i) < nodft1_sms .OR.
2694 . nodlt1_sms < nodnx_sms(i))cycle
2695 kmv =kmv + 1
2696 imv(kmv)=i
2697 mv(kmv) = -mskyi_sms(k)*vfi(kk)
2698 END DO
2699 END IF
2700C
2701 END DO
2702C
2703 END IF
2704C
2705 CALL foat_to_6_float(1,kmv,mv,mv6)
2706C
2707 DO n=nodft1_sms,nodlt1_sms
2708 i=indx1_sms(n)
2709 DO j=1,6
2710 mw6(j,i)=zero
2711 END DO
2712 END DO
2713C
2714 DO k=1,kmv
2715 i=imv(k)
2716 DO j=1,6
2717 mw6(j,i) = mw6(j,i)+mv6(j,k)
2718 END DO
2719 END DO
2720C
2721 DO n=nodft1_sms,nodlt1_sms
2722 i=indx1_sms(n)
2723 w(i) = w(i)
2724 . +mw6(1,i)+mw6(2,i)+mw6(3,i)
2725 . +mw6(4,i)+mw6(5,i)+mw6(6,i)
2726 END DO
2727C
2728 END IF
2729
2730 END IF
2731C
2732 IF(nspmd>1) THEN
2733C
2734 CALL my_barrier
2735C
2736 IF(itask==0)THEN ! comm sur 1er thread
2737C
2738 SIZE = 1
2739 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2740 IF(imonm>0) CALL startime(timers,65)
2741 CALL spmd_exch_sms(w,nodnx_sms,iad_elem,fr_elem,SIZE,
2742 . lenr)
2743 IF(imonm>0) CALL stoptime(timers,65)
2744 END IF
2745 END IF
2746C
2747 CALL my_barrier
2748C
2749C--------------------------------------------
2750 RETURN
spmd_fi_sms
subroutine spmd_fi_sms(v, nodnx_sms, size, vfi, fr_rms, fr_sms, list_rms, list_sms)
Definition spmd_fi_sms.F:33

◆ sms_pcg()

subroutine sms_pcg ( type(timer_), intent(inout) timers,
integer nodft,
integer nodlt,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_sms,
lt_k,
r,
integer isp,
x_sms,
p_sms,
z_sms,
y_sms,
prec_sms,
integer nodft1_sms,
integer nodlt1_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) iskew,
skew,
integer itask,
integer, dimension(*) nodnx_sms,
integer, dimension(2,nspmd+1) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) weight,
integer, dimension(nifv,*) ibfv,
vel,
integer, dimension(*) npc,
tf,
v,
x,
d,
type (sensor_str_), dimension(nsensor), intent(in) sensor_tab,
integer, dimension(liskn,*) iframe,
xframe,
integer, dimension(*) jadi_sms,
integer, dimension(*) jdii_sms,
integer nsensor,
lti_sms,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
mskyi_fi_sms,
vfi,
integer, dimension(*) iskyi_sms,
mskyi_sms,
res_sms,
integer, dimension(*) ilink,
integer, dimension(*) llink,
integer, dimension(nspmd+2,*) fr_rl,
double precision, dimension(*) frl6,
integer, dimension(10,*) nnlink,
integer, dimension(*) lnlink,
integer, dimension(nspmd+2,*) fr_ll,
double precision, dimension(*) fnl6,
ms,
integer, dimension(*) tag_lnk_sms,
integer, dimension(*) itab,
fsav,
integer, dimension(*) ljoint,
integer, dimension(*) iadcj,
integer, dimension(*) fr_cj,
cjwork,
frl,
fnl,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
rwbuf,
rwsav,
fopt,
integer, dimension(*) fr_wall,
integer, dimension(*) irwl_work,
integer, dimension(*) nrwl_sms,
frea,
type(intstamp_data), dimension(*) intstamp,
integer, dimension(*) imv,
mv,
double precision, dimension(*) mv6,
double precision, dimension(*) mw6,
integer, dimension(*) kinet,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(ksh4tree,*) sh4tree,
integer, dimension(ksh3tree,*) sh3tree,
integer cptreac,
integer, dimension(*) nodreac,
fthreac,
double precision, dimension(*) frwl6,
am,
vr,
dr,
in,
rby,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(*) tagmsr_rby_sms,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer nmrbe2,
integer r2size,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe3,
frbe3,
integer, dimension(*) iad_rbe3m,
integer, dimension(*) fr_rbe3m,
integer, dimension(*) fr_rbe3mp,
rrbe3,
double precision, dimension(*) rrbe3_pon,
prec_sms3,
diag_sms3,
integer, dimension(*) iad_rby,
integer, dimension(*) fr_rby6,
double precision, dimension(8,6,nrbykin) rby6,
integer, dimension(*) tagslv_rby_sms,
integer r3size,
integer nodft2_sms,
integer nodlt2_sms,
integer, dimension(*) indx2_sms,
integer, dimension(*) nodii_sms,
integer, dimension(*) ibcscyc,
integer, dimension(*) lbcscyc,
double precision, intent(inout) wfext,
type (ams_work_), intent(inout) ams_work )

Definition at line 66 of file sms_pcg.F.

92C-----------------------------------------------
93C M o d u l e s
94C-----------------------------------------------
95 USE timer_mod
96 USE intstamp_mod
97 USE sensor_mod
98 USE sms_pcg_proj
99 USE ams_work_mod
100C-----------------------------------------------
101C I m p l i c i t T y p e s
102C-----------------------------------------------
103#include "implicit_f.inc"
104#include "comlock.inc"
105C-----------------------------------------------
106C G l o b a l P a r a m e t e r s
107C-----------------------------------------------
108#include "mvsiz_p.inc"
109C-----------------------------------------------
110C C o m m o n B l o c k s
111C-----------------------------------------------
112#include "com01_c.inc"
113#include "com04_c.inc"
114#include "param_c.inc"
115#include "parit_c.inc"
116#include "remesh_c.inc"
117#include "scr03_c.inc"
118#include "scr07_c.inc"
119#include "sms_c.inc"
120#include "task_c.inc"
121#include "timeri_c.inc"
122#include "units_c.inc"
123C-----------------------------------------------
124C D u m m y A r g u m e n t s
125C-----------------------------------------------
126C----------resol [M]{X}={F}---------
127 TYPE(TIMER_), INTENT(inout) :: TIMERS
128 INTEGER NODFT, NODLT, IADK(*), JDIK(*), NNZ, ISP,NSENSOR,
129 . NODFT1_SMS,NODLT1_SMS,INDX1_SMS(*),
130 . ICODT(*), ICODR(*), ISKEW(*), ITASK, NODNX_SMS(*),
131 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*), WEIGHT(*),
132 . NPC(*), IBFV(NIFV,*),IFRAME(LISKN,*),
133 . JADI_SMS(*), JDII_SMS(*),
134 . FR_SMS(NSPMD+1), FR_RMS(NSPMD+1),
135 . LIST_SMS(*), LIST_RMS(*),ISKYI_SMS(*),
136 . ILINK(*), LLINK(*), FR_RL(NSPMD+2,*), NNLINK(10,*),
137 . LNLINK(*), FR_LL(NSPMD+2,*), TAG_LNK_SMS(*), ITAB(*),
138 . LJOINT(*), FR_CJ(*), IADCJ(*),
139 . NPRW(*), LPRW(*), FR_WALL(*), IRWL_WORK(*), NRWL_SMS(*),
140 . IMV(*), KINET(*),CPTREAC,NODREAC(*),
141 . IXC(NIXC,*), IXTG(NIXTG,*),
142 . SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*),
143 . NPBY(NNPBY,*), LPBY(*), TAGMSR_RBY_SMS(*),
144 . IRBE2(NRBE2L,*), LRBE2(*), IAD_RBE2(*),
145 . FR_RBE2M(*), NMRBE2, R2SIZE, IRBE3(NRBE3L,*), LRBE3(*),
146 . IAD_RBE3M(*) ,FR_RBE3M(*) ,FR_RBE3MP(*),
147 . FR_RBY6(*),IAD_RBY(*), TAGSLV_RBY_SMS(*),R3SIZE,
148 . NODFT2_SMS,NODLT2_SMS,INDX2_SMS(*),NODII_SMS(*),
149 . IBCSCYC(*) ,LBCSCYC(*)
150C REAL
151 my_real
152 . diag_sms(*), lt_k(*) ,r(3,*),
153 . x_sms(3,*), p_sms(3,*), y_sms(3,*), z_sms(3,*), prec_sms(*),
154 . skew(*), v(3,*), x(3,*), d(3,*), tf(*), vel(lfxvelr,*),
155 . xframe(nxframe,*), lti_sms(*), res_sms(3,*),
156 . ms(*), fsav(nthvki,*), cjwork(*), frl(*), fnl(*),
157 . rwbuf(*), rwsav(*), fopt(*), frea(3,*),rbid,
158 . mskyi_fi_sms(*), mskyi_sms(*), vfi(*), mv(*),fthreac(6,*),
159 . am(3,*), vr(3,*), dr(3,*), in(*), rby(nrby,*),
160 . frbe3(*), rrbe3(*),
161 . prec_sms3(3,numnod), diag_sms3(3,numnod)
162 DOUBLE PRECISION FRL6(*), FNL6(*), MV6(*), MW6(*), FRWL6(*),
163 . RRBE3_PON(*)
164 DOUBLE PRECISION RBY6(8,6,NRBYKIN)
165 TYPE(INTSTAMP_DATA) INTSTAMP(*)
166 TYPE (sensor_str_) ,DIMENSION(NSENSOR) ,INTENT(IN) :: sensor_tab
167 DOUBLE PRECISION,INTENT(INOUT) :: WFEXT
168 TYPE (ams_work_), INTENT(INOUT) :: AMS_WORK
169C-----------------------------------------------
170C L o c a l V a r i a b l e s
171C-----------------------------------------------
172 INTEGER I, IT, TOTIT, NLIM, N, L, K, LLT, IDOWN, J, IFLAG, IACT,
173 . NCPRIA, M, MSR, IAD, NSN, KI, NRBDIM
174 my_real
175 . alpha, beta, toln,
176 . st , r2t, r02t, g0t, g1t, res_old,
177 . p1, p2, p3, dt05,
178 . xx, yy, zz, vrx, vry, vrz, v1, v2, v3, gx, gy, gz, a1, a2, a3
179 my_real
180 . r2(mvsiz), g(mvsiz), s(mvsiz), r02(mvsiz)
181 my_real
182 . rbuf(2)
183 DOUBLE PRECISION R6T(6), G6T(6), S6T(6), DBUF(12)
184C--------------INITIALISATION--------------------------
185 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
186
187 ncpria=abs(ncprisms)
188 nlim =max(nsmspcg,2)
189!$OMP SINGLE
190 nupdtl_sms=-1
191!$OMP END SINGLE
192
193 iact=0
194 it =0
195 totit=0
196C-------------IT=0--------
197C------X(I)=ZERO--------
198C
199C warning : PREC_SMS == DIAG_SMS at THIS STAGE
200C
201C comment faire rbody secnd de rbe (cf diag) ?
202 IF(nrbe2+r2size+nrbe3/=0)THEN
203 DO n=nodft1_sms,nodlt1_sms
204 i=indx1_sms(n)
205 diag_sms3(1,i)=prec_sms(i)
206 diag_sms3(2,i)=prec_sms(i)
207 diag_sms3(3,i)=prec_sms(i)
208 END DO
209 END IF
210C
211C warning : PREC_SMS == 1/DIAG_SMS after THIS STAGE
212 DO n=nodft1_sms,nodlt1_sms
213 i=indx1_sms(n)
214 IF(prec_sms(i)==zero)THEN
215C reset (spotflag=1 forces non remises a zero)
216C PREC_SMS(I)=ZERO
217 r(1,i)=zero
218 r(2,i)=zero
219 r(3,i)=zero
220 ELSE
221 prec_sms(i)=one/prec_sms(i)
222 END IF
223 ENDDO
224C-----------------------------------
225C RBE2
226C-----------------------------------
227 IF(nrbe2+r2size+nrbe3/=0)THEN
228 IF (nrbe2>0.OR.r2size>0) THEN
229C
230 CALL my_barrier
231C
232 IF(itask==0)THEN
233 CALL sms_rbe_prec(
234 1 irbe2 ,lrbe2 ,diag_sms,ms ,diag_sms3,
235 1 skew ,weight ,iad_rbe2,fr_rbe2m ,nmrbe2)
236 END IF
237 END IF
238C-----------------------------------
239C RBE3
240C-----------------------------------
241 IF (nrbe3>0)THEN
242C
243 CALL my_barrier
244C
245 IF(itask==0)THEN
246 CALL sms_rbe3_prec(
247 1 irbe3 ,lrbe3 ,x ,diag_sms ,diag_sms3,
248 2 frbe3 ,skew ,weight ,iad_rbe3m,fr_rbe3m ,
249 3 fr_rbe3mp,rrbe3 ,rrbe3_pon ,r3size)
250 END IF
251 END IF
252C
253 CALL my_barrier
254C
255 DO n=nodft1_sms,nodlt1_sms
256 i=indx1_sms(n)
257 IF(diag_sms3(1,i)==zero)THEN
258 prec_sms3(1,i)=zero
259 ELSE
260 prec_sms3(1,i)=one/diag_sms3(1,i)
261 END IF
262 IF(diag_sms3(2,i)==zero)THEN
263 prec_sms3(2,i)=zero
264 ELSE
265 prec_sms3(2,i)=one/diag_sms3(2,i)
266 END IF
267 IF(diag_sms3(3,i)==zero)THEN
268 prec_sms3(3,i)=zero
269 ELSE
270 prec_sms3(3,i)=one/diag_sms3(3,i)
271 END IF
272 END DO
273C
274 END IF ! IF(NRBE2+NRBE3/=0)THEN
275C-----------------------------------
276C LIENS RIGIDES ENTRE NOEUDS : REMONTEE FORCES
277C---- // ----------------------------
278 IF(nrlink+nlink+njoint+nadmesh > 0)THEN
279C
280 CALL my_barrier
281C
282 idown=0
283 IF(nrlink>0)CALL sms_rlink10(
284 1 ms ,r ,ilink ,llink,skew,
285 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
286 3 itab ,frl )
287C
288 IF(nlink>0) CALL sms_rlink11(
289 1 ms ,r ,nnlink,lnlink,skew ,
290 2 fr_ll ,weight,fnl6 ,x ,xframe,
291 3 v ,idown ,tag_lnk_sms,itab,fnl)
292C
293 IF(njoint > 0)
294 . CALL sms_cjoint_1(r ,diag_sms,ljoint,iadcj,fr_cj,
295 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
296C
297C IF(NADMESH/=0)THEN
298C IF(ITASK==0)THEN
299C CALL SMS_ADMESH_1(R, DIAG_SMS, IXC, IXTG,SH4TREE ,
300C . SH3TREE ,NODNX_SMS)
301C END IF
302C END IF
303C
304 CALL my_barrier
305C
306 END IF
307C
308C------PCG(PROJECTION)----place here to have the same reference value
309 IF (m_vs_sms > 0 ) THEN
310 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
311 IF(imonm>0.AND.itask==0)CALL startime(timers,70)
312C
313 CALL sms_inisi(
314 1 iadk ,jdik ,diag_sms,lt_k ,itask ,
315 2 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
316 3 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
317 4 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
318 5 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
319 6 mv6 ,mw6 ,ms ,nodft ,nodlt ,
320 7 prec_sms ,kinet )
321C /---------------/
322 CALL my_barrier
323C /---------------/
324 CALL sms_inist(timers,
325 1 iadk ,jdik ,diag_sms,lt_k ,itask ,
326 2 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
327 3 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
328 4 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
329 5 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
330 6 mv6 ,mw6 ,ms ,nodft ,nodlt )
331C /---------------/
332 CALL my_barrier
333C /---------------/
334 CALL sms_inix(timers,nodft,nodlt,numnod,x_sms,r ,weight,itask ,
335 . diag_sms )
336C
337 IF(imonm>0.AND.itask==0)CALL stoptime(timers,70)
338 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
339C
340 ELSE
341C
342 DO n=nodft1_sms,nodlt1_sms
343 i=indx1_sms(n)
344C
345 x_sms(1,i) = r(1,i)*prec_sms(i)
346 x_sms(2,i) = r(2,i)*prec_sms(i)
347 x_sms(3,i) = r(3,i)*prec_sms(i)
348 ENDDO
349 END IF
350C-----------------------------------
351C RBE3
352C-----------------------------------
353 IF (nrbe3>0)THEN
354C
355 CALL my_barrier
356C
357 IF(itask==0)THEN
358 CALL sms_rbe3t2(irbe3 ,lrbe3 ,x ,x_sms ,frbe3 ,
359 2 skew ,r ,prec_sms3 )
360 END IF
361 END IF
362C-----------------------------------
363C RBE2
364C-----------------------------------
365 IF (nrbe2>0) THEN
366C
367 CALL my_barrier
368C
369 IF(itask==0)THEN
370 CALL sms_rbe_accl(
371 1 irbe2 ,lrbe2 ,r ,x_sms ,prec_sms3 ,
372 1 skew ,weight ,iad_rbe2 ,fr_rbe2m,nmrbe2)
373 END IF
374C
375 END IF
376C-----------------------------------
377C LIENS RIGIDES ENTRE NOEUDS : PROJETTE X_SMS
378C---- // ----------------------------
379 IF(nrlink+nlink+njoint+nadmesh > 0)THEN
380C
381 CALL my_barrier
382C
383 idown=1
384 IF(nrlink>0)CALL sms_rlink10(
385 1 ms ,x_sms ,ilink ,llink,skew,
386 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
387 3 itab ,frl )
388C
389 IF(nlink>0) CALL sms_rlink11(
390 1 ms ,x_sms ,nnlink,lnlink,skew ,
391 2 fr_ll ,weight,fnl6 ,x ,xframe,
392 3 v ,idown ,tag_lnk_sms,itab,fnl)
393C
394 IF(njoint > 0)
395 . CALL sms_cjoint_1(x_sms ,diag_sms,ljoint,iadcj,fr_cj,
396 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
397C
398 IF(nadmesh/=0)THEN
399 CALL sms_admesh_2(x_sms, diag_sms, ixc, ixtg,sh4tree ,
400 . sh3tree ,itask)
401 END IF
402 END IF
403C
404 IF(nrwall > 0)THEN
405C
406 CALL my_barrier
407C
408C detect impacts
409 iflag=0
410 CALL sms_rgwal_0(iflag ,x ,v ,rwbuf ,lprw ,
411 2 nprw ,ms ,fsav(1,ninter+1),fr_wall ,fopt ,
412 3 rwsav ,weight ,irwl_work ,nrwl_sms,frwl6,
413 4 x_sms ,rbid ,rbid ,rbid ,wfext )
414C
415 CALL my_barrier
416C
417C project x_sms
418 iflag=1
419 CALL sms_rgwal_0(iflag ,x ,v ,rwbuf ,lprw ,
420 2 nprw ,ms ,fsav(1,ninter+1),fr_wall ,fopt ,
421 3 rwsav ,weight ,irwl_work ,nrwl_sms,frwl6,
422 4 x_sms ,rbid ,rbid ,rbid ,wfext )
423 END IF
424C
425 IF(nadmesh/=0)THEN
426C
427 y_sms(1:3,nodft:nodlt)=zero
428 z_sms(1:3,nodft:nodlt)=zero
429C
430 CALL my_barrier
431C
432 END IF
433C
434C-----------------------------------
435 IF(nrbody/=0)THEN
436C
437 CALL my_barrier()
438C
439 DO n=nodft1_sms,nodlt1_sms
440 i=indx1_sms(n)
441 m=tagslv_rby_sms(i)
442 IF(m /= 0)THEN
443 msr=npby(1,m)
444 x_sms(1,i)=x_sms(1,msr)
445 x_sms(2,i)=x_sms(2,msr)
446 x_sms(3,i)=x_sms(3,msr)
447 END IF
448 END DO
449C
450 CALL my_barrier()
451C
452 END IF
453C-----------------------------------
454 10 CONTINUE
455C-----------------------------------
456C
457 CALL my_barrier
458C
459C-----------------------------------
460 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
461 CALL sms_mav_lt(timers,
462 1 nodft ,nodlt ,numnod ,iadk ,jdik ,
463 2 itask ,diag_sms,lt_k ,x_sms ,z_sms ,
464 3 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
465 4 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
466 5 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
467 6 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
468 7 mv6 ,mw6 ,nodft2_sms,nodlt2_sms,indx2_sms,
469 8 nodii_sms )
470C
471 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
472C
473 IF(iparit==0)THEN
474 res0_sms = zero
475 g0_sms = zero
476 ELSE
477!$OMP SINGLE
478 DO k=1,6
479 r6sms(k)=zero
480 g6sms(k)=zero
481 ENDDO
482!$OMP END SINGLE
483 END IF
484C
485 CALL my_barrier
486C
487 IF(nadmesh/=0)THEN
488 IF(itask==0)THEN
489 CALL sms_admesh_1(z_sms, diag_sms, ixc, ixtg,sh4tree ,
490 . sh3tree ,nodnx_sms)
491 END IF
492C
493 CALL my_barrier
494C
495 END IF
496C-----------------------------------
497C RBE2
498C-----------------------------------
499 IF (nrbe2>0.OR.r2size>0) THEN
500C
501 CALL my_barrier
502C
503 IF(itask==0)THEN
504C
505 CALL sms_rbe_corr(
506 1 irbe2 ,lrbe2 ,x_sms ,z_sms ,ms ,
507 1 skew ,weight ,iad_rbe2,fr_rbe2m,nmrbe2)
508C
509 CALL sms_rbe_cnds(
510 1 irbe2 ,lrbe2 ,x ,z_sms ,am ,
511 1 ms ,in ,skew ,weight ,iad_rbe2,
512 2 fr_rbe2m,nmrbe2)
513C
514 END IF
515C
516 END IF
517C-----------------------------------
518C RBE3
519C-----------------------------------
520 IF (nrbe3>0)THEN
521C
522 CALL my_barrier
523C
524 IF(itask==0)THEN
525 CALL sms_rbe3t1(
526 1 irbe3 ,lrbe3 ,x ,z_sms ,frbe3 ,
527 2 skew ,weight ,iad_rbe3m,fr_rbe3m,fr_rbe3mp,
528 3 rrbe3 ,rrbe3_pon ,r3size)
529 END IF
530 END IF
531C-----------------------------------
532 IF(nrbody/=0)THEN
533C
534 CALL my_barrier()
535C
536!$OMP DO SCHEDULE(DYNAMIC,1)
537 DO m =1,nrbody
538 DO k = 1, 6
539 rby6(1,k,m) = zero
540 rby6(2,k,m) = zero
541 rby6(3,k,m) = zero
542 END DO
543C
544 msr=npby(1,m)
545 IF(msr < 0) cycle
546C
547 IF(tagmsr_rby_sms(msr) /= 0) THEN
548 rby6(1,1,m)=z_sms(1,msr)*weight(msr)
549 rby6(2,1,m)=z_sms(2,msr)*weight(msr)
550 rby6(3,1,m)=z_sms(3,msr)*weight(msr)
551 END IF
552
553 END DO
554!$OMP END DO
555
556!$OMP SINGLE
557 DO n=1,nindx1_sms
558 i=indx1_sms(n)
559 m=tagslv_rby_sms(i)
560 IF(m /= 0)THEN
561 IF(weight(i) /= 0)THEN
562 rby6(1,1,m)=rby6(1,1,m)+z_sms(1,i)
563 rby6(2,1,m)=rby6(2,1,m)+z_sms(2,i)
564 rby6(3,1,m)=rby6(3,1,m)+z_sms(3,i)
565 END IF
566 END IF
567 END DO
568!$OMP END SINGLE
569
570 IF (nspmd > 1) THEN
571!$OMP SINGLE
572 nrbdim=3
573 CALL spmd_exch_a_rb6(
574 1 nrbdim,iad_rby,fr_rby6,iad_rby(nspmd+1),rby6)
575!$OMP END SINGLE
576 END IF
577
578!$OMP DO SCHEDULE(DYNAMIC,1)
579 DO m =1,nrbody
580 msr=npby(1,m)
581 IF(msr < 0) cycle
582 IF(tagmsr_rby_sms(msr) /= 0) THEN
583 z_sms(1,msr)=rby6(1,1,m)
584 z_sms(2,msr)=rby6(2,1,m)
585 z_sms(3,msr)=rby6(3,1,m)
586 END IF
587 END DO
588!$OMP END DO
589 END IF
590C-----------------------------------
591 CALL sms_bcs(nodft1_sms,nodlt1_sms,indx1_sms,icodt ,iskew ,
592 2 skew ,z_sms ,nodlt1_sms )
593C-----------------------------------
594C /BCS/CYCLIC
595C-----------------------------------
596 IF (nbcscyc>0) CALL sms_bcscyc(ibcscyc,lbcscyc,skew,x,z_sms)
597C-----------------------------------
598C LIENS RIGIDES ENTRE NOEUDS : REMONTEE Z_SMS
599C---- // ----------------------------
600 IF(nrlink+nlink+njoint > 0)THEN
601C
602 CALL my_barrier
603C
604 idown=0
605 IF(nrlink>0)CALL sms_rlink10(
606 1 ms ,z_sms ,ilink ,llink,skew,
607 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
608 3 itab ,frl )
609C
610 IF(nlink>0) CALL sms_rlink11(
611 1 ms ,z_sms ,nnlink,lnlink,skew ,
612 2 fr_ll ,weight,fnl6 ,x ,xframe,
613 3 v ,idown ,tag_lnk_sms,itab,fnl)
614C
615 IF(njoint > 0)
616 . CALL sms_cjoint_1(z_sms ,diag_sms,ljoint,iadcj,fr_cj,
617 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
618 END IF
619C
620 CALL my_barrier
621C
622 DO n=nodft1_sms,nodlt1_sms
623 i=indx1_sms(n)
624 res_sms(1,i) = r(1,i)-z_sms(1,i)
625 res_sms(2,i) = r(2,i)-z_sms(2,i)
626 res_sms(3,i) = r(3,i)-z_sms(3,i)
627 ENDDO
628C-----------------------------------
629 IF(nrbody/=0)THEN
630C
631 CALL my_barrier()
632C
633 DO n=nodft1_sms,nodlt1_sms
634 i=indx1_sms(n)
635 m=tagslv_rby_sms(i)
636 IF(m /= 0)THEN
637 res_sms(1,i)=zero
638 res_sms(2,i)=zero
639 res_sms(3,i)=zero
640 END IF
641 END DO
642C
643 CALL my_barrier
644C
645 END IF
646C-----------------------------------
647 IF(nfxvel > 0)THEN
648C
649 CALL my_barrier
650C
651 IF(itask==0)
652 . CALL sms_fixvel(ibfv ,res_sms ,v ,npc ,tf ,
653 2 vel ,diag_sms,x ,skew ,sensor_tab,
654 3 weight ,d ,iframe ,xframe ,nsensor ,
655 4 it+1 ,diag_sms,nodnx_sms,cptreac,nodreac,
656 5 fthreac,am ,vr ,dr ,in ,
657 6 rby ,wfext )
658C
659 CALL my_barrier
660C
661 END IF
662C
663 IF(nrwall > 0)THEN
664C
665 CALL my_barrier
666C
667C project res
668 iflag=2
669 CALL sms_rgwal_0(iflag ,x ,v ,rwbuf ,lprw ,
670 2 nprw ,ms ,fsav(1,ninter+1),fr_wall ,fopt ,
671 3 rwsav ,weight ,irwl_work ,nrwl_sms,frwl6,
672 4 rbid ,res_sms,rbid ,rbid ,wfext )
673C
674 CALL my_barrier
675C
676 END IF
677C-----------------------------------
678 DO n=nodft1_sms,nodlt1_sms
679 i=indx1_sms(n)
680 z_sms(1,i) = res_sms(1,i) *prec_sms(i)
681 z_sms(2,i) = res_sms(2,i) *prec_sms(i)
682 z_sms(3,i) = res_sms(3,i) *prec_sms(i)
683 ENDDO
684C-----------------------------------
685C RBE3
686C-----------------------------------
687 IF (nrbe3>0)THEN
688C
689 CALL my_barrier
690C
691 IF(itask==0)THEN
692 CALL sms_rbe3t2(irbe3 ,lrbe3 ,x ,z_sms ,frbe3 ,
693 2 skew ,res_sms ,prec_sms3 )
694 END IF
695 END IF
696C-----------------------------------
697C RBE2
698C-----------------------------------
699 IF (nrbe2>0) THEN
700C
701 CALL my_barrier
702C
703 IF(itask==0)THEN
704 CALL sms_rbe_accl(
705 1 irbe2 ,lrbe2 ,res_sms,z_sms ,prec_sms3,
706 1 skew ,weight ,iad_rbe2 ,fr_rbe2m,nmrbe2)
707 END IF
708C
709 END IF
710C-----------------------------------
711C LIENS RIGIDES ENTRE NOEUDS : PROJETTE
712C---- // ----------------------------
713 IF(nrlink+nlink+njoint+nadmesh > 0)THEN
714C
715 CALL my_barrier
716C
717 idown=1
718 IF(nrlink>0)CALL sms_rlink10(
719 1 ms ,z_sms ,ilink ,llink,skew,
720 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
721 3 itab ,frl )
722C
723 IF(nlink>0) CALL sms_rlink11(
724 1 ms ,z_sms ,nnlink,lnlink,skew ,
725 2 fr_ll ,weight,fnl6 ,x ,xframe,
726 3 v ,idown ,tag_lnk_sms,itab,fnl)
727C
728 IF(njoint > 0)
729 . CALL sms_cjoint_1(z_sms ,diag_sms,ljoint,iadcj,fr_cj,
730 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
731C
732 IF(nadmesh/=0)THEN
733 CALL sms_admesh_2(z_sms, diag_sms, ixc, ixtg,sh4tree ,
734 . sh3tree ,itask)
735 END IF
736C
737 CALL my_barrier
738C
739 END IF
740C-----------------------------------
741C
742 DO n=nodft1_sms,nodlt1_sms,mvsiz
743C
744 llt=min(nodlt1_sms-n+1,mvsiz)
745C
746 DO l=1,llt
747 i=indx1_sms(n+l-1)
748 p_sms(1,i) = z_sms(1,i)
749 p_sms(2,i) = z_sms(2,i)
750 p_sms(3,i) = z_sms(3,i)
751 g(l) = ( z_sms(1,i)*res_sms(1,i)
752 . + z_sms(2,i)*res_sms(2,i)
753 . + z_sms(3,i)*res_sms(3,i))
754 . * weight(i)
755C
756C Tolerance wrt RES, not to R (due to kinematic conditions, like RWALLs)
757 r2(l) = ( res_sms(1,i)*res_sms(1,i)
758 . + res_sms(2,i)*res_sms(2,i)
759 . + res_sms(3,i)*res_sms(3,i))
760 . * weight(i)
761 ENDDO
762C
763 IF(iparit==0)THEN
764 r02t = zero
765 g0t = zero
766 DO l=1,llt
767 r02t = r02t + r2(l)
768 g0t = g0t + g(l)
769 ENDDO
770#include "lockon.inc"
771 res0_sms=res0_sms+r02t
772 g0_sms =g0_sms +g0t
773#include "lockoff.inc"
774 ELSE
775 DO k=1,6
776 r6t(k) = zero
777 g6t(k) = zero
778 ENDDO
779 IF(imonm>0.AND.itask==0)CALL startime(timers,62)
780 CALL sum_6_float(1,llt,r2,r6t,1)
781 CALL sum_6_float(1,llt,g,g6t,1)
782 IF(imonm>0.AND.itask==0)CALL stoptime(timers,62)
783#include "lockon.inc"
784 DO k=1,6
785 r6sms(k)=r6sms(k)+r6t(k)
786 g6sms(k)=g6sms(k)+g6t(k)
787 ENDDO
788#include "lockoff.inc"
789 END IF
790 ENDDO
791C-----------------------------------
792C
793 CALL my_barrier
794C
795 IF(nspmd <= 1)THEN
796 IF(iparit/=0.AND.itask==0)THEN
797 res0_sms=r6sms(1)+r6sms(2)+r6sms(3)+
798 . r6sms(4)+r6sms(5)+r6sms(6)
799 g0_sms =g6sms(1)+g6sms(2)+g6sms(3)+
800 . g6sms(4)+g6sms(5)+g6sms(6)
801 END IF
802 ELSEIF(itask==0)THEN ! communication sur un seul thread
803 IF(iparit==0)THEN
804 IF(imonm>0) CALL startime(timers,63)
805 rbuf(1)=res0_sms
806 rbuf(2)=g0_sms
807 CALL spmd_glob_dsum9(rbuf,2)
808 CALL spmd_rbcast(rbuf,rbuf,2,1,0,2)
809 res0_sms=rbuf(1)
810 g0_sms =rbuf(2)
811 IF(imonm>0) CALL stoptime(timers,63)
812 ELSE
813 IF(imonm>0) CALL startime(timers,63)
814 DO k=1,6
815 dbuf(k) =r6sms(k)
816 dbuf(k+6)=g6sms(k)
817 END DO
818 CALL spmd_glob_dpsum9(dbuf,12)
819 rbuf(1) = dbuf(1)+dbuf(2)+dbuf(3)+
820 . dbuf(4)+dbuf(5)+dbuf(6)
821 rbuf(2) = dbuf(7) +dbuf(8) +dbuf(9)+
822 . dbuf(10)+dbuf(11)+dbuf(12)
823 CALL spmd_rbcast(rbuf,rbuf,2,1,0,2)
824 res0_sms=rbuf(1)
825 g0_sms =rbuf(2)
826 IF(imonm>0) CALL stoptime(timers,63)
827 END IF
828 END IF
829C-----------------------------------
830C redescente Pm => Pi
831C-----------------------------------
832 IF(nrbody/=0)THEN
833C
834 CALL my_barrier()
835C
836 DO n=nodft1_sms,nodlt1_sms
837 i=indx1_sms(n)
838 m=tagslv_rby_sms(i)
839 IF(m /= 0)THEN
840 msr=npby(1,m)
841 p_sms(1,i)=p_sms(1,msr)
842 p_sms(2,i)=p_sms(2,msr)
843 p_sms(3,i)=p_sms(3,msr)
844 END IF
845 END DO
846C
847 CALL my_barrier()
848C
849 END IF
850C-----------------------------------
851C
852 CALL my_barrier
853C
854 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
855 IF (res0_sms<em10) GOTO 200
856 toln=res0_sms*tol_sms
857
858 100 CONTINUE
859
860 it = it +1
861 totit = totit + 1
862
863C
864C------PCG(PROJECTION)----
865 IF (m_vs_sms > 0 ) THEN
866 IF(imonm>0.AND.itask==0)CALL startime(timers,70)
867C
868 CALL sms_pro_p(timers,nodft ,nodlt ,numnod ,p_sms,weight,itask ,
869C z as work array
870 . z_sms ,diag_sms)
871C /---------------/
872 CALL my_barrier
873C /---------------/
874C
875 IF(imonm>0.AND.itask==0)CALL stoptime(timers,70)
876 END IF
877C
878c CALL MY_BARRIER
879C
880 CALL sms_mav_lt(timers,
881 1 nodft ,nodlt ,numnod ,iadk ,jdik ,
882 2 itask ,diag_sms,lt_k ,p_sms ,y_sms ,
883 3 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
884 4 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
885 5 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
886 6 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
887 7 mv6 ,mw6 ,nodft2_sms,nodlt2_sms,indx2_sms,
888 8 nodii_sms )
889C
890 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
891 IF(iparit==0)THEN
892 res1_sms= zero
893 g1_sms = zero
894 s_sms = zero
895 ELSE
896!$OMP SINGLE
897 DO k=1,6
898 r6sms(k)=zero
899 g6sms(k)=zero
900 s6sms(k)=zero
901 ENDDO
902!$OMP END SINGLE
903 END IF
904C
905 CALL my_barrier
906C
907 IF(nadmesh/=0)THEN
908C
909 CALL my_barrier
910C
911 IF(itask==0)THEN
912 CALL sms_admesh_1(y_sms, diag_sms, ixc, ixtg,sh4tree ,
913 . sh3tree ,nodnx_sms)
914 END IF
915C
916 CALL my_barrier
917C
918 END IF
919C-----------------------------------
920C RBE2
921C-----------------------------------
922 IF (nrbe2>0.OR.r2size>0) THEN
923C
924 CALL my_barrier
925C
926 IF(itask==0)THEN
927C
928 CALL sms_rbe_corr(
929 1 irbe2 ,lrbe2 ,p_sms ,y_sms ,ms ,
930 1 skew ,weight ,iad_rbe2,fr_rbe2m,nmrbe2)
931C
932 CALL sms_rbe_cnds(
933 1 irbe2 ,lrbe2 ,x ,y_sms ,am ,
934 1 ms ,in ,skew ,weight ,iad_rbe2,
935 2 fr_rbe2m,nmrbe2)
936C
937 END IF
938C
939 END IF
940C-----------------------------------
941C RBE3
942C-----------------------------------
943 IF (nrbe3>0)THEN
944C
945 CALL my_barrier
946C
947 IF(itask==0)THEN
948 CALL sms_rbe3t1(
949 1 irbe3 ,lrbe3 ,x ,y_sms ,frbe3 ,
950 2 skew ,weight ,iad_rbe3m,fr_rbe3m,fr_rbe3mp,
951 3 rrbe3 ,rrbe3_pon ,r3size)
952 END IF
953 END IF
954C-----------------------------------
955C remontee Yi => Ym
956C-----------------------------------
957 IF(nrbody/=0)THEN
958C
959 CALL my_barrier()
960C
961!$OMP DO SCHEDULE(DYNAMIC,1)
962 DO m =1,nrbody
963 DO k = 1, 6
964 rby6(1,k,m) = zero
965 rby6(2,k,m) = zero
966 rby6(3,k,m) = zero
967 END DO
968C
969 msr=npby(1,m)
970 IF(msr < 0) cycle
971C
972 IF(tagmsr_rby_sms(msr) /= 0) THEN
973 rby6(1,1,m)=y_sms(1,msr)*weight(msr)
974 rby6(2,1,m)=y_sms(2,msr)*weight(msr)
975 rby6(3,1,m)=y_sms(3,msr)*weight(msr)
976 END IF
977C
978 END DO
979!$OMP END DO
980
981!$OMP SINGLE
982 DO n=1,nindx1_sms
983 i=indx1_sms(n)
984 m=tagslv_rby_sms(i)
985 IF(m /= 0 )THEN
986 IF(weight(i) /= 0)THEN
987 rby6(1,1,m)=rby6(1,1,m)+y_sms(1,i)
988 rby6(2,1,m)=rby6(2,1,m)+y_sms(2,i)
989 rby6(3,1,m)=rby6(3,1,m)+y_sms(3,i)
990 END IF
991 y_sms(1,i)=zero
992 y_sms(2,i)=zero
993 y_sms(3,i)=zero
994 END IF
995 END DO
996!$OMP END SINGLE
997
998 IF (nspmd > 1) THEN
999!$OMP SINGLE
1000 nrbdim=3
1001 CALL spmd_exch_a_rb6(
1002 1 nrbdim,iad_rby,fr_rby6,iad_rby(nspmd+1),rby6)
1003!$OMP END SINGLE
1004 END IF
1005
1006!$OMP DO SCHEDULE(DYNAMIC,1)
1007 DO m =1,nrbody
1008 msr=npby(1,m)
1009 IF(msr < 0) cycle
1010
1011 IF(tagmsr_rby_sms(msr) /= 0) THEN
1012 y_sms(1,msr)=rby6(1,1,m)
1013 y_sms(2,msr)=rby6(2,1,m)
1014 y_sms(3,msr)=rby6(3,1,m)
1015 END IF
1016
1017 END DO
1018!$OMP END DO
1019 END IF
1020C-----------------------------------
1021 CALL sms_bcs(nodft1_sms,nodlt1_sms,indx1_sms,icodt ,iskew ,
1022 2 skew ,y_sms ,nodlt1_sms )
1023C-----------------------------------
1024 IF (nbcscyc>0) CALL sms_bcscyc(ibcscyc,lbcscyc,skew,x,y_sms)
1025C-----------------------------------
1026C LIENS RIGIDES ENTRE NOEUDS : REMONTEE
1027C---- // ----------------------------
1028 IF(nrlink+nlink+njoint > 0)THEN
1029C
1030 CALL my_barrier
1031C
1032 idown=0
1033 IF(nrlink>0)CALL sms_rlink10(
1034 1 ms ,y_sms ,ilink ,llink,skew,
1035 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
1036 3 itab ,frl )
1037C
1038 IF(nlink>0) CALL sms_rlink11(
1039 1 ms ,y_sms ,nnlink,lnlink,skew ,
1040 2 fr_ll ,weight,fnl6 ,x ,xframe,
1041 3 v ,idown ,tag_lnk_sms,itab,fnl)
1042C
1043 IF(njoint > 0)
1044 . CALL sms_cjoint_1(y_sms ,diag_sms,ljoint,iadcj,fr_cj,
1045 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
1046 END IF
1047C
1048 IF(nrwall > 0)THEN
1049C
1050 CALL my_barrier
1051C
1052C project y_sms
1053 iflag=2
1054 CALL sms_rgwal_0(iflag ,x ,v ,rwbuf ,lprw ,
1055 2 nprw ,ms ,fsav(1,ninter+1),fr_wall ,fopt ,
1056 3 rwsav ,weight ,irwl_work ,nrwl_sms,frwl6,
1057 4 rbid ,y_sms ,rbid ,rbid ,wfext )
1058 END IF
1059C
1060 CALL my_barrier
1061C
1062C-----------------------------------
1063 DO n=nodft1_sms,nodlt1_sms,mvsiz
1064C
1065 llt=min(nodlt1_sms-n+1,mvsiz)
1066C
1067 DO l=1,llt
1068 i=indx1_sms(n+l-1)
1069 s(l) = (p_sms(1,i)*y_sms(1,i)
1070 . + p_sms(2,i)*y_sms(2,i)
1071 . + p_sms(3,i)*y_sms(3,i))*weight(i)
1072 ENDDO
1073C
1074 IF(iparit==0)THEN
1075 st = zero
1076 DO l=1,llt
1077 st=st+s(l)
1078 END DO
1079#include "lockon.inc"
1080 s_sms=s_sms+st
1081#include "lockoff.inc"
1082 ELSE
1083 DO k=1,6
1084 s6t(k) = zero
1085 ENDDO
1086 IF(imonm>0.AND.itask==0)CALL startime(timers,62)
1087 CALL sum_6_float(1,llt,s,s6t,1)
1088 IF(imonm>0.AND.itask==0)CALL stoptime(timers,62)
1089#include "lockon.inc"
1090 DO k=1,6
1091 s6sms(k)=s6sms(k)+s6t(k)
1092 ENDDO
1093#include "lockoff.inc"
1094 END IF
1095 ENDDO
1096C-----------------------------------
1097C
1098 CALL my_barrier
1099C
1100 IF(nspmd <= 1)THEN
1101 IF(iparit/=0.AND.itask==0)THEN
1102 s_sms=s6sms(1)+s6sms(2)+s6sms(3)+
1103 . s6sms(4)+s6sms(5)+s6sms(6)
1104 END IF
1105 ELSEIF(itask==0)THEN ! communication sur un seul thread
1106 IF(iparit==0)THEN
1107 IF(imonm>0.AND.itask==0)CALL startime(timers,63)
1108 CALL spmd_glob_dsum9(s_sms,1)
1109 CALL spmd_rbcast(s_sms,s_sms,1,1,0,2)
1110 IF(imonm>0.AND.itask==0)CALL stoptime(timers,63)
1111 ELSE
1112 IF(imonm>0.AND.itask==0)CALL startime(timers,63)
1113 DO k=1,6
1114 dbuf(k) =s6sms(k)
1115 END DO
1116 CALL spmd_glob_dpsum9(dbuf,6)
1117 s_sms = dbuf(1)+dbuf(2)+dbuf(3)+
1118 . dbuf(4)+dbuf(5)+dbuf(6)
1119 CALL spmd_rbcast(s_sms,s_sms,1,1,0,2)
1120 IF(imonm>0.AND.itask==0)CALL stoptime(timers,63)
1121 END IF
1122 END IF
1123C
1124 CALL my_barrier
1125C
1126 alpha=g0_sms/max(em30,s_sms)
1127c print *,'alpha',it,alpha,g0_sms,s_sms
1128C
1129 DO n=nodft1_sms,nodlt1_sms
1130 i=indx1_sms(n)
1131 x_sms(1,i) = x_sms(1,i) + alpha*p_sms(1,i)
1132 x_sms(2,i) = x_sms(2,i) + alpha*p_sms(2,i)
1133 x_sms(3,i) = x_sms(3,i) + alpha*p_sms(3,i)
1134 res_sms(1,i) = res_sms(1,i) - alpha*y_sms(1,i)
1135 res_sms(2,i) = res_sms(2,i) - alpha*y_sms(2,i)
1136 res_sms(3,i) = res_sms(3,i) - alpha*y_sms(3,i)
1137 ENDDO
1138C-----------------------------------
1139 IF(nfxvel > 0)THEN
1140C
1141 CALL my_barrier
1142C
1143 IF(itask==0)
1144 . CALL sms_fixvel(ibfv ,res_sms ,v ,npc ,tf ,
1145 2 vel ,diag_sms,x ,skew ,sensor_tab,
1146 3 weight ,d ,iframe,xframe ,nsensor ,
1147 4 it+1 ,diag_sms,nodnx_sms,cptreac,nodreac,
1148 5 fthreac,am ,vr ,dr ,in ,
1149 6 rby ,wfext)
1150C
1151 CALL my_barrier
1152C
1153 END IF
1154C-----------------------------------
1155 DO n=nodft1_sms,nodlt1_sms
1156 i=indx1_sms(n)
1157 z_sms(1,i) = res_sms(1,i) *prec_sms(i)
1158 z_sms(2,i) = res_sms(2,i) *prec_sms(i)
1159 z_sms(3,i) = res_sms(3,i) *prec_sms(i)
1160 END DO
1161C-----------------------------------
1162C RBE3
1163C-----------------------------------
1164 IF (nrbe3>0)THEN
1165C
1166 CALL my_barrier
1167C
1168 IF(itask==0)THEN
1169 CALL sms_rbe3t2(irbe3 ,lrbe3 ,x ,z_sms ,frbe3 ,
1170 2 skew ,res_sms ,prec_sms3 )
1171 END IF
1172 END IF
1173C-----------------------------------
1174C RBE2
1175C-----------------------------------
1176 IF (nrbe2>0) THEN
1177C
1178 CALL my_barrier
1179C
1180 IF(itask==0)THEN
1181 CALL sms_rbe_accl(
1182 1 irbe2 ,lrbe2 ,res_sms,z_sms ,prec_sms3,
1183 1 skew ,weight ,iad_rbe2 ,fr_rbe2m,nmrbe2)
1184 END IF
1185C
1186 END IF
1187C-----------------------------------
1188C LIENS RIGIDES ENTRE NOEUDS : PROJETTE
1189C---- // ----------------------------
1190 IF(nrlink+nlink+njoint+nadmesh > 0)THEN
1191C
1192 CALL my_barrier
1193C
1194 idown=1
1195 IF(nrlink>0)CALL sms_rlink10(
1196 1 ms ,z_sms ,ilink ,llink,skew,
1197 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
1198 3 itab ,frl )
1199C
1200 IF(nlink>0) CALL sms_rlink11(
1201 1 ms ,z_sms ,nnlink,lnlink,skew ,
1202 2 fr_ll ,weight,fnl6 ,x ,xframe,
1203 3 v ,idown ,tag_lnk_sms,itab,fnl)
1204C
1205 IF(njoint > 0)
1206 . CALL sms_cjoint_1(z_sms ,diag_sms,ljoint,iadcj,fr_cj,
1207 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
1208C
1209 IF(nadmesh/=0)THEN
1210 CALL sms_admesh_2(z_sms, diag_sms, ixc, ixtg,sh4tree ,
1211 . sh3tree ,itask)
1212 END IF
1213C
1214 CALL my_barrier
1215C
1216 END IF
1217C-----------------------------------
1218 DO n=nodft1_sms,nodlt1_sms,mvsiz
1219C
1220 llt=min(nodlt1_sms-n+1,mvsiz)
1221C
1222 DO l=1,llt
1223 i=indx1_sms(n+l-1)
1224 r2(l) = ( res_sms(1,i)*res_sms(1,i)
1225 . + res_sms(2,i)*res_sms(2,i)
1226 . + res_sms(3,i)*res_sms(3,i))
1227 . * weight(i)
1228 g(l) = ( z_sms(1,i)*res_sms(1,i)
1229 . + z_sms(2,i)*res_sms(2,i)
1230 . + z_sms(3,i)*res_sms(3,i))
1231 . * weight(i)
1232 ENDDO
1233C
1234 IF(iparit==0)THEN
1235 r2t = zero
1236 g1t = zero
1237 DO l=1,llt
1238 r2t = r2t + r2(l)
1239 g1t = g1t + g(l)
1240 ENDDO
1241#include "lockon.inc"
1242 res1_sms= res1_sms+ r2t
1243 g1_sms = g1_sms + g1t
1244#include "lockoff.inc"
1245 ELSE
1246 DO k=1,6
1247 r6t(k) = zero
1248 g6t(k) = zero
1249 ENDDO
1250 IF(imonm>0.AND.itask==0)CALL startime(timers,62)
1251 CALL sum_6_float(1,llt,r2,r6t,1)
1252 CALL sum_6_float(1,llt,g,g6t,1)
1253 IF(imonm>0.AND.itask==0)CALL stoptime(timers,62)
1254#include "lockon.inc"
1255 DO k=1,6
1256 r6sms(k)=r6sms(k)+r6t(k)
1257 g6sms(k)=g6sms(k)+g6t(k)
1258 ENDDO
1259#include "lockoff.inc"
1260 END IF
1261 ENDDO
1262C-----------------------------------
1263C
1264 CALL my_barrier
1265C
1266 IF(nspmd <= 1)THEN
1267 IF(iparit/=0.AND.itask==0)THEN
1268 res1_sms=r6sms(1)+r6sms(2)+r6sms(3)+
1269 . r6sms(4)+r6sms(5)+r6sms(6)
1270 g1_sms =g6sms(1)+g6sms(2)+g6sms(3)+
1271 . g6sms(4)+g6sms(5)+g6sms(6)
1272 END IF
1273 ELSEIF(itask==0)THEN ! communication sur un seul thread
1274 IF(iparit==0)THEN
1275 IF(imonm>0) CALL startime(timers,63)
1276 rbuf(1)=res1_sms
1277 rbuf(2)=g1_sms
1278 CALL spmd_glob_dsum9(rbuf,2)
1279 CALL spmd_rbcast(rbuf,rbuf,2,1,0,2)
1280 res1_sms =rbuf(1)
1281 g1_sms =rbuf(2)
1282 IF(imonm>0) CALL stoptime(timers,63)
1283 ELSE
1284 IF(imonm>0) CALL startime(timers,63)
1285 DO k=1,6
1286 dbuf(k) =r6sms(k)
1287 dbuf(k+6)=g6sms(k)
1288 END DO
1289 CALL spmd_glob_dpsum9(dbuf,12)
1290 rbuf(1) = dbuf(1)+dbuf(2)+dbuf(3)+
1291 . dbuf(4)+dbuf(5)+dbuf(6)
1292 rbuf(2) = dbuf(7) +dbuf(8) +dbuf(9)+
1293 . dbuf(10)+dbuf(11)+dbuf(12)
1294 CALL spmd_rbcast(rbuf,rbuf,2,1,0,2)
1295 res1_sms=rbuf(1)
1296 g1_sms =rbuf(2)
1297 IF(imonm>0) CALL stoptime(timers,63)
1298 END IF
1299 END IF
1300C
1301 CALL my_barrier
1302C
1303
1304 if(ncpria > 0) then
1305 if(itask==0.and.ispmd==0
1306 . .and.(ncprisms < 0 .and.
1307 . mod(ncycle,ncpria)==0))then
1308 write(iout,1002) ncycle,totit,res1_sms,toln
1309 end if
1310 endif
1311C
1312 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
1313 IF(it>=nlim.OR.res1_sms<=toln) GO TO 200
1314 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
1315
1316 beta=g1_sms/max(em30,g0_sms)
1317C
1318 CALL my_barrier
1319C
1320!$OMP SINGLE
1321 g0_sms = g1_sms
1322!$OMP END SINGLE
1323
1324 DO n=nodft1_sms,nodlt1_sms
1325 i=indx1_sms(n)
1326 p_sms(1,i) = z_sms(1,i) + beta*p_sms(1,i)
1327 p_sms(2,i) = z_sms(2,i) + beta*p_sms(2,i)
1328 p_sms(3,i) = z_sms(3,i) + beta*p_sms(3,i)
1329 ENDDO
1330C-----------------------------------
1331C redescente Pm => Pi
1332C-----------------------------------
1333 IF(nrbody/=0)THEN
1334C
1335 CALL my_barrier()
1336C
1337 DO n=nodft1_sms,nodlt1_sms
1338 i=indx1_sms(n)
1339 m=tagslv_rby_sms(i)
1340 IF(m /= 0)THEN
1341 msr=npby(1,m)
1342 p_sms(1,i)=p_sms(1,msr)
1343 p_sms(2,i)=p_sms(2,msr)
1344 p_sms(3,i)=p_sms(3,msr)
1345 END IF
1346 END DO
1347C
1348 CALL my_barrier()
1349C
1350 END IF
1351C-----------------------------------
1352C
1353 CALL my_barrier
1354C
1355 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
1356 GO TO 100
1357 200 CONTINUE
1358c if(itask==0.and.ispmd==0)then
1359c . .and.mod(ncycle,npri_sms)==0)then
1360c print *,ncycle,'nit=',it,nlim,res1_sms,toln
1361c end if
1362
1363 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
1364 IF(it>=nlim)THEN
1365 mstop = 2
1366 IF(ispmd==0.AND.itask==0)THEN
1367#include "lockon.inc"
1368 WRITE(istdo,*)
1369 . ' ** ERROR : AMS IS LIKELY DIVERGING '
1370 WRITE(iout,1100) nlim,ncycle
1371#include "lockoff.inc"
1372 ENDIF
1373C
1374 IF(idtmins/=0)THEN
1375C
1376 CALL my_barrier
1377C
1378 CALL sms_check(timers, nodft ,nodlt ,iadk ,jdik ,diag_sms,
1379 2 lt_k ,jadi_sms ,jdii_sms ,lti_sms ,itask ,
1380 3 itab ,iad_elem ,fr_elem ,fr_sms ,fr_rms ,
1381 4 list_sms,list_rms,ams_work)
1382C
1383 END IF
1384C
1385 GO TO 300
1386 ENDIF
1387C-----------------------------------
1388C Reaction force and work
1389C-----------------------------------
1390 IF(nrwall/=0)THEN
1391C
1392 CALL my_barrier
1393C
1394 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
1395 CALL sms_mav_lt( timers,
1396 1 nodft ,nodlt ,numnod ,iadk ,jdik ,
1397 2 itask ,diag_sms,lt_k ,x_sms ,z_sms ,
1398 3 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
1399 4 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
1400 5 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
1401 6 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
1402 7 mv6 ,mw6 ,nodft2_sms,nodlt2_sms,indx2_sms,
1403 8 nodii_sms )
1404C
1405 IF(imonm>0.AND.itask==0)CALL startime(timers,61)
1406C
1407 CALL my_barrier
1408C
1409 IF(nadmesh/=0)THEN
1410 IF(itask==0)THEN
1411 CALL sms_admesh_1(z_sms, diag_sms, ixc, ixtg,sh4tree ,
1412 . sh3tree ,nodnx_sms)
1413 END IF
1414C
1415 CALL my_barrier
1416C
1417 END IF
1418C-----------------------------------
1419C RBE2
1420C-----------------------------------
1421 IF (nrbe2>0.OR.r2size>0) THEN
1422C
1423 CALL my_barrier
1424C
1425 IF(itask==0)THEN
1426C
1427 CALL sms_rbe_corr(
1428 1 irbe2 ,lrbe2 ,x_sms ,z_sms ,ms ,
1429 1 skew ,weight ,iad_rbe2,fr_rbe2m,nmrbe2)
1430C
1431 CALL sms_rbe_cnds(
1432 1 irbe2 ,lrbe2 ,x ,z_sms ,am ,
1433 1 ms ,in ,skew ,weight ,iad_rbe2,
1434 2 fr_rbe2m,nmrbe2)
1435C
1436 END IF
1437C
1438 END IF
1439C-----------------------------------
1440C RBE3
1441C-----------------------------------
1442 IF (nrbe3>0)THEN
1443C
1444 CALL my_barrier
1445C
1446 IF(itask==0)THEN
1447 CALL sms_rbe3t1(
1448 1 irbe3 ,lrbe3 ,x ,z_sms ,frbe3 ,
1449 2 skew ,weight ,iad_rbe3m,fr_rbe3m,fr_rbe3mp,
1450 3 rrbe3 ,rrbe3_pon ,r3size)
1451 END IF
1452 END IF
1453C-----------------------------------
1454 IF(nrbody/=0)THEN
1455C
1456 CALL my_barrier()
1457C
1458!$OMP DO SCHEDULE(DYNAMIC,1)
1459 DO m =1,nrbody
1460 DO k = 1, 6
1461 rby6(1,k,m) = zero
1462 rby6(2,k,m) = zero
1463 rby6(3,k,m) = zero
1464 END DO
1465C
1466 msr=npby(1,m)
1467 IF(msr < 0) cycle
1468C
1469 IF(tagmsr_rby_sms(msr) /= 0) THEN
1470 rby6(1,1,m)=z_sms(1,msr)*weight(msr)
1471 rby6(2,1,m)=z_sms(2,msr)*weight(msr)
1472 rby6(3,1,m)=z_sms(3,msr)*weight(msr)
1473 END IF
1474C
1475 END DO
1476!$OMP END DO
1477
1478!$OMP SINGLE
1479 DO n=1,nindx1_sms
1480 i=indx1_sms(n)
1481 m=tagslv_rby_sms(i)
1482 IF(m /= 0 )THEN
1483 IF(weight(i) /= 0)THEN
1484 rby6(1,1,m)=rby6(1,1,m)+z_sms(1,i)
1485 rby6(2,1,m)=rby6(2,1,m)+z_sms(2,i)
1486 rby6(3,1,m)=rby6(3,1,m)+z_sms(3,i)
1487 END IF
1488 END IF
1489 END DO
1490!$OMP END SINGLE
1491
1492 IF (nspmd > 1) THEN
1493!$OMP SINGLE
1494 nrbdim=3
1495 CALL spmd_exch_a_rb6(
1496 1 nrbdim,iad_rby,fr_rby6,iad_rby(nspmd+1),rby6)
1497!$omp END single
1498 END IF
1499
1500!$OMP DO SCHEDULE(DYNAMIC,1)
1501 DO m =1,nrbody
1502 msr=npby(1,m)
1503 IF(msr < 0) cycle
1504 IF(tagmsr_rby_sms(msr) /= 0) THEN
1505 z_sms(1,msr)=rby6(1,1,m)
1506 z_sms(2,msr)=rby6(2,1,m)
1507 z_sms(3,msr)=rby6(3,1,m)
1508 END IF
1509 END DO
1510!$OMP END DO
1511 END IF
1512C
1513 CALL my_barrier
1514C
1515 CALL sms_bcs(nodft1_sms,nodlt1_sms,indx1_sms,icodt ,iskew ,
1516 2 skew ,z_sms ,nodlt1_sms )
1517C-----------------------------------
1518C /BCS/CYCLIC
1519C-----------------------------------
1520 IF (nbcscyc>0) CALL sms_bcscyc(ibcscyc,lbcscyc,skew,x,z_sms)
1521C-----------------------------------
1522C LIENS RIGIDES ENTRE NOEUDS : REMONTEE
1523C---- // ----------------------------
1524 IF(nrlink+nlink+njoint > 0)THEN
1525C
1526 CALL my_barrier
1527C
1528 idown=0
1529 IF(nrlink>0)CALL sms_rlink10(
1530 1 ms ,z_sms ,ilink ,llink,skew,
1531 2 fr_rl ,weight,frl6 ,idown,tag_lnk_sms,
1532 3 itab ,frl )
1533C
1534 IF(nlink>0) CALL sms_rlink11(
1535 1 ms ,z_sms ,nnlink,lnlink,skew ,
1536 2 fr_ll ,weight,fnl6 ,x ,xframe,
1537 3 v ,idown ,tag_lnk_sms,itab,fnl)
1538C
1539 IF(njoint > 0)
1540 . CALL sms_cjoint_1(z_sms ,diag_sms,ljoint,iadcj,fr_cj,
1541 . cjwork,idown ,tag_lnk_sms(nrlink+nlink+1),itask)
1542 END IF
1543C
1544 CALL my_barrier
1545C
1546 IF(ifricw/=0.AND.iact==0)THEN
1547C
1548 iact=iact+1
1549C
1550 DO n=nodft1_sms,nodlt1_sms
1551 i=indx1_sms(n)
1552C
1553 res_sms(1,i) = r(1,i)-z_sms(1,i)
1554 res_sms(2,i) = r(2,i)-z_sms(2,i)
1555 res_sms(3,i) = r(3,i)-z_sms(3,i)
1556 ENDDO
1557C--------
1558 IF(nrbody/=0)THEN
1559C
1560 CALL my_barrier()
1561C
1562 DO n=nodft1_sms,nodlt1_sms
1563 i=indx1_sms(n)
1564 m=tagslv_rby_sms(i)
1565 IF(m /= 0)THEN
1566 res_sms(1,i)=zero
1567 res_sms(2,i)=zero
1568 res_sms(3,i)=zero
1569 END IF
1570 END DO
1571 END IF
1572C
1573 CALL my_barrier
1574C
1575C store Ft
1576 iflag=3
1577 CALL sms_rgwal_0(iflag ,x ,v ,rwbuf ,lprw ,
1578 2 nprw ,ms ,fsav(1,ninter+1),fr_wall ,fopt ,
1579 3 rwsav ,weight ,irwl_work ,nrwl_sms,frwl6,
1580 4 x_sms ,res_sms,r ,frea ,wfext)
1581 it =0
1582 GO TO 10
1583 ELSE
1584C
1585 DO n=nodft1_sms,nodlt1_sms
1586 i=indx1_sms(n)
1587C
1588C retrieve Frea == 0 or Ft if sliding
1589 frea(1,i) = frea(1,i)+r(1,i)-z_sms(1,i)
1590 frea(2,i) = frea(2,i)+r(2,i)-z_sms(2,i)
1591 frea(3,i) = frea(3,i)+r(3,i)-z_sms(3,i)
1592 ENDDO
1593C
1594 CALL my_barrier
1595C
1596C--------
1597 IF(nrbody/=0)THEN
1598C
1599 CALL my_barrier()
1600C
1601 DO n=nodft1_sms,nodlt1_sms
1602 i=indx1_sms(n)
1603 m=tagslv_rby_sms(i)
1604 IF(m /= 0)THEN
1605 frea(1,i)=zero
1606 frea(2,i)=zero
1607 frea(3,i)=zero
1608 END IF
1609 END DO
1610C
1611 CALL my_barrier()
1612C
1613 END IF
1614C
1615 iflag=4
1616 CALL sms_rgwal_0(iflag ,x ,v ,rwbuf ,lprw ,
1617 2 nprw ,ms ,fsav(1,ninter+1),fr_wall ,fopt ,
1618 3 rwsav ,weight ,irwl_work ,nrwl_sms,frwl6,
1619 4 x_sms ,res_sms,r ,frea ,wfext)
1620C
1621 CALL my_barrier
1622C
1623 END IF
1624 END IF
1625C
1626C-------X->R--------
1627 300 CONTINUE
1628 DO n=nodft1_sms,nodlt1_sms
1629 i=indx1_sms(n)
1630 r(1,i) = x_sms(1,i)
1631 r(2,i) = x_sms(2,i)
1632 r(3,i) = x_sms(3,i)
1633 ENDDO
1634 IF(imonm>0.AND.itask==0)CALL stoptime(timers,61)
1635C--------PCG (PROJECTION)
1636 IF (m_vs_sms > 0 .AND. it > 0) THEN
1637 IF(imonm>0.AND.itask==0)CALL startime(timers,70)
1638 CALL sms_updst(
1639 1 iadk ,jdik ,diag_sms,lt_k ,itask ,
1640 2 nodft1_sms,nodlt1_sms,indx1_sms,nodnx_sms,iad_elem ,
1641 3 fr_elem ,weight ,jadi_sms ,jdii_sms ,lti_sms ,
1642 4 iskyi_sms ,mskyi_sms ,fr_sms ,fr_rms ,list_sms ,
1643 5 list_rms ,mskyi_fi_sms ,vfi ,imv ,mv ,
1644 6 mv6 ,mw6 ,ms ,x_sms ,p_sms ,
1645 7 y_sms ,nodft ,nodlt ,kinet )
1646C----------------------
1647 CALL my_barrier
1648C----------------------
1649 IF (itask == 0) ncg_run_sms = ncg_run_sms + 1
1650 IF(imonm>0.AND.itask==0)CALL stoptime(timers,70)
1651 END IF
1652C
1653 if(ncpria > 0) then
1654 if(itask==0.and.ispmd==0
1655 . .and.(ncprisms/=0.and.mod(ncycle,ncpria)==0))then
1656 IF(totit==0)THEN
1657 write(iout,1000) ncycle,totit
1658 ELSE
1659 write(iout,1001) ncycle,totit,res1_sms,toln
1660 END IF
1661 end if
1662 endif
1663C--------------------------------------------
1664 1000 FORMAT(3x,'CYCLE NUMBER',i5,
1665 . ' TOTAL C.G. ITERATION NUMBER=',i5)
1666 1001 FORMAT(3x,'CYCLE NUMBER',i5,
1667 . ' TOTAL C.G. ITERATION NUMBER=',i5,
1668 . ' RELATIVE RESIDUAL NORM=',e11.4,
1669 . ' REFERENCE RESIDUAL NORM',e11.4)
1670 1002 FORMAT(3x,'CYCLE NUMBER',i5,
1671 . ' ITERATION NUMBER=',i5,
1672 . ' RELATIVE RESIDUAL NORM=',e11.4,
1673 . ' REFERENCE RESIDUAL NORM',e11.4)
1674 1100 FORMAT(
1675 . ' ** ERROR : AMS IS LIKELY DIVERGING:',/,
1676 . ' TOTAL C.G. ITERATION NUMBER = ',i8,' AT CYCLE NUMBER ',i8)
1677 RETURN
alpha
#define alpha
Definition eval.h:35
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
intstamp_mod
Definition intstamp_mod.F:38
sms_pcg_proj
Definition sms_mod.F:72
sum_6_float
subroutine sum_6_float(jft, jlt, f, f6, n)
Definition parit.F:64
sms_admesh_1
subroutine sms_admesh_1(a, diag_sms, ixc, ixtg, sh4tree, sh3tree, nodnx_sms)
Definition sms_admesh.F:182
sms_admesh_2
subroutine sms_admesh_2(a, diag_sms, ixc, ixtg, sh4tree, sh3tree, itask)
Definition sms_admesh.F:346
sms_bcs
subroutine sms_bcs(nodft, nodlt, indx1, icodt, iskew, skew, a, nodlast)
Definition sms_bcs.F:34
sms_bcscyc
subroutine sms_bcscyc(ibcscyc, lbcscyc, skew, x, a)
Definition sms_bcscyc.F:33
sms_cjoint_1
subroutine sms_cjoint_1(a, ms, ljoint, iadcj, fr_cj, cjwork, idown, tag_lnk_sms, itask)
Definition sms_cjoint.F:108
sms_fixvel
subroutine sms_fixvel(ibfv, a, v, npc, tf, vel, ms, x, skew, sensor_tab, weight, d, iframe, xframe, nsensor, it, diag_sms, nodnx_sms, cptreac, nodreac, fthreac, ar, vr, dr, in, rby, wfext)
Definition sms_fixvel.F:40
sms_check
subroutine sms_check(timers, nodft, nodlt, iadk, jdik, diag_k, lt_k, iadi, jdii, lt_i, itask, itab, iad_elem, fr_elem, fr_sms, fr_rms, list_sms, list_rms, ams_work)
Definition sms_fsa_inv.F:48
sms_mav_lt
subroutine sms_mav_lt(timers, nodft, nodlt, numnod, iadl, jdil, itask, diag_k, lt_k, v, w, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, nodft2_sms, nodlt2_sms, indx2_sms, nodii_sms)
Definition sms_pcg.F:1706
sms_inist
subroutine sms_inist(timers, iadk, jdik, diag_k, lt_k, itask, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, ms, nodft, nodlt)
Definition sms_proj.F:45
sms_inisi
subroutine sms_inisi(iadk, jdik, diag_k, lt_k, itask, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, ms, nodft, nodlt, prec_sms, kinet)
Definition sms_proj.F:507
sms_pro_p
subroutine sms_pro_p(timers, nodft, nodlt, numnod, p, weight, itask, pj, diag_sms)
Definition sms_proj.F:302
sms_updst
subroutine sms_updst(iadk, jdik, diag_k, lt_k, itask, nodft1_sms, nodlt1_sms, indx1_sms, nodnx_sms, iad_elem, fr_elem, weight, jadi_sms, jdii_sms, lti_sms, iskyi_sms, mskyi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, vfi, imv, mv, mv6, mw6, ms, u, p, y, nodft, nodlt, kinet)
Definition sms_proj.F:416
sms_inix
subroutine sms_inix(timers, nodft, nodlt, numnod, x, r, weight, itask, diag_sms)
Definition sms_proj.F:184
sms_rbe_cnds
subroutine sms_rbe_cnds(irbe2, lrbe2, x, a, ar, ms, in, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:274
sms_rbe_accl
subroutine sms_rbe_accl(irbe2, lrbe2, r, a, prec_sms3, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:367
sms_rbe_prec
subroutine sms_rbe_prec(irbe2, lrbe2, diag_sms, ms, diag_sms3, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:470
sms_rbe_corr
subroutine sms_rbe_corr(irbe2, lrbe2, v, w, ms, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:418
sms_rbe3t2
subroutine sms_rbe3t2(irbe3, lrbe3, x, a, frbe3, skew, r, prec_sms3)
Definition sms_rbe3.F:254
sms_rbe3_prec
subroutine sms_rbe3_prec(irbe3, lrbe3, x, diag_sms, diag_sms3, frbe3, skew, weight, iad_m, fr_m, fr_mpon, rsum, rsum_pon, r3size)
Definition sms_rbe3.F:349
sms_rbe3t1
subroutine sms_rbe3t1(irbe3, lrbe3, x, a, frbe3, skew, weight, iad_m, fr_m, fr_mpon, rsum, rsum_pon, r3size)
Definition sms_rbe3.F:143
sms_rgwal_0
subroutine sms_rgwal_0(iflag, x, v, rwbuf, lprw, nprw, ms, fsav, fr_wall, fopt, rwsav, weight, irwl_work, nrwl_sms, frwl6, a, res, r, frea, wfext)
Definition sms_rgwal0.F:57
sms_rlink11
subroutine sms_rlink11(ms, a, nnlink, lllink, skew, fr_ll, weight, frl6, x, xframe, v, idown, tag_lnk_sms, itab, frl)
Definition sms_rlink.F:157
sms_rlink10
subroutine sms_rlink10(ms, a, nlink, llink, skew, fr_rl, weight, frl6, idown, tag_lnk_sms, itab, frl)
Definition sms_rlink.F:36
spmd_exch_a_rb6
subroutine spmd_exch_a_rb6(nrbdim, iad_rby, fr_rby6, icsize, rbf6)
Definition spmd_exch_a_rb6.F:37
spmd_rbcast
subroutine spmd_rbcast(tabi, tabr, n1, n2, from, add)
Definition spmd_rbcast.F:62
spmd_glob_dsum9
subroutine spmd_glob_dsum9(v, len)
Definition spmd_th.F:380
spmd_glob_dpsum9
subroutine spmd_glob_dpsum9(v, len)
Definition spmd_th.F:437