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 1700 of file sms_pcg.F.

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

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

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