OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rinit3.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| rinit3 ../starter/source/elements/spring/rinit3.F
25!||--- called by ------------------------------------------------------
26!|| initia ../starter/source/elements/initia/initia.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl2 ../starter/source/starter/freform.F
30!|| r1buf3 ../starter/source/elements/spring/r1buf3.F
31!|| r23mass ../starter/source/elements/spring/rmass.F
32!|| r2buf3 ../starter/source/elements/spring/r2buf3.f
33!|| r3buf3 ../starter/source/elements/spring/r3buf3.F
34!|| r4buf3 ../starter/source/elements/spring/r4buf3.F
35!|| r4ini ../starter/source/elements/spring/rinit3.F
36!|| r8ini ../starter/source/elements/spring/rinit3.F
37!|| rini1u ../starter/source/elements/spring/rinit3.F
38!|| rini2u ../starter/source/elements/spring/rinit3.F
39!|| rini32 ../starter/source/properties/spring/hm_read_prop32.F
40!|| rini33 ../starter/source/elements/joint/rjoint/rini33.F
41!|| rini35 ../starter/source/elements/spring/rini35.F
42!|| rini36 ../starter/source/properties/spring/hm_read_prop36.F
43!|| rini3u ../starter/source/elements/spring/rinit3.F
44!|| rini44 ../starter/source/elements/spring/rini44.F
45!|| rini45 ../starter/source/elements/joint/rjoint/rini45.F
46!|| rini46 ../starter/source/elements/spring/rini46.F
47!|| rkini3 ../starter/source/elements/spring/rkini3.F
48!|| rmas12 ../starter/source/elements/spring/rmas12.F
49!|| rmass ../starter/source/elements/spring/rmass.F
50!|| ruini ../starter/source/elements/spring/rinit3.f
51!|| user_output ../starter/source/user_interface/user_output.F
52!||--- uses -----------------------------------------------------
53!|| bpreload_mod ../starter/share/modules1/bpreload_mod.F
54!|| format_mod ../starter/share/modules1/format_mod.F90
55!|| message_mod ../starter/share/message_module/message_mod.F
56!||====================================================================
57 SUBROUTINE rinit3(ELBUF_STR,
58 . IXR ,X ,GEO ,XMAS ,NPC ,
59 . PLD ,XIN ,SKEW ,DTELEM ,NEL ,
60 . STIFN ,STIFR ,PARTSAV ,V ,IPART ,
61 . ITAB ,MSR ,
62 . INR ,STIFINT ,STR ,IGEO ,SIGRS ,
63 . NSIGRS ,IMERGE2 ,IADMERGE2,MSRT ,IXR_KJ,
64 . NOM_OPT ,STRR ,PTSPRI ,IPM ,PM ,
65 . UPARAM ,R_SKEW ,PRELOAD_A,IPRELD ,NPRELOAD_A,
66 . IKINE)
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
76 use element_mod , only : nixr
77C-----------------------------------------------
78C I m p l i c i t T y p e s
79C-----------------------------------------------
80#include "implicit_f.inc"
81C-----------------------------------------------
82C G l o b a l P a r a m e t e r s
83C-----------------------------------------------
84#include "mvsiz_p.inc"
85C-----------------------------------------------
86C C o m m o n B l o c k s
87C-----------------------------------------------
88#include "param_c.inc"
89#include "units_c.inc"
90#include "vect01_c.inc"
91#include "com01_c.inc"
92#include "com04_c.inc"
93#include "random_c.inc"
94#include "scr12_c.inc"
95#include "scr17_c.inc"
96#include "userlib.inc"
97#include "scr15_c.inc"
98#include "kincod_c.inc"
99C-----------------------------------------------
100C D u m m y A r g u m e n t s
101C-----------------------------------------------
102 INTEGER IXR(NIXR,*), NPC(*),IPART(*),ITAB(*),NEL,
103 . IGEO(NPROPGI,*),NSIGRS,IMERGE2(NUMNOD+1),
104 . IADMERGE2(NUMNOD+1),IXR_KJ(5,*),PTSPRI(*),
105 . IPM(NPROPMI,*),R_SKEW(*)
106 INTEGER NOM_OPT(LNOPT1,*)
107 INTEGER , INTENT (IN) :: IPRELD,NPRELOAD_A
108 INTEGER , INTENT (IN) :: IKINE(3*NUMNOD)
109C REAL
110 my_real
111 . x(3,*), geo(npropg,*), xmas(*), pld(*), xin(*),
112 . skew(lskew,*), dtelem(*),stifn(*),stifr(*),partsav(20,*), v(*),
113 . msr(3,*), inr(3,*),
114 . stifint(*), str(*),sigrs(nsigrs,*), msrt(*),strr(*),uparam(*),
115 . pm(npropm,*)
116C
117 TYPE(elbuf_struct_), TARGET :: ELBUF_STR
118 TYPE(PREL1D_) , DIMENSION(NPRELOAD_A), TARGET :: PRELOAD_A
119C-----------------------------------------------
120C L o c a l V a r i a b l e s
121C-----------------------------------------------
122 INTEGER I,J,I2, IGTYP, NDEPAR,
123 . K,KK,KK1,ITMP,
124 . I1, I0, I3,NUVAR,NUPARAM,NFUNC,IADFUN,
125 . ILENG,NFUND,
126 3 uix(4,mvsiz),
127 . imat,k1,k11,k14,k12,k13,iadbuf,imass,slip,fra,ih,nkin,
128 . kcond1,kcond2
129C REAL
130 my_real
131 . dt, dtc, xkm, xcm, xkr, xcr, xm, xine, ex, ey, ez,
132 . al2, sti,rho,kx,kxy,kxz,
133 . ul(mvsiz),
134 . uiner(mvsiz) ,ustifm(mvsiz) ,
135 . ustifr(mvsiz),uvism(mvsiz) ,
136 . uvisr(mvsiz), xl(mvsiz), dx(mvsiz,3),ems(mvsiz)
137 my_real
138 . length, ratio, lmin
139 my_real
140 . minl, maxl, rfac, ixx, iyy, ine2
141 INTEGER IDS, CNT1, CNT2, NSPRG, NSPRG4, NSPRG8, NSPRG12,
142 . NSPRG13, NSPRG25, NSPRG26, NSPRGU, IUN,NSPRG23,NSPRG27
143 DATA NSPRG /0/, NSPRG4 /0/, NSPRG8 /0/, NSPRG12 /0/,
144 . NSPRG13 /0/, NSPRG25 /0/,NSPRG26/0/,NSPRGU /0/,
145 . NSPRG23 /0/,NSPRG27/0/
146 INTEGER MINIDL, MAXIDL,IPID,IFUNC
147 my_real
148 . noise,bidon,mas2,undamp
149 INTEGER ID
150 CHARACTER(LEN=NCHARTITLE)::TITR
151 CHARACTER OPTION*50
152C
153 TYPE(g_bufel_),POINTER :: GBUF
154 INTEGER II(6)
155 my_real :: dfs(2), dv(2)
156C=======================================================================
157 bidon = zero
158C
159 gbuf => elbuf_str%GBUF
160C
161 DO i=1,6
162 ii(i) = (i-1)*nel + 1
163 ENDDO
164C
165 iun = 1
166 noise = two*sqrt(three)*xalea
167C
168 DO i=1,numgeo
169 igtyp=igeo(11,i)
170 id=igeo(1,i)
171 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i),ltitr)
172 IF (igtyp == 4 .OR. igtyp == 12 .OR. igtyp == 27) THEN
173 CALL rkini3(igeo(101,i),npc,pld,geo(2,i),geo(7,i),igeo(1,i),
174 . geo(10,i) ,geo(39,i) ,id,titr,nom_opt)
175 ELSEIF (igtyp == 8 .OR. igtyp == 13) THEN
176 CALL rkini3(igeo(101,i),npc,pld,geo(3,i) , geo(7,i) , igeo(1,i),
177 . geo(41,i) ,geo(39,i) ,id,titr,nom_opt)
178 CALL rkini3(igeo(104,i),npc,pld,geo(10,i), geo(14,i), igeo(1,i),
179 . geo(45,i) ,geo(174,i) ,id,titr,nom_opt)
180 CALL rkini3(igeo(107,i),npc,pld,geo(15,i), geo(18,i), igeo(1,i),
181 . geo(49,i) ,geo(175,i) ,id,titr,nom_opt)
182 CALL rkini3(igeo(110,i),npc,pld,geo(19,i), geo(22,i), igeo(1,i),
183 . geo(53,i) ,geo(176,i) ,id,titr,nom_opt)
184 CALL rkini3(igeo(113,i),npc,pld,geo(23,i), geo(26,i), igeo(1,i),
185 . geo(57,i) ,geo(177,i) ,id,titr,nom_opt)
186 CALL rkini3(igeo(116,i),npc,pld,geo(27,i), geo(30,i), igeo(1,i),
187 . geo(61,i) ,geo(178,i) ,id,titr,nom_opt)
188 ELSEIF (igtyp == 25) THEN
189 CALL rkini3(igeo(102,i),npc,pld,geo(3,i) , geo(7,i) , igeo(1,i),
190 . geo(41,i) ,geo(39,i) ,id,titr,nom_opt)
191 CALL rkini3(igeo(106,i),npc,pld,geo(10,i), geo(14,i), igeo(1,i),
192 . geo(45,i) ,geo(174,i) ,id,titr,nom_opt)
193 CALL rkini3(igeo(110,i),npc,pld,geo(19,i), geo(22,i), igeo(1,i),
194 . geo(53,i) ,geo(176,i) ,id,titr,nom_opt)
195 CALL rkini3(igeo(114,i),npc,pld,geo(23,i), geo(26,i), igeo(1,i),
196 . geo(57,i) ,geo(177,i) ,id,titr,nom_opt)
197 ELSEIF (igtyp == 26) THEN
198 nfunc = igeo(20,i)
199 nfund = igeo(21,i)
200 iadfun = 100
201 DO j = 1,nfunc
202 CALL rkini3(igeo(iadfun+j,i),npc,pld,geo(2,i),one, igeo(1,i),
203 . one ,one ,id,titr,nom_opt)
204 ENDDO
205 iadfun = nfund+100
206 DO j = 1,nfund
207 CALL rkini3(igeo(iadfun+j,i),npc,pld,geo(2,i),one, igeo(1,i),
208 . one ,one ,id,titr,nom_opt)
209 ENDDO
210 ELSEIF (igtyp == 23) THEN
211 geo(4,i) = ep30 !
212 ENDIF ! IF (IGTYP
213 ENDDO ! DO I=1,NUMGEO
214C
215 CALL ancmsg(msgid=506,
216 . msgtype=msgwarning,
217 . anmode=aninfo_blind_1,
218 . prmod=msg_print)
219C-----------------
220 ipid=ixr(1,nft+1)
221 id=igeo(1,ipid)
222 CALL fretitl2(titr,igeo(npropgi-ltitr+1,ipid),ltitr)
223 DO i=lft,llt
224 j=i+nft
225 i0=ixr(1,j)
226 i1=ixr(2,j)
227 i2=ixr(3,j)
228 i3=ixr(4,j)
229C-----------------
230 IF (i1 == i2 .OR. i1 == i3 .OR. i2 == i3) THEN
231 IF (i1 == i2 .OR. i1 == i3) itmp = i1
232 IF (i2 == i3) itmp = i2
233 IF (imerge2(itmp) /= 0) THEN
234 CALL ancmsg(msgid=682,
235 . msgtype=msgwarning,
236 . anmode=aninfo_blind_1,
237 . i1=ixr(nixr,j),
238 . i2=itab(itmp))
239 WRITE (iout,1000) itab(itmp)
240 kk = 0
241 DO k=1,iadmerge2(itmp+1) - iadmerge2(itmp)
242 kk = kk + 1
243 IF (kk == 10) THEN
244 WRITE (iout,fmt=fmt_10i)(itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
245 kk = 0
246 ENDIF
247 ENDDO
248 IF (kk /= 0) THEN
249 WRITE (iout,fmt=fmt_10i)
250 . (itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
251 ENDIF
252 ELSE
253 CALL ancmsg(msgid=681,
254 . msgtype=msgerror,
255 . anmode=aninfo_blind_1,
256 . i1=ixr(nixr,j) )
257 ENDIF ! IF (IMERGE2(ITMP) /= 0)
258 ENDIF ! IF (I1 == I2 .OR. I1 == I3 .OR. I2 == I3)
259C-----------------
260 igtyp=igeo(11,i0)
261 IF (igtyp /= 4 .AND. igtyp /= 8 .AND.
262 . igtyp /= 12 .AND. igtyp /= 13 .AND. igtyp /= 25 .AND.
263 . igtyp /= 44 .AND. igtyp /= 26 .AND. igtyp < 29 .AND.
264 . igtyp /= 46 .AND. igtyp /= 23 .AND. igtyp /= 27) THEN
265 CALL ancmsg(msgid=243,
266 . msgtype=msgerror,
267 . anmode=aninfo_blind_1,
268 . i1=id,
269 . c1=titr)
270 ENDIF
271C check compatibility of property type with spring elements.
272 IF (igtyp > 33 .AND. igtyp /= 35 .AND. igtyp /= 36 .AND.
273 . igtyp /= 44 .AND. igtyp /= 45 .AND. igtyp /= 46) THEN
274 CALL ancmsg(msgid=243,
275 . msgtype=msgerror,
276 . anmode=aninfo_blind_1,
277 . i1=id,
278 . c1=titr)
279 ENDIF
280 ENDDO
281C-----
282 i0=ixr(1,1+nft)
283 id=igeo(1,i0)
284 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
285 igtyp = igeo(11,i0)
286 IF (igtyp == 12) THEN
287 DO i=lft,llt
288 IF (ixr(4,i+nft) == 0) THEN
289 ipid=ixr(1,i+nft)
290 CALL ancmsg(msgid=244,
291 . msgtype=msgerror,
292 . anmode=aninfo,
293 . i1=id,
294 . c1=titr,
295 . i2=ixr(nixr,i+nft))
296 ENDIF
297 ENDDO
298 ENDIF
299C
300 ids = 328
301 cnt1 = 0
302 cnt2 = 0
303 nsprg = 0
304c CALL ANCNTS(IDS, CNT2)
305 DO i=lft,llt
306 j=i+nft
307 i0=ixr(1,j)
308 i1=ixr(2,j)
309 i2=ixr(3,j)
310 i3=ixr(4,j)
311 igtyp=igeo(11,i0)
312 ileng=nint(geo(93,i0))
313 IF (igtyp == 4) THEN
314 nsprg4 = nsprg4 + 1
315 ELSE IF (igtyp == 8) THEN
316 nsprg8 = nsprg8 + 1
317 ELSE IF (igtyp == 12) THEN
318 nsprg12 = nsprg12 + 1
319 ELSE IF (igtyp == 13) THEN
320 nsprg13 = nsprg13 + 1
321 ELSE IF (igtyp == 23) THEN
322 nsprg23 = nsprg23 + 1
323 imat = ixr(5,i+nft)
324 iadbuf = ipm(7,imat) - 1
325 ileng = nint(uparam(iadbuf + 2))
326 imass = igeo(4,i0)
327 mtn = ipm(2,imat)
328 IF(mtn == 114) THEN
329 imass = 1
330 lmin = max(uparam(iadbuf + 119),uparam(iadbuf + 126))
331 ENDIF
332 ELSE IF (igtyp == 25) THEN
333 nsprg25 = nsprg25 + 1
334 ELSE IF (igtyp == 26) THEN
335 nsprg26 = nsprg26 + 1
336 ELSE IF (igtyp == 27) THEN
337 nsprg27 = nsprg27 + 1
338 ELSE
339 nsprgu = nsprgu + 1
340 ENDIF
341 IF (ileng > 0) THEN
342 xl(i) = sqrt(
343 . (x(1,i1)-x(1,i2))*(x(1,i1)-x(1,i2))
344 + + (x(2,i1)-x(2,i2))*(x(2,i1)-x(2,i2))
345 + + (x(3,i1)-x(3,i2))*(x(3,i1)-x(3,i2)) )
346 IF (igtyp == 12) THEN
347 xl(i) = xl(i) + sqrt(
348 . (x(1,i3)-x(1,i2))*(x(1,i3)-x(1,i2))
349 + + (x(2,i3)-x(2,i2))*(x(2,i3)-x(2,i2))
350 + + (x(3,i3)-x(3,i2))*(x(3,i3)-x(3,i2)) )
351 ENDIF
352 IF (mtn == 114) xl(i) = max(xl(i),lmin)
353 IF (xl(i) <= noise) THEN
354 ipid = ixr(1,i)
355 CALL ancmsg(msgid=328,
356 . msgtype=msgerror,
357 . anmode=aninfo_blind_1,
358 . i1=id,
359 . c1=titr,
360 . i2=ixr(nixr,j))
361 ENDIF
362 ELSE
363 xl(i)=one
364 ENDIF
365 ENDDO
366C
367c CALL ANCNTG(IDS, CNT1, CNT2)
368 nsprg = nsprg + cnt2
369 minl = zero
370 maxl = zero
371 minidl = 0
372 maxidl = 0
373 DO i=lft,llt
374 j=i+nft
375 i0=ixr(1,j)
376 i1=ixr(2,j)
377 i2=ixr(3,j)
378 i3=ixr(4,j)
379 igtyp=igeo(11,i0)
380C
381 length = sqrt(
382 . (x(1,i1)-x(1,i2))*(x(1,i1)-x(1,i2))
383 + + (x(2,i1)-x(2,i2))*(x(2,i1)-x(2,i2))
384 + + (x(3,i1)-x(3,i2))*(x(3,i1)-x(3,i2)) )
385 IF (igtyp == 12) THEN
386 length = length + sqrt(
387 . (x(1,i3)-x(1,i2))*(x(1,i3)-x(1,i2))
388 + + (x(2,i3)-x(2,i2))*(x(2,i3)-x(2,i2))
389 + + (x(3,i3)-x(3,i2))*(x(3,i3)-x(3,i2)) )
390 ENDIF
391C
392 IF (minl <= 0 .OR. (length < minl .AND. length > em15)) THEN
393 minidl = ixr(nixr,j)
394 minl = length
395 ENDIF
396C
397 IF (length > maxl) THEN
398 maxidl = ixr(nixr,j)
399 maxl = length
400 ENDIF
401C
402 IF(igtyp == 8 .OR. igtyp==13 .OR. igtyp==25) THEN
403 ileng=nint(geo(93,i0))
404C
405 IF (ileng > 0) THEN
406 xm=geo(1,i0)*xl(i)
407 xine=geo(9,i0)*xl(i)
408 ELSE
409 xm=geo(1,i0)
410 xine=geo(9,i0)
411 ENDIF
412C
413C---- For prop type8 - skew per element is used if available
414 IF ((igtyp == 8).AND.( r_skew(i+nft) > 0)) THEN
415 gbuf%SKEW_ID(i) = r_skew(i+nft)
416 ELSEIF (igtyp == 8) THEN
417C---- For prop type8 - skew of property is used if no skew per element
418 gbuf%SKEW_ID(i) = igeo(2,i0)
419 r_skew(i+nft) = igeo(2,i0)
420 ENDIF
421C
422 ratio = xm * length * length
423 IF ( (.NOT.((igtyp == 8).AND.(length < em15))) .AND.
424 . (xine < ratio/ep03 .OR. xine > ratio*ep03) ) THEN
425 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
426 CALL ancmsg(msgid=432,
427 . msgtype=msgwarning,
428 . anmode=aninfo_blind_2,
429 . i1=igeo(1,i0),
430 . c1=titr,
431 . r2=ratio,
432 . r1=xine,
433 . i2=ixr(nixr,i+nft),
434 . prmod=msg_cumu)
435 ENDIF
436 ELSEIF(igtyp == 23) THEN
437 imat = ixr(5,i+nft)
438 iadbuf = ipm(7,imat) - 1
439 ileng = nint(uparam(iadbuf + 2))
440 rho = pm(1,imat)
441 imass = igeo(4,i0)
442 mtn = ipm(2,imat)
443 uiner(i) = zero
444C---- For mat law108 skew per element is used if available
445 IF ((mtn == 108).AND.( r_skew(i+nft) > 0)) THEN
446 gbuf%SKEW_ID(i) = r_skew(i+nft)
447 ELSEIF (mtn == 108) THEN
448C---- For mat law108 skew of property 23 is used if no skew per element
449 gbuf%SKEW_ID(i) = igeo(2,i0)
450 ELSEIF (mtn == 114) THEN
451C---- For mat law114 lmin is used for mass setting of element with null length
452 imass = 1
453 IF (gbuf%RETRACTOR_ID(i) < 0) THEN
454 lmin = max(uparam(iadbuf + 119),uparam(iadbuf + 126))
455 ELSE
456 lmin = uparam(iadbuf + 119)
457 ENDIF
458 rfac = uparam(iadbuf + 124)
459 ixx = uparam(iadbuf + 122)
460 iyy = uparam(iadbuf + 123)
461 length = max(length,lmin)
462 IF (uparam(iadbuf + 127) > zero) THEN
463C- 1D material of 2D seatbelt - no need for inertia - mass and inertia given by shell
464 rfac = zero
465 ENDIF
466C- inertia of element is automatically computed according to moment of inertia area if Young modulus > 0
467 uiner(i) = max(em20,rfac*max((rho*geo(1,i0)*length*length*length)/twelve + rho*iyy*length,rho*ixx*length))
468 ENDIF
469C
470 IF(imass == 1) THEN
471 gbuf%MASS(i) = geo(1,i0)*length*rho
472 IF ((length == zero).AND.(rho /= zero)) THEN
473 ipid = ixr(1,i)
474 nkin = ikine(i1)
475 kcond1 = irb(nkin)+irb2(nkin)
476 nkin = ikine(i2)
477 kcond2 = irb(nkin)+irb2(nkin)
478 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
479 IF (((xmas(i1) > zero).OR.(kcond1 > 0)).AND.((xmas(i2) > zero).OR.(kcond1 > 0)).AND.(mtn == 108)) THEN
480C- imass = 1 (mass per unit lenght) + null length accepted for law108
481C- if nodes have masses are or connected to rbodies - only a warning is printed
482 CALL ancmsg(msgid=3103,
483 . msgtype=msgwarning,
484 . anmode=aninfo_blind_1,
485 . i1=id,
486 . c1=titr,
487 . i2=ixr(nixr,i))
488 ELSE
489 CALL ancmsg(msgid=1664,
490 . msgtype=msgerror,
491 . anmode=aninfo_blind_1,
492 . i1=id,
493 . c1=titr,
494 . i2=ixr(nixr,i))
495 ENDIF
496 ENDIF
497 ELSEIF(imass == 2) THEN
498 gbuf%MASS(i) = geo(1,i0)*rho
499 ENDIF
500C
501
502 xm = gbuf%MASS(i)
503 xine = geo(2,i0)
504
505C
506 ratio = xm * length * length
507 IF( mtn == 113) THEN
508 IF ( ((length < em15)) .AND.
509 . (xine < ratio/ep03 .OR. xine > ratio*ep03) ) THEN
510 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
511 CALL ancmsg(msgid=432,
512 . msgtype=msgwarning,
513 . anmode=aninfo_blind_2,
514 . i1=igeo(1,i0),
515 . c1=titr,
516 . r2=ratio,
517 . r1=xine,
518 . i2=ixr(nixr,i+nft),
519 . prmod=msg_cumu)
520 ENDIF
521 ENDIF
522 ENDIF
523 ENDDO ! DO I=LFT,LLT
524C
525 CALL ancmsg(msgid=432,
526 . msgtype=msgwarning,
527 . anmode=aninfo_blind_2,
528 . prmod=msg_print)
529C------------------------------------------
530C initialization of nodal rigidities for interfaces
531C------------------------------------------
532 IF (i7stifs /= 0) THEN
533 IF (igtyp == 4 .OR. igtyp == 12 .OR. igtyp == 27) THEN
534 DO i=lft,llt
535 j=i+nft
536 i0=ixr(1,j)
537 i1=ixr(2,j)
538 i2=ixr(3,j)
539 i3=ixr(4,j)
540 sti = geo(2,i0)*geo(10,i0)/max(em30,xl(i))
541 str(i)=sti
542 ENDDO
543 ELSEIF (igtyp == 8 .OR. igtyp == 13) THEN
544 DO i=lft,llt
545 j=i+nft
546 i0=ixr(1,j)
547 i1=ixr(2,j)
548 i2=ixr(3,j)
549 sti = max(geo(3,i0)*geo(41,i0),geo(10,i0)*geo(45,i0),geo(15,i0)*geo(49,i0))/max(em30,xl(i))
550 str(i)=sti
551 ENDDO
552 ELSEIF (igtyp == 23 ) THEN
553 k11 = 64 ! 4 + 6*10
554 DO i=lft,llt
555 j=i+nft
556 i0=ixr(1,j)
557 i1=ixr(2,j)
558 i2=ixr(3,j)
559 imat = ixr(5,i+nft)
560 iadbuf = ipm(7,imat) - 1
561 kx = uparam(iadbuf + k11 + 1)
562 kxy = uparam(iadbuf + k11 + 2)
563 kxz = uparam(iadbuf + k11 + 3)
564 sti = max(kx,kxy,kxz)/max(em30,xl(i))
565 str(i)=sti
566 ENDDO
567 ELSEIF (igtyp == 25) THEN
568 DO i=lft,llt
569 j=i+nft
570 i0=ixr(1,j)
571 i1=ixr(2,j)
572 i2=ixr(3,j)
573 sti = max(geo(3,i0)*geo(41,i0),geo(10,i0)*geo(45,i0))/max(em30,xl(i))
574 str(i)=sti
575 ENDDO
576 ELSEIF (igtyp == 26) THEN
577 DO i=lft,llt
578 j=i+nft
579 i0=ixr(1,j)
580 i1=ixr(2,j)
581 i2=ixr(3,j)
582 i3=ixr(4,j)
583 sti = geo(2,i0)/max(em30,xl(i))
584 str(i)=sti
585 ENDDO
586 ELSE
587 DO i=lft,llt
588 j=i+nft
589 i0=ixr(1,j)
590 i1=ixr(2,j)
591 i2=ixr(3,j)
592 sti = geo(3,i0)
593 str(i)=sti
594 ENDDO
595 ENDIF ! IF (igtyp
596 ENDIF ! IF (I7STIF /= 0)
597C------------------------------------------
598 ndepar=numels+numelc+numelt+numelp+nft
599C-------------------------------------------------------------------
600C SPRINGS --> all types
601C-------------------------------------------------------------------
602C=======================================================================
603 IF (igtyp == 4) THEN
604C=======================================================================
605 CALL rmass(ixr ,geo ,xmas ,xin ,partsav ,
606 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
607 3 inr(1,nft+1),msrt ,ems )
608 CALL r1buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,
609 2 igeo )
610C----
611 IF (inispri /= 0)
612 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
613 2 gbuf%TOTDEPL ,gbuf%FOREP ,gbuf%DEP_IN_TENS ,gbuf%DEP_IN_COMP,gbuf%LENGTH,
614 3 dfs , dv,igtyp ,ptspri ,gbuf%DEFINI(ii(1)),
615 4 gbuf%FORINI(ii(1)))
616 ELSEIF (igtyp == 26) THEN
617 CALL rmass(ixr ,geo ,xmas ,xin ,partsav ,
618 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
619 3 inr(1,nft+1),msrt ,ems )
620 CALL r1buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,
621 2 igeo )
622C----
623 IF (inispri /= 0)
624 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
625 2 gbuf%TOTDEPL ,gbuf%FOREP ,bidon ,bidon ,gbuf%LENGTH,
626 3 dfs ,gbuf%DV ,igtyp ,ptspri ,gbuf%DEFINI,
627 4 gbuf%FORINI )
628c------
629C=======================================================================
630 ELSEIF (igtyp == 8) THEN
631C=======================================================================
632 CALL rmass(ixr ,geo ,xmas ,xin,partsav ,
633 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
634 3 inr(1,nft+1),msrt,ems )
635 CALL r2buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)),
636 2 gbuf%LENGTH(ii(3)) ,ixr ,skew ,gbuf%POSX,gbuf%POSY,
637 3 gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY,gbuf%POSZZ,igeo ,
638 3 gbuf%SKEW_ID)
639C----
640 IF (inispri /= 0)
641 . CALL r8ini(
642 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
643 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
644 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
645 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)),
646 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)),
647 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)) ,
648 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
649 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
650 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
651 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
652 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
653C=======================================================================
654 ELSEIF (igtyp == 12) THEN
655C=======================================================================
656 CALL rmas12 (ixr ,geo,partsav ,
657 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
658 3 inr(1,nft+1),msrt)
659 ids = 457
660 cnt1 = 0
661 cnt2 = 0
662 CALL r3buf3(gbuf%OFF,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,igeo ,itab )
663 nsprg = nsprg + cnt2
664 IF (inispri /= 0)
665 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
666 2 gbuf%TOTDEPL ,gbuf%FOREP ,gbuf%DEP_IN_TENS,gbuf%DEP_IN_TENS,gbuf%LENGTH,
667 3 gbuf%DFS ,dv,igtyp ,ptspri ,gbuf%DEFINI,
668 4 gbuf%FORINI )
669C=======================================================================
670 ELSEIF (igtyp == 13) THEN
671C=======================================================================
672 CALL rmass(ixr ,geo ,xmas ,xin,partsav ,
673 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
674 3 inr(1,nft+1),msrt,ems )
675
676 ids = 325
677 cnt1 = 0
678 cnt2 = 0
679 CALL r4buf3(
680 1 gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)),
681 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
682 3 gbuf%POSY ,gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
683 4 itab ,gbuf%E6 ,igeo ,ipm)
684 nsprg = nsprg + cnt2
685 IF (inispri /= 0)
686 . CALL r8ini(
687 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
688 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
689 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
690 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)),
691 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)),
692 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)) ,
693 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
694 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
695 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
696 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
697 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
698C=======================================================================
699 ELSEIF (igtyp == 23) THEN
700C=======================================================================
701 ids = 325
702 cnt1 = 0
703 cnt2 = 0
704 CALL r23mass(ixr ,geo ,xmas ,xin,partsav ,
705 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
706 3 inr(1,nft+1),msrt,ems ,gbuf%MASS ,uiner,mtn)
707 IF(mtn == 108) THEN
708C
709 CALL r2buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)),
710 2 gbuf%LENGTH(ii(3)) ,ixr ,skew ,gbuf%POSX,gbuf%POSY,
711 3 gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY,gbuf%POSZZ,igeo ,
712 4 gbuf%SKEW_ID)
713C----
714 ELSEIF (mtn==113) THEN
715 CALL r4buf3(
716 1 gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)),
717 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
718 3 gbuf%POSY ,gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
719 4 itab ,gbuf%E6 ,igeo ,ipm)
720 nsprg = nsprg + cnt2
721C----
722 ELSEIF(mtn == 114) THEN
723 CALL r4buf3(
724 1 gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)),
725 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
726 3 gbuf%POSY ,gbuf%POSZ ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
727 4 itab ,gbuf%E6 ,igeo ,ipm)
728 nsprg = nsprg + cnt2
729 ENDIF ! MTN
730
731 IF (inispri /= 0)
732 . CALL r8ini(
733 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
734 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
735 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
736 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)),
737 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)),
738 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)) ,
739 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
740 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
741 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
742 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
743 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
744C=======================================================================
745 ELSEIF (igtyp == 25) THEN
746C=======================================================================
747 CALL rmass(ixr ,geo ,xmas ,xin,partsav ,
748 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
749 3 inr(1,nft+1),msrt,ems )
750 ids = 325
751 cnt1 = 0
752 cnt2 = 0
753 CALL r4buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)),gbuf%LENGTH(ii(2)) ,
754 2 gbuf%LENGTH(ii(3)),ixr ,skew ,gbuf%SKEW ,gbuf%POSX,
755 3 gbuf%POSY ,gbuf%POSZ,gbuf%POSXX,gbuf%POSYY ,gbuf%POSZZ,
756 4 itab ,gbuf%E6 ,igeo ,ipm)
757 nsprg = nsprg + cnt2
758 IF (inispri /= 0)
759 . CALL r8ini(
760 2 igtyp ,nel ,sigrs ,ixr ,nsigrs ,
761 3 gbuf%FOR(ii(1)) ,gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,
762 4 gbuf%MOM(ii(3)) ,gbuf%FOREP(ii(1)) ,gbuf%FOREP(ii(2)) ,gbuf%FOREP(ii(3)) ,gbuf%MOMEP(ii(1)) ,
763 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)),
764 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)),
765 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)) ,
766 8 gbuf%TOTDEPL(ii(2)) ,gbuf%TOTDEPL(ii(3)) ,gbuf%TOTROT(ii(1)) ,gbuf%TOTROT(ii(2)) ,gbuf%TOTROT(ii(3)) ,
767 9 gbuf%LENGTH(ii(1)) ,gbuf%LENGTH(ii(2)) ,gbuf%LENGTH(ii(3)) ,gbuf%EINT ,gbuf%E6 ,
768 a ptspri ,gbuf%DEFINI(ii(1)) ,gbuf%DEFINI(ii(2)) ,gbuf%DEFINI(ii(3)) ,gbuf%DEFINI(ii(4)) ,
769 b gbuf%DEFINI(ii(5)) ,gbuf%DEFINI(ii(6)) ,gbuf%FORINI(ii(1)) ,gbuf%FORINI(ii(2)) ,gbuf%FORINI(ii(3)) ,
770 b gbuf%FORINI(ii(4)) ,gbuf%FORINI(ii(5)) ,gbuf%FORINI(ii(6)) )
771C=======================================================================
772 ELSEIF (igtyp == 27) THEN
773C=======================================================================
774 CALL rmass(ixr ,geo ,xmas ,xin ,partsav ,
775 2 x ,v ,ipart(nft+1),xl ,msr(1,nft+1),
776 3 inr(1,nft+1),msrt ,ems )
777 CALL r1buf3(gbuf%OFF ,geo ,x ,gbuf%LENGTH(ii(1)) ,ixr ,gbuf%POSX,
778 2 igeo )
779C----
780 IF (inispri /= 0)
781 . CALL r4ini(sigrs ,ixr ,nsigrs ,gbuf%EINT ,gbuf%FOR ,
782 2 gbuf%TOTDEPL ,gbuf%FOREP ,gbuf%DEP_IN_TENS ,gbuf%DEP_IN_COMP,gbuf%LENGTH,
783 3 dfs,dv,igtyp ,ptspri ,gbuf%DEFINI(ii(1)),
784 4 gbuf%FORINI(ii(1)))
785C=======================================================================
786 ELSEIF (igtyp == 32 .OR. igtyp == 33 .OR. igtyp == 45) THEN
787C=======================================================================
788 CALL rini1u(gbuf%OFF ,geo ,x ,ul ,ixr ,
789 2 skew ,gbuf%SKEW,itab ,uix ,igeo)
790 nuvar = nint(geo(25,i0))
791 nuparam = nint(geo(26,i0))
792 IF (igtyp == 32) THEN
793 CALL rini32(
794 1 nel ,i0 ,
795 2 uix ,ul ,gbuf%MASS,uiner ,ustifm ,
796 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar ,id,titr,
797 4 gbuf%EINT,npc ,pld )
798 ELSEIF (igtyp == 33) THEN
799 DO i=lft,llt
800 j=i+nft
801 i1=ixr(2,j)
802 i2=ixr(3,j)
803 dx(i,1) = (x(1,i2)-x(1,i1))
804 dx(i,2) = (x(2,i2)-x(2,i1))
805 dx(i,3) = (x(3,i2)-x(3,i1))
806 ENDDO
807 CALL rini33(nel ,iout ,i0 ,uix,dx,
808 1 gbuf%MASS ,uiner ,ustifm ,ustifr,
809 2 uvism ,uvisr ,gbuf%VAR,nuvar )
810 ELSEIF (igtyp == 45) THEN
811 DO i=lft,llt
812 j=i+nft
813 i1=ixr(2,j)
814 i2=ixr(3,j)
815 dx(i,1) = (x(1,i2)-x(1,i1))
816 dx(i,2) = (x(2,i2)-x(2,i1))
817 dx(i,3) = (x(3,i2)-x(3,i1))
818 ENDDO
819 CALL rini45(nel ,iout ,i0 ,uix ,x ,dx,
820 . gbuf%MASS,uiner ,ustifm ,ustifr ,uvism ,
821 . uvisr ,gbuf%VAR,nuvar ,ixr ,ixr_kj,id ,titr)
822 ENDIF
823C
824 DO i=lft,llt
825 j=i+nft
826 i0=ixr(1,j)
827 i1=ixr(2,j)
828 i2=ixr(3,j)
829 i3=ixr(4,j)
830 xm = gbuf%MASS(i)
831 xine = uiner(i)
832 al2= ul(i)*ul(i)
833 xkr= ustifr(i)
834 xkm= ustifm(i)
835 xcr= uvisr(i)
836 xcm= uvism(i)
837 stifn(i1)=stifn(i1)+xkm
838 stifn(i2)=stifn(i2)+xkm
839 stifr(i1)=stifr(i1)+xkr
840 stifr(i2)=stifr(i2)+xkr
841 strr(j)=xkr
842 IF (xcm+xkm<em15) xm =one
843 IF (xcr+xkr<em15) xine=one
844 xkm= max(em15,xkm)
845 xkr= max(em15,xkr)
846 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
847 dtc=half*xm / max(em15,xcm)
848 dt = min(dt,dtc)
849 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
850 dt = min(dt,dtc)
851 dtc=half*xine / max( em15,xcr)
852 dt = min(dt,dtc)
853 dtelem(ndepar+i)= dt
854 ENDDO
855C
856 CALL rini2u(
857 1 ixr ,gbuf%MASS,uiner,
858 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
859 3 inr(1,nft+1),msrt ,ems )
860 IF (inispri /= 0)
861 . CALL ruini(
862 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
863 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
864 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)),
865 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
866 6 ptspri)
867C=======================================================================
868 ELSEIF (igtyp == 35 .OR. igtyp == 36) THEN
869C=======================================================================
870 CALL rini3u(gbuf%OFF ,geo ,x ,ul ,ixr ,
871 2 skew ,gbuf%SKEW ,itab ,uix ,igeo)
872 nuvar = nint(geo(25,i0))
873 nuparam = nint(geo(26,i0))
874C---
875 IF (igtyp == 35) THEN
876 CALL rini35(
877 1 nel ,iout ,i0 ,
878 2 uix ,ul ,gbuf%MASS,uiner ,ustifm ,
879 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
880 ELSEIF (igtyp == 36) THEN
881 CALL rini36(
882 1 nel ,iout ,i0 ,
883 2 ul ,gbuf%MASS,uiner ,ustifm ,
884 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
885 ENDIF
886C---
887 DO i=lft,llt
888 j=i+nft
889 i0=ixr(1,j)
890 i1=ixr(2,j)
891 i2=ixr(3,j)
892 i3=ixr(4,j)
893 xm = gbuf%MASS(i)
894 xine = uiner(i)
895 al2= ul(i)*ul(i)
896 xkr= ustifr(i)
897 xkm= ustifm(i)
898 xcr= uvisr(i)
899 xcm= uvism(i)
900 stifn(i1)=stifn(i1)+xkm
901 stifn(i2)=stifn(i2)+xkm
902 stifr(i1)=stifr(i1)+xkr
903 stifr(i2)=stifr(i2)+xkr
904 strr(j)=xkr
905 IF (xcm+xkm<em15) xm =one
906 IF (xcr+xkr<em15) xine=one
907 xkm= max(em15,xkm)
908 xkr= max(em15,xkr)
909 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
910 dtc=half*xm / max(em15,xcm)
911 dt = min(dt,dtc)
912 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
913 dt = min(dt,dtc)
914 dtc=half*xine / max( em15,xcr)
915 dt = min(dt,dtc)
916 dtelem(ndepar+i)= dt
917 ENDDO
918 CALL rini2u(
919 1 ixr ,gbuf%MASS,uiner,
920 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
921 3 inr(1,nft+1),msrt ,ems )
922 IF (inispri /= 0)
923 + CALL ruini(
924 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
925 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
926 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)),
927 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
928 6 ptspri)
929C
930C=======================================================================
931 ELSEIF (igtyp > 28 .AND. igtyp < 43) THEN ! reserved for user properties
932C=======================================================================
933 CALL rini3u(gbuf%OFF ,geo ,x ,ul ,ixr ,
934 2 skew ,gbuf%SKEW ,itab ,uix ,igeo)
935 nuvar = nint(geo(25,i0))
936 nuparam = nint(geo(26,i0))
937C
938 IF (igtyp == 29) THEN
939 IF (userl_avail == 1) THEN
940 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
941 1 nel ,i0 ,
942 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
943 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
944 CALL user_output(iout,igtyp,rootnam,rootlen,0)
945 ELSE
946 option='/PROP/USER29'
947 CALL ancmsg(msgid=1155,
948 . anmode=aninfo,
949 . msgtype=msgerror,
950 . c1=option)
951 ENDIF
952 ELSEIF (igtyp == 30) THEN
953 IF (userl_avai l == 1) THEN
954 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
955 1 nel ,i0 ,
956 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
957 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
958 CALL user_output(iout,igtyp,rootnam,rootlen,0)
959 ELSE
960 option='/PROP/USER30'
961 CALL ancmsg(msgid=1155,
962 . anmode=aninfo,
963 . msgtype=msgerror,
964 . c1=option)
965 ENDIF
966 ELSEIF (igtyp == 31) THEN
967 IF (userl_avail == 1) THEN
968 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
969 1 nel ,i0 ,
970 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
971 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
972 CALL user_output(iout,igtyp,rootnam,rootlen,0)
973 ELSE
974 option='/PROP/USER31'
975 CALL ancmsg(msgid=1155,
976 . anmode=aninfo,
977 . msgtype=msgerror,
978 . c1=option)
979 ENDIF
980 ELSEIF (igtyp == 37) THEN
981 IF (userl_avail == 1) THEN
982 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
983 1 nel ,i0 ,
984 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
985 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
986 CALL user_output(iout,igtyp,rootnam,rootlen,0)
987 ELSE
988 option='/PROP/USER37'
989 CALL ancmsg(msgid=1155,
990 . anmode=aninfo,
991 . msgtype=msgerror,
992 . c1=option)
993 ENDIF
994 ELSEIF (igtyp == 38) THEN
995 IF (userl_avail == 1) THEN
996 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
997 1 nel ,i0 ,
998 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
999 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1000 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1001 ELSE
1002 option='/PROP/USER38'
1003 CALL ancmsg(msgid=1155,
1004 . anmode=aninfo,
1005 . msgtype=msgerror,
1006 . c1=option)
1007 ENDIF
1008 ELSEIF (igtyp == 39) THEN
1009 IF (userl_avail == 1) THEN
1010 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
1011 1 nel ,i0 ,
1012 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1013 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1014 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1015 ELSE
1016 option='/PROP/USER39'
1017 CALL ancmsg(msgid=1155,
1018 . anmode=aninfo,
1019 . msgtype=msgerror,
1020 . c1=option)
1021 ENDIF
1022 ELSEIF (igtyp == 40) THEN
1023 IF (userl_avail == 1) THEN
1024 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
1025 1 nel ,i0 ,
1026 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1027 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1028 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1029 ELSE
1030 option='/PROP/USER40'
1031 CALL ancmsg(msgid=1155,
1032 . anmode=aninfo,
1033 . msgtype=msgerror,
1034 . c1=option)
1035 ENDIF
1036 ELSEIF (igtyp == 41) THEN
1037 IF (userl_avail == 1) THEN
1038 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
1039 1 nel ,i0 ,
1040 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1041 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1042 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1043 ELSE
1044 option='/PROP/USER41'
1045 CALL ancmsg(msgid=1155,
1046 . anmode=aninfo,
1047 . msgtype=msgerror,
1048 . c1=option)
1049 ENDIF
1050 ELSEIF (igtyp == 42) THEN
1051 IF (userl_avail == 1) THEN
1052 CALL st_userlib_riniuser(igtyp,rootnam,rootlen,
1053 1 nel ,i0 ,
1054 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1055 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1056 CALL user_output(iout,igtyp,rootnam,rootlen,0)
1057 ELSE
1058 option='/PROP/USER42'
1059 CALL ancmsg(msgid=1155,
1060 . anmode=aninfo,
1061 . msgtype=msgerror,
1062 . c1=option)
1063 ENDIF
1064 ENDIF
1065C
1066 DO i=lft,llt
1067 j=i+nft
1068 i0=ixr(1,j)
1069 i1=ixr(2,j)
1070 i2=ixr(3,j)
1071 i3=ixr(4,j)
1072 xm = gbuf%MASS(i)
1073 xine = uiner(i)
1074 al2= ul(i)*ul(i)
1075 xkr= ustifr(i)
1076 xkm= ustifm(i)
1077 xcr= uvisr(i)
1078 xcm= uvism(i)
1079 stifn(i1)=stifn(i1)+xkm
1080 stifn(i2)=stifn(i2)+xkm
1081 stifr(i1)=stifr(i1)+xkr
1082 stifr(i2)=stifr(i2)+xkr
1083 strr(j)=xkr
1084 IF (xcm+xkm<em15) xm =one
1085 IF (xcr+xkr<em15) xine=one
1086 xkm= max(em15,xkm)
1087 xkr= max(em15,xkr)
1088 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
1089 dtc=half*xm / max(em15,xcm)
1090 dt = min(dt,dtc)
1091 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
1092 dt = min(dt,dtc)
1093 dtc=half*xine / max( em15,xcr)
1094 dt = min(dt,dtc)
1095 dtelem(ndepar+i)= dt
1096 ENDDO
1097C
1098 CALL rini2u(
1099 1 ixr ,gbuf%MASS,uiner,
1100 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
1101 3 inr(1,nft+1),msrt ,ems )
1102 IF (inispri /= 0)
1103 . CALL ruini(
1104 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
1105 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
1106 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)),
1107 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
1108 6 ptspri)
1109C=======================================================================
1110 ELSEIF (igtyp == 44) THEN
1111C=======================================================================
1112 CALL rini3u(gbuf%OFF ,geo ,x ,ul ,ixr ,
1113 2 skew ,gbuf%SKEW ,itab ,uix ,igeo)
1114 nuvar = nint(geo(25,i0))
1115 nuparam = nint(geo(26,i0))
1116 CALL rini44(
1117 1 nel ,iout ,i0 ,
1118 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1119 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1120C
1121 DO i=lft,llt
1122 j=i+nft
1123 i0=ixr(1,j)
1124 i1=ixr(2,j)
1125 i2=ixr(3,j)
1126 i3=ixr(4,j)
1127 xm = gbuf%MASS(i)
1128 xine = uiner(i)
1129 al2= ul(i)*ul(i)
1130 xkr= ustifr(i)
1131 xkm= ustifm(i)
1132 xcr= uvisr(i)
1133 xcm= uvism(i)
1134 stifn(i1)=stifn(i1)+xkm
1135 stifn(i2)=stifn(i2)+xkm
1136 stifr(i1)=stifr(i1)+xkr
1137 stifr(i2)=stifr(i2)+xkr
1138 strr(j)=xkr
1139 IF(xcm+xkm<em15)xm =one
1140 IF(xcr+xkr<em15)xine=one
1141 xkm= max(em15,xkm)
1142 xkr= max(em15,xkr)
1143 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
1144 dtc=half*xm / max(em15,xcm)
1145 dt = min(dt,dtc)
1146 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
1147 dt = min(dt,dtc)
1148 dtc=half*xine / max( em15,xcr)
1149 dt = min(dt,dtc)
1150 dtelem(ndepar+i)= dt
1151 ENDDO
1152 CALL rini2u(
1153 1 ixr ,gbuf%MASS,uiner,
1154 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
1155 3 inr(1,nft+1),msrt ,ems )
1156 IF (inispri /= 0)
1157 . CALL ruini(
1158 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
1159 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
1160 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)),
1161 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
1162 6 ptspri)
1163C=======================================================================
1164 ELSEIF (igtyp == 46) THEN
1165C=======================================================================
1166 CALL rini3u(gbuf%OFF ,geo ,x ,ul ,ixr ,
1167 2 skew ,gbuf%SKEW ,itab ,uix ,igeo)
1168 nuvar = nint(geo(25,i0))
1169 nuparam = nint(geo(26,i0))
1170 CALL rini46(
1171 1 nel ,iout ,i0 ,
1172 2 uix ,ul ,gbuf%MASS ,uiner ,ustifm ,
1173 3 ustifr ,uvism ,uvisr ,gbuf%VAR,nuvar )
1174C
1175 DO i=lft,llt
1176 j=i+nft
1177 i0=ixr(1,j)
1178 i1=ixr(2,j)
1179 i2=ixr(3,j)
1180 i3=ixr(4,j)
1181 xm = gbuf%MASS(i)
1182 xine = uiner(i)
1183 al2= ul(i)*ul(i)
1184 xkr= ustifr(i)
1185 xkm= ustifm(i)
1186 xcr= uvisr(i)
1187 xcm= uvism(i)
1188 stifn(i1)=stifn(i1)+xkm
1189 stifn(i2)=stifn(i2)+xkm
1190 stifr(i1)=stifr(i1)+xkr
1191 stifr(i2)=stifr(i2)+xkr
1192 strr(j)=xkr
1193 IF (xcm+xkm<em15) xm =one
1194 IF (xcr+xkr<em15) xine=one
1195 xkm= max(em15,xkm)
1196 xkr= max(em15,xkr)
1197 dt=(sqrt(xcm*xcm+xm*xkm)-xcm)/xkm
1198 dtc=half*xm / max(em15,xcm)
1199 dt = min(dt,dtc)
1200 dtc=(sqrt(xcr*xcr+xine*xkr)-xcr)/xkr
1201 dt = min(dt,dtc)
1202 dtc=half*xine / max( em15,xcr)
1203 dt = min(dt,dtc)
1204 dtelem(ndepar+i)= dt
1205 ENDDO
1206C
1207 CALL rini2u(
1208 1 ixr ,gbuf%MASS,uiner,
1209 2 partsav ,x ,v ,ipart(nft+1),msr(1,nft+1),
1210 3 inr(1,nft+1),msrt ,ems )
1211C
1212 IF (inispri /= 0)
1213 . CALL ruini(
1214 2 sigrs ,nsigrs ,nuvar ,gbuf%FOR(ii(1)) ,
1215 3 gbuf%FOR(ii(2)) ,gbuf%FOR(ii(3)) ,gbuf%MOM(ii(1)) ,gbuf%MOM(ii(2)) ,gbuf%MOM(ii(3)) ,
1216 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)),
1217 5 gbuf%VR_REPCVT(ii(3)),gbuf%VAR ,gbuf%EINT ,
1218 6 ptspri)
1219C-----
1220 ENDIF ! IGTYP
1221C------------------------------------------
1222C COMPUTATION OF ELEMENT TIME STEPS & Nodal DT (take into account XCM)
1223C------------------------------------------
1224C
1225 k1 = 4
1226 k11 = 64
1227 k12 = k11 + 6
1228 k13 = k12 + 6
1229 k14 = k13 + 6
1230 DO i=lft,llt
1231 j=i+nft
1232 i0=ixr(1,j)
1233 i1=ixr(2,j)
1234 i2=ixr(3,j)
1235 i3=ixr(4,j)
1236 igtyp=igeo(11,i0)
1237 ipid=ixr(1,i+nft)
1238C
1239 IF (igtyp == 4) THEN
1240 xm = geo(1,i0)*xl(i)
1241 xkm= geo(2,i0)*geo(10,i0)/xl(i)
1242 xcm= (geo(3,i0)) +geo(141,i0) /xl(i)!
1243 IF (xcm /= zero .AND. xkm /= zero) THEN
1244 dt=xm/(sqrt(xcm*xcm+xkm*xm)+xcm)
1245 ELSEIF (xkm /= zero) THEN
1246 dt=sqrt(xm/xkm)
1247 ELSEIF (xcm /= zero) THEN
1248 dt=xm/xcm
1249 ELSE
1250 dt=ep20
1251 ENDIF
1252 dtc=half*xm / max(em15,xcm)
1253 dtelem(ndepar+i)=min(dt,dtc)
1254 mas2 = two*msr(1,j)
1255 IF (mas2>zero) THEN
1256 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1257 ELSE
1258 sti = xkm
1259 END IF
1260 stifn(i1)=stifn(i1)+sti
1261 stifn(i2)=stifn(i2)+sti
1262 ELSEIF (igtyp == 26) THEN
1263 xm = geo(1,i0)*xl(i)
1264 xkm= geo(2,i0)/xl(i)
1265 xcm= zero
1266 IF (xkm > zero) THEN
1267 dt=sqrt(xm/xkm)
1268 ELSE
1269 dt=ep20
1270 ENDIF
1271 dtc=half*xm / max(em15,xcm)
1272 dtelem(ndepar+i)=min(dt,dtc)
1273 stifn(i1)=stifn(i1)+xkm
1274 stifn(i2)=stifn(i2)+xkm
1275 ELSEIF (igtyp == 8) THEN
1276 xkm= max(geo(3,i0)*geo(41,i0),
1277 . geo(10,i0)*geo(45,i0),
1278 . geo(15,i0)*geo(49,i0))/xl(i)
1279 xcm= (max(geo(4,i0),geo(11,i0),geo(16,i0))
1280 . + max(geo(141,i0),geo(142,i0),geo(143,i0)))/xl(i)
1281 xkr= max(geo(19,i0)*geo(53,i0),
1282 . geo(23,i0)*geo(57,i0),
1283 . geo(27,i0)*geo(61,i0))/xl(i)
1284 xcr= (max(geo(20,i0),geo(24,i0),geo(28,i0))
1285 . + max(geo(144,i0),geo(145,i0),geo(146,i0)))/xl(i)
1286 xm=geo(1,i0)*xl(i)
1287 xine=geo(9,i0)*xl(i)
1288 IF (xcm+xkm<em15) xm =one
1289 IF (xcr+xkr<em15) xine=one
1290 xkm= max(em15,xkm)
1291 xkr= max(em15,xkr)
1292 dt=xm/max(em15,sqrt(xcm*xcm+xkm*xm)+xcm)
1293 dtc=xine/max(em15,sqrt(xcr*xcr+xine*xkr)+xcr)
1294 dtelem(ndepar+i)=min(dt,dtc)
1295 mas2 = two*msr(1,j)
1296 IF (mas2>zero) THEN
1297 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1298 ELSE
1299 sti = xkm
1300 END IF
1301 stifn(i1)=stifn(i1)+sti
1302 stifn(i2)=stifn(i2)+sti
1303 mas2 = inr(1,j)
1304 IF (mas2>zero) THEN
1305 sti = (sqrt(xcr**2+xkr*mas2)+xcr)**2/mas2
1306 ELSE
1307 sti = xkr
1308 END IF
1309 stifr(i1)=stifr(i1)+sti
1310 stifr(i2)=stifr(i2)+sti
1311 strr(j)=xkr
1312 ELSEIF(igtyp == 12) THEN
1313 xm = geo(1,i0)*xl(i)
1314 xkm= geo(2,i0)/xl(i)
1315 xcm= (geo(3,i0)+geo(141,i0))/xl(i)
1316 IF (xcm /= zero .AND. xkm /= zero) THEN
1317 dt=xm/(two*sqrt(xcm*xcm+xkm*xm)+xcm)
1318 ELSEIF (xkm /= zero) THEN
1319 dt=sqrt(xm/xkm)
1320 ELSEIF (xcm /= zero) THEN
1321 dt=xm/xcm
1322 ELSE
1323 dt=ep20
1324 ENDIF
1325 dtc=half*xm / max(em15,xcm)
1326 dtelem(ndepar+i)=min(dt,dtc)
1327 mas2 = two*msr(2,j)
1328 IF (mas2>zero) THEN
1329 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1330 ELSE
1331 sti = xkm
1332 END IF
1333 stifn(i2)=stifn(i2)+sti
1334 mas2 = two*msr(1,j)
1335 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1336 stifn(i1)=stifn(i1)+sti
1337 stifn(i3)=stifn(i3)+sti
1338 ELSEIF (igtyp == 13) THEN
1339 ex=x(1,i2)-x(1,i1)
1340 ey=x(2,i2)-x(2,i1)
1341 ez=x(3,i2)-x(3,i1)
1342 al2= ex*ex+ey*ey+ez*ez
1343 xkm= max(geo(3,i0)*geo(41,i0),
1344 . geo(10,i0)*geo(45,i0),
1345 . geo(15,i0)*geo(49,i0))/xl(i)
1346 xcm= (max(geo(4,i0),geo(11,i0),geo(16,i0))
1347 . + max(geo(141,i0),geo(142,i0),geo(143,i0)) )/xl(i)
1348 xkr= max(geo(10,i0)*geo(45,i0),
1349 . geo(15,i0)*geo(49,i0)) * al2
1350 xcr= (max(geo(11,i0),geo(16,i0))+ max(geo(142,i0),geo(143,i0)))* al2
1351 xkr= ( xkr
1352 . +max(geo(19,i0)*geo(53,i0),
1353 . geo(23,i0)*geo(57,i0),
1354 . geo(27,i0)*geo(61,i0)))/xl(i)
1355 xcr= (xcr+max(geo(20,i0),geo(24,i0),geo(28,i0))
1356 . + max(geo(144,i0),geo(145,i0),geo(146,i0)) )/xl(i)
1357 xm=geo(1,i0)*xl(i)
1358 xine=geo(9,i0)*xl(i)
1359 IF (xcm+xkm<em15) xm =one
1360 IF (xcr+xkr<em15) xine=one
1361 xkm= max(em15,xkm)
1362 xkr= max(em15,xkr)
1363 dt=xm/max(em15,sqrt(xcm*xcm+xkm*xm)+xcm)
1364 dtc=xine/max(em15,sqrt(xcr*xcr+xine*xkr)+xcr)
1365 dt = min(dt,dtc)
1366 dtelem(ndepar+i)= dt
1367 mas2 = two*msr(1,j)
1368 IF (mas2>zero) THEN
1369 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1370 ELSE
1371 sti = xkm
1372 END IF
1373 stifn(i1)=stifn(i1)+sti
1374 stifn(i2)=stifn(i2)+sti
1375 mas2 = two*inr(1,j)
1376 IF (mas2>zero) THEN
1377 sti = (sqrt(xcr**2+xkr*mas2)+xcr)**2/mas2
1378 ELSE
1379 sti = xkr
1380 END IF
1381 stifr(i1)=stifr(i1)+sti
1382 stifr(i2)=stifr(i2)+sti
1383 strr(j)=xkr
1384 ELSEIF (igtyp == 23) THEN
1385 imat = ixr(5,i+nft)
1386 iadbuf = ipm(7,imat) - 1
1387 mtn = ipm(2,imat)
1388 IF(mtn == 108) THEN
1389 xkm= max(uparam(iadbuf + k11 + 1)*uparam(iadbuf + k1 + 1),
1390 . uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
1391 . uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3))/xl(i)
1392 xcm= max(uparam(iadbuf + k12 + 1),uparam(iadbuf + k12 + 2),uparam(iadbuf + k12 + 3))
1393C
1394 xkr= max(uparam(iadbuf + k11 + 4)*uparam(iadbuf + k1 + 4),
1395 . uparam(iadbuf + k11 + 5)*uparam(iadbuf + k1 + 5),
1396 . uparam(iadbuf + k11 + 6)*uparam(iadbuf + k1 + 6))/xl(i)
1397C
1398 xcr= (max(uparam(iadbuf + k12 + 4),uparam(iadbuf + k12 + 5),uparam(iadbuf + k12 + 6)))/xl(i)
1399 ! old Geo 144,145,146 not used.
1400 xm = gbuf%MASS(i)*xl(i)
1401 xine= geo(2,i0)*xl(i)
1402 IF (xcm+xkm<em15) xm =one
1403 IF (xcr+xkr<em15) xine=one
1404 xkm= max(em15,xkm)
1405 xkr= max(em15,xkr)
1406 dt =xm/max(em15,sqrt(xcm*xcm+xkm*xm)+xcm)
1407 dtc=xine/max(em15,sqrt(xcr*xcr+xine*xkr)+xcr)
1408 dtelem(ndepar+i)=min(dt,dtc)
1409 geo(4,i0)= min(geo(4,i0),dt,dtc) ! to be fixed also put it in buffer material
1410 mas2 = two*msr(1,j)
1411 ine2 = two*inr(1,j)
1412 ELSEIF (mtn==113) THEN
1413 ex=x(1,i2)-x(1,i1)
1414 ey=x(2,i2)-x(2,i1)
1415 ez=x(3,i2)-x(3,i1)
1416 al2= ex*ex+ey*ey+ez*ez
1417 xkm= max(uparam(iadbuf + k11 + 1)*uparam(iadbuf + k1 + 1),
1418 . uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
1419 . uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3))/xl(i)
1420 xcm= (max(uparam(iadbuf + k12 +1),uparam(iadbuf + k12 +2 ),uparam(iadbuf + k12 + 3))
1421 . + max(uparam(iadbuf + k14 + 1),uparam(iadbuf + k14 + 2),uparam(iadbuf + k14 + 3)))/xl(i)
1422 xkr= max(uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
1423 . uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3)) * al2
1424 xcr= (max(uparam(iadbuf + k12 + 2),uparam(iadbuf + k12 + 3)) +
1425 . max(uparam(iadbuf + k14 + 2),uparam(iadbuf + k14 + 3)))* al2
1426 xkr= ( xkr
1427 . + max(uparam(iadbuf + k11 + 4)*uparam(iadbuf + k1 + 4),
1428 . uparam(iadbuf + k11 + 5)*uparam(iadbuf + k1 + 5),
1429 . uparam(iadbuf + k11 + 6)*uparam(iadbuf + k1 + 6)))/xl(i)
1430 xcr= (xcr+max(uparam(iadbuf + k12 + 4),uparam(iadbuf + k12 + 5),uparam(iadbuf + k12 + 6))
1431 . + max(uparam(iadbuf + k14 + 4),uparam(iadbuf + k14 + 5),uparam(iadbuf + k14 + 6)) )/xl(i)
1432 xm =gbuf%MASS(i)
1433 xine=geo(2,i0)*xl(i)
1434 IF (xcm+xkm<em15) xm =one
1435 IF (xcr+xkr<em15) xine=one
1436 xkm= max(em15,xkm)
1437 xkr= max(em15,xkr)
1438 dt =xm/max(em15,sqrt(xcm*xcm+xkm*xm)+xcm)
1439 dtc=xine/max(em15,sqrt(xcr*xcr+xine*xkr)+xcr)
1440 dt = min(dt,dtc)
1441 geo(4,i0)= min(geo(4,i0),dt)
1442 dtelem(ndepar+i)= dt
1443 mas2 = two*msr(1,j)
1444 ine2 = two*inr(1,j)
1445 ELSEIF (mtn==114) THEN
1446 ex=x(1,i2)-x(1,i1)
1447 ey=x(2,i2)-x(2,i1)
1448 ez=x(3,i2)-x(3,i1)
1449 al2= ex*ex+ey*ey+ez*ez
1450C
1451 xkm= max(uparam(iadbuf + k11 + 1)*uparam(iadbuf + k1 + 1),
1452 . uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
1453 . uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3),
1454 . uparam(iadbuf+117)*geo(1,i0))/xl(i)
1455C
1456 xcm= (max(uparam(iadbuf + k12 +1),uparam(iadbuf + k12 +2 ),uparam(iadbuf + k12 + 3))
1457 . + max(uparam(iadbuf + k14 + 1),uparam(iadbuf + k14 + 2),uparam(iadbuf + k14 + 3)))/xl(i)
1458 xkr= max(uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
1459 . uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3)) * al2
1460 xcr= (max(uparam(iadbuf + k12 + 2),uparam(iadbuf + k12 + 3)) +
1461 . max(uparam(iadbuf + k14 + 2),uparam(iadbuf + k14 + 3)))* al2
1462 xkr= ( xkr
1463 . + max(uparam(iadbuf + k11 + 4)*uparam(iadbuf + k1 + 4),
1464 . uparam(iadbuf + k11 + 5)*uparam(iadbuf + k1 + 5),
1465 . uparam(iadbuf + k11 + 6)*uparam(iadbuf + k1 + 6)))/xl(i)
1466 xcr= (xcr+max(uparam(iadbuf+k12 + 1),uparam(iadbuf+ k12 + 2),uparam(iadbuf+ k12 + 3))
1467 . + max(uparam(iadbuf+k14 + 4),uparam(iadbuf+ k14 + 5),uparam(iadbuf+ k14 + 6)) )/xl(i)
1468C-
1469 IF (uparam(iadbuf + 127) > zero) THEN
1470C- 1D material of 2D seatbelt - element mass and inertia recomputed for elementary time step
1471 rho = uparam(iadbuf+128)
1472 xm = rho*xl(i)*geo(1,i0)
1473 xine=max(em20,max((rho*geo(1,i0)*length*length*length)/twelve+ rho*iyy*length,rho*ixx*length))
1474 gbuf%MASS(i) = xm*gbuf%FRAM_FACTOR(i)
1475 gbuf%INTVAR(i) = xine*gbuf%FRAM_FACTOR(i)
1476 mas2 = xm
1477 ine2 = xine
1478 ELSE
1479 gbuf%FRAM_FACTOR(i) = one
1480 xm =gbuf%MASS(i)
1481 xine=uiner(i)
1482 gbuf%INTVAR(i) = xine
1483 mas2 = two*msr(1,j)
1484 ine2 = two*inr(1,j)
1485 ENDIF
1486C
1487 IF (gbuf%SLIPRING_STRAND(i) > 0) THEN
1488C---------> Update of third node if seatbelt spring in slipring------------
1489 slip = gbuf%SLIPRING_ID(i)
1490 fra = gbuf%SLIPRING_FRAM_ID(i)
1491 DO kk=1,3
1492 IF ((slipring(slip)%FRAM(fra)%NODE(kk)/=i1).AND.(slipring(slip)%FRAM(fra)%NODE(kk)/=i2)) THEN
1493 ixr(4,j)=slipring(slip)%FRAM(fra)%NODE(kk)
1494 ENDIF
1495 ENDDO
1496 ELSEIF (gbuf%RETRACTOR_ID(i) < 0) THEN
1497C---------> Deactivation of elements initially in retractor------------
1498 gbuf%OFF(i) = zero
1499 gbuf%RETRACTOR_ID(i) = 0
1500 ENDIF
1501C
1502 IF (xcm+xkm<em15) xm =one
1503 IF (xcr+xkr<em15) xine=one
1504 xkm= max(em15,xkm)
1505 xkr= max(em15,xkr)
1506 dt =xm/max(em15,sqrt(xcm*xcm+xkm*xm)+xcm)
1507 dtc=xine/max(em15,sqrt(xcr*xcr+xine*xkr)+xcr)
1508 dt = min(dt,dtc)
1509 geo(4,i0)= min(geo(4,i0),dt)
1510 dtelem(ndepar+i)= dt
1511 ENDIF
1512 IF (mas2>zero) THEN
1513 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1514 ELSE
1515 sti = xkm
1516 END IF
1517 stifn(i1)=stifn(i1)+sti
1518 stifn(i2)=stifn(i2)+sti
1519 IF (ine2>zero) THEN
1520 sti = (sqrt(xcr**2+xkr*ine2)+xcr)**2/ine2
1521 ELSE
1522 sti = xkr
1523 END IF
1524 stifr(i1)=stifr(i1)+sti
1525 stifr(i2)=stifr(i2)+sti
1526 strr(j)=xkr
1527 ELSEIF (igtyp == 25) THEN
1528 ex=x(1,i2)-x(1,i1)
1529 ey=x(2,i2)-x(2,i1)
1530 ez=x(3,i2)-x(3,i1)
1531 al2= ex*ex+ey*ey+ez*ez
1532 xkm= max(geo(3,i0)*geo(41,i0),
1533 . geo(10,i0)*geo(45,i0))/xl(i)
1534 xcm= (max(geo(4,i0),geo(11,i0))
1535 . + max(geo(141,i0),geo(142,i0)))/xl(i)
1536 xkr= geo(10,i0)*geo(45,i0)*al2
1537 xkr= (xkr
1538 . +max(geo(19,i0)*geo(53,i0),geo(23,i0)*geo(57,i0)))/xl(i)
1539 xcr= (geo(11,i0)+geo(142,i0))*al2
1540 xcr= (xcr+
1541 . max(geo(141,i0),geo(142,i0))+max(geo(20,i0),geo(24,i0))
1542 . +max(geo(143,i0),geo(144,i0)) )/xl(i)
1543 xm=geo(1,i0)*xl(i)
1544 xine=geo(9,i0)*xl(i)
1545 IF (xcm+xkm<em15) xm =one
1546 IF (xcr+xkr<em15) xine=one
1547 xkm= max(em15,xkm)
1548 xkr= max(em15,xkr)
1549 dt=xm/max(em15,sqrt(xcm*xcm+xkm*xm)+xcm)
1550 dtc=xine/max(em15,sqrt(xcr*xcr+xine*xkr)+xcr)
1551 dtelem(ndepar+i)=min(dt,dtc)
1552 mas2 = two*msr(1,j)
1553 IF (mas2>zero) THEN
1554 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1555 ELSE
1556 sti = xkm
1557 END IF
1558 stifn(i1)=stifn(i1)+sti
1559 stifn(i2)=stifn(i2)+sti
1560 mas2 = inr(1,j)
1561 IF (mas2>zero) THEN
1562 sti = (sqrt(xcr**2+xkr*mas2)+xcr)**2/mas2
1563 ELSE
1564 sti = xkr
1565 END IF
1566 stifr(i1)=stifr(i1)+sti
1567 stifr(i2)=stifr(i2)+sti
1568 strr(j)=xkr
1569 ELSEIF (igtyp == 27) THEN
1570 xm = geo(1,i0)*xl(i)
1571 xkm= geo(2,i0)*geo(10,i0)/xl(i)
1572 xcm= (geo(3,i0)+geo(141,i0))/xl(i)!
1573 IF (xcm /= zero .AND. xkm /= zero) THEN
1574 dt=xm/(sqrt(xcm*xcm+xkm*xm)+xcm)
1575 ELSEIF (xkm /= zero) THEN
1576 dt=sqrt(xm/xkm)
1577 ELSEIF (xcm /= zero) THEN
1578 dt=xm/xcm
1579 ELSE
1580 dt=ep20
1581 ENDIF
1582 dtc=half*xm / max(em15,xcm)
1583 dtelem(ndepar+i)=min(dt,dtc)
1584 mas2 = two*msr(1,j)
1585 IF (mas2>zero) THEN
1586 sti = (sqrt(xcm**2+xkm*mas2)+xcm)**2/mas2
1587 ELSE
1588 sti = xkm
1589 END IF
1590 stifn(i1)=stifn(i1)+sti
1591 stifn(i2)=stifn(i2)+sti
1592 END IF
1593 ENDDO
1594!
1595 IF (ipreld>0) THEN
1596 SELECT CASE (igtyp)
1597 CASE(4,13)
1598 j=1+nft
1599 i0=ixr(1,j)
1600 ih = nint(geo(7,i0))
1601 ifunc = igeo(101,i0)
1602 IF (ifunc==0) ih =0
1603 IF (ih==0.OR.ih==8) THEN
1604 CALL ancmsg(msgid=3057,
1605 . msgtype=msgerror,
1606 . anmode=aninfo_blind_1,
1607 . i1=id,
1608 . i2=ih,
1609 . c1=titr)
1610 ELSE
1611 DO i=lft,llt
1612 xm=geo(1,i0)*xl(i)
1613 undamp = xm/dtelem(ndepar+i)
1614 gbuf%BPRELD(i) = preload_a(ipreld)%preload
1615 gbuf%BPRELD(i+nel) = undamp*preload_a(ipreld)%damp
1616 ENDDO
1617 END IF
1618 CASE(23)
1619 IF (mtn==113) THEN
1620 j=1+nft
1621 i0=ixr(1,j)
1622 imat = ixr(5,j)
1623 ifunc = ipm(10 + 1,imat)
1624 iadbuf = ipm(7,imat) - 1
1625 ih= nint(uparam(iadbuf + 4 + 12*6 + 1))
1626 IF (ifunc==0) ih =0
1627 IF (ih==0.OR.ih==8) THEN
1628 CALL ancmsg(msgid=3057,
1629 . msgtype=msgerror,
1630 . anmode=aninfo_blind_1,
1631 . i1=id,
1632 . i2=ih,
1633 . c1=titr)
1634 ELSE
1635 DO i=lft,llt
1636 xm=gbuf%MASS(i)
1637 undamp = xm/dtelem(ndepar+i)
1638 gbuf%BPRELD(i) = preload_a(ipreld)%preload
1639 gbuf%BPRELD(i+nel) = undamp*preload_a(ipreld)%damp
1640 ENDDO
1641 END IF ! IH==0.OR.
1642 ELSE
1643 CALL ancmsg(msgid=3053,
1644 . msgtype=msgerror,
1645 . anmode=aninfo_blind_1,
1646 . i1=id,
1647 . i2=igtyp,
1648 . c1=titr)
1649 END IF
1650 CASE DEFAULT
1651 CALL ancmsg(msgid=3053,
1652 . msgtype=msgerror,
1653 . anmode=aninfo_blind_1,
1654 . i1=id,
1655 . i2=igtyp,
1656 . c1=titr)
1657 END SELECT
1658!
1659 END IF
1660C-----
1661 1000 FORMAT('LIST OF POSSIBLE CNODES MERGED WITH NODE OF ID=',i10)
1662C-----
1663 RETURN
1664 END
1665!||====================================================================
1666!|| rini3u ../starter/source/elements/spring/rinit3.F
1667!||--- called by ------------------------------------------------------
1668!|| rinit3 ../starter/source/elements/spring/rinit3.F
1669!||--- uses -----------------------------------------------------
1670!||====================================================================
1671 SUBROUTINE rini3u(OFF ,GEO ,X ,X0 ,IX ,
1672 . SKEW ,RLOC ,ITAB ,UIX ,IGEO )
1673 use element_mod , only : nixr
1674C-----------------------------------------------
1675C I m p l i c i t T y p e s
1676C-----------------------------------------------
1677#include "implicit_f.inc"
1678C-----------------------------------------------
1679C G l o b a l P a r a m e t e r s
1680C-----------------------------------------------
1681#include "mvsiz_p.inc"
1682C-----------------------------------------------
1683C C o m m o n B l o c k s
1684C-----------------------------------------------
1685#include "vect01_c.inc"
1686#include "param_c.inc"
1687C-----------------------------------------------
1688C D u m m y A r g u m e n t s
1689C-----------------------------------------------
1690 INTEGER IX(NIXR,*),UIX(4,MVSIZ),ITAB(*), IGEO(NPROPGI,*)
1691C REAL
1692 my_real
1693 . OFF(*), GEO(NPROPG,*), X(3,*), X0(*), SKEW(LSKEW,*),
1694 . RLOC(6,*)
1695C-----------------------------------------------
1696C L o c a l V a r i a b l e s
1697C-----------------------------------------------
1698 INTEGER I, J, NG, I1, I2, I3, ISK
1699C REAL
1700 my_real
1701 . x1, y1, z1
1702C-----------------------------------------------
1703 DO i=lft,llt
1704 off(i) = one
1705 ENDDO
1706C
1707 DO i=lft,llt
1708 j=i+nft
1709 ng=ix(1,j)
1710 isk=igeo(2,ng)
1711 i1=ix(2,j)
1712 i2=ix(3,j)
1713 i3=ix(4,j)
1714 x1=x(1,i2)-x(1,i1)
1715 y1=x(2,i2)-x(2,i1)
1716 z1=x(3,i2)-x(3,i1)
1717 x0(i)=sqrt(x1**2+y1**2+z1**2)
1718 IF (x0(i) < em15) THEN
1719 rloc(1,i)= one
1720 rloc(2,i)= zero
1721 rloc(3,i)= zero
1722 rloc(4,i)= zero
1723 rloc(5,i)= one
1724 rloc(6,i)= zero
1725 ELSEIF (i3 /= 0) THEN
1726 rloc(1,i)=x1
1727 rloc(2,i)=y1
1728 rloc(3,i)=z1
1729 rloc(4,i)=x(1,i3)-x(1,i1)
1730 rloc(5,i)=x(2,i3)-x(2,i1)
1731 rloc(6,i)=x(3,i3)-x(3,i1)
1732 ELSEIF (isk /= 1) THEN
1733 rloc(1,i)= x1
1734 rloc(2,i)= y1
1735 rloc(3,i)= z1
1736 rloc(4,i)=skew(4,isk)
1737 rloc(5,i)=skew(5,isk)
1738 rloc(6,i)=skew(6,isk)
1739 ELSE
1740 rloc(1,i)=x1
1741 rloc(2,i)=y1
1742 rloc(3,i)=z1
1743 IF (abs(y1) < half*x0(i)) THEN
1744 rloc(4,i)=zero
1745 rloc(5,i)=one
1746 rloc(6,i)=zero
1747 ELSE
1748 rloc(4,i)=one
1749 rloc(5,i)=zero
1750 rloc(6,i)=zero
1751 ENDIF
1752 ENDIF
1753 uix(1,i)=itab(i1)
1754 uix(2,i)=itab(i2)
1755 IF(i3 /= 0) THEN
1756 uix(3,i)=itab(i3)
1757 ELSE
1758 uix(3,i)=0
1759 ENDIF
1760 uix(4,i)=ix(6,j)
1761 ENDDO
1762C
1763 RETURN
1764 END
1765!||====================================================================
1766!|| rini1u ../starter/source/elements/spring/rinit3.F
1767!||--- called by ------------------------------------------------------
1768!|| rinit3 ../starter/source/elements/spring/rinit3.F
1769!||--- uses -----------------------------------------------------
1770!||====================================================================
1771 SUBROUTINE rini1u(OFF ,GEO ,X ,X0 ,IX ,
1772 . SKEW ,RLOC ,ITAB ,UIX ,IGEO )
1773 use element_mod , only : nixr
1774C-----------------------------------------------
1775C I m p l i c i t T y p e s
1776C-----------------------------------------------
1777#include "implicit_f.inc"
1778C-----------------------------------------------
1779C G l o b a l P a r a m e t e r s
1780C-----------------------------------------------
1781#include "mvsiz_p.inc"
1782C-----------------------------------------------
1783C C o m m o n B l o c k s
1784C-----------------------------------------------
1785#include "vect01_c.inc"
1786#include "param_c.inc"
1787C-----------------------------------------------
1788C D u m m y A r g u m e n t s
1789C-----------------------------------------------
1790 INTEGER IX(NIXR,*),UIX(4,MVSIZ),ITAB(*), IGEO(NPROPGI,*)
1791C REAL
1792 my_real
1793 . OFF(*), GEO(NPROPG,*), X(3,*), X0(*), SKEW(LSKEW,*)
1794C REAL
1795 my_real
1796 . RLOC(3,*)
1797C-----------------------------------------------
1798C L o c a l V a r i a b l e s
1799C-----------------------------------------------
1800 INTEGER I, J, NG, I1, I2, I3, ISK
1801C REAL
1802 my_real
1803 . x1, y1, z1
1804C-----------------------------------------------
1805 DO i=lft,llt
1806 off(i) = one
1807 ENDDO
1808C
1809 DO i=lft,llt
1810 j=i+nft
1811 ng=ix(1,j)
1812 isk=igeo(2,ng)
1813 i1=ix(2,j)
1814 i2=ix(3,j)
1815 i3=ix(4,j)
1816 x1=x(1,i2)-x(1,i1)
1817 y1=x(2,i2)-x(2,i1)
1818 z1=x(3,i2)-x(3,i1)
1819 x0(i)=sqrt(x1**2+y1**2+z1**2)
1820 IF (x0(i) < em15) THEN
1821 rloc(1,i)= one
1822 rloc(2,i)= zero
1823 rloc(3,i)= zero
1824 ELSEIF (i3 /= 0) THEN
1825 rloc(1,i)=x(1,i3)-x(1,i1)
1826 rloc(2,i)=x(2,i3)-x(2,i1)
1827 rloc(3,i)=x(3,i3)-x(3,i1)
1828 ELSEIF( isk /= 1) THEN
1829 rloc(1,i)=skew(4,isk)
1830 rloc(2,i)=skew(5,isk)
1831 rloc(3,i)=skew(6,isk)
1832 ELSE
1833 IF (abs(y1) < half*x0(i)) THEN
1834 rloc(1,i)=zero
1835 rloc(2,i)=one
1836 rloc(3,i)=zero
1837 ELSE
1838 rloc(1,i)=one
1839 rloc(2,i)=zero
1840 rloc(3,i)=zero
1841 ENDIF
1842 ENDIF
1843 uix(1,i)=itab(i1)
1844 uix(2,i)=itab(i2)
1845 IF (i3 == 0) THEN
1846 uix(3,i)=0
1847 ELSE
1848 uix(3,i)=itab(i3)
1849 ENDIF
1850 uix(4,i)=ix(6,j)
1851 ENDDO
1852C-----------------------------------------------
1853 RETURN
1854 END
1855!||====================================================================
1856!|| rini2u ../starter/source/elements/spring/rinit3.F
1857!||--- called by ------------------------------------------------------
1858!|| rinit3 ../starter/source/elements/spring/rinit3.F
1859!||--- uses -----------------------------------------------------
1860!||====================================================================
1861 SUBROUTINE rini2u(IXR ,UMASS ,UINER,
1862 . PARTSAV ,X ,V ,IPART ,MSR,
1863 . INR ,MSRT ,EMS )
1864 use element_mod , only : nixr
1865C----------------------------------------------
1866C initialization of nodal masses
1867C----------------------------------------------
1868C-----------------------------------------------
1869C I m p l i c i t T y p e s
1870C-----------------------------------------------
1871#include "implicit_f.inc"
1872C-----------------------------------------------
1873C C o m m o n B l o c k s
1874C-----------------------------------------------
1875#include "com01_c.inc"
1876#include "vect01_c.inc"
1877C-----------------------------------------------
1878C D u m m y A r g u m e n t s
1879C-----------------------------------------------
1880 INTEGER IXR(NIXR,*),IPART(*)
1881 my_real :: UMASS(*),UINER(*), X(3,*),V(3,*)
1882 my_real :: PARTSAV(20,*), MSR(3,*), INR(3,*), MSRT(*),EMS(*)
1883C-----------------------------------------------
1884C L o c a l V a r i a b l e s
1885C-----------------------------------------------
1886 INTEGER I, IP,I1,I2
1887 my_real :: XX,YY,ZZ,XY,YZ,ZX
1888 my_real :: XI
1889C---------------------------------------------------------------------
1890C----------------------------------------------
1891C MASSE ELEMENT /2
1892C----------------------------------------------
1893 DO i=lft,llt
1894 ems(i)=half*umass(i)
1895 ENDDO
1896C----------------------------------------------
1897C initialization of nodal masses
1898C----------------------------------------------
1899C specific spmd treatment for mass and iner parith/on
1900 DO i=lft,llt
1901 i1 = ixr(2,i+nft)
1902 i2 = ixr(3,i+nft)
1903C
1904 xi=half*uiner(i)
1905 msr(1,i)=ems(i)
1906 msr(2,i)=ems(i)
1907 msr(3,i)=ems(i)
1908 inr(1,i)=xi
1909 inr(2,i)=xi
1910 inr(3,i)=xi
1911C
1912 ip=ipart(i)
1913 partsav(1,ip)=partsav(1,ip) + two*ems(i)
1914 partsav(2,ip)=partsav(2,ip) + ems(i)*(x(1,i1)+x(1,i2))
1915 partsav(3,ip)=partsav(3,ip) + ems(i)*(x(2,i1)+x(2,i2))
1916 partsav(4,ip)=partsav(4,ip) + ems(i)*(x(3,i1)+x(3,i2))
1917 xx = (x(1,i1)*x(1,i1)+x(1,i2)*x(1,i2))
1918 xy = (x(1,i1)*x(2,i1)+x(1,i2)*x(2,i2))
1919 yy = (x(2,i1)*x(2,i1)+x(2,i2)*x(2,i2))
1920 yz = (x(2,i1)*x(3,i1)+x(2,i2)*x(3,i2))
1921 zz = (x(3,i1)*x(3,i1)+x(3,i2)*x(3,i2))
1922 zx = (x(3,i1)*x(1,i1)+x(3,i2)*x(1,i2))
1923 partsav(5,ip) =partsav(5,ip) + two*xi + ems(i) * (yy+zz)
1924 partsav(6,ip) =partsav(6,ip) + two*xi + ems(i) * (zz+xx)
1925 partsav(7,ip) =partsav(7,ip) + two*xi + ems(i) * (xx+yy)
1926 partsav(8,ip) =partsav(8,ip) - ems(i) * xy
1927 partsav(9,ip) =partsav(9,ip) - ems(i) * yz
1928 partsav(10,ip)=partsav(10,ip) - ems(i) * zx
1929C
1930 partsav(11,ip)=partsav(11,ip) + ems(i)*(v(1,i1)+v(1,i2))
1931 partsav(12,ip)=partsav(12,ip) + ems(i)*(v(2,i1)+v(2,i2))
1932 partsav(13,ip)=partsav(13,ip) + ems(i)*(v(3,i1)+v(3,i2))
1933 partsav(14,ip)=partsav(14,ip) + half * ems(i) *
1934 . (v(1,i1)*v(1,i1)+v(2,i1)*v(2,i1)+v(3,i1)*v(3,i1)
1935 . +v(1,i2)*v(1,i2)+v(2,i2)*v(2,i2)+v(3,i2)*v(3,i2))
1936 ENDDO
1937C
1938 IF (irest_mselt /= 0)THEN
1939 DO i=lft,llt
1940 msrt(i)=umass(i)
1941 ENDDO
1942 ENDIF
1943C
1944 RETURN
1945 END
1946!||====================================================================
1947!|| r4ini ../starter/source/elements/spring/rinit3.F
1948!||--- called by ------------------------------------------------------
1949!|| rinit3 ../starter/source/elements/spring/rinit3.F
1950!||--- uses -----------------------------------------------------
1951!||====================================================================
1952 SUBROUTINE r4ini(SIGRS ,IXR ,NSIGI ,EINT ,F ,
1953 . DL ,FEP ,DPL ,DPL2 ,XL0 ,
1954 . DFS ,DV ,IGTYP ,PTSPRI,DL0 ,
1955 . F0 )
1956 use element_mod , only : nixr
1957C-----------------------------------------------
1958C I m p l i c i t T y p e s
1959C-----------------------------------------------
1960#include "implicit_f.inc"
1961C-----------------------------------------------
1962C C o m m o n B l o c k s
1963C-----------------------------------------------
1964#include "vect01_c.inc"
1965#include "com01_c.inc"
1966C-----------------------------------------------
1967C D u m m y A r g u m e n t s
1968C-----------------------------------------------
1969 INTEGER NSIGI,IGTYP
1970 INTEGER IXR(NIXR,*),PTSPRI(*)
1971C REAL
1972 my_real
1973 . f(*),eint(*),sigrs(nsigi,*),dpl(*),dpl2(*),dfs(*),
1974 . fep(*),dl(*),xl0(*),dv(*),dl0(*),f0(*)
1975C-----------------------------------------------
1976C L o c a l V a r i a b l e s
1977C-----------------------------------------------
1978 INTEGER I,II,JJ
1979C-----------------------------------------------------------------------
1980C---
1981C CONTRAINTES INITIALES + OTHERS
1982C---
1983 IF (INISPRI /= 0) then
1984 DO i=lft,llt
1985 ii = i+nft
1986! length recumputed in engine if not concerned by INISPRI
1987 xl0(i) = zero
1988!
1989 jj = ptspri(ii)
1990 IF( jj == 0) GOTO 200
1991C---
1992!! F(I) = SIGRS(2,JJ)
1993 f0(i) = sigrs(2,jj)
1994!! DL(I) = SIGRS(3,JJ)
1995 dl0(i) = sigrs(3,jj)
1996 fep(i) = sigrs(4,jj)
1997 IF (igtyp /= 26) THEN ! IGTYP = 4,12
1998 dpl(i) = sigrs(5,jj)
1999 dpl2(i) = sigrs(6,jj)
2000 ENDIF
2001 xl0(i) = sigrs(7,jj)
2002 eint(i) = sigrs(8,jj)
2003 IF (igtyp == 12) THEN
2004 dfs(i) = sigrs(9,jj)
2005 ELSEIF (igtyp == 26) THEN
2006 dv(i) = sigrs(9,jj)
2007 ENDIF
2008C---
2009 200 CONTINUE
2010 ENDDO ! DO I=LFT,LLT
2011 ENDIF ! IF (INISPRI /= 0)
2012C---
2013 RETURN
2014 END
2015!||====================================================================
2016!|| r8ini ../starter/source/elements/spring/rinit3.F
2017!||--- called by ------------------------------------------------------
2018!|| rinit3 ../starter/source/elements/spring/rinit3.F
2019!||--- uses -----------------------------------------------------
2020!||====================================================================
2021 SUBROUTINE r8ini(IGTYP ,NEL ,SIGRS ,IXR ,NSIGI,
2022 . FX ,FY ,FZ ,MX ,MY ,
2023 . MZ ,FXEP ,FYEP ,FZEP ,XMEP ,
2024 . YMEP ,ZMEP ,DXPL ,DYPL ,DZPL ,
2025 . RPX ,RPY ,RPZ ,DXPL2 ,DYPL2,
2026 . DZPL2 ,RPX2 ,RPY2 ,RPZ2 ,DX ,
2027 . DY ,DZ ,RX ,RY ,RZ ,
2028 . XL0 ,YL0 ,ZL0 ,EINT ,E6 ,
2029 . PTSPRI,DX0 ,DY0 ,DZ0 ,RX0 ,
2030 . RY0 ,RZ0 ,FX0 ,FY0 ,FZ0 ,
2031 . MX0 ,MY0 ,MZ0 )
2032 use element_mod , only : nixr
2033C-----------------------------------------------
2034C I m p l i c i t T y p e s
2035C-----------------------------------------------
2036#include "implicit_f.inc"
2037C-----------------------------------------------
2038C C o m m o n B l o c k s
2039C-----------------------------------------------
2040#include "vect01_c.inc"
2041#include "com01_c.inc"
2042C-----------------------------------------------
2043C D u m m y A r g u m e n t s
2044C-----------------------------------------------
2045
2046 INTEGER IXR(NIXR,*),NSIGI,NEL,IGTYP,PTSPRI(*)
2047C REAL
2048 my_real
2049 . fx(*),fy(*),fz(*),eint(*),sigrs(nsigi,*),
2050 . mx(*),my(*),mz(*),dxpl(*),dypl(*),dzpl(*),
2051 . dxpl2(*),dzpl2(*),dypl2(*),fxep(*),fyep(*),fzep(*),
2052 . xmep(*),ymep(*),zmep(*),rpx(*),rpy(*),rpz(*),
2053 . rpx2(*),rpy2(*),rpz2(*),dx(*),dy(*),dz(*),rx(*),
2054 . ry(*),rz(*),xl0(*),yl0(*),zl0(*),e6(nel,6),
2055 . dx0(*),dy0(*),dz0(*),rx0(*),ry0(*),rz0(*),
2056 . fx0(*),fy0(*),fz0(*),mx0(*),my0(*),mz0(*)
2057C-----------------------------------------------
2058C L o c a l V a r i a b l e s
2059C-----------------------------------------------
2060 INTEGER I,II,JJ
2061C-----------------------------------------------------------------------
2062C---
2063C CONTRAINTES INITIALES + OTHERS
2064C---
2065 IF (INISPRI /= 0) then
2066 DO i=lft,llt
2067 ii = i+nft
2068! length recumputed in engine if not concerned by INISPRI
2069 xl0(i) = zero
2070 yl0(i) = zero
2071 zl0(i) = zero
2072!
2073 jj = ptspri(ii)
2074 IF (jj == 0) GOTO 200
2075C---
2076 fxep(i) = sigrs(4, jj)
2077 dxpl(i) = sigrs(5, jj)
2078 dxpl2(i) = sigrs(6, jj)
2079 fyep(i) = sigrs(9,jj)
2080 dypl(i) = sigrs(10,jj)
2081 dypl2(i) = sigrs(11,jj)
2082 fzep(i) = sigrs(14,jj)
2083 dzpl(i) = sigrs(15,jj)
2084 dzpl2(i) = sigrs(16,jj)
2085 xmep(i) = sigrs(19,jj)
2086 rpx(i) = sigrs(20,jj)
2087 rpx2(i) = sigrs(21,jj)
2088 ymep(i) = sigrs(24,jj)
2089 rpy(i) = sigrs(25,jj)
2090 rpy2(i) = sigrs(26,jj)
2091 zmep(i) = sigrs(29,jj)
2092 rpz(i) = sigrs(30,jj)
2093 rpz2(i) = sigrs(31,jj)
2094 xl0(i) = sigrs(32,jj)
2095 yl0(i) = sigrs(33,jj)
2096 zl0(i) = sigrs(34,jj)
2097 IF (igtyp == 8 .OR. igtyp == 13 .OR.
2098 . igtyp == 23 .OR. igtyp == 25) THEN
2099 dx0(i) = sigrs(3, jj)
2100 fx0(i) = sigrs(2, jj)
2101 dy0(i) = sigrs(8, jj)
2102 fy0(i) = sigrs(7, jj)
2103 dz0(i) = sigrs(13,jj)
2104 fz0(i) = sigrs(12,jj)
2105 rx0(i) = sigrs(18,jj)
2106 mx0(i) = sigrs(17,jj)
2107 ry0(i) = sigrs(23,jj)
2108 my0(i) = sigrs(22,jj)
2109 rz0(i) = sigrs(28,jj)
2110 mz0(i) = sigrs(27,jj)
2111!
2112 e6(i,1) = sigrs(36,jj)
2113 e6(i,2) = sigrs(37,jj)
2114 e6(i,3) = sigrs(38,jj)
2115 e6(i,4) = sigrs(39,jj)
2116 e6(i,5) = sigrs(40,jj)
2117 e6(i,6) = sigrs(41,jj)
2118 ENDIF
2119C---
2120 200 CONTINUE
2121 ENDDO ! DO I=LFT,LLT
2122 ENDIF ! IF (INISPRI /= 0)
2123C---
2124 RETURN
2125 END
2126!||====================================================================
2127!|| ruini ../starter/source/elements/spring/rinit3.F
2128!||--- called by ------------------------------------------------------
2129!|| rinit3 ../starter/source/elements/spring/rinit3.F
2130!||====================================================================
2131 SUBROUTINE ruini(
2132 . SIGRS ,NSIGI,NUVAR,FX ,
2133 . FY ,FZ ,XMOM ,YMOM ,ZMOM ,
2134 . DX ,DY ,DZ ,RX ,RY ,
2135 . RZ ,UVAR ,EINT ,
2136 . PTSPRI)
2137C-----------------------------------------------
2138C I m p l i c i t T y p e s
2139C-----------------------------------------------
2140#include "implicit_f.inc"
2141C-----------------------------------------------
2142C C o m m o n B l o c k s
2143C-----------------------------------------------
2144#include "vect01_c.inc"
2145#include "com01_c.inc"
2146C-----------------------------------------------
2147C D u m m y A r g u m e n t s
2148C-----------------------------------------------
2149 INTEGER NUVAR,NSIGI
2150 INTEGER PTSPRI(*)
2151C REAL
2152 my_real
2153 . fx(*),fy(*),fz(*),xmom(*),ymom(*),zmom(*),
2154 . eint(*),sigrs(nsigi,*),
2155 . uvar(nuvar,*),dx(*),dy(*),dz(*),rx(*),ry(*),rz(*)
2156C-----------------------------------------------
2157C L o c a l V a r i a b l e s
2158C-----------------------------------------------
2159 INTEGER I,II,JJ,K,PT
2160C-----------------------------------------------
2161C---
2162C CONTRAINTES INITIALES + OTHERS
2163C---
2164 IF (inispri /= 0) THEN
2165C
2166 DO i=lft,llt
2167 ii = i+nft
2168 jj = ptspri(ii)
2169 IF (jj == 0) GOTO 200
2170C---
2171 fx(i) = sigrs(2, jj)
2172 dx(i) = sigrs(3, jj)
2173 fy(i) = sigrs(4, jj)
2174 dy(i) = sigrs(5, jj)
2175 fz(i) = sigrs(6, jj)
2176 dz(i) = sigrs(7, jj)
2177 xmom(i) = sigrs(8, jj)
2178 rx(i) = sigrs(9,jj)
2179 ymom(i) = sigrs(10,jj)
2180 ry(i) = sigrs(11,jj)
2181 zmom(i) = sigrs(12,jj)
2182 rz(i) = sigrs(13,jj)
2183 eint(i) = sigrs(14,jj)
2184C
2185 pt = 14
2186 DO k=1,nuvar
2187 uvar(k,i) = sigrs(pt + k ,jj)
2188 ENDDO
2189C---
2190 200 CONTINUE
2191 ENDDO ! DO I=LFT,LLT
2192 ENDIF ! IF (INISPRI /= 0)
2193C-----------
2194 RETURN
2195 END
my_real
#define my_real
Definition cppsort.cpp:32
rini32
subroutine rini32(nel, 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, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar)
Definition hm_read_prop36.F:264
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
bpreload_mod
Definition bpreload_mod.F:40
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
seatbelt_mod
Definition seatbelt_mod.F:55
seatbelt_mod::slipring
type(slipring_struct), dimension(:), allocatable slipring
Definition seatbelt_mod.F:110
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:31
r2buf3
subroutine r2buf3(off, geo, x, x0, y0, z0, ix, skew, iposx, iposy, iposz, iposxx, iposyy, iposzz, igeo, skew_id)
Definition r2buf3.F:34
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
rini44
subroutine rini44(nel, iout, iprop, ix, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar)
Definition rini44.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
rini46
subroutine rini46(nel, iout, iprop, ix, xl, mass, xiner, stifm, stifr, viscm, viscr, uvar, nuvar)
Definition rini46.F:38
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:2032
rini3u
subroutine rini3u(off, geo, x, x0, ix, skew, rloc, itab, uix, igeo)
Definition rinit3.F:1673
rini2u
subroutine rini2u(ixr, umass, uiner, partsav, x, v, ipart, msr, inr, msrt, ems)
Definition rinit3.F:1864
rinit3
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)
Definition rinit3.F:67
rini1u
subroutine rini1u(off, geo, x, x0, ix, skew, rloc, itab, uix, igeo)
Definition rinit3.F:1773
ruini
subroutine ruini(sigrs, nsigi, nuvar, fx, fy, fz, xmom, ymom, zmom, dx, dy, dz, rx, ry, rz, uvar, eint, ptspri)
Definition rinit3.F:2137
r4ini
subroutine r4ini(sigrs, ixr, nsigi, eint, f, dl, fep, dpl, dpl2, xl0, dfs, dv, igtyp, ptspri, dl0, f0)
Definition rinit3.F:1956
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:31
rmass
subroutine rmass(ixr, geo, ms, xin, partsav, x, v, ipart, xl, msr, inr, msrt, ems)
Definition rmass.F:32
r23mass
subroutine r23mass(ixr, geo, ms, xin, partsav, x, v, ipart, xl, msr, inr, msrt, ems, mass, uiner, mtyp)
Definition rmass.F:125
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:895
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
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
starter
program starter
Definition starter.F:39