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