OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rinit3.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "vect01_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "random_c.inc"
#include "scr12_c.inc"
#include "scr17_c.inc"
#include "userlib.inc"
#include "scr15_c.inc"
#include "kincod_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine rinit3 (elbuf_str, ixr, x, geo, xmas, npc, pld, xin, skew, dtelem, nel, stifn, stifr, partsav, v, ipart, itab, msr, inr, stifint, str, igeo, sigrs, nsigrs, imerge2, iadmerge2, msrt, ixr_kj, nom_opt, strr, ptspri, ipm, pm, uparam, r_skew, preload_a, ipreld, npreload_a, ikine)
subroutine rini3u (off, geo, x, x0, ix, skew, rloc, itab, uix, igeo)
subroutine rini1u (off, geo, x, x0, ix, skew, rloc, itab, uix, igeo)
subroutine rini2u (ixr, umass, uiner, partsav, x, v, ipart, msr, inr, msrt, ems)
subroutine r4ini (sigrs, ixr, nsigi, eint, f, dl, fep, dpl, dpl2, xl0, dfs, dv, igtyp, ptspri, dl0, f0)
subroutine r8ini (igtyp, nel, sigrs, ixr, nsigi, fx, fy, fz, mx, my, mz, fxep, fyep, fzep, xmep, ymep, zmep, dxpl, dypl, dzpl, rpx, rpy, rpz, dxpl2, dypl2, dzpl2, rpx2, rpy2, rpz2, dx, dy, dz, rx, ry, rz, xl0, yl0, zl0, eint, e6, ptspri, dx0, dy0, dz0, rx0, ry0, rz0, fx0, fy0, fz0, mx0, my0, mz0)
subroutine ruini (sigrs, nsigi, nuvar, fx, fy, fz, xmom, ymom, zmom, dx, dy, dz, rx, ry, rz, uvar, eint, ptspri)

Function/Subroutine Documentation

◆ r4ini()

subroutine r4ini ( sigrs,
integer, dimension(nixr,*) ixr,
integer nsigi,
eint,
f,
dl,
fep,
dpl,
dpl2,
xl0,
dfs,
dv,
integer igtyp,
integer, dimension(*) ptspri,
dl0,
f0 )

Definition at line 1940 of file rinit3.F.

1944C-----------------------------------------------
1945C I m p l i c i t T y p e s
1946C-----------------------------------------------
1947#include "implicit_f.inc"
1948C-----------------------------------------------
1949C C o m m o n B l o c k s
1950C-----------------------------------------------
1951#include "vect01_c.inc"
1952#include "com01_c.inc"
1953C-----------------------------------------------
1954C D u m m y A r g u m e n t s
1955C-----------------------------------------------
1956 INTEGER NSIGI,NUVAR,IGTYP
1957 INTEGER IXR(NIXR,*),PTSPRI(*)
1958C REAL
1959 my_real
1960 . f(*),eint(*),sigrs(nsigi,*),dpl(*),dpl2(*),dfs(*),
1961 . fep(*),dl(*),xl0(*),dv(*),dl0(*),f0(*)
1962C-----------------------------------------------
1963C L o c a l V a r i a b l e s
1964C-----------------------------------------------
1965 INTEGER I,II,JJ
1966C-----------------------------------------------------------------------
1967C---
1968C CONTRAINTES INITIALES + OTHERS
1969C---
1970 IF (inispri /= 0) THEN
1971 DO i=lft,llt
1972 ii = i+nft
1973! length recumputed in engine if not concerned by INISPRI
1974 xl0(i) = zero
1975!
1976 jj = ptspri(ii)
1977 IF( jj == 0) GOTO 200
1978C---
1979!! F(I) = SIGRS(2,JJ)
1980 f0(i) = sigrs(2,jj)
1981!! DL(I) = SIGRS(3,JJ)
1982 dl0(i) = sigrs(3,jj)
1983 fep(i) = sigrs(4,jj)
1984 IF (igtyp /= 26) THEN ! IGTYP = 4,12
1985 dpl(i) = sigrs(5,jj)
1986 dpl2(i) = sigrs(6,jj)
1987 ENDIF
1988 xl0(i) = sigrs(7,jj)
1989 eint(i) = sigrs(8,jj)
1990 IF (igtyp == 12) THEN
1991 dfs(i) = sigrs(9,jj)
1992 ELSEIF (igtyp == 26) THEN
1993 dv(i) = sigrs(9,jj)
1994 ENDIF
1995C---
1996 200 CONTINUE
1997 ENDDO ! DO I=LFT,LLT
1998 ENDIF ! IF (INISPRI /= 0)
1999C---
2000 RETURN
my_real
#define my_real
Definition cppsort.cpp:32

◆ r8ini()

subroutine r8ini ( integer igtyp,
integer nel,
sigrs,
integer, dimension(nixr,*) ixr,
integer nsigi,
fx,
fy,
fz,
mx,
my,
mz,
fxep,
fyep,
fzep,
xmep,
ymep,
zmep,
dxpl,
dypl,
dzpl,
rpx,
rpy,
rpz,
dxpl2,
dypl2,
dzpl2,
rpx2,
rpy2,
rpz2,
dx,
dy,
dz,
rx,
ry,
rz,
xl0,
yl0,
zl0,
eint,
e6,
integer, dimension(*) ptspri,
dx0,
dy0,
dz0,
rx0,
ry0,
rz0,
fx0,
fy0,
fz0,
mx0,
my0,
mz0 )

Definition at line 2007 of file rinit3.F.

2018C-----------------------------------------------
2019C I m p l i c i t T y p e s
2020C-----------------------------------------------
2021#include "implicit_f.inc"
2022C-----------------------------------------------
2023C C o m m o n B l o c k s
2024C-----------------------------------------------
2025#include "vect01_c.inc"
2026#include "com01_c.inc"
2027C-----------------------------------------------
2028C D u m m y A r g u m e n t s
2029C-----------------------------------------------
2030
2031 INTEGER IXR(NIXR,*),NSIGI,NUVAR,NEL,IGTYP,PTSPRI(*)
2032C REAL
2033 my_real
2034 . fx(*),fy(*),fz(*),eint(*),sigrs(nsigi,*),
2035 . mx(*),my(*),mz(*),dxpl(*),dypl(*),dzpl(*),
2036 . dxpl2(*),dzpl2(*),dypl2(*),fxep(*),fyep(*),fzep(*),
2037 . xmep(*),ymep(*),zmep(*),rpx(*),rpy(*),rpz(*),
2038 . rpx2(*),rpy2(*),rpz2(*),dx(*),dy(*),dz(*),rx(*),
2039 . ry(*),rz(*),xl0(*),yl0(*),zl0(*),e6(nel,6),
2040 . dx0(*),dy0(*),dz0(*),rx0(*),ry0(*),rz0(*),
2041 . fx0(*),fy0(*),fz0(*),mx0(*),my0(*),mz0(*)
2042C-----------------------------------------------
2043C L o c a l V a r i a b l e s
2044C-----------------------------------------------
2045 INTEGER I,II,JJ
2046C-----------------------------------------------------------------------
2047C---
2048C CONTRAINTES INITIALES + OTHERS
2049C---
2050 IF (inispri /= 0) THEN
2051 DO i=lft,llt
2052 ii = i+nft
2053! length recumputed in engine if not concerned by inispri
2054 xl0(i) = zero
2055 yl0(i) = zero
2056 zl0(i) = zero
2057!
2058 jj = ptspri(ii)
2059 IF (jj == 0) GOTO 200
2060C---
2061 fxep(i) = sigrs(4, jj)
2062 dxpl(i) = sigrs(5, jj)
2063 dxpl2(i) = sigrs(6, jj)
2064 fyep(i) = sigrs(9,jj)
2065 dypl(i) = sigrs(10,jj)
2066 dypl2(i) = sigrs(11,jj)
2067 fzep(i) = sigrs(14,jj)
2068 dzpl(i) = sigrs(15,jj)
2069 dzpl2(i) = sigrs(16,jj)
2070 xmep(i) = sigrs(19,jj)
2071 rpx(i) = sigrs(20,jj)
2072 rpx2(i) = sigrs(21,jj)
2073 ymep(i) = sigrs(24,jj)
2074 rpy(i) = sigrs(25,jj)
2075 rpy2(i) = sigrs(26,jj)
2076 zmep(i) = sigrs(29,jj)
2077 rpz(i) = sigrs(30,jj)
2078 rpz2(i) = sigrs(31,jj)
2079 xl0(i) = sigrs(32,jj)
2080 yl0(i) = sigrs(33,jj)
2081 zl0(i) = sigrs(34,jj)
2082 IF (igtyp == 8 .OR. igtyp == 13 .OR.
2083 . igtyp == 23 .OR. igtyp == 25) THEN
2084 dx0(i) = sigrs(3, jj)
2085 fx0(i) = sigrs(2, jj)
2086 dy0(i) = sigrs(8, jj)
2087 fy0(i) = sigrs(7, jj)
2088 dz0(i) = sigrs(13,jj)
2089 fz0(i) = sigrs(12,jj)
2090 rx0(i) = sigrs(18,jj)
2091 mx0(i) = sigrs(17,jj)
2092 ry0(i) = sigrs(23,jj)
2093 my0(i) = sigrs(22,jj)
2094 rz0(i) = sigrs(28,jj)
2095 mz0(i) = sigrs(27,jj)
2096!
2097 e6(i,1) = sigrs(36,jj)
2098 e6(i,2) = sigrs(37,jj)
2099 e6(i,3) = sigrs(38,jj)
2100 e6(i,4) = sigrs(39,jj)
2101 e6(i,5) = sigrs(40,jj)
2102 e6(i,6) = sigrs(41,jj)
2103 ENDIF
2104C---
2105 200 CONTINUE
2106 ENDDO ! DO I=LFT,LLT
2107 ENDIF ! IF (INISPRI /= 0)
2108C---
2109 RETURN

◆ rini1u()

subroutine rini1u ( off,
geo,
x,
x0,
integer, dimension(nixr,*) ix,
skew,
rloc,
integer, dimension(*) itab,
integer, dimension(4,mvsiz) uix,
integer, dimension(npropgi,*) igeo )

Definition at line 1763 of file rinit3.F.

1765C-----------------------------------------------
1766C I m p l i c i t T y p e s
1767C-----------------------------------------------
1768#include "implicit_f.inc"
1769C-----------------------------------------------
1770C G l o b a l P a r a m e t e r s
1771C-----------------------------------------------
1772#include "mvsiz_p.inc"
1773C-----------------------------------------------
1774C C o m m o n B l o c k s
1775C-----------------------------------------------
1776#include "vect01_c.inc"
1777#include "param_c.inc"
1778C-----------------------------------------------
1779C D u m m y A r g u m e n t s
1780C-----------------------------------------------
1781 INTEGER IX(NIXR,*),UIX(4,MVSIZ),ITAB(*), IGEO(NPROPGI,*)
1782C REAL
1783 my_real
1784 . off(*), geo(npropg,*), x(3,*), x0(*), skew(lskew,*)
1785C REAL
1786 my_real
1787 . rloc(3,*)
1788C-----------------------------------------------
1789C L o c a l V a r i a b l e s
1790C-----------------------------------------------
1791 INTEGER I, J, NG, I1, I2, I3, ISK
1792C REAL
1793 my_real
1794 . x1, y1, z1
1795C-----------------------------------------------
1796 DO i=lft,llt
1797 off(i) = one
1798 ENDDO
1799C
1800 DO i=lft,llt
1801 j=i+nft
1802 ng=ix(1,j)
1803 isk=igeo(2,ng)
1804 i1=ix(2,j)
1805 i2=ix(3,j)
1806 i3=ix(4,j)
1807 x1=x(1,i2)-x(1,i1)
1808 y1=x(2,i2)-x(2,i1)
1809 z1=x(3,i2)-x(3,i1)
1810 x0(i)=sqrt(x1**2+y1**2+z1**2)
1811 IF (x0(i) < em15) THEN
1812 rloc(1,i)= one
1813 rloc(2,i)= zero
1814 rloc(3,i)= zero
1815 ELSEIF (i3 /= 0) THEN
1816 rloc(1,i)=x(1,i3)-x(1,i1)
1817 rloc(2,i)=x(2,i3)-x(2,i1)
1818 rloc(3,i)=x(3,i3)-x(3,i1)
1819 ELSEIF( isk /= 1) THEN
1820 rloc(1,i)=skew(4,isk)
1821 rloc(2,i)=skew(5,isk)
1822 rloc(3,i)=skew(6,isk)
1823 ELSE
1824 IF (abs(y1) < half*x0(i)) THEN
1825 rloc(1,i)=zero
1826 rloc(2,i)=one
1827 rloc(3,i)=zero
1828 ELSE
1829 rloc(1,i)=one
1830 rloc(2,i)=zero
1831 rloc(3,i)=zero
1832 ENDIF
1833 ENDIF
1834 uix(1,i)=itab(i1)
1835 uix(2,i)=itab(i2)
1836 IF (i3 == 0) THEN
1837 uix(3,i)=0
1838 ELSE
1839 uix(3,i)=itab(i3)
1840 ENDIF
1841 uix(4,i)=ix(6,j)
1842 ENDDO
1843C-----------------------------------------------
1844 RETURN

◆ rini2u()

subroutine rini2u ( integer, dimension(nixr,*) ixr,
umass,
uiner,
partsav,
x,
v,
integer, dimension(*) ipart,
msr,
inr,
msrt,
ems )

Definition at line 1851 of file rinit3.F.

