OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
update_slipring.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!|| update_slipring ../engine/source/tools/seatbelts/update_slipring.F
25!||--- called by ------------------------------------------------------
26!|| resol ../engine/source/engine/resol.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!|| shell_loc_cor ../engine/source/tools/seatbelts/shell_loc_cor.F
31!|| shell_reactivation ../engine/source/tools/seatbelts/shell_reactivation.F
32!||--- uses -----------------------------------------------------
33!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
34!|| element_mod ../common_source/modules/elements/element_mod.F90
35!|| message_mod ../engine/share/message_module/message_mod.F
36!|| seatbelt_mod ../common_source/modules/seatbelt_mod.F
37!||====================================================================
38 SUBROUTINE update_slipring(IXR,IXC,IPARG,ELBUF_TAB,FLAG_SLIPRING_UPDATE,
39 . FLAG_RETRACTOR_UPDATE,X,NPBY)
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE elbufdef_mod
44 USE seatbelt_mod
45 USE message_mod
46 use element_mod , only : nixc,nixr
47C-----------------------------------------------
48C I m p l i c i t T y p e s
49C-----------------------------------------------
50#include "implicit_f.inc"
51C-----------------------------------------------
52C C o m m o n B l o c k s
53C-----------------------------------------------
54#include "com01_c.inc"
55#include "com04_c.inc"
56#include "param_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER ,INTENT(IN) :: IXC(NIXC,NUMELC),IPARG(NPARG,NGROUP),NPBY(NNPBY,NRBODY)
61 INTEGER ,INTENT(INOUT) :: IXR(NIXR,NUMELR),FLAG_SLIPRING_UPDATE,FLAG_RETRACTOR_UPDATE
62 my_real ,INTENT(IN) :: x(3,numnod)
63 TYPE(elbuf_struct_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
64C-----------------------------------------------
65C L o c a l V a r i a b l e s
66C-----------------------------------------------
67 INTEGER I,J,K,ITYP,NG,JFT,JLT,NEL,
68 . nft,n1,n2,n3,n4,mtn,nn1,nn2,nn3,ii(6),slip,
69 . compt,fra,nfound,found_slip(2),found_fram(2),fram1,fram2,
70 . node_fram1,node_fram2,irep,flag_reactiv,flag_r1,flag_r2,nuvar,
71 . iseatbelt,fra1,fra2,l_dira,nlay,ismstr,strand,node_cores_dir2(4),
72 . nptr,npts,nptt,ir,is,it,s_slipring,l_smstr,orient,pos_b,ret,comptr,
73 . flag_slipring_l
74C
75 INTEGER, DIMENSION(:), ALLOCATABLE :: TAG_NOD,CORES_SLIP,CORES_FRAM,CORES_RET
76C
77 my_real
78 . xl2,yl2,xl3,yl3,xl4,yl4,l0fram1,l0fram2,dist,distb,offset,n_dir2(2),
79 . flow_direction,gap
80C
81 TYPE(g_bufel_),POINTER :: GBUF
82 TYPE(buf_lay_) ,POINTER :: BUFLY
83C---------------------------------------------------------
84C
85C----------------------------------------------------------
86C- UPDATE OF SLIPRING
87C----------------------------------------------------------
88C----------------------------------------------------------
89C
90 s_slipring = -huge(s_slipring)
91 strand = 0
92 flow_direction = -huge(flow_direction)
93 flag_slipring_l = flag_slipring_update
94 IF (((n_seatbelt_2d > 0).AND.(ncycle==0)).OR.(flag_slipring_update /= 0).OR.
95 . (flag_retractor_update /= 0)) THEN
96 s_slipring = 0
97 DO slip=1,nslipring
98 s_slipring = s_slipring + slipring(slip)%NFRAM
99C Check of rbody status
100 IF (slipring(slip)%RBODY > 0) THEN
101 IF (npby(7,slipring(slip)%RBODY) == 0) THEN
102 ! ERROR to be printed & exit
103 CALL ancmsg(msgid=300,i1=slipring(slip)%RBODY,i2=npby(6,slipring(slip)%RBODY),anmode=aninfo)
104 CALL arret(2)
105 ENDIF
106 ENDIF
107 ENDDO
108 ALLOCATE(tag_nod(numnod))
109 ALLOCATE(cores_slip(s_slipring))
110 ALLOCATE(cores_fram(s_slipring))
111 ALLOCATE(cores_ret(nretractor))
112 ENDIF
113C
114C----------------------------------------------------------
115C----------------------------------------------------------
116C-- Loop on springs for slipring update
117C----------------------------------------------------------
118C----------------------------------------------------------
119C
120 IF ((flag_slipring_update /= 0).OR.(flag_retractor_update /= 0)) THEN
121C
122 tag_nod(1:numnod) = 0
123 cores_slip(1:s_slipring) = 0
124 cores_fram(1:s_slipring) = 0
125C-----> Tag of nodes of updated sliprings -------
126 compt = 0
127 DO slip=1,nslipring
128 DO fra = 1,slipring(slip)%NFRAM
129 IF (slipring(slip)%FRAM(fra)%UPDATE /= 0) THEN
130 compt = compt + 1
131 tag_nod(slipring(slip)%FRAM(fra)%NODE(1)) = compt
132 tag_nod(slipring(slip)%FRAM(fra)%NODE(2)) = compt
133 tag_nod(slipring(slip)%FRAM(fra)%NODE(3)) = compt
134 tag_nod(slipring(slip)%FRAM(fra)%NODE_NEXT(1)) = compt
135 tag_nod(slipring(slip)%FRAM(fra)%NODE_NEXT(2)) = compt
136 tag_nod(slipring(slip)%FRAM(fra)%NODE_NEXT(3)) = compt
137 cores_slip(compt) = slip
138 cores_fram(compt) = fra
139 ENDIF
140 ENDDO
141 ENDDO
142C-----> Tag of nodes of updated retractors -------
143 comptr = 0
144 DO ret=1,nretractor
145 IF (retractor(ret)%UPDATE /= 0) THEN
146 comptr = comptr + 1
147 tag_nod(retractor(ret)%NODE(1)) = -comptr
148 tag_nod(retractor(ret)%NODE(2)) = -comptr
149 tag_nod(retractor(ret)%NODE_NEXT(1)) = -comptr
150 tag_nod(retractor(ret)%NODE_NEXT(2)) = -comptr
151 cores_ret(comptr) = ret
152 ENDIF
153 ENDDO
154C
155 DO ng=1,ngroup
156C
157 ityp = iparg(5,ng)
158 mtn = iparg(1,ng)
159 nel = iparg(2,ng)
160 nft = iparg(3,ng)
161 jft = 1
162 jlt = min(nvsiz,nel)
163 gbuf => elbuf_tab(ng)%GBUF
164C
165 DO i=1,6
166 ii(i) = (i-1)*nel + 1
167 ENDDO
168C
169 nuvar = 6
170C
171 IF ((ityp==6).AND.(mtn==114)) THEN
172C--------> Loop over seatbelt spring elements-------
173 DO i=jft,jlt
174C
175 j = i + nft
176 n1 = ixr(2,j)
177 n2 = ixr(3,j)
178 slip = 0
179 ret = 0
180C
181 IF (tag_nod(n1) > 0) THEN
182 slip = cores_slip(tag_nod(n1))
183 fra = cores_fram(tag_nod(n1))
184 ELSEIF (tag_nod(n2) > 0) THEN
185 slip = cores_slip(tag_nod(n2))
186 fra = cores_fram(tag_nod(n2))
187 ELSEIF (tag_nod(n1) < 0) THEN
188 ret = cores_ret(abs(tag_nod(n1)))
189 ELSEIF (tag_nod(n2) < 0) THEN
190 ret = cores_ret(abs(tag_nod(n2)))
191 ENDIF
192C
193 IF (slip > 0) THEN
194 nn1 = slipring(slip)%FRAM(fra)%NODE_NEXT(1)
195 nn2 = slipring(slip)%FRAM(fra)%NODE_NEXT(2)
196 nn3 = slipring(slip)%FRAM(fra)%NODE_NEXT(3)
197 IF (((n1==nn1).AND.(n2==nn2)).OR.((n2==nn1).AND.(n1==nn2))) THEN
198 gbuf%SLIPRING_ID(i) = slip
199 gbuf%SLIPRING_FRAM_ID(i) = fra
200 gbuf%SLIPRING_STRAND(i) = 1
201 gbuf%UPDATE(i) = slipring(slip)%FRAM(fra)%UPDATE
202 IF (gbuf%UPDATE(i) > 0) gbuf%DFS(i) = slipring(slip)%FRAM(fra)%DFS
203 IF (n2 == nn2) THEN
204 slipring(slip)%FRAM(fra)%STRAND_DIRECTION(1) = 1
205 ELSE
206 slipring(slip)%FRAM(fra)%STRAND_DIRECTION(1) = -1
207 ENDIF
208 slipring(slip)%FRAM(fra)%RESIDUAL_LENGTH(1) = gbuf%LENGTH(ii(1)+i-1)
209 slipring(slip)%FRAM(fra)%INTVAR_STR1(1) = gbuf%FOR(ii(1)+i-1)
210 slipring(slip)%FRAM(fra)%INTVAR_STR1(2) = gbuf%DEP_IN_TENS(ii(1)+i-1)
211 slipring(slip)%FRAM(fra)%INTVAR_STR1(3) = gbuf%YIELD(ii(1)+i-1)
212 slipring(slip)%FRAM(fra)%INTVAR_STR1(4) = gbuf%VAR(nuvar*(i-1)+1)
213 slipring(slip)%FRAM(fra)%INTVAR_STR1(5) = gbuf%FOREP(ii(1)+i-1)
214 slipring(slip)%FRAM(fra)%INTVAR_STR1(6) = gbuf%POSX(i)
215 slipring(slip)%FRAM(fra)%INTVAR_STR1(7) = gbuf%INTVAR(ii(2)+i-1)
216C -> Update of third node -------
217 ixr(4,j) = slipring(slip)%FRAM(fra)%NODE_NEXT(3)
218 ELSEIF (((n1==nn2).AND.(n2==nn3)).OR.((n2==nn2).AND.(n1==nn3))) THEN
219 gbuf%SLIPRING_ID(i) = slip
220 gbuf%SLIPRING_FRAM_ID(i) = fra
221 gbuf%SLIPRING_STRAND(i) = 2
222 gbuf%UPDATE(i) = slipring(slip)%FRAM(fra)%UPDATE
223 IF (gbuf%UPDATE(i) < 0) gbuf%DFS(i) = slipring(slip)%FRAM(fra)%DFS
224 IF (n1 == nn2) THEN
225 slipring(slip)%FRAM(fra)%STRAND_DIRECTION(2) = 1
226 ELSE
227 slipring(slip)%FRAM(fra)%STRAND_DIRECTION(2) = -1
228 ENDIF
229 slipring(slip)%FRAM(fra)%RESIDUAL_LENGTH(2) = gbuf%LENGTH(ii(1)+i-1)
230 slipring(slip)%FRAM(fra)%INTVAR_STR2(1) = gbuf%FOR(ii(1)+i-1)
231 slipring(slip)%FRAM(fra)%INTVAR_STR2(2) = gbuf%DEP_IN_TENS(ii(1)+i-1)
232 slipring(slip)%FRAM(fra)%INTVAR_STR2(3) = gbuf%YIELD(ii(1)+i-1)
233 slipring(slip)%FRAM(fra)%INTVAR_STR2(4) = gbuf%VAR(nuvar*(i-1)+1)
234 slipring(slip)%FRAM(fra)%INTVAR_STR2(5) = gbuf%FOREP(ii(1)+i-1)
235 slipring(slip)%FRAM(fra)%INTVAR_STR2(6) = gbuf%POSX(i)
236 slipring(slip)%FRAM(fra)%INTVAR_STR2(7) = gbuf%INTVAR(ii(2)+i-1)
237C -> Update of third node -------
238 ixr(4,j) = slipring(slip)%FRAM(fra)%NODE_NEXT(1)
239 ELSEIF ((gbuf%SLIPRING_ID(i)==slip).AND.(gbuf%SLIPRING_FRAM_ID(i)==fra)) THEN
240 gbuf%SLIPRING_ID(i) = 0
241 gbuf%SLIPRING_FRAM_ID(i) = 0
242 gbuf%SLIPRING_STRAND(i) = 0
243 slipring(slip)%FRAM(fra)%PREV_REF_LENGTH = gbuf%LENGTH(ii(1)+i-1)
244 ENDIF
245 ENDIF
246C
247C -> Storage of current fram ref length in slipring buffer -------
248 slip = gbuf%SLIPRING_ID(i)
249 fra = gbuf%SLIPRING_FRAM_ID(i)
250 k = gbuf%SLIPRING_STRAND(i)
251 IF ((slip > 0).AND.(fra > 0).AND.(k > 0)) THEN
252 IF (slipring(slip)%FRAM(fra)%UPDATE == 0) THEN
253 slipring(slip)%FRAM(fra)%CURRENT_LENGTH(k) = gbuf%LENGTH(ii(1)+i-1)
254 ENDIF
255 ENDIF
256C
257 IF (ret > 0) THEN
258 nn1 = retractor(ret)%NODE_NEXT(1)
259 nn2 = retractor(ret)%NODE_NEXT(2)
260 IF (((n1==nn1).AND.(n2==nn2)).OR.((n2==nn1).AND.(n1==nn2))) THEN
261 gbuf%RETRACTOR_ID(i) = ret
262 gbuf%SLIPRING_STRAND(i) = -1
263 gbuf%UPDATE(i) = -1
264 IF (n1==nn1) THEN
265 retractor(ret)%STRAND_DIRECTION = 1
266 ELSE
267 retractor(ret)%STRAND_DIRECTION = -1
268 ENDIF
269 ELSEIF (gbuf%SLIPRING_STRAND(i) < 0) THEN
270 gbuf%SLIPRING_STRAND(i) = 0
271 IF (retractor(ret)%UPDATE > 0) THEN
272C Small gap to prevent early release of element
273 gap = 0.01*retractor(ret)%ELEMENT_SIZE
274 gbuf%RINGSLIP(i) = gbuf%RINGSLIP(i) -gap
275 ELSE
276C Element deactivated - X0 updated in r23l114def3 for consistency
277 gbuf%UPDATE(i) = -2
278 gbuf%RINGSLIP(i) = zero
279 ENDIF
280 ENDIF
281 ENDIF
282C
283 ENDDO
284C
285 ENDIF
286C
287 ENDDO
288C
289 ENDIF
290
291C
292C----------------------------------------------------------
293C
294 IF (flag_slipring_update /= 0) THEN
295 DO slip=1,nslipring
296 DO fra = 1,slipring(slip)%NFRAM
297 IF (slipring(slip)%FRAM(fra)%UPDATE /= 0) THEN
298 slipring(slip)%FRAM(fra)%UPDATE = 0
299 slipring(slip)%FRAM(fra)%NODE2_PREV = slipring(slip)%FRAM(fra)%NODE(2)
300 slipring(slip)%FRAM(fra)%NODE(1) = slipring(slip)%FRAM(fra)%NODE_NEXT(1)
301 slipring(slip)%FRAM(fra)%NODE(2) = slipring(slip)%FRAM(fra)%NODE_NEXT(2)
302 slipring(slip)%FRAM(fra)%NODE(3) = slipring(slip)%FRAM(fra)%NODE_NEXT(3)
303 ENDIF
304 ENDDO
305 ENDDO
306 flag_slipring_update = 0
307 ENDIF
308C
309 IF (flag_retractor_update /= 0) THEN
310 DO ret=1,nretractor
311 IF (retractor(ret)%UPDATE /= 0) THEN
312 retractor(ret)%UPDATE = 0
313 retractor(ret)%NODE(1) = retractor(ret)%NODE_NEXT(1)
314 retractor(ret)%NODE(2) = retractor(ret)%NODE_NEXT(2)
315 ENDIF
316 ENDDO
317 flag_retractor_update = 0
318 ENDIF
319C
320C----------------------------------------------------------
321C----------------------------------------------------------
322C-- Loop on shells for activation / deactivation
323C----------------------------------------------------------
324C----------------------------------------------------------
325C
326 IF ((n_seatbelt_2d > 0).AND.((ncycle==0).OR.(flag_slipring_l /= 0))) THEN
327C
328 tag_nod(1:numnod) = 0
329 cores_slip(1:s_slipring) = 0
330 cores_fram(1:s_slipring) = 0
331 compt = 0
332 DO slip=1,nslipring
333 DO fra = 1,slipring(slip)%NFRAM
334 compt = compt + 1
335 tag_nod(slipring(slip)%FRAM(fra)%NODE(2)) = compt
336 cores_slip(compt) = slip
337 cores_fram(compt) = fra
338 tag_nod(slipring(slip)%FRAM(fra)%NODE(1)) = -compt
339 tag_nod(slipring(slip)%FRAM(fra)%NODE(3)) = -compt
340 ENDDO
341 ENDDO
342C
343 DO ng=1,ngroup
344C
345 ityp = iparg(5,ng)
346 mtn = iparg(1,ng)
347 nel = iparg(2,ng)
348 nft = iparg(3,ng)
349 iseatbelt = iparg(91,ng)
350 irep = iparg(35,ng)
351 ismstr = iparg(9,ng)
352C
353 jft = 1
354 jlt = min(nvsiz,nel)
355 gbuf => elbuf_tab(ng)%GBUF
356 DO i=1,6
357 ii(i) = (i-1)*nel + 1
358 ENDDO
359C
360 IF ((ityp == 3).AND.(iseatbelt==1)) THEN
361C
362 bufly => elbuf_tab(ng)%BUFLY(1)
363 nlay = elbuf_tab(ng)%NLAY
364 nptr = elbuf_tab(ng)%NPTR
365 npts = elbuf_tab(ng)%NPTS
366 nptt = elbuf_tab(ng)%NPTT
367 l_dira = bufly%LY_DIRA
368 l_smstr = bufly%L_SMSTR
369C
370 DO i=jft,jlt
371C
372 j = i + nft
373C
374 flag_reactiv = 0
375C
376 nfound = 0
377 found_slip(1:2) = 0
378 found_fram(1:2) = 0
379 flag_r1 = 0
380 flag_r2 = 0
381C
382 IF (gbuf%ADD_NODE(i) == ixc(3,j)) THEN
383C-- dir1 is N1 N2
384 orient = 1
385 node_cores_dir2(1) = 4
386 node_cores_dir2(2) = 3
387 node_cores_dir2(3) = 2
388 node_cores_dir2(4) = 1
389 ELSE
390C-- dir1 is N1 N4
391 orient = 2
392 node_cores_dir2(1) = 2
393 node_cores_dir2(2) = 1
394 node_cores_dir2(3) = 4
395 node_cores_dir2(4) = 3
396 ENDIF
397C
398C-- Get previous connection between element / slipring
399 slip = gbuf%SLIPRING_ID(i)
400 fram1 = max(0,gbuf%SLIPRING_FRAM_ID(ii(1)+i-1))
401 fram2 = max(0,gbuf%SLIPRING_FRAM_ID(ii(2)+i-1))
402C
403 DO k=1,4
404C-- Tag > 0 - node 2 of slipring
405 IF (tag_nod(ixc(k+1,j)) > 0) THEN
406 nfound = nfound + 1
407 found_slip(nfound) = cores_slip(tag_nod(ixc(k+1,j)))
408 found_fram(nfound) = cores_fram(tag_nod(ixc(k+1,j)))
409 flag_r1 = 1
410 ENDIF
411 ENDDO
412C
413 IF (flag_r1 == 0) THEN
414 DO k=2,5
415C-- Tag < 0 - node 1 or 3 of slipring
416 IF (tag_nod(ixc(k,j)) < 0) flag_r2 = k - 1
417 ENDDO
418 ENDIF
419C
420C-----------------------------------------------------------------------------------------
421C-- 2nd rank of element behind/ahead slipring - scaling factor on stress
422C-----------------------------------------------------------------------------------------
423 gbuf%INTVAR(ii(1)+i-1) = one
424 IF ((flag_r2 > 0).AND.(gbuf%UPDATE(i) == 0)) THEN
425 IF (slip == 0) THEN
426C-- element will be slowly deactivated - stress factor -> 0 in mulawc
427 gbuf%UPDATE(i) = flag_r2
428 pos_b = node_cores_dir2(flag_r2)
429 n1 = ixc(1+flag_r2,j)
430 n2 = gbuf%ADD_NODE(nel*flag_r2+i)
431 n3 = ixc(1+pos_b,j)
432 n4 = gbuf%ADD_NODE(nel*pos_b+i)
433 dist = sqrt((x(1,n1)-x(1,n2))**2+(x(2,n1)-x(2,n2))**2+(x(3,n1)-x(3,n2))**2)
434 distb = sqrt(max(em20,(x(1,n3)-x(1,n4))**2+(x(2,n3)-x(2,n4))**2+(x(3,n3)-x(3,n4))**2))
435 dist = min(dist,distb)
436 gbuf%INTVAR(ii(2)+i-1) = half*dist
437 ELSE
438C-- element will be slowly activated - stress factor -> 1 in mulawc
439 gbuf%UPDATE(i) = -flag_r2
440 n1 = ixc(2,j)
441 n2 = gbuf%ADD_NODE(i)
442 dist = (x(1,n1)-x(1,n2))**2+(x(2,n1)-x(2,n2))**2+(x(3,n1)-x(3,n2))**2
443 gbuf%INTVAR(ii(2)+i-1) = third*sqrt(dist)
444 ENDIF
445 ELSEIF (flag_r2 == 0) THEN
446 gbuf%UPDATE(i) = 0
447 ENDIF
448C
449C-----------------------------------------------------------------------------------------
450C-- 1st rank of element connected to slipring - full reactivation / deactivation
451C-----------------------------------------------------------------------------------------
452 DO k=1,nfound
453 IF ((fram1 == 0).AND.(found_fram(k) /= fram2)) THEN
454 slip = found_slip(k)
455 fram1 = found_fram(k)
456 gbuf%SLIPRING_FRAM_ID(ii(1)+i-1) = fram1
457 ELSEIF ((fram2 == 0).AND.(found_fram(k) /= fram1)) THEN
458 fram2 = found_fram(k)
459 gbuf%SLIPRING_FRAM_ID(ii(2)+i-1) = fram2
460 ENDIF
461 ENDDO
462C
463 IF ((fram1 > 0).AND.(fram1 /= found_fram(1)).AND.(fram1 /= found_fram(2))) THEN
464C disconnection with slipring fram1 - ringslip must be stored in bufel
465 gbuf%SLIPRING_FRAM_ID(ii(1)+i-1) = -gbuf%SLIPRING_FRAM_ID(ii(1)+i-1)
466 gbuf%POSX(ii(1)+i-1) = slipring(slip)%FRAM(fram1)%RINGSLIP
467 gbuf%INTVAR(ii(3)+i-1) = abs(slipring(slip)%FRAM(fram1)%PREV_REF_LENGTH)
468 DO k=1,4
469 IF (ixc(k+1,j) == slipring(slip)%FRAM(fram1)%NODE(1)) THEN
470 gbuf%INTVAR(ii(5)+i-1) = k
471 strand = 1
472 flow_direction = one
473 ELSEIF (ixc(k+1,j) == slipring(slip)%FRAM(fram1)%NODE(3)) THEN
474 gbuf%INTVAR(ii(5)+i-1) = k
475 strand = 2
476 flow_direction = -one
477 ENDIF
478 ENDDO
479 ENDIF
480C
481 IF ((fram2 > 0).AND.(fram2 /= found_fram(1)).AND.(fram2 /= found_fram(2))) THEN
482C disconnection with slipring fram2 - ringslip must be stored in bufel
483 gbuf%SLIPRING_FRAM_ID(ii(2)+i-1) = -gbuf%SLIPRING_FRAM_ID(ii(2)+i-1)
484 gbuf%POSX(ii(2)+i-1) = slipring(slip)%FRAM(fram2)%RINGSLIP
485 gbuf%INTVAR(ii(4)+i-1) = abs(slipring(slip)%FRAM(fram2)%PREV_REF_LENGTH)
486 DO k=1,4
487 IF (ixc(k+1,j) == slipring(slip)%FRAM(fram2)%NODE(1)) THEN
488 gbuf%INTVAR(ii(6)+i-1) = k
489 strand = 1
490 flow_direction = one
491 ELSEIF (ixc(k+1,j) == slipring(slip)%FRAM(fram2)%NODE(3)) THEN
492 gbuf%INTVAR(ii(6)+i-1) = k
493 strand = 2
494 flow_direction = -one
495 ENDIF
496 ENDDO
497 ENDIF
498C
499 IF ((gbuf%SLIPRING_ID(i)==0).AND.(nfound > 0)) THEN
500C-- shell connected to slipring - deactivated
501 gbuf%OFF(i) = -one
502 gbuf%SLIPRING_ID(i) = slip
503 ELSEIF ((gbuf%SLIPRING_ID(i) > 0).AND.(nfound == 0)) THEN
504C-- shell fully released by slipring - reactivated - tag -1
505 gbuf%OFF(i) = one
506 gbuf%SLIPRING_ID(i) = 0
507 flag_reactiv = 1
508 ENDIF
509C
510 IF (flag_reactiv == 1) THEN
511 fra1 = abs(gbuf%SLIPRING_FRAM_ID(ii(1)+i-1))
512 fra2 = abs(gbuf%SLIPRING_FRAM_ID(ii(2)+i-1))
513 l0fram1 = gbuf%INTVAR(ii(3)+i-1)
514 l0fram2 = gbuf%INTVAR(ii(4)+i-1)
515 node_fram1 = nint(gbuf%INTVAR(ii(5)+i-1))
516 node_fram2 = nint(gbuf%INTVAR(ii(6)+i-1))
517 IF (fra2 > 0) THEN
518 offset = (gbuf%POSX(ii(1)+i-1)-gbuf%POSX(ii(2)+i-1))*flow_direction
519 ELSE
520 node_fram2 = node_cores_dir2(node_fram1)
521 compt = abs(tag_nod(ixc(1+node_fram2,j)))
522 fra2 = cores_fram(compt)
523 offset = slipring(slip)%FRAM(fra1)%RINGSLIP - slipring(slip)%FRAM(fra2)%RINGSLIP
524 offset = flow_direction*offset-slipring(slip)%FRAM(fra2)%CURRENT_LENGTH(strand)
525 ENDIF
526C-- computation of local coordinates
527 nn1 = slipring(slip)%FRAM(fra1)%ANCHOR_NODE
528 nn2 = slipring(slip)%FRAM(fra2)%ANCHOR_NODE
529 CALL shell_loc_cor(x,ixc,j,xl2,yl2,xl3,yl3,xl4,yl4,irep,nn1,nn2,n_dir2)
530C-- shell reactivation process - update of reference state -- reset of strain tensor
531 CALL shell_reactivation(i,ii,l0fram1,l0fram2,node_fram1,
532 . node_fram2,gbuf%STRA,nel,xl2,yl2,
533 . xl3,yl3,xl4,yl4,offset,
534 . n_dir2,bufly%DIRA(i),bufly%DIRA(nel+i),gbuf%SMSTR,ismstr,
535 . l_smstr,orient)
536C reset of fram
537 gbuf%SLIPRING_FRAM_ID(ii(1)+i-1) = zero
538 gbuf%SLIPRING_FRAM_ID(ii(2)+i-1) = zero
539C flag for reset of stress - for each integ point
540 DO ir=1,nptr
541 DO is=1,npts
542 DO it=1,nptt
543 bufly%MAT(ir,is,it)%VAR(nel*(7-1)+i) = 1
544 ENDDO
545 ENDDO
546 ENDDO
547C
548 ENDIF
549C
550 ENDDO
551 ENDIF
552C
553 ENDDO
554C
555 ENDIF
556C
557 IF (((n_seatbelt_2d > 0).AND.(ncycle==0)).OR.(flag_slipring_update /= 0)) THEN
558 DEALLOCATE(tag_nod,cores_slip,cores_fram)
559 ENDIF
560C
561C----------------------------------------------------------
562C----------------------------------------------------------
563C----------------------------------------------------------
564C
565 RETURN
566
567 END
my_real
#define my_real
Definition cppsort.cpp:32
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::retractor
type(retractor_struct), dimension(:), allocatable retractor
Definition seatbelt_mod.F:155
seatbelt_mod::slipring
type(slipring_struct), dimension(:), allocatable slipring
Definition seatbelt_mod.F:110
shell_loc_cor
subroutine shell_loc_cor(x, ixc, j, xl2, yl2, xl3, yl3, xl4, yl4, irep, nn1, nn2, n_dir2)
Definition shell_loc_cor.F:33
shell_reactivation
subroutine shell_reactivation(i, ii, l0fram1, l0fram2, node_fram1, node_fram2, gstr, nel, xl2, yl2, xl3, yl3, xl4, yl4, offset, n_dir2, dira_x, dira_y, smstr, ismstr, l_smstr, orient)
Definition shell_reactivation.F:35
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
arret
subroutine arret(nn)
Definition arret.F:86
update_slipring
subroutine update_slipring(ixr, ixc, iparg, elbuf_tab, flag_slipring_update, flag_retractor_update, x, npby)
Definition update_slipring.F:40