OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
create_seatbelt.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!|| create_seatbelt ../starter/source/tools/seatbelts/create_seatbelt.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| c_prevent_decomposition ../starter/source/spmd/domain_decomposition/c_domain_decomposition.cpp
30!|| new_seatbelt ../starter/source/tools/seatbelts/new_seatbelt.F
31!||--- uses -----------------------------------------------------
32!|| message_mod ../starter/share/message_module/message_mod.F
33!||====================================================================
34 SUBROUTINE create_seatbelt(IXR,ITAB,KNOD2EL1D,NOD2EL1D,IPM,
35 . X,SENSORS,BUFMAT,PM,GEO,
36 . IDDLEVEL,KNOD2ELC,NOD2ELC,IXC,IGEO,
37 . ISKN ,TF ,NPC)
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 sensor_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 "units_c.inc"
55#include "com04_c.inc"
56#include "com01_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 IDDLEVEL,IXR(NIXR,*),ITAB(*),KNOD2EL1D(*),NOD2EL1D(*),IPM(NPROPMI,*),
62 . KNOD2ELC(*),NOD2ELC(*),IXC(NIXC,*)
63 INTEGER, INTENT(INOUT) :: IGEO(NPROPGI,NUMGEO),ISKN(SISKWN)
64 my_real x(3,*),bufmat(*),pm(npropm,*),geo(npropg,*)
65 TYPE (SENSORS_) ,INTENT(IN) :: SENSORS
66 INTEGER ,INTENT(IN) :: NPC(SNPC)
67 my_real ,INTENT(IN) :: tf(stf)
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71 INTEGER I,J,K,L,JJ,NOD_START,SEATBELT_ID,COMPT,ELEM_CUR,
72 . FLAG,NNOD,MTYP,MID,NDIR,
73 . I1,I2,IADBUF,TAG_PRINT,ISENS_LOC(2),IPID,OFFC,OFFR,NB_ELEM,NODE,
74 . nb_2d_seatbelt,compt_belt_end,compt_fram,next_node,node_cur,compt_2d,mid_2d,node_longi,
75 . func1,func2,isk,n1,n2,seatbelt_elem_found,imov,iecrou,nb_elem_1d,nb_branch,
76 . branch_cpt,nb_elem_2d,j1,npt,npt2,stat,warnfunc,same_func,mid2,mtyp2,flag_shell
77 my_real dist2,lmin,rho,xk,xc,area,longi_direction(3),edge_direction(3),scal,e11,e22,g12,det,
78 . n12,n21,nu,fscale1,fscale2,a11,a22,a12,c1,ssp,rho0,fscalet,kmax,a1c,a2c
79 my_real x1,x2,y1,y2,shift,deri,min_slope,min_slope_abs,deri_p
80C
81 INTEGER , DIMENSION(:), ALLOCATABLE:: TAG_RES,TAG_SHELL,TAG_NOD,CC_ELEM,CPT_MAT,TAG_MAT_2D,
82 . tag_nod_shell,tag_nod_spring,fram_tab,tag_fram_seatbelt,
83 . nnod_fram_seatbelt,belt_end_nfram,belt_end_addr,tag_prop_2d,
84 . branch_tab,tag_spring_2d,tag_nod_spri2d,tag_comn_1d_2d
85 my_real , DIMENSION(:), ALLOCATABLE:: av_len_mat,av_area_mat,elemsize_mat,belt_end_section,
86 . section_mat
87C-----------------------------------------------
88C S o u r c e L i n e s
89C-----------------------------------------------
90C
91C-----------------------------------------------
92C-- Check of sensor and sliprings (not made in hm_read_slipring or hm_read_retractor as sensor are not yet read)
93 nb_2d_seatbelt = 0
94C
95 IF (iddlevel == 0) THEN
96C
97 DO i=1,nslipring
98 isens_loc(1) = 0
99 IF(slipring(i)%SENSID > 0)THEN
100 DO k=1,sensors%NSENSOR
101 IF(slipring(i)%SENSID == sensors%SENSOR_TAB(k)%SENS_ID) isens_loc(1) = k
102 ENDDO
103 IF(isens_loc(1) == 0) THEN
104 CALL ancmsg(msgid=2002,
105 . msgtype=msgerror,
106 . anmode=aninfo_blind_1,
107 . c1='SENSOR',
108 . i1=slipring(i)%ID,i2=slipring(i)%SENSID)
109 ELSE
110 slipring(i)%SENSID = isens_loc(1)
111 ENDIF
112 ENDIF
113 ENDDO
114C
115 DO i=1,nretractor
116 isens_loc(1:2) = 0
117C check of sensors
118 DO j=1,2
119 IF(retractor(i)%ISENS(j) > 0)THEN
120 DO k=1,sensors%NSENSOR
121 IF(retractor(i)%ISENS(j) == sensors%SENSOR_TAB(k)%SENS_ID) isens_loc(j) = k
122 ENDDO
123 IF(isens_loc(j) == 0) THEN
124 CALL ancmsg(msgid=2028,
125 . msgtype=msgerror,
126 . anmode=aninfo_blind_1,
127 . c1='SENSOR',
128 . i1=retractor(i)%ID,i2=retractor(i)%ISENS(j))
129 ELSE
130 retractor(i)%ISENS(j) = isens_loc(j)
131 ENDIF
132 ENDIF
133 ENDDO
134C check if functions are identical
135 same_func = 0
136 IF ((retractor(i)%IFUNC(1) > 0).AND.(retractor(i)%IFUNC(2) > 0)) THEN
137 npt=(npc(retractor(i)%IFUNC(1)+1)-npc(retractor(i)%IFUNC(1)))/2
138 npt2=(npc(retractor(i)%IFUNC(2)+1)-npc(retractor(i)%IFUNC(2)))/2
139 IF (retractor(i)%IFUNC(1)==retractor(i)%IFUNC(2)) THEN
140 same_func = 1
141 ELSEIF (npt == npt2) THEN
142 same_func = 1
143 DO k=1,npt
144 j1 =2*(k-1)
145 x1 = tf(npc(retractor(i)%IFUNC(1)) + j1)
146 y1 = tf(npc(retractor(i)%IFUNC(1)) + j1 + 1)
147 x2 = tf(npc(retractor(i)%IFUNC(2)) + j1)
148 y2 = tf(npc(retractor(i)%IFUNC(2)) + j1 + 1)
149 IF ((x1 /= x2).OR.(y1 /= y2)) same_func = 0
150 ENDDO
151 ENDIF
152 ENDIF
153C functions are stored in table and in case of null slope a small slope is added
154 retractor(i)%S_TABLE(1:2) = 0
155 DO j=1,2
156 IF (retractor(i)%IFUNC(j) > 0) THEN
157 npt=(npc(retractor(i)%IFUNC(j)+1)-npc(retractor(i)%IFUNC(j)))/2
158 retractor(i)%S_TABLE(j) = npt
159 retractor(i)%TABLE(j)%NDIM = 1
160 ALLOCATE (retractor(i)%TABLE(j)%X(1),stat=stat)
161 ALLOCATE (retractor(i)%TABLE(j)%X(1)%VALUES(npt),stat=stat)
162 ALLOCATE (retractor(i)%TABLE(j)%Y,stat=stat)
163 ALLOCATE (retractor(i)%TABLE(j)%Y%VALUES(npt),stat=stat)
164C first pass to find minimum slope
165 min_slope = ep20
166 min_slope_abs = ep20
167 warnfunc = 0
168 DO k=2,npt
169 j1 =2*(k-2)
170 x1 = tf(npc(retractor(i)%IFUNC(j)) + j1)
171 y1 = tf(npc(retractor(i)%IFUNC(j)) + j1 + 1)
172 x2 = tf(npc(retractor(i)%IFUNC(j)) + j1 + 2)
173 y2 = tf(npc(retractor(i)%IFUNC(j)) + j1 + 3)
174 deri = (y2-y1)/(x2-x1)
175 IF (abs(deri) > em20) THEN
176 min_slope = min(min_slope,deri)
177 min_slope_abs = min(min_slope_abs,abs(deri))
178 ELSE
179 warnfunc = 1
180 ENDIF
181 ENDDO
182C if slope is zero, error message is issued
183 IF(warnfunc == 1) THEN
184 CALL ancmsg(msgid=3073,
185 . msgtype=msgwarning,
186 . anmode=aninfo_blind_1,
187 . i1=retractor(i)%ID,
188 . i2=npc(nfunct+retractor(i)%IFUNC(j)+1),
189 . r1=em05*min_slope_abs)
190 ENDIF
191C Unload function must be monotoninc if func1 /= func2 - table_inv is used in material_flow
192C
193 IF ((same_func == 0).and.((j==2).and.(min_slope<zero))) THEN
194 CALL ancmsg(msgid=3071,
195 . msgtype=msgwarning,
196 . anmode=aninfo_blind_1,
197 . i1=retractor(i)%ID,
198 . i2=npc(nfunct+retractor(i)%IFUNC(j)+1))
199 ENDIF
200C functions must be monotoninc if (Fmax > 0 and pretens=1 or 5) or pretens=3 - table_inv is used in material_flow
201 IF ((((((retractor(i)%TENS_TYP==1).or.(retractor(i)%TENS_TYP==5)).and.(retractor(i)%FORCE>zero)))
202 . .or.(retractor(i)%TENS_TYP==3)).and.(min_slope<zero)) THEN
203 CALL ancmsg(msgid=3072,
204 . msgtype=msgerror,
205 . anmode=aninfo_blind_1,
206 . i1=retractor(i)%ID,
207 . i2=npc(nfunct+retractor(i)%IFUNC(j)+1))
208 ENDIF
209C second pass to add slope if too small
210 retractor(i)%TABLE(j)%X(1)%VALUES(1) = tf(npc(retractor(i)%IFUNC(j)))
211 retractor(i)%TABLE(j)%Y%VALUES(1) = tf(npc(retractor(i)%IFUNC(j))+1)
212 shift = zero
213 deri_p = zero
214 DO k=2,npt
215 j1 =2*(k-2)
216 x1 = tf(npc(retractor(i)%IFUNC(j)) + j1)
217 y1 = tf(npc(retractor(i)%IFUNC(j)) + j1 + 1) + shift
218 x2 = tf(npc(retractor(i)%IFUNC(j)) + j1 + 2)
219 y2 = tf(npc(retractor(i)%IFUNC(j)) + j1 + 3)
220 deri = (y2-y1)/(x2-x1)
221 IF (abs(deri) < em05*min_slope_abs) THEN
222 shift = shift+em05*sign(min_slope_abs*(x2-x1),deri_p)
223 ELSE
224 shift = zero
225 ENDIF
226C small slope not added for unload curve
227 IF (j==2) shift=zero
228 retractor(i)%TABLE(j)%X(1)%VALUES(k) = x2
229 retractor(i)%TABLE(j)%Y%VALUES(k) = y2 + shift
230 deri_p=deri
231 ENDDO
232 ENDIF
233 ENDDO
234 ENDDO
235C
236 ENDIF
237C
238C-----------------------------------------------
239C
240C-- Loop to find elements of the seatbelt from starting node for each slipiring/retractor
241C-- Need to check bifurcation in seatbelt and to tag elements on same cpu for domdec
242C
243C-----------------------------------------------
244C
245 CALL my_alloc(tag_nod_shell,numnod)
246 CALL my_alloc(tag_prop_2d,numgeo)
247 tag_nod_shell(1:numnod) = 0
248 tag_prop_2d(1:numgeo) = 0
249 nb_elem_2d = 0
250 DO i=1,numelc
251 mid = ixc(1,i)
252 mtyp = ipm(2,mid)
253 ipid = ixc(6,i)
254 IF (mtyp == 119) THEN
255 nb_elem_2d = nb_elem_2d + 1
256 DO j=2,5
257 tag_nod_shell(ixc(j,i)) = tag_nod_shell(ixc(j,i)) + 1
258 ENDDO
259C- tag of prop type 9 to 1 to set IP=24 or -2 if conflict with non seatbelt elements
260 IF (tag_prop_2d(ipid)==0) tag_prop_2d(ipid) = 1
261 IF (tag_prop_2d(ipid)==-1) tag_prop_2d(ipid) = -2
262 ELSEIF (igeo(11,ipid)==9) THEN
263C- tag of prop type 9 to -2 for error message if conflict with non seatbelt elements
264 IF (tag_prop_2d(ipid)==0) tag_prop_2d(ipid) = -1
265 IF (tag_prop_2d(ipid)==1) tag_prop_2d(ipid) = -2
266 ENDIF
267 ENDDO
268C
269 nb_elem_1d = 0
270 n_comn_1d2d = 0
271 CALL my_alloc(tag_nod_spring,numnod)
272 CALL my_alloc(tag_nod_spri2d,numnod)
273 CALL my_alloc(tag_spring_2d,numelr)
274 tag_nod_spring(1:numnod) = 0
275 tag_nod_spri2d(1:numnod) = 0
276 tag_spring_2d(1:numelr) = 0
277 DO i=1,numelr
278 mid = ixr(5,i)
279 IF (mid > 0) THEN
280 mtyp = ipm(2,mid)
281 IF (mtyp == 114) THEN
282 nb_elem_1d = nb_elem_1d + 1
283 DO j=2,3
284 tag_nod_spring(ixr(j,i)) = tag_nod_spring(ixr(j,i)) + 1
285 ENDDO
286C check if spring is attached to a 2D seatblet element
287 n1 = ixr(2,i)
288 n2 = ixr(3,i)
289 DO k=knod2elc(n1)+1,knod2elc(n1+1)
290 elem_cur = nod2elc(k)
291 mid2 = ixc(1,elem_cur)
292 mtyp2 = ipm(2,mid2)
293 IF (mtyp2==119) THEN
294 DO j=2,5
295 IF (ixc(j,elem_cur)==n2) tag_spring_2d(i) = 1
296 ENDDO
297 ENDIF
298 ENDDO
299 DO j=2,3
300 tag_nod_spri2d(ixr(j,i)) = tag_nod_spri2d(ixr(j,i)) + tag_spring_2d(i)
301C if node is connected to 2 spring and only 1 is kined to 2D seatblet then it's a 1D/2D blet connection
302 IF (((tag_nod_spri2d(ixr(j,i)))==1).AND.(tag_nod_spring(ixr(j,i))==2)) n_comn_1d2d = n_comn_1d2d + 1
303 ENDDO
304 ENDIF
305 ENDIF
306 ENDDO
307C
308C Mat_seatbelt not used - nothing to do
309 IF ((nb_elem_1d > 0).or.(nb_elem_2d > 0)) THEN
310C
311C----------------------------------------------------------------------------
312C--- Check of /PROP/TYPE9 - IP flag and skew
313C----------------------------------------------------------------------------
314C
315 DO i=1,numgeo
316C- automatic setting of ip = 24
317 IF (igeo(14,i) /= 24) THEN
318 IF (tag_prop_2d(i) == 1) THEN
319 igeo(14,i) = 24
320 CALL ancmsg(msgid=2076,
321 . msgtype=msgwarning,
322 . anmode=aninfo_blind_1,
323 . i1=igeo(1,i))
324 isk = igeo(2,i)
325 IF (isk > 0) THEN
326C- skew must be skew/mov or skew/fix
327 imov = iskn(liskn*(isk-1)+5)
328 IF (imov == 0) THEN
329 CALL ancmsg(msgid=2082,
330 . msgtype=msgerror,
331 . anmode=aninfo_blind_1,
332 . i1=igeo(1,i))
333 ENDIF
334 ENDIF
335 ELSEIF (tag_prop_2d(i) == -2) THEN
336 CALL ancmsg(msgid=2077,
337 . msgtype=msgerror,
338 . anmode=aninfo_blind_1,
339 . i1=igeo(1,i))
340 ENDIF
341 ENDIF
342C- check of nodes 1 and 2 of skew - must be on the same element
343 IF (tag_prop_2d(i)==1) THEN
344 isk = igeo(2,i)
345 IF (isk > 0) THEN
346 imov = iskn(liskn*(isk-1)+5)
347 IF (imov > 0) THEN
348 n1 = iskn(liskn*(isk-1)+1)
349 n2 = iskn(liskn*(isk-1)+2)
350 seatbelt_elem_found = 0
351 DO k=knod2elc(n1)+1,knod2elc(n1+1)
352 elem_cur = nod2elc(k)
353 mid = ixc(1,elem_cur)
354 mtyp = ipm(2,mid)
355 IF (mtyp==119) THEN
356 DO j=2,5
357 IF (ixc(j,elem_cur)==n2) seatbelt_elem_found = 1
358 ENDDO
359 ENDIF
360 ENDDO
361 IF (seatbelt_elem_found == 0) THEN
362 CALL ancmsg(msgid=2083,
363 . msgtype=msgerror,
364 . anmode=aninfo_blind_1,
365 . i1=igeo(1,i),i2=iskn(liskn*(isk-1)+4))
366 ENDIF
367 ENDIF
368 ENDIF
369 ENDIF
370 ENDDO
371C
372 DEALLOCATE(tag_prop_2d)
373C
374C----------------------------------------------------------------------------
375C--- Loop on elements on edges of seatbelt
376C----------------------------------------------------------------------------
377C
378C-- if nshell = 1 and nspring = 1 -> node in corner of 2D belt
379C-- if nshell = 2 and nspring = 1 -> node on edge of 2D belt
380C-- if nshell = 0 and nspring = 1 -> node at end of 1D belt
381C-- if nspring = 2 and nspring_2D = 1 -> node common between 1D and 2D seatblet
382C
383C common nodes between 1D and 2D seatblet are tagged and stored in list
384 IF (iddlevel == 0) CALL my_alloc(comn_1d2d,n_comn_1d2d)
385 CALL my_alloc(tag_comn_1d_2d,numnod)
386 comn_1d2d(1:n_comn_1d2d) = 0
387 tag_comn_1d_2d(1:numnod) = 0
388 j = 0
389 DO i=1,numnod
390 IF ((tag_nod_spring(i) > tag_nod_spri2d(i)).and.(tag_nod_spri2d(i) > 0)) THEN
391 j = j + 1
392 comn_1d2d(j) = i
393 tag_comn_1d_2d(i) = 1
394 ENDIF
395 ENDDO
396 DEALLOCATE(tag_nod_spri2d)
397C
398 CALL my_alloc(tag_nod,numnod)
399 tag_nod(1:numnod) = 0
400 compt_belt_end = 0
401 compt_fram = 0
402 DO i=1,numnod
403 IF (((tag_nod_shell(i) < 2).AND.(tag_nod_spring(i)==1).AND.(tag_nod(i)==0)).OR.
404 . (tag_comn_1d_2d(i) == 1)) THEN
405 compt_belt_end = compt_belt_end + 1
406 compt_fram = compt_fram + 1
407 tag_nod(i) = 1
408 IF (tag_nod_shell(i) == 1) THEN
409 next_node = i
410 DO WHILE(next_node > 0)
411 node_cur = next_node
412 next_node = 0
413 DO k=knod2elc(node_cur)+1,knod2elc(node_cur+1)
414 elem_cur = nod2elc(k)
415 mid = ixc(1,elem_cur)
416 mtyp = ipm(2,mid)
417 IF (mtyp==119) THEN
418 DO j=2,5
419 IF (((tag_nod_spring(ixc(j,elem_cur))==1).OR.(tag_comn_1d_2d(ixc(j,elem_cur))==1))
420 . .AND.(tag_nod(ixc(j,elem_cur))==0)) THEN
421C-- next node on transverse edge of seatbelt
422 next_node = ixc(j,elem_cur)
423 tag_nod(next_node) = 1
424 compt_fram = compt_fram + 1
425 ENDIF
426 ENDDO
427 ENDIF
428 ENDDO
429 ENDDO
430 ENDIF
431 IF (tag_comn_1d_2d(i) == 1) tag_nod(i) = 0
432 ENDIF
433 ENDDO
434C
435 tag_nod(1:numnod) = 0
436 CALL my_alloc(belt_end_nfram,compt_belt_end)
437 CALL my_alloc(belt_end_addr,compt_belt_end)
438 CALL my_alloc(fram_tab,compt_fram)
439 CALL my_alloc(belt_end_section,compt_belt_end)
440 belt_end_nfram(1:compt_belt_end) = 0
441 belt_end_addr(1:compt_belt_end) = 0
442 belt_end_section(1:compt_belt_end) = zero
443 fram_tab(1:compt_fram) = 0
444 compt_belt_end = 0
445 compt_fram = 0
446 node_longi = -huge(node_longi)
447 DO i=1,numnod
448 IF (((tag_nod_shell(i) < 2).AND.(tag_nod_spring(i)==1).AND.(tag_nod(i)==0)).OR.
449 . (tag_comn_1d_2d(i) == 1)) THEN
450 compt_belt_end = compt_belt_end + 1
451 compt_fram = compt_fram + 1
452 tag_nod(i) = 1
453 belt_end_nfram(compt_belt_end) = 1
454 belt_end_addr(compt_belt_end) = compt_fram
455 fram_tab(compt_fram) = i
456 IF (tag_nod_shell(i) == 1) THEN
457C
458C-- determination of longitudinal direction using spring connected to corner of seatblet
459 DO k=knod2el1d(i)+1,knod2el1d(i+1)
460 IF (nod2el1d(k) > numelt+numelp) THEN
461 elem_cur = nod2el1d(k)-numelt-numelp
462 mid = ixr(5,elem_cur)
463 IF (mid > 0) THEN
464 mtyp = ipm(2,mid)
465 IF ((mtyp == 114).AND.(ixr(2,elem_cur)/= i)) THEN
466 node_longi = ixr(2,elem_cur)
467 ELSEIF (mtyp == 114) THEN
468 node_longi = ixr(3,elem_cur)
469 ENDIF
470 ENDIF
471 ENDIF
472 ENDDO
473 dist2 = (x(1,i)-x(1,node_longi))**2+(x(2,i)-x(2,node_longi))**2+(x(3,i)-x(3,node_longi))**2
474 longi_direction(1) = (x(1,i)-x(1,node_longi))/sqrt(max(em20,dist2))
475 longi_direction(2) = (x(2,i)-x(2,node_longi))/sqrt(max(em20,dist2))
476 longi_direction(3) = (x(3,i)-x(3,node_longi))/sqrt(max(em20,dist2))
477C
478 next_node = i
479 DO WHILE(next_node > 0)
480 node_cur = next_node
481 next_node = 0
482 DO k=knod2elc(node_cur)+1,knod2elc(node_cur+1)
483 elem_cur = nod2elc(k)
484 mid = ixc(1,elem_cur)
485 mtyp = ipm(2,mid)
486 IF (mtyp==119) THEN
487 DO j=2,5
488 IF (((tag_nod_spring(ixc(j,elem_cur))==1).OR.(tag_comn_1d_2d(ixc(j,elem_cur))==1))
489 . .AND.(tag_nod(ixc(j,elem_cur))==0)) THEN
490C-- next node on transverse edge of seatbelt
491 next_node = ixc(j,elem_cur)
492 tag_nod(next_node) = 1
493 compt_fram = compt_fram + 1
494 fram_tab(compt_fram) = next_node
495 ENDIF
496 ENDDO
497 ENDIF
498 ENDDO
499 IF (next_node > 0) THEN
500C-- seatbelt section is incremented
501 dist2 = (x(1,node_cur)-x(1,next_node))**2+(x(2,node_cur)-x(2,next_node))**2
502 . +(x(3,node_cur)-x(3,next_node))**2
503 edge_direction(1) = (x(1,node_cur)-x(1,next_node))/sqrt(max(em20,dist2))
504 edge_direction(2) = (x(2,node_cur)-x(2,next_node))/sqrt(max(em20,dist2))
505 edge_direction(3) = (x(3,node_cur)-x(3,next_node))/sqrt(max(em20,dist2))
506 scal = longi_direction(1)*edge_direction(1)+longi_direction(2)*edge_direction(2)
507 . +longi_direction(3)*edge_direction(3)
508 dist2 = dist2*(one-scal*scal)
509 ipid = ixc(6,elem_cur)
510 belt_end_section(compt_belt_end) = belt_end_section(compt_belt_end) + sqrt(max(em20,dist2))*geo(1,ipid)
511 ENDIF
512 ENDDO
513 belt_end_nfram(compt_belt_end) = compt_fram - belt_end_addr(compt_belt_end) + 1
514 ENDIF
515 IF (tag_comn_1d_2d(i) == 1) tag_nod(i) = 0
516 ENDIF
517 ENDDO
518C
519C DO I=1,COMPT_BELT_END
520C DO J=1,BELT_END_NFRAM(I)
521C print *,"-->",I,ITAB(FRAM_TAB(BELT_END_ADDR(I)+J-1))
522C ENDDO
523C print *,"SECTION",BELT_END_SECTION(I)
524C ENDDO
525C
526 DEALLOCATE(tag_nod_spring,tag_nod_shell,tag_comn_1d_2d)
527C
528 CALL my_alloc(tag_res,numelr)
529 CALL my_alloc(tag_fram_seatbelt,compt_belt_end)
530 CALL my_alloc(nnod_fram_seatbelt,compt_belt_end)
531 tag_nod(1:numnod) = 0
532 tag_res(1:numelr) = 0
533 seatbelt_id = 0
534 flag = 0
535 nb_2d_seatbelt = 0
536 tag_fram_seatbelt(1:compt_belt_end) = 0
537 nnod_fram_seatbelt(1:compt_belt_end) = 0
538C
539C----------------------------------------------------------------------------
540C--- Loop on seatblet elements in longitudinal direction
541C----------------------------------------------------------------------------
542C
543 IF (compt_belt_end == 0) THEN
544 CALL ancmsg(msgid=2099,
545 . msgtype=msgerror,
546 . anmode=aninfo_blind_1)
547 ENDIF
548C
549 CALL my_alloc(branch_tab,2*nb_elem_1d)
550C
551 DO i=1,compt_belt_end
552C
553C-- Check of nodes
554C
555 IF (tag_nod(fram_tab(belt_end_addr(i)))==0) THEN
556 seatbelt_id = seatbelt_id + 1
557 nnod = 0
558C
559 IF (belt_end_nfram(i) > 1) nb_2d_seatbelt = nb_2d_seatbelt + 1
560C
561 DO j=1,belt_end_nfram(i)
562C
563 nnod = nnod + 1
564 nod_start = fram_tab(belt_end_addr(i)+j-1)
565 ndir = 0
566C
567 DO k=knod2el1d(nod_start)+1,knod2el1d(nod_start+1)
568 IF (nod2el1d(k) > numelt+numelp) THEN
569 elem_cur = nod2el1d(k)-numelt-numelp
570 mid = ixr(5,elem_cur)
571 IF (mid > 0) THEN
572 mtyp = ipm(2,mid)
573 IF (mtyp == 114) THEN
574C in case of 1D/2D connection the loop must start on the right spring
575 IF (((belt_end_nfram(i)==1).and.(tag_spring_2d(elem_cur)==0)).OR.
576 . ((belt_end_nfram(i) >1).and.(tag_spring_2d(elem_cur)==1))) THEN
577C-- Loop on belt elements
578 nb_branch = 0
579 branch_cpt = 0
580 CALL new_seatbelt(ixr,itab,knod2el1d,nod2el1d,nod_start,
581 . elem_cur,tag_res,tag_nod,seatbelt_id,flag,
582 . nnod,ipm,nb_elem_1d,nb_branch,branch_tab,
583 . branch_cpt)
584
585C-- Loop on subranch (only if no sliprings and no retractors)
586 DO WHILE(nb_branch > 0)
587 nod_start = branch_tab(2*(branch_cpt-nb_branch)+1)
588 elem_cur = branch_tab(2*(branch_cpt-nb_branch)+2)
589 nb_branch = nb_branch -1
590 CALL new_seatbelt(ixr,itab,knod2el1d,nod2el1d,nod_start,
591 . elem_cur,tag_res,tag_nod,seatbelt_id,flag,
592 . nnod,ipm,nb_elem_1d,nb_branch,branch_tab,
593 . branch_cpt)
594 ENDDO
595C
596 ENDIF
597 ENDIF
598 ENDIF
599 ENDIF
600 ENDDO
601C
602 ENDDO
603C
604 tag_fram_seatbelt(i) = seatbelt_id
605 nnod_fram_seatbelt(i) = nnod
606C
607 ELSEIF(belt_end_nfram(i) > 1) THEN
608C-- check of frames (2D sliprings)
609 compt = 0
610 DO j=1,belt_end_nfram(i)
611 IF (tag_nod(fram_tab(belt_end_addr(i))) /= 0) compt = compt + 1
612 ENDDO
613 IF (compt /= belt_end_nfram(i)) THEN
614 CALL ancmsg(msgid=2073,
615 . msgtype=msgerror,
616 . anmode=aninfo_blind_1,
617 . i1=slipring(i)%ID)
618 ENDIF
619C
620 ENDIF
621C
622 ENDDO
623C
624 DEALLOCATE(branch_tab,tag_spring_2d)
625C
626C----------------------------------------------------------------------------
627C--- Filling of seatbelt structure
628C----------------------------------------------------------------------------
629C
630 n_seatbelt = seatbelt_id
631 IF (iddlevel == 0) ALLOCATE(seatbelt_tab(n_seatbelt))
632 CALL my_alloc(tag_mat_2d,nummat)
633 tag_mat_2d(1:nummat) = 0
634 IF (nb_2d_seatbelt > 0) THEN
635 CALL my_alloc(tag_shell,numelc)
636 CALL my_alloc(section_mat,nummat)
637 tag_shell(1:numelc) = 0
638 section_mat(1:nummat) = zero
639 ENDIF
640C
641 DO i=1,n_seatbelt
642 compt = 0
643 compt_2d = 0
644 seatbelt_tab(i)%NFRAM = 1
645 seatbelt_tab(i)%NNOD = 0
646 seatbelt_tab(i)%ELEM_SIZE = zero
647 DO j=1,compt_belt_end
648 IF (tag_fram_seatbelt(j)==i) THEN
649 seatbelt_tab(i)%NNOD = seatbelt_tab(i)%NNOD + nnod_fram_seatbelt(j)
650 seatbelt_tab(i)%NFRAM = belt_end_nfram(j)
651 seatbelt_tab(i)%SECTION = belt_end_section(j)
652 ENDIF
653 ENDDO
654 DO j=1,numelr
655 IF (tag_res(j) == i) THEN
656C-- count of 1d elements of the seatbelt
657 compt = compt + 1
658 mid = ixr(5,j)
659 IF (tag_mat_2d(mid)==0) tag_mat_2d(mid) = -mid
660C-- count and tag of 2d elements of the seatbelt
661 node = ixr(2,j)
662 n2 = ixr(3,j)
663 DO l=knod2elc(node)+1,knod2elc(node+1)
664 elem_cur = nod2elc(l)
665 mid_2d = ixc(1,elem_cur)
666 mtyp = ipm(2,mid_2d)
667 flag_shell = 0
668 DO jj=2,5
669 IF (ixc(jj,elem_cur)==n2) flag_shell = 1
670 ENDDO
671C FLAG_SHELL needed in case of 1D/2D connection
672 IF ((mtyp==119).AND.(flag_shell==1)) THEN
673 IF (tag_shell(elem_cur)==0) THEN
674 tag_shell(elem_cur) = i
675 compt_2d = compt_2d + 1
676 tag_mat_2d(mid) = mid_2d
677 IF (section_mat(mid_2d) == zero) THEN
678 section_mat(mid_2d) = seatbelt_tab(i)%SECTION
679 ELSEIF (abs(seatbelt_tab(i)%SECTION-section_mat(mid_2d)) > em05) THEN
680 CALL ancmsg(msgid=2075,
681 . msgtype=msgerror,
682 . anmode=aninfo_blind_1,
683 . i1=ipm(1,mid_2d))
684 ENDIF
685 ENDIF
686 ENDIF
687 ENDDO
688 ENDIF
689 ENDDO
690 seatbelt_tab(i)%NSPRING = compt
691 seatbelt_tab(i)%NSHELL = compt_2d
692 IF (iddlevel == 0) CALL my_alloc(seatbelt_tab(i)%SPRING,compt)
693 compt = 0
694 DO j=1,numelr
695 IF (tag_res(j) == i) THEN
696 compt = compt + 1
697 seatbelt_tab(i)%SPRING(compt) = j
698 ENDIF
699 ENDDO
700 ENDDO
701C
702 DEALLOCATE(belt_end_nfram,belt_end_section,belt_end_addr,fram_tab,tag_res,tag_fram_seatbelt,nnod_fram_seatbelt)
703C
704C----------------------------------------------------------------------------
705C--- Computation of elem_size from retractor
706C----------------------------------------------------------------------------
707C
708 DO i=1,nretractor
709 seatbelt_id = tag_nod(retractor(i)%NODE(1))
710 retractor(i)%INACTI_NNOD_MAX = seatbelt_tab(seatbelt_id)%NNOD
711 IF (iddlevel == 0) CALL my_alloc(retractor(i)%INACTI_NODE,seatbelt_tab(seatbelt_id)%NNOD)
712 seatbelt_tab(seatbelt_id)%ELEM_SIZE = max(seatbelt_tab(seatbelt_id)%ELEM_SIZE,retractor(i)%ELEMENT_SIZE)
713 ENDDO
714C
715C----------------------------------------------------------------------------
716C--- Computation of default lmin and default critical damping
717C----------------------------------------------------------------------------
718C
719 CALL my_alloc(cpt_mat,nummat)
720 CALL my_alloc(av_len_mat,nummat)
721 CALL my_alloc(av_area_mat,nummat)
722 CALL my_alloc(elemsize_mat,nummat)
723 compt = 0
724 cpt_mat(1:nummat) = 0
725 av_len_mat(1:nummat) = zero
726 av_area_mat(1:nummat) = zero
727 elemsize_mat(1:nummat) = zero
728C
729 DO i=1,n_seatbelt
730 DO j=1,seatbelt_tab(i)%NSPRING
731 elem_cur = seatbelt_tab(i)%SPRING(j)
732 ipid = ixr(1,elem_cur)
733 i1 = ixr(2,elem_cur)
734 i2 = ixr(3,elem_cur)
735 mid= ixr(5,elem_cur)
736 elemsize_mat(mid) = max(elemsize_mat(mid),seatbelt_tab(i)%ELEM_SIZE)
737 dist2 = (x(1,i1)-x(1,i2))**2+(x(2,i1)-x(2,i2))**2+(x(3,i1)-x(3,i2))**2
738 IF (dist2 > zero) THEN
739 av_len_mat(mid) = av_len_mat(mid) + sqrt(dist2)
740 av_area_mat(mid) = av_area_mat(mid) + geo(1,ipid)
741 cpt_mat(mid) = cpt_mat(mid) + 1
742 ENDIF
743 ENDDO
744 ENDDO
745C
746 tag_print = 0
747 DO mid=1,nummat
748 iadbuf = ipm(7,mid)
749 IF (cpt_mat(mid) > 0) THEN
750 lmin = bufmat(iadbuf+119-1)
751 IF (lmin == zero) THEN
752C-- default lmin = 1% of average length
753 bufmat(iadbuf+119-1) = em02 * (av_len_mat(mid) / cpt_mat(mid))
754 IF (tag_print == 0) WRITE(iout,1000)
755 tag_print = 1
756 WRITE(iout,'(5X,I10,8X,G16.9)') ipm(1,abs(tag_mat_2d(mid))),bufmat(iadbuf+119-1)
757 ENDIF
758C-- storage of retrator eleme size
759 bufmat(iadbuf+126-1) = elemsize_mat(mid)
760 ENDIF
761 ENDDO
762C
763 tag_print = 0
764 DO mid=1,nummat
765 iadbuf = ipm(7,mid)
766 IF (cpt_mat(mid) > 0) THEN
767 xc = bufmat(iadbuf+70)
768 xk = bufmat(iadbuf+64)
769 iecrou = int(bufmat(iadbuf+76))
770 IF (xc == zero) THEN
771C-- default damping is 30% of critical damping
772 rho = pm(1,mid)
773 area = av_area_mat(mid) / cpt_mat(mid)
774 xc = zep3 * sqrt(rho*area*xk) * (av_len_mat(mid) / cpt_mat(mid))
775 bufmat(iadbuf+70) = xc
776 IF (tag_print == 0) WRITE(iout,1100)
777 tag_print = 1
778 WRITE(iout,'(5X,I10,8X,G16.9)') ipm(1,abs(tag_mat_2d(mid))),bufmat(iadbuf+70)
779 ENDIF
780 bufmat(iadbuf+71) = 0.1*xc
781 bufmat(iadbuf+72) = 0.1*xc
782C-- for 2D_seatbelt mass is applied on shell - rho set to 0 - rho is stored int UPARAM(128) for elementary time step
783 IF ((tag_mat_2d(mid) > 0).AND.(iddlevel==0)) THEN
784 bufmat(iadbuf+127-1) = one
785 bufmat(iadbuf+128-1) = 0.9*pm(1,mid)
786 pm(1,mid) = em20
787 bufmat(iadbuf+71) = 0.3*xc
788 bufmat(iadbuf+72) = 0.3*xc
789 IF (iecrou==10) THEN
790C-- specific non linear formulation for 2d seatblets
791 iecrou = 12
792 bufmat(iadbuf+76) = iecrou + em01
793 ENDIF
794 ENDIF
795 ENDIF
796 ENDDO
797C
798 DEALLOCATE(cpt_mat,av_len_mat,av_area_mat,elemsize_mat,tag_mat_2d)
799C
800C----------------------------------------------------------------------------
801C--- Update of mat119 variables after section computation
802C----------------------------------------------------------------------------
803C
804 IF ((nb_2d_seatbelt > 0).AND.(iddlevel==0)) THEN
805 tag_print = 0
806 DO mid=1,nummat
807 mtyp = ipm(2,mid)
808 iadbuf = ipm(7,mid)
809 IF (mtyp == 119) THEN
810 func1 = ipm(227,mid)
811 func2 = ipm(228,mid)
812C-- RHO = MPUL/S)
813 rho0=pm(1,mid)/section_mat(mid)
814C-- E11 = K/S
815 e11 = bufmat(iadbuf)/section_mat(mid)
816 e22 = bufmat(iadbuf+1)
817 fscalet = bufmat(iadbuf+12)
818 IF (e22 == em20) e22 = fscalet*e11
819 n12 = bufmat(iadbuf+2)
820 IF (func1 == 0) THEN
821 n21 = n12*e22/e11
822 kmax = max(e11,e22)
823 ELSE
824 n21 = n12*fscalet
825 kmax = max(one,fscalet)*bufmat(iadbuf+21)/section_mat(mid)
826 ENDIF
827 nu = sqrt(n12*n21)
828 g12 = bufmat(iadbuf+5)
829 IF (g12 == em20) g12 = e11/(two*(one + n12))
830 det = one / (one - n12*n21)
831 a11 = e11 * det
832 a22 = e22 * det
833 a12 = a11 * n21
834 c1 = kmax * det
835C-- coating
836 a1c = bufmat(iadbuf+13)
837 a2c = bufmat(iadbuf+14)
838 c1 = max(a11,a22,a1c)
839 ssp = sqrt(c1/rho0)
840 IF(det<=zero) THEN
841 CALL ancmsg(msgid=307,
842 . msgtype=msgerror,
843 . anmode=aninfo,
844 . i1=ipm(1,mid),
845 . c1='SEATBELT MATERIAL')
846 ENDIF
847 fscale1 = bufmat(iadbuf+10)/section_mat(mid)
848 fscale2 = bufmat(iadbuf+11)/section_mat(mid)
849C-- update of UPARAM
850 bufmat(iadbuf) = e11
851 bufmat(iadbuf+1) = e22
852 bufmat(iadbuf+3) = n21
853 bufmat(iadbuf+4) = nu
854 bufmat(iadbuf+5) = g12
855 bufmat(iadbuf+6) = a11
856 bufmat(iadbuf+7) = a22
857 bufmat(iadbuf+8) = a12
858 bufmat(iadbuf+10) = fscale1
859 bufmat(iadbuf+11) = fscale2
860 bufmat(iadbuf+16) = ssp
861C-- update of PM
862 pm(1,mid)=rho0
863 pm(89,mid)=rho0
864 pm(20,mid) = kmax/(one - nu**2)
865 pm(21,mid) = nu
866 pm(22,mid) = half*kmax/(one + nu)
867 pm(24,mid) = kmax/(one - nu**2)
868 pm(32,mid) = c1
869C-- Need to be store in PM for hourglass forces computation
870 pm(33,mid) = e11
871 pm(34,mid) = e22
872 pm(35,mid) = n12
873 pm(36,mid) = n21
874 pm(37,mid) = g12
875 pm(38,mid) = g12
876 pm(39,mid) = g12
877
878C-- printout
879 IF (tag_print == 0) WRITE(iout,1200)
880 tag_print = 1
881 WRITE(iout,'(5X,I10,8X,G16.9,G16.9,G16.9,G16.9)') ipm(1,mid),section_mat(mid),
882 . e11,e22,g12
883 ENDIF
884 ENDDO
885 ENDIF
886C
887 IF (nb_2d_seatbelt > 0) DEALLOCATE(section_mat)
888C
889 IF (nspmd > 1) THEN
890C
891C----------------------------------------------------------------------------
892C--- DOMDEC - all elements of 1 seatbelt on the same proc
893C----------------------------------------------------------------------------
894C
895 offc = numels + numelq
896 offr = numels + numelq + numelc + numelp + numelt
897C
898 DO i=1,n_seatbelt
899C
900 IF (seatbelt_tab(i)%NFRAM == 1) THEN
901C-- 1D SEATBELT
902 CALL my_alloc(cc_elem,seatbelt_tab(i)%NSPRING)
903 cc_elem(1:seatbelt_tab(i)%NSPRING) = 0
904 compt = 0
905 DO j=1,seatbelt_tab(i)%NSPRING
906 compt = compt + 1
907 cc_elem(compt) = offr + seatbelt_tab(i)%SPRING(j)
908 ENDDO
909 nb_elem = compt
910C
911 ELSEIF (seatbelt_tab(i)%NFRAM > 1) THEN
912C-- 2D SEATBELT
913 nb_elem = seatbelt_tab(i)%NSPRING + seatbelt_tab(i)%NSHELL
914 CALL my_alloc(cc_elem,nb_elem)
915 cc_elem(1:nb_elem) = 0
916 compt = 0
917 DO j=1,seatbelt_tab(i)%NSPRING
918 compt = compt + 1
919 cc_elem(compt) = offr + seatbelt_tab(i)%SPRING(j)
920 ENDDO
921 DO j=1,numelc
922 IF (tag_shell(j) == i) THEN
923 compt = compt + 1
924 cc_elem(compt) = offc + j
925 ENDIF
926 ENDDO
927C
928 ENDIF
929C
930 CALL c_prevent_decomposition(nb_elem,cc_elem)
931 DEALLOCATE(cc_elem)
932C
933 ENDDO
934C
935 ENDIF
936C
937 ENDIF
938C
939 IF (nb_2d_seatbelt > 0) DEALLOCATE(tag_shell)
940C
941C if setbelt elts in model array ar deallocated before
942 IF ((nb_elem_1d==0).and.(nb_elem_2d == 0)) THEN
943 DEALLOCATE(tag_nod_shell,tag_nod_spring,tag_nod_spri2d)
944 DEALLOCATE(tag_prop_2d,tag_spring_2d)
945 ENDIF
946C
947 RETURN
948C
9491000 FORMAT(/
950 . ' SEATBELTS DEFAULT LMIN COMPUTATION '/
951 . ' ---------------------------------- '/
952 . ' MAT ID DEFAULT LMIN '/)
953C
9541100 FORMAT(/
955 . ' SEATBELTS DEFAULT DAMPING COMPUTATION '/
956 . ' ---------------------------------- '/
957 . ' MAT ID DEFAULT DAMPING '/)
958C
9591200 FORMAT(/
960 . ' 2D SEATBELTS SECTION COMPUTATION '/
961 . ' ---------------------------------- '/
962 . ' MAT ID SEATBELT SECTION E11 E22 G12'/)
963C
964 END SUBROUTINE create_seatbelt
965
c_prevent_decomposition
void c_prevent_decomposition(int *clusterSize, int *elements)
Definition c_domain_decomposition.cpp:63
my_real
#define my_real
Definition cppsort.cpp:32
create_seatbelt
subroutine create_seatbelt(ixr, itab, knod2el1d, nod2el1d, ipm, x, sensors, bufmat, pm, geo, iddlevel, knod2elc, nod2elc, ixc, igeo, iskn, tf, npc)
Definition create_seatbelt.F:38
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
message_mod
Definition message_mod.F:1257
seatbelt_mod
Definition seatbelt_mod.F:55
seatbelt_mod::n_comn_1d2d
integer n_comn_1d2d
Definition seatbelt_mod.F:172
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::comn_1d2d
integer, dimension(:), allocatable comn_1d2d
Definition seatbelt_mod.F:173
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