OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ini_seatbelt.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "random_c.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine ini_seatbelt (iparg, elbuf_tab, knod2el1d, nod2el1d, ixr, x, itab, ipm, alea, knod2elc, nod2elc, ixc)

Function/Subroutine Documentation

◆ ini_seatbelt()

subroutine ini_seatbelt ( integer, dimension(nparg,ngroup) iparg,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(*) knod2el1d,
integer, dimension(*) nod2el1d,
integer, dimension(nixr,*) ixr,
x,
integer, dimension(*) itab,
integer, dimension(npropmi,*) ipm,
alea,
integer, dimension(*) knod2elc,
integer, dimension(*) nod2elc,
integer, dimension(nixc,*) ixc )

Definition at line 35 of file ini_seatbelt.F.

38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE my_alloc_mod
42 USE message_mod
43 USE seatbelt_mod
44 USE elbufdef_mod
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "param_c.inc"
53#include "com01_c.inc"
54#include "com04_c.inc"
55#include "random_c.inc"
56#include "tabsiz_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER IPARG(NPARG,NGROUP),KNOD2EL1D(*),NOD2EL1D(*),IXR(NIXR,*),ITAB(*),IPM(NPROPMI,*),
61 . KNOD2ELC(*),NOD2ELC(*),IXC(NIXC,*)
62 my_real :: x(3,*),alea(*)
63 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
64C-----------------------------------------------
65C F u n c t i o n
66C-----------------------------------------------
67 INTEGER NLOCAL
68 EXTERNAL nlocal
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I,J,K,L,M,N,NG,NEL,ITY,IAD,LFT,LLT,NFT,MTN,NODE,NODE_NEXT,
73 . ELEM_NEXT,N1,N2,NTOOL,KK,NOT_USED,FLAG,ELEM_CUR,NN,ID,NNOD,
74 . MID,MTYP,P,NB_SHELL,NFRAM,N3,N4,MS,NODES,ISEATBELT,NSL,IDRB,
75 . NOD,NFOUND_RBY,NFOUND_BCS,BCS_X,BCS_Y,BCS_Z,IC,IC1,IC2,N1SP,
76 . N2SP,ELEM,ORIENT
77C
78 my_real dist1,dist2,alea_max,tole_2
79C
80 INTEGER , DIMENSION(:), ALLOCATABLE:: TAG_RETRACTOR,TAGN_RETRACTOR,TAG_RES
81C
82 TYPE(G_BUFEL_),POINTER :: GBUF
83C-----------------------------------------------
84C S o u r c e L i n e s
85C-----------------------------------------------
86C
87C-----Reset of TAG_RES from SEATBELT_TAB structure----------------------------------
88 CALL my_alloc(tag_res,numelr)
89 tag_res(1:numelr) = 0
90 DO i=1,n_seatbelt
91 DO j=1,seatbelt_tab(i)%NSPRING
92 tag_res(seatbelt_tab(i)%SPRING(j)) = i
93 ENDDO
94 ENDDO
95C
96C-----Preparation for SPMD computation ---------------------------------------------
97 IF (nspmd > 1) THEN
98C
99 DO i=1,nslipring
100 DO j=1,slipring(i)%NFRAM
101 n2 = slipring(i)%FRAM(j)%NODE(2)
102 DO p=1,nspmd
103 IF ((nlocal(n2,p)==1).AND.(nlocal(slipring(i)%FRAM(j)%ANCHOR_NODE,p)==0)) THEN
104C-- Anchor node and orientation node must be stick on the proc of the slipring
105 CALL ifrontplus(slipring(i)%FRAM(j)%ANCHOR_NODE,p)
106 IF (slipring(i)%FRAM(j)%ORIENTATION_NODE > 0)
107 . CALL ifrontplus(slipring(i)%FRAM(j)%ORIENTATION_NODE,p)
108 ENDIF
109 ENDDO
110 ENDDO
111 ENDDO
112C
113 DO i=1,nretractor
114 n2 = retractor(i)%NODE(2)
115 DO p=1,nspmd
116 IF ((nlocal(n2,p)==1).AND.(nlocal(retractor(i)%ANCHOR_NODE,p)==0)) THEN
117C-- Anchor node must be stick on the proc of the retractor
118 CALL ifrontplus(retractor(i)%ANCHOR_NODE,p)
119 ENDIF
120 ENDDO
121 ENDDO
122C
123 ENDIF
124
125C-----------------------------------------------------------------------------------
126
127 CALL my_alloc(tag_retractor,numelr)
128 CALL my_alloc(tagn_retractor,numnod)
129 tag_retractor(1:numelr) = 0
130 tagn_retractor(1:numnod) = 0
131 flag = 1
132 not_used = 0
133C
134C----- Loop on retractors to identify elements in retractor to deactivate (same algorithm as in creat_seatbelt) --
135C
136 DO i=1,nretractor
137C
138 n1 = retractor(i)%NODE(1)
139 n2 = retractor(i)%NODE(2)
140C
141C-- loop of elements initially inside the retractor - tag with negative value
142C
143 nnod = 2
144C
145 DO k=knod2el1d(n1)+1,knod2el1d(n1+1)
146 IF (nod2el1d(k) > numelt+numelp) THEN
147 elem_cur = nod2el1d(k)-numelt-numelp
148 mid = ixr(5,elem_cur)
149 IF (mid > 0) THEN
150 mtyp = ipm(2,mid)
151 IF (((ixr(2,elem_cur)==n2).OR.(ixr(3,elem_cur)==n2)).AND.(mtyp == 114)) THEN
152C-- Loop on belt inside the retractor
153 CALL new_seatbelt(ixr,itab,knod2el1d,nod2el1d,n1,
154 . elem_cur,tag_retractor,tagn_retractor,i,flag,
155 . not_used,ipm,not_used,not_used,not_used,
156 . not_used)
157 ENDIF
158 ENDIF
159 ENDIF
160 ENDDO
161C
162 ENDDO
163C
164C-- Loop to initialise elements with seatbelt material
165C
166 DO ng=1,ngroup
167C
168 mtn = iparg(1,ng)
169 nel = iparg(2,ng)
170 ity = iparg(5,ng)
171 nft = iparg(3,ng)
172 iad = iparg(4,ng)
173 iseatbelt = iparg(91,ng)
174 lft = 1
175 llt = nel
176C
177 IF ((ity==6).AND.(mtn==114)) THEN
178C
179C--- 1D seatbelts springs
180C
181 gbuf => elbuf_tab(ng)%GBUF
182C
183 DO i=1,nel
184C
185 j = nft + i
186 n1 = ixr(2,j)
187 n2 = ixr(3,j)
188 ntool = 0
189C
190C----------------------------------------------------------------------------
191C- Detection if element is in slipring
192C----------------------------------------------------------------------------
193C
194 DO k=1,nslipring
195 DO l=1,slipring(k)%NFRAM
196 IF (((n1==slipring(k)%FRAM(l)%NODE(1)).AND.(n2==slipring(k)%FRAM(l)%NODE(2))).OR.
197 . ((n1==slipring(k)%FRAM(l)%NODE(2)).AND.(n2==slipring(k)%FRAM(l)%NODE(1)))) THEN
198CC- element is strand number 1
199 ntool = ntool + 1
200 gbuf%SLIPRING_ID(i) = k
201 gbuf%SLIPRING_FRAM_ID(i) = l
202 gbuf%SLIPRING_STRAND(i) = 1
203C
204CC- determinaton of slipring direction for strand1
205 IF (n1==slipring(k)%FRAM(l)%NODE(1)) THEN
206 slipring(k)%FRAM(l)%STRAND_DIRECTION(1) = 1
207 ELSE
208 slipring(k)%FRAM(l)%STRAND_DIRECTION(1) = -1
209 ENDIF
210C
211 ELSEIF (((n1==slipring(k)%FRAM(l)%NODE(2)).AND.(n2==slipring(k)%FRAM(l)%NODE(3))).OR.
212 . ((n1==slipring(k)%FRAM(l)%NODE(3)).AND.(n2==slipring(k)%FRAM(l)%NODE(2)))) THEN
213CC- element is strand number 2
214 ntool = ntool + 1
215 gbuf%SLIPRING_ID(i) = k
216 gbuf%SLIPRING_FRAM_ID(i) = l
217 gbuf%SLIPRING_STRAND(i) = 2
218C
219CC- determinaton of slipring direction for strand2
220 IF (n1==slipring(k)%FRAM(l)%NODE(2)) THEN
221 slipring(k)%FRAM(l)%STRAND_DIRECTION(2) = 1
222 ELSE
223 slipring(k)%FRAM(l)%STRAND_DIRECTION(2) = -1
224 ENDIF
225C
226 ENDIF
227 ENDDO
228 ENDDO
229C
230C----------------------------------------------------------------------------
231C- Detection if element is in retractor
232C----------------------------------------------------------------------------
233C
234 DO k=1,nretractor
235 IF (((n1==retractor(k)%NODE(1)).AND.(n2==retractor(k)%NODE(2))).OR.
236 . ((n2==retractor(k)%NODE(1)).AND.(n1==retractor(k)%NODE(2)))) THEN
237CC- element is mouth element of retractor - 1st direction
238 ntool = ntool + 1
239 gbuf%RETRACTOR_ID(i) = k
240 gbuf%SLIPRING_STRAND(i) = -1
241 ENDIF
242 ENDDO
243C
244 IF (tag_retractor(j) > 0) THEN
245C- element initially in the retractor
246 gbuf%OFF(i) = zero
247 gbuf%RETRACTOR_ID(i) = -k
248 k = tag_retractor(j)
249 id = retractor(k)%ID
250 nn = retractor(k)%ANCHOR_NODE
251 dist1 = (x(1,nn)-x(1,n1))**2+(x(2,nn)-x(2,n1))**2+(x(3,nn)-x(3,n1))**2
252 dist2 = (x(1,nn)-x(1,n2))**2+(x(2,nn)-x(2,n2))**2+(x(3,nn)-x(3,n2))**2
253C
254C-- default tolerance
255 tole_2 = em10*retractor(k)%ELEMENT_SIZE*retractor(k)%ELEMENT_SIZE
256C-- compatibility with random noise
257 IF (nrand > 0) THEN
258 alea_max = zero
259 DO j=1,nrand
260 alea_max = max(alea_max,alea(j))
261 ENDDO
262 tole_2 = max(tole_2,ten*alea_max*alea_max)
263 ENDIF
264
265C-- tolerance if nodes are very close to anchorage node
266 IF (dist1 <= tole_2) THEN
267 x(1,n1) = x(1,nn)
268 x(2,n1) = x(2,nn)
269 x(3,n1) = x(3,nn)
270 dist1 = zero
271 ENDIF
272 IF (dist2 <= tole_2) THEN
273 x(1,n2) = x(1,nn)
274 x(2,n2) = x(2,nn)
275 x(3,n2) = x(3,nn)
276 dist2 = zero
277 ENDIF
278C
279 IF(dist2 + dist1 > em30) CALL ancmsg(msgid=2011,
280 . msgtype=msgerror,
281 . anmode=aninfo,
282 . i1=id,i2=ixr(nixr,j),i3=id)
283C
284 IF (tagn_retractor(n1) > 0) THEN
285 retractor(k)%INACTI_NNOD = retractor(k)%INACTI_NNOD + 1
286 retractor(k)%INACTI_NODE(retractor(k)%INACTI_NNOD) = n1
287 tagn_retractor(n1) = 0
288 ENDIF
289C
290 IF (tagn_retractor(n2) > 0) THEN
291 retractor(k)%INACTI_NNOD = retractor(k)%INACTI_NNOD + 1
292 retractor(k)%INACTI_NODE(retractor(k)%INACTI_NNOD) = n2
293 tagn_retractor(n2) = 0
294 ENDIF
295C
296 ENDIF
297C
298C----------------------------------------------------------------------------
299C
300 IF(ntool > 1) CALL ancmsg(msgid=2006,
301 . msgtype=msgerror,
302 . anmode=aninfo,
303 . i1=ixr(nixr,j))
304C
305CCC- Find node before node 1
306 node = n1
307 node_next = 0
308 DO k=knod2el1d(node)+1,knod2el1d(node+1)
309 IF ((nod2el1d(k) /= j + numelt+numelp).AND.(nod2el1d(k) > numelt+numelp)) THEN
310 elem_next = nod2el1d(k)-numelt-numelp
311 mid = ixr(5,elem_next)
312 IF (mid > 0) THEN
313 mtyp = ipm(2,mid)
314 IF (mtyp == 114) THEN
315 IF (ixr(2,elem_next) == node) THEN
316 node_next = ixr(3,elem_next)
317 ELSE
318 node_next = ixr(2,elem_next)
319 ENDIF
320 ENDIF
321 ENDIF
322 ENDIF
323 ENDDO
324 gbuf%ADD_NODE(i) = node_next
325
326CCC- Find node after node 2
327 node = n2
328 node_next = 0
329 DO k=knod2el1d(node)+1,knod2el1d(node+1)
330 IF ((nod2el1d(k) /= j + numelt+numelp).AND.(nod2el1d(k) > numelt+numelp)) THEN
331 elem_next = nod2el1d(k)-numelt-numelp
332 mid = ixr(5,elem_next)
333 IF (mid > 0) THEN
334 mtyp = ipm(2,mid)
335 IF (mtyp == 114) THEN
336 IF (ixr(2,elem_next) == node) THEN
337 node_next = ixr(3,elem_next)
338 ELSE
339 node_next = ixr(2,elem_next)
340 ENDIF
341 ENDIF
342 ENDIF
343 ENDIF
344 ENDDO
345 gbuf%ADD_NODE(nel+i) = node_next
346C
347CCC- Compute Fram factor for 2D seatbelt
348C
349 nb_shell = 0
350 IF (gbuf%ADD_NODE(i) > 0) THEN
351 node = n1
352 ELSE
353 node = n2
354 ENDIF
355 DO k=knod2elc(node)+1,knod2elc(node+1)
356 elem_cur = nod2elc(k)
357 mid = ixc(1,elem_cur)
358 mtyp = ipm(2,mid)
359 IF (mtyp == 119) nb_shell = nb_shell + 1
360 ENDDO
361C
362 nfram = seatbelt_tab(tag_res(j))%NFRAM
363 IF ((nfram > 1).AND.(nb_shell==4)) THEN
364C-- spring is on the edge of the 2D belt
365 gbuf%FRAM_FACTOR(i) = one/(nfram-1)
366 ELSEIF ((nfram > 1).AND.(nb_shell==2)) THEN
367C-- spring is inside the 2D belt
368 gbuf%FRAM_FACTOR(i) = half/(nfram-1)
369 ELSE
370C-- 1D seatbelt
371 gbuf%FRAM_FACTOR(i) = one
372 ENDIF
373C-- element mass and inertia scaled by frame factor for elementary time step
374 gbuf%MASS(i) = gbuf%MASS(i)*gbuf%FRAM_FACTOR(i)
375 gbuf%INTVAR(i) = gbuf%INTVAR(i)*gbuf%FRAM_FACTOR(i)
376C
377 ENDDO
378C
379 ELSEIF ((ity==3).AND.(iseatbelt==1)) THEN
380C
381C--- 2D seatbelts shells
382C
383 gbuf => elbuf_tab(ng)%GBUF
384C
385 DO i=1,nel
386C
387 j = nft + i
388C
389 n1 = ixc(2,j)
390 n2 = ixc(3,j)
391 n3 = ixc(4,j)
392 n4 = ixc(5,j)
393C
394C-- Scale factor on stress initialised
395 gbuf%INTVAR(i) = one
396C
397C-- Initial length of fram 1/2 and fram 4/3
398 dist1 = (x(1,n2)-x(1,n1))**2+(x(2,n2)-x(2,n1))**2+(x(3,n2)-x(3,n1))**2
399 dist2 = (x(1,n3)-x(1,n4))**2+(x(2,n3)-x(2,n4))**2+(x(3,n3)-x(3,n4))**2
400 gbuf%INTVAR(i+2*nel) = sqrt(dist1)
401 gbuf%INTVAR(i+3*nel) = sqrt(dist2)
402C
403CCC- Find node defining 1rst orthotropy direction with N1 using springs : N2 (default) or N4
404 gbuf%ADD_NODE(i) = n2
405 DO k=knod2el1d(n1)+1,knod2el1d(n1+1)
406 IF (nod2el1d(k) > numelt+numelp) THEN
407 elem = nod2el1d(k)-numelt-numelp
408 mid = ixr(5,elem)
409 IF (mid > 0) THEN
410 mtyp = ipm(2,mid)
411 IF ((mtyp==114).AND.((ixr(2,elem)==n1).AND.(ixr(3,elem) == n4))
412 . .OR.((ixr(3,elem)==n1).AND.(ixr(2,elem) == n4))) THEN
413 gbuf%ADD_NODE(i) = n4
414 ENDIF
415 ENDIF
416 ENDIF
417 ENDDO
418C
419CCC- Find node after node i
420 DO m=2,5
421 node = ixc(m,j)
422 node_next = 0
423 DO k=knod2el1d(node)+1,knod2el1d(node+1)
424 IF (nod2el1d(k) > numelt+numelp) THEN
425 elem_next = nod2el1d(k)-numelt-numelp
426 mid = ixr(5,elem_next)
427 IF (mid > 0) THEN
428 mtyp = ipm(2,mid)
429 IF (mtyp==114) THEN
430 n1sp=ixr(2,elem_next)
431 n2sp=ixr(3,elem_next)
432 IF ((n1sp==node).AND.(n2sp/=n1).AND.(n2sp/=n2).AND.(n2sp/=n3).AND.(n2sp/=n4)) THEN
433 node_next = n2sp
434 ELSEIF ((n2sp==node).AND.(n1sp/=n1).AND.(n1sp/=n2).AND.(n1sp/=n3).AND.(n1sp/=n4)) THEN
435 node_next = n1sp
436 ENDIF
437 ENDIF
438 ENDIF
439 ENDIF
440 ENDDO
441 gbuf%ADD_NODE((m-1)*nel+i) = node_next
442C
443 ENDDO
444C
445 ENDDO
446C
447 ENDIF
448C
449 ENDDO
450C
451 DEALLOCATE(tag_res,tag_retractor,tagn_retractor)
452C
my_real
#define my_real
Definition cppsort.cpp:32
nlocal
integer function nlocal(n, p)
Definition ddtools.F:349
ifrontplus
subroutine ifrontplus(n, p)
Definition frontplus.F:100
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
message_mod
Definition message_mod.F:1249
seatbelt_mod
Definition seatbelt_mod.F:55
seatbelt_mod::retractor
type(retractor_struct), dimension(:), allocatable retractor
Definition seatbelt_mod.F:155
seatbelt_mod::seatbelt_tab
type(seatbelt_struct), dimension(:), allocatable seatbelt_tab
Definition seatbelt_mod.F:171
seatbelt_mod::slipring
type(slipring_struct), dimension(:), allocatable slipring
Definition seatbelt_mod.F:110
new_seatbelt
subroutine new_seatbelt(ixr, itab, knod2el1d, nod2el1d, nod_start, elem_cur, tag_res, tag_nod, id, flag, nnod, ipm, nb_elem_1d, nb_branch, branch_tab, branch_cpt)
Definition new_seatbelt.F:38
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