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