1854C----------------------------------------------
1855C INITIALISATION DES MASSES NODALES
1856C----------------------------------------------
1857C-----------------------------------------------
1858C I m p l i c i t T y p e s
1859C-----------------------------------------------
1860#include "implicit_f.inc"
1861C-----------------------------------------------
1862C C o m m o n B l o c k s
1863C-----------------------------------------------
1864#include "com01_c.inc"
1865#include "vect01_c.inc"
1866C-----------------------------------------------
1867C D u m m y A r g u m e n t s
1868C-----------------------------------------------
1869 INTEGER IXR(NIXR,*),IPART(*)
1870 my_real :: umass(*),uiner(*), x(3,*),v(3,*)
1871 my_real :: partsav(20,*), msr(3,*), inr(3,*), msrt(*),ems(*)
1872C-----------------------------------------------
1873C L o c a l V a r i a b l e s
1874C-----------------------------------------------
1875 INTEGER I, IP,I1,I2
1876 my_real :: xx,yy,zz,xy,yz,zx
1877 my_real :: xi
1878C---------------------------------------------------------------------
1879C----------------------------------------------
1880C MASSE ELEMENT /2
1881C----------------------------------------------
1882 DO i=lft,llt
1883 ems(i)=half*umass(i)
1884 ENDDO
1885C----------------------------------------------
1886C INITIALISATION DES MASSES NODALES
1887C----------------------------------------------
1888C traitement specifique spmd pour mass et iner parith/on
1889 DO i=lft,llt
1890 i1 = ixr(2,i+nft)
1891 i2 = ixr(3,i+nft)
1892C
1893 xi=half*uiner(i)
1894 msr(1,i)=ems(i)
1895 msr(2,i)=ems(i)
1896 msr(3,i)=ems(i)
1897 inr(1,i)=xi
1898 inr(2,i)=xi
1899 inr(3,i)=xi
1900C
1901 ip=ipart(i)
1902 partsav(1,ip)=partsav(1,ip) + two*ems(i)
1903 partsav(2,ip)=partsav(2,ip) + ems(i)*(x(1,i1)+x(1,i2))
1904 partsav(3,ip)=partsav(3,ip) + ems(i)*(x(2,i1)+x(2,i2))
1905 partsav(4,ip)=partsav(4,ip) + ems(i)*(x(3,i1)+x(3,i2))
1906 xx = (x(1,i1)*x(1,i1)+x(1,i2)*x(1,i2))
1907 xy = (x(1,i1)*x(2,i1)+x(1,i2)*x(2,i2))
1908 yy = (x(2,i1)*x(2,i1)+x(2,i2)*x(2,i2))
1909 yz = (x(2,i1)*x(3,i1)+x(2,i2)*x(3,i2))
1910 zz = (x(3,i1)*x(3,i1)+x(3,i2)*x(3,i2))
1911 zx = (x(3,i1)*x(1,i1)+x(3,i2)*x(1,i2))
1912 partsav(5,ip) =partsav(5,ip) + two*xi + ems(i) * (yy+zz)
1913 partsav(6,ip) =partsav(6,ip) + two*xi + ems(i) * (zz+xx)
1914 partsav(7,ip) =partsav(7,ip) + two*xi + ems(i) * (xx+yy)
1915 partsav(8,ip) =partsav(8,ip) - ems(i) * xy
1916 partsav(9,ip) =partsav(9,ip) - ems(i) * yz
1917 partsav(10,ip)=partsav(10,ip) - ems(i) * zx
1918C
1919 partsav(11,ip)=partsav(11,ip) + ems(i)*(v(1,i1)+v(1,i2))
1920 partsav(12,ip)=partsav(12,ip) + ems(i)*(v(2,i1)+v(2,i2))
1921 partsav(13,ip)=partsav(13,ip) + ems(i)*(v(3,i1)+v(3,i2))
1922 partsav(14,ip)=partsav(14,ip) + half * ems(i) *
1923 . (v(1,i1)*v(1,i1)+v(2,i1)*v(2,i1)+v(3,i1)*v(3,i1)
1924 . +v(1,i2)*v(1,i2)+v(2,i2)*v(2,i2)+v(3,i2)*v(3,i2))
1925 ENDDO
1926C
1927 IF (irest_mselt /= 0)THEN
1928 DO i=lft,llt
1929 msrt(i)=umass(i)
1930 ENDDO
1931 ENDIF
1932C
1933 RETURN

◆ rini3u()

subroutine rini3u ( off,
geo,
x,
x0,
integer, dimension(nixr,*) ix,
skew,
rloc,
integer, dimension(*) itab,
integer, dimension(4,mvsiz) uix,
integer, dimension(npropgi,*) igeo )

Definition at line 1665 of file rinit3.F.

1667C-----------------------------------------------
1668C I m p l i c i t T y p e s
1669C-----------------------------------------------
1670#include "implicit_f.inc"
1671C-----------------------------------------------
1672C G l o b a l P a r a m e t e r s
1673C-----------------------------------------------
1674#include "mvsiz_p.inc"
1675C-----------------------------------------------
1676C C o m m o n B l o c k s
1677C-----------------------------------------------
1678#include "vect01_c.inc"
1679#include "param_c.inc"
1680C-----------------------------------------------
1681C D u m m y A r g u m e n t s
1682C-----------------------------------------------
1683 INTEGER IX(NIXR,*),UIX(4,MVSIZ),ITAB(*), IGEO(NPROPGI,*)
1684C REAL
1685 my_real
1686 . off(*), geo(npropg,*), x(3,*), x0(*), skew(lskew,*),
1687 . rloc(6,*)
1688C-----------------------------------------------
1689C L o c a l V a r i a b l e s
1690C-----------------------------------------------
1691 INTEGER I, J, NG, I1, I2, I3, ISK
1692C REAL
1693 my_real
1694 . x1, y1, z1
1695C-----------------------------------------------
1696 DO i=lft,llt
1697 off(i) = one
1698 ENDDO
1699C
1700 DO i=lft,llt
1701 j=i+nft
1702 ng=ix(1,j)
1703 isk=igeo(2,ng)
1704 i1=ix(2,j)
1705 i2=ix(3,j)
1706 i3=ix(4,j)
1707 x1=x(1,i2)-x(1,i1)
1708 y1=x(2,i2)-x(2,i1)
1709 z1=x(3,i2)-x(3,i1)
1710 x0(i)=sqrt(x1**2+y1**2+z1**2)
1711 IF (x0(i) < em15) THEN
1712 rloc(1,i)= one
1713 rloc(2,i)= zero
1714 rloc(3,i)= zero
1715 rloc(4,i)= zero
1716 rloc(5,i)= one
1717 rloc(6,i)= zero
1718 ELSEIF (i3 /= 0) THEN
1719 rloc(1,i)=x1
1720 rloc(2,i)=y1
1721 rloc(3,i)=z1
1722 rloc(4,i)=x(1,i3)-x(1,i1)
1723 rloc(5,i)=x(2,i3)-x(2,i1)
1724 rloc(6,i)=x(3,i3)-x(3,i1)
1725 ELSEIF (isk /= 1) THEN
1726 rloc(1,i)= x1
1727 rloc(2,i)= y1
1728 rloc(3,i)= z1
1729 rloc(4,i)=skew(4,isk)
1730 rloc(5,i)=skew(5,isk)
1731 rloc(6,i)=skew(6,isk)
1732 ELSE
1733 rloc(1,i)=x1
1734 rloc(2,i)=y1
1735 rloc(3,i)=z1
1736 IF (abs(y1) < half*x0(i)) THEN
1737 rloc(4,i)=zero
1738 rloc(5,i)=one
1739 rloc(6,i)=zero
1740 ELSE
1741 rloc(4,i)=one
1742 rloc(5,i)=zero
1743 rloc(6,i)=zero
1744 ENDIF
1745 ENDIF
1746 uix(1,i)=itab(i1)
1747 uix(2,i)=itab(i2)
1748 IF(i3 /= 0) THEN
1749 uix(3,i)=itab(i3)
1750 ELSE
1751 uix(3,i)=0
1752 ENDIF
1753 uix(4,i)=ix(6,j)
1754 ENDDO
1755C
1756 RETURN

◆ rinit3()

subroutine rinit3 ( type(elbuf_struct_), target elbuf_str,
integer, dimension(nixr,*) ixr,
x,
geo,
xmas,
integer, dimension(*) npc,
pld,
xin,
skew,
dtelem,
integer nel,
stifn,
stifr,
partsav,
v,
integer, dimension(*) ipart,
integer, dimension(*) itab,
msr,
inr,
stifint,
str,
integer, dimension(npropgi,*) igeo,
sigrs,
integer nsigrs,
integer, dimension(numnod+1) imerge2,
integer, dimension(numnod+1) iadmerge2,
msrt,
integer, dimension(5,*) ixr_kj,
integer, dimension(lnopt1,*) nom_opt,
strr,
integer, dimension(*) ptspri,
integer, dimension(npropmi,*) ipm,
pm,
uparam,
integer, dimension(*) r_skew,
type(prel1d_), dimension(npreload_a), target preload_a,
integer, intent(in) ipreld,
integer, intent(in) npreload_a,
integer, dimension(3*numnod), intent(in) ikine )

Definition at line 57 of file rinit3.F.

