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