OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
w_fi.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!|| w_fi ../starter/source/restart/ddsplit/w_fi.F
25!||--- called by ------------------------------------------------------
26!|| ddsplit ../starter/source/restart/ddsplit/ddsplit.F
27!||--- calls -----------------------------------------------------
28!|| nlocal ../starter/source/spmd/node/ddtools.F
29!|| plist_ifront ../starter/source/spmd/node/ddtools.f
30!||--- uses -----------------------------------------------------
31!|| front_mod ../starter/share/modules1/front_mod.F
32!|| i25_fie_mod ../starter/share/modules1/i25_fie_mod.F
33!|| i7i10splitmod ../starter/share/modules1/i710split_mod.F
34!||====================================================================
35 SUBROUTINE w_fi(IPARI,PROC,LEN_IA,
36 1 INTERCEP ,INTBUF_TAB,ITAB,MULTI_FVM,TAG,
37 2 NINDX_TAG,INDX_TAG ,NODLOCAL,NUMNOD_L,LEN_CEP,CEP)
38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE my_alloc_mod
42 USE i7i10splitmod
43 USE front_mod
44 USE intbufdef_mod
45 USE multi_fvm_mod
46 USE i25_fie_mod
47C-----------------------------------------------
48C I m p l i c i t T y p e s
49C-----------------------------------------------
50#include "implicit_f.inc"
51#include "assert.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "com04_c.inc"
57#include "param_c.inc"
58C-----------------------------------------------
59 TYPE intermasurfep
60 INTEGER, DIMENSION(:), POINTER :: P
61 END TYPE intermasurfep
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 INTEGER PROC, IPARI(NPARI,*), LEN_IA, ITAB(*)
66 INTEGER :: NINDX_TAG,NUMNOD_L
67 INTEGER, DIMENSION(*), INTENT(IN) :: NODLOCAL
68 INTEGER, DIMENSION(*), INTENT(INOUT) :: TAG,INDX_TAG
69! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
70! NINDX_TAG : integer,
71! number of non-zero value of TAG
72! TAG : integer, dimension=NUMNOD + I24MAXNSNE + SIZE_FVM
73! | |
74! max NSNE for TYP24 ____| |
75! SIZE_FVM=NUMELS for INACTI=7 and FVM, otherwise 0 ___|
76! tagged array, TAG is TAG_SCRATCH array, allocated in lectur.F
77! INDX_TAG : integer, dimension = dimension(TAG)
78! index array, used to flush TAG to 0
79! NODLOCAL : integer, dimension=NUMNOD
80! gives the local ID of a global element
81! --> used here to avoid NLOCAL call (the NLOCAL perf is bad)
82! NODLOCAL /= 0 if the element is on the current domain/processor
83! and =0 if the element is not on the current domain
84! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
85C-----------------------------------------------
86 TYPE(intersurfp),INTENT(IN) :: INTERCEP(3,NINTER)
87 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
88 TYPE(multi_fvm_struct), INTENT(IN) :: MULTI_FVM
89 INTEGER, INTENT(in) :: LEN_CEP !< size of cep
90 INTEGER, DIMENSION(LEN_CEP), INTENT(in) :: CEP !< element -> proc connectivity array
91C-----------------------------------------------
92C F u n c t i o n
93C-----------------------------------------------
94 INTEGER NLOCAL
95 EXTERNAL NLOCAL
96C-----------------------------------------------
97C L o c a l V a r i a b l e s
98C-----------------------------------------------
99 INTEGER NI, P, K, L, ITYP, INACTI, NSN, NMN, NRTS, NRTM,
100 . N, N1, N2, N3, N4, NRTM_L,
101 . i_stok, nodfi, e, multimp, ideb, ifq,
102 . nisub, nisubs, nisubm, intth, nl, n1l, n2l, n3l, n4l,
103 . nlins, nlinm, nsne, nmne, nln, nn,intfric,
104 . work(70000),kd(50),jd(50),i,j,iedge4,intnitsche,my_node,
105 . cpt1,cpt2,p1,p2,proc1,proc2,se1,ploc,nd,flagremn,lremnormax
106 INTEGER IT,ID
107 INTEGER, DIMENSION(:),ALLOCATABLE :: NSNFI
108 INTEGER, DIMENSION(:),ALLOCATABLE :: NUMP
109 INTEGER, DIMENSION(:),ALLOCATABLE :: NMNFI
110 INTEGER :: IEDGE,NEDGE,NEDGE_KEPT,ILEV
111 INTEGER, PARAMETER :: E_IBUF_SIZE = 13
112 LOGICAL INACTI_CASE
113
114 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGE, NSNLOCAL, NSNP, NSVFI,
115 . NRTSLOCAL, NRTSP, INDEX, PFI,
116 . itafi, itafi2
117 INTEGER, DIMENSION(:,:),ALLOCATABLE :: CLEF,IRTLMFI2,IRTLMFI
118
119 INTEGER, DIMENSION(:),ALLOCATABLE :: PLIST
120 INTEGER, DIMENSION(:),ALLOCATABLE :: TAB1,TAB2
121 INTEGER SPLIST
122 INTEGER, DIMENSION(:),ALLOCATABLE :: TABZERO
123 INTEGER, DIMENSION(:), ALLOCATABLE :: LEDGE_FIE
124 INTEGER :: INTER_LAW151
125 LOGICAL :: INTER18_LAW151
126C-----------------------------------------------
127 CALL my_alloc(nsnfi,nspmd)
128 CALL my_alloc(nump,nspmd)
129 CALL my_alloc(nmnfi,nspmd)
130C
131
132 DO ni =1, ninter
133 nindx_tag = 0
134 ityp = ipari(7,ni)
135 inacti = ipari(22,ni)
136 inter_law151 = ipari(14,ni)
137 inter18_law151 = .false.
138
139 IF(ityp==7.AND.inacti==7.AND.inter_law151==151) inter18_law151 = .true.
140C
141 IF(ityp==7.OR.ityp==10.OR.ityp==11.OR.
142 . (ityp==17.AND.ipari(33,ni)==0).OR.ityp==20.OR.
143 . ityp==22.OR.ityp==23.OR.ityp==24.OR.ityp==25)THEN
144C ecriture nsnsi : 0
145 DO p = 1, nspmd
146 nsnfi(p) = 0
147 END DO
148 CALL write_i_c(nsnfi,nspmd) ! NSNSI at engine
149 len_ia = len_ia + nspmd
150 IF(((inacti/=5.AND.inacti/=6.AND.inacti/=7).OR.
151 . ityp==10).AND.ityp/=23.AND.inacti/=-1) THEN
152C ecriture nsnfi : 0 si inacti # 5, 6 et 7
153 CALL write_i_c(nsnfi,nspmd) ! nsnfi at engine
154 len_ia = len_ia + nspmd
155 ELSE
156 nrts = ipari(3,ni)
157 nrtm = ipari(4,ni)
158 nsn = ipari(5,ni)
159 nmn = ipari(6,ni)
160 multimp= ipari(23,ni)
161 intth = ipari(47,ni)
162 intfric = ipari(72,ni)
163 flagremn =ipari(63,ni)
164 lremnormax =ipari(82,ni)
165 intnitsche = ipari(86,ni)
166
167 nsne = 0
168 iedge4 = 0
169! +++++++++++++++++++++++++++++++++++++++++++++++
170 IF(ityp==7.OR.ityp==22.OR.ityp==23.OR.ityp==24.OR.
171 . ityp==25)THEN
172
173 IF(ityp==24) THEN
174 nsne = ipari(55,ni)
175 iedge4 = ipari(59,ni)
176 ENDIF
177 i_stok = intbuf_tab(ni)%I_STOK(1)
178! IF (multi_fvm%IS_USED .AND. inacti == 7) THEN
179!C Interface type 18 for law151
180! ALLOCATE(TAG(NUMNOD+NSNE+NUMELS))
181! TAG(1:NUMNOD+NSNE+NUMELS) = 0
182! ELSE
183! ALLOCATE(TAG(NUMNOD+NSNE))
184! TAG(1:NUMNOD+NSNE) = 0
185! ENDIF
186 ALLOCATE(nsnlocal(nsn))
187 ALLOCATE(nsnp(nsn))
188 ALLOCATE(nsvfi(nsn))
189 ALLOCATE(pfi(nsn))
190 ALLOCATE(itafi(nsn))
191 ALLOCATE(tage(nrtm))
192 IF (ityp==24) ALLOCATE(irtlmfi(2,nsn))
193 IF (ityp==25) THEN
194 ALLOCATE(irtlmfi(4,nsn))
195 irtlmfi(1:4,1:nsn)=0
196 END IF
197 DO p = 1, nspmd
198 nump(p) = 0
199 END DO
200C
201C
202C
203! optimize loop with PLIST tool
204 ALLOCATE(plist(nspmd))
205 plist(1:nspmd) = -1
206 DO k=1,nsn
207 n = intbuf_tab(ni)%NSV(k)
208 nsnlocal(k) = 0
209 IF(tag(n)==0) THEN
210 splist=0
211 ploc = 0
212 IF(inter18_law151) THEN
213 IF(cep(n)==proc) ploc = 1
214 splist = 1
215 plist(1) = cep(n) + 1
216 ELSE
217 IF(n<=numnod) THEN
218 CALL plist_ifront(plist,n,splist)
219 ploc = 0
220 IF(nodlocal(n)/=0.AND.nodlocal(n)<=numnod_l) ploc = 1
221 ELSE
222C T24 E2E Fictive nodes are only on 1 domain (But they are not nodes
223 ploc = 0
224 se1 = intbuf_tab(ni)%IS2SE(2*(n-numnod-1)+1)
225 plist(1)=intercep(2,ni)%P(se1)
226 splist=1
227 IF(plist(1)==proc+1)ploc=1
228 ENDIF
229 ENDIF
230 DO i=1,splist
231 p=plist(i)
232 nump(p) = nump(p)+1
233 ENDDO
234
235 IF(ploc==1) THEN
236 nsnlocal(k) = nump(proc+1)
237 nsnp(k) = proc+1
238 ELSE
239 p = plist(1)
240 nsnlocal(k) = nump(p)
241 nsnp(k) = p
242 ENDIF
243 tag(n) = 1
244 nindx_tag = nindx_tag + 1
245 indx_tag(nindx_tag) = n
246 ENDIF
247 ENDDO
248
249 DEALLOCATE(plist)
250
251 nrtm_l = 0
252 DO k=1,nrtm
253C TAGE flag servant pour inacti
254 tage(k) = 0
255 IF(intercep(1,ni)%P(k)==proc+1)THEN
256 nrtm_l = nrtm_l + 1
257 tage(k) = nrtm_l
258 ENDIF
259 ENDDO
260C
261 nodfi = 0
262 DO p = 1, nspmd
263 nsnfi(p) = 0
264 END DO
265C
266 DO k = 1, i_stok
267 e = intbuf_tab(ni)%CAND_E(k)
268 IF (tage(e)/=0) THEN
269 n = intbuf_tab(ni)%CAND_N(k)
270C Add boolean in order to treat INACTI=5 Candidates
271 inacti_case = .false.
272 nd = intbuf_tab(ni)%NSV(n)
273 IF (nd <= numnod)THEN
274 my_node = intbuf_tab(ni)%NSV(n)
275 IF(nodlocal( my_node )==0.OR.nodlocal( my_node )>numnod_l ) inacti_case=.true.
276 ELSE
277 se1 = intbuf_tab(ni)%IS2SE(2*(nd-numnod-1)+1)
278 IF (intercep(2,ni)%P(se1)/=(proc+1) ) inacti_case=.true.
279 ENDIF
280c IF (INTBUF_TAB(NI)%NSV(N) > NUMNOD) CYCLE
281
282 IF(inacti_case .EQV. .true.) THEN
283C ne traiter qu une seule fois les noeuds
284 IF(nsnp(n)>0) THEN
285 p = nsnp(n)
286 nsnp(n) = -p
287 nsnfi(p) = nsnfi(p) + 1
288 nodfi = nodfi + 1
289 nsvfi(nodfi) = nsnlocal(n)
290 nd = intbuf_tab(ni)%NSV(n)
291 IF(nd<=numnod)THEN
292 itafi(nodfi) = itab(nd)
293 ELSE
294 itafi(nodfi) = intbuf_tab(ni)%IS2ID(nd-numnod)
295 ENDIF
296 IF(ityp==24)THEN
297 irtlmfi(1,nodfi)=intbuf_tab(ni)%IRTLM(2*(n-1)+1)
298 irtlmfi(2,nodfi)=intbuf_tab(ni)%IRTLM(2*(n-1)+2)
299 ENDIF
300 IF(ityp==25)THEN
301 irtlmfi(1,nodfi)=intbuf_tab(ni)%IRTLM(4*(n-1)+1)
302 irtlmfi(2,nodfi)=intbuf_tab(ni)%IRTLM(4*(n-1)+2)
303 irtlmfi(3,nodfi)=intbuf_tab(ni)%IRTLM(4*(n-1)+3)
304 irtlmfi(4,nodfi)=intbuf_tab(ni)%IRTLM(4*(n-1)+4)
305 ENDIF
306 pfi(nodfi) = p
307 END IF
308 END IF
309 END IF
310 END DO
311C
312
313 IF(nodfi>0) THEN
314 ALLOCATE(index(2*nodfi))
315 ALLOCATE(clef(2,nodfi))
316 IF(ityp==24)ALLOCATE(irtlmfi2(2,nodfi))
317 IF(ityp==25)ALLOCATE(irtlmfi2(4,nodfi))
318 ALLOCATE(itafi2(nodfi))
319 DO k = 1, nodfi
320 clef(1,k)=pfi(k)
321 clef(2,k)=nsvfi(k)
322 itafi2(k) = itafi(k)
323 IF(ityp==24)THEN
324 irtlmfi2(1,k)= irtlmfi(1,k)
325 irtlmfi2(2,k)= irtlmfi(2,k)
326 ENDIF
327 IF(ityp==25)THEN
328 irtlmfi2(1,k)= irtlmfi(1,k)
329 irtlmfi2(2,k)= irtlmfi(2,k)
330 irtlmfi2(3,k)= irtlmfi(3,k)
331 irtlmfi2(4,k)= irtlmfi(4,k)
332 ENDIF
333 END DO
334 CALL my_orders(0,work,clef,index,nodfi,2)
335 DO k = 1, nodfi
336 nsvfi(k) = clef(2,index(k))
337 itafi(k) = itafi2(index(k))
338 pfi(k) = clef(1,index(k))
339 IF(ityp==24)THEN
340 irtlmfi(1,k)=irtlmfi2(1,index(k))
341 irtlmfi(2,k)=irtlmfi2(2,index(k))
342 ENDIF
343 IF(ityp==25)THEN
344 irtlmfi(1,k)=irtlmfi2(1,index(k))
345 irtlmfi(2,k)=irtlmfi2(2,index(k))
346 irtlmfi(3,k)=irtlmfi2(3,index(k))
347 irtlmfi(4,k)=irtlmfi2(4,index(k))
348 ENDIF
349 END DO
350 DEALLOCATE(index)
351 DEALLOCATE(clef)
352 DEALLOCATE(itafi2)
353 IF(ityp==24.OR.ityp==25) DEALLOCATE(irtlmfi2)
354 END IF
355 DEALLOCATE(pfi)
356C
357 CALL write_i_c(nsnfi,nspmd) ! NSNFI
358 len_ia = len_ia + nspmd
359 CALL write_i_c(nsvfi,nodfi) !NSVFI
360 len_ia = len_ia + nodfi
361
362 CALL write_i_c(itafi,nodfi) !ITAFI
363 len_ia = len_ia + nodfi
364C ecriture bidon kinfi
365 CALL write_i_c(nsvfi,nodfi)
366 len_ia = len_ia + nodfi
367C Void writing for MATSFI
368 IF (intth>0) THEN
369 CALL write_i_c(nsvfi,nodfi)
370 len_ia = len_ia + nodfi
371 ENDIF
372C Void writing for IPARTFRICSFI
373 IF (intfric>0) THEN
374 CALL write_i_c(nsvfi,nodfi)
375 len_ia = len_ia + nodfi
376 ENDIF
377 IF(ityp==24)THEN
378C write dummy irtlm_fi = 2xnodfi
379 CALL write_i_c(irtlmfi,nodfi*2)
380 len_ia = len_ia + nodfi*2
381C Write dummy ICONT_I_FI
382 CALL write_i_c(nsvfi,nodfi)
383 len_ia = len_ia + nodfi
384C Write Dummy ISEDGE_FI
385 CALL write_i_c(nsvfi,nodfi)
386 len_ia = len_ia + nodfi
387 IF(iedge4>0)THEN
388C Write dummy IRTSE_FI : 5*NODFI
389 CALL write_i_c(nsvfi,nodfi)
390 CALL write_i_c(nsvfi,nodfi)
391 CALL write_i_c(nsvfi,nodfi)
392 CALL write_i_c(nsvfi,nodfi)
393 CALL write_i_c(nsvfi,nodfi)
394 len_ia = len_ia + 5*nodfi
395
396C Write dummy IS2PT_FI
397 CALL write_i_c(nsvfi,nodfi)
398 len_ia = len_ia + nodfi
399C Write dummy ISPT2_FI - to be modified in case INACT - ISPT2 must also be initialized
400 CALL write_i_c(nsvfi,nodfi)
401 len_ia = len_ia + nodfi
402C Write dummy ISEGPT_FI
403 CALL write_i_c(nsvfi,nodfi)
404 len_ia = len_ia + nodfi
405C Write dummy IS2SE_FI : 2*NODFI
406 CALL write_i_c(nsvfi,nodfi)
407 CALL write_i_c(nsvfi,nodfi)
408 len_ia = len_ia + 2* nodfi
409
410 ENDIF
411 IF(intnitsche>0) CALL write_i_c(nsvfi,3*nodfi)
412 ENDIF
413
414 IF(ityp==25)THEN
415C write dummy PMAINFI
416 CALL write_i_c(nsvfi,nodfi)
417 len_ia = len_ia + nodfi
418C write dummy irtlm_fi = 4xnodfi
419 CALL write_i_c(irtlmfi,nodfi*4)
420 len_ia = len_ia + nodfi*4
421C Write dummy ICONT_I_FI
422 CALL write_i_c(nsvfi,nodfi)
423 len_ia = len_ia + nodfi
424C Write dummy KREMNORF REMNORFI
425 IF(flagremn == 2.AND.nodfi>0) THEN
426 ALLOCATE(tabzero(nodfi+1))
427 tabzero(1:nodfi+1) = 0
428 CALL write_i_c(tabzero,nodfi+1)
429 len_ia = len_ia + nodfi + 1
430 DEALLOCATE(tabzero)
431 ENDIF
432
433 ENDIF
434C
435! DEALLOCATE(TAG)
436 DEALLOCATE(nsnlocal)
437 DEALLOCATE(nsnp)
438 DEALLOCATE(nsvfi)
439 DEALLOCATE(itafi)
440 DEALLOCATE(tage)
441 IF (ityp==24.OR.ityp==25)DEALLOCATE(irtlmfi)
442C fin type 7
443! +++++++++++++++++++++++++++++++++++++++++++++++
444 ELSEIF(ityp==11)THEN
445
446 i_stok = intbuf_tab(ni)%I_STOK(1)
447 ALLOCATE(nrtslocal(nrts))
448 ALLOCATE(nrtsp(nrts))
449 ALLOCATE(nsvfi(nrts))
450 ALLOCATE(pfi(nrts))
451 ALLOCATE(tage(nrtm))
452 DO p = 1, nspmd
453 nump(p) = 0
454 END DO
455!
456 ALLOCATE(tab1(nspmd),tab2(nspmd))
457 DO k=1,nrts
458 n1 = intbuf_tab(ni)%IRECTS(2*(k-1)+1)
459 n2 = intbuf_tab(ni)%IRECTS(2*(k-1)+2)
460
461 CALL plist_ifront(tab1,n1,cpt1)
462 CALL plist_ifront(tab2,n2,cpt2)
463
464 nrtslocal(k) = 0
465 IF(cpt1>0.AND.cpt2>0) THEN
466 DO p1 = 1,cpt1
467 proc1 = tab1(p1)
468 DO p2 = 1,cpt2
469 proc2 = tab1(p2)
470 IF((proc1==proc+1).AND.(proc2==proc+1)) THEN
471 nump(proc+1) = nump(proc+1) + 1
472 nrtslocal(k) = nump(proc+1)
473 nrtsp(k) = proc+1
474 ELSEIF((proc1==proc2).AND.(nrtslocal(k)==0)) THEN
475 nump(proc1) = nump(proc1) + 1
476 nrtslocal(k) = nump(proc1)
477 nrtsp(k) = proc1
478 ENDIF
479 ENDDO
480 ENDDO
481 ENDIF
482C
483 END DO
484 DEALLOCATE(tab1,tab2)
485C
486 nrtm_l = 0
487 DO k=1,nrtm
488 tage(k) = 0
489 IF(intercep(1,ni)%P(k)==proc+1)THEN
490 nrtm_l = nrtm_l + 1
491 tage(k) = nrtm_l
492 ENDIF
493 ENDDO
494C
495 nodfi = 0
496 DO p = 1, nspmd
497 nsnfi(p) = 0
498 END DO
499C
500 DO k = 1, i_stok
501 e = intbuf_tab(ni)%CAND_E(k)
502 IF (tage(e)/=0) THEN
503 l = intbuf_tab(ni)%CAND_N(k)
504 n1 = intbuf_tab(ni)%IRECTS((l-1)*2+1)
505 n2 = intbuf_tab(ni)%IRECTS((l-1)*2+2)
506 IF((nodlocal( n1 )==0.OR.nodlocal( n1 )>numnod_l).AND.
507 + (nodlocal( n2 )==0.OR.nodlocal( n2 )>numnod_l) ) THEN
508 IF(nrtsp(l)>0)THEN
509 p = nrtsp(l)
510 nrtsp(l) = -p
511 nsnfi(p) = nsnfi(p) + 1
512 nodfi = nodfi + 1
513 nsvfi(nodfi) = nrtslocal(l)
514 pfi(nodfi) = p
515 END IF
516 END IF
517 END IF
518 END DO
519C
520 IF(nodfi>0) THEN
521 ALLOCATE(index(2*nodfi))
522 ALLOCATE(clef(2,nodfi))
523 DO k = 1, nodfi
524 clef(1,k)=pfi(k)
525 clef(2,k)=nsvfi(k)
526 END DO
527 CALL my_orders(0,work,clef,index,nodfi,2)
528 DO k = 1, nodfi
529 nsvfi(k) = clef(2,index(k))
530 pfi(k) = clef(1,index(k))
531 END DO
532 DEALLOCATE(index)
533 DEALLOCATE(clef)
534 END IF
535 DEALLOCATE(pfi)
536C
537 CALL write_i_c(nsnfi,nspmd)
538 CALL write_i_c(nsvfi,nodfi)
539C ecriture bidon itafi n1
540 CALL write_i_c(nsvfi,nodfi)
541C ecriture bidon itafi n2
542 CALL write_i_c(nsvfi,nodfi)
543C Void writing for MATSFI
544 IF (intth>0) THEN
545 CALL write_i_c(nsvfi,nodfi)
546 len_ia = len_ia + nodfi
547 ENDIF
548C Void writing for IPARTSFI
549 IF (intfric>0) THEN
550 CALL write_i_c(nsvfi,nodfi)
551 len_ia = len_ia + nodfi
552 ENDIF
553C
554 DEALLOCATE(nrtslocal)
555 DEALLOCATE(nrtsp)
556 DEALLOCATE(nsvfi)
557 DEALLOCATE(tage)
558C fin type 11
559 ELSEIF(ityp==20)THEN
560C type 20 (partie non edge)
561 ifq = ipari(31,ni)
562 nln = ipari(35,ni)
563 nisub = ipari(36,ni)
564 nisubs = ipari(37,ni)
565 nisubm = ipari(38,ni)
566 intth = ipari(47,ni)
567C
568 i_stok = intbuf_tab(ni)%I_STOK(1)
569 ALLOCATE(nsnlocal(nsn))
570 ALLOCATE(nsnp(nsn))
571 ALLOCATE(nsvfi(nsn))
572 ALLOCATE(pfi(nsn))
573 ALLOCATE(tage(nrtm))
574
575 DO p = 1, nspmd
576 nump(p) = 0
577 END DO
578C
579 DO k=1,nsn
580 nl= intbuf_tab(ni)%NSV(k)
581 n = intbuf_tab(ni)%NLG(nl)
582C
583 nsnlocal(k) = 0
584 IF(tag(n)==0) THEN
585 IF(nodlocal( n )/=0.AND.nodlocal( n )<=numnod_l) THEN
586 nump(proc+1) = nump(proc+1) + 1
587 nsnlocal(k) = nump(proc+1)
588 nsnp(k) = proc+1
589 ENDIF
590C
591 DO p = 1, nspmd
592 IF(p/=proc+1.AND.nlocal(n,p)==1) THEN
593 nump(p) = nump(p) + 1
594 IF(nsnlocal(k)==0) THEN
595 nsnlocal(k) = nump(p)
596 nsnp(k) = p
597 END IF
598 END IF
599 END DO
600
601 tag(n) = 1
602 nindx_tag = nindx_tag + 1
603 indx_tag(nindx_tag) = n
604 END IF
605 END DO
606C
607 nrtm_l = 0
608 DO k=1,nrtm
609 tage(k) = 0
610 IF(intercep(1,ni)%P(k)==proc+1) THEN
611 nrtm_l = nrtm_l + 1
612 tage(k) = nrtm_l
613 ENDIF
614 ENDDO
615C
616 nodfi = 0
617 DO p = 1, nspmd
618 nsnfi(p) = 0
619 END DO
620C
621 DO k = 1, i_stok
622 e = intbuf_tab(ni)%CAND_E(k)
623 IF (tage(e)/=0) THEN
624 n = intbuf_tab(ni)%CAND_N(k)
625 nl = intbuf_tab(ni)%NSV(n)
626 nn = intbuf_tab(ni)%NLG(nl)
627 IF(nodlocal( nn )==0.OR.nodlocal( nn )>numnod_l) THEN
628C ne traiter qu une seule fois les noeuds
629 IF(nsnp(n)>0) THEN
630 p = nsnp(n)
631 nsnp(n) = -p
632 nsnfi(p) = nsnfi(p) + 1
633 nodfi = nodfi + 1
634 nsvfi(nodfi) = nsnlocal(n)
635 pfi(nodfi) = p
636 END IF
637 END IF
638 END IF
639 END DO
640C
641 IF(nodfi>0) THEN
642 ALLOCATE(index(2*nodfi))
643 ALLOCATE(clef(2,nodfi))
644 DO k = 1, nodfi
645 clef(1,k)=pfi(k)
646 clef(2,k)=nsvfi(k)
647 END DO
648 CALL my_orders(0,work,clef,index,nodfi,2)
649 DO k = 1, nodfi
650 nsvfi(k) = clef(2,index(k))
651 pfi(k) = clef(1,index(k))
652 END DO
653 DEALLOCATE(index)
654 DEALLOCATE(clef)
655 END IF
656 DEALLOCATE(pfi)
657C
658 CALL write_i_c(nsnfi,nspmd)
659 len_ia = len_ia + nspmd
660 CALL write_i_c(nsvfi,nodfi)
661 len_ia = len_ia + nodfi
662C ecriture bidon itafi
663 CALL write_i_c(nsvfi,nodfi)
664 len_ia = len_ia + nodfi
665C ecriture bidon kinfi
666 CALL write_i_c(nsvfi,nodfi)
667 len_ia = len_ia + nodfi
668C ecriture bidon nbinflfi
669 CALL write_i_c(nsvfi,nodfi)
670 len_ia = len_ia + nodfi
671C Void writing for MATSFI
672 IF (intth>0) THEN
673 CALL write_i_c(nsvfi,nodfi)
674 len_ia = len_ia + nodfi
675 ENDIF
676C
677 DEALLOCATE(nsnlocal)
678 DEALLOCATE(nsnp)
679 DEALLOCATE(nsvfi)
680 DEALLOCATE(tage)
681 END IF ! fin type20
682C fin interface de contact inacti
683 END IF
684C Type20 ajout pour edge
685 IF (ityp==20)THEN
686C ecriture nsnsie : 0
687 DO p = 1, nspmd
688 nsnfi(p) = 0
689 END DO
690 CALL write_i_c(nsnfi,nspmd)
691 inacti = ipari(22,ni)
692 IF(inacti/=5.AND.inacti/=6.AND.inacti/=7) THEN
693C ecriture nsnfie : 0 si inacti # 5, 6 et 7
694 CALL write_i_c(nsnfi,nspmd)
695 ELSE
696 nrts = ipari(3,ni)
697 nrtm = ipari(4,ni)
698 nsn = ipari(5,ni)
699 nmn = ipari(6,ni)
700 multimp= ipari(23,ni)
701 ifq = ipari(31,ni)
702 nln = ipari(35,ni)
703 nisub = ipari(36,ni)
704 nisubs = ipari(37,ni)
705 nisubm = ipari(38,ni)
706C
707 intth = ipari(47,ni)
708C
709 nlins = ipari(51,ni)
710 nlinm = ipari(52,ni)
711 nsne = ipari(55,ni)
712 nmne = ipari(56,ni)
713C
714 i_stok = intbuf_tab(ni)%I_STOK_E(1)
715 ALLOCATE(nrtslocal(nlins))
716 ALLOCATE(nrtsp(nlins))
717 ALLOCATE(nsvfi(nlins))
718 ALLOCATE(pfi(nlins))
719 ALLOCATE(tage(nlinm))
720 DO p = 1, nspmd
721 nump(p) = 0
722 END DO
723 DO k=1,nlins
724 n1l = intbuf_tab(ni)%IXLINS(2*(k-1)+1)
725 n2l = intbuf_tab(ni)%IXLINS(2*(k-1)+2)
726 n1 = intbuf_tab(ni)%NLG(n1l)
727 n2 = intbuf_tab(ni)%NLG(n2l)
728C
729 nrtslocal(k) = 0
730 IF( (nodlocal( n1 )/=0.AND.nodlocal( n1 )<=numnod_l).AND.
731 + (nodlocal( n2 )/=0.AND.nodlocal( n2 )<=numnod_l) ) THEN
732 nump(proc+1) = nump(proc+1) + 1
733 nrtslocal(k) = nump(proc+1)
734 nrtsp(k) = proc+1
735 END IF
736C
737 DO p = 1, nspmd
738 IF(p/=proc+1.AND.nlocal(n1,p)==1.AND.
739 . nlocal(n2,p)==1) THEN
740 IF(nrtslocal(k)==0) THEN
741 nump(p) = nump(p) + 1
742 nrtslocal(k) = nump(p)
743 nrtsp(k) = p
744 GOTO 2400
745 END IF
746 END IF
747 END DO
748 2400 CONTINUE
749 END DO
750C
751 nrtm_l = 0
752 DO k=1,nlinm
753 tage(k) = 0
754 IF(intercep(2,ni)%P(k)==proc+1) THEN
755 nrtm_l = nrtm_l + 1
756 tage(k) = nrtm_l
757 END IF
758 END DO
759C
760 nodfi = 0
761 DO p = 1, nspmd
762 nsnfi(p) = 0
763 END DO
764C
765 DO k = 1, i_stok
766 e = intbuf_tab(ni)%LCAND_S(k)
767 IF (tage(e)/=0) THEN
768 l = intbuf_tab(ni)%IXLINS(k)
769 n1l = intbuf_tab(ni)%IXLINS((l-1)*2+1)
770 n2l = intbuf_tab(ni)%IXLINS((l-1)*2+2)
771 n1 = intbuf_tab(ni)%NLG(n1l)
772 n2 = intbuf_tab(ni)%NLG(n2l)
773 IF( (nodlocal( n1 )==0.OR.nodlocal( n1 )>numnod_l).AND.
774 + (nodlocal( n2 )==0.OR.nodlocal( n2 )>numnod_l) ) THEN
775 IF(nrtsp(l)>0)THEN
776 p = nrtsp(l)
777 nrtsp(l) = -p
778 nsnfi(p) = nsnfi(p) + 1
779 nodfi = nodfi + 1
780 nsvfi(nodfi) = nrtslocal(l)
781 pfi(nodfi) = p
782 END IF
783 END IF
784 END IF
785 END DO
786C
787 IF(nodfi>0) THEN
788 ALLOCATE(index(2*nodfi))
789 ALLOCATE(clef(2,nodfi))
790 DO k = 1, nodfi
791 clef(1,k)=pfi(k)
792 clef(2,k)=nsvfi(k)
793 END DO
794 CALL my_orders(0,work,clef,index,nodfi,2)
795 DO k = 1, nodfi
796 nsvfi(k) = clef(2,index(k))
797 pfi(k) = clef(1,index(k))
798 END DO
799 DEALLOCATE(index)
800 DEALLOCATE(clef)
801 END IF
802 DEALLOCATE(pfi)
803C
804 CALL write_i_c(nsnfi,nspmd)
805 CALL write_i_c(nsvfi,nodfi)
806C ecriture bidon itafi n1
807 CALL write_i_c(nsvfi,nodfi)
808C ecriture bidon itafi n2
809 CALL write_i_c(nsvfi,nodfi)
810C
811 DEALLOCATE(nrtslocal)
812 DEALLOCATE(nrtsp)
813 DEALLOCATE(nsvfi)
814 DEALLOCATE(tage)
815 END IF ! fin inacti
816 END IF ! Type 20 edge
817
818 iedge = ipari(58,ni)
819 ilev = ipari(20,ni)
820
821 IF( ityp == 25 .AND. iedge /= 0) THEN
822 nedge = ipari(68,ni)
823 nrtm = ipari(4,ni)
824 nsnfi(1:nspmd) = 0
825 CALL write_i_c(nsnfi,nspmd) ! NSNSIE = 0
826 CALL write_i_c(i25_fie(ni,proc+1)%NEDGE(1:nspmd),nspmd) ! NSNFIE
827 nedge_kept = i25_fie(ni,proc+1)%NEDGE_TOT
828 nodfi = 2 * nedge_kept
829 ALLOCATE(ledge_fie(nodfi*e_ibuf_size)) !working array, max size
830 ledge_fie(1:nodfi*e_ibuf_size) = 0
831 IF(nedge_kept > 0) THEN
832 CALL write_i_c(i25_fie(ni,proc+1)%ID(1:nedge_kept),nedge_kept) ! NSVFIE
833C CALL WRITE_I_C(TAGE(1:NODFI),NODFI) ! ITAFIE
834C CALL WRITE_I_C(MAIN_FIE(1:NEDGE_KEPT),NEDGE_KEPT)!MAIN_FIE
835
836C LEDGE_FIE
837 DO k = 1, nedge_kept
838 j = i25_fie(ni,proc+1)%ID(k)
839 assert(j > 0)
840 ledge_fie(e_ibuf_size*(k-1) + 1) = intbuf_tab(ni)%LEDGE(8 + (j-1)*nledge)
841 ledge_fie(e_ibuf_size*(k-1) + 2) = intbuf_tab(ni)%LEDGE(1 + (j-1)*nledge)
842 ledge_fie(e_ibuf_size*(k-1) + 3) = intbuf_tab(ni)%LEDGE(2 + (j-1)*nledge)
843 ledge_fie(e_ibuf_size*(k-1) + 4) = intbuf_tab(ni)%LEDGE(3+ (j-1)*nledge)
844 ledge_fie(e_ibuf_size*(k-1) + 5) = intbuf_tab(ni)%LEDGE(4+ (j-1)*nledge)
845 ledge_fie(e_ibuf_size*(k-1) + 6) = intbuf_tab(ni)%LEDGE(5+ (j-1)*nledge)
846 ledge_fie(e_ibuf_size*(k-1) + 7) = intbuf_tab(ni)%LEDGE(6+ (j-1)*nledge)
847 ledge_fie(e_ibuf_size*(k-1) + 8) = intbuf_tab(ni)%LEDGE(7+ (j-1)*nledge)
848 ! global id node 1
849 ledge_fie(e_ibuf_size*(k-1) + 9) = itab(ledge_fie(e_ibuf_size*(k-1) + 6))
850 !global id node 2
851 ledge_fie(e_ibuf_size*(k-1) +10) = itab(ledge_fie(e_ibuf_size*(k-1) + 7))
852 ! IM
853 ledge_fie(e_ibuf_size*(k-1) +11) = intbuf_tab(ni)%LEDGE(10 + (j-1)*nledge)
854 ! LocalID
855 ledge_fie(e_ibuf_size*(k-1) +12) = 0
856 ! BINFLG
857 IF(ilev == 2) THEN
858 ledge_fie(e_ibuf_size*(k-1) +13) = intbuf_tab(ni)%EBINFLG(j)
859 ELSE
860 ledge_fie(e_ibuf_size*(k-1) +13) = 0
861 ENDIF
862 ENDDO
863 nsne = e_ibuf_size*nedge_kept
864 CALL write_i_c(ledge_fie,nsne) ! LEDGE_FIE
865C Void writing for IPARTFRIC_FIE
866 IF (intfric>0) THEN
867 CALL write_i_c(i25_fie(ni,proc+1)%ID(1:nedge_kept),nedge_kept)
868 ENDIF
869 ENDIF
870 DEALLOCATE(ledge_fie)
871
872 ENDIF ! TYPE25+EDGE
873C
874 IF(ipari(36,ni)>0.AND.ityp/=17) THEN
875C init a 0 des structures de sous interfaces
876 nump(1:nspmd) = 0
877 CALL write_i_c(nump,nspmd)
878 IF(ityp == 25 .AND. ipari(58,ni) > 0) THEN
879 ! fake NISUBSFIE
880 CALL write_i_c(nump,nspmd)
881 ENDIF
882 END IF
883C
884 END IF
885
886
887 IF(ityp==21 ) THEN
888 intth = ipari(47,ni)
889 IF(intth==2.OR.ipari(95,ni) > 0) THEN
890C ecriture NMNSI : 0
891 DO p = 1, nspmd
892 nmnfi(p) = 0
893 END DO
894 CALL write_i_c(nmnfi,nspmd)
895 len_ia = len_ia + nspmd
896C ecriture nmnfi : 0
897 CALL write_i_c(nmnfi,nspmd)
898 len_ia = len_ia + nspmd
899C
900 ENDIF
901 ENDIF
902! ----------------------------------
903! Flush arrays to 0
904 ! TAG(INDX_TAG(1:NINDX_TAG)) = 0
905 IF(nindx_tag>0)THEN
906 DO it=1,nindx_tag
907 id=indx_tag(it)
908 tag(id)=0
909 ENDDO
910 ENDIF
911
912! ----------------------------------
913
914 END DO
915C
916 DEALLOCATE(nsnfi)
917 DEALLOCATE(nump)
918 DEALLOCATE(nmnfi)
919
920 RETURN
921 END
plist_ifront
subroutine plist_ifront(tab, n, cpt)
Definition ddtools.F:153
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
front_mod
Definition front_mod.F:84
i25_fie_mod
Definition i25_fie_mod.F:30
i25_fie_mod::i25_fie
type(i25_fie_), dimension(:,:), allocatable i25_fie
Definition i25_fie_mod.F:54
nl
character *2 function nl()
Definition message.F:2354
starter
program starter
Definition starter.F:39
front_mod::intersurfp
Definition front_mod.F:109
w_fi
subroutine w_fi(ipari, proc, len_ia, intercep, intbuf_tab, itab, multi_fvm, tag, nindx_tag, indx_tag, nodlocal, numnod_l, len_cep, cep)
Definition w_fi.F:38
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645