67C-----------------------------------------------
68C M o d u l e s
69C-----------------------------------------------
70 USE elbufdef_mod
71 USE message_mod
72 USE seatbelt_mod
73 USE bpreload_mod
74 USE names_and_titles_mod , ONLY : nchartitle
75 USE format_mod , ONLY : fmt_10i
76C-----------------------------------------------
77C I m p l i c i t T y p e s
78C-----------------------------------------------
79#include "implicit_f.inc"
80C-----------------------------------------------
81C G l o b a l P a r a m e t e r s
82C-----------------------------------------------
83#include "mvsiz_p.inc"
84C-----------------------------------------------
85C C o m m o n B l o c k s
86C-----------------------------------------------
87#include "param_c.inc"
88#include "units_c.inc"
89#include "vect01_c.inc"
90#include "com01_c.inc"
91#include "com04_c.inc"
92#include "random_c.inc"
93#include "scr12_c.inc"
94#include "scr17_c.inc"
95#include "userlib.inc"
96#include "scr15_c.inc"
97#include "kincod_c.inc"
98C-----------------------------------------------
99C D u m m y A r g u m e n t s
100C-----------------------------------------------
101 INTEGER IXR(NIXR,*), NPC(*),IPART(*),ITAB(*),NEL,
102 . IGEO(NPROPGI,*),NSIGRS,IMERGE2(NUMNOD+1),
103 . IADMERGE2(NUMNOD+1),IXR_KJ(5,*),PTSPRI(*),
104 . IPM(NPROPMI,*),R_SKEW(*)
105 INTEGER NOM_OPT(LNOPT1,*)
106 INTEGER , INTENT (IN) :: IPRELD,NPRELOAD_A
107 INTEGER , INTENT (IN) :: IKINE(3*NUMNOD)
108C REAL
109 my_real
110 . x(3,*), geo(npropg,*), xmas(*), pld(*), xin(*),
111 . skew(lskew,*), dtelem(*),stifn(*),stifr(*),partsav(20,*), v(*),
112 . msr(3,*), inr(3,*),
113 . stifint(*), str(*),sigrs(nsigrs,*), msrt(*),strr(*),uparam(*),
114 . pm(npropm,*)
115C
116 TYPE(ELBUF_STRUCT_), TARGET :: ELBUF_STR
117 TYPE(PREL1D_) , DIMENSION(NPRELOAD_A), TARGET :: PRELOAD_A
118C-----------------------------------------------
119C L o c a l V a r i a b l e s
120C-----------------------------------------------
121 INTEGER I,J,I2, IGTYP, NDEPAR,
122 . K,KK,KK1,ITMP,
123 . I1, I0, I3,NEL3,NUVAR,NUPARAM,NFUNC,IADFUN,
124 . NMAT,IADMAT,NJPID,ILENG,NFUND,
125 3 UIX(4,MVSIZ),
126 . IMAT,K1,K11,K14,K12,K13,IADBUF,IMASS,SLIP,FRA,IH,NKIN,
127 . KCOND1,KCOND2
128C REAL
129 my_real
130 . dt, dtc, xkm, xcm, xkr, xcr, xm, xine, ex, ey, ez,
131 . al2, sti,rho,kx,kxy,kxz,
132 . ul(mvsiz),
133 . uiner(mvsiz) ,ustifm(mvsiz) ,
134 . ustifr(mvsiz),uvism(mvsiz) ,
135 . uvisr(mvsiz), xl(mvsiz), dx(mvsiz,3),ems(mvsiz)
136 my_real
137 . length, ratio, lmin
138 my_real
139 . minl, maxl, rfac, ixx, iyy, ine2
140 INTEGER IDS, CNT1, CNT2, NSPRG, NSPRG4, NSPRG8, NSPRG12,
141 . NSPRG13, NSPRG25, NSPRG26, NSPRGU, IUN,NSPRG23,NSPRG27
142 DATA nsprg /0/, nsprg4 /0/, nsprg8 /0/, nsprg12 /0/,
143 . nsprg13 /0/, nsprg25 /0/,nsprg26/0/,nsprgu /0/,
144 . nsprg23 /0/,nsprg27/0/
145 INTEGER MINIDL, MAXIDL,IPID,IFUNC
146 my_real
147 . noise,bidon,mas2,undamp
148 INTEGER ID
149 CHARACTER(LEN=NCHARTITLE)::TITR
150 CHARACTER OPTION*50
151C
152 TYPE(G_BUFEL_),POINTER :: GBUF
153 INTEGER II(6)
154 my_real :: dfs(2), dv(2)
155C=======================================================================
156 bidon = zero
157C
158 gbuf => elbuf_str%GBUF
159C
160 DO i=1,6
161 ii(i) = (i-1)*nel + 1
162 ENDDO
163C
164 iun = 1
165 noise = two*sqrt(three)*xalea
166C
167 DO i=1,numgeo
168 igtyp=igeo(11,i)
169 id=igeo(1,i)
170 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i),ltitr)
171 IF (igtyp == 4 .OR. igtyp == 12 .OR. igtyp == 27) THEN
172 CALL rkini3(igeo(101,i),npc,pld,geo(2,i),geo(7,i),igeo(1,i),
173 . geo(10,i) ,geo(39,i) ,id,titr,nom_opt)
174 ELSEIF (igtyp == 8 .OR. igtyp == 13) THEN
175 CALL rkini3(igeo(101,i),npc,pld,geo(3,i) , geo(7,i) , igeo(1,i),
176 . geo(41,i) ,geo(39,i) ,id,titr,nom_opt)
177 CALL rkini3(igeo(104,i),npc,pld,geo(10,i), geo(14,i), igeo(1,i),
178 . geo(45,i) ,geo(174,i) ,id,titr,nom_opt)
179 CALL rkini3(igeo(107,i),npc,pld,geo(15,i), geo(18,i), igeo(1,i),
180 . geo(49,i) ,geo(175,i) ,id,titr,nom_opt)
181 CALL rkini3(igeo(110,i),npc,pld,geo(19,i), geo(22,i), igeo(1,i),
182 . geo(53,i) ,geo(176,i) ,id,titr,nom_opt)
183 CALL rkini3(igeo(113,i),npc,pld,geo(23,i), geo(26,i), igeo(1,i),
184 . geo(57,i) ,geo(177,i) ,id,titr,nom_opt)
185 CALL rkini3(igeo(116,i),npc,pld,geo(27,i), geo(30,i), igeo(1,i),
186 . geo(61,i) ,geo(178,i) ,id,titr,nom_opt)
187 ELSEIF (igtyp == 25) THEN
188 CALL rkini3(igeo(102,i),npc,pld,geo(3,i) , geo(7,i) , igeo(1,i),
189 . geo(41,i) ,geo(39,i) ,id,titr,nom_opt)
190 CALL rkini3(igeo(106,i),npc,pld,geo(10,i), geo(14,i), igeo(1,i),
191 . geo(45,i) ,geo(174,i) ,id,titr,nom_opt)
192 CALL rkini3(igeo(110,i),npc,pld,geo(19,i), geo(22,i), igeo(1,i),
193 . geo(53,i) ,geo(176,i) ,id,titr,nom_opt)
194 CALL rkini3(igeo(114,i),npc,pld,geo(23,i), geo(26,i), igeo(1,i),
195 . geo(57,i) ,geo(177,i) ,id,titr,nom_opt)
196 ELSEIF (igtyp == 26) THEN
197 nfunc = igeo(20,i)
198 nfund = igeo(21,i)
199 iadfun = 100
200 DO j = 1,nfunc
201 CALL rkini3(igeo(iadfun+j,i),npc,pld,geo(2,i),one, igeo(1,i),
202 . one ,one ,id,titr,nom_opt)
203 ENDDO
204 iadfun = nfund+100
205 DO j = 1,nfund
206 CALL rkini3(igeo(iadfun+j,i),npc,pld,geo(2,i),one, igeo(1,i),
207 . one ,one ,id,titr,nom_opt)
208 ENDDO
209 ELSEIF (igtyp == 23) THEN
210 geo(4,i) = ep30 !
211 ENDIF ! IF (IGTYP
212 ENDDO ! DO I=1,NUMGEO
213C
214 CALL ancmsg(msgid=506,
215 . msgtype=msgwarning,
216 . anmode=aninfo_blind_1,
217 . prmod=msg_print)
218C-----------------
219 ipid=ixr(1,nft+1)
220 id=igeo(1,ipid)
221 CALL fretitl2(titr,igeo(npropgi-ltitr+1,ipid),ltitr)
222 DO i=lft,llt
223 j=i+nft
224 i0=ixr(1,j)
225 i1=ixr(2,j)
226 i2=ixr(3,j)
227 i3=ixr(4,j)
228C-----------------
229 IF (i1 == i2 .OR. i1 == i3 .OR. i2 == i3) THEN
230 IF (i1 == i2 .OR. i1 == i3) itmp = i1
231 IF (i2 == i3) itmp = i2
232 IF (imerge2(itmp) /= 0) THEN
233 CALL ancmsg(msgid=682,
234 . msgtype=msgwarning,
235 . anmode=aninfo_blind_1,
236 . i1=ixr(nixr,j),
237 . i2=itab(itmp))
238 WRITE (iout,1000) itab(itmp)
239 kk = 0
240 DO k=1,iadmerge2(itmp+1) - iadmerge2(itmp)
241 kk = kk + 1
242 IF (kk == 10) THEN
243 WRITE (iout,fmt=fmt_10i)(itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
244 kk = 0
245 ENDIF
246 ENDDO
247 IF (kk /= 0) THEN
248 WRITE (iout,fmt=fmt_10i)
249 . (itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
250 ENDIF
251 ELSE
252 CALL ancmsg(msgid=681,
253 . msgtype=msgerror,
254 . anmode=aninfo_blind_1,
255 . i1=ixr(nixr,j) )
256 ENDIF ! IF (IMERGE2(ITMP) /= 0)
257 ENDIF ! IF (I1 == I2 .OR. I1 == I3 .OR. I2 == I3)
258C-----------------
259 igtyp=igeo(11,i0)
260 IF (igtyp /= 4 .AND. igtyp /= 8 .AND.
261 . igtyp /= 12 .AND. igtyp /= 13 .AND. igtyp /= 25 .AND.
262 . igtyp /= 44 .AND. igtyp /= 26 .AND. igtyp < 29 .AND.
263 . igtyp /= 46 .AND. igtyp /= 23 .AND. igtyp /= 27) THEN
264 CALL ancmsg(msgid=243,
265 . msgtype=msgerror,
266 . anmode=aninfo_blind_1,
267 . i1=id,
268 . c1=titr)
269 ENDIF
270C check compatibility of property type with spring elements.
271 IF (igtyp > 33 .AND. igtyp /= 35 .AND. igtyp /= 36 .AND.
272 . igtyp /= 44 .AND. igtyp /= 45 .AND. igtyp /= 46) THEN
273 CALL ancmsg(msgid=243,
274 . msgtype=msgerror,
275 . anmode=aninfo_blind_1,
276 . i1=id,
277 . c1=titr)
278 ENDIF
279 ENDDO
280C-----
281 i0=ixr(1,1+nft)
282 id=igeo(1,i0)
283 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
284 igtyp = igeo(11,i0)
285 IF (igtyp == 12) THEN
286 DO i=lft,llt
287 IF (ixr(4,i+nft) == 0) THEN
288 ipid=ixr(1,i+nft)
289 CALL ancmsg(msgid=244,
290 . msgtype=msgerror,
291 . anmode=aninfo,
292 . i1=id,
293 . c1=titr,
294 . i2=ixr(nixr,i+nft))
295 ENDIF
296 ENDDO
297 ENDIF
298C
299 ids = 328
300 cnt1 = 0
301 cnt2 = 0
302 nsprg = 0
303c CALL ANCNTS(IDS, CNT2)
304 DO i=lft,llt
305 j=i+nft
306 i0=ixr(1,j)
307 i1=ixr(2,j)
308 i2=ixr(3,j)
309 i3=ixr(4,j)
310 igtyp=igeo(11,i0)
311 ileng=nint(geo(93,i0))
312 IF (igtyp == 4) THEN
313 nsprg4 = nsprg4 + 1
314 ELSE IF (igtyp == 8) THEN
315 nsprg8 = nsprg8 + 1
316 ELSE IF (igtyp == 12) THEN
317 nsprg12 = nsprg12 + 1
318 ELSE IF (igtyp == 13) THEN
319 nsprg13 = nsprg13 + 1
320 ELSE IF (igtyp == 23) THEN
321 nsprg23 = nsprg23 + 1
322 imat = ixr(5,i+nft)
323 iadbuf = ipm(7,imat) - 1
324 ileng = nint(uparam(iadbuf + 2))
325 imass = igeo(4,i0)
326 mtn = ipm(2,imat)
327 IF(mtn == 114) THEN
328 imass = 1
329 lmin = max(uparam(iadbuf + 119),uparam(iadbuf + 126))
330 ENDIF
331 ELSE IF (igtyp == 25) THEN
332 nsprg25 = nsprg25 + 1
333 ELSE IF (igtyp == 26) THEN
334 nsprg26 = nsprg26 + 1
335 ELSE IF (igtyp == 27) THEN
336 nsprg27 = nsprg27 + 1
337 ELSE
338 nsprgu = nsprgu + 1
339 ENDIF
340 IF (ileng > 0) THEN
341 xl(i) = sqrt(
342 . (x(1,i1)-x(1,i2))*(x(1,i1)-x(1,i2))
343 + + (x(2,i1)-x(2,i2))*(x(2,i1)-x(2,i2))
344 + + (x(3,i1)-x(3,i2))*(x(3,i1)-x(3,i2)) )
345 IF (igtyp == 12) THEN
346 xl(i) = xl(i) + sqrt(
347 . (x(1,i3)-x(1,i2))*(x(1,i3)-x(1,i2))
348 + + (x(2,i3)-x(2,i2))*(x(2,i3)-x(2,i2))
349 + + (x(3,i3)-x(3,i2))*(x(3,i3)-x(3,i2)) )
350 ENDIF
351 IF (mtn == 114) xl(i) = max(xl(i),lmin)
352 IF (xl(i) <= noise) THEN
353 ipid = ixr(1,i)
354 CALL ancmsg(msgid=328,
355 . msgtype=msgerror,
356 . anmode=aninfo_blind_1,
357 . i1=id,
358 . c1=titr,
359 . i2=ixr(nixr,j))
360 ENDIF
361 ELSE
362 xl(i)=one
363 ENDIF
364 ENDDO
365C
366c CALL ANCNTG(IDS, CNT1, CNT2)
367 nsprg = nsprg + cnt2
368 minl = zero
369 maxl = zero
370 minidl = 0
371 maxidl = 0
372 DO i=lft,llt
373 j=i+nft
374 i0=ixr(1,j)
375 i1=ixr(2,j)
376 i2=ixr(3,j)
377 i3=ixr(4,j)
378 igtyp=igeo(11,i0)
379C
380 length = sqrt(
381 . (x(1,i1)-x(1,i2))*(x(1,i1)-x(1,i2))
382 + + (x(2,i1)-x(2,i2))*(x(2,i1)-x(2,i2))
383 + + (x(3,i1)-x(3,i2))*(x(3,i1)-x(3,i2)) )
384 IF (igtyp == 12) THEN
385 length = length + sqrt(
386 . (x(1,i3)-x(1,i2))*(x(1,i3)-x(1,i2))
387 + + (x(2,i3)-x(2,i2))*(x(2,i3)-x(2,i2))
388 + + (x(3,i3)-x(3,i2))*(x(3,i3)-x(3,i2)) )
389 ENDIF
390C
391 IF (minl <= 0 .OR. (length < minl .AND. length > em15)) THEN
392 minidl = ixr(nixr,j)
393 minl = length
394 ENDIF
395C
396 IF (length > maxl) THEN
397 maxidl = ixr(nixr,j)
398 maxl = length
399 ENDIF
400C
401 IF(igtyp == 8 .OR. igtyp==13 .OR. igtyp==25) THEN
402 ileng=nint(geo(93,i0))
403C
404 IF (ileng > 0) THEN
405 xm=geo(1,i0)*xl(i)
406 xine=geo(9,i0)*xl(i)
407 ELSE
408 xm=geo(1,i0)
409 xine=geo(9,i0)
410 ENDIF
411C
412C---- For prop type8 - skew per element is used if available
413 IF ((igtyp == 8).AND.( r_skew(i+nft) > 0)) THEN
414 gbuf%SKEW_ID(i) = r_skew(i+nft)
415 ELSEIF (igtyp == 8) THEN
416C---- For prop type8 - skew of property is used if no skew per element
417 gbuf%SKEW_ID(i) = igeo(2,i0)
418 r_skew(i+nft) = igeo(2,i0)
419 ENDIF
420C
421 ratio = xm * length * length
422 IF ( (.NOT.((igtyp == 8).AND.(length < em15))) .AND.
423 . (xine < ratio/ep03 .OR. xine > ratio*ep03) ) THEN
424 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
425 CALL ancmsg(msgid=432,
426 . msgtype=msgwarning,
427 . anmode=aninfo_blind_2,
428 . i1=igeo(1,i0),
429 . c1=titr,
430 . r2=ratio,
431 . r1=xine,
432 . i2=ixr(nixr,i+nft),
433 . prmod=msg_cumu)
434 ENDIF
435 ELSEIF(igtyp == 23) THEN
436 imat = ixr(5,i+nft)
437 iadbuf = ipm(7,imat) - 1
438 ileng = nint(uparam(iadbuf + 2))
439 rho = pm(1,imat)
440 imass = igeo(4,i0)
441 mtn = ipm(2,imat)
442 uiner(i) = zero
443C---- For mat law108 skew per element is used if available
444 IF ((mtn == 108).AND.( r_skew(i+nft) > 0)) THEN
445 gbuf%SKEW_ID(i) = r_skew(i+nft)
446 ELSEIF (mtn == 108) THEN
447C---- For mat law108 skew of property 23 is used if no skew per element
448 gbuf%SKEW_ID(i) = igeo(2,i0)
449 ELSEIF (mtn == 114) THEN
450C---- For mat law114 lmin is used for mass setting of element with null length
451 imass = 1
452 lmin = max(uparam(iadbuf + 119),uparam(iadbuf + 126))
453 rfac = uparam(iadbuf + 124)
454 ixx = uparam(iadbuf + 122)
455 iyy = uparam(iadbuf + 123)
456 length = max(length,lmin)
457 IF (uparam(iadbuf + 127) > zero) THEN
458C- 1D material of 2D seatbelt - no need for inertia - mass and inertia given by shell
459 rfac = zero
460 ENDIF
461C- inertia of element is automatically computed according to moment of inertia area if Young modulus > 0
462 uiner(i) = max(em20,rfac*max((rho*geo(1,i0)*length*length*length)/twelve + rho*iyy*length,rho*ixx*length))
463 ENDIF
464C
465 IF(imass == 1) THEN
466 gbuf%MASS(i) = geo(1,i0)*length*rho
467 IF ((length == zero).AND.(rho /= zero)) THEN
468 ipid = ixr(1,i)
469 nkin = ikine(i1)
470 kcond1 = irb(nkin)+irb2(nkin)
471 nkin = ikine(i2)
472 kcond2 = irb(nkin)+irb2(nkin)
473 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
474 IF (((xmas(i1) > zero).OR.(kcond1 > 0)).AND.((xmas(i2) > zero).OR.(kcond1 > 0)).AND.(mtn == 108)) THEN
475C- imass = 1 (mass per unit lenght) + null length accepted for law108
476C- if nodes have masses are or connected to rbodies - only a warning is printed
477 CALL ancmsg(msgid=3103,
478 . msgtype=msgwarning,
479 . anmode=aninfo_blind_1,
480 . i1=id,
481 . c1=titr,
482 . i2=ixr(nixr,i))
483 ELSE
484 CALL ancmsg(msgid=1664,
485 . msgtype=msgerror,
486 . anmode=aninfo_blind_1,
487 . i1=id,
488 . c1=titr,
489 . i2=ixr(nixr,i))
490 ENDIF
491 ENDIF
492 ELSEIF(imass == 2) THEN
493 gbuf%MASS(i) = geo(1,i0)*rho
494 ENDIF
495C
496
497 xm = gbuf%MASS(i)
498 xine = geo(2,i0)
499
500C
501 ratio = xm * length * length
502 IF( mtn == 113) THEN
503 IF ( ((length < em15)) .AND.
504 . (xine < ratio/ep03 .OR. xine > ratio*ep03) ) THEN
505 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
506 CALL ancmsg(msgid=432,
507 . msgtype=msgwarning,
508 . anmode=aninfo_blind_2,
509 . i1=igeo(1,i0),
510 . c1=titr,
511 . r2=ratio,
512 . r1=xine,
513 . i2=ixr(nixr,i+nft),
514 . prmod=msg_cumu)
515 ENDIF
516 ENDIF
517 ENDIF
518 ENDDO ! DO I=LFT,LLT
519C
520 CALL ancmsg(msgid=432,
521 . msgtype=msgwarning,
522 . anmode=aninfo_blind_2,
523 . prmod=msg_print)
524C------------------------------------------
525C INITIALISATION DES RIGIDITES NODALES POUR INTERFACES
526C------------------------------------------
527 IF (i7stifs /= 0) THEN
528 IF (igtyp == 4 .OR. igtyp == 12 .OR. igtyp == 27) THEN
529 DO i=lft,llt
530 j=i+nft
531 i0=ixr(1,j)
532 i1=ixr(2,j)
533 i2=ixr(3,j)
534 i3=ixr(4,j)
535 sti = geo(2,i0)*geo(10,i0)/max(em30,xl(i))
536 str(i)=sti
537 ENDDO
538 ELSEIF (igtyp == 8 .OR. igtyp == 13) THEN
539 DO i=lft,llt
540 j=i+nft
541 i0=ixr(1,j)
542 i1=ixr(2,j)
543 i2=ixr(3,j)
544 sti = max(geo(3,i0)*geo(41,i0),geo(10,i0)*geo(45,i0),geo(15,i0)*geo(49,i0))/max(em30,xl(i))
545 str(i)=sti
546 ENDDO
547 ELSEIF (igtyp == 23 ) THEN
548 k11 = 64 ! 4 + 6*10
549 DO i=lft,llt
550 j=i+nft
551 i0=ixr(1,j)
552 i1=ixr(2,j)
553 i2=ixr(3,j)
554 imat = ixr(5,i+nft)
555 iadbuf = ipm(7,imat) - 1
556 kx = uparam(iadbuf + k11 + 1)
557 kxy = uparam(iadbuf + k11 + 2)
558 kxz = uparam(iadbuf + k11 + 3)
559 sti = max(kx,kxy,kxz)/max(em30,xl(i))
560 str(i)=sti
561 ENDDO
562 ELSEIF (igtyp == 25) THEN
563 DO i=lft,llt
564 j=i+nft
565 i0=ixr(1,j)
566 i1=ixr(2,j)
567 i2=ixr(3,j)
568 sti = max(geo(3,i0)*geo(41,i0),geo(10,i0)*geo(45,i0))/max(em30,xl(i))
569 str(i)=sti
570 ENDDO
571 ELSEIF (igtyp == 26) THEN
572 DO i=lft,llt
573 j=i+nft
574 i0=ixr(1,j)
575 i1=ixr(2,j)
576 i2=ixr(3,j)
577 i3=ixr(4,j)
578 sti = geo(2,i0)/max(em30,xl(i))
579 str(i)=sti
580 ENDDO
581 ELSE
582 DO i=lft,llt
583 j=i+nft
584 i0=ixr(1,j)
585 i1=ixr(2,j)
586 i2=ixr(3,j)
587 sti = geo(3,i0)
588 str(i)=sti
589 ENDDO
590 ENDIF ! IF (IGTYP
591 ENDIF ! IF (I7STIF /= 0)
592C------------------------------------------
593 ndepar=numels+numelc+numelt+numelp+nft
594C-------------------------------------------------------------------
595C SPRINGS --> all types
596C-------------------------------------------------------------------
597C=======================================================================
598 IF (igtyp == 4) THEN
599C=======================================================================
600 CALL rmass(ixr ,geo ,xmas ,xin ,partsav ,
601 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
602 3 inr(1,nft+1),msrt ,ems )
603 CALL r1buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,
604 2 igeo )
605C----
606 IF (inispri /= 0)
607 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
608 2 gbuf%TOTDEPL ,gbuf%FOREP ,gbuf%DEP_IN_TENS ,gbuf%DEP_IN_COMP,gbuf%LENGTH,
609 3 dfs , dv,igtyp ,ptspri ,gbuf%DEFINI(ii(1)),
610 4 gbuf%FORINI(ii(1)))
611 ELSEIF (igtyp == 26) THEN
612 CALL rmass(ixr ,geo ,xmas ,xin ,partsav ,
613 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
614 3 inr(1,nft+1),msrt ,ems )
615 CALL r1buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,
616 2 igeo )
617C----
618 IF (inispri /= 0)
619 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
620 2 gbuf%TOTDEPL ,gbuf%FOREP ,bidon ,bidon ,gbuf%LENGTH,
621 3 dfs ,gbuf%DV ,igtyp ,ptspri ,gbuf%DEFINI,
622 4 gbuf%FORINI )
623c------
624C=======================================================================
625 ELSEIF (igtyp == 8) THEN
626C=======================================================================
627 CALL rmass(ixr ,geo ,xmas ,xin,partsav ,
628 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
629 3 inr(1,nft+1),msrt,ems )
630 CALL r2buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)),
631 2 gbuf%LENGTH(ii(3)) ,ixr ,skew ,gbuf%POSX,gbuf%POSY,
632 3 gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY,gbuf%POSZZ,igeo ,
633 3 gbuf%SKEW_ID)
634C----
635 IF (inispri /= 0)
636 . CALL r8ini(
637 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
638 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
639 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
640 5 gbuf%MOMEP(ii(2)) ,gbuf%MOMEP(ii(3)) ,gbuf%DEP_IN_TENS(ii(1)),gbuf%DEP_IN_TENS(ii(2)),gbuf%DEP_IN_TENS(ii(3)),
641 6 gbuf%ROT_IN_TENS(ii(1)),gbuf%ROT_IN_TENS(ii(2)),gbuf%ROT_IN_TENS(ii(3)),gbuf%DEP_IN_COMP(ii(1)),gbuf%DEP_IN_COMP(ii(2)),
642 7 gbuf%DEP_IN_COMP(ii(3)),gbuf%ROT_IN_COMP(ii(1)),gbuf%ROT_IN_COMP(ii(2)),gbuf%ROT_IN_COMP(ii(3)),gbuf%TOTDEPL(ii(1)) ,
643 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
644 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
645 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
646 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
647 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
648C=======================================================================
649 ELSEIF (igtyp == 12) THEN
650C=======================================================================
651 CALL rmas12 (ixr ,geo,partsav ,
652 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
653 3 inr(1,nft+1),msrt)
654 ids = 457
655 cnt1 = 0
656 cnt2 = 0
657 CALL r3buf3(gbuf%OFF,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,igeo ,itab )
658 nsprg = nsprg + cnt2
659 IF (inispri /= 0)
660 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
661 2 gbuf%TOTDEPL ,gbuf%FOREP ,gbuf%DEP_IN_TENS,gbuf%DEP_IN_TENS,gbuf%LENGTH,
662 3 gbuf%DFS ,dv,igtyp ,ptspri ,gbuf%DEFINI,
663 4 gbuf%FORINI )
664C=======================================================================
665 ELSEIF (igtyp == 13) THEN
666C=======================================================================
667 CALL rmass(ixr ,geo ,xmas ,xin,partsav ,
668 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
669 3 inr(1,nft+1),msrt,ems )
670
671 ids = 325
672 cnt1 = 0
673 cnt2 = 0
674 CALL r4buf3(
675 1 gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)),
676 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
677 3 gbuf%POSY ,gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
678 4 itab ,gbuf%E6 ,igeo ,ipm)
679 nsprg = nsprg + cnt2
680 IF (inispri /= 0)
681 . CALL r8ini(
682 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
683 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
684 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
685 5 gbuf%MOMEP(ii(2)) ,gbuf%MOMEP(ii(3)) ,gbuf%DEP_IN_TENS(ii(1)),gbuf%DEP_IN_TENS(ii(2)),gbuf%DEP_IN_TENS(ii(3)),
686 6 gbuf%ROT_IN_TENS(ii(1)),gbuf%ROT_IN_TENS(ii(2)),gbuf%ROT_IN_TENS(ii(3)),gbuf%DEP_IN_COMP(ii(1)),gbuf%DEP_IN_COMP(ii(2)),
687 7 gbuf%DEP_IN_COMP(ii(3)),gbuf%ROT_IN_COMP(ii(1)),gbuf%ROT_IN_COMP(ii(2)),gbuf%ROT_IN_COMP(ii(3)),gbuf%TOTDEPL(ii(1)) ,
688 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
689 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
690 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
691 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
692 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
693C=======================================================================
694 ELSEIF (igtyp == 23) THEN
695C=======================================================================
696 ids = 325
697 cnt1 = 0
698 cnt2 = 0
699 CALL r23mass(ixr ,geo ,xmas ,xin,partsav ,
700 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
701 3 inr(1,nft+1),msrt,ems ,gbuf%MASS ,uiner,mtn)
702 IF(mtn == 108) THEN
703C
704 CALL r2buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)),
705 2 gbuf%LENGTH(ii(3)) ,ixr ,skew ,gbuf%POSX,gbuf%POSY,
706 3 gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY,gbuf%POSZZ,igeo ,
707 4 gbuf%SKEW_ID)
708C----
709 ELSEIF (mtn==113) THEN
710 CALL r4buf3(
711 1 gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)),
712 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
713 3 gbuf%POSY ,gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
714 4 itab ,gbuf%E6 ,igeo ,ipm)
715 nsprg = nsprg + cnt2
716C----
717 ELSEIF(mtn == 114) THEN
718 CALL r4buf3(
719 1 gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)),
720 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
721 3 gbuf%POSY ,gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
722 4 itab ,gbuf%E6 ,igeo ,ipm)
723 nsprg = nsprg + cnt2
724 ENDIF ! MTN
725
726 IF (inispri /= 0)
727 . CALL r8ini(
728 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
729 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
730 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
731 5 gbuf%MOMEP(ii(2)) ,gbuf%MOMEP(ii(3)) ,gbuf%DEP_IN_TENS(ii(1)),gbuf%DEP_IN_TENS(ii(2)),gbuf%DEP_IN_TENS(ii(3)),
732 6 gbuf%ROT_IN_TENS(ii(1)),gbuf%ROT_IN_TENS(ii(2)),gbuf%ROT_IN_TENS(ii(3)),gbuf%DEP_IN_COMP(ii(1)),gbuf%DEP_IN_COMP(ii(2)),
733 7 gbuf%DEP_IN_COMP(ii(3)),gbuf%ROT_IN_COMP(ii(1)),gbuf%ROT_IN_COMP(ii(2)),gbuf%ROT_IN_COMP(ii(3)),gbuf%TOTDEPL(ii(1)) ,
734 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
735 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
736 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
737 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
738 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
739C=======================================================================
740 ELSEIF (igtyp == 25) THEN
741C=======================================================================
742 CALL rmass(ixr ,geo ,xmas ,xin,partsav ,
743 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
744 3 inr(1,nft+1),msrt,ems )
745 ids = 325
746 cnt1 = 0
747 cnt2 = 0
748 CALL r4buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)) ,
749 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
750 3 gbuf%POSY ,gbuf%POSZ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
751 4 itab ,gbuf%E6 ,igeo ,ipm)
752 nsprg = nsprg + cnt2
753 IF (inispri /= 0)
754 . CALL r8ini(
755 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
756 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
757 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
758 5 gbuf%MOMEP(ii(2)) ,gbuf%MOMEP(ii(3)) ,gbuf%DEP_IN_TENS(ii(1)),gbuf%DEP_IN_TENS(ii(2)),gbuf%DEP_IN_TENS(ii(3)),
759 6 gbuf%ROT_IN_TENS(ii(1)),gbuf%ROT_IN_TENS(ii(2)),gbuf%ROT_IN_TENS(ii(3)),gbuf%DEP_IN_COMP(ii(1)),gbuf%DEP_IN_COMP(ii(2)),
760 7 gbuf%DEP_IN_COMP(ii(3)),gbuf%ROT_IN_COMP(ii(1)),gbuf%ROT_IN_COMP(ii(2)),gbuf%ROT_IN_COMP(ii(3)),gbuf%TOTDEPL(ii(1)) ,
761 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
762 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
763 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
764 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
765 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
766C=======================================================================
767 ELSEIF (igtyp == 27) THEN
768C=======================================================================
769 CALL rmass(ixr ,geo ,xmas ,xin ,partsav ,
770 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
771 3 inr(1,nft+1),msrt ,ems )
772 CALL r1buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,
773 2 igeo )
774C----
775 IF (inispri /= 0)
776 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
777 2 gbuf%TOTDEPL ,gbuf%FOREP ,gbuf%DEP_IN_TENS ,gbuf%DEP_IN_COMP,gbuf%LENGTH,
778 3 dfs,dv,igtyp ,ptspri ,gbuf%DEFINI(ii(1)),
779 4 gbuf%FORINI(ii(1)))
780C=======================================================================
781 ELSEIF (igtyp == 32 .OR. igtyp == 33 .OR. igtyp == 45) THEN
782C=======================================================================
783 CALL rini1u(gbuf%OFF ,geo ,x ,ul ,ixr ,
784 2 skew ,gbuf%SKEW,itab ,uix ,igeo)
785 nuvar = nint(geo(25,i0))
786 nuparam = nint(geo(26,i0))
787 IF (igtyp == 32) THEN
788 CALL rini32(
789 1 nel ,iout ,i0 ,
790 2 uix ,ul ,gbuf%MASS,uiner ,ustifm ,
791 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar ,id,titr,
792 4 gbuf%EINT,npc ,pld )
793 ELSEIF (igtyp == 33) THEN
794 DO i=lft,llt
795 j=i+nft
796 i1=ixr(2,j)
797 i2=ixr(3,j)
798 dx(i,1) = (x(1,i2)-x(1,i1))
799 dx(i,2) = (x(2,i2)-x(2,i1))
800 dx(i,3) = (x(3,i2)-x(3,i1))
801 ENDDO
802 CALL rini33(nel ,iout ,i0 ,uix,dx,
803 1 gbuf%MASS ,uiner ,ustifm ,ustifr,
804 2 uvism ,uvisr ,gbuf%VAR,nuvar )
805 ELSEIF (igtyp == 45) THEN
806 DO i=lft,llt
807 j=i+nft
808 i1=ixr(2,j)
809 i2=ixr(3,j)
810 dx(i,1) = (x(1,i2)-x(1,i1))
811 dx(i,2) = (x(2,i2)-x(2,i1))
812 dx(i,3) = (x(3,i2)-x(3,i1))
813 ENDDO
814 CALL rini45(nel ,iout ,i0 ,uix ,x ,dx,
815 . gbuf%MASS,uiner ,ustifm ,ustifr ,uvism ,
816 . uvisr ,gbuf%VAR,nuvar ,ixr ,ixr_kj,id ,titr)
817 ENDIF
818C
819 DO i=lft,llt
820 j=i+nft
821 i0=ixr(1,j)
822 i1=ixr(2,j)
823 i2=ixr(3,j)
824 i3=ixr(4,j)
825 xm = gbuf%MASS(i)
826 xine = uiner(i)
827 al2= ul(i)*ul(i)
828 xkr= ustifr(i)
829 xkm= ustifm(i)
830 xcr= uvisr(i)
831 xcm= uvism(i)
832 stifn(i1)=stifn(i1)+xkm
833 stifn(i2)=stifn(i2)+xkm
834 stifr(i1)=stifr(i1)+xkr
835 stifr(i2)=stifr(i2)+xkr
836 strr(j)=xkr
837 IF (xcm+xkm<em15) xm =one
838 IF (xcr+xkr<em15) xine=one
839 xkm= max(em15,xkm)
840 xkr= max(em15,xkr)
841 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
842 dtc=half*xm / max(em15,xcm)
843 dt = min(dt,dtc)
844 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
845 dt = min(dt,dtc)
846 dtc=half*xine / max( em15,xcr)
847 dt = min(dt,dtc)
848 dtelem(ndepar+i)= dt
849 ENDDO
850C
851 CALL rini2u(
852 1 ixr ,gbuf%MASS,uiner,
853 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
854 3 inr(1,nft+1),msrt ,ems )
855 IF (inispri /= 0)
856 . CALL ruini(
857 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
858 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
859 4 gbuf%V_REPCVT(ii(1)) ,gbuf%V_REPCVT(ii(2)),gbuf%V_REPCVT(ii(3)),gbuf%VR_REPCVT(ii(1)),gbuf%VR_REPCVT(ii(2)),
860 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
861 6 ptspri)
862C=======================================================================
863 ELSEIF (igtyp == 35 .OR. igtyp == 36) THEN
864C=======================================================================
865 CALL rini3u(gbuf%OFF ,geo ,x ,ul ,ixr ,
866 2 skew ,gbuf%SKEW ,itab ,uix ,igeo)
867 nuvar = nint(geo(25,i0))
868 nuparam = nint(geo(26,i0))
869C---
870 IF (igtyp == 35) THEN
871 CALL rini35(
872 1 nel ,iout ,i0 ,
873 2 uix ,ul ,gbuf%MASS,uiner ,ustifm ,
874 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
875 ELSEIF (igtyp == 36) THEN
876 CALL rini36(
877 1 nel ,iout ,i0 ,
878 2 uix ,ul ,gbuf%MASS,uiner ,ustifm ,
879 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
880 ENDIF
881C---
882 DO i=lft,llt
883 j=i+nft
884 i0=ixr(1,j)
885 i1=ixr(2,j)
886 i2=ixr(3,j)
887 i3=ixr(4,j)
888 xm = gbuf%MASS(i)
889 xine = uiner(i)
890 al2= ul(i)*ul(i)
891 xkr= ustifr(i)
892 xkm= ustifm(i)
893 xcr= uvisr(i)
894 xcm= uvism(i)
895 stifn(i1)=stifn(i1)+xkm
896 stifn(i2)=stifn(i2)+xkm
897 stifr(i1)=stifr(i1)+xkr
898 stifr(i2)=stifr(i2)+xkr
899 strr(j)=xkr
900 IF (xcm+xkm<em15) xm =one
901 IF (xcr+xkr<em15) xine=one
902 xkm= max(em15,xkm)
903 xkr= max(em15,xkr)
904 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
905 dtc=half*xm / max(em15,xcm)
906 dt = min(dt,dtc)
907 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
908 dt = min(dt,dtc)
909 dtc=half*xine / max( em15,xcr)
910 dt = min(dt,dtc)
911 dtelem(ndepar+i)= dt
912 ENDDO
913 CALL rini2u(
914 1 ixr ,gbuf%MASS,uiner,
915 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
916 3 inr(1,nft+1),msrt ,ems )
917 IF (inispri /= 0)
918 + CALL ruini(
919 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
920 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
921 4 gbuf%V_REPCVT(ii(1)) ,gbuf%V_REPCVT(ii(2)),gbuf%V_REPCVT(ii(3)),gbuf%VR_REPCVT(ii(1)),gbuf%VR_REPCVT(ii(2)),
922 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
923 6 ptspri)
924C
925C=======================================================================
926 ELSEIF (igtyp > 28 .AND. igtyp < 43) THEN ! reserved for user properties
927C=======================================================================
928 CALL rini3u(gbuf%OFF ,geo ,x ,ul ,ixr ,
929 2 skew ,gbuf%SKEW ,itab ,uix ,igeo)
930 nuvar = nint(geo(25,i0))
931 nuparam = nint(geo(26,i0))
932C
933 IF (igtyp == 29) THEN
934 IF (userl_avail == 1) THEN
935 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
936 1 nel ,i0 ,
937 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
938 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
939 CALL user_output(iout,igtyp,rootnam,rootlen,0)
940 ELSE
941 option='/PROP/USER29'
942 CALL ancmsg(msgid=1155,
943 . anmode=aninfo,
944 . msgtype=msgerror,
945 . c1=option)
946 ENDIF
947 ELSEIF (igtyp == 30) THEN
948 IF (userl_avai l == 1) THEN
949 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
950 1 nel ,i0 ,
951 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
952 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
953 CALL user_output(iout,igtyp,rootnam,rootlen,0)
954 ELSE
955 option='/PROP/USER30'
956 CALL ancmsg(msgid=1155,
957 . anmode=aninfo,
958 . msgtype=msgerror,
959 . c1=option)
960 ENDIF
961 ELSEIF (igtyp == 31) THEN
962 IF (userl_avail == 1) THEN
963 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
964 1 nel ,i0 ,
965 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
966 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
967 CALL user_output(iout,igtyp,rootnam,rootlen,0)
968 ELSE
969 option='/PROP/USER31'
970 CALL ancmsg(msgid=1155,
971 . anmode=aninfo,
972 . msgtype=msgerror,
973 . c1=option)
974 ENDIF
975 ELSEIF (igtyp == 37) THEN
976 IF (userl_avail == 1) THEN
977 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
978 1 nel ,i0 ,
979 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
980 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
981 CALL user_output(iout,igtyp,rootnam,rootlen,0)
982 ELSE
983 option='/PROP/USER37'
984 CALL ancmsg(msgid=1155,
985 . anmode=aninfo,
986 . msgtype=msgerror,
987 . c1=option)
988 ENDIF
989 ELSEIF (igtyp == 38) THEN
990 IF (userl_avail == 1) THEN
991 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
992 1 nel ,i0 ,
993 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
994 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
995 CALL user_output(iout,igtyp,rootnam,rootlen,0)
996 ELSE
997 option='/PROP/USER38'
998 CALL ancmsg(msgid=1155,
999 . anmode=aninfo,
1000 . msgtype=msgerror,
1001 . c1=option)
1002 ENDIF
1003 ELSEIF (igtyp == 39) THEN
1004 IF (userl_avail == 1) THEN
1005 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
1006 1 nel ,i0 ,
1007 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1008 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1009 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1010 ELSE
1011 option='/PROP/USER39'
1012 CALL ancmsg(msgid=1155,
1013 . anmode=aninfo,
1014 . msgtype=msgerror,
1015 . c1=option)
1016 ENDIF
1017 ELSEIF (igtyp == 40) THEN
1018 IF (userl_avail == 1) THEN
1019 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
1020 1 nel ,i0 ,
1021 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1022 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1023 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1024 ELSE
1025 option='/prop/user40'
1026 CALL ANCMSG(MSGID=1155,
1027 . ANMODE=ANINFO,
1028 . MSGTYPE=MSGERROR,
1029 . C1=OPTION)
1030 ENDIF
1031 ELSEIF (IGTYP == 41) THEN
1032 IF (USERL_AVAIL == 1) THEN
1033 CALL ST_USERLIB_RINIUSER(IGTYP,ROOTNAM,ROOTLEN,
1034 1 NEL ,I0 ,
1035 2 UIX ,UL ,GBUF%MASS ,UINER ,USTIFM ,
1036 3 USTIFR ,UVISM ,UVISR ,GBUF%VAR,NUVAR )
1037 CALL USER_OUTPUT(IOUT,IGTYP,ROOTNAM,ROOTLEN,0)
1038 ELSE
1039 OPTION='/prop/user41'
1040 CALL ANCMSG(MSGID=1155,
1041 . ANMODE=ANINFO,
1042 . MSGTYPE=MSGERROR,
1043 . C1=OPTION)
1044 ENDIF
1045 ELSEIF (IGTYP == 42) THEN
1046 IF (USERL_AVAIL == 1) THEN
1047 CALL ST_USERLIB_RINIUSER(IGTYP,ROOTNAM,ROOTLEN,
1048 1 NEL ,I0 ,
1049 2 UIX ,UL ,GBUF%MASS ,UINER ,USTIFM ,
1050 3 USTIFR ,UVISM ,UVISR ,GBUF%VAR,NUVAR )
1051 CALL USER_OUTPUT(IOUT,IGTYP,ROOTNAM,ROOTLEN,0)
1052 ELSE
1053 OPTION='/prop/user42'
1054 CALL ANCMSG(MSGID=1155,
1055 . ANMODE=ANINFO,
1056 . MSGTYPE=MSGERROR,
1057 . C1=OPTION)
1058 ENDIF
1059 ENDIF
1060C
1061 DO I=LFT,LLT
1062 J=I+NFT
1063 I0=IXR(1,J)
1064 I1=IXR(2,J)
1065 I2=IXR(3,J)
1066 I3=IXR(4,J)
1067 XM = GBUF%MASS(I)
1068 XINE = UINER(I)
1069 AL2= UL(I)*UL(I)
1070 XKR= USTIFR(I)
1071 XKM= USTIFM(I)
1072 XCR= UVISR(I)
1073 XCM= UVISM(I)
1074 STIFN(I1)=STIFN(I1)+XKM
1075 STIFN(I2)=STIFN(I2)+XKM
1076 STIFR(I1)=STIFR(I1)+XKR
1077 STIFR(I2)=STIFR(I2)+XKR
1078 STRR(J)=XKR
1079 IF (XCM+XKM<EM15) XM =ONE
1080 IF (XCR+XKR<EM15) XINE=ONE
1081 XKM= MAX(EM15,XKM)
1082 XKR= MAX(EM15,XKR)
1083 DT=(SQRT(XCM*XCM+XM*XKM)-XCM)/XKM
1084 DTC=HALF*XM / MAX(EM15,XCM)
1085 DT = MIN(DT,DTC)
1086 DTC=(SQRT(XCR*XCR+XINE*XKR)-XCR)/XKR
1087 DT = MIN(DT,DTC)
1088 DTC=HALF*XINE / MAX( EM15,XCR)
1089 DT = MIN(DT,DTC)
1090 DTELEM(NDEPAR+I)= DT
1091 ENDDO
1092C
1093 CALL RINI2U(
1094 1 IXR ,GBUF%MASS,UINER,
1095 2 PARTSAV ,X ,V ,IPART(NFT+1),MSR(1,NFT+1),
1096 3 INR(1,NFT+1),MSRT ,EMS )
1097 IF (INISPRI /= 0)
1098 . CALL RUINI(
1099 2 SIGRS ,NSIGRS ,NUVAR ,GBUF%FOR(II(1)) ,
1100 3 GBUF%FOR(II(2)) ,GBUF%FOR(II(3)) ,GBUF%MOM(II(1)) ,GBUF%MOM(II(2)) ,GBUF%MOM(II(3)) ,
1101 4 GBUF%V_REPCVT(II(1)) ,GBUF%V_REPCVT(II(2)),GBUF%V_REPCVT(II(3)),GBUF%VR_REPCVT(II(1)),GBUF%VR_REPCVT(II(2)),
1102 5 GBUF%VR_REPCVT(II(3)),GBUF%VAR ,GBUF%EINT ,
1103 6 PTSPRI)
1104C=======================================================================
1105 ELSEIF (IGTYP == 44) THEN
1106C=======================================================================
1107 CALL RINI3U(GBUF%OFF ,GEO ,X ,UL ,IXR ,
1108 2 SKEW ,GBUF%SKEW ,ITAB ,UIX ,IGEO)
1109 NUVAR = NINT(GEO(25,I0))
1110 NUPARAM = NINT(GEO(26,I0))
1111 CALL RINI44(
1112 1 NEL ,IOUT ,I0 ,
1113 2 UIX ,UL ,GBUF%MASS ,UINER ,USTIFM ,
1114 3 USTIFR ,UVISM ,UVISR ,GBUF%VAR,NUVAR )
1115C
1116 DO I=LFT,LLT
1117 J=I+NFT
1118 I0=IXR(1,J)
1119 I1=IXR(2,J)
1120 I2=IXR(3,J)
1121 I3=IXR(4,J)
1122 XM = GBUF%MASS(I)
1123 XINE = UINER(I)
1124 AL2= UL(I)*UL(I)
1125 XKR= USTIFR(I)
1126 XKM= USTIFM(I)
1127 XCR= UVISR(I)
1128 XCM= UVISM(I)
1129 STIFN(I1)=STIFN(I1)+XKM
1130 STIFN(I2)=STIFN(I2)+XKM
1131 STIFR(I1)=STIFR(I1)+XKR
1132 STIFR(I2)=STIFR(I2)+XKR
1133 STRR(J)=XKR
1134 IF(XCM+XKM<EM15)XM =ONE
1135 IF(XCR+XKR<EM15)XINE=ONE
1136 XKM= MAX(EM15,XKM)
1137 XKR= MAX(EM15,XKR)
1138 DT=(SQRT(XCM*XCM+XM*XKM)-XCM)/XKM
1139 DTC=HALF*XM / MAX(EM15,XCM)
1140 DT = MIN(DT,DTC)
1141 DTC=(SQRT(XCR*XCR+XINE*XKR)-XCR)/XKR
1142 DT = MIN(DT,DTC)
1143 DTC=HALF*XINE / MAX( EM15,XCR)
1144 DT = MIN(DT,DTC)
1145 DTELEM(NDEPAR+I)= DT
1146 ENDDO
1147 CALL RINI2U(
1148 1 IXR ,GBUF%MASS,UINER,
1149 2 PARTSAV ,X ,V ,IPART(NFT+1),MSR(1,NFT+1),
1150 3 INR(1,NFT+1),MSRT ,EMS )
1151 IF (INISPRI /= 0)
1152 . CALL RUINI(
1153 2 SIGRS ,NSIGRS ,NUVAR ,GBUF%FOR(II(1)) ,
1154 3 GBUF%FOR(II(2)) ,GBUF%FOR(II(3)) ,GBUF%MOM(II(1)) ,GBUF%MOM(II(2)) ,GBUF%MOM(II(3)) ,
1155 4 GBUF%V_REPCVT(II(1)) ,GBUF%V_REPCVT(II(2)),GBUF%V_REPCVT(II(3)),GBUF%VR_REPCVT(II(1)),GBUF%VR_REPCVT(II(2)),
1156 5 GBUF%VR_REPCVT(II(3)),GBUF%VAR ,GBUF%EINT ,
1157 6 PTSPRI)
1158C=======================================================================
1159 ELSEIF (IGTYP == 46) THEN
1160C=======================================================================
1161 CALL RINI3U(GBUF%OFF ,GEO ,X ,UL ,IXR ,
1162 2 SKEW ,GBUF%SKEW ,ITAB ,UIX ,IGEO)
1163 NUVAR = NINT(GEO(25,I0))
1164 NUPARAM = NINT(GEO(26,I0))
1165 CALL RINI46(
1166 1 NEL ,IOUT ,I0 ,
1167 2 UIX ,UL ,GBUF%MASS ,UINER ,USTIFM ,
1168 3 USTIFR ,UVISM ,UVISR ,GBUF%VAR,NUVAR )
1169C
1170 DO I=LFT,LLT
1171 J=I+NFT
1172 I0=IXR(1,J)
1173 I1=IXR(2,J)
1174 I2=IXR(3,J)
1175 I3=IXR(4,J)
1176 XM = GBUF%MASS(I)
1177 XINE = UINER(I)
1178 AL2= UL(I)*UL(I)
1179 XKR= USTIFR(I)
1180 XKM= USTIFM(I)
1181 XCR= UVISR(I)
1182 XCM= UVISM(I)
1183 STIFN(I1)=STIFN(I1)+XKM
1184 STIFN(I2)=STIFN(I2)+XKM
1185 STIFR(I1)=STIFR(I1)+XKR
1186 STIFR(I2)=STIFR(I2)+XKR
1187 STRR(J)=XKR
1188 IF (XCM+XKM<EM15) XM =ONE
1189 IF (XCR+XKR<EM15) XINE=ONE
1190 XKM= MAX(EM15,XKM)
1191 XKR= MAX(EM15,XKR)
1192 DT=(SQRT(XCM*XCM+XM*XKM)-XCM)/XKM
1193 DTC=HALF*XM / MAX(EM15,XCM)
1194 DT = MIN(DT,DTC)
1195 DTC=(SQRT(XCR*XCR+XINE*XKR)-XCR)/XKR
1196 DT = MIN(DT,DTC)
1197 DTC=HALF*XINE / MAX( EM15,XCR)
1198 DT = MIN(DT,DTC)
1199 DTELEM(NDEPAR+I)= DT
1200 ENDDO
1201C
1202 CALL RINI2U(
1203 1 IXR ,GBUF%MASS,UINER,
1204 2 PARTSAV ,X ,V ,IPART(NFT+1),MSR(1,NFT+1),
1205 3 INR(1,NFT+1),MSRT ,EMS )
1206C
1207 IF (INISPRI /= 0)
1208 . CALL RUINI(
1209 2 SIGRS ,NSIGRS ,NUVAR ,GBUF%FOR(II(1)) ,
1210 3 GBUF%FOR(II(2)) ,GBUF%FOR(II(3)) ,GBUF%MOM(II(1)) ,GBUF%MOM(II(2)) ,GBUF%MOM(II(3)) ,
1211 4 GBUF%V_REPCVT(II(1)) ,GBUF%V_REPCVT(II(2)),GBUF%V_REPCVT(II(3)),GBUF%VR_REPCVT(II(1)),GBUF%VR_REPCVT(II(2)),
1212 5 GBUF%VR_REPCVT(II(3)),GBUF%VAR ,GBUF%EINT ,
1213 6 PTSPRI)
1214C-----
1215 ENDIF ! IGTYP
1216C------------------------------------------
1217C CALCUL DES DT ELEMENTAIRES & DT Nodal (take into account XCM)
1218C------------------------------------------
1219C
1220 K1 = 4
1221 K11 = 64
1222 K12 = K11 + 6
1223 K13 = K12 + 6
1224 K14 = K13 + 6
1225 DO I=LFT,LLT
1226 J=I+NFT
1227 I0=IXR(1,J)
1228 I1=IXR(2,J)
1229 I2=IXR(3,J)
1230 I3=IXR(4,J)
1231 IGTYP=IGEO(11,I0)
1232 IPID=IXR(1,I+NFT)
1233C
1234 IF (IGTYP == 4) THEN
1235 XM = GEO(1,I0)*XL(I)
1236 XKM= GEO(2,I0)*GEO(10,I0)/XL(I)
1237 XCM= (GEO(3,I0)) +GEO(141,I0) /XL(I)!
1238.AND. IF (XCM /= ZERO XKM /= ZERO) THEN
1239 DT=XM/(SQRT(XCM*XCM+XKM*XM)+XCM)
1240 ELSEIF (XKM /= ZERO) THEN
1241 DT=SQRT(XM/XKM)
1242 ELSEIF (XCM /= ZERO) THEN
1243 DT=XM/XCM
1244 ELSE
1245 DT=EP20
1246 ENDIF
1247 DTC=HALF*XM / MAX(EM15,XCM)
1248 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1249 MAS2 = TWO*MSR(1,J)
1250 IF (MAS2>ZERO) THEN
1251 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1252 ELSE
1253 STI = XKM
1254 END IF
1255 STIFN(I1)=STIFN(I1)+STI
1256 STIFN(I2)=STIFN(I2)+STI
1257 ELSEIF (IGTYP == 26) THEN
1258 XM = GEO(1,I0)*XL(I)
1259 XKM= GEO(2,I0)/XL(I)
1260 XCM= ZERO
1261 IF (XKM > ZERO) THEN
1262 DT=SQRT(XM/XKM)
1263 ELSE
1264 DT=EP20
1265 ENDIF
1266 DTC=HALF*XM / MAX(EM15,XCM)
1267 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1268 STIFN(I1)=STIFN(I1)+XKM
1269 STIFN(I2)=STIFN(I2)+XKM
1270 ELSEIF (IGTYP == 8) THEN
1271 XKM= MAX(GEO(3,I0)*GEO(41,I0),
1272 . GEO(10,I0)*GEO(45,I0),
1273 . GEO(15,I0)*GEO(49,I0))/XL(I)
1274 XCM= (MAX(GEO(4,I0),GEO(11,I0),GEO(16,I0))
1275 . + MAX(GEO(141,I0),GEO(142,I0),GEO(143,I0)))/XL(I)
1276 XKR= MAX(GEO(19,I0)*GEO(53,I0),
1277 . GEO(23,I0)*GEO(57,I0),
1278 . GEO(27,I0)*GEO(61,I0))/XL(I)
1279 XCR= (MAX(GEO(20,I0),GEO(24,I0),GEO(28,I0))
1280 . + MAX(GEO(144,I0),GEO(145,I0),GEO(146,I0)))/XL(I)
1281 XM=GEO(1,I0)*XL(I)
1282 XINE=GEO(9,I0)*XL(I)
1283 IF (XCM+XKM<EM15) XM =ONE
1284 IF (XCR+XKR<EM15) XINE=ONE
1285 XKM= MAX(EM15,XKM)
1286 XKR= MAX(EM15,XKR)
1287 DT=XM/MAX(EM15,SQRT(XCM*XCM+XKM*XM)+XCM)
1288 DTC=XINE/MAX(EM15,SQRT(XCR*XCR+XINE*XKR)+XCR)
1289 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1290 MAS2 = TWO*MSR(1,J)
1291 IF (MAS2>ZERO) THEN
1292 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1293 ELSE
1294 STI = XKM
1295 END IF
1296 STIFN(I1)=STIFN(I1)+STI
1297 STIFN(I2)=STIFN(I2)+STI
1298 MAS2 = INR(1,J)
1299 IF (MAS2>ZERO) THEN
1300 STI = (SQRT(XCR**2+XKR*MAS2)+XCR)**2/MAS2
1301 ELSE
1302 STI = XKR
1303 END IF
1304 STIFR(I1)=STIFR(I1)+STI
1305 STIFR(I2)=STIFR(I2)+STI
1306 STRR(J)=XKR
1307 ELSEIF(IGTYP == 12) THEN
1308 XM = GEO(1,I0)*XL(I)
1309 XKM= GEO(2,I0)/XL(I)
1310 XCM= (GEO(3,I0)+GEO(141,I0))/XL(I)
1311.AND. IF (XCM /= ZERO XKM /= ZERO) THEN
1312 DT=XM/(TWO*SQRT(XCM*XCM+XKM*XM)+XCM)
1313 ELSEIF (XKM /= ZERO) THEN
1314 DT=SQRT(XM/XKM)
1315 ELSEIF (XCM /= ZERO) THEN
1316 DT=XM/XCM
1317 ELSE
1318 DT=EP20
1319 ENDIF
1320 DTC=HALF*XM / MAX(EM15,XCM)
1321 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1322 MAS2 = TWO*MSR(2,J)
1323 IF (MAS2>ZERO) THEN
1324 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1325 ELSE
1326 STI = XKM
1327 END IF
1328 STIFN(I2)=STIFN(I2)+STI
1329 MAS2 = TWO*MSR(1,J)
1330 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1331 STIFN(I1)=STIFN(I1)+STI
1332 STIFN(I3)=STIFN(I3)+STI
1333 ELSEIF (IGTYP == 13) THEN
1334 EX=X(1,I2)-X(1,I1)
1335 EY=X(2,I2)-X(2,I1)
1336 EZ=X(3,I2)-X(3,I1)
1337 AL2= EX*EX+EY*EY+EZ*EZ
1338 XKM= MAX(GEO(3,I0)*GEO(41,I0),
1339 . GEO(10,I0)*GEO(45,I0),
1340 . GEO(15,I0)*GEO(49,I0))/XL(I)
1341 XCM= (MAX(GEO(4,I0),GEO(11,I0),GEO(16,I0))
1342 . + MAX(GEO(141,I0),GEO(142,I0),GEO(143,I0)) )/XL(I)
1343 XKR= MAX(GEO(10,I0)*GEO(45,I0),
1344 . GEO(15,I0)*GEO(49,I0)) * AL2
1345 XCR= (MAX(GEO(11,I0),GEO(16,I0))+ MAX(GEO(142,I0),GEO(143,I0)))* AL2
1346 XKR= ( XKR
1347 . +MAX(GEO(19,I0)*GEO(53,I0),
1348 . GEO(23,I0)*GEO(57,I0),
1349 . GEO(27,I0)*GEO(61,I0)))/XL(I)
1350 XCR= (XCR+MAX(GEO(20,I0),GEO(24,I0),GEO(28,I0))
1351 . + MAX(GEO(144,I0),GEO(145,I0),GEO(146,I0)) )/XL(I)
1352 XM=GEO(1,I0)*XL(I)
1353 XINE=GEO(9,I0)*XL(I)
1354 IF (XCM+XKM<EM15) XM =ONE
1355 IF (XCR+XKR<EM15) XINE=ONE
1356 XKM= MAX(EM15,XKM)
1357 XKR= MAX(EM15,XKR)
1358 DT=XM/MAX(EM15,SQRT(XCM*XCM+XKM*XM)+XCM)
1359 DTC=XINE/MAX(EM15,SQRT(XCR*XCR+XINE*XKR)+XCR)
1360 DT = MIN(DT,DTC)
1361 DTELEM(NDEPAR+I)= DT
1362 MAS2 = TWO*MSR(1,J)
1363 IF (MAS2>ZERO) THEN
1364 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1365 ELSE
1366 STI = XKM
1367 END IF
1368 STIFN(I1)=STIFN(I1)+STI
1369 STIFN(I2)=STIFN(I2)+STI
1370 MAS2 = TWO*INR(1,J)
1371 IF (MAS2>ZERO) THEN
1372 STI = (SQRT(XCR**2+XKR*MAS2)+XCR)**2/MAS2
1373 ELSE
1374 STI = XKR
1375 END IF
1376 STIFR(I1)=STIFR(I1)+STI
1377 STIFR(I2)=STIFR(I2)+STI
1378 STRR(J)=XKR
1379 ELSEIF (IGTYP == 23) THEN
1380 IMAT = IXR(5,I+NFT)
1381 IADBUF = IPM(7,IMAT) - 1
1382 MTN = IPM(2,IMAT)
1383 IF(MTN == 108) THEN
1384 XKM= MAX(UPARAM(IADBUF + K11 + 1)*UPARAM(IADBUF + K1 + 1),
1385 . UPARAM(IADBUF + K11 + 2)*UPARAM(IADBUF + K1 + 2),
1386 . UPARAM(IADBUF + K11 + 3)*UPARAM(IADBUF + K1 + 3))/XL(I)
1387 XCM= MAX(UPARAM(IADBUF + K12 + 1),UPARAM(IADBUF + K12 + 2),UPARAM(IADBUF + K12 + 3))
1388C
1389 XKR= MAX(UPARAM(IADBUF + K11 + 4)*UPARAM(IADBUF + K1 + 4),
1390 . UPARAM(IADBUF + K11 + 5)*UPARAM(IADBUF + K1 + 5),
1391 . UPARAM(IADBUF + K11 + 6)*UPARAM(IADBUF + K1 + 6))/XL(I)
1392C
1393 XCR= (MAX(UPARAM(IADBUF + K12 + 4),UPARAM(IADBUF + K12 + 5),UPARAM(IADBUF + K12 + 6)))/XL(I)
1394 ! old Geo 144,145,146 not used.
1395 XM = GBUF%MASS(I)*XL(I)
1396 XINE= GEO(2,I0)*XL(I)
1397 IF (XCM+XKM<EM15) XM =ONE
1398 IF (XCR+XKR<EM15) XINE=ONE
1399 XKM= MAX(EM15,XKM)
1400 XKR= MAX(EM15,XKR)
1401 DT =XM/MAX(EM15,SQRT(XCM*XCM+XKM*XM)+XCM)
1402 DTC=XINE/MAX(EM15,SQRT(XCR*XCR+XINE*XKR)+XCR)
1403 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1404 GEO(4,I0)= MIN(GEO(4,I0),DT,DTC) ! to be fixed also put it in buffer material
1405 MAS2 = TWO*MSR(1,J)
1406 INE2 = TWO*INR(1,J)
1407 ELSEIF (MTN==113) THEN
1408 EX=X(1,I2)-X(1,I1)
1409 EY=X(2,I2)-X(2,I1)
1410 EZ=X(3,I2)-X(3,I1)
1411 AL2= EX*EX+EY*EY+EZ*EZ
1412 XKM= MAX(UPARAM(IADBUF + K11 + 1)*UPARAM(IADBUF + K1 + 1),
1413 . UPARAM(IADBUF + K11 + 2)*UPARAM(IADBUF + K1 + 2),
1414 . UPARAM(IADBUF + K11 + 3)*UPARAM(IADBUF + K1 + 3))/XL(I)
1415 XCM= (MAX(UPARAM(IADBUF + K12 +1),UPARAM(IADBUF + K12 +2 ),UPARAM(IADBUF + K12 + 3))
1416 . + MAX(UPARAM(IADBUF + K14 + 1),UPARAM(IADBUF + K14 + 2),UPARAM(IADBUF + K14 + 3)))/XL(I)
1417 XKR= MAX(UPARAM(IADBUF + K11 + 2)*UPARAM(IADBUF + K1 + 2),
1418 . UPARAM(IADBUF + K11 + 3)*UPARAM(IADBUF + K1 + 3)) * AL2
1419 XCR= (MAX(UPARAM(IADBUF + K12 + 2),UPARAM(IADBUF + K12 + 3)) +
1420 . MAX(UPARAM(IADBUF + K14 + 2),UPARAM(IADBUF + K14 + 3)))* AL2
1421 XKR= ( XKR
1422 . + MAX(UPARAM(IADBUF + K11 + 4)*UPARAM(IADBUF + K1 + 4),
1423 . UPARAM(IADBUF + K11 + 5)*UPARAM(IADBUF + K1 + 5),
1424 . UPARAM(IADBUF + K11 + 6)*UPARAM(IADBUF + K1 + 6)))/XL(I)
1425 XCR= (XCR+MAX(UPARAM(IAD + K12 + 1),UPARAM(IADBUF + K12 + 2),UPARAM(IADBUF + K12 + 3))
1426 . + MAX(UPARAM(IAD + K14 + 4),UPARAM(IADBUF + K14 + 5),UPARAM(IADBUF + K14 + 6)) )/XL(I)
1427 XM =GBUF%MASS(I)
1428 XINE=GEO(2,I0)*XL(I)
1429 IF (XCM+XKM<EM15) XM =ONE
1430 IF (XCR+XKR<EM15) XINE=ONE
1431 XKM= MAX(EM15,XKM)
1432 XKR= MAX(EM15,XKR)
1433 DT =XM/MAX(EM15,SQRT(XCM*XCM+XKM*XM)+XCM)
1434 DTC=XINE/MAX(EM15,SQRT(XCR*XCR+XINE*XKR)+XCR)
1435 DT = MIN(DT,DTC)
1436 GEO(4,I0)= MIN(GEO(4,I0),DT)
1437 DTELEM(NDEPAR+I)= DT
1438 MAS2 = TWO*MSR(1,J)
1439 INE2 = TWO*INR(1,J)
1440 ELSEIF (MTN==114) THEN
1441 EX=X(1,I2)-X(1,I1)
1442 EY=X(2,I2)-X(2,I1)
1443 EZ=X(3,I2)-X(3,I1)
1444 AL2= EX*EX+EY*EY+EZ*EZ
1445C
1446 XKM= MAX(UPARAM(IADBUF + K11 + 1)*UPARAM(IADBUF + K1 + 1),
1447 . UPARAM(IADBUF + K11 + 2)*UPARAM(IADBUF + K1 + 2),
1448 . UPARAM(IADBUF + K11 + 3)*UPARAM(IADBUF + K1 + 3),
1449 . UPARAM(IADBUF+117)*GEO(1,I0))/XL(I)
1450C
1451 XCM= (MAX(UPARAM(IADBUF + K12 +1),UPARAM(IADBUF + K12 +2 ),UPARAM(IADBUF + K12 + 3))
1452 . + MAX(UPARAM(IADBUF + K14 + 1),UPARAM(IADBUF + K14 + 2),UPARAM(IADBUF + K14 + 3)))/XL(I)
1453 XKR= MAX(UPARAM(IADBUF + K11 + 2)*UPARAM(IADBUF + K1 + 2),
1454 . UPARAM(IADBUF + K11 + 3)*UPARAM(IADBUF + K1 + 3)) * AL2
1455 XCR= (MAX(UPARAM(IADBUF + K12 + 2),UPARAM(IADBUF + K12 + 3)) +
1456 . MAX(UPARAM(IADBUF + K14 + 2),UPARAM(IADBUF + K14 + 3)))* AL2
1457 XKR= ( XKR
1458 . + MAX(UPARAM(IADBUF + K11 + 4)*UPARAM(IADBUF + K1 + 4),
1459 . UPARAM(IADBUF + K11 + 5)*UPARAM(IADBUF + K1 + 5),
1460 . UPARAM(IADBUF + K11 + 6)*UPARAM(IADBUF + K1 + 6)))/XL(I)
1461 XCR= (XCR+MAX(UPARAM(IADBUF+K12 + 1),UPARAM(IADBUF+ K12 + 2),UPARAM(IADBUF+ K12 + 3))
1462 . + MAX(UPARAM(IADBUF+K14 + 4),UPARAM(IADBUF+ K14 + 5),UPARAM(IADBUF+ K14 + 6)) )/XL(I)
1463C-
1464 IF (UPARAM(IADBUF + 127) > ZERO) THEN
1465C- 1D material of 2D seatbelt - element mass and inertia recomputed for elementary time step
1466 RHO = UPARAM(IADBUF+128)
1467 XM = RHO*XL(I)*GEO(1,I0)
1468 XINE=MAX(EM20,MAX((RHO*GEO(1,I0)*LENGTH*LENGTH*LENGTH)/TWELVE+ RHO*IYY*LENGTH,RHO*IXX*LENGTH))
1469 GBUF%MASS(I) = XM*GBUF%FRAM_FACTOR(I)
1470 GBUF%INTVAR(I) = XINE*GBUF%FRAM_FACTOR(I)
1471 MAS2 = XM
1472 INE2 = XINE
1473 ELSE
1474 GBUF%FRAM_FACTOR(I) = ONE
1475 XM =GBUF%MASS(I)
1476 XINE=UINER(I)
1477 GBUF%INTVAR(I) = XINE
1478 MAS2 = TWO*MSR(1,J)
1479 INE2 = TWO*INR(1,J)
1480 ENDIF
1481C
1482 IF (GBUF%SLIPRING_STRAND(I) > 0) THEN
1483C---------> Update of third node if seatbelt spring in slipring------------
1484 SLIP = GBUF%SLIPRING_ID(I)
1485 FRA = GBUF%SLIPRING_FRAM_ID(I)
1486 DO KK=1,3
1487.AND. IF ((SLIPRING(SLIP)%FRAM(FRA)%NODE(KK)/=I1)(SLIPRING(SLIP)%FRAM(FRA)%NODE(KK)/=I2)) THEN
1488 IXR(4,J)=SLIPRING(SLIP)%FRAM(FRA)%NODE(KK)
1489 ENDIF
1490 ENDDO
1491 ELSEIF (GBUF%RETRACTOR_ID(I) < 0) THEN
1492C---------> Deactivation of elements initially in retractor------------
1493 GBUF%OFF(I) = ZERO
1494 GBUF%RETRACTOR_ID(I) = 0
1495 ENDIF
1496C
1497 IF (XCM+XKM<EM15) XM =ONE
1498 IF (XCR+XKR<EM15) XINE=ONE
1499 XKM= MAX(EM15,XKM)
1500 XKR= MAX(EM15,XKR)
1501 DT =XM/MAX(EM15,SQRT(XCM*XCM+XKM*XM)+XCM)
1502 DTC=XINE/MAX(EM15,SQRT(XCR*XCR+XINE*XKR)+XCR)
1503 DT = MIN(DT,DTC)
1504 GEO(4,I0)= MIN(GEO(4,I0),DT)
1505 DTELEM(NDEPAR+I)= DT
1506 ENDIF
1507 IF (MAS2>ZERO) THEN
1508 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1509 ELSE
1510 STI = XKM
1511 END IF
1512 STIFN(I1)=STIFN(I1)+STI
1513 STIFN(I2)=STIFN(I2)+STI
1514 IF (INE2>ZERO) THEN
1515 STI = (SQRT(XCR**2+XKR*INE2)+XCR)**2/INE2
1516 ELSE
1517 STI = XKR
1518 END IF
1519 STIFR(I1)=STIFR(I1)+STI
1520 STIFR(I2)=STIFR(I2)+STI
1521 STRR(J)=XKR
1522 ELSEIF (IGTYP == 25) THEN
1523 EX=X(1,I2)-X(1,I1)
1524 EY=X(2,I2)-X(2,I1)
1525 EZ=X(3,I2)-X(3,I1)
1526 AL2= EX*EX+EY*EY+EZ*EZ
1527 XKM= MAX(GEO(3,I0)*GEO(41,I0),
1528 . GEO(10,I0)*GEO(45,I0))/XL(I)
1529 XCM= (MAX(GEO(4,I0),GEO(11,I0))
1530 . + MAX(GEO(141,I0),GEO(142,I0)))/XL(I)
1531 XKR= GEO(10,I0)*GEO(45,I0)*AL2
1532 XKR= (XKR
1533 . +MAX(GEO(19,I0)*GEO(53,I0),GEO(23,I0)*GEO(57,I0)))/XL(I)
1534 XCR= (GEO(11,I0)+GEO(142,I0))*AL2
1535 XCR= (XCR+
1536 . MAX(GEO(141,I0),GEO(142,I0))+MAX(GEO(20,I0),GEO(24,I0))
1537 . +MAX(GEO(143,I0),GEO(144,I0)) )/XL(I)
1538 XM=GEO(1,I0)*XL(I)
1539 XINE=GEO(9,I0)*XL(I)
1540 IF (XCM+XKM<EM15) XM =ONE
1541 IF (XCR+XKR<EM15) XINE=ONE
1542 XKM= MAX(EM15,XKM)
1543 XKR= MAX(EM15,XKR)
1544 DT=XM/MAX(EM15,SQRT(XCM*XCM+XKM*XM)+XCM)
1545 DTC=XINE/MAX(EM15,SQRT(XCR*XCR+XINE*XKR)+XCR)
1546 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1547 MAS2 = TWO*MSR(1,J)
1548 IF (MAS2>ZERO) THEN
1549 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1550 ELSE
1551 STI = XKM
1552 END IF
1553 STIFN(I1)=STIFN(I1)+STI
1554 STIFN(I2)=STIFN(I2)+STI
1555 MAS2 = INR(1,J)
1556 IF (MAS2>ZERO) THEN
1557 STI = (SQRT(XCR**2+XKR*MAS2)+XCR)**2/MAS2
1558 ELSE
1559 STI = XKR
1560 END IF
1561 STIFR(I1)=STIFR(I1)+STI
1562 STIFR(I2)=STIFR(I2)+STI
1563 STRR(J)=XKR
1564 ELSEIF (IGTYP == 27) THEN
1565 XM = GEO(1,I0)*XL(I)
1566 XKM= GEO(2,I0)*GEO(10,I0)/XL(I)
1567 XCM= (GEO(3,I0)+GEO(141,I0))/XL(I)!
1568.AND. IF (XCM /= ZERO XKM /= ZERO) THEN
1569 DT=XM/(SQRT(XCM*XCM+XKM*XM)+XCM)
1570 ELSEIF (XKM /= ZERO) THEN
1571 DT=SQRT(XM/XKM)
1572 ELSEIF (XCM /= ZERO) THEN
1573 DT=XM/XCM
1574 ELSE
1575 DT=EP20
1576 ENDIF
1577 DTC=HALF*XM / MAX(EM15,XCM)
1578 DTELEM(NDEPAR+I)=MIN(DT,DTC)
1579 MAS2 = TWO*MSR(1,J)
1580 IF (MAS2>ZERO) THEN
1581 STI = (SQRT(XCM**2+XKM*MAS2)+XCM)**2/MAS2
1582 ELSE
1583 STI = XKM
1584 END IF
1585 STIFN(I1)=STIFN(I1)+STI
1586 STIFN(I2)=STIFN(I2)+STI
1587 END IF
1588 ENDDO
1589!
1590 IF (IPRELD>0) THEN
1591 SELECT CASE (IGTYP)
1592 CASE(4,13)
1593 J=1+NFT
1594 I0=IXR(1,J)
1595 IH = NINT(GEO(7,I0))
1596 IFUNC = IGEO(101,I0)
1597 IF (IFUNC==0) IH =0
1598.OR. IF (IH==0IH==8) THEN
1599 CALL ANCMSG(MSGID=3057,
1600 . MSGTYPE=MSGERROR,
1601 . ANMODE=ANINFO_BLIND_1,
1602 . I1=ID,
1603 . I2=IH,
1604 . C1=TITR)
1605 ELSE
1606 DO I=LFT,LLT
1607 XM=GEO(1,I0)*XL(I)
1608 UNDAMP = XM/DTELEM(NDEPAR+I)
1609 GBUF%BPRELD(I) = PRELOAD_A(IPRELD)%preload
1610 GBUF%BPRELD(I+NEL) = UNDAMP*PRELOAD_A(IPRELD)%damp
1611 ENDDO
1612 END IF
1613 CASE(23)
1614 IF (MTN==113) THEN
1615 J=1+NFT
1616 I0=IXR(1,J)
1617 IMAT = IXR(5,J)
1618 IFUNC = IPM(10 + 1,IMAT)
1619 IADBUF = IPM(7,IMAT) - 1
1620 IH= NINT(UPARAM(IADBUF + 4 + 12*6 + 1))
1621 IF (IFUNC==0) IH =0
1622.OR. IF (IH==0IH==8) THEN
1623 CALL ANCMSG(MSGID=3057,
1624 . MSGTYPE=MSGERROR,
1625 . ANMODE=ANINFO_BLIND_1,
1626 . I1=ID,
1627 . I2=IH,
1628 . C1=TITR)
1629 ELSE
1630 DO I=LFT,LLT
1631 XM=GBUF%MASS(I)
1632 UNDAMP = XM/DTELEM(NDEPAR+I)
1633 GBUF%BPRELD(I) = PRELOAD_A(IPRELD)%preload
1634 GBUF%BPRELD(I+NEL) = UNDAMP*PRELOAD_A(IPRELD)%damp
1635 ENDDO
1636.OR. END IF ! IH==0
1637 ELSE
1638 CALL ANCMSG(MSGID=3053,
1639 . MSGTYPE=MSGERROR,
1640 . ANMODE=ANINFO_BLIND_1,
1641 . I1=ID,
1642 . I2=IGTYP,
1643 . C1=TITR)
1644 END IF
1645 CASE DEFAULT
1646 CALL ANCMSG(MSGID=3053,
1647 . MSGTYPE=MSGERROR,
1648 . ANMODE=ANINFO_BLIND_1,
1649 . I1=ID,
1650 . I2=IGTYP,
1651 . C1=TITR)
1652 END SELECT
1653!
1654 END IF
1655C-----
1656 1000 FORMAT('list of possible cnodes merged with node of id=',I10)
1657C-----
1658 RETURN
rini32
subroutine rini32(nel, iout, iprop, ix, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar, id, titr, eint, npf, tf)
Definition hm_read_prop32.F:356
rini36
subroutine rini36(nel, iout, iprop, ix, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar)
Definition hm_read_prop36.F:270
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
bpreload_mod
Definition bpreload_mod.F:40
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
seatbelt_mod
Definition seatbelt_mod.F:55
noise
subroutine noise(dt2r, in, j, buf, v, a, ixs, elbuf_tab, iparg, weight, ixq)
Definition noise.F:41
r1buf3
subroutine r1buf3(off, geo, x, al, ix, ipos, igeo)
Definition r1buf3.F:30
r2buf3
subroutine r2buf3(off, geo, x, x0, y0, z0, ix, skew, iposx, iposy, iposz, iposxx, iposyy, iposzz, igeo, skew_id)
Definition r2buf3.F:33
r3buf3
subroutine r3buf3(off, geo, x, al, ix, ipos, igeo, itab)
Definition r3buf3.F:35
r4buf3
subroutine r4buf3(off, geo, x, x0, y0, z0, ix, skew, rloc, iposx, iposy, iposz, iposxx, iposyy, iposzz, itab, eint6, igeo, ipm)
Definition r4buf3.F:37
rini33
subroutine rini33(nel, iout, iprop, ix, xl, mass, xiner, stifn, stifr, viscm, viscr, uvar, nuvar)
Definition rini33.F:38
rini35
subroutine rini35(nel, iout, iprop, ix, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar)
Definition rini35.F:38
rini45
subroutine rini45(nel, iout, iprop, ix, x, xl, mass, xiner, stifn, stifr, viscm, viscr, uvar, nuvar, ixr, ixr_kj, id, titr)
Definition rini45.F:41
r8ini
subroutine r8ini(igtyp, nel, sigrs, ixr, nsigi, fx, fy, fz, mx, my, mz, fxep, fyep, fzep, xmep, ymep, zmep, dxpl, dypl, dzpl, rpx, rpy, rpz, dxpl2, dypl2, dzpl2, rpx2, rpy2, rpz2, dx, dy, dz, rx, ry, rz, xl0, yl0, zl0, eint, e6, ptspri, dx0, dy0, dz0, rx0, ry0, rz0, fx0, fy0, fz0, mx0, my0, mz0)
Definition rinit3.F:2018
rini3u
subroutine rini3u(off, geo, x, x0, ix, skew, rloc, itab, uix, igeo)
Definition rinit3.F:1667
rini2u
subroutine rini2u(ixr, umass, uiner, partsav, x, v, ipart, msr, inr, msrt, ems)
Definition rinit3.F:1854
rini1u
subroutine rini1u(off, geo, x, x0, ix, skew, rloc, itab, uix, igeo)
Definition rinit3.F:1765
ruini
subroutine ruini(sigrs, nsigi, nuvar, fx, fy, fz, xmom, ymom, zmom, dx, dy, dz, rx, ry, rz, uvar, eint, ptspri)
Definition rinit3.F:2122
r4ini
subroutine r4ini(sigrs, ixr, nsigi, eint, f, dl, fep, dpl, dpl2, xl0, dfs, dv, igtyp, ptspri, dl0, f0)
Definition rinit3.F:1944
rkini3
subroutine rkini3(ifunct, npc, pld, xk, ecrou, igeo, a, lscale, id, titr, nom_opt)
Definition rkini3.F:35
rmas12
subroutine rmas12(ixr, geo, partsav, x, v, ipart, xl, msr, inr, msrt)
Definition rmas12.F:30
rmass
subroutine rmass(ixr, geo, ms, xin, partsav, x, v, ipart, xl, msr, inr, msrt, ems)
Definition rmass.F:31
r23mass
subroutine r23mass(ixr, geo, ms, xin, partsav, x, v, ipart, xl, msr, inr, msrt, ems, mass, uiner, mtyp)
Definition rmass.F:122
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
bidon
subroutine bidon
Definition machine.F:41
strr
character *8 function strr(y)
Definition strr.F:34
user_output
subroutine user_output(iout, ilaw, rootn, rootlen, inpf)
Definition user_output.F:38

◆ ruini()

subroutine ruini ( sigrs,
integer nsigi,
integer nuvar,
fx,
fy,
fz,
xmom,
ymom,
zmom,
dx,
dy,
dz,
rx,
ry,
rz,
uvar,
eint,
integer, dimension(*) ptspri )

Definition at line 2116 of file rinit3.F.

2122C-----------------------------------------------
2123C I m p l i c i t T y p e s
2124C-----------------------------------------------
2125#include "implicit_f.inc"
2126C-----------------------------------------------
2127C C o m m o n B l o c k s
2128C-----------------------------------------------
2129#include "vect01_c.inc"
2130#include "com01_c.inc"
2131C-----------------------------------------------
2132C D u m m y A r g u m e n t s
2133C-----------------------------------------------
2134 INTEGER NUVAR,NSIGI
2135 INTEGER PTSPRI(*)
2136C REAL
2137 my_real
2138 . fx(*),fy(*),fz(*),xmom(*),ymom(*),zmom(*),
2139 . eint(*),sigrs(nsigi,*),
2140 . uvar(nuvar,*),dx(*),dy(*),dz(*),rx(*),ry(*),rz(*)
2141C-----------------------------------------------
2142C L o c a l V a r i a b l e s
2143C-----------------------------------------------
2144 INTEGER I,II,JJ,K,PT
2145C-----------------------------------------------
2146C---
2147C CONTRAINTES INITIALES + OTHERS
2148C---
2149 IF (inispri /= 0) THEN
2150C
2151 DO i=lft,llt
2152 ii = i+nft
2153 jj = ptspri(ii)
2154 IF (jj == 0) GOTO 200
2155C---
2156 fx(i) = sigrs(2, jj)
2157 dx(i) = sigrs(3, jj)
2158 fy(i) = sigrs(4, jj)
2159 dy(i) = sigrs(5, jj)
2160 fz(i) = sigrs(6, jj)
2161 dz(i) = sigrs(7, jj)
2162 xmom(i) = sigrs(8, jj)
2163 rx(i) = sigrs(9,jj)
2164 ymom(i) = sigrs(10,jj)
2165 ry(i) = sigrs(11,jj)
2166 zmom(i) = sigrs(12,jj)
2167 rz(i) = sigrs(13,jj)
2168 eint(i) = sigrs(14,jj)
2169C
2170 pt = 14
2171 DO k=1,nuvar
2172 uvar(k,i) = sigrs(pt + k ,jj)
2173 ENDDO
2174C---
2175 200 CONTINUE
2176 ENDDO ! DO I=LFT,LLT
2177 ENDIF ! IF (INISPRI /= 0)
2178C-----------
2179 RETURN