OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_tri25gat.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "task_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "scr18_c.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "spmd_c.inc"
#include "sms_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_tri25gat (result, nsn, cand_n, i_stok, nin, igap, nsnr, multimp, ity, intth, ilev, nsnfiold, ipari, nsnrold, renum, h3d_data, intfric, flagremn, lremnormax, nrtm, kremnod, remnod, ivis2, istif_msdt, ifsub_carea, nodadt_therm)

Function/Subroutine Documentation

◆ spmd_tri25gat()

subroutine spmd_tri25gat ( integer result,
integer nsn,
integer, dimension(*) cand_n,
integer i_stok,
integer nin,
integer igap,
integer nsnr,
integer multimp,
integer ity,
integer intth,
integer ilev,
integer, dimension(*) nsnfiold,
integer, dimension(npari,ninter) ipari,
integer nsnrold,
integer, dimension(*) renum,
type(h3d_database) h3d_data,
integer intfric,
integer flagremn,
integer lremnormax,
integer nrtm,
integer, dimension(*) kremnod,
integer, dimension(*) remnod,
integer ivis2,
integer, intent(in) istif_msdt,
integer, intent(in) ifsub_carea,
integer, intent(in) nodadt_therm )

Definition at line 35 of file spmd_tri25gat.F.

41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE tri7box
45 USE message_mod
46 USE h3d_mod
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 "com08_c.inc"
57#include "task_c.inc"
58#include "scr14_c.inc"
59#include "scr16_c.inc"
60#include "scr18_c.inc"
61#include "param_c.inc"
62#include "parit_c.inc"
63#include "spmd_c.inc"
64#include "sms_c.inc"
65C-----------------------------------------------
66C D u m m y A r g u m e n t s
67C-----------------------------------------------
68 INTEGER RESULT, NIN, NSN, I_STOK, IGAP, NSNR, MULTIMP, ITY,
69 . FLAGREMN,LREMNORMAX,NRTM,
70 . CAND_N(*),INTTH,ILEV, INTFRIC, IVIS2,
71 . NSNFIOLD(*), IPARI(NPARI,NINTER), NSNROLD, RENUM(*),
72 . KREMNOD(*), REMNOD(*)
73 TYPE(H3D_DATABASE) :: H3D_DATA
74 INTEGER , INTENT(IN) :: ISTIF_MSDT, IFSUB_CAREA
75 INTEGER , INTENT(IN) :: NODADT_THERM
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79#ifdef MPI
80 INTEGER OLDNSNR,NODFI,NNP,LSKYFI,
81 . NOD, LOC_PROC, I, N, NN, P, IDEB, J, K, NI,
82 . IERROR1,IERROR2,IERROR3,IERROR4,IERROR5,IERROR6,IERROR7,
83 . IERROR8,IERROR9,IERROR0,IERROR11,IERROR12,
84 . IERROR13,IERROR14,IERROR15,IERROR16,IERROR17,IERROR18,IERROR19,IERROR20,
85 . IERROR21,INDEX(NSNR),NN2,RSHIFT,ISHIFT, IOLDNSNFI, ND, JDEB, NSNR_OLD, Q,
86 . KK ,SIZREMNORFI, NE, KI, KM, LL
87
88 INTEGER, DIMENSION(:), ALLOCATABLE :: IAUX, IFFI_ADH
89 my_real,
90 . DIMENSION(:), ALLOCATABLE :: stiffi_old
91 my_real,
92 . DIMENSION(:,:), ALLOCATABLE :: penefi_old, secnd_frfi_old
93 INTEGER, DIMENSION(:), ALLOCATABLE :: REMNOR_FI_TMP
94C-----------------------------------------------
95C S o u r c e L i n e s
96C-----------------------------------------------
97 loc_proc = ispmd + 1
98C
99C
100 nodfi = 0
101 lskyfi= 0
102
103 IF(.NOT.(ALLOCATED(current_fi_size))) ALLOCATE(current_fi_size(ninter))
104 IF(.NOT.(ALLOCATED(current_nodfi))) ALLOCATE(current_nodfi(ninter))
105
106
107 IF(result==0) THEN
108C
109C Reperage des candidats
110C
111 DO ni = 1, nsnrold
112C STIFI a ete mis a jour dans SPMD_GET_STIF !
113C STIFI was not set at time=0 (not read from restart)
114 IF((tt==zero.OR.stifi(nin)%P(ni)>zero).AND.irtlm_fi(nin)%P(4,ni)==loc_proc)THEN
115 nodfi = nodfi + 1
116 nn = renum(ni)
117 IF( nn >0)THEN
118 irem(1,nn) = -irem(1,nn)
119 ENDIF
120 END IF
121 END DO
122C
123 DO i = 1, i_stok
124 n = cand_n(i)
125 nn = n-nsn
126 IF(nn>0)THEN
127 IF(irem(1,nn)>0)THEN
128 nodfi = nodfi + 1
129 irem(1,nn) = -irem(1,nn)
130 ENDIF
131 ENDIF
132 ENDDO
133C
134C Allocation des tableaux de frontieres interfaces
135C
136 ierror1 = 0
137 ierror2 = 0
138 ierror3 = 0
139 ierror4 = 0
140 ierror5 = 0
141 ierror6 = 0
142 ierror7 = 0
143 ierror8 = 0
144 ierror9 = 0
145 ierror0 = 0
146 ierror11 = 0
147 ierror12 = 0
148 ierror13 = 0
149 ierror14 = 0
150 ierror15 = 0
151 ierror16 = 0
152 ierror17 = 0
153 ierror18 = 0
154 ierror19 = 0
155 ierror20 = 0
156 ierror21 = 0
157
158
159 ! margin can be implemented here in order to avoid
160 ! allocation / deallocation for type 25 in case of sliding
161 current_fi_size(nin) = nodfi
162 current_nodfi(nin) = nodfi
163
164 IF(ASSOCIATED(nsvfi(nin)%P)) DEALLOCATE(nsvfi(nin)%P)
165 ALLOCATE(nsvfi(nin)%P(nodfi),stat=ierror1)
166 IF(ASSOCIATED(pmainfi(nin)%P)) DEALLOCATE(pmainfi(nin)%P)
167 ALLOCATE(pmainfi(nin)%P(nodfi),stat=ierror2)
168 ierror1 = ierror2 + ierror1
169 IF(ASSOCIATED(xfi(nin)%P)) DEALLOCATE(xfi(nin)%P)
170 ALLOCATE(xfi(nin)%P(3,nodfi),stat=ierror2)
171 IF(ASSOCIATED(vfi(nin)%P)) DEALLOCATE(vfi(nin)%P)
172 ALLOCATE(vfi(nin)%P(3,nodfi),stat=ierror3)
173 IF(ASSOCIATED(msfi(nin)%P)) DEALLOCATE(msfi(nin)%P)
174 ALLOCATE(msfi(nin)%P(nodfi),stat=ierror4)
175 IF(ASSOCIATED(stifi(nin)%P)) DEALLOCATE(stifi(nin)%P)
176 ALLOCATE(stifi(nin)%P(nodfi),stat=ierror5)
177 IF(ASSOCIATED(itafi(nin)%P)) DEALLOCATE(itafi(nin)%P)
178 ALLOCATE(itafi(nin)%P(nodfi),stat=ierror6)
179 IF(ity==7.OR.ity==22.OR.ity==23.OR.ity==24.OR.
180 + ity==25) THEN
181 IF(ASSOCIATED(kinfi(nin)%P)) DEALLOCATE(kinfi(nin)%P)
182 ALLOCATE(kinfi(nin)%P(nodfi),stat=ierror8)
183 IF(intth > 0 ) THEN
184 IF(ASSOCIATED(tempfi(nin)%P)) DEALLOCATE(tempfi(nin)%P)
185 ALLOCATE(tempfi(nin)%P(nodfi),stat=ierror9)
186 IF(ASSOCIATED(matsfi(nin)%P)) DEALLOCATE(matsfi(nin)%P)
187 ALLOCATE(matsfi(nin)%P(nodfi),stat=ierror0)
188 IF(ASSOCIATED(areasfi(nin)%P)) DEALLOCATE(areasfi(nin)%P)
189 ALLOCATE(areasfi(nin)%P(nodfi),stat=ierror11)
190 ENDIF
191 IF(intth==0.AND.ivis2==-1) THEN
192 IF(ASSOCIATED(areasfi(nin)%P)) DEALLOCATE(areasfi(nin)%P)
193 ALLOCATE(areasfi(nin)%P(nodfi),stat=ierror11)
194c IF_ADHFI allocation is done later once NSNR_OLD is calculated
195 ENDIF
196 ENDIF
197 IF(idtmins == 2) THEN
198 IF(ASSOCIATED(nodnxfi(nin)%P)) DEALLOCATE(nodnxfi(nin)%P)
199 ALLOCATE(nodnxfi(nin)%P(nodfi),stat=ierror12)
200 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
201 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror13)
202 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
203 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror14)
204 ELSEIF(idtmins_int /= 0) THEN
205 IF(ASSOCIATED(nodamsfi(nin)%P)) DEALLOCATE(nodamsfi(nin)%P)
206 ALLOCATE(nodamsfi(nin)%P(nodfi),stat=ierror13)
207 IF(ASSOCIATED(procamsfi(nin)%P)) DEALLOCATE(procamsfi(nin)%P)
208 ALLOCATE(procamsfi(nin)%P(nodfi),stat=ierror14)
209 ENDIF
210 IF(igap/=0) THEN
211 IF(ASSOCIATED(gapfi(nin)%P)) DEALLOCATE(gapfi(nin)%P)
212 ALLOCATE(gapfi(nin)%P(nodfi),stat=ierror7)
213 IF(igap==3) THEN
214 IF(ASSOCIATED(gap_lfi(nin)%P)) DEALLOCATE(gap_lfi(nin)%P)
215 ALLOCATE(gap_lfi(nin)%P(nodfi),stat=ierror7)
216 ENDIF
217 ENDIF
218 IF(istif_msdt > 0) THEN
219 IF(ASSOCIATED(stif_msdt_fi(nin)%P))DEALLOCATE(stif_msdt_fi(nin)%P)
220 ALLOCATE(stif_msdt_fi(nin)%P(nodfi),stat=ierror7)
221 ENDIF
222 IF(ifsub_carea > 0) THEN
223 IF(ASSOCIATED(intareanfi(nin)%P))DEALLOCATE(intareanfi(nin)%P)
224 ALLOCATE(intareanfi(nin)%P(nodfi),stat=ierror7)
225 ENDIF
226C
227 nsnr_old=ipari(24,nin)
228 ALLOCATE(secnd_frfi_old(3,nsnr_old),penefi_old(4,nsnr_old),
229 . stiffi_old(nsnr_old),
230 . stat=ierror16)
231 secnd_frfi_old(1:3,1:nsnr_old)=zero
232 penefi_old(1:4,1:nsnr_old) =zero
233 stiffi_old(1:nsnr_old) =zero
234
235C create a temporary array IFFI_ADH to copy old values
236
237 IF(ity==25.AND.ivis2==-1) THEN
238 ALLOCATE(iffi_adh(nsnr_old), stat=ierror16)
239 iffi_adh(1:nsnr_old) = 0
240 ENDIF
241C
242 IF(ASSOCIATED(irtlm_fi(nin)%P)) DEALLOCATE(irtlm_fi(nin)%P)
243 ALLOCATE(irtlm_fi(nin)%P(4,nodfi),stat=ierror15)
244C
245 IF(ASSOCIATED(time_sfi(nin)%P)) DEALLOCATE(time_sfi(nin)%P)
246 ALLOCATE(time_sfi(nin)%P(2*nodfi),stat=ierror16)
247C
248 IF(ASSOCIATED(secnd_frfi(nin)%P)) THEN
249 secnd_frfi_old(1:3,1:nsnr_old)=secnd_frfi(nin)%P(1:3,1:nsnr_old)
250 DEALLOCATE(secnd_frfi(nin)%P)
251 END IF
252 ALLOCATE(secnd_frfi(nin)%P(6,nodfi),stat=ierror16)
253C
254 IF(ASSOCIATED(pene_oldfi(nin)%P)) THEN
255 penefi_old(1,1:nsnr_old)=pene_oldfi(nin)%P(1,1:nsnr_old)
256 penefi_old(2,1:nsnr_old)=pene_oldfi(nin)%P(5,1:nsnr_old)
257 penefi_old(3,1:nsnr_old)=pene_oldfi(nin)%P(3,1:nsnr_old)
258 penefi_old(4,1:nsnr_old)=pene_oldfi(nin)%P(4,1:nsnr_old)
259 DEALLOCATE(pene_oldfi(nin)%P)
260 END IF
261 ALLOCATE(pene_oldfi(nin)%P(5,nodfi),stat=ierror16)
262C
263 IF(ASSOCIATED(stif_oldfi(nin)%P)) THEN
264 stiffi_old(1:nsnr_old)=stif_oldfi(nin)%P(1,1:nsnr_old)
265 DEALLOCATE(stif_oldfi(nin)%P)
266 END IF
267 ALLOCATE(stif_oldfi(nin)%P(2,nodfi),stat=ierror16)
268C
269C copy old values of if_adh
270 IF(ivis2==-1) THEN
271 IF(ASSOCIATED(if_adhfi(nin)%P)) THEN
272 iffi_adh(1:nsnr_old)=if_adhfi(nin)%P(1:nsnr_old)
273 DEALLOCATE(if_adhfi(nin)%P)
274 END IF
275 ALLOCATE(if_adhfi(nin)%P(nodfi),stat=ierror16)
276 ENDIF
277C
278 IF(ASSOCIATED(icont_i_fi(nin)%P))DEALLOCATE(icont_i_fi(nin)%P)
279 ALLOCATE(icont_i_fi(nin)%P(nodfi),stat=ierror16)
280
281 IF(ASSOCIATED(iskew_fi(nin)%P))DEALLOCATE(iskew_fi(nin)%P)
282 ALLOCATE(iskew_fi(nin)%P(nodfi),stat=ierror17)
283
284 IF(ASSOCIATED(icodt_fi(nin)%P))DEALLOCATE(icodt_fi(nin)%P)
285 ALLOCATE(icodt_fi(nin)%P(nodfi),stat=ierror17)
286C
287 IF(ASSOCIATED(islide_fi(nin)%P))DEALLOCATE(islide_fi(nin)%P)
288 ALLOCATE(islide_fi(nin)%P(4,nodfi),stat=ierror17)
289C
290C Friction model
291 IF(intfric > 0 ) THEN
292 IF(ASSOCIATED(ipartfricsfi(nin)%P)) DEALLOCATE(ipartfricsfi(nin)%P)
293 ALLOCATE(ipartfricsfi(nin)%P(nodfi),stat=ierror18)
294 ENDIF
295C REMOVE NODES FLAGREMNOD
296 IF(flagremn == 2 ) THEN
297 IF(ASSOCIATED(kremnor_fi(nin)%P)) DEALLOCATE(kremnor_fi(nin)%P)
298 ALLOCATE(kremnor_fi(nin)%P(nodfi+1),stat=ierror19)
299 kremnor_fi(nin)%P(1:nodfi+1) = 0
300 IF(ASSOCIATED(remnor_fi(nin)%P)) DEALLOCATE(remnor_fi(nin)%P)
301 NULLIFY(remnor_fi(nin)%P)
302 ENDIF
303C
304 IF(ierror1+ierror2+ierror3+ierror4+ierror5+
305 + ierror6+ierror7+ierror8 + ierror9 + ierror0 +
306 + ierror11+ierror12+ierror13+ierror14+ierror15+
307 + ierror16+ierror17+ierror18+ierror19/= 0) THEN
308 CALL ancmsg(msgid=20,anmode=aninfo)
309 CALL arret(2)
310 ENDIF
311C
312 secnd_frfi(nin)%P (1:6,1:nodfi)=zero
313 pene_oldfi(nin)%P(1:5,1:nodfi)=zero
314 stif_oldfi(nin)%P(1:2,1:nodfi)=zero
315C
316C reset FI
317 IF(ivis2==-1) if_adhfi(nin)%P(1:nodfi) = 0
318C
319 IF(flagremn == 2 ) THEN
320 ALLOCATE(remnor_fi_tmp(nodfi*lremnormax),stat=ierror20)
321 IF(ierror20/= 0) THEN
322 CALL ancmsg(msgid=20,anmode=aninfo)
323 CALL arret(2)
324 ENDIF
325C
326 ENDIF
327C
328C Packing candidates
329C
330 ideb = 0
331 nn2 = 0
332 jdeb = 0
333
334 DO p = 1, nspmd
335 nn = 0
336 oldnsnr = nsnfi(nin)%P(p)
337 IF(oldnsnr/=0) THEN
338 ALLOCATE(iaux(oldnsnr),stat=ierror17)
339 IF(ierror17/=0) THEN
340 CALL ancmsg(msgid=20,anmode=aninfo)
341 CALL arret(2)
342 ENDIF
343 nnp = nn2
344 DO i = 1, oldnsnr
345 IF(irem(1,i+ideb)<0) THEN
346 nn = nn + 1
347 iaux(nn) = i
348 ENDIF
349 ENDDO
350c general case
351#include "vectorize.inc"
352 DO j = 1, nn
353 i = iaux(j)
354 index(i+ideb) = nn2+j
355 xfi(nin)%P(1,nn2+j) = xrem(1,i+ideb)
356 xfi(nin)%P(2,nn2+j) = xrem(2,i+ideb)
357 xfi(nin)%P(3,nn2+j) = xrem(3,i+ideb)
358 vfi(nin)%P(1,nn2+j) = xrem(4,i+ideb)
359 vfi(nin)%P(2,nn2+j) = xrem(5,i+ideb)
360 vfi(nin)%P(3,nn2+j) = xrem(6,i+ideb)
361 msfi(nin)%P(nn2+j) = xrem(7,i+ideb)
362 stifi(nin)%P(nn2+j) = xrem(8,i+ideb)
363 nsvfi(nin)%P(nn2+j) = -irem(1,i+ideb)
364 itafi(nin)%P(nn2+j) = irem(2,i+ideb)
365 kinfi(nin)%P(nn2+j) = irem(3,i+ideb)
366 pmainfi(nin)%P(nn2+j) = p
367
368 !ignore specifics IREM and XREM indexes for INT24 sorting
369 !IGAPXREMP = IREM(4,I+IDEB)
370 !I24XREMP = IREM(5,I+IDEB)
371 !I24IREMP = IREM(6,I+IDEB)
372 ENDDO
373
374c shift for real variables (prepare for next setting)
375 rshift = 9
376c shift for integer variables (prepare for next setting)
377 ishift = 7
378
379 IF(.true.)THEN
380#include "vectorize.inc"
381 DO j = 1, nn
382 i = iaux(j)
383 icodt_fi(nin)%P(nn2+j) = irem(ishift+0,i+ideb)
384 iskew_fi(nin)%P(nn2+j) = irem(ishift+1,i+ideb)
385 ENDDO
386 ishift = ishift + 2
387 ENDIF
388
389c IGAP=1 or IGAP=2
390 IF(igap==1 .OR. igap==2)THEN
391#include "vectorize.inc"
392 DO j = 1, nn
393 i = iaux(j)
394 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
395 ENDDO
396 rshift = rshift + 1
397c IGAP=3
398 ELSEIF(igap==3)THEN
399#include "vectorize.inc"
400 DO j = 1, nn
401 i = iaux(j)
402 gapfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
403 gap_lfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
404 ENDDO
405 rshift = rshift + 2
406 ENDIF
407
408C thermic
409 IF(intth>0)THEN
410#include "vectorize.inc"
411 DO j = 1, nn
412 i = iaux(j)
413 tempfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
414 areasfi(nin)%P(nn2+j) = xrem(rshift+1,i+ideb)
415 matsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
416 ENDDO
417 rshift = rshift + 2
418 ishift = ishift + 1
419 ENDIF
420C Interface Adhesion
421 IF(ivis2==-1)THEN
422 jdeb = 0
423 DO q=1,p-1
424 jdeb = jdeb + nsnfiold(q)
425 END DO
426 IF(tt==0) THEN
427#include "vectorize.inc"
428 DO j = 1, nn
429 i = iaux(j)
430 IF(intth==0) areasfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
431 if_adhfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
432 ioldnsnfi = irem(ishift+1,i+ideb)
433 ENDDO
434 ELSE
435#include "vectorize.inc"
436 DO j = 1, nn
437 i = iaux(j)
438 IF(intth==0) areasfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
439 ioldnsnfi = irem(ishift+1,i+ideb)
440 IF(ioldnsnfi /= 0)THEN
441 if_adhfi(nin)%P(nn2+j)=iffi_adh(ioldnsnfi+jdeb)
442 ELSE
443 if_adhfi(nin)%P(nn2+j)=0
444 ENDIF
445 ENDDO
446 ENDIF
447 IF(intth==0) rshift = rshift + 1
448 ishift = ishift + 2
449 ENDIF
450
451C Friction model
452 IF(intfric>0)THEN
453#include "vectorize.inc"
454 DO j = 1, nn
455 i = iaux(j)
456 ipartfricsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
457 ENDDO
458 ishift = ishift + 1
459 ENDIF
460
461C Stif based on mass and dt
462
463 IF(istif_msdt > 0) THEN
464#include "vectorize.inc"
465 DO j = 1, nn
466 i = iaux(j)
467 stif_msdt_fi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
468 ENDDO
469 rshift = rshift + 1
470 ENDIF
471
472C CAREA output in case of NISUB
473
474 IF(ifsub_carea > 0) THEN
475#include "vectorize.inc"
476 DO j = 1, nn
477 i = iaux(j)
478 intareanfi(nin)%P(nn2+j) = xrem(rshift,i+ideb)
479 ENDDO
480 rshift = rshift + 1
481 ENDIF
482
483C -- IDTMINS==2
484 IF(idtmins==2)THEN
485#include "vectorize.inc"
486 DO j = 1, nn
487 i = iaux(j)
488 nodnxfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
489 nodamsfi(nin)%P(nn2+j) = irem(ishift+1,i+ideb)
490 procamsfi(nin)%P(nn2+j) = p
491 ENDDO
492 ishift = ishift + 2
493C -- IDTMINS_INT /= 0
494 ELSEIF(idtmins_int/=0)THEN
495#include "vectorize.inc"
496 DO j = 1, nn
497 i = iaux(j)
498 nodamsfi(nin)%P(nn2+j) = irem(ishift,i+ideb)
499 procamsfi(nin)%P(nn2+j) = p
500 ENDDO
501 ishift = ishift + 1
502 ENDIF
503
504 jdeb = 0
505 DO q=1,p-1
506 jdeb = jdeb + nsnfiold(q)
507 END DO
508
509 IF(tt==zero)THEN
510#include "vectorize.inc"
511 DO j = 1, nn
512 i = iaux(j)
513 irtlm_fi(nin)%P(1,nn2+j) = irem(ishift,i+ideb)
514 irtlm_fi(nin)%P(2,nn2+j) = irem(ishift+1,i+ideb)
515 irtlm_fi(nin)%P(3,nn2+j) = irem(ishift+2,i+ideb)
516 irtlm_fi(nin)%P(4,nn2+j) = irem(ishift+3,i+ideb)
517 icont_i_fi(nin)%P(nn2+j) = irem(ishift+4,i+ideb)
518
519 time_sfi(nin)%P(2*(nn2+j-1)+1) =xrem(rshift,i+ideb)
520 time_sfi(nin)%P(2*(nn2+j-1)+2) =xrem(rshift+1,i+ideb)
521 pene_oldfi(nin)%P(5,nn2+j) =xrem(rshift+2,i+ideb)
522 ioldnsnfi = irem(ishift+5,i+ideb)
523
524 IF(ioldnsnfi /= 0)THEN
525 secnd_frfi(nin)%P(1,nn2+j) =secnd_frfi_old(1,ioldnsnfi+jdeb)
526 secnd_frfi(nin)%P(2,nn2+j) =secnd_frfi_old(2,ioldnsnfi+jdeb)
527 secnd_frfi(nin)%P(3,nn2+j) =secnd_frfi_old(3,ioldnsnfi+jdeb)
528 pene_oldfi(nin)%P(1,nn2+j)=penefi_old(1,ioldnsnfi+jdeb)
529 stif_oldfi(nin)%P(1,nn2+j)=stiffi_old(ioldnsnfi+jdeb)
530 ELSE
531 secnd_frfi(nin)%P(1,nn2+j) =zero
532 secnd_frfi(nin)%P(2,nn2+j) =zero
533 secnd_frfi(nin)%P(3,nn2+j) =zero
534 pene_oldfi(nin)%P(1,nn2+j)=zero
535 stif_oldfi(nin)%P(1,nn2+j)=zero
536 END IF
537 pene_oldfi(nin)%P(2,nn2+j)=zero
538 stif_oldfi(nin)%P(2,nn2+j)=zero
539 ENDDO
540 ELSE
541#include "vectorize.inc"
542 DO j = 1, nn
543 i = iaux(j)
544 irtlm_fi(nin)%P(1,nn2+j) = irem(ishift,i+ideb)
545 irtlm_fi(nin)%P(2,nn2+j) = irem(ishift+1,i+ideb)
546 irtlm_fi(nin)%P(3,nn2+j) = irem(ishift+2,i+ideb)
547 irtlm_fi(nin)%P(4,nn2+j) = irem(ishift+3,i+ideb)
548 icont_i_fi(nin)%P(nn2+j) = irem(ishift+4,i+ideb)
549
550 time_sfi(nin)%P(2*(nn2+j-1)+1) =xrem(rshift,i+ideb)
551 time_sfi(nin)%P(2*(nn2+j-1)+2) =xrem(rshift+1,i+ideb)
552 ioldnsnfi = irem(ishift+5,i+ideb)
553
554 IF(ioldnsnfi /= 0)THEN
555 secnd_frfi(nin)%P(1,nn2+j) =secnd_frfi_old(1,ioldnsnfi+jdeb)
556 secnd_frfi(nin)%P(2,nn2+j) =secnd_frfi_old(2,ioldnsnfi+jdeb)
557 secnd_frfi(nin)%P(3,nn2+j) =secnd_frfi_old(3,ioldnsnfi+jdeb)
558 pene_oldfi(nin)%P(1,nn2+j)=penefi_old(1,ioldnsnfi+jdeb)
559 stif_oldfi(nin)%P(1,nn2+j)=stiffi_old(ioldnsnfi+jdeb)
560 pene_oldfi(nin)%P(5,nn2+j)=penefi_old(2,ioldnsnfi+jdeb)
561 pene_oldfi(nin)%P(3,nn2+j)=penefi_old(3,ioldnsnfi+jdeb)
562 pene_oldfi(nin)%P(4,nn2+j)=penefi_old(4,ioldnsnfi+jdeb)
563 ELSE
564 secnd_frfi(nin)%P(1,nn2+j) =zero
565 secnd_frfi(nin)%P(2,nn2+j) =zero
566 secnd_frfi(nin)%P(3,nn2+j) =zero
567 pene_oldfi(nin)%P(1,nn2+j)=zero
568 stif_oldfi(nin)%P(1,nn2+j)=zero
569 pene_oldfi(nin)%P(5,nn2+j)=zero
570 pene_oldfi(nin)%P(3,nn2+j)=zero
571 pene_oldfi(nin)%P(4,nn2+j)=zero
572 END IF
573 pene_oldfi(nin)%P(2,nn2+j)=zero
574 stif_oldfi(nin)%P(2,nn2+j)=zero
575 ENDDO
576 END IF
577 rshift = rshift + 3
578 ishift = ishift + 6
579 IF (ilev==2) ishift = ishift + 1
580
581 nn2 = nn2 + nn
582 ideb = ideb + oldnsnr
583 nsnfi(nin)%P(p) = nn2-nnp
584 DEALLOCATE(iaux)
585
586 ENDIF !IF(OLDNSNR/=0)
587
588 ENDDO ! end do NSPMD
589 lskyfi = nn2*multimax
590 nsnr = nn2
591 ENDIF
592C-------------------------------------------------------------------------------
593C FLAGREMN REMOVE main SEGMENTS : no reception but reconstruction of the tab REMNOR_FI
594C-------------------------------------------------------------------------------
595 IF(flagremn == 2 ) THEN
596 ki = 0
597 DO n = 1, nodfi
598 DO ne=1,nrtm
599 kk = kremnod(2*(ne-1)+2) + 1
600 ll = kremnod(2*(ne-1)+3)
601 DO km=kk,ll
602 IF(remnod(km) == -itafi(nin)%P(n) ) THEN
603 kremnor_fi(nin)%P(n)=kremnor_fi(nin)%P(n)+1
604 ki = ki+1
605 remnor_fi_tmp(ki) = ne
606 ENDIF
607 ENDDO
608 ENDDO
609 ENDDO
610 DO n=1,nodfi
611 kremnor_fi(nin)%P(n+1) = kremnor_fi(nin)%P(n+1) + kremnor_fi(nin)%P(n)
612 END DO
613 DO n=nodfi,1,-1
614 kremnor_fi(nin)%P(n+1)=kremnor_fi(nin)%P(n)
615 END DO
616 kremnor_fi(nin)%P(1)=0
617
618 sizremnorfi = kremnor_fi(nin)%P(nodfi+1)
619 ALLOCATE(remnor_fi(nin)%P(sizremnorfi),stat=ierror21)
620 IF(sizremnorfi /= 0) THEN
621 IF(ierror21/= 0) THEN
622 CALL ancmsg(msgid=20,anmode=aninfo)
623 CALL arret(2)
624 ENDIF
625#include "vectorize.inc"
626 DO n=1,sizremnorfi
627 remnor_fi(nin)%P(n) =remnor_fi_tmp(n)
628 ENDDO
629 ENDIF
630 DEALLOCATE(remnor_fi_tmp)
631 ENDIF
632
633 IF(ALLOCATED(xrem)) DEALLOCATE(xrem)
634 IF(ALLOCATED(irem)) DEALLOCATE(irem)
635
636 IF(ity==25)THEN
637 DEALLOCATE(secnd_frfi_old,penefi_old,stiffi_old)
638 IF(ivis2==-1) DEALLOCATE(iffi_adh)
639 END IF
640
641C
642 ierror1=0
643 ierror2=0
644 ierror3=0
645 ierror4=0
646 IF(intth == 0 ) THEN
647C
648C Allocation Parith/OFF
649C
650 IF(iparit==0) THEN
651
652 IF(ASSOCIATED(afi(nin)%P)) THEN
653 DEALLOCATE(afi(nin)%P)
654 NULLIFY(afi(nin)%P)
655 ENDIF
656 IF(ASSOCIATED(stnfi(nin)%P)) THEN
657 DEALLOCATE(stnfi(nin)%P)
658 NULLIFY(afi(nin)%P)
659 ENDIF
660
661 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
662 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
663C Init a 0
664 DO i = 1, nodfi*nthread
665 afi(nin)%P(1,i) = zero
666 afi(nin)%P(2,i) = zero
667 afi(nin)%P(3,i) = zero
668 stnfi(nin)%P(i) = zero
669 ENDDO
670C
671 IF(kdtint/=0)THEN
672 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
673 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi*nthread),stat=ierror3)
674C Init a 0
675 DO i = 1, nodfi*nthread
676 vscfi(nin)%P(i) = zero
677 ENDDO
678 ENDIF
679 nlskyfi(nin) = nodfi
680C
681 ELSE
682C
683C Allocation Parith/ON Done in upgrade_rem_slv
684C
685 ENDIF
686 ELSE
687C
688C Allocation Parith/OFF
689C
690 IF(iparit==0) THEN
691 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
692 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
693 IF(ASSOCIATED(fthefi(nin)%P)) DEALLOCATE(fthefi(nin)%P)
694 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
695 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
696 IF(nodfi>0)ALLOCATE(fthefi(nin)%P(nodfi*nthread),stat=ierror3)
697C
698 IF(nodadt_therm ==1) THEN
699 IF(ASSOCIATED(condnfi(nin)%P)) DEALLOCATE(condnfi(nin)%P)
700 IF(nodfi>0.AND.nodadt_therm ==1)ALLOCATE(condnfi(nin)%P(nodfi*nthread),stat=ierror4)
701 ENDIF
702C Init a 0
703 DO i = 1, nodfi*nthread
704 afi(nin)%P(1,i) = zero
705 afi(nin)%P(2,i) = zero
706 afi(nin)%P(3,i) = zero
707 stnfi(nin)%P(i) = zero
708 fthefi(nin)%P(i) = zero
709 ENDDO
710 IF(nodadt_therm ==1) THEN
711 DO i = 1, nodfi
712 condnfi(nin)%P(i) = zero
713 ENDDO
714 ENDIF
715C
716 IF(kdtint/=0)THEN
717 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
718 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi),stat=ierror4)
719C Init a 0
720 DO i = 1, nodfi
721 vscfi(nin)%P(i) = zero
722 ENDDO
723 ENDIF
724C
725 ELSE
726C
727C Allocation Parith/ON
728C
729
730C Done in upgrade_rem_slv
731 ENDIF
732 ENDIF
733C
734 IF(ierror1+ierror2+ierror3+ierror4/=0) THEN
735 CALL ancmsg(msgid=20,anmode=aninfo)
736 CALL arret(2)
737 ENDIF
738C
739C pressure output / friction energy output
740C
741 IF(anim_v(12)+outp_v(12)+h3d_data%N_VECT_PCONT >0)THEN
742 IF(ASSOCIATED(fnconti(nin)%P)) DEALLOCATE(fnconti(nin)%P)
743 IF(ASSOCIATED(ftconti(nin)%P)) DEALLOCATE(ftconti(nin)%P)
744 ALLOCATE(fnconti(nin)%P(3,nodfi),stat=ierror1)
745 ALLOCATE(ftconti(nin)%P(3,nodfi),stat=ierror2)
746 IF(ierror1+ierror2/=0) THEN
747 CALL ancmsg(msgid=20,anmode=aninfo)
748 CALL arret(2)
749 ELSE
750 DO j = 1, nodfi
751 fnconti(nin)%P(1,j)=zero
752 fnconti(nin)%P(2,j)=zero
753 fnconti(nin)%P(3,j)=zero
754 ftconti(nin)%P(1,j)=zero
755 ftconti(nin)%P(2,j)=zero
756 ftconti(nin)%P(3,j)=zero
757 END DO
758 END IF
759 END IF
760
761 IF(h3d_data%N_SCAL_CSE_FRICINT >0)THEN
762 IF(h3d_data%N_CSE_FRIC_INTER (nin) >0)THEN
763 IF(ASSOCIATED(efricfi(nin)%P)) DEALLOCATE(efricfi(nin)%P)
764 ALLOCATE(efricfi(nin)%P(nodfi),stat=ierror1)
765 IF(ierror1/=0) THEN
766 CALL ancmsg(msgid=20,anmode=aninfo)
767 CALL arret(2)
768 ELSE
769 DO j = 1, nodfi
770 efricfi(nin)%P(j)=zero
771 END DO
772 END IF
773 END IF
774 ENDIF
775
776 IF(h3d_data%N_SCAL_CSE_FRIC >0)THEN
777 IF(ASSOCIATED(efricgfi(nin)%P)) DEALLOCATE(efricgfi(nin)%P)
778 ALLOCATE(efricgfi(nin)%P(nodfi),stat=ierror1)
779 IF(ierror1/=0) THEN
780 CALL ancmsg(msgid=20,anmode=aninfo)
781 CALL arret(2)
782 ELSE
783 DO j = 1, nodfi
784 efricgfi(nin)%P(j)=zero
785 END DO
786 END IF
787 END IF
788C
789C Renumbering candidate
790C
791 DO i = 1, i_stok
792 n = cand_n(i)
793 nn = n-nsn
794 IF(nn>0)THEN
795 cand_n(i) = index(nn)+nsn
796 ENDIF
797 ENDDO
798#endif
799 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
h3d_mod
Definition h3d_mod.F:308
message_mod
Definition message_mod.F:1249
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::stif_msdt_fi
type(real_pointer), dimension(:), allocatable stif_msdt_fi
Definition tri7box.F:552
tri7box::condnfi
type(real_pointer), dimension(:), allocatable condnfi
Definition tri7box.F:449
tri7box::iskew_fi
type(int_pointer), dimension(:), allocatable iskew_fi
Definition tri7box.F:550
tri7box::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::vfi
type(real_pointer2), dimension(:), allocatable vfi
Definition tri7box.F:459
tri7box::fnconti
type(real_pointer2), dimension(:), allocatable fnconti
Definition tri7box.F:510
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
tri7box::matsfi
type(int_pointer), dimension(:), allocatable matsfi
Definition tri7box.F:440
tri7box::current_fi_size
integer, dimension(:), allocatable current_fi_size
Definition tri7box.F:426
tri7box::efricgfi
type(real_pointer), dimension(:), allocatable efricgfi
Definition tri7box.F:511
tri7box::tempfi
type(real_pointer), dimension(:), allocatable tempfi
Definition tri7box.F:449
tri7box::stifi
type(real_pointer), dimension(:), allocatable stifi
Definition tri7box.F:449
tri7box::kremnor_fi
type(int_pointer), dimension(:), allocatable kremnor_fi
Definition tri7box.F:549
tri7box::gap_lfi
type(real_pointer), dimension(:), allocatable gap_lfi
Definition tri7box.F:449
tri7box::stnfi
type(real_pointer), dimension(:), allocatable stnfi
Definition tri7box.F:449
tri7box::afi
type(real_pointer2), dimension(:), allocatable afi
Definition tri7box.F:459
tri7box::nodamsfi
type(int_pointer), dimension(:), allocatable nodamsfi
Definition tri7box.F:440
tri7box::remnor_fi
type(int_pointer), dimension(:), allocatable remnor_fi
Definition tri7box.F:548
tri7box::pmainfi
type(int_pointer), dimension(:), allocatable pmainfi
Definition tri7box.F:435
tri7box::gapfi
type(real_pointer), dimension(:), allocatable gapfi
Definition tri7box.F:449
tri7box::nodnxfi
type(int_pointer), dimension(:), allocatable nodnxfi
Definition tri7box.F:440
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::intareanfi
type(real_pointer), dimension(:), allocatable intareanfi
Definition tri7box.F:554
tri7box::areasfi
type(real_pointer), dimension(:), allocatable areasfi
Definition tri7box.F:449
tri7box::icodt_fi
type(int_pointer), dimension(:), allocatable icodt_fi
Definition tri7box.F:551
tri7box::efricfi
type(real_pointer), dimension(:), allocatable efricfi
Definition tri7box.F:511
tri7box::msfi
type(real_pointer), dimension(:), allocatable msfi
Definition tri7box.F:449
tri7box::current_nodfi
integer, dimension(:), allocatable current_nodfi
Definition tri7box.F:425
tri7box::vscfi
type(real_pointer), dimension(:), allocatable vscfi
Definition tri7box.F:449
tri7box::ipartfricsfi
type(int_pointer), dimension(:), allocatable ipartfricsfi
Definition tri7box.F:440
tri7box::xfi
type(real_pointer2), dimension(:), allocatable xfi
Definition tri7box.F:459
tri7box::kinfi
type(int_pointer), dimension(:), allocatable kinfi
Definition tri7box.F:440
tri7box::nlskyfi
integer, dimension(:), allocatable nlskyfi
Definition tri7box.F:512
tri7box::fthefi
type(real_pointer), dimension(:), allocatable fthefi
Definition tri7box.F:449
tri7box::ftconti
type(real_pointer2), dimension(:), allocatable ftconti
Definition tri7box.F:510
tri7box::procamsfi
type(int_pointer), dimension(:), allocatable procamsfi
Definition tri7box.F:440
tri7box::islide_fi
type(int_pointer2), dimension(:), allocatable islide_fi
Definition tri7box.F:547
tri7box::pene_oldfi
type(real_pointer2), dimension(:), allocatable pene_oldfi
Definition tri7box.F:544
tri7box::icont_i_fi
type(int_pointer), dimension(:), allocatable icont_i_fi
Definition tri7box.F:532
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
tri7box::if_adhfi
type(int_pointer), dimension(:), allocatable if_adhfi
Definition tri7box.F:440
tri7box::irem
integer, dimension(:,:), allocatable irem
Definition tri7box.F:339
tri7box::itafi
type(int_pointer), dimension(:), allocatable itafi
Definition tri7box.F:440
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