OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25irtlm.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine i25irtlm (ipari, intbuf_tab, itab, nin)

Function/Subroutine Documentation

◆ i25irtlm()

subroutine i25irtlm ( integer, dimension(npari,ninter) ipari,
type(intbuf_struct_) intbuf_tab,
integer, dimension(*) itab,
integer nin )

Definition at line 31 of file i25irtlm.F.

33C=======================================================================
34C-----------------------------------------------
35C M o d u l e s
36C-----------------------------------------------
37 USE intbufdef_mod
38 USE tri7box
39C-----------------------------------------------
40C I m p l i c i t T y p e s
41C-----------------------------------------------
42#include "implicit_f.inc"
43#include "comlock.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com04_c.inc"
48#include "param_c.inc"
49#include "task_c.inc"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53 INTEGER NIN
54 INTEGER IPARI(NPARI,NINTER), ITAB(*)
55C REAL
56 TYPE(INTBUF_STRUCT_) INTBUF_TAB
57C-----------------------------------------------
58C L o c a l V a r i a b l e s
59C-----------------------------------------------
60 INTEGER
61 . I, J, L, H, I_STOK_RTLM,
62 . N, NSN, NSNR, IVIS2
63C REAL
64C-----------------------------------------------
65C REAL
66C-----------------------------------------------
67 nsn =ipari(5,nin)
68 nsnr =ipari(24,nin)
69 ivis2 =ipari(14,nin)
70C
71 i_stok_rtlm = 0
72 IF(ivis2/=-1) THEN
73
74 DO n=1,nsn
75c if(itab(INTBUF_TAB%nsv(n))==10004284)
76c . print *,'nat',nin,ipari(15,nin),ispmd+1,INTBUF_TAB%IRTLM(4*(N-1)+1),INTBUF_TAB%IRTLM(4*(N-1)+4),
77c . INTBUF_TAB%PENE_OLD(5*(N-1)+5)
78 IF(intbuf_tab%IRTLM(4*(n-1)+1) > 0)THEN
79 IF(intbuf_tab%STFNS(n)==zero)THEN
80C
81C Shooting Nodes
82 intbuf_tab%IRTLM(4*n-3:4*n)=0
83 ELSEIF(intbuf_tab%IRTLM(4*(n-1)+4) == ispmd+1)THEN
84 l = intbuf_tab%IRTLM(4*(n-1)+3)
85 IF(intbuf_tab%STFM(l)==zero)THEN
86C
87C Reset IRTLM when a Secnd node is in contact with a Main surface which was deleted.
88 intbuf_tab%IRTLM(4*(n-1)+1)=0
89 intbuf_tab%IRTLM(4*(n-1)+2)=0
90C
91C The segment where the node was impacted has been deleted
92C at the previous cycle => the node can not impact during THIS cycle, but the next cycle ONLY
93 intbuf_tab%IRTLM(4*(n-1)+3) = -1
94 intbuf_tab%IRTLM(4*(n-1)+4) = 0
95 intbuf_tab%TIME_S(2*(n-1)+1) = ep20
96 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
97C
98 intbuf_tab%SECND_FR(6*(n-1)+1:6*n) = zero
99 intbuf_tab%STIF_OLD(2*(n-1)+1:2*n)= zero
100 intbuf_tab%PENE_OLD(5*(n-1)+1:5*n)= zero
101C
102 ELSE
103C
104C N impacte sur mon domaine SPMD, sur le segment n IRTLM(3,N)
105 i_stok_rtlm=i_stok_rtlm+1
106 intbuf_tab%CAND_OPT_N(i_stok_rtlm)= n
107 intbuf_tab%CAND_OPT_E(i_stok_rtlm)= l
108C
109C copy old friction forces
110 intbuf_tab%SECND_FR(6*(n-1)+4:6*n)=intbuf_tab%SECND_FR(6*(n-1)+1:6*(n-1)+3)
111C set new friction forces at 0
112 intbuf_tab%SECND_FR(6*(n-1)+1:6*(n-1)+3)=zero
113 intbuf_tab%PENE_OLD(5*(n-1)+2) = intbuf_tab%PENE_OLD(5*(n-1)+1)
114 intbuf_tab%PENE_OLD(5*(n-1)+1) = zero
115 intbuf_tab%STIF_OLD(2*(n-1)+2) = intbuf_tab%STIF_OLD(2*(n-1)+1)
116 intbuf_tab%STIF_OLD(2*(n-1)+1) = zero
117C
118C se prepare a quitter le contact
119 intbuf_tab%TIME_S(2*(n-1)+1) = ep20
120 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
121 END IF
122 ELSE ! IF(INTBUF_TAB%IRTLM(4*(N-1)+4) == ISPMD+1)THEN
123C
124C Seul le processeur qui a l ancien impact garde les informations correspondantes
125 intbuf_tab%SECND_FR(6*(n-1)+1:6*n) =zero
126 intbuf_tab%STIF_OLD(2*(n-1)+1:2*n)=zero
127 intbuf_tab%PENE_OLD(5*(n-1)+1) =zero
128 intbuf_tab%PENE_OLD(5*(n-1)+2) =zero
129 intbuf_tab%PENE_OLD(5*(n-1)+3) =zero
130 intbuf_tab%PENE_OLD(5*(n-1)+4) =zero
131 intbuf_tab%PENE_OLD(5*(n-1)+5) =zero
132C
133C se prepare a quitter le contact
134 intbuf_tab%TIME_S(2*(n-1)+1) = ep20
135 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
136 END IF
137 ELSE ! IF(INTBUF_TAB%IRTLM(4*(N-1)+1) > 0)THEN
138C reset all for future impact
139c INTBUF_TAB%IRTLM(4*(N-1)+3)=0
140c INTBUF_TAB%SECND_FR(6*(N-1)+1:6*N) =ZERO
141c INTBUF_TAB%STIF_OLD(2*(N-1)+1:2*N)= ZERO
142c INTBUF_TAB%PENE_OLD(5*(N-1)+1:5*N)= ZERO
143 intbuf_tab%PENE_OLD(5*(n-1)+3) =zero
144 intbuf_tab%PENE_OLD(5*(n-1)+4) =zero
145 intbuf_tab%TIME_S(2*(n-1)+1) = -ep20
146 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
147 END IF
148 END DO
149C
150 DO n=1,nsnr
151c if(itafi(nin)%p(n)==28552)
152c . print *,'rem',nin,ipari(15,nin),ispmd+1,IRTLM_FI(NIN)%P(1,N),IRTLM_FI(NIN)%P(4,N),
153c . PENE_OLDFI(NIN)%P(5,N)
154 IF(irtlm_fi(nin)%P(1,n) > 0)THEN
155 IF(stifi(nin)%P(n)==zero)THEN
156C
157C Shooting Nodes
158 irtlm_fi(nin)%P(1:4,n)=0
159 ELSEIF(irtlm_fi(nin)%P(4,n) == ispmd+1)THEN
160 l = irtlm_fi(nin)%P(3,n)
161 IF(intbuf_tab%STFM(l)==zero)THEN
162C
163C Reset IRTLM when a Secnd node is in contact with a Main surface which was deleted.
164 irtlm_fi(nin)%P(1,n)=0
165 irtlm_fi(nin)%P(2,n)=0
166C
167C The segment where the node was impacted has been deleted
168C at the previous cycle => the node can not impact during THIS cycle, but the next cycle ONLY
169 irtlm_fi(nin)%P(3,n) = -1
170 irtlm_fi(nin)%P(4,n) = 0
171 time_sfi(nin)%P(2*(n-1)+1) = ep20
172 time_sfi(nin)%P(2*(n-1)+2) = ep20
173C
174 secnd_frfi(nin)%P (1:6,n)=zero
175 pene_oldfi(nin)%P(1:5,n)=zero
176 stif_oldfi(nin)%P(1:2,n)=zero
177C
178 ELSE
179 i_stok_rtlm=i_stok_rtlm+1
180 intbuf_tab%CAND_OPT_N(i_stok_rtlm)= nsn+n
181 intbuf_tab%CAND_OPT_E(i_stok_rtlm)= l
182C
183C copy old friction forces
184 secnd_frfi(nin)%P(4:6,n)=secnd_frfi(nin)%P(1:3,n)
185C set new friction forces at 0
186 secnd_frfi(nin)%P(1:3,n)=zero
187 pene_oldfi(nin)%P(2,n) = pene_oldfi(nin)%P(1,n)
188 pene_oldfi(nin)%P(1,n) = zero
189 stif_oldfi(nin)%P(2,n) = stif_oldfi(nin)%P(1,n)
190 stif_oldfi(nin)%P(1,n) = zero
191C
192C se prepare a quitter le contact
193 time_sfi(nin)%P(2*(n-1)+1) = ep20
194 time_sfi(nin)%P(2*(n-1)+2) = ep20
195 END IF
196 ELSE ! IF(IRTLM_FI(NIN)%P(4,N) == ISPMD+1)THEN
197C
198C Seul le processeur qui a l ancien impact garde les informations correspondantes
199 secnd_frfi(nin)%P(1:6,n) =zero
200 stif_oldfi(nin)%P(1:2,n)=zero
201 pene_oldfi(nin)%P(1,n) =zero
202 pene_oldfi(nin)%P(2,n) =zero
203 pene_oldfi(nin)%P(3,n) =zero
204 pene_oldfi(nin)%P(4,n) =zero
205 pene_oldfi(nin)%P(5,n) =zero
206C
207C se prepare a quitter le contact
208 time_sfi(nin)%P(2*(n-1)+1) = ep20
209 time_sfi(nin)%P(2*(n-1)+2) = ep20
210 END IF
211 ELSE ! IF(IRTLM_FI(NIN)%P(1,N) > 0)THEN
212C reset all for future impact
213c IRTLM_FI(NIN)%P(3,N)=0
214c SECND_FRFI(NIN)%P (1:6,N)=ZERO
215c PENE_OLDFI(NIN)%P(1:5,N)=ZERO
216c STIF_OLDFI(NIN)%P(1:2,N)=ZERO
217 pene_oldfi(nin)%P(3,n) =zero
218 pene_oldfi(nin)%P(4,n) =zero
219 time_sfi(nin)%P(2*(n-1)+1) = -ep20
220 time_sfi(nin)%P(2*(n-1)+2) = ep20
221 END IF
222 END DO
223C
224 ELSE ! IVIS2 == -1 : Interface adhesion case
225C
226 DO n=1,nsn
227c if(itab(INTBUF_TAB%nsv(n))==10004284)
228c . print *,'nat',nin,ipari(15,nin),ispmd+1,INTBUF_TAB%IRTLM(4*(N-1)+1),INTBUF_TAB%IRTLM(4*(N-1)+4),
229c . INTBUF_TAB%PENE_OLD(5*(N-1)+5)
230 IF(intbuf_tab%IRTLM(4*(n-1)+1) > 0)THEN
231 IF(intbuf_tab%STFNS(n)==zero)THEN
232C
233C Shooting Nodes
234 intbuf_tab%IRTLM(4*n-3:4*n)=0
235 ELSEIF(intbuf_tab%IRTLM(4*(n-1)+4) == ispmd+1)THEN
236 l = intbuf_tab%IRTLM(4*(n-1)+3)
237 IF(intbuf_tab%STFM(l)==zero)THEN
238C
239C Reset IRTLM when a Secnd node is in contact with a Main surface which was deleted.
240 intbuf_tab%IRTLM(4*(n-1)+1)=0
241 intbuf_tab%IRTLM(4*(n-1)+2)=0
242C
243C The segment where the node was impacted has been deleted
244C at the previous cycle => the node can not impact during THIS cycle, but the next cycle ONLY
245 intbuf_tab%IRTLM(4*(n-1)+3) = -1
246 intbuf_tab%IRTLM(4*(n-1)+4) = 0
247 intbuf_tab%TIME_S(2*(n-1)+1) = ep20
248 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
249C
250 intbuf_tab%SECND_FR(6*(n-1)+1:6*n) = zero
251 intbuf_tab%STIF_OLD(2*(n-1)+1:2*n)= zero
252 intbuf_tab%PENE_OLD(5*(n-1)+1:5*n)= zero
253 intbuf_tab%IF_ADH(n) = 0
254C
255 ELSE
256C
257C N impacte sur mon domaine SPMD, sur le segment n IRTLM(3,N)
258 i_stok_rtlm=i_stok_rtlm+1
259 intbuf_tab%CAND_OPT_N(i_stok_rtlm)= n
260 intbuf_tab%CAND_OPT_E(i_stok_rtlm)= l
261C
262C copy old friction forces
263 intbuf_tab%SECND_FR(6*(n-1)+4:6*n)=intbuf_tab%SECND_FR(6*(n-1)+1:6*(n-1)+3)
264C set new friction forces at 0
265 intbuf_tab%SECND_FR(6*(n-1)+1:6*(n-1)+3)=zero
266 intbuf_tab%PENE_OLD(5*(n-1)+2) = intbuf_tab%PENE_OLD(5*(n-1)+1)
267 intbuf_tab%PENE_OLD(5*(n-1)+1) = zero
268 intbuf_tab%STIF_OLD(2*(n-1)+2) = intbuf_tab%STIF_OLD(2*(n-1)+1)
269 intbuf_tab%STIF_OLD(2*(n-1)+1) = zero
270C
271C se prepare a quitter le contact
272 intbuf_tab%TIME_S(2*(n-1)+1) = ep20
273 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
274 END IF
275 ELSE ! IF(INTBUF_TAB%IRTLM(4*(N-1)+4) == ISPMD+1)THEN
276C
277C Seul le processeur qui a l ancien impact garde les informations correspondantes
278 intbuf_tab%SECND_FR(6*(n-1)+1:6*n) =zero
279 intbuf_tab%STIF_OLD(2*(n-1)+1:2*n)=zero
280 intbuf_tab%PENE_OLD(5*(n-1)+1) =zero
281 intbuf_tab%PENE_OLD(5*(n-1)+2) =zero
282 intbuf_tab%PENE_OLD(5*(n-1)+3) =zero
283 intbuf_tab%PENE_OLD(5*(n-1)+4) =zero
284 intbuf_tab%PENE_OLD(5*(n-1)+5) =zero
285 intbuf_tab%IF_ADH(n) = 0
286C
287C se prepare a quitter le contact
288 intbuf_tab%TIME_S(2*(n-1)+1) = ep20
289 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
290 END IF
291 ELSE ! IF(INTBUF_TAB%IRTLM(4*(N-1)+1) > 0)THEN
292C reset all for future impact
293c INTBUF_TAB%IRTLM(4*(N-1)+3)=0
294c INTBUF_TAB%SECND_FR(6*(N-1)+1:6*N) =ZERO
295c INTBUF_TAB%STIF_OLD(2*(N-1)+1:2*N)= ZERO
296c INTBUF_TAB%PENE_OLD(5*(N-1)+1:5*N)= ZERO
297 intbuf_tab%TIME_S(2*(n-1)+1) = -ep20
298 intbuf_tab%TIME_S(2*(n-1)+2) = ep20
299 END IF
300 END DO
301C
302 DO n=1,nsnr
303c if(itafi(nin)%p(n)==28552)
304c . print *,'rem',nin,ipari(15,nin),ispmd+1,IRTLM_FI(NIN)%P(1,N),IRTLM_FI(NIN)%P(4,N),
305c . PENE_OLDFI(NIN)%P(5,N)
306 IF(irtlm_fi(nin)%P(1,n) > 0)THEN
307 IF(stifi(nin)%P(n)==zero)THEN
308C
309C Shooting Nodes
310 irtlm_fi(nin)%P(1:4,n)=0
311 ELSEIF(irtlm_fi(nin)%P(4,n) == ispmd+1)THEN
312 l = irtlm_fi(nin)%P(3,n)
313 IF(intbuf_tab%STFM(l)==zero)THEN
314C
315C Reset IRTLM when a Secnd node is in contact with a Main surface which was deleted.
316 irtlm_fi(nin)%P(1,n)=0
317 irtlm_fi(nin)%P(2,n)=0
318C
319C The segment where the node was impacted has been deleted
320C at the previous cycle => the node can not impact during THIS cycle, but the next cycle ONLY
321 irtlm_fi(nin)%P(3,n) = -1
322 irtlm_fi(nin)%P(4,n) = 0
323 time_sfi(nin)%P(2*(n-1)+1) = ep20
324 time_sfi(nin)%P(2*(n-1)+2) = ep20
325C
326 secnd_frfi(nin)%P (1:6,n)=zero
327 pene_oldfi(nin)%P(1:5,n)=zero
328 stif_oldfi(nin)%P(1:2,n)=zero
329 if_adhfi(nin)%P(n) = 0
330C
331 ELSE
332 i_stok_rtlm=i_stok_rtlm+1
333 intbuf_tab%CAND_OPT_N(i_stok_rtlm)= nsn+n
334 intbuf_tab%CAND_OPT_E(i_stok_rtlm)= l
335C
336C copy old friction forces
337 secnd_frfi(nin)%P(4:6,n)=secnd_frfi(nin)%P(1:3,n)
338C set new friction forces at 0
339 secnd_frfi(nin)%P(1:3,n)=zero
340 pene_oldfi(nin)%P(2,n) = pene_oldfi(nin)%P(1,n)
341 pene_oldfi(nin)%P(1,n) = zero
342 stif_oldfi(nin)%P(2,n) = stif_oldfi(nin)%P(1,n)
343 stif_oldfi(nin)%P(1,n) = zero
344C
345C se prepare a quitter le contact
346 time_sfi(nin)%P(2*(n-1)+1) = ep20
347 time_sfi(nin)%P(2*(n-1)+2) = ep20
348 END IF
349 ELSE ! IF(IRTLM_FI(NIN)%P(4,N) == ISPMD+1)THEN
350C
351C Seul le processeur qui a l ancien impact garde les informations correspondantes
352 secnd_frfi(nin)%P(1:6,n) =zero
353 stif_oldfi(nin)%P(1:2,n)=zero
354 pene_oldfi(nin)%P(1,n) =zero
355 pene_oldfi(nin)%P(2,n) =zero
356 pene_oldfi(nin)%P(3,n) =zero
357 pene_oldfi(nin)%P(4,n) =zero
358 pene_oldfi(nin)%P(5,n) =zero
359 if_adhfi(nin)%P(n) = 0
360C
361C se prepare a quitter le contact
362 time_sfi(nin)%P(2*(n-1)+1) = ep20
363 time_sfi(nin)%P(2*(n-1)+2) = ep20
364 END IF
365 ELSE ! IF(IRTLM_FI(NIN)%P(1,N) > 0)THEN
366C reset all for future impact
367c IRTLM_FI(NIN)%P(3,N)=0
368c SECND_FRFI(NIN)%P (1:6,N)=ZERO
369c PENE_OLDFI(NIN)%P(1:5,N)=ZERO
370c STIF_OLDFI(NIN)%P(1:2,N)=ZERO
371 time_sfi(nin)%P(2*(n-1)+1) = -ep20
372 time_sfi(nin)%P(2*(n-1)+2) = ep20
373 END IF
374 END DO
375C
376 ENDIF ! IVIS2 if
377C
378 intbuf_tab%I_STOK(3) = i_stok_rtlm
379 intbuf_tab%I_STOK(2) = i_stok_rtlm
380C
381C-----------------------------------------------------------------------
382 RETURN
tri7box::stif_oldfi
type(real_pointer2), dimension(:), allocatable stif_oldfi
Definition tri7box.F:545
tri7box::secnd_frfi
type(real_pointer2), dimension(:), allocatable secnd_frfi
Definition tri7box.F:543
tri7box::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
tri7box::stifi
type(real_pointer), dimension(:), allocatable stifi
Definition tri7box.F:449
tri7box::pene_oldfi
type(real_pointer2), dimension(:), allocatable pene_oldfi
Definition tri7box.F:544
tri7box::if_adhfi
type(int_pointer), dimension(:), allocatable if_adhfi
Definition tri7box.F:440