OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
chkstfn3.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!|| chkslv3 ../engine/source/interfaces/interf/chkstfn3.F
25!||--- called by ------------------------------------------------------
26!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
27!||====================================================================
28 SUBROUTINE chkslv3(
29 . NSN ,NSV,STFN,ITAG,ITASK,
30 . NEWFRONT)
31C-----------------------------------------------
32C I m p l i c i t T y p e s
33C-----------------------------------------------
34#include "implicit_f.inc"
35C-----------------------------------------------
36C C o m m o n B l o c k s
37C-----------------------------------------------
38#include "task_c.inc"
39C-----------------------------------------------
40C D u m m y A r g u m e n t s
41C-----------------------------------------------
42 INTEGER NSN, NSV(*), ITAG(*), ITASK, NEWFRONT
43C REAL
44 my_real
45 . stfn(*)
46C-----------------------------------------------
47C L o c a l V a r i a b l e s
48C-----------------------------------------------
49 INTEGER I, NSNF, NSNL
50C REAL
51C-----------------------------------------------
52 nsnf = 1 + itask*nsn / nthread
53 nsnl = (itask+1)*nsn / nthread
54C
55 DO i = nsnf, nsnl
56C si tag nul sur noeuds secnds alors stifn = 0.
57 IF (itag(nsv(i)) == 0.AND.stfn(i) > zero) THEN
58C STFN (i) = Zero => Take into account following APRES AFTER COMM SPMD (CF I7FOR3)
59 stfn(i) = -stfn(i)
60 newfront = -1
61 ENDIF
62 ENDDO
63C
64 RETURN
65 END
66C
67!||====================================================================
68!|| chkslv3_t24 ../engine/source/interfaces/interf/chkstfn3.F
69!||--- called by ------------------------------------------------------
70!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
71!||====================================================================
72 SUBROUTINE chkslv3_t24(
73 . NSN ,NSV, STFN, ITAG, ITASK,
74 . IS2SE ,IRTSE, NEWFRONT )
75C-----------------------------------------------
76C I m p l i c i t T y p e s
77C-----------------------------------------------
78#include "implicit_f.inc"
79C-----------------------------------------------
80C C o m m o n B l o c k s
81C-----------------------------------------------
82#include "task_c.inc"
83#include "com04_c.inc"
84C-----------------------------------------------
85C D u m m y A r g u m e n t s
86C-----------------------------------------------
87 INTEGER NSN, NSV(*), ITAG(*), ITASK, NEWFRONT
88 INTEGER IS2SE(2,*),IRTSE(5,*)
89C REAL
90 my_real
91 . stfn(*)
92C-----------------------------------------------
93C L o c a l V a r i a b l e s
94C-----------------------------------------------
95 INTEGER I, NSNF, NSNL,ND,SE
96C REAL
97 INTEGER IK1(4),IK2(4),IE1,IE2,IED,NS1,NS2
98 DATA IK1 /1,2,3,4/
99 DATA ik2 /2,3,4,1/
100C-----------------------------------------------
101 nsnf = 1 + itask*nsn / nthread
102 nsnl = (itask+1)*nsn / nthread
103C
104 DO i = nsnf, nsnl
105C si tag nul sur noeuds secnds alors stifn = 0.
106 nd = nsv(i)
107 IF (nd > numnod)THEN
108 se=is2se(1,nd-numnod)
109 ied=irtse(5,se)
110 ns1= irtse(ik1(ied),se)
111 ns2= irtse(ik2(ied),se)
112 IF(itag(ns1)==0 .AND.itag(ns2)==0 .AND. stfn(i) > zero) THEN
113 stfn(i) = -stfn(i)
114 newfront = -1
115 ENDIF
116 ENDIF
117 ENDDO
118C
119 RETURN
120 END
121!||====================================================================
122!|| chkslv3b ../engine/source/interfaces/interf/chkstfn3.f
123!||--- called by ------------------------------------------------------
124!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
125!||====================================================================
126 SUBROUTINE chkslv3b(NSN,NSV,STFN,ITAG,ITASK)
127C-----------------------------------------------
128C I m p l i c i t T y p e s
129C-----------------------------------------------
130#include "implicit_f.inc"
131C-----------------------------------------------
132C C o m m o n B l o c k s
133C-----------------------------------------------
134#include "task_c.inc"
135C-----------------------------------------------
136C D u m m y A r g u m e n t s
137C-----------------------------------------------
138 INTEGER NSN, NSV(*), ITAG(*), ITASK
139C REAL
140 my_real
141 . STFN(*)
142C-----------------------------------------------
143C L o c a l V a r i a b l e s
144C-----------------------------------------------
145 INTEGER I, NSNF, NSNL
146C REAL
147C-----------------------------------------------
148 NSNF = 1 + itask*nsn / nthread
149 nsnl = (itask+1)*nsn / nthread
150C
151 DO i = nsnf, nsnl
152C if tag is zero on secondary nodes then stifn = 0 from the current cycle
153 IF (itag(nsv(i)) == 0) THEN
154 stfn(i) = zero
155 END IF
156 END DO
157C
158 RETURN
159 END
160C
161!||====================================================================
162!|| chkslv3c ../engine/source/interfaces/interf/chkstfn3.F
163!||--- called by ------------------------------------------------------
164!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
165!||====================================================================
166 SUBROUTINE chkslv3c(
167 . NSN ,NSV,STFA,ITAG,ITASK,
168 . NEWFRONT,NLG)
169C-----------------------------------------------
170C I m p l i c i t T y p e s
171C-----------------------------------------------
172#include "implicit_f.inc"
173C-----------------------------------------------
174C C o m m o n B l o c k s
175C-----------------------------------------------
176#include "task_c.inc"
177C-----------------------------------------------
178C D u m m y A r g u m e n t s
179C-----------------------------------------------
180 INTEGER NSN, NSV(*), ITAG(*), NLG(*), ITASK, NEWFRONT
181C REAL
182 my_real
183 . STFA(*)
184C-----------------------------------------------
185C L o c a l V a r i a b l e s
186C-----------------------------------------------
187 INTEGER I, NSNF, NSNL
188C REAL
189C-----------------------------------------------
190 nsnf = 1 + itask*nsn / nthread
191 nsnl = (itask+1)*nsn / nthread
192C
193 DO i = nsnf, nsnl
194C si tag nul sur noeuds secnds alors stifn = 0.
195 IF (itag(nlg(nsv(i))) == 0.AND.stfa(nsv(i)) > zero) THEN
196C STFA (NSV (I)) = Zero => Take into account following afterwards APMD SPMD (see i7for3)
197 stfa(nsv(i)) = -stfa(nsv(i))
198 newfront = -1
199 ENDIF
200 ENDDO
201C
202 RETURN
203 END
204C
205!||====================================================================
206!|| chkipari ../engine/source/interfaces/interf/chkstfn3.F
207!||--- called by ------------------------------------------------------
208!|| lectur ../engine/source/input/lectur.F
209!||====================================================================
210 SUBROUTINE chkipari(IPARI)
211C-----------------------------------------------
212C I m p l i c i t T y p e s
213C-----------------------------------------------
214#include "implicit_f.inc"
215C-----------------------------------------------
216C C o m m o n B l o c k s
217C-----------------------------------------------
218#include "param_c.inc"
219#include "scr17_c.inc"
220#include "com04_c.inc"
221C-----------------------------------------------
222C D u m m y A r g u m e n t s
223C-----------------------------------------------
224 INTEGER IPARI(NPARI,*)
225C-----------------------------------------------
226C L o c a l V a r i a b l e s
227C-----------------------------------------------
228 INTEGER NG, ITY
229CC-----------------------------------------------
230C
231C ipari(16) : flag parallelisation interfaces sauf type 2
232C Ipari (16): Number of local send nodes int.Type 2
233C ipari(17) : flag delete facettes/noeuds int. type7, type2
234C ipari(17) = 0 => ras
235C ipari(17) = 1 => delete facettes+noeuds methode 1
236C ipari(17) = 2 => delete facettes+noeuds methode 2 (sauf type 2)
237 idel7ng = 0
238 idel7nok = 0
239 DO ng=1,ninter
240 ity = ipari(7,ng)
241 IF(ity/=2) ipari(16,ng)=-1
242 IF(ity== 2.OR.ity== 3.OR.ity== 5.OR.
243 + ity== 7.OR.ity==10.OR.ity==11.OR.
244 + ity==20.OR.ity==21.OR.ity==22.OR.
245 + ity==23.OR.ity==24.OR.ity==25)
246 + idel7ng = max(idel7ng,ipari(17,ng))
247 ENDDO
248 IF (idel7ng>=1) idel7nok = 1
249C
250 RETURN
251 END
252C
253!||====================================================================
254!|| chkinit ../engine/source/interfaces/interf/chkstfn3.F
255!||--- called by ------------------------------------------------------
256!|| resol_init ../engine/source/engine/resol_init.F
257!||--- uses -----------------------------------------------------
258!|| element_mod ../common_source/modules/elements/element_mod.F90
259!||====================================================================
260 SUBROUTINE chkinit(
261 2 IXS ,IXQ ,IXC ,IXT ,IXP ,
262 3 IXR ,IXTG ,IXS10 ,IXS20 ,
263 4 IXS16 ,IXTG1 ,GEO ,ADDCNEL ,CNEL ,
264 5 ADSKY ,IPARG )
265 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
266C-----------------------------------------------
267C I m p l i c i t T y p e s
268C-----------------------------------------------
269#include "implicit_f.inc"
270C-----------------------------------------------
271C C o m m o n B l o c k s
272C-----------------------------------------------
273#include "param_c.inc"
274#include "com01_c.inc"
275#include "com04_c.inc"
276C-----------------------------------------------
277C D u m m y A r g u m e n t s
278C-----------------------------------------------
279 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),
280 . IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
281 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG1(4,*),
282 . ADDCNEL(0:*), CNEL(0:*), ADSKY(0:*), IPARG(NPARG,*)
283 my_real
284 . GEO(NPROPG,*)
285C-----------------------------------------------
286C L o c a l V a r i a b l e s
287C-----------------------------------------------
288 INTEGER I, K, N, ITY, NEL, LLT, LFT, NFT, IE, ISOLNOD, ICNOD,
289 . ofq, ofc, oft, ofp, ofr, oftg, ofur, ng
290CC-----------------------------------------------
291C
292C pre-construction of addcnel
293C
294 DO i=0,numnod+1
295 addcnel(i) = 0
296 END DO
297C
298 DO k=2,9
299 DO i=1,numels
300 n = ixs(k,i) + 1
301 addcnel(n) = addcnel(n) + 1
302 END DO
303 END DO
304C
305 DO k=1,6
306 DO i=1,numels10
307 n = ixs10(k,i) + 1
308 addcnel(n) = addcnel(n) + 1
309 END DO
310 END DO
311C
312 DO k=1,12
313 DO i=1,numels20
314 n = ixs20(k,i) + 1
315 addcnel(n) = addcnel(n) + 1
316 END DO
317 END DO
318C
319 DO k=1,8
320 DO i=1,numels16
321 n = ixs16(k,i) + 1
322 addcnel(n) = addcnel(n) + 1
323 END DO
324 END DO
325C
326 DO k=2,5
327 DO i=1,numelq
328 n = ixq(k,i) + 1
329 addcnel(n) = addcnel(n) + 1
330 END DO
331 END DO
332C
333 DO k=2,5
334 DO i=1,numelc
335 n = ixc(k,i) + 1
336 addcnel(n) = addcnel(n) + 1
337 END DO
338 END DO
339C
340 DO k=2,3
341 DO i=1,numelt
342 n = ixt(k,i) + 1
343 addcnel(n) = addcnel(n) + 1
344 END DO
345 END DO
346C
347 DO k=2,3
348 DO i=1,numelp
349 n = ixp(k,i) + 1
350 addcnel(n) = addcnel(n) + 1
351 END DO
352 END DO
353C
354 DO k=2,3
355 DO i=1,numelr
356 n = ixr(k,i) + 1
357 addcnel(n) = addcnel(n) + 1
358 END DO
359 END DO
360C Treatment apart from the 3rd optional node except type 12
361 DO i=1,numelr
362 n = ixr(4,i) + 1
363 IF(nint(geo(12,ixr(1,i))) == 12) addcnel(n) = addcnel(n) + 1
364 END DO
365C
366 DO k=2,4
367 DO i=1,numeltg
368 n = ixtg(k,i) + 1
369 addcnel(n) = addcnel(n) + 1
370 END DO
371 END DO
372C
373 DO k=1,3
374 DO i=1,numeltg6
375 n = ixtg1(k,i) + 1
376 IF (n > 1) addcnel(n) = addcnel(n) + 1
377 END DO
378 END DO
379C
380 addcnel(1) = 1
381 DO i=2,numnod+1
382 addcnel(i) = addcnel(i) + addcnel(i-1)
383 END DO
384C
385C construction of the cnel matrix
386C
387C cnel is built in a similar way as in chkstfn3n (idel processing)
388C numbering in cnel is global from 1 to numels+numelq+...+numelr
389C
390 adsky(0) = 0
391 DO i = 1, numnod
392 adsky(i) = addcnel(i)
393 ENDDO
394C
395 ofq=numels
396 ofc=ofq+numelq
397 oft=ofc+numelc
398 ofp=oft+numelt
399 ofr=ofp+numelp
400 oftg=ofr+numelr
401 ofur=oftg+numeltg
402C
403 DO ng = 1,ngroup
404 ity = iparg(5,ng)
405 nel = iparg(2,ng)
406 nft = iparg(3,ng)
407 icnod = iparg(11,ng)
408 isolnod = iparg(28,ng)
409 lft = 1
410 llt = nel
411 IF(ity == 1) THEN
412C#include "vectorize.inc"
413 DO i = lft,llt
414 ie = nft+i
415 DO k=2,9
416 n = ixs(k,nft+i)
417 cnel(adsky(n)) = ie
418 adsky(n) = adsky(n)+1
419 ENDDO
420 ENDDO
421C
422 IF(isolnod == 10) THEN
423C#include "vectorize.inc"
424 DO i = lft,llt
425 ie = nft+i
426 DO k=1,6
427 n = ixs10(k,nft+i-numels8)
428 cnel(adsky(n)) = ie
429 adsky(n) = adsky(n)+1
430 ENDDO
431 ENDDO
432 ELSEIF(isolnod == 20) THEN
433C#include "vectorize.inc"
434 DO i = lft,llt
435 ie = nft+i
436 DO k=1,12
437 n = ixs20(k,nft+i-numels8-numels10)
438 cnel(adsky(n)) = ie
439 adsky(n) = adsky(n)+1
440 ENDDO
441 ENDDO
442 ELSEIF(isolnod == 16) THEN
443C#include "vectorize.inc"
444 DO i = lft,llt
445 ie = nft+i
446 DO k=1,8
447 n = ixs16(k,nft+i-numels8-numels10-numels20)
448 cnel(adsky(n)) = ie
449 adsky(n) = adsky(n)+1
450 ENDDO
451 ENDDO
452 ENDIF
453C
454 ELSEIF(ity == 2) THEN
455C#include "vectorize.inc"
456 DO i = lft,llt
457 ie = nft+i+ofq
458 DO k=2,5
459 n = ixq(k,nft+i)
460 cnel(adsky(n)) = ie
461 adsky(n) = adsky(n)+1
462 ENDDO
463 ENDDO
464C
465 ELSEIF(ity == 3)THEN
466C#include "vectorize.inc"
467 DO i = lft,llt
468 ie = nft+i+ofc
469 DO k=2,5
470 n = ixc(k,nft+i)
471 cnel(adsky(n)) = ie
472 adsky(n) = adsky(n)+1
473 ENDDO
474 ENDDO
475C
476 ELSEIF(ity == 4)THEN
477C#include "vectorize.inc"
478 DO i = lft,llt
479 ie = nft+i+oft
480 DO k=2,3
481 n = ixt(k,nft+i)
482 cnel(adsky(n)) = ie
483 adsky(n) = adsky(n)+1
484 ENDDO
485 ENDDO
486C
487 ELSEIF(ity == 5)THEN
488C#include "vectorize.inc"
489 DO i = lft,llt
490 ie = nft+i+ofp
491 DO k=2,3
492 n = ixp(k,nft+i)
493 cnel(adsky(n)) = ie
494 adsky(n) = adsky(n)+1
495 ENDDO
496 ENDDO
497C
498 ELSEIF(ity == 6)THEN
499C#include "vectorize.inc"
500 DO i = lft,llt
501 ie = nft+i+ofr
502 DO k=2,3
503 n = ixr(k,nft+i)
504 cnel(adsky(n)) = ie
505 adsky(n) = adsky(n)+1
506 ENDDO
507 IF(nint(geo(12,ixr(1,nft+i))) == 12) THEN
508 n = ixr(4,nft+i)
509 cnel(adsky(n)) = ie
510 adsky(n) = adsky(n)+1
511 ENDIF
512 ENDDO
513C
514 ELSEIF(ity == 7)THEN
515C#include "vectorize.inc"
516 DO i = lft,llt
517 ie = nft+i+oftg
518 DO k=2,4
519 n = ixtg(k,nft+i)
520 cnel(adsky(n)) = ie
521 adsky(n) = adsky(n)+1
522 ENDDO
523 ENDDO
524 IF(icnod == 6) THEN
525C#include "vectorize.inc"
526 DO i = lft,llt
527 ie = nft+i
528 DO k=1,3
529 n = max(0,ixtg1(k,nft+i-numeltg+numeltg6))
530 cnel(adsky(n)) = ie
531 adsky(n) = adsky(n)+1
532 ENDDO
533 ENDDO
534 END IF
535C
536 ENDIF
537 ENDDO
538C
539 RETURN
540 END
541!||====================================================================
542!|| tagoff3n ../engine/source/interfaces/interf/chkstfn3.F
543!||--- called by ------------------------------------------------------
544!|| resol ../engine/source/engine/resol.F
545!||--- calls -----------------------------------------------------
546!|| exch_tagel_c ../engine/source/coupling/rad2rad/rad2rad_c.c
547!|| get_ibuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
548!|| get_shmbuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
549!|| my_barrier ../engine/source/system/machine.F
550!|| r2r_exch_itag ../engine/source/coupling/rad2rad/r2r_exchange.F
551!|| r2r_tagel ../engine/source/coupling/rad2rad/r2r_exchange.F
552!|| send_ibuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
553!|| send_shmbuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
554!|| spmd_allglob_isum9 ../engine/source/mpi/generic/spmd_allglob_isum9.F
555!|| spmd_exch_idel ../engine/source/mpi/interfaces/spmd_exch_idel.f
556!|| spmd_exch_r2r_itag ../engine/source/mpi/r2r/spmd_r2r.F
557!|| spmd_ibcast ../engine/source/mpi/generic/spmd_ibcast.f
558!|| spmd_r2r_tagel ../engine/source/mpi/r2r/spmd_r2r.F
559!||--- uses -----------------------------------------------------
560!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
561!|| element_mod ../common_source/modules/elements/element_mod.F90
562!|| groupdef_mod ../common_source/modules/groupdef_mod.F
563!|| nodal_arrays_mod ../common_source/modules/nodal_arrays.F90
564!|| rad2r_mod ../engine/share/modules/rad2r.F
565!|| remesh_mod ../engine/share/modules/remesh_mod.F
566!|| shooting_node_mod ../engine/share/modules/shooting_node_mod.F90
567!||====================================================================
568 SUBROUTINE tagoff3n(NODES,
569 1 GEO ,IXS ,IXS10 ,IXS20 ,IXS16 ,IXQ ,
570 2 IXC ,IXT ,IXP ,IXR ,IXTG ,
571 3 ITAG ,NODFT ,NODLT ,IPARG ,EV ,ITASK ,
572 4 IXTG1 ,IAD_ELEM,FR_ELEM,ITAB ,
573 5 ADDCNEL ,CNEL ,KXSP ,ELBUF_TAB,TAGEL ,IEXLNK ,
574 6 IGRNOD ,DD_R2R,DD_R2R_ELEM,SDD_R2R_ELEM,IDEL7NOK_SAV,
575 7 IDEL7NOK_R2R,TAGTRIMC,TAGTRIMTG,S_ELEM_STATE,ELEM_STATE,
576 8 SHOOT_STRUCT,GLOBAL_NB_ELEM_OFF)
577C-----------------------------------------------
578C M o d u l e s
579C-----------------------------------------------
580 USE nodal_arrays_mod
581 USE elbufdef_mod
582 USE rad2r_mod
583 USE remesh_mod
584 USE groupdef_mod
585 USE shooting_node_mod
586 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
587C----6---------------------------------------------------------------7---------8
588C I m p l i c i t T y p e s
589C-----------------------------------------------
590#include "implicit_f.inc"
591#include "comlock.inc"
592C-----------------------------------------------
593C C o m m o n B l o c k s
594C-----------------------------------------------
595#include "param_c.inc"
596#include "com01_c.inc"
597#include "com04_c.inc"
598#include "scr17_c.inc"
599#include "task_c.inc"
600#include "sphcom.inc"
601#include "rad2r_c.inc"
602#include "remesh_c.inc"
603C-----------------------------------------------------------------
604C D u m m y A r g u m e n t s
605C-----------------------------------------------
606 TYPE(nodal_arrays_) :: NODES
607 INTEGER
608 . LINDIDEL, LBUFIDEL,
609 . IXS(NIXS,*),IXS10(6,*),IXS20(12,*),IXS16(8,*),
610 . IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*), IXP(NIXP,*),
611 . IXR(NIXR,*), IXTG(NIXTG,*),IXTG1(4,*),ITAG(*),
612 . IPARG(NPARG,*), NODFT,NODLT,ITASK,
613 . IAD_ELEM(2,*),FR_ELEM(*),ITAB(*),
614 . ADDCNEL(0:*),CNEL(0:*),KXSP(NISP,*),
615 . TAGEL(*),
616 . IEXLNK(NR2R,NR2RLNK),DD_R2R(NSPMD+1,*),
617 . TAGTRIMC(*),TAGTRIMTG(*),
618 . DD_R2R_ELEM(*),SDD_R2R_ELEM,IDEL7NOK_SAV,IDEL7NOK_R2R
619 my_real
620 . GEO(NPROPG,*), EV(*)
621 TYPE(ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
622!
623 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
624 INTEGER, INTENT(in) :: S_ELEM_STATE ! size of ELEM_STATE
625 LOGICAL, DIMENSION(S_ELEM_STATE), INTENT(inout) :: ELEM_STATE ! boolean : true if element is ON, false if element is OFF
626 INTEGER, DIMENSION(NTHREAD), INTENT(inout) :: GLOBAL_NB_ELEM_OFF
627 TYPE(shooting_node_type), INTENT(inout) :: SHOOT_STRUCT ! structure for shooting node algo
628C-----------------------------------------------
629C L o c a l V a r i a b l e s
630C-----------------------------------------------
631 INTEGER I, NG, K, ITY, MLW, NEL, NFT, ISOLNOD, LFT, LLT,
632 . KAD, NPT, IHBE, JD(50), KD(50), JFI, KFI, NRTM, NRTS,
633 . NTY, NSN, ISTRA, N, IDEL, NMN,ILEV,
634 . N1, N2, N3, N4, SIZE, LENR, IDB, IDBS, INC, IDELKEEP,
635 . IDEB, OFQ, OFC, OFT, OFP, OFR, OFTG, OFUR, ICNOD, IE,
636 . NLINSA, NLINMA, NSNE, NMNE, IEXPAN, IRSIZE,
637 . irecv(nspmd),siz,j,r2r_numel,tagel_r2r_ispmd(nspmd+1),
638 . ipartr2r,ntagel_r2r_recv,ntagel_r2r_send,ntagel_r2r_sendg,
639 . tagel_size,level
640 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGEL_R2R_RECV,TAGEL_R2R_SENDG
641 TYPE(g_bufel_) ,POINTER :: GBUF
642 INTEGER, DIMENSION(:), ALLOCATABLE :: LOCAL_ELEM_INDEX
643 INTEGER :: SHIFT
644C-----------------------------------------------
645 ! allocation of local list of deactivated element
646 ALLOCATE( local_elem_index(s_elem_state) )
647 global_nb_elem_off(itask+1) = 0
648 lft = nodft
649 llt = nodlt
650 ntagel_r2r_send = 0
651 ntagel_r2r_recv = 0
652 tagel_size = 0
653C
654 DO i = lft, llt
655 itag(i) = 0
656 ENDDO
657C
658#include "vectorize.inc"
659 DO i = lft, llt
660 itag(numnod+i) = 0
661 ENDDO
662C
663 CALL my_barrier()
664C
665 ofq=numels
666 ofc=ofq+numelq
667 oft=ofc+numelc
668 ofp=oft+numelt
669 ofr=ofp+numelp
670 oftg=ofr+numelr
671 ofur=oftg+numeltg
672C
673!$OMP DO
674
675 DO ng = 1,ngroup
676 gbuf => elbuf_tab(ng)%GBUF
677 ity =iparg(5,ng)
678 mlw = iparg(1,ng)
679 nel = iparg(2,ng)
680 nft = iparg(3,ng)
681 kad = iparg(4,ng)
682 npt = iparg(6,ng)
683 icnod = iparg(11,ng)
684 istra = iparg(44,ng)
685 ihbe = iparg(23,ng)
686 isolnod = iparg(28,ng)
687 iexpan = iparg(49,ng)
688 ipartr2r = iparg(77,ng)
689 IF (ihbe == 101) THEN
690 ihbe=1
691 ELSEIF(ihbe == 102) THEN
692 ihbe=0
693 ELSEIF(ihbe == 112) THEN
694 ihbe=0
695 ENDIF
696 lft = 1
697 llt = nel
698 IF(ity == 1) THEN
699 IF (mlw/=0) THEN
700 DO i = lft,llt
701 ie = nft+i
702 IF (abs(gbuf%OFF(i)) == one .OR.
703 . abs(gbuf%OFF(i)) == two) THEN
704 tagel(ie)=1
705#include "lockon.inc"
706 DO k=2,9
707 n = ixs(k,nft+i)
708 itag(n) = 1
709 ENDDO
710#include "lockoff.inc"
711 ELSE
712 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
713 CALL r2r_tagel(ntagel_r2r_send,ixs(11,nft+i),itab(ixs(2,nft+i)),ity,
714 . ofur,tagel_size)
715 ENDIF
716 tagel(ie)=-1
717 IF(elem_state(ie)) THEN
718 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
719 local_elem_index(global_nb_elem_off(itask+1)) = ie
720 ENDIF
721 elem_state(ie) = .false.
722#include "lockon.inc"
723 DO k=2,9
724 n = ixs(k,nft+i)
725 itag(numnod+n) = 1
726 ENDDO
727#include "lockoff.inc"
728 ENDIF
729 ENDDO
730 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
731C Void elements never break and doesn't have ELBUF
732#include "vectorize.inc"
733 DO i = lft,llt
734 ie = nft+i
735 tagel(ie)=1
736 DO k=2,9
737 n = ixs(k,nft+i)
738 itag(n) = 1
739 ENDDO
740 ENDDO
741 ENDIF
742C
743 IF(isolnod == 10) THEN
744 IF(mlw/=0)THEN
745#include "vectorize.inc"
746 DO i = lft,llt
747 ie = nft+i
748 IF(abs(gbuf%OFF(i)) == one.OR.
749 . abs(gbuf%OFF(i)) == two) THEN
750 DO k=1,6
751 n = ixs10(k,nft+i-numels8)
752 itag(n) = 1
753 ENDDO
754 ELSE
755 DO k=1,6
756 n = ixs10(k,nft+i-numels8)
757 itag(numnod+n) = 1
758 ENDDO
759 ENDIF
760 ENDDO
761 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
762C Void elements never break and doesn't have ELBUF
763#include "vectorize.inc"
764 DO i = lft,llt
765 ie = nft+i
766 DO k=1,6
767 n = ixs10(k,nft+i-numels8)
768 itag(n) = 1
769 ENDDO
770 ENDDO
771 ENDIF
772 ELSEIF(isolnod == 20) THEN
773 IF(mlw/=0)THEN
774#include "vectorize.inc"
775 DO i = lft,llt
776 ie = nft+i
777 IF(abs(gbuf%OFF(i)) == one.OR.
778 . abs(gbuf%OFF(i)) == two) THEN
779 DO k=1,12
780 n = ixs20(k,nft+i-numels8-numels10)
781 itag(n) = 1
782 ENDDO
783 ELSE
784 DO k=1,12
785 n = ixs20(k,nft+i-numels8-numels10)
786 itag(numnod+n) = 1
787 ENDDO
788 ENDIF
789 ENDDO
790 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
791C Void elements never break and doesn't have ELBUF
792#include "vectorize.inc"
793 DO i = lft,llt
794 ie = nft+i
795 DO k=1,12
796 n = ixs20(k,nft+i-numels8-numels10)
797 itag(n) = 1
798 ENDDO
799 ENDDO
800 ENDIF
801 ELSEIF(isolnod == 16) THEN
802 IF(mlw/=0)THEN
803#include "vectorize.inc"
804 DO i = lft,llt
805 ie = nft+i
806 IF(abs(gbuf%OFF(i)) == one.OR.
807 . abs(gbuf%OFF(i)) == two) THEN
808 DO k=1,8
809 n = ixs16(k,nft+i-numels8-numels10-numels20)
810 itag(n) = 1
811 ENDDO
812 ELSE
813 DO k=1,8
814 n = ixs16(k,nft+i-numels8-numels10-numels20)
815 itag(numnod+n) = 1
816 ENDDO
817 ENDIF
818 ENDDO
819 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
820C Void elements never break and doesn't have ELBUF
821#include "vectorize.inc"
822 DO i = lft,llt
823 ie = nft+i
824 DO k=1,8
825 n = ixs16(k,nft+i-numels8-numels10-numels20)
826 itag(n) = 1
827 ENDDO
828 ENDDO
829 ENDIF
830 ENDIF
831C
832 ELSEIF(ity == 2) THEN
833 DO i = lft,llt
834 ie = nft+i+ofq
835 IF(abs(gbuf%OFF(i))>=one) THEN
836 tagel(ie)=1
837 DO k=2,5
838 n = ixq(k,nft+i)
839 itag(n) = 1
840 ENDDO
841 ELSE
842 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
843 CALL r2r_tagel(ntagel_r2r_send,ixq(7,nft+i),itab(ixq(2,nft+i)),ity,
844 . ofur,tagel_size)
845 ENDIF
846 tagel(ie)=-1
847 IF(elem_state(ie)) THEN
848 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
849 local_elem_index(global_nb_elem_off(itask+1)) = ie
850 ENDIF
851 elem_state(ie) = .false.
852 DO k=2,5
853 n = ixq(k,nft+i)
854 itag(numnod+n) = 1
855 ENDDO
856 ENDIF
857 ENDDO
858C
859 ELSEIF(ity == 3)THEN
860 IF(mlw/=0)THEN
861 DO i = lft,llt
862 ie = nft+i+ofc
863 IF(nadmesh/=0) THEN
864 IF(abs(gbuf%OFF(i))>=one.AND.tagtrimc(nft+i)==0)THEN
865 tagel(ie)=1
866 DO k=2,5
867 n = ixc(k,nft+i)
868 itag(n) = 1
869 ENDDO
870 ENDIF
871 ELSEIF(abs(gbuf%OFF(i))>=one) THEN
872 tagel(ie)=1
873 DO k=2,5
874 n = ixc(k,nft+i)
875 itag(n) = 1
876 ENDDO
877 ELSE
878 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
879 CALL r2r_tagel(ntagel_r2r_send,ixc(7,nft+i),itab(ixc(2,nft+i)),ity,
880 . ofur,tagel_size)
881 ENDIF
882 tagel(ie)=-1
883 IF(elem_state(ie)) THEN
884 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
885 local_elem_index(global_nb_elem_off(itask+1)) = ie
886 ENDIF
887 elem_state(ie) = .false.
888 DO k=2,5
889 n = ixc(k,nft+i)
890 itag(numnod+n) = 1
891 ENDDO
892 ENDIF
893 ENDDO
894 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
895C Void elements never break and doesn t have ELBUF
896#include "vectorize.inc"
897 DO i = lft,llt
898 ie = nft+i+ofc
899 tagel(ie)=1
900 DO k=2,5
901 n = ixc(k,nft+i)
902 itag(n) = 1
903 ENDDO
904 ENDDO
905 ENDIF
906C
907 ELSEIF(ity == 4)THEN
908 IF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
909 DO i = lft,llt
910 ie = nft+i+oft
911 IF (abs(gbuf%OFF(i)) >= one) THEN
912 tagel(ie)=1
913 DO k=2,3
914 n = ixt(k,nft+i)
915 itag(n) = 1
916 ENDDO
917 ELSE
918 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
919 CALL r2r_tagel(ntagel_r2r_send,ixt(5,nft+i),itab(ixt(2,nft+i)),ity,
920 . ofur,tagel_size)
921 ENDIF
922 tagel(ie)=-1
923 IF(elem_state(ie)) THEN
924 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
925 local_elem_index(global_nb_elem_off(itask+1)) = ie
926 ENDIF
927 elem_state(ie) = .false.
928 DO k=2,3
929 n = ixt(k,nft+i)
930 itag(numnod+n) = 1
931 ENDDO
932 ENDIF
933 ENDDO
934 ENDIF
935C
936 ELSEIF(ity == 5)THEN
937 IF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
938 DO i = lft,llt
939 ie = nft+i+ofp
940 IF (abs(gbuf%OFF(i)) >= one) THEN
941 tagel(ie)=1
942 DO k=2,3
943 n = ixp(k,nft+i)
944 itag(n) = 1
945 ENDDO
946 ELSE
947 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
948 CALL r2r_tagel(ntagel_r2r_send,ixp(6,nft+i),itab(ixp(2,nft+i)),ity,
949 . ofur,tagel_size)
950 ENDIF
951 tagel(ie)=-1
952 IF(elem_state(ie)) THEN
953 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
954 local_elem_index(global_nb_elem_off(itask+1)) = ie
955 ENDIF
956 elem_state(ie) = .false.
957 DO k=2,3
958 n = ixp(k,nft+i)
959 itag(numnod+n) = 1
960 ENDDO
961 ENDIF
962 ENDDO
963 ENDIF
964C
965 ELSEIF(ity == 6)THEN
966 IF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
967 DO i = lft,llt
968 ie = nft+i+ofr
969 IF (abs(gbuf%OFF(i)) >= one) THEN
970 tagel(ie)=1
971 DO k=2,3
972 n = ixr(k,nft+i)
973 itag(n) = 1
974 ENDDO
975 IF(nint(geo(12,ixr(1,nft+i))) == 12) THEN
976 n = ixr(4,nft+i)
977 itag(n) = 1
978 ENDIF
979 ELSE
980 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
981 CALL r2r_tagel(ntagel_r2r_send,ixr(nixr,nft+i),itab(ixr(2,nft+i)),ity,
982 . ofur,tagel_size)
983 ENDIF
984 tagel(ie)=-1
985 IF(elem_state(ie)) THEN
986 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
987 local_elem_index(global_nb_elem_off(itask+1)) = ie
988 ENDIF
989 elem_state(ie) = .false.
990 DO k=2,3
991 n = ixr(k,nft+i)
992 itag(numnod+n) = 1
993 ENDDO
994 IF(nint(geo(12,ixr(1,nft+i))) == 12) THEN
995 n = ixr(4,nft+i)
996 itag(numnod+n) = 1
997 ENDIF
998 ENDIF
999 ENDDO
1000 ENDIF
1001C
1002 ELSEIF(ity == 7)THEN
1003 IF(mlw/=0)THEN
1004 DO i = lft,llt
1005 ie = nft+i+oftg
1006
1007 IF(nadmesh/=0) THEN
1008 IF(abs(gbuf%OFF(i))>=one.AND.tagtrimtg(nft+i)==0)THEN
1009 tagel(ie)=1
1010 DO k=2,4
1011 n = ixtg(k,nft+i)
1012 itag(n) = 1
1013 ENDDO
1014 ENDIF
1015 ELSEIF(abs(gbuf%OFF(i))>=one) THEN
1016 tagel(ie)=1
1017 DO k=2,4
1018 n = ixtg(k,nft+i)
1019 itag(n) = 1
1020 ENDDO
1021 ELSE
1022 IF ((r2r_siu == 1).AND.(tagel(ie) > -1)) THEN
1023 CALL r2r_tagel(ntagel_r2r_send,ixtg(6,nft+i),itab(ixtg(2,nft+i)),ity,
1024 . ofur,tagel_size)
1025 ENDIF
1026 tagel(ie)=-1
1027 IF(elem_state(ie)) THEN
1028 global_nb_elem_off(itask+1) = global_nb_elem_off(itask+1) + 1
1029 local_elem_index(global_nb_elem_off(itask+1)) = ie
1030 ENDIF
1031 elem_state(ie) = .false.
1032 DO k=2,4
1033 n = ixtg(k,nft+i)
1034 itag(numnod+n) = 1
1035 ENDDO
1036 ENDIF
1037 ENDDO
1038 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
1039C Void elements never break and doesn't have ELBUF
1040#include "vectorize.inc"
1041 DO i = lft,llt
1042 ie = nft+i+oftg
1043 tagel(ie)=1
1044 DO k=2,4
1045 n = ixtg(k,nft+i)
1046 itag(n) = 1
1047 ENDDO
1048 ENDDO
1049 ENDIF
1050C
1051 IF(icnod == 6) THEN
1052 IF(mlw/=0)THEN
1053#include "vectorize.inc"
1054 DO i = lft,llt
1055 ie = nft+i+oftg
1056 IF(abs(gbuf%OFF(i))>=one) THEN
1057 DO k=1,3
1058 n = ixtg1(k,nft+i-numeltg+numeltg6)
1059 itag(n) = 1
1060 ENDDO
1061 ELSE
1062 DO k=1,3
1063 n = ixtg1(k,nft+i-numeltg+numeltg6)
1064 itag(numnod+n) = 1
1065 ENDDO
1066 ENDIF
1067 ENDDO
1068 ELSEIF ((r2r_siu == 0).OR.(ipartr2r > 0)) THEN
1069C Void elements never break and doesn't have ELBUF
1070#include "vectorize.inc"
1071 DO i = lft,llt
1072 ie = nft+i+oftg
1073 DO k=1,3
1074 n = ixtg1(k,nft+i-numeltg+numeltg6)
1075 itag(n) = 1
1076 ENDDO
1077 ENDDO
1078 ENDIF
1079 END IF
1080C
1081 ELSEIF(ity == 51) THEN
1082#include "vectorize.inc"
1083 DO i = lft,llt
1084 IF(abs(gbuf%OFF(i))>=one) THEN
1085 n = kxsp(3,nft+i)
1086 itag(n) = 1
1087 ELSE
1088 n = kxsp(3,nft+i)
1089 itag(numnod+n) = 1
1090 ENDIF
1091 END DO
1092 ENDIF
1093 ENDDO
1094
1095!$OMP END DO
1096
1097 IF(itask==0) THEN
1098 IF(ALLOCATED( shoot_struct%GLOBAL_ELEM_INDEX ) ) DEALLOCATE( shoot_struct%GLOBAL_ELEM_INDEX )
1099 ! compute the total number of new deactivated element
1100 shoot_struct%S_GLOBAL_ELEM_INDEX = 0
1101 DO i=1,nthread
1102 shoot_struct%S_GLOBAL_ELEM_INDEX = shoot_struct%S_GLOBAL_ELEM_INDEX + global_nb_elem_off(i)
1103 ENDDO
1104 ! allocate the array "list of new deactivated element"
1105 ALLOCATE( shoot_struct%GLOBAL_ELEM_INDEX(shoot_struct%S_GLOBAL_ELEM_INDEX) )
1106 ENDIF
1107 CALL my_barrier( )
1108
1109 ! omp reduction of "list of new deactivated elements"
1110 shift = 0
1111 DO i=1,itask
1112 shift = shift + global_nb_elem_off(i)
1113 ENDDO
1114 shoot_struct%GLOBAL_ELEM_INDEX(1+shift:global_nb_elem_off(itask+1)+shift) =
1115 . local_elem_index(1:global_nb_elem_off(itask+1))
1116
1117
1118C call my_barrier() => replaced by implicit barrier on do //
1119C
1120C SPMD SPECIFIQUE : ECHANGE ITAG NOEUDS FRONTIERES
1121C
1122 IF (nspmd > 1) THEN
1123
1124C Partie non parallele
1125!$OMP SINGLE
1126
1127 SIZE = 2
1128 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
1129 CALL spmd_exch_idel(itag,iad_elem,fr_elem,SIZE,lenr)
1130
1131C Fin Partie non parallele
1132!$OMP END SINGLE
1133
1134 ENDIF
1135
1136C--------------------------------
1137C R2R part : only for IDEL INTER
1138C-------------------------------
1139
1140C Partie non parallele
1141!$OMP SINGLE
1142 IF (r2r_siu == 1.AND.idel7nok==1) THEN
1143C-----------------------------------------------------------------
1144C sending itag and tagel for multidomains
1145C-----------------------------------------------------------------
1146 IF (idel7nok_sav > 0) THEN
1147C communication partie nodale ITAGq
1148 CALL send_shmbuf_c(idel7nok,1)
1149 CALL r2r_exch_itag(iexlnk,igrnod,itag,0)
1150C Tagel Element Party Communication
1151 ntagel_r2r_sendg = ntagel_r2r_send
1152 CALL spmd_allglob_isum9(ntagel_r2r_sendg,1)
1153 IF (ntagel_r2r_sendg > 0) THEN
1154 IF (nspmd > 1) THEN
1155 tagel_r2r_ispmd(:)=0
1156 tagel_r2r_ispmd(ispmd+1) = 3*ntagel_r2r_send
1157 CALL spmd_allglob_isum9(tagel_r2r_ispmd,nspmd)
1158 ALLOCATE(tagel_r2r_sendg(3*ntagel_r2r_sendg))
1159 CALL spmd_r2r_tagel(tagel_r2r_sendg,tagel_r2r_send,tagel_r2r_ispmd)
1160 CALL spmd_ibcast(tagel_r2r_sendg,tagel_r2r_sendg,3*ntagel_r2r_sendg,1,0,2)
1161 CALL exch_tagel_c(ntagel_r2r_sendg,tagel_r2r_sendg,0)
1162 DEALLOCATE(tagel_r2r_sendg)
1163 ELSE
1164 CALL exch_tagel_c(ntagel_r2r_sendg,tagel_r2r_send,0)
1165 ENDIF
1166 ENDIF
1167 ENDIF
1168C-----------------------------------------------------------------
1169C SYNCRO
1170C-----------------------------------------------------------------
1171 IF (ncycle == 0) THEN
1172 lenr = 2209
1173 CALL send_ibuf_c(lenr,1)
1174 CALL get_ibuf_c(lenr,1)
1175 ENDIF
1176C-----------------------------------------------------------------
1177C assembling itag for multidomains
1178C-----------------------------------------------------------------
1179 CALL r2r_exch_itag(iexlnk,igrnod,itag,1)
1180 IF (sdd_r2r_elem > 0) THEN
1181 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
1182 CALL spmd_exch_r2r_itag(itag,iad_elem,fr_elem,dd_r2r,dd_r2r_elem,lenr)
1183 ENDIF
1184C-----------------------------------------------------------------
1185C receiving tagel for multidomains
1186C-----------------------------------------------------------------
1187 IF (idel7nok_r2r > 0) THEN
1188 CALL get_shmbuf_c(ntagel_r2r_recv,4)
1189 ntagel_r2r_recv = ntagel_r2r_recv / 3
1190 IF (ntagel_r2r_recv > 0) THEN
1191 ALLOCATE(tagel_r2r_recv(3*ntagel_r2r_recv))
1192 CALL exch_tagel_c(ntagel_r2r_recv,tagel_r2r_recv,1)
1193 ENDIF
1194 DO i=1,ntagel_r2r_recv
1195 n1 = get_local_node_id(nodes,tagel_r2r_recv((i-1)*3+2))
1196 IF (n1 > 0) THEN
1197 ity = tagel_r2r_recv((i-1)*3+3)
1198 DO j = addcnel(n1),addcnel(n1+1)-1
1199 ie = cnel(j)
1200C
1201 IF ((ity == 1).AND.(ie<=ofq)) THEN
1202 r2r_numel = ixs(11,ie)
1203 ELSEIF ((ity == 2).AND.((ie > ofq).AND.(ie<=ofc))) THEN
1204 r2r_numel = ixq(7,ie-ofq)
1205 ELSEIF ((ity == 3).AND.((ie > ofc).AND.(ie<=oft))) THEN
1206 r2r_numel = ixc(7,ie-ofc)
1207 ELSEIF ((ity == 4).AND.((ie > oft).AND.(ie<=ofp))) THEN
1208 r2r_numel = ixt(5,ie-oft)
1209 ELSEIF ((ity == 5).AND.((ie > ofp).AND.(ie<=ofr))) THEN
1210 r2r_numel = ixp(6,ie-ofp)
1211 ELSEIF ((ity == 6).AND.((ie > ofr).AND.(ie<=oftg))) THEN
1212 r2r_numel = ixr(nixr,ie-ofr)
1213 ELSEIF ((ity == 7).AND.((ie > oftg).AND.(ie<=ofur))) THEN
1214 r2r_numel = ixtg(6,ie-oftg)
1215 ENDIF
1216C
1217 IF (r2r_numel == tagel_r2r_recv((i-1)*3+1)) THEN
1218 tagel(ie) = -1
1219 EXIT
1220 ENDIF
1221 ENDDO
1222 ENDIF
1223 ENDDO
1224C reset of idel7nok_r2r and ntagel_r2r_recv
1225 idel7nok_r2r = 0
1226 ntagel_r2r_recv = 0
1227 CALL send_shmbuf_c(idel7nok_r2r,2)
1228 CALL send_shmbuf_c(ntagel_r2r_recv,4)
1229 IF(ALLOCATED(tagel_r2r_recv)) DEALLOCATE(tagel_r2r_recv)
1230 ENDIF
1231C--------------------------------------------------------
1232 ENDIF
1233C Fin Partie non parallele
1234!$OMP END SINGLE
1235 ! deallocation of local list of deactivated element
1236 DEALLOCATE( local_elem_index )
1237C
1238 RETURN
1239 END
1240
1241
1242!||====================================================================
1243!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
1244!||--- called by ------------------------------------------------------
1245!|| resol ../engine/source/engine/resol.F
1246!||--- calls -----------------------------------------------------
1247!|| chk11msr3n ../engine/source/interfaces/interf/chkstfn3.F
1248!|| chk11msr3nb ../engine/source/interfaces/interf/chkstfn3.F
1249!|| chk20emsr3n ../engine/source/interfaces/interf/chkstfn3.F
1250!|| chk20emsr3nb ../engine/source/interfaces/interf/chkstfn3.F
1251!|| chk20msr3n ../engine/source/interfaces/interf/chkstfn3.F
1252!|| chk20msr3nb ../engine/source/interfaces/interf/chkstfn3.F
1253!|| chk23msr3n ../engine/source/interfaces/interf/chkstfn3.F
1254!|| chk23msr3nb ../engine/source/interfaces/interf/chkstfn3.F
1255!|| chk2msr3n ../engine/source/interfaces/interf/chkstfn3.F
1256!|| chk2msr3nb ../engine/source/interfaces/interf/chkstfn3.F
1257!|| chk2msr3np ../engine/source/interfaces/interf/chkstfn3.F
1258!|| chkmsr3n ../engine/source/interfaces/interf/chkstfn3.F
1259!|| chkmsr3nb ../engine/source/interfaces/interf/chkstfn3.F
1260!|| chkslv3 ../engine/source/interfaces/interf/chkstfn3.F
1261!|| chkslv3_t24 ../engine/source/interfaces/interf/chkstfn3.F
1262!|| chkslv3b ../engine/source/interfaces/interf/chkstfn3.F
1263!|| chkslv3c ../engine/source/interfaces/interf/chkstfn3.F
1264!|| setmsr2 ../engine/source/interfaces/interf/chkstfn3.F
1265!|| setmsr3 ../engine/source/interfaces/interf/chkstfn3.F
1266!|| spmd_exchmsr_idel ../engine/source/mpi/interfaces/spmd_exchmsr_idel.F
1267!|| spmd_init_idel ../engine/source/mpi/interfaces/spmd_init_idel.F
1268!||--- uses -----------------------------------------------------
1269!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
1270!|| element_mod ../common_source/modules/elements/element_mod.F90
1271!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1272!|| nodal_arrays_mod ../common_source/modules/nodal_arrays.F90
1273!||====================================================================
1274 SUBROUTINE chkstfn3n(NODES,
1275 1 IPARI ,GEO ,IXS ,IXQ ,IXC ,IXT ,
1276 2 IXP ,IXR ,IXTG ,ITAG ,IPARG ,ITASK ,
1277 3 NEWFRONT,ITAGL ,MS ,IN ,ADM ,ITAB ,
1278 4 ITABM1 ,ADDCNEL ,CNEL ,IND ,NINDEX1 ,NINDEX2 ,
1279 5 NINDEX3 ,NINDEX4 ,TAGEL ,INT24USE,IBUFSEGLO,INDSEGLO ,
1280 6 IBUFS ,INTBUF_TAB,IAD_ELEM)
1281C-----------------------------------------------
1282C M o d u l e s
1283C-----------------------------------------------
1284 USE nodal_arrays_mod
1285 USE elbufdef_mod
1286 USE intbufdef_mod
1287 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
1288C----6---------------------------------------------------------------7---------8
1289C I m p l i c i t T y p e s
1290C-----------------------------------------------
1291#include "implicit_f.inc"
1292#include "comlock.inc"
1293C-----------------------------------------------
1294C C o m m o n B l o c k s
1295C-----------------------------------------------
1296#include "param_c.inc"
1297#include "com01_c.inc"
1298#include "com04_c.inc"
1299#include "task_c.inc"
1300C-----------------------------------------------------------------
1301C D u m m y A r g u m e n t s
1302C-----------------------------------------------
1303 TYPE(nodal_arrays_), intent(inout) :: NODES
1304 INTEGER
1305 . IPARI(NPARI,*), LINDIDEL, LBUFIDEL,
1306 . IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*), IXP(NIXP,*),
1307 . IXR(NIXR,*), IXTG(NIXTG,*),ITAG(*),
1308 . iparg(nparg,*), itask, newfront(*),itagl(*),
1309 . itab(*),itabm1(*),addcnel(0:*),cnel(0:*),
1310 . nindex1(*), nindex2(*),nindex3(*), nindex4(*),
1311 . ind(*), tagel(*),int24use,ibufseglo(*),indseglo(*),
1312 . ibufs(*)
1313 my_real
1314 . geo(npropg,*), ms(*),in(*), adm(*)
1315
1316 TYPE(intbuf_struct_) INTBUF_TAB(*)
1317 INTEGER, DIMENSION(2,NSPMD+1), INTENT(in) :: IAD_ELEM
1318C-----------------------------------------------
1319C L o c a l V a r i a b l e s
1320C-----------------------------------------------
1321 INTEGER I, NG, K, ITY, MLW, NEL, NFT, ISOLNOD,
1322 . KAD, NPT, IHBE, JD(50), KD(50), JFI, KFI, NRTM, NRTS,
1323 . NTY, NSN, ISTRA, N, IDEL, NMN,ILEV,
1324 . N1, N2, N3, N4, SIZE, LENR, IDB, IDBS, INC, IDELKEEP,
1325 . IDEB, OFQ, OFC, OFT, OFP, OFR, OFTG, OFUR, ICNOD, IE,
1326 . NLINSA, NLINMA, NSNE, NMNE, IEXPAN, IRSIZE,
1327 . irecv(nspmd),siz,j,r2r_numel,tagel_r2r_ispmd(nspmd+1),
1328 . ipartr2r,ntagel_r2r_recv,ntagel_r2r_send,ntagel_r2r_sendg,
1329 . tagel_size,level
1330 INTEGER, DIMENSION(:),ALLOCATABLE ::IBUFSEGLO_SAV,INDSEGLO_sav
1331 TYPE(G_BUFEL_) ,POINTER :: GBUF
1332C
1333 OFQ=numels
1334 ofc=ofq+numelq
1335 oft=ofc+numelc
1336 ofp=oft+numelt
1337 ofr=ofp+numelp
1338 oftg=ofr+numelr
1339 ofur=oftg+numeltg
1340C
1341
1342 idb = 1
1343 idbs = 1
1344 DO ng=1,ninter
1345 nty =ipari(7,ng)
1346 idel=ipari(17,ng)
1347 idelkeep=ipari(61,ng)
1348 IF(int24use==1.OR.ninter25/=0)THEN
1349!$OMP SINGLE
1350 indseglo(ng+1)=indseglo(ng)
1351!$OMP END SINGLE
1352 ENDIF
1353
1354 IF((nty==7.OR.nty==10.OR.nty==22.OR.nty==24.OR.nty==25).AND.
1355 . idel>=1) THEN
1356 nsn = ipari(5,ng)
1357 IF(idelkeep /= 1) THEN
1358 IF(nty==24)THEN
1359C T24 E2E requires specific treatments for check
1360C E2E have fictive nodes with NSV > NUMNOD
1361 CALL chkslv3_t24(
1362 . nsn ,intbuf_tab(ng)%NSV,intbuf_tab(ng)%STFNS,itag,itask,
1363 . intbuf_tab(ng)%IS2SE,intbuf_tab(ng)%IRTSE,newfront(ng))
1364 ENDIF
1365 ENDIF
1366 nmn =ipari(6,ng)
1367 nrtm =ipari(4,ng)
1368 inc=4
1369 IF(idel == 1) THEN
1370!$OMP SINGLE
1371 nindex1(ng) = 0
1372!$OMP END SINGLE
1373 CALL chkmsr3nb(
1374 1 nmn ,intbuf_tab(ng)%MSR ,itag ,itask,intbuf_tab(ng)%IRECTM,
1375 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1376 3 ixtg ,ixq ,iparg ,itagl ,
1377 3 nty ,itab ,itabm1 ,cnel ,addcnel ,
1378 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1379 6 ibufs(idbs+4),ind(idb) ,tagel ,ng ,intbuf_tab(ng)%MSEGLO,
1380 7 intbuf_tab(ng)%MVOISIN,indseglo ,ibufseglo)
1381 ELSEIF(idel == 2)THEN
1382!$OMP SINGLE
1383 nindex1(ng) = 0
1384!$OMP END SINGLE
1385 CALL chkmsr3n(
1386 1 nmn ,intbuf_tab(ng)%MSR ,itag ,itask,intbuf_tab(ng)%IRECTM,
1387 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1388 3 ixtg ,ixq ,iparg ,itagl ,
1389 4 nty ,itab ,itabm1 ,cnel ,addcnel ,
1390 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1391 6 ibufs(idbs+4),ind(idb) ,tagel ,ng,
1392 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo ,ibufseglo)
1393 END IF
1394!$OMP SINGLE
1395 nindex2(ng)=0
1396!$OMP END SINGLE
1397
1398 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1399C Partie non parallele
1400!$OMP SINGLE
1401 ibufs(idbs)=idel
1402 ibufs(idbs+1)=nty
1403 ibufs(idbs+2)=nindex1(ng)
1404 ibufs(idbs+3)=nindex2(ng)
1405C Fin Partie non parallele
1406!$OMP END SINGLE
1407 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1408 idb = idb + nindex1(ng) + nindex2(ng)
1409 END IF
1410 ELSEIF(nty == 23.AND.idel>=1) THEN
1411 nsn = ipari(5,ng)
1412 IF(idelkeep /= 1) CALL chkslv3(
1413 . nsn ,intbuf_tab(ng)%NSV,intbuf_tab(ng)%STFNS,itag,itask,
1414 . newfront(ng))
1415 nmn =ipari(6,ng)
1416 nrtm =ipari(4,ng)
1417 inc=4
1418 IF(idel == 1) THEN
1419 CALL chk23msr3nb(
1420 1 nmn ,intbuf_tab(ng)%MSR ,itag ,itask,intbuf_tab(ng)%IRECTM,
1421 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1422 3 ixtg ,ixq ,iparg ,itagl ,
1423 3 nty ,itab ,itabm1 ,cnel ,addcnel ,
1424 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1425 6 ibufs(idbs+4),ind(idb) ,tagel )
1426 ELSEIF(idel == 2)THEN
1427 CALL chk23msr3n(
1428 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1429 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1430 3 ixtg ,ixq ,iparg ,itagl ,
1431 4 nty ,itab ,itabm1 ,cnel ,addcnel ,
1432 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1433 6 ibufs(idbs+4),ind(idb) ,tagel )
1434 END IF
1435 nindex2(ng)=0
1436 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1437C Partie non parallele
1438!$OMP SINGLE
1439 ibufs(idbs)=idel
1440 ibufs(idbs+1)=nty
1441 ibufs(idbs+2)=nindex1(ng)
1442 ibufs(idbs+3)=nindex2(ng)
1443C Fin Partie non parallele
1444!$OMP END SINGLE
1445 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1446 idb = idb + nindex1(ng) + nindex2(ng)
1447 END IF
1448 ELSEIF((nty == 11).AND.idel>=1) THEN
1449 nmn =ipari(6,ng)
1450 nsn =ipari(5,ng)
1451 nrtm =ipari(4,ng)
1452 nrts =ipari(3,ng)
1453 inc=2
1454 IF(idel == 1) THEN
1455Cote main
1456 CALL chk11msr3nb(
1457 1 nmn ,intbuf_tab(ng)%MSR ,itag ,itask ,intbuf_tab(ng)%IRECTM ,
1458 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1459 3 ixtg ,ixq ,iparg ,itagl ,
1460 4 nty ,itab ,itabm1 ,newfront(ng),ixt ,
1461 5 ixp ,ixr ,geo ,1 ,cnel ,
1462 6 addcnel,ofc ,oft ,oftg ,ofur ,
1463 7 ofr ,ofp ,nindex1(ng) ,ibufs(idbs+4),ind(idb),
1464 8 tagel )
1465Cote secnd
1466 CALL chk11msr3nb(
1467 1 nsn ,intbuf_tab(ng)%NSV ,itag ,itask ,intbuf_tab(ng)%IRECTS,
1468 2 nrts ,intbuf_tab(ng)%STFS,itag(numnod+1),ixs ,ixc ,
1469 3 ixtg ,ixq ,iparg ,itagl ,
1470 4 nty ,itab ,itabm1 ,newfront(ng),ixt ,
1471 5 ixp ,ixr ,geo ,2 ,cnel ,
1472 6 addcnel,ofc ,oft ,oftg ,ofur ,
1473 7 ofr ,ofp ,nindex2(ng) ,
1474 + ibufs(idbs+4+nindex1(ng)*inc), ind(idb+nindex1(ng)) ,
1475 8 tagel )
1476 ELSEIF(idel == 2)THEN
1477Cote main
1478 CALL chk11msr3n(
1479 1 nmn ,intbuf_tab(ng)%MSR ,itag ,itask ,intbuf_tab(ng)%IRECTM ,
1480 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1481 3 ixtg ,ixq ,iparg ,itagl ,
1482 4 nty ,newfront(ng) ,ixt ,ixp ,ixr ,
1483 5 geo ,1 ,itab ,itabm1 ,cnel ,
1484 6 addcnel,ofc ,oft ,oftg ,ofur ,
1485 7 ofr ,ofp ,nindex1(ng) ,ibufs(idbs+4),ind(idb),
1486 8 tagel )
1487Cote secnd
1488 CALL chk11msr3n(
1489 1 nsn ,intbuf_tab(ng)%NSV ,itag ,itask ,intbuf_tab(ng)%IRECTS,
1490 2 nrts ,intbuf_tab(ng)%STFS,itag(numnod+1),ixs ,ixc ,
1491 3 ixtg ,ixq ,iparg ,itagl ,
1492 4 nty ,newfront(ng) ,ixt ,ixp ,ixr ,
1493 5 geo ,2 ,itab ,itabm1 ,cnel ,
1494 6 addcnel,ofc ,oft ,oftg ,ofur ,
1495 7 ofr ,ofp ,nindex2(ng) ,
1496 + ibufs(idbs+4+nindex1(ng)*inc), ind(idb+nindex1(ng)) ,
1497 8 tagel )
1498 END IF
1499 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1500C Partie non parallele
1501!$OMP SINGLE
1502 ibufs(idbs)=idel
1503 ibufs(idbs+1)=nty
1504 ibufs(idbs+2)=nindex1(ng)
1505 ibufs(idbs+3)=nindex2(ng)
1506C Fin Partie non parallele
1507!$OMP END SINGLE
1508 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1509 idb = idb + nindex1(ng) + nindex2(ng)
1510 END IF
1511C------
1512 ELSEIF(nty == 21.AND.idel>=1) THEN
1513 nsn = ipari(5,ng)
1514 IF(idelkeep /= 1)
1515 . CALL chkslv3b(nsn,intbuf_tab(ng)%NSV,intbuf_tab(ng)%STFNS,itag,itask)
1516C------
1517 ELSEIF(nty == 20.AND.idel>=1) THEN
1518 nsn = ipari(5,ng)
1519 IF(idelkeep /= 1) CALL chkslv3c(
1520 . nsn ,intbuf_tab(ng)%NSV,intbuf_tab(ng)%STFA,itag,itask,
1521 . newfront(ng),intbuf_tab(ng)%NLG)
1522 nmn =ipari(6,ng)
1523 nrtm =ipari(4,ng)
1524 inc=4
1525 IF(idel == 1) THEN
1526 CALL chk20msr3nb(
1527 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1528 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1529 3 ixtg ,ixq ,iparg ,itagl ,
1530 3 nty ,itab ,itabm1 ,cnel ,addcnel ,
1531 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1532 6 ibufs(idbs+4),ind(idb) ,intbuf_tab(ng)%NLG ,tagel)
1533 ELSEIF(idel == 2)THEN
1534 CALL chk20msr3n(
1535 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1536 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1537 3 ixtg ,ixq ,iparg ,itagl ,
1538 4 nty ,itab ,itabm1 ,cnel ,addcnel ,
1539 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1540 6 ibufs(idbs+4),ind(idb) ,intbuf_tab(ng)%NLG ,tagel)
1541 END IF
1542 nindex2(ng)=0
1543 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1544C Partie non parallele
1545!$OMP SINGLE
1546 ibufs(idbs)=idel
1547 ibufs(idbs+1)=nty
1548 ibufs(idbs+2)=nindex1(ng)
1549 ibufs(idbs+3)=nindex2(ng)
1550C Fin Partie non parallele
1551!$OMP END SINGLE
1552 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1553 idb = idb + nindex1(ng) + nindex2(ng)
1554 END IF
1555C
1556C Adjet type20 part Edge
1557C
1558 nlinsa =ipari(53,ng)
1559 nlinma =ipari(54,ng)
1560 nsne =ipari(55,ng)
1561 nmne =ipari(56,ng)
1562 inc=2
1563 IF(idel == 1) THEN
1564Cote main
1565 CALL chk20emsr3nb(
1566 1 nmne ,intbuf_tab(ng)%MSRL,itag ,itask ,intbuf_tab(ng)%IXLINM ,
1567 2 nlinma ,intbuf_tab(ng)%STF,itag(numnod+1),ixs ,ixc ,
1568 3 ixtg ,ixq ,iparg ,itagl ,
1569 4 nty ,itab ,itabm1 ,newfront(ng),ixt ,
1570 5 ixp ,ixr ,geo ,1 ,cnel ,
1571 6 addcnel,ofc ,oft ,oftg ,ofur ,
1572 7 ofr ,ofp ,nindex3(ng) ,ibufs(idbs+4),ind(idb),
1573 8 intbuf_tab(ng)%NLG ,tagel)
1574Cote secnd
1575 CALL chk20emsr3nb(
1576 1 nsne ,intbuf_tab(ng)%NSVL,itag ,itask ,intbuf_tab(ng)%IXLINS,
1577 2 nlinsa ,intbuf_tab(ng)%STFS,itag(numnod+1),ixs ,ixc ,
1578 3 ixtg ,ixq ,iparg ,itagl ,
1579 4 nty ,itab ,itabm1 ,newfront(ng),ixt ,
1580 5 ixp ,ixr ,geo ,2 ,cnel ,
1581 6 addcnel,ofc ,oft ,oftg ,ofur ,
1582 7 ofr ,ofp ,nindex4(ng) ,
1583 + ibufs(idbs+4+nindex3(ng)*inc), ind(idb+nindex3(ng)) ,
1584 8 intbuf_tab(ng)%NLG ,tagel)
1585 ELSEIF(idel == 2)THEN
1586Cote main
1587 CALL chk20emsr3n(
1588 1 nmne ,intbuf_tab(ng)%MSRL,itag ,itask ,intbuf_tab(ng)%IXLINM ,
1589 2 nlinma ,intbuf_tab(ng)%STF,itag(numnod+1),ixs ,ixc ,
1590 3 ixtg ,ixq ,iparg ,itagl ,
1591 4 nty ,newfront(ng) ,ixt ,ixp ,ixr ,
1592 5 geo ,1 ,itab ,itabm1 ,cnel ,
1593 6 addcnel,ofc ,oft ,oftg ,ofur ,
1594 7 ofr ,ofp ,nindex3(ng) ,ibufs(idbs+4),ind(idb),
1595 8 intbuf_tab(ng)%NLG ,tagel)
1596Cote secnd
1597 CALL chk20emsr3n(
1598 1 nsne ,intbuf_tab(ng)%NSVL,itag ,itask ,intbuf_tab(ng)%IXLINS,
1599 2 nlinsa ,intbuf_tab(ng)%STFS,itag(numnod+1),ixs ,ixc ,
1600 3 ixtg ,ixq ,iparg ,itagl ,
1601 4 nty ,newfront(ng) ,ixt ,ixp ,ixr ,
1602 5 geo ,2 ,itab ,itabm1 ,cnel ,
1603 6 addcnel,ofc ,oft ,oftg ,ofur ,
1604 7 ofr ,ofp ,nindex4(ng) ,
1605 + ibufs(idbs+4+nindex3(ng)*inc), ind(idb+nindex3(ng)) ,
1606 8 intbuf_tab(ng)%NLG ,tagel)
1607 END IF
1608C
1609 IF(nindex3(ng)+nindex4(ng) > 0)THEN
1610C Partie non parallele
1611!$OMP SINGLE
1612 ibufs(idbs)=idel
1613 ibufs(idbs+1)=-nty ! -20 for the LED PARTING REPORT
1614 ibufs(idbs+2)=nindex3(ng)
1615 ibufs(idbs+3)=nindex4(ng)
1616C Fin Partie non parallele
1617!$OMP END SINGLE
1618 idbs = idbs + inc*(nindex3(ng)+nindex4(ng)) + 4
1619 idb = idb + nindex3(ng) + nindex4(ng)
1620 END IF
1621C------
1622 ELSEIF(nty == 3.AND.idel>=1) THEN
1623 IF(ispmd == 0) THEN
1624 nsn = ipari(5,ng)
1625 IF(idelkeep /= 1)
1626 . CALL chkslv3b(nsn,intbuf_tab(ng)%NSV,intbuf_tab(ng)%STFNS,itag,itask)
1627 nmn =ipari(6,ng)
1628 IF(idelkeep /= 1)
1629 . CALL chkslv3b(nmn,intbuf_tab(ng)%MSR,intbuf_tab(ng)%STFNM,itag,itask)
1630 nrts =ipari(3,ng)
1631 nrtm =ipari(4,ng)
1632 ELSE ! interface treated by P0 only
1633 nsn = 0
1634 nmn = 0
1635 nrts = 0
1636 nrtm = 0
1637 END IF
1638 inc=4
1639 IF(idel == 1) THEN
1640C cote secnd
1641 CALL chkmsr3nb(
1642 1 nsn ,intbuf_tab(ng)%NSV,itag ,itask,intbuf_tab(ng)%IRECTS,
1643 2 nrts ,intbuf_tab(ng)%STFS,itag(numnod+1),ixs ,ixc ,
1644 3 ixtg ,ixq ,iparg ,itagl ,
1645 3 nty ,itab ,itabm1 ,cnel ,addcnel ,
1646 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1647 6 ibufs(idbs+4),ind(idb) ,tagel ,ng ,intbuf_tab(ng)%IRTLOS,
1648 7 intbuf_tab(ng)%ILOCM,indseglo ,ibufseglo)
1649C cote main
1650 CALL chkmsr3nb(
1651 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1652 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1653 3 ixtg ,ixq ,iparg ,itagl ,
1654 3 nty ,itab ,itabm1 ,cnel ,addcnel ,
1655 5 ofc ,oft ,oftg ,ofur ,nindex2(ng) ,
1656 6 ibufs(idbs+4+nindex1(ng)*inc),ind(idb+nindex1(ng)),tagel ,
1657 7 ng ,intbuf_tab(ng)%IRTLOS,intbuf_tab(ng)%ILOCM,indseglo,ibufseglo )
1658 ELSEIF(idel == 2)THEN
1659C cote secnd
1660 CALL chkmsr3n(
1661 1 nsn ,intbuf_tab(ng)%NSV,itag ,itask,intbuf_tab(ng)%IRECTS,
1662 2 nrts ,intbuf_tab(ng)%STFS,itag(numnod+1),ixs ,ixc ,
1663 3 ixtg ,ixq ,iparg ,itagl ,
1664 4 nty ,itab ,itabm1 ,cnel ,addcnel ,
1665 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1666 6 ibufs(idbs+4),ind(idb) ,tagel ,ng,
1667 7 intbuf_tab(ng)%IRTLOS,intbuf_tab(ng)%ILOCM,indseglo ,ibufseglo)
1668C cote main
1669 CALL chkmsr3n(
1670 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1671 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1672 3 ixtg ,ixq ,iparg ,itagl ,
1673 4 nty ,itab ,itabm1 ,cnel ,addcnel ,
1674 5 ofc ,oft ,oftg ,ofur ,nindex2(ng) ,
1675 6 ibufs(idbs+4+nindex1(ng)*inc),ind(idb+nindex1(ng)),tagel ,ng,
1676 7 intbuf_tab(ng)%IRTLOS,intbuf_tab(ng)%ILOCM,indseglo ,ibufseglo)
1677 END IF
1678 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1679C Partie non parallele
1680!$OMP SINGLE
1681 ibufs(idbs)=idel
1682 ibufs(idbs+1)=nty
1683 ibufs(idbs+2)=nindex1(ng)
1684 ibufs(idbs+3)=nindex2(ng)
1685C Fin Partie non parallele
1686!$OMP END SINGLE
1687 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1688 idb = idb + nindex1(ng) + nindex2(ng)
1689 END IF
1690 ELSEIF(nty == 5.AND.idel>=1) THEN
1691 IF(ispmd == 0) THEN
1692 nsn = ipari(5,ng)
1693 IF(idelkeep /= 1)
1694 . CALL chkslv3b(nsn,intbuf_tab(ng)%NSV,intbuf_tab(ng)%STFNS,itag,itask)
1695 nmn =ipari(6,ng)
1696 nrtm =ipari(4,ng)
1697 ELSE
1698 nmn = 0
1699 nrtm = 0
1700 END IF
1701 inc=4
1702 IF(idel == 1) THEN
1703 CALL chkmsr3nb(
1704 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1705 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1706 3 ixtg ,ixq ,iparg ,itagl ,
1707 3 nty ,itab ,itabm1 ,cnel ,addcnel ,
1708 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1709 6 ibufs(idbs+4),ind(idb) ,tagel ,ng ,intbuf_tab(ng)%IRTLOS,
1710 7 intbuf_tab(ng)%ILOCM,indseglo ,ibufseglo )
1711 ELSEIF(idel == 2)THEN
1712 CALL chkmsr3n(
1713 1 nmn ,intbuf_tab(ng)%MSR,itag ,itask,intbuf_tab(ng)%IRECTM,
1714 2 nrtm ,intbuf_tab(ng)%STFM,itag(numnod+1),ixs ,ixc ,
1715 3 ixtg ,ixq ,iparg ,itagl ,
1716 4 nty ,itab ,itabm1 ,cnel ,addcnel ,
1717 5 ofc ,oft ,oftg ,ofur ,nindex1(ng) ,
1718 6 ibufs(idbs+4),ind(idb) ,tagel ,ng,
1719 7 intbuf_tab(ng)%IRTLOS,intbuf_tab(ng)%ILOCM,indseglo ,ibufseglo)
1720 END IF
1721 nindex2(ng)=0
1722 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1723C Partie non parallele
1724!$OMP SINGLE
1725 ibufs(idbs)=idel
1726 ibufs(idbs+1)=nty
1727 ibufs(idbs+2)=nindex1(ng)
1728 ibufs(idbs+3)=nindex2(ng)
1729C Fin Partie non parallele
1730!$OMP END SINGLE
1731 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1732 idb = idb + nindex1(ng) + nindex2(ng)
1733 END IF
1734 ELSEIF (nty == 2 .AND. idel > 0) THEN
1735 nsn = ipari(5,ng)
1736 ilev = ipari(20,ng)
1737C
1738 inc=4
1739 IF (idel == 2) THEN
1740 CALL chk2msr3n(
1741 1 nsn ,intbuf_tab(ng)%NSV ,itag,itask,intbuf_tab(ng)%IRECTM,
1742 2 intbuf_tab(ng)%IRTLM,itag(numnod+1),ixs ,ixc ,ixtg ,
1743 3 ixq ,iparg ,itagl,ms ,
1744 4 in ,intbuf_tab(ng)%SMAS ,intbuf_tab(ng)%SINER,adm,cnel ,
1745 5 addcnel ,ofc ,oft ,oftg ,ofur ,
1746 6 tagel ,ilev )
1747 ELSEIF (idel == 1) THEN
1748 CALL chk2msr3nb(
1749 1 nsn ,intbuf_tab(ng)%NSV ,itag ,itask,intbuf_tab(ng)%IRECTM,
1750 2 intbuf_tab(ng)%IRTLM,itag(numnod+1),ixs ,ixc ,ixtg ,
1751 3 ixq ,iparg ,itagl,ms ,
1752 4 in ,intbuf_tab(ng)%SMAS ,intbuf_tab(ng)%SINER,adm,cnel ,
1753 5 addcnel ,ofc ,oft ,oftg ,ofur ,
1754 6 nindex1(ng) ,ibufs(idbs+4) ,ind(idb),tagel,itab ,
1755 7 ilev )
1756
1757 ENDIF
1758C
1759 IF (nspmd > 1 .AND. idel == 2) THEN
1760 n1 = numnod+1
1761 CALL chk2msr3np(
1762 1 nsn ,intbuf_tab(ng)%NSV,itag ,itask ,intbuf_tab(ng)%IRECTM,
1763 2 intbuf_tab(ng)%IRTLM,itag(n1) ,ixs ,ixc ,ixtg ,
1764 3 ixq ,iparg ,itagl ,ms ,
1765 4 in,intbuf_tab(ng)%SMAS,intbuf_tab(ng)%SINER ,adm ,itab ,
1766 5 itabm1 ,cnel ,addcnel,ofc ,oft ,
1767 6 oftg ,ofur,nindex1(ng),ibufs(idbs+4),ind(idb) ,
1768 7 idel)
1769 ELSEIF (idel == 2) THEN
1770 nindex1(ng)=0
1771 ENDIF
1772 nindex2(ng)=0
1773 IF(nindex1(ng)+nindex2(ng) > 0)THEN
1774C Partie non parallele
1775!$OMP SINGLE
1776 ibufs(idbs)=idel
1777 ibufs(idbs+1)=nty
1778 ibufs(idbs+2)=nindex1(ng)
1779 ibufs(idbs+3)=nindex2(ng)
1780C Fin Partie non parallele
1781!$OMP END SINGLE
1782 idbs = idbs + inc*(nindex1(ng)+nindex2(ng)) + 4
1783 idb = idb + nindex1(ng) + nindex2(ng)
1784 END IF
1785C------
1786 ENDIF
1787 ENDDO
1788C
1789 IF(nspmd > 1) THEN
1790
1791C
1792C additional processing in spmd with a single communication point
1793C
1794
1795C Partie non parallele
1796
1797!$OMP SINGLE
1798
1799 CALL spmd_init_idel(idbs-1, irsize, irecv,iad_elem)
1800 CALL spmd_exchmsr_idel(
1801 1 ibufs ,idbs-1 ,ixs ,ixc ,ixtg ,
1802 2 ixq ,iparg ,itagl ,nodes,
1803 3 irsize ,irecv ,cnel ,addcnel,ofc ,
1804 4 oft ,oftg ,ofur ,ofr ,ofp ,
1805 5 idb-1 ,ixp ,ixr ,ixt ,geo ,
1806 6 tagel ,iad_elem)
1807
1808C
1809C finalization of the update stif part
1810C
1811 IF(int24use==1.OR.ninter25/=0)THEN
1812 ALLOCATE(indseglo_sav(ninter+1))
1813 siz=indseglo(ninter+1)-indseglo(1)
1814 ALLOCATE(ibufseglo_sav(siz))
1815
1816 indseglo_sav(1:ninter+1)=indseglo(1:ninter+1)
1817 ibufseglo_sav(1:siz)=ibufseglo(1:siz)
1818
1819 indseglo(1:ninter+1)=0
1820 indseglo(1)=1
1821 ibufseglo(1:siz)=0
1822 ENDIF
1823
1824 idb=1
1825 DO ng=1,ninter
1826 nty =ipari(7,ng)
1827 nrtm =ipari(4,ng)
1828 idel=ipari(17,ng)
1829 IF(int24use==1.OR.ninter25/=0)THEN
1830 indseglo(ng+1)=indseglo(ng)
1831 ENDIF
1832 IF((nty==7.OR.nty==10.OR.nty==5.OR.nty==20.OR.nty==22
1833 + .OR.nty==23.OR.nty==24.OR.nty==25).AND.idel>=1) THEN
1834
1835 IF(int24use==1.OR.ninter25/=0)THEN
1836 siz=indseglo_sav(ng+1)-indseglo_sav(ng)
1837 DO i=1,siz
1838 ibufseglo(indseglo(ng+1))=ibufseglo_sav(indseglo_sav(ng)+i-1)
1839 indseglo(ng+1)=indseglo(ng+1)+1
1840 ENDDO
1841 ENDIF
1842 CALL setmsr3(
1843 1 intbuf_tab(ng)%STFM,nindex1(ng),ibufs(idb),ind(idb),nty,
1844 2 idel ,0, newfront(ng),ng,nrtm,
1845 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo,ibufseglo)
1846 idb = idb+nindex1(ng)
1847 ELSEIF((nty == 11).AND.idel>=1) THEN
1848Cote main
1849 CALL setmsr3(
1850 1 intbuf_tab(ng)%STFM,nindex1(ng),ibufs(idb),ind(idb),nty,
1851 2 idel ,1, newfront(ng),ng,nrtm,
1852 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo,ibufseglo)
1853 idb = idb+nindex1(ng)
1854Cote secnd
1855 CALL setmsr3(
1856 1 intbuf_tab(ng)%STFS,nindex2(ng),ibufs(idb),ind(idb),nty,
1857 2 idel ,2, newfront(ng),ng,nrtm,
1858 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo,ibufseglo)
1859 idb = idb+nindex2(ng)
1860 ELSEIF(nty == 3.AND.idel>=1) THEN
1861C cote secnd
1862 CALL setmsr3(
1863 1 intbuf_tab(ng)%STFS,nindex1(ng),ibufs(idb),ind(idb),nty,
1864 2 idel ,0, newfront(ng),ng,nrtm,
1865 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo,ibufseglo)
1866 idb = idb+nindex1(ng)
1867C cote main
1868 CALL setmsr3(
1869 1 intbuf_tab(ng)%STFM,nindex2(ng),ibufs(idb),ind(idb),nty,
1870 2 idel ,0, newfront(ng),ng,nrtm,
1871 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo,ibufseglo)
1872 idb = idb+nindex2(ng)
1873 ELSEIF(nty == 2.AND.idel/=0)THEN
1874 CALL setmsr2(
1875 1 nindex1(ng) ,ibufs(idb),ind(idb) ,intbuf_tab(ng)%NSV,ms,
1876 2 intbuf_tab(ng)%SMAS,in ,intbuf_tab(ng)%SINER,idel)
1877 idb = idb+nindex1(ng)
1878C
1879 ENDIF
1880C
1881C Adjet type20 part Edge
1882C
1883 IF(nty == 20.AND.idel>=1)THEN
1884Cote main
1885 CALL setmsr3(
1886 1 intbuf_tab(ng)%STF,nindex3(ng),ibufs(idb),ind(idb),-nty, ! -NTY => type20 edge
1887 2 idel ,1, newfront(ng),ng,nrtm,
1888 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo,ibufseglo)
1889 idb = idb+nindex3(ng)
1890Cote secnd
1891 CALL setmsr3(
1892 1 intbuf_tab(ng)%STFS,nindex4(ng),ibufs(idb),ind(idb),-nty, ! -NTY => type20 edge
1893 2 idel ,2, newfront(ng),ng,nrtm,
1894 7 intbuf_tab(ng)%MSEGLO,intbuf_tab(ng)%MVOISIN,indseglo ,ibufseglo)
1895 idb = idb+nindex4(ng)
1896 END IF ! fin type20 edge
1897 ENDDO
1898
1899
1900 IF(int24use > 0.OR.ninter25/=0)THEN
1901 DEALLOCATE(indseglo_sav)
1902 DEALLOCATE(ibufseglo_sav)
1903 ENDIF
1904
1905C Fin Partie non parallele
1906!$OMP END SINGLE
1907
1908 END IF ! SPECIFIC NSPMD> 1
1909C
1910C barrier and reset of idel7nok performed in resol
1911C
1912 RETURN
1913 END
1914
1915!||====================================================================
1916!|| chkmsr3n ../engine/source/interfaces/interf/chkstfn3.F
1917!||--- called by ------------------------------------------------------
1918!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
1919!||--- calls -----------------------------------------------------
1920!|| i24_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
1921!|| i25_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
1922!|| my_barrier ../engine/source/system/machine.f
1923!||--- uses -----------------------------------------------------
1924!|| element_mod ../common_source/modules/elements/element_mod.F90
1925!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
1926!||====================================================================
1927 SUBROUTINE chkmsr3n(
1928 1 NMN ,MSR ,ITAG ,ITASK,IRECT ,
1929 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
1930 3 IXTG ,IXQ ,IPARG ,ITAGL ,
1931 4 NTY ,ITAB ,ITABM1,CNEL ,ADDCNEL ,
1932 5 OFC ,OFT ,OFTG ,OFUR ,NINDG ,
1933 6 BUFS ,NINDEX,TAGEL ,NG,
1934 7 MSEGLO,MVOISIN,
1935 8 INDSEGLO ,IBUFSEGLO)
1936C-----------------------------------------------
1937 USE my_alloc_mod
1938 use element_mod , only : nixs,nixq,nixc,nixtg
1939C-----------------------------------------------
1940C I m p l i c i t T y p e s
1941C-----------------------------------------------
1942#include "implicit_f.inc"
1943#include "comlock.inc"
1944C-----------------------------------------------
1945C C o m m o n B l o c k s
1946C-----------------------------------------------
1947#include "task_c.inc"
1948#include "com01_c.inc"
1949#include "param_c.inc"
1950 COMMON /idelg/icomp
1951 INTEGER ICOMP
1952C-----------------------------------------------
1953C D u m m y A r g u m e n t s
1954C-----------------------------------------------
1955 INTEGER NMN, NTY, MSR(*), ITAG(*), ITASK, IRECT(4,*), NRTM,
1956 . ITAG2(*), IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*),
1957 . IXTG(NIXTG,*), IPARG(NPARG,*), ITAGL(*),ITAB(*),ITABM1(*),
1958 . CNEL(0:*), ADDCNEL(0:*), OFC, OFT, OFTG, OFUR, NINDG,
1959 . nindex(*), bufs(*), tagel(*) ,ng,mseglo(*),mvoisin(*),
1960 . indseglo(*) ,ibufseglo(*)
1961C REAL
1962 my_real
1963 . stf(*)
1964C-----------------------------------------------
1965C L o c a l V a r i a b l e s
1966C-----------------------------------------------
1967 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
1968 . NN, II, IX, K, NIND, N, NIND2, MA_SURF,NIND_SEGLO
1969 INTEGER,DIMENSION(:),ALLOCATABLE :: NINDL
1970 INTEGER,DIMENSION(:),ALLOCATABLE :: IND_SEGLO
1971C REAL
1972C-----------------------------------------------
1973 CALL MY_ALLOC(NINDL,NRTM*2)
1974 CALL MY_ALLOC(IND_SEGLO,NRTM*2)
1975
1976 NMNF = 1 + itask*nmn / nthread
1977 nmnl = (itask+1)*nmn / nthread
1978C
1979 IF(nty/=3.AND.nty/=5) THEN
1980C A - only to optimize type 7, 10 interfaces
1981 DO i = nmnf, nmnl
1982C si tag nul sur noeuds main alors msr(i) = -msr(i)
1983 IF (itag(abs(msr(i))) == 0) THEN
1984 msr(i) = -abs(msr(i))
1985 ENDIF
1986 ENDDO
1987 END IF
1988
1989!$OMP SINGLE
1990 icomp = 0
1991!$OMP END SINGLE
1992C
1993 CALL my_barrier()
1994 IF(nty==7.OR.nty==10.OR.nty==22.OR.nty==24.OR.nty==25) RETURN
1995C
1996 nrtf = 1 + itask*nrtm / nthread
1997 nrtl = (itask+1)*nrtm / nthread
1998C
1999 nind = 0
2000 nind_seglo = 0
2001 DO i = nrtf, nrtl
2002 IF(stf(i)/=zero) THEN
2003 n1 = irect(1,i)
2004 n2 = irect(2,i)
2005 n3 = irect(3,i)
2006 n4 = irect(4,i)
2007 IF(n4 == 0) n4 = n3
2008 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
2009 + itag(n3) == 0.OR.itag(n4) == 0) THEN
2010 stf(i) = zero
2011 IF(nty==24.OR.nty==25)THEN
2012 nind_seglo = nind_seglo + 1
2013 ind_seglo(nind_seglo)=i
2014 ENDIF
2015C CAUTION> = 1 because cumulative node front of tags at 1
2016 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
2017 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
2018 nind = nind + 1
2019 nindl(nind) = i
2020 END IF
2021 END IF
2022 END DO
2023C
2024 DO n = 1, nind
2025 i = nindl(n)
2026 n1 = irect(1,i)
2027 n2 = irect(2,i)
2028 n3 = irect(3,i)
2029 n4 = irect(4,i)
2030 IF(n4 == 0) n4 = n3
2031 DO j = addcnel(n1),addcnel(n1+1)-1
2032 ii = cnel(j)
2033 IF(tagel(ii)<0) THEN ! elt detruit trouve
2034 itagl(n1) = 0
2035 itagl(n2) = 0
2036 itagl(n3) = 0
2037 itagl(n4) = 0
2038 IF(ii<=ofc) THEN ! solide detruit
2039 DO k = 2, 9
2040 ix = ixs(k,ii)
2041 itagl(ix) = 1
2042 END DO
2043 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell detruit
2044 ii = ii - ofc
2045 DO k=2,5
2046 ix = ixc(k,ii)
2047 itagl(ix)=1
2048 END DO
2049 ELSEIF(ii > oftg.AND.ii<=ofur)THEN
2050 ii = ii - oftg
2051 DO k=2,4
2052 ix = ixtg(k,ii)
2053 itagl(ix) = 1
2054 END DO
2055 END IF
2056 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
2057 stf(i) = zero
2058 ma_surf=i
2059
2060
2061 IF(nty==24.OR.nty==25)THEN
2062 nind_seglo = nind_seglo + 1
2063 ind_seglo(nind_seglo)=i
2064 ENDIF
2065
2066 GOTO 400
2067 END IF
2068 END IF
2069 END DO
2070C
2071C nothing found, need to check on other procs in spmd (case of double element or facet with boundary nodes on 2 cpus)
2072 IF(nspmd > 1) THEN
2073#include "lockon.inc"
2074 icomp = icomp + 1
2075 nind2 = icomp
2076#include "lockoff.inc"
2077 nindex(nind2) = i
2078 bufs(4*(nind2-1)+1) = itab(n1)
2079 bufs(4*(nind2-1)+2) = itab(n2)
2080 bufs(4*(nind2-1)+3) = itab(n3)
2081 bufs(4*(nind2-1)+4) = itab(n4)
2082 END IF
2083 400 CONTINUE
2084 END DO
2085 IF(nty==24)THEN
2086 CALL i24_remove_global_segment(ind_seglo,nind_seglo,ng,nrtm,mseglo,mvoisin,1)
2087 IF(nspmd > 1)THEN
2088#include "lockon.inc"
2089 DO i=1,nind_seglo
2090 ibufseglo(indseglo(ng+1))=mseglo(ind_seglo(i))
2091 indseglo(ng+1)=indseglo(ng+1)+1
2092 ENDDO
2093#include "lockoff.inc"
2094 ENDIF
2095 ELSEIF(nty==25)THEN
2096 CALL i25_remove_global_segment(ind_seglo,nind_seglo,ng,nrtm,mseglo,mvoisin,1)
2097 IF(nspmd > 1)THEN
2098#include "lockon.inc"
2099 DO i=1,nind_seglo
2100 ibufseglo(indseglo(ng+1))=mseglo(ind_seglo(i))
2101 indseglo(ng+1)=indseglo(ng+1)+1
2102 ENDDO
2103#include "lockoff.inc"
2104 ENDIF
2105 ENDIF
2106C
2107 CALL my_barrier()
2108C
2109 nindg = icomp
2110C
2111 CALL my_barrier()
2112
2113 DEALLOCATE(nindl)
2114 DEALLOCATE(ind_seglo)
2115C
2116 RETURN
2117 END
2118C
2119!||====================================================================
2120!|| chkmsr3nb ../engine/source/interfaces/interf/chkstfn3.F
2121!||--- called by ------------------------------------------------------
2122!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2123!||--- calls -----------------------------------------------------
2124!|| i24_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
2125!|| i25_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
2126!|| my_barrier ../engine/source/system/machine.F
2127!||--- uses -----------------------------------------------------
2128!|| element_mod ../common_source/modules/elements/element_mod.F90
2129!||====================================================================
2130 SUBROUTINE chkmsr3nb(
2131 1 NMN ,MSR ,ITAG ,ITASK,IRECT ,
2132 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2133 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2134 4 NTY ,ITAB ,ITABM1,CNEL ,ADDCNEL ,
2135 5 OFC ,OFT ,OFTG ,OFUR ,NINDG ,
2136 6 BUFS ,NINDEX,TAGEL ,NG,MSEGLO,
2137 7 MVOISIN,INDSEGLO,IBUFSEGLO)
2138 use element_mod , only : nixs,nixq,nixc,nixtg
2139C-----------------------------------------------
2140C I m p l i c i t T y p e s
2141C-----------------------------------------------
2142#include "implicit_f.inc"
2143#include "comlock.inc"
2144C-----------------------------------------------
2145C C o m m o n B l o c k s
2146C-----------------------------------------------
2147#include "task_c.inc"
2148#include "com01_c.inc"
2149#include "param_c.inc"
2150 COMMON /idelg/icomp
2151 INTEGER ICOMP
2152C-----------------------------------------------
2153C D u m m y A r g u m e n t s
2154C-----------------------------------------------
2155 INTEGER NMN, NTY, NRTM, MSR(*), ITAG(*), ITASK, IRECT(4,*),
2156 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
2157 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itab(*),
2158 . itabm1(*), cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur,
2159 . nindg, nindex(*), bufs(*), tagel(*),
2160 . ng,mseglo(*),mvoisin(*),ibufseglo(*),indseglo(*)
2161C REAL
2162 my_real
2163 . stf(*)
2164C-----------------------------------------------
2165C L o c a l V a r i a b l e s
2166C-----------------------------------------------
2167 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
2168 . NN, II, IX, K, NIND, NIND2, N, NINDL(NRTM),IND_SEGLO(NRTM*2),NIND_SEGLO
2169C REAL
2170C-----------------------------------------------
2171 nmnf = 1 + itask*nmn / nthread
2172 nmnl = (itask+1)*nmn / nthread
2173 icomp = 0
2174C
2175 IF(nty/=3.AND.nty/=5) THEN
2176C A - only to optimize type 7, 10 interfaces
2177 DO i = nmnf, nmnl
2178C si tag nul sur noeuds main alors msr(i) = -msr(i)
2179 IF (itag(abs(msr(i))) == 0) THEN
2180 msr(i) = -abs(msr(i))
2181 END IF
2182 ENDDO
2183 END IF
2184C
2185 CALL my_barrier()
2186 IF(nty==7.OR.nty==10.OR.nty==22.OR.nty==24.OR.nty==25) RETURN
2187C
2188 nrtf = 1 + itask*nrtm / nthread
2189 nrtl = (itask+1)*nrtm / nthread
2190C
2191 nind = 0
2192 nind_seglo = 0
2193 DO i = nrtf, nrtl
2194 IF(stf(i)/=zero) THEN
2195 n1 = irect(1,i)
2196 n2 = irect(2,i)
2197 n3 = irect(3,i)
2198 n4 = irect(4,i)
2199 IF(n4 == 0) n4 = n3
2200 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
2201 + itag(n3) == 0.OR.itag(n4) == 0) THEN
2202 stf(i) = zero
2203 IF(nty==24.OR.nty==25)THEN
2204 nind_seglo = nind_seglo + 1
2205 ind_seglo(nind_seglo)=i
2206 ENDIF
2207C CAUTION> = 1 because cumulative node front of tags at 1
2208 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
2209 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
2210 nind = nind + 1
2211 nindl(nind) = i
2212 END IF
2213 END IF
2214 END DO
2215C
2216 DO n = 1, nind
2217 i = nindl(n)
2218 n1 = irect(1,i)
2219 n2 = irect(2,i)
2220 n3 = irect(3,i)
2221 n4 = irect(4,i)
2222 IF(n4 == 0) n4 = n3
2223 DO j = addcnel(n1),addcnel(n1+1)-1
2224 ii = cnel(j)
2225 IF(tagel(ii) > 0) THEN ! ELT Active finds
2226 itagl(n1) = 0
2227 itagl(n2) = 0
2228 itagl(n3) = 0
2229 itagl(n4) = 0
2230 IF(ii<=ofc) THEN ! solide actif
2231 DO k = 2, 9
2232 ix = ixs(k,ii)
2233 itagl(ix) = 1
2234 END DO
2235 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell actif
2236 ii = ii - ofc
2237 DO k=2,5
2238 ix = ixc(k,ii)
2239 itagl(ix)=1
2240 END DO
2241 ELSEIF(ii > oftg.AND.ii<=ofur)THEN ! triangle actif
2242 ii = ii - oftg
2243 DO k=2,4
2244 ix = ixtg(k,ii)
2245 itagl(ix) = 1
2246 END DO
2247 END IF
2248 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
2249 GOTO 400
2250 END IF
2251 END IF
2252 END DO
2253C If no active element: Stif A 0 in SMP or Mono
2254 IF(nspmd == 1) THEN
2255 stf(i) = zero
2256 IF(nty==24.OR.nty==25)THEN
2257 nind_seglo = nind_seglo + 1
2258 ind_seglo(nind_seglo)=i
2259 ENDIF
2260C If no active element: COMM in SPMD
2261 ELSE
2262#include "lockon.inc"
2263 icomp = icomp + 1
2264 nind2 = icomp
2265#include "lockoff.inc"
2266 nindex(nind2) = i
2267 bufs(4*(nind2-1)+1) = itab(n1)
2268 bufs(4*(nind2-1)+2) = itab(n2)
2269 bufs(4*(nind2-1)+3) = itab(n3)
2270 bufs(4*(nind2-1)+4) = itab(n4)
2271 END IF
2272 400 CONTINUE
2273 END DO
2274C
2275 IF(nty==24)THEN
2276 CALL i24_remove_global_segment(ind_seglo,nind_seglo,ng,nrtm,mseglo,mvoisin,1)
2277 IF(nspmd > 1)THEN
2278#include "lockon.inc"
2279 DO i=1,nind_seglo
2280 ibufseglo(indseglo(ng+1))=mseglo(ind_seglo(i))
2281 indseglo(ng+1)=indseglo(ng+1)+1
2282 ENDDO
2283#include "lockoff.inc"
2284 ENDIF
2285 ELSEIF(nty==25)THEN
2286 CALL i25_remove_global_segment(ind_seglo,nind_seglo,ng,nrtm,mseglo,mvoisin,1)
2287 IF(nspmd > 1)THEN
2288#include "lockon.inc"
2289 DO i=1,nind_seglo
2290 ibufseglo(indseglo(ng+1))=mseglo(ind_seglo(i))
2291 indseglo(ng+1)=indseglo(ng+1)+1
2292 ENDDO
2293#include "lockoff.inc"
2294 ENDIF
2295 ENDIF
2296C
2297 nindg = icomp
2298C
2299 CALL my_barrier()
2300C
2301 RETURN
2302 END
2303C
2304!||====================================================================
2305!|| chk20msr3n ../engine/source/interfaces/interf/chkstfn3.F
2306!||--- called by ------------------------------------------------------
2307!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2308!||--- calls -----------------------------------------------------
2309!|| my_barrier ../engine/source/system/machine.F
2310!||--- uses -----------------------------------------------------
2311!|| element_mod ../common_source/modules/elements/element_mod.F90
2312!||====================================================================
2313 SUBROUTINE chk20msr3n(
2314 1 NMN ,MSR ,ITAG ,ITASK,IRECT ,
2315 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2316 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2317 4 NTY ,ITAB ,ITABM1,CNEL ,ADDCNEL ,
2318 5 OFC ,OFT ,OFTG ,OFUR ,NINDG ,
2319 6 BUFS ,NINDEX,NLG ,TAGEL)
2320 use element_mod , only : nixs,nixq,nixc,nixtg
2321C-----------------------------------------------
2322C I m p l i c i t T y p e s
2323C-----------------------------------------------
2324#include "implicit_f.inc"
2325#include "comlock.inc"
2326C-----------------------------------------------
2327C C o m m o n B l o c k s
2328C-----------------------------------------------
2329#include "task_c.inc"
2330#include "com01_c.inc"
2331#include "param_c.inc"
2332 COMMON /idelg/icomp
2333 INTEGER ICOMP
2334C-----------------------------------------------
2335C D u m m y A r g u m e n t s
2336C-----------------------------------------------
2337 INTEGER NMN, NTY, MSR(*), ITAG(*), ITASK, IRECT(4,*), NRTM,
2338 . ITAG2(*), IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*),
2339 . ixtg(nixtg,*), iparg(nparg,*), itagl(*),itab(*),itabm1(*),
2340 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, nindg,
2341 . nindex(*), bufs(*), nlg(*), tagel(*)
2342C REAL
2343 my_real
2344 . stf(*)
2345C-----------------------------------------------
2346C L o c a l V a r i a b l e s
2347C-----------------------------------------------
2348 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
2349 . NN, II, IX, K, NIND, N, NIND2, N1L, N2L, N3L, N4L,
2350 . NINDL(NRTM)
2351C REAL
2352C-----------------------------------------------
2353 NMNF = 1 + itask*nmn / nthread
2354 nmnl = (itask+1)*nmn / nthread
2355 icomp = 0
2356C
2357 IF(nty/=3.AND.nty/=5) THEN
2358C A - only to optimize type 7, 10, 20 interfaces
2359 DO i = nmnf, nmnl
2360C si tag nul sur noeuds main alors msr(i) = -msr(i)
2361 IF (itag(abs(nlg(abs(msr(i))))) == 0) THEN
2362 msr(i) = -abs(msr(i))
2363 ENDIF
2364 ENDDO
2365 END IF
2366C
2367 CALL my_barrier()
2368C
2369 nrtf = 1 + itask*nrtm / nthread
2370 nrtl = (itask+1)*nrtm / nthread
2371C
2372 nind = 0
2373 DO i = nrtf, nrtl
2374 IF(stf(i)/=zero) THEN
2375 n1l = irect(1,i)
2376 n2l = irect(2,i)
2377 n3l = irect(3,i)
2378 n4l = irect(4,i)
2379 n1 = nlg(n1l)
2380 n2 = nlg(n2l)
2381 n3 = nlg(n3l)
2382 n4 = nlg(n4l)
2383 IF(n4 == 0) n4 = n3
2384 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
2385 + itag(n3) == 0.OR.itag(n4) == 0) THEN
2386 stf(i) = zero
2387C CAUTION> = 1 because cumulative node front of tags at 1
2388 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
2389 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
2390 nind = nind + 1
2391 nindl(nind) = i
2392 END IF
2393 END IF
2394 END DO
2395C
2396 nind2 = 0
2397 DO n = 1, nind
2398 i = nindl(n)
2399 n1l = irect(1,i)
2400 n2l = irect(2,i)
2401 n3l = irect(3,i)
2402 n4l = irect(4,i)
2403 n1 = nlg(n1l)
2404 n2 = nlg(n2l)
2405 n3 = nlg(n3l)
2406 n4 = nlg(n4l)
2407 IF(n4 == 0) n4 = n3
2408 DO j = addcnel(n1),addcnel(n1+1)-1
2409 ii = cnel(j)
2410 IF(tagel(ii)<0) THEN ! elt detruit trouve
2411 itagl(n1) = 0
2412 itagl(n2) = 0
2413 itagl(n3) = 0
2414 itagl(n4) = 0
2415 IF(ii<=ofc) THEN ! solide detruit
2416 DO k = 2, 9
2417 ix = ixs(k,ii)
2418 itagl(ix) = 1
2419 END DO
2420 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell detruit
2421 ii = ii - ofc
2422 DO k=2,5
2423 ix = ixc(k,ii)
2424 itagl(ix)=1
2425 END DO
2426 ELSEIF(ii > oftg.AND.ii<=ofur)THEN
2427 ii = ii - oftg
2428 DO k=2,4
2429 ix = ixtg(k,ii)
2430 itagl(ix) = 1
2431 END DO
2432 END IF
2433 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
2434 stf(i) = zero
2435 GOTO 400
2436 END IF
2437 END IF
2438 END DO
2439C
2440C nothing found, need to check on other procs in spmd (case of double element or facet with boundary nodes on 2 cpus)
2441 IF(nspmd > 1) THEN
2442#include "lockon.inc"
2443 icomp = icomp + 1
2444 nind2 = icomp
2445#include "lockoff.inc"
2446 nindex(nind2) = i
2447 bufs(4*(nind2-1)+1) = itab(n1)
2448 bufs(4*(nind2-1)+2) = itab(n2)
2449 bufs(4*(nind2-1)+3) = itab(n3)
2450 bufs(4*(nind2-1)+4) = itab(n4)
2451 END IF
2452 400 CONTINUE
2453 END DO
2454C
2455 CALL my_barrier()
2456C
2457 nindg = icomp
2458C
2459 CALL my_barrier()
2460C
2461 RETURN
2462 END
2463C
2464!||====================================================================
2465!|| chk20msr3nb ../engine/source/interfaces/interf/chkstfn3.F
2466!||--- called by ------------------------------------------------------
2467!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2468!||--- calls -----------------------------------------------------
2469!|| my_barrier ../engine/source/system/machine.F
2470!||--- uses -----------------------------------------------------
2471!|| element_mod ../common_source/modules/elements/element_mod.F90
2472!||====================================================================
2473 SUBROUTINE chk20msr3nb(
2474 1 NMN ,MSR ,ITAG ,ITASK,IRECT ,
2475 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2476 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2477 4 NTY ,ITAB ,ITABM1,CNEL ,ADDCNEL ,
2478 5 OFC ,OFT ,OFTG ,OFUR ,NINDG ,
2479 6 BUFS ,NINDEX,NLG ,TAGEL)
2480 use element_mod , only : nixs,nixq,nixc,nixtg
2481C-----------------------------------------------
2482C I m p l i c i t T y p e s
2483C-----------------------------------------------
2484#include "implicit_f.inc"
2485#include "comlock.inc"
2486C-----------------------------------------------
2487C C o m m o n B l o c k s
2488C-----------------------------------------------
2489#include "task_c.inc"
2490#include "com01_c.inc"
2491#include "param_c.inc"
2492 COMMON /idelg/icomp
2493 INTEGER ICOMP
2494C-----------------------------------------------
2495C D u m m y A r g u m e n t s
2496C-----------------------------------------------
2497 INTEGER NMN, NTY, NRTM, MSR(*), ITAG(*), ITASK, IRECT(4,*),
2498 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
2499 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itab(*),
2500 . itabm1(*), cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur,
2501 . nindg, nindex(*), bufs(*), nlg(*), tagel(*)
2502C REAL
2503 my_real
2504 . stf(*)
2505C-----------------------------------------------
2506C L o c a l V a r i a b l e s
2507C-----------------------------------------------
2508 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
2509 . NN, II, IX, K, NIND, NIND2, N, N1L, N2L, N3L, N4L,
2510 . nindl(nrtm)
2511C REAL
2512C-----------------------------------------------
2513 nmnf = 1 + itask*nmn / nthread
2514 nmnl = (itask+1)*nmn / nthread
2515 icomp = 0
2516C
2517 IF(nty/=3.AND.nty/=5) THEN
2518C A - only to optimize type 7, 10, 20 interfaces
2519 DO i = nmnf, nmnl
2520C si tag nul sur noeuds main alors msr(i) = -msr(i)
2521 IF (itag(abs(nlg(abs(msr(i))))) == 0) THEN
2522 msr(i) = -abs(msr(i))
2523 END IF
2524 ENDDO
2525 END IF
2526C
2527 CALL my_barrier()
2528C
2529 nrtf = 1 + itask*nrtm / nthread
2530 nrtl = (itask+1)*nrtm / nthread
2531C
2532 nind = 0
2533 DO i = nrtf, nrtl
2534 IF(stf(i)/=zero) THEN
2535 n1l = irect(1,i)
2536 n2l = irect(2,i)
2537 n3l = irect(3,i)
2538 n4l = irect(4,i)
2539 n1 = nlg(n1l)
2540 n2 = nlg(n2l)
2541 n3 = nlg(n3l)
2542 n4 = nlg(n4l)
2543 IF(n4 == 0) n4 = n3
2544 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
2545 + itag(n3) == 0.OR.itag(n4) == 0) THEN
2546 stf(i) = zero
2547C CAUTION> = 1 because cumulative node front of tags at 1
2548 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
2549 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
2550 nind = nind + 1
2551 nindl(nind) = i
2552 END IF
2553 END IF
2554 END DO
2555C
2556 nind2 = 0
2557 DO n = 1, nind
2558 i = nindl(n)
2559 n1l = irect(1,i)
2560 n2l = irect(2,i)
2561 n3l = irect(3,i)
2562 n4l = irect(4,i)
2563 n1 = nlg(n1l)
2564 n2 = nlg(n2l)
2565 n3 = nlg(n3l)
2566 n4 = nlg(n4l)
2567 IF(n4 == 0) n4 = n3
2568 DO j = addcnel(n1),addcnel(n1+1)-1
2569 ii = cnel(j)
2570 IF(tagel(ii) > 0) THEN ! ELT Active finds
2571 itagl(n1) = 0
2572 itagl(n2) = 0
2573 itagl(n3) = 0
2574 itagl(n4) = 0
2575 IF(ii<=ofc) THEN ! solide actif
2576 DO k = 2, 9
2577 ix = ixs(k,ii)
2578 itagl(ix) = 1
2579 END DO
2580 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell actif
2581 ii = ii - ofc
2582 DO k=2,5
2583 ix = ixc(k,ii)
2584 itagl(ix)=1
2585 END DO
2586 ELSEIF(ii > oftg.AND.ii<=ofur)THEN ! triangle actif
2587 ii = ii - oftg
2588 DO k=2,4
2589 ix = ixtg(k,ii)
2590 itagl(ix) = 1
2591 END DO
2592 END IF
2593 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
2594 GOTO 400
2595 END IF
2596 END IF
2597 END DO
2598C If no active element: Stif A 0 in SMP or Mono
2599 IF(nspmd == 1) THEN
2600 stf(i) = zero
2601C If no active element: COMM in SPMD
2602 ELSE
2603#include "lockon.inc"
2604 icomp = icomp + 1
2605 nind2 = icomp
2606#include "lockoff.inc"
2607 nindex(nind2) = i
2608 bufs(4*(nind2-1)+1) = itab(n1)
2609 bufs(4*(nind2-1)+2) = itab(n2)
2610 bufs(4*(nind2-1)+3) = itab(n3)
2611 bufs(4*(nind2-1)+4) = itab(n4)
2612 END IF
2613 400 CONTINUE
2614 END DO
2615C
2616 CALL my_barrier()
2617C
2618 nindg = icomp
2619C
2620 CALL my_barrier()
2621C
2622 RETURN
2623 END
2624
2625!||====================================================================
2626!|| chk11msr3n ../engine/source/interfaces/interf/chkstfn3.F
2627!||--- called by ------------------------------------------------------
2628!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2629!||--- calls -----------------------------------------------------
2630!|| my_barrier ../engine/source/system/machine.F
2631!||--- uses -----------------------------------------------------
2632!|| element_mod ../common_source/modules/elements/element_mod.f90
2633!||====================================================================
2634 SUBROUTINE chk11msr3n(
2635 1 NMN ,MSR ,ITAG ,ITASK ,IRECT ,
2636 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2637 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2638 4 NTY ,NEWFRONT,IXT ,IXP ,IXR ,
2639 5 GEO ,IFL ,ITAB ,ITABM1 ,CNEL ,
2640 6 ADDCNEL,OFC ,OFT ,OFTG ,OFUR ,
2641 7 OFR ,OFP ,NINDG ,BUFS ,NINDEX ,
2642 8 TAGEL )
2643 use element_mod , only : nixs,nixq,nixc,nixtg,nixt,nixr,nixp
2644C-----------------------------------------------
2645C I m p l i c i t T y p e s
2646C-----------------------------------------------
2647#include "implicit_f.inc"
2648#include "comlock.inc"
2649C-----------------------------------------------
2650C C o m m o n B l o c k s
2651C-----------------------------------------------
2652#include "task_c.inc"
2653#include "param_c.inc"
2654 COMMON /idelg/icomp
2655 INTEGER ICOMP
2656C-----------------------------------------------
2657C D u m m y A r g u m e n t s
2658C-----------------------------------------------
2659 INTEGER NMN, NTY, MSR(*), ITAG(*), ITASK, IRECT(2,*), NRTM,
2660 . ITAG2(*), IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*),
2661 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itabm1(*),
2662 . ixt(nixt,*),ixp(nixp,*),ixr(nixr,*),itab(*),
2663 . ifl,newfront,
2664 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, ofr, ofp,
2665 . nindg, nindex(*), bufs(*), tagel(*)
2666C REAL
2667 my_real
2668 . stf(*), geo(npropg,*)
2669C-----------------------------------------------
2670C L o c a l V a r i a b l e s
2671C-----------------------------------------------
2672 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
2673 . nn, ii, ix, k, nind, n, nind2, nindl(nrtm)
2674C REAL
2675C-----------------------------------------------
2676 nmnf = 1 + itask*nmn / nthread
2677 nmnl = (itask+1)*nmn / nthread
2678 icomp = 0
2679C
2680 DO i = nmnf, nmnl
2681C si tag nul sur noeuds main alors msr(i) = -msr(i)
2682 IF (itag(abs(msr(i))) == 0) THEN
2683 msr(i) = -abs(msr(i))
2684 ENDIF
2685 ENDDO
2686C
2687 CALL my_barrier()
2688C
2689 nrtf = 1 + itask*nrtm / nthread
2690 nrtl = (itask+1)*nrtm / nthread
2691C
2692 nind = 0
2693C
2694 nindg = icomp
2695C
2696 RETURN
2697 END
2698C
2699!||====================================================================
2700!|| chk11msr3nb ../engine/source/interfaces/interf/chkstfn3.F
2701!||--- called by ------------------------------------------------------
2702!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2703!||--- calls -----------------------------------------------------
2704!|| my_barrier ../engine/source/system/machine.F
2705!||--- uses -----------------------------------------------------
2706!|| element_mod ../common_source/modules/elements/element_mod.F90
2707!||====================================================================
2708 SUBROUTINE chk11msr3nb(
2709 1 NMN ,MSR ,ITAG ,ITASK ,IRECT ,
2710 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2711 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2712 4 NTY ,ITAB ,ITABM1,NEWFRONT,IXT ,
2713 5 IXP ,IXR ,GEO ,IFL ,CNEL ,
2714 6 ADDCNEL,OFC ,OFT ,OFTG ,OFUR ,
2715 7 OFR ,OFP ,NINDG ,BUFS ,NINDEX,
2716 8 TAGEL )
2717 use element_mod , only : nixs,nixq,nixc,nixtg,nixt,nixr,nixp
2718C-----------------------------------------------
2719C I m p l i c i t T y p e s
2720C-----------------------------------------------
2721#include "implicit_f.inc"
2722#include "comlock.inc"
2723C-----------------------------------------------
2724C C o m m o n B l o c k s
2725C-----------------------------------------------
2726#include "task_c.inc"
2727#include "param_c.inc"
2728 COMMON /idelg/icomp
2729 INTEGER ICOMP
2730C-----------------------------------------------
2731C D u m m y A r g u m e n t s
2732C-----------------------------------------------
2733 INTEGER NMN, NTY, NRTM, IFL, NEWFRONT,
2734 . msr(*), itag(*), itask, irect(2,*),
2735 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
2736 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itab(*),
2737 . itabm1(*),ixt(nixt,*),ixp(nixp,*),ixr(nixr,*),
2738 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, ofr, ofp,
2739 . nindg, nindex(*), bufs(*), tagel(*)
2740C REAL
2741 my_real
2742 . stf(*), geo(npropg,*)
2743C-----------------------------------------------
2744C L o c a l V a r i a b l e s
2745C-----------------------------------------------
2746 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
2747 . nn, ii, ix, k, nind, nind2, n, nindl(nrtm)
2748C REAL
2749C-----------------------------------------------
2750 nmnf = 1 + itask*nmn / nthread
2751 nmnl = (itask+1)*nmn / nthread
2752 icomp = 0
2753C
2754C A - only to optimize type 7, 10 interfaces
2755 DO i = nmnf, nmnl
2756C si tag nul sur noeuds main alors msr(i) = -msr(i)
2757 IF (itag(abs(msr(i))) == 0) THEN
2758 msr(i) = -abs(msr(i))
2759 END IF
2760 ENDDO
2761C
2762 CALL my_barrier()
2763C
2764 nrtf = 1 + itask*nrtm / nthread
2765 nrtl = (itask+1)*nrtm / nthread
2766C
2767 nind = 0
2768C
2769 nind2 = 0
2770C
2771 nindg = 0
2772C
2773 RETURN
2774 END
2775C
2776!||====================================================================
2777!|| chk20emsr3n ../engine/source/interfaces/interf/chkstfn3.F
2778!||--- called by ------------------------------------------------------
2779!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2780!||--- calls -----------------------------------------------------
2781!|| my_barrier ../engine/source/system/machine.F
2782!||--- uses -----------------------------------------------------
2783!|| element_mod ../common_source/modules/elements/element_mod.F90
2784!||====================================================================
2785 SUBROUTINE chk20emsr3n(
2786 1 NMN ,MSR ,ITAG ,ITASK ,IRECT ,
2787 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2788 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2789 4 NTY ,NEWFRONT,IXT ,IXP ,IXR ,
2790 5 GEO ,IFL ,ITAB ,ITABM1 ,CNEL ,
2791 6 ADDCNEL,OFC ,OFT ,OFTG ,OFUR ,
2792 7 OFR ,OFP ,NINDG ,BUFS ,NINDEX ,
2793 8 NLG ,TAGEL )
2794 use element_mod , only : nixs,nixq,nixc,nixtg,nixt,nixr,nixp
2795C-----------------------------------------------
2796C I m p l i c i t T y p e s
2797C-----------------------------------------------
2798#include "implicit_f.inc"
2799#include "comlock.inc"
2800C-----------------------------------------------
2801C C o m m o n B l o c k s
2802C-----------------------------------------------
2803#include "task_c.inc"
2804#include "com01_c.inc"
2805#include "param_c.inc"
2806 COMMON /idelg/icomp
2807 INTEGER ICOMP
2808C-----------------------------------------------
2809C D u m m y A r g u m e n t s
2810C-----------------------------------------------
2811 INTEGER NMN, NTY, MSR(*), ITAG(*), ITASK, IRECT(2,*), NRTM,
2812 . ITAG2(*), IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*),
2813 . IXTG(NIXTG,*), IPARG(NPARG,*), ITAGL(*), ITABM1(*),
2814 . IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),ITAB(*),
2815 . IFL,NEWFRONT,
2816 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, ofr, ofp,
2817 . nindg, nindex(*), bufs(*), nlg(*), tagel(*)
2818C REAL
2819 my_real
2820 . stf(*), geo(npropg,*)
2821C-----------------------------------------------
2822C L o c a l V a r i a b l e s
2823C-----------------------------------------------
2824 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N1L, N2L,
2825 . nn, ii, ix, k, nind, n, nind2, nindl(nrtm)
2826C REAL
2827C-----------------------------------------------
2828 nmnf = 1 + itask*nmn / nthread
2829 nmnl = (itask+1)*nmn / nthread
2830 icomp = 0
2831C
2832 DO i = nmnf, nmnl
2833C si tag nul sur noeuds main alors msr(i) = -msr(i)
2834 IF (itag(abs(nlg(abs(msr(i))))) == 0) THEN
2835 msr(i) = -abs(msr(i))
2836 ENDIF
2837 ENDDO
2838C
2839 CALL my_barrier()
2840C
2841 nrtf = 1 + itask*nrtm / nthread
2842 nrtl = (itask+1)*nrtm / nthread
2843C
2844 nind = 0
2845 DO i = nrtf, nrtl
2846 IF(stf(i)/=zero) THEN
2847 n1l = irect(1,i)
2848 n2l = irect(2,i)
2849 n1 = nlg(n1l)
2850 n2 = nlg(n2l)
2851 IF(itag(n1) == 0.OR.itag(n2) == 0) THEN
2852C Next main or second facet
2853 IF(ifl == 1) THEN
2854 stf(i) = zero
2855 ELSE
2856 stf(i) =-abs(stf(i))
2857 newfront = -1
2858 END IF
2859C CAUTION> = 1 because cumulative node front of tags at 1
2860 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1) THEN
2861 nind = nind + 1
2862 nindl(nind) = i
2863 END IF
2864 END IF
2865 END DO
2866C
2867 nind2 = 0
2868 DO n = 1, nind
2869 i = nindl(n)
2870 n1l = irect(1,i)
2871 n2l = irect(2,i)
2872 n1 = nlg(n1l)
2873 n2 = nlg(n2l)
2874C
2875 DO j = addcnel(n1),addcnel(n1+1)-1
2876 ii = cnel(j)
2877 IF(tagel(ii)<0) THEN ! elt detruit trouve
2878 itagl(n1) = 0
2879 itagl(n2) = 0
2880 IF(ii<=ofc) THEN ! solide detruit
2881 DO k = 2, 9
2882 ix = ixs(k,ii)
2883 itagl(ix) = 1
2884 END DO
2885 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell detruit
2886 ii = ii - ofc
2887 DO k=2,5
2888 ix = ixc(k,ii)
2889 itagl(ix)=1
2890 END DO
2891 ELSEIF(ii > oftg.AND.ii<=ofur)THEN ! triangle detruit
2892 ii = ii - oftg
2893 DO k=2,4
2894 ix = ixtg(k,ii)
2895 itagl(ix) = 1
2896 END DO
2897 ELSEIF(ii > oft.AND.ii<=ofp)THEN ! truss detruit
2898 ii = ii - oft
2899 DO k=2,3
2900 ix = ixt(k,ii)
2901 itagl(ix) = 1
2902 ENDDO
2903 ELSEIF(ii > ofp.AND.ii<=ofr)THEN ! beam destroyed
2904 ii = ii - ofp
2905 DO k=2,3
2906 ix = ixp(k,ii)
2907 itagl(ix) = 1
2908 ENDDO
2909 ELSEIF(ii > ofr.AND.ii<=oftg)THEN ! Spring destroyed
2910 ii = ii - ofr
2911 DO k=2,3
2912 ix = ixr(k,ii)
2913 itagl(ix) = 1
2914 ENDDO
2915 IF(nint(geo(12,ixr(1,ii))) == 12) THEN ! Spring destroyed
2916 ix = ixr(4,ii)
2917 itagl(ix) = 1
2918 ENDIF
2919 END IF
2920 IF(itagl(n1)+itagl(n2) == 2)THEN
2921C Next main or second facet
2922 IF(ifl == 1) THEN
2923 stf(i) = zero
2924 ELSE
2925 stf(i) =-abs(stf(i))
2926 newfront = -1
2927 END IF
2928 GOTO 400
2929 END IF
2930 END IF
2931 END DO
2932C
2933C We have not found anything, we have to see on the other SPMD procs
2934 IF(nspmd > 1) THEN
2935#include "lockon.inc"
2936 icomp = icomp + 1
2937 nind2 = icomp
2938#include "lockoff.inc"
2939 nindex(nind2) = i
2940 bufs(2*(nind2-1)+1) = itab(n1)
2941 bufs(2*(nind2-1)+2) = itab(n2)
2942 END IF
2943 400 CONTINUE
2944 END DO
2945C
2946 CALL my_barrier()
2947C
2948 nindg = icomp
2949C
2950 CALL my_barrier()
2951c NINDG = NIND2
2952
2953C
2954 RETURN
2955 END
2956C
2957!||====================================================================
2958!|| chk20emsr3nb ../engine/source/interfaces/interf/chkstfn3.F
2959!||--- called by ------------------------------------------------------
2960!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
2961!||--- calls -----------------------------------------------------
2962!|| my_barrier ../engine/source/system/machine.F
2963!||--- uses -----------------------------------------------------
2964!|| element_mod ../common_source/modules/elements/element_mod.F90
2965!||====================================================================
2966 SUBROUTINE chk20emsr3nb(
2967 1 NMN ,MSR ,ITAG ,ITASK ,IRECT ,
2968 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
2969 3 IXTG ,IXQ ,IPARG ,ITAGL ,
2970 4 NTY ,ITAB ,ITABM1,NEWFRONT,IXT ,
2971 5 IXP ,IXR ,GEO ,IFL ,CNEL ,
2972 6 ADDCNEL,OFC ,OFT ,OFTG ,OFUR ,
2973 7 OFR ,OFP ,NINDG ,BUFS ,NINDEX,
2974 8 NLG ,TAGEL )
2975 use element_mod , only : nixs,nixq,nixc,nixtg,nixt,nixr,nixp
2976C-----------------------------------------------
2977C I m p l i c i t T y p e s
2978C-----------------------------------------------
2979#include "implicit_f.inc"
2980#include "comlock.inc"
2981C-----------------------------------------------
2982C C o m m o n B l o c k s
2983C-----------------------------------------------
2984#include "task_c.inc"
2985#include "com01_c.inc"
2986#include "param_c.inc"
2987 COMMON /idelg/icomp
2988 INTEGER ICOMP
2989C-----------------------------------------------
2990C D u m m y A r g u m e n t s
2991C-----------------------------------------------
2992 INTEGER NMN, NTY, NRTM, IFL, NEWFRONT,
2993 . msr(*), itag(*), itask, irect(2,*),
2994 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
2995 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itab(*),
2996 . itabm1(*),ixt(nixt,*),ixp(nixp,*),ixr(nixr,*),
2997 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, ofr, ofp,
2998 . nindg, nindex(*), bufs(*), nlg(*), tagel(*)
2999C REAL
3000 my_real
3001 . stf(*), geo(npropg,*)
3002C-----------------------------------------------
3003C L o c a l V a r i a b l e s
3004C-----------------------------------------------
3005 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N1L, N2L,
3006 . nn, ii, ix, k, nind, nind2, n, nindl(nrtm)
3007C REAL
3008C-----------------------------------------------
3009 nmnf = 1 + itask*nmn / nthread
3010 nmnl = (itask+1)*nmn / nthread
3011 icomp = 0
3012C
3013C A - only to optimize type 7, 10 interfaces
3014 DO i = nmnf, nmnl
3015C si tag nul sur noeuds main alors msr(i) = -msr(i)
3016 IF (itag(abs(nlg(abs(msr(i))))) == 0) THEN
3017 msr(i) = -abs(msr(i))
3018 END IF
3019 ENDDO
3020C
3021 CALL my_barrier()
3022C
3023 nrtf = 1 + itask*nrtm / nthread
3024 nrtl = (itask+1)*nrtm / nthread
3025C
3026 nind = 0
3027 DO i = nrtf, nrtl
3028 IF(stf(i)/=zero) THEN
3029 n1l = irect(1,i)
3030 n2l = irect(2,i)
3031 n1 = nlg(n1l)
3032 n2 = nlg(n2l)
3033 IF(itag(n1) == 0.OR.itag(n2) == 0) THEN
3034C Next main or second facet
3035 IF(ifl == 1) THEN
3036 stf(i) = zero
3037 ELSE
3038 stf(i) =-abs(stf(i))
3039 newfront = -1
3040 END IF
3041C CAUTION> = 1 because cumulative node front of tags at 1
3042 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1) THEN
3043 nind = nind + 1
3044 nindl(nind) = i
3045 END IF
3046 END IF
3047 END DO
3048C
3049 nind2 = 0
3050 DO n = 1, nind
3051 i = nindl(n)
3052 n1l = irect(1,i)
3053 n2l = irect(2,i)
3054 n1 = nlg(n1l)
3055 n2 = nlg(n2l)
3056C
3057 DO j = addcnel(n1),addcnel(n1+1)-1
3058 ii = cnel(j)
3059 IF(tagel(ii) > 0) THEN ! ELT Active finds
3060 itagl(n1) = 0
3061 itagl(n2) = 0
3062 IF(ii<=ofc) THEN ! solide actif
3063 DO k = 2, 9
3064 ix = ixs(k,ii)
3065 itagl(ix) = 1
3066 END DO
3067 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell actif
3068 ii = ii - ofc
3069 DO k=2,5
3070 ix = ixc(k,ii)
3071 itagl(ix)=1
3072 END DO
3073 ELSEIF(ii > oftg.AND.ii<=ofur)THEN ! triangle actif
3074 ii = ii - oftg
3075 DO k=2,4
3076 ix = ixtg(k,ii)
3077 itagl(ix) = 1
3078 END DO
3079 ELSEIF(ii > oft.AND.ii<=ofp)THEN ! truss actif
3080 ii = ii - oft
3081 DO k=2,3
3082 ix = ixt(k,ii)
3083 itagl(ix) = 1
3084 ENDDO
3085 ELSEIF(ii > ofp.AND.ii<=ofr)THEN ! active beam
3086 ii = ii - ofp
3087 DO k=2,3
3088 ix = ixp(k,ii)
3089 itagl(ix) = 1
3090 ENDDO
3091 ELSEIF(ii > ofr.AND.ii<=oftg)THEN ! active
3092 ii = ii - ofr
3093 DO k=2,3
3094 ix = ixr(k,ii)
3095 itagl(ix) = 1
3096 ENDDO
3097 IF(nint(geo(12,ixr(1,ii))) == 12) THEN ! active
3098 ix = ixr(4,ii)
3099 itagl(ix) = 1
3100 ENDIF
3101 END IF
3102 IF(itagl(n1)+itagl(n2) == 2)THEN
3103 GOTO 400
3104 ENDIF
3105 ENDIF
3106 ENDDO
3107C
3108C If no active element: Stif A 0
3109 IF(nspmd == 1) THEN
3110C Next main or second facet
3111 IF(ifl == 1) THEN
3112 stf(i) = zero
3113 ELSE
3114 stf(i) =-abs(stf(i))
3115 newfront = -1
3116 END IF
3117 ELSE
3118#include "lockon.inc"
3119 icomp = icomp + 1
3120 nind2 = icomp
3121#include "lockoff.inc"
3122 nindex(nind2) = i
3123 bufs(2*(nind2-1)+1) = itab(n1)
3124 bufs(2*(nind2-1)+2) = itab(n2)
3125 END IF
3126C
3127 400 CONTINUE
3128 END DO
3129C
3130 CALL my_barrier()
3131C
3132 nindg = icomp
3133C
3134 CALL my_barrier()
3135C
3136 RETURN
3137 END
3138C
3139!||====================================================================
3140!|| chk2msr3n ../engine/source/interfaces/interf/chkstfn3.F
3141!||--- called by ------------------------------------------------------
3142!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
3143!||--- calls -----------------------------------------------------
3144!|| my_barrier ../engine/source/system/machine.F
3145!||--- uses -----------------------------------------------------
3146!|| element_mod ../common_source/modules/elements/element_mod.F90
3147!||====================================================================
3148 SUBROUTINE chk2msr3n(
3149 1 NSN ,NSV ,ITAG ,ITASK,IRECT,
3150 2 IRTL ,ITAG2,IXS ,IXC ,IXTG ,
3151 3 IXQ ,IPARG,ITAGL,MS ,
3152 4 IN ,SMAS ,SINER,ADM ,CNEL ,
3153 5 ADDCNEL,OFC ,OFT ,OFTG ,OFUR ,
3154 6 TAGEL ,ILEV )
3155 use element_mod , only : nixs,nixq,nixc,nixtg
3156C-----------------------------------------------
3157C I m p l i c i t T y p e s
3158C-----------------------------------------------
3159#include "implicit_f.inc"
3160C-----------------------------------------------
3161C C o m m o n B l o c k s
3162C-----------------------------------------------
3163#include "task_c.inc"
3164#include "param_c.inc"
3165C-----------------------------------------------
3166C D u m m y A r g u m e n t s
3167C-----------------------------------------------
3168 INTEGER NSN, NSV(*), ITAG(*), ITASK, IRECT(4,*), IRTL(*),
3169 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
3170 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), tagel(*),
3171 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur,ilev
3172C REAL
3173 my_real
3174 . ms(*),in(*),smas(*),siner(*),adm(*)
3175C-----------------------------------------------
3176C L o c a l V a r i a b l e s
3177C-----------------------------------------------
3178 INTEGER I, J, NSNF, NSNL, IS, L, N1, N2, N3, N4,
3179 . ii, ix, k, nind, n, nindex(nsn)
3180C REAL
3181C-----------------------------------------------
3182C
3183 CALL my_barrier()
3184C
3185 nsnf = 1 + itask*nsn / nthread
3186 nsnl = (itask+1)*nsn / nthread
3187C
3188 nind = 0
3189 DO i = nsnf, nsnl
3190 is=nsv(i)
3191 IF (is > 0) THEN
3192 l =irtl(i)
3193 n1 = irect(1,l)
3194 n2 = irect(2,l)
3195 n3 = irect(3,l)
3196 n4 = irect(4,l)
3197 IF (n4 == 0) n4 = n3
3198 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
3199 + itag(n3) == 0.OR.itag(n4) == 0) THEN
3200 nsv(i) = -nsv(i)
3201 IF (ilev /= 25 .and. ilev /= 26) THEN
3202 ms(is) = smas(i)
3203 in(is) = siner(i)
3204 ENDIF
3205C CAUTION> = 1 because cumulative node front of tags at 1
3206 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
3207 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
3208 nind = nind + 1
3209 nindex(nind) = i
3210 END IF
3211 END IF
3212 END DO
3213C
3214 DO n = 1, nind
3215 i = nindex(n)
3216 is= nsv(i)
3217 l =irtl(i)
3218 n1 = irect(1,l)
3219 n2 = irect(2,l)
3220 n3 = irect(3,l)
3221 n4 = irect(4,l)
3222 IF(n4 == 0) n4 = n3
3223C
3224 DO j = addcnel(n1),addcnel(n1+1)-1
3225 ii = cnel(j)
3226 IF(tagel(ii)<0) THEN ! elt detruit trouve
3227 itagl(n1) = 0
3228 itagl(n2) = 0
3229 itagl(n3) = 0
3230 itagl(n4) = 0
3231 IF(ii<=ofc) THEN ! solide detruit
3232 DO k = 2, 9
3233 ix = ixs(k,ii)
3234 itagl(ix) = 1
3235 END DO
3236 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell detruit
3237 ii = ii - ofc
3238 DO k=2,5
3239 ix = ixc(k,ii)
3240 itagl(ix)=1
3241 END DO
3242 ELSEIF(ii > oftg.AND.ii<=ofur)THEN
3243 ii = ii - oftg
3244 DO k=2,4
3245 ix = ixtg(k,ii)
3246 itagl(ix) = 1
3247 END DO
3248 END IF
3249 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
3250 nsv(i) = -nsv(i)
3251 IF (ilev /= 25 .and. ilev /= 26) THEN
3252 ms(is) = smas(i)
3253 in(is) = siner(i)
3254 ENDIF
3255 GOTO 400
3256 END IF
3257 END IF
3258 END DO
3259 400 CONTINUE
3260 END DO
3261C
3262 RETURN
3263 END
3264C
3265!||====================================================================
3266!|| chk2msr3nb ../engine/source/interfaces/interf/chkstfn3.F
3267!||--- called by ------------------------------------------------------
3268!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
3269!||--- calls -----------------------------------------------------
3270!|| my_barrier ../engine/source/system/machine.F
3271!||--- uses -----------------------------------------------------
3272!|| element_mod ../common_source/modules/elements/element_mod.F90
3273!||====================================================================
3274 SUBROUTINE chk2msr3nb(
3275 1 NSN ,NSV ,ITAG ,ITASK,IRECT,
3276 2 IRTL ,ITAG2,IXS ,IXC ,IXTG ,
3277 3 IXQ ,IPARG,ITAGL,MS ,
3278 4 IN ,SMAS ,SINER,ADM ,CNEL ,
3279 5 ADDCNEL,OFC ,OFT ,OFTG ,OFUR ,
3280 6 NINDG ,BUFS ,NINDEX,TAGEL,ITAB ,
3281 7 ILEV )
3282 use element_mod , only : nixs,nixq,nixc,nixtg
3283C-----------------------------------------------
3284C I m p l i c i t T y p e s
3285C-----------------------------------------------
3286#include "implicit_f.inc"
3287#include "comlock.inc"
3288C-----------------------------------------------
3289C C o m m o n B l o c k s
3290C-----------------------------------------------
3291#include "task_c.inc"
3292#include "com01_c.inc"
3293#include "param_c.inc"
3294 COMMON /idelg/icomp
3295 INTEGER ICOMP
3296C-----------------------------------------------
3297C D u m m y A r g u m e n t s
3298C-----------------------------------------------
3299 INTEGER NSN, NSV(*), ITAG(*), ITASK, IRECT(4,*), IRTL(*),
3300 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
3301 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), tagel(*),
3302 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, ilev,
3303 . nindg, nindex(*), bufs(*),itab(*)
3304C REAL
3305 my_real
3306 . ms(*),in(*),smas(*),siner(*),adm(*)
3307C-----------------------------------------------
3308C L o c a l V a r i a b l e s
3309C-----------------------------------------------
3310 INTEGER I, J, NSNF, NSNL, IS, L, N1, N2, N3, N4,
3311 . ii, ix, k, nind, n, nindex0(nsn),nind2
3312C REAL
3313C-----------------------------------------------
3314C
3315 icomp = 0
3316 CALL my_barrier()
3317C
3318 nsnf = 1 + itask*nsn / nthread
3319 nsnl = (itask+1)*nsn / nthread
3320C
3321 nind = 0
3322 DO i = nsnf, nsnl
3323 is=nsv(i)
3324 IF(is > 0) THEN
3325 l =irtl(i)
3326 n1 = irect(1,l)
3327 n2 = irect(2,l)
3328 n3 = irect(3,l)
3329 n4 = irect(4,l)
3330 IF(n4 == 0) n4 = n3
3331 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
3332 + itag(n3) == 0.OR.itag(n4) == 0) THEN
3333 nsv(i) = -nsv(i)
3334 IF (ilev /= 25 .and. ilev /= 26) THEN
3335 ms(is) = smas(i)
3336 in(is) = siner(i)
3337 ENDIF
3338C CAUTION> = 1 because cumulative node front of tags at 1
3339 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
3340 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
3341 nind = nind + 1
3342 nindex0(nind) = i
3343 END IF
3344 END IF
3345 END DO
3346C
3347 DO n = 1, nind
3348 i = nindex0(n)
3349 is = nsv(i)
3350 l = irtl(i)
3351 n1 = irect(1,l)
3352 n2 = irect(2,l)
3353 n3 = irect(3,l)
3354 n4 = irect(4,l)
3355 IF(n4 == 0) n4 = n3
3356 DO j = addcnel(n1),addcnel(n1+1)-1
3357 ii = cnel(j)
3358 IF(tagel(ii) > 0) THEN ! ELT Active finds
3359 itagl(n1) = 0
3360 itagl(n2) = 0
3361 itagl(n3) = 0
3362 itagl(n4) = 0
3363 IF(ii<=ofc) THEN ! solide actif
3364 DO k = 2, 9
3365 ix = ixs(k,ii)
3366 itagl(ix) = 1
3367 END DO
3368 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell actif
3369 ii = ii - ofc
3370 DO k=2,5
3371 ix = ixc(k,ii)
3372 itagl(ix)=1
3373 END DO
3374 ELSEIF(ii > oftg.AND.ii<=ofur)THEN ! triangle actif
3375 ii = ii - oftg
3376 DO k=2,4
3377 ix = ixtg(k,ii)
3378 itagl(ix) = 1
3379 END DO
3380 END IF
3381 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
3382 GOTO 400
3383 END IF
3384 END IF
3385 END DO
3386C If no active element: Stif A 0 in SMP or Mono
3387 IF(nspmd == 1) THEN
3388 nsv(i) = -nsv(i)
3389 IF (ilev /= 25 .and. ilev /= 26) THEN
3390 ms(is) = smas(i)
3391 in(is) = siner(i)
3392 ENDIF
3393C If no active element: COMM in SPMD
3394 ELSE
3395#include "lockon.inc"
3396 icomp = icomp + 1
3397 nind2 = icomp
3398#include "lockoff.inc"
3399 nindex(nind2) = i
3400 bufs(4*(nind2-1)+1) = itab(n1)
3401 bufs(4*(nind2-1)+2) = itab(n2)
3402 bufs(4*(nind2-1)+3) = itab(n3)
3403 bufs(4*(nind2-1)+4) = itab(n4)
3404 END IF
3405 400 CONTINUE
3406 END DO
3407C
3408 CALL my_barrier()
3409C
3410 nindg = icomp
3411C
3412 CALL my_barrier()
3413C
3414 RETURN
3415 END
3416C
3417!||====================================================================
3418!|| chk2msr3np ../engine/source/interfaces/interf/chkstfn3.F
3419!||--- called by ------------------------------------------------------
3420!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
3421!||--- calls -----------------------------------------------------
3422!|| my_barrier ../engine/source/system/machine.F
3423!||--- uses -----------------------------------------------------
3424!|| element_mod ../common_source/modules/elements/element_mod.F90
3425!||====================================================================
3426 SUBROUTINE chk2msr3np(
3427 1 NSN ,NSV ,ITAG ,ITASK,IRECT ,
3428 2 IRTL ,ITAG2,IXS ,IXC ,IXTG ,
3429 3 IXQ ,IPARG,ITAGL,MS ,
3430 4 IN ,SMAS ,SINER ,ADM ,ITAB ,
3431 5 ITABM1,CNEL ,ADDCNEL,OFC ,OFT ,
3432 6 OFTG ,OFUR ,NINDG ,BUFS ,INDEX ,
3433 7 IDEL )
3434 use element_mod , only : nixs,nixq,nixc,nixtg
3435C-----------------------------------------------
3436C I m p l i c i t T y p e s
3437C-----------------------------------------------
3438#include "implicit_f.inc"
3439#include "comlock.inc"
3440C-----------------------------------------------
3441C C o m m o n B l o c k s
3442C-----------------------------------------------
3443#include "task_c.inc"
3444#include "param_c.inc"
3445 COMMON /idelg/icomp
3446 INTEGER ICOMP
3447C-----------------------------------------------
3448C D u m m y A r g u m e n t s
3449C-----------------------------------------------
3450 INTEGER NSN, NSV(*), ITAG(*), ITASK, IRECT(4,*), IRTL(*),
3451 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
3452 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itab(*),
3453 . itabm1(*), cnel(0:*), addcnel(0:*),
3454 . ofc, oft, oftg, ofur, nindg,
3455 . index(*), bufs(*),idel
3456C REAL
3457 my_real
3458 . ms(*),in(*),smas(*),siner(*),adm(*)
3459C-----------------------------------------------
3460C L o c a l V a r i a b l e s
3461C-----------------------------------------------
3462 INTEGER I, NSNF, NSNL, IS, L, N1, N2, N3, N4,
3463 . nn, ii, nindex, j
3464C REAL
3465C-----------------------------------------------
3466 icomp = 0
3467 CALL my_barrier()
3468C
3469 nsnf = 1 + itask*nsn / nthread
3470 nsnl = (itask+1)*nsn / nthread
3471C
3472 DO i = nsnf, nsnl
3473 is=nsv(i)
3474 IF(is > 0) THEN
3475C
3476C the destroyed facet is possibly on another processor
3477C
3478 l =irtl(i)
3479 n1 = irect(1,l)
3480 n2 = irect(2,l)
3481 n3 = irect(3,l)
3482 n4 = irect(4,l)
3483 IF(n4 == 0) n4 = n3
3484C CAUTION> = 1 because cumulative node front of tags at 1
3485 IF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
3486 + itag2(n3)>=1.AND.itag2(n4)>=1 .AND. idel== 2) THEN
3487#include "lockon.inc"
3488 icomp = icomp + 1
3489 nindex = icomp
3490#include "lockoff.inc"
3491 index(nindex) = i
3492 bufs(4*(nindex-1)+1) = itab(n1)
3493 bufs(4*(nindex-1)+2) = itab(n2)
3494 bufs(4*(nindex-1)+3) = itab(n3)
3495 bufs(4*(nindex-1)+4) = itab(n4)
3496C CAUTION> = 1 because cumulative node front of tags at 1
3497 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
3498 + itag2(n3)>=1.AND.itag2(n4)>=1 .AND. idel== 1) THEN
3499#include "lockon.inc"
3500 icomp = icomp + 1
3501 nindex = icomp
3502#include "lockoff.inc"
3503 index(nindex) = i
3504 bufs(4*(nindex-1)+1) = itab(n1)
3505 bufs(4*(nindex-1)+2) = itab(n2)
3506 bufs(4*(nindex-1)+3) = itab(n3)
3507 bufs(4*(nindex-1)+4) = itab(n4)
3508 ENDIF
3509 ENDIF
3510 ENDDO
3511C
3512 CALL my_barrier()
3513C
3514 nindg = icomp
3515C
3516 CALL my_barrier()
3517C
3518 RETURN
3519 END
3520C
3521!||====================================================================
3522!|| chk23msr3n ../engine/source/interfaces/interf/chkstfn3.F
3523!||--- called by ------------------------------------------------------
3524!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
3525!||--- calls -----------------------------------------------------
3526!|| my_barrier ../engine/source/system/machine.F
3527!||--- uses -----------------------------------------------------
3528!|| element_mod ../common_source/modules/elements/element_mod.F90
3529!||====================================================================
3530 SUBROUTINE chk23msr3n(
3531 1 NMN ,MSR ,ITAG ,ITASK,IRECT ,
3532 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
3533 3 IXTG ,IXQ ,IPARG ,ITAGL ,
3534 4 NTY ,ITAB ,ITABM1,CNEL ,ADDCNEL ,
3535 5 OFC ,OFT ,OFTG ,OFUR ,NINDG ,
3536 6 BUFS ,NINDEX,TAGEL )
3537 use element_mod , only : nixs,nixq,nixc,nixtg
3538C-----------------------------------------------
3539C I m p l i c i t T y p e s
3540C-----------------------------------------------
3541#include "implicit_f.inc"
3542#include "comlock.inc"
3543C-----------------------------------------------
3544C C o m m o n B l o c k s
3545C-----------------------------------------------
3546#include "task_c.inc"
3547#include "com01_c.inc"
3548#include "param_c.inc"
3549 COMMON /idelg/icomp
3550 INTEGER ICOMP
3551C-----------------------------------------------
3552C D u m m y A r g u m e n t s
3553C-----------------------------------------------
3554 INTEGER NMN, NTY, MSR(*), ITAG(*), ITASK, IRECT(4,*), NRTM,
3555 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
3556 . ixtg(nixtg,*), iparg(nparg,*), itagl(*),itab(*),itabm1(*),
3557 . cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur, nindg,
3558 . nindex(*), bufs(*), tagel(*)
3559C REAL
3560 my_real
3561 . stf(*)
3562C-----------------------------------------------
3563C L o c a l V a r i a b l e s
3564C-----------------------------------------------
3565 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
3566 . nn, ii, ix, k, nind, n, nind2, nindl(nrtm)
3567C REAL
3568C-----------------------------------------------
3569 nmnf = 1 + itask*nmn / nthread
3570 nmnl = (itask+1)*nmn / nthread
3571 icomp = 0
3572C
3573c arebrancher IF(NTY/=3.AND.NTY/=5) THEN
3574c Arebrancherc Place A - Only to optimize Type 7 interfaces, 10
3575c arebrancher DO I = NMNF, NMNL
3576c arebrancherC si tag nul sur noeuds main alors msr(i) = -msr(i)
3577c arebrancher IF (ITAG(ABS(MSR(I))) == 0) THEN
3578c arebrancher MSR(I) = -ABS(MSR(I))
3579c arebrancher ENDIF
3580c arebrancher ENDDO
3581c arebrancher END IF
3582C
3583 CALL my_barrier()
3584C
3585 nrtf = 1 + itask*nrtm / nthread
3586 nrtl = (itask+1)*nrtm / nthread
3587C
3588 nind = 0
3589 DO i = nrtf, nrtl
3590 IF(stf(i)/=zero) THEN
3591 n1 = msr(irect(1,i))
3592 n2 = msr(irect(2,i))
3593 n3 = msr(irect(3,i))
3594 n4 = msr(irect(4,i))
3595 IF(n4 == 0) n4 = n3
3596 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
3597 + itag(n3) == 0.OR.itag(n4) == 0) THEN
3598 stf(i) = zero
3599C CAUTION> = 1 because cumulative node front of tags at 1
3600 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
3601 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
3602 nind = nind + 1
3603 nindl(nind) = i
3604 END IF
3605 END IF
3606 END DO
3607C
3608 DO n = 1, nind
3609 i = nindl(n)
3610 n1 = msr(irect(1,i))
3611 n2 = msr(irect(2,i))
3612 n3 = msr(irect(3,i))
3613 n4 = msr(irect(4,i))
3614 IF(n4 == 0) n4 = n3
3615 DO j = addcnel(n1),addcnel(n1+1)-1
3616 ii = cnel(j)
3617 IF(tagel(ii)<0) THEN ! elt detruit trouve
3618 itagl(n1) = 0
3619 itagl(n2) = 0
3620 itagl(n3) = 0
3621 itagl(n4) = 0
3622 IF(ii<=ofc) THEN ! solide detruit
3623 DO k = 2, 9
3624 ix = ixs(k,ii)
3625 itagl(ix) = 1
3626 END DO
3627 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell detruit
3628 ii = ii - ofc
3629 DO k=2,5
3630 ix = ixc(k,ii)
3631 itagl(ix)=1
3632 END DO
3633 ELSEIF(ii > oftg.AND.ii<=ofur)THEN
3634 ii = ii - oftg
3635 DO k=2,4
3636 ix = ixtg(k,ii)
3637 itagl(ix) = 1
3638 END DO
3639 END IF
3640 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
3641 stf(i) = zero
3642 GOTO 400
3643 END IF
3644 END IF
3645 END DO
3646C
3647C nothing found, need to check on other procs in spmd (case of double element or facet with boundary nodes on 2 cpus)
3648 IF(nspmd > 1) THEN
3649#include "lockon.inc"
3650 icomp = icomp + 1
3651 nind2 = icomp
3652#include "lockoff.inc"
3653 nindex(nind2) = i
3654 bufs(4*(nind2-1)+1) = itab(n1)
3655 bufs(4*(nind2-1)+2) = itab(n2)
3656 bufs(4*(nind2-1)+3) = itab(n3)
3657 bufs(4*(nind2-1)+4) = itab(n4)
3658 END IF
3659 400 CONTINUE
3660 END DO
3661C
3662 CALL my_barrier()
3663C
3664 nindg = icomp
3665C
3666 CALL my_barrier()
3667C
3668 RETURN
3669 END
3670C
3671!||====================================================================
3672!|| chk23msr3nb ../engine/source/interfaces/interf/chkstfn3.F
3673!||--- called by ------------------------------------------------------
3674!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
3675!||--- calls -----------------------------------------------------
3676!|| my_barrier ../engine/source/system/machine.F
3677!||--- uses -----------------------------------------------------
3678!|| element_mod ../common_source/modules/elements/element_mod.F90
3679!||====================================================================
3680 SUBROUTINE chk23msr3nb(
3681 1 NMN ,MSR ,ITAG ,ITASK,IRECT ,
3682 2 NRTM ,STF ,ITAG2 ,IXS ,IXC ,
3683 3 IXTG ,IXQ ,IPARG ,ITAGL ,
3684 4 NTY ,ITAB ,ITABM1,CNEL ,ADDCNEL ,
3685 5 OFC ,OFT ,OFTG ,OFUR ,NINDG ,
3686 6 BUFS ,NINDEX,TAGEL )
3687 use element_mod , only : nixs,nixq,nixc,nixtg
3688C-----------------------------------------------
3689C I m p l i c i t T y p e s
3690C-----------------------------------------------
3691#include "implicit_f.inc"
3692#include "comlock.inc"
3693C-----------------------------------------------
3694C C o m m o n B l o c k s
3695C-----------------------------------------------
3696#include "task_c.inc"
3697#include "com01_c.inc"
3698#include "param_c.inc"
3699 COMMON /idelg/icomp
3700 INTEGER ICOMP
3701C-----------------------------------------------
3702C D u m m y A r g u m e n t s
3703C-----------------------------------------------
3704 INTEGER NMN, NTY, NRTM, MSR(*), ITAG(*), ITASK, IRECT(4,*),
3705 . itag2(*), ixs(nixs,*), ixq(nixq,*), ixc(nixc,*),
3706 . ixtg(nixtg,*), iparg(nparg,*), itagl(*), itab(*),
3707 . itabm1(*), cnel(0:*), addcnel(0:*), ofc, oft, oftg, ofur,
3708 . nindg, nindex(*), bufs(*), tagel(*)
3709C REAL
3710 my_real
3711 . stf(*)
3712C-----------------------------------------------
3713C L o c a l V a r i a b l e s
3714C-----------------------------------------------
3715 INTEGER I, J, NMNF, NMNL, NRTF, NRTL, N1, N2, N3, N4,
3716 . NN, II, IX, K, NIND, NIND2, N, NINDL(NRTM)
3717C REAL
3718C-----------------------------------------------
3719 nmnf = 1 + itask*nmn / nthread
3720 nmnl = (itask+1)*nmn / nthread
3721 icomp = 0
3722C
3723c arebrancher IF(NTY/=3.AND.NTY/=5) THEN
3724c Arebrancherc Place A - Only to optimize Type 7 interfaces, 10
3725c arebrancher DO I = NMNF, NMNL
3726c arebrancherC si tag nul sur noeuds main alors msr(i) = -msr(i)
3727c arebrancher IF (ITAG(ABS(MSR(I))) == 0) THEN
3728c arebrancher MSR(I) = -ABS(MSR(I))
3729c arebrancher END IF
3730c arebrancher ENDDO
3731c arebrancher END IF
3732C
3733 CALL my_barrier()
3734C
3735 nrtf = 1 + itask*nrtm / nthread
3736 nrtl = (itask+1)*nrtm / nthread
3737C
3738 nind = 0
3739 DO i = nrtf, nrtl
3740 IF(stf(i)/=zero) THEN
3741 n1 = msr(irect(1,i))
3742 n2 = msr(irect(2,i))
3743 n3 = msr(irect(3,i))
3744 n4 = msr(irect(4,i))
3745 IF(n4 == 0) n4 = n3
3746 IF(itag(n1) == 0.OR.itag(n2) == 0.OR.
3747 + itag(n3) == 0.OR.itag(n4) == 0) THEN
3748 stf(i) = zero
3749C CAUTION> = 1 because cumulative node front of tags at 1
3750 ELSEIF(itag2(n1)>=1.AND.itag2(n2)>=1.AND.
3751 + itag2(n3)>=1.AND.itag2(n4)>=1) THEN
3752 nind = nind + 1
3753 nindl(nind) = i
3754 END IF
3755 END IF
3756 END DO
3757C
3758 DO n = 1, nind
3759 i = nindl(n)
3760 n1 = msr(irect(1,i))
3761 n2 = msr(irect(2,i))
3762 n3 = msr(irect(3,i))
3763 n4 = msr(irect(4,i))
3764 IF(n4 == 0) n4 = n3
3765 DO j = addcnel(n1),addcnel(n1+1)-1
3766 ii = cnel(j)
3767 IF(tagel(ii) > 0) THEN ! ELT Active finds
3768 itagl(n1) = 0
3769 itagl(n2) = 0
3770 itagl(n3) = 0
3771 itagl(n4) = 0
3772 IF(ii<=ofc) THEN ! solide actif
3773 DO k = 2, 9
3774 ix = ixs(k,ii)
3775 itagl(ix) = 1
3776 END DO
3777 ELSEIF(ii > ofc.AND.ii<=oft) THEN ! shell actif
3778 ii = ii - ofc
3779 DO k=2,5
3780 ix = ixc(k,ii)
3781 itagl(ix)=1
3782 END DO
3783 ELSEIF(ii > oftg.AND.ii<=ofur)THEN ! triangle actif
3784 ii = ii - oftg
3785 DO k=2,4
3786 ix = ixtg(k,ii)
3787 itagl(ix) = 1
3788 END DO
3789 END IF
3790 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4) == 4)THEN
3791 GOTO 400
3792 END IF
3793 END IF
3794 END DO
3795C If no active element: Stif A 0 in SMP or Mono
3796 IF(nspmd == 1) THEN
3797 stf(i) = zero
3798C If no active element: COMM in SPMD
3799 ELSE
3800#include "lockon.inc"
3801 icomp = icomp + 1
3802 nind2 = icomp
3803#include "lockoff.inc"
3804 nindex(nind2) = i
3805 bufs(4*(nind2-1)+1) = itab(n1)
3806 bufs(4*(nind2-1)+2) = itab(n2)
3807 bufs(4*(nind2-1)+3) = itab(n3)
3808 bufs(4*(nind2-1)+4) = itab(n4)
3809 END IF
3810 400 CONTINUE
3811 END DO
3812C
3813 CALL my_barrier()
3814C
3815 nindg = icomp
3816C
3817 CALL my_barrier()
3818C
3819 RETURN
3820 END
3821C
3822!||====================================================================
3823!|| setmsr3 ../engine/source/interfaces/interf/chkstfn3.F
3824!||--- called by ------------------------------------------------------
3825!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.f
3826!||--- calls -----------------------------------------------------
3827!|| i24_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
3828!|| i25_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
3829!||====================================================================
3830 SUBROUTINE setmsr3(STF , NINDG, BUFS , NINDEX, NTY,
3831 1 IDEL , IFL , NEWFRONT,NG,NRTM,
3832 2 MSEGLO,MVOISIN,INDSEGLO,IBUFSEGLO)
3833C-----------------------------------------------
3834C I m p l i c i t T y p e s
3835C-----------------------------------------------
3836#include "implicit_f.inc"
3837#include "comlock.inc"
3838C-----------------------------------------------
3839C G l o b a l P a r a m e t e r s
3840C-----------------------------------------------
3841#include "com01_c.inc"
3842C-----------------------------------------------
3843C D u m m y A r g u m e n t s
3844C-----------------------------------------------
3845 INTEGER NINDG, NTY, IDEL, IFL, NEWFRONT, NINDEX(*), BUFS(*),NRTM,
3846 * NG,MSEGLO(*),MVOISIN(*),IBUFSEGLO(*),INDSEGLO(*)
3847C REAL
3848 my_real
3849 . STF(*)
3850C-----------------------------------------------
3851C L o c a l V a r i a b l e s
3852C-----------------------------------------------
3853 INTEGER I, J, NN,IND_SEGLO(NRTM*2),NIND_SEGLO
3854C-----------------------------------------------
3855 IF(nty==7.OR.nty==10.OR.nty==22.OR.nty==23.OR.
3856 .nty==5.OR.nty==20.OR.nty==3.OR.nty==24.OR.nty==25)THEN
3857 IF(idel==2)THEN
3858 nind_seglo = 0
3859 DO j = 1, nindg
3860 nn = bufs(j)
3861 IF(nn > 0) THEN
3862 i = nindex(j)
3863C Next main or second facet
3864 stf(i) = zero
3865 IF(nty==24.OR.nty==25)THEN
3866 nind_seglo = nind_seglo + 1
3867 ind_seglo(nind_seglo)=i
3868 ENDIF
3869 END IF
3870 END DO
3871 ELSEIF(idel == 1)THEN
3872 nind_seglo = 0
3873 DO j = 1, nindg
3874 nn = bufs(j)
3875 IF(nn == 0) THEN
3876 i = nindex(j)
3877 stf(i) = zero
3878 IF(nty==24.OR.nty==25)THEN
3879 nind_seglo = nind_seglo + 1
3880 ind_seglo(nind_seglo)=i
3881 ENDIF
3882 END IF
3883 END DO
3884 END IF
3885 ELSEIF(nty == 11.OR.nty == -20) THEN
3886 IF(idel == 2)THEN
3887#include "vectorize.inc"
3888 DO j = 1, nindg
3889 nn = bufs(j)
3890 IF(nn > 0) THEN
3891 i = nindex(j)
3892C Next main or second facet
3893 IF(ifl == 1) THEN
3894 stf(i) = zero
3895 ELSE
3896 stf(i) =-abs(stf(i))
3897 newfront = -1
3898 END IF
3899 END IF
3900 END DO
3901 ELSEIF(idel == 1)THEN
3902#include "vectorize.inc"
3903 DO j = 1, nindg
3904 nn = bufs(j)
3905 IF(nn == 0) THEN
3906 i = nindex(j)
3907C Next main or second facet
3908 IF(ifl == 1) THEN
3909 stf(i) = zero
3910 ELSE
3911 stf(i) =-abs(stf(i))
3912 newfront = -1
3913 END IF
3914 END IF
3915 END DO
3916 END IF
3917 END IF
3918C
3919 IF(nty==24)THEN
3920 CALL i24_remove_global_segment(ind_seglo,nind_seglo,ng,nrtm,mseglo,mvoisin,1)
3921 IF(nspmd > 1)THEN
3922#include "lockon.inc"
3923 DO i=1,nind_seglo
3924 ibufseglo(indseglo(ng+1))=mseglo(ind_seglo(i))
3925 indseglo(ng+1)=indseglo(ng+1)+1
3926 ENDDO
3927#include "lockoff.inc"
3928 ENDIF
3929 ELSEIF(nty==25)THEN
3930 CALL i25_remove_global_segment(ind_seglo,nind_seglo,ng,nrtm,mseglo,mvoisin,1)
3931 IF(nspmd > 1)THEN
3932#include "lockon.inc"
3933 DO i=1,nind_seglo
3934 ibufseglo(indseglo(ng+1))=mseglo(ind_seglo(i))
3935 indseglo(ng+1)=indseglo(ng+1)+1
3936 ENDDO
3937#include "lockoff.inc"
3938 ENDIF
3939 ENDIF
3940
3941C
3942 RETURN
3943 END
3944C
3945!||====================================================================
3946!|| setmsr2 ../engine/source/interfaces/interf/chkstfn3.F
3947!||--- called by ------------------------------------------------------
3948!|| chkstfn3n ../engine/source/interfaces/interf/chkstfn3.F
3949!||====================================================================
3950 SUBROUTINE setmsr2(NINDG, BUFS, NINDEX, NSV, MS,
3951 2 SMAS , IN , SINER ,IDEL)
3952C-----------------------------------------------
3953C I m p l i c i t T y p e s
3954C-----------------------------------------------
3955#include "implicit_f.inc"
3956C-----------------------------------------------
3957C D u m m y A r g u m e n t s
3958C-----------------------------------------------
3959 INTEGER NINDG, NINDEX(*), BUFS(*), NSV(*), IDEL
3960 my_real
3961 . MS(*), SMAS(*), IN(*), SINER(*)
3962C-----------------------------------------------
3963C L o c a l V a r i a b l e s
3964C-----------------------------------------------
3965 INTEGER I, J, IS, NN
3966C-----------------------------------------------
3967 IF(idel == 2)THEN
3968#include "vectorize.inc"
3969 DO j = 1, nindg
3970 nn = bufs(j)
3971 IF(nn == 1) THEN
3972 i = nindex(j)
3973 is = nsv(i)
3974 IF(is > 0)THEN
3975 nsv(i) = -nsv(i)
3976 ms(is) = smas(i)
3977 in(is) = siner(i)
3978 ENDIF
3979 ENDIF
3980 ENDDO
3981 ELSEIF(idel == 1)THEN
3982#include "vectorize.inc"
3983 DO j = 1, nindg
3984 nn = bufs(j)
3985 IF(nn == 0) THEN
3986 i = nindex(j)
3987 is = nsv(i)
3988 IF(is > 0)THEN
3989 nsv(i) = -nsv(i)
3990 ms(is) = smas(i)
3991 in(is) = siner(i)
3992 ENDIF
3993 ENDIF
3994 ENDDO
3995 ENDIF
3996C
3997 RETURN
3998 END
3999
4000
4001!||====================================================================
4002!|| i24_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
4003!||--- called by ------------------------------------------------------
4004!|| chkmsr3n ../engine/source/interfaces/interf/chkstfn3.F
4005!|| chkmsr3nb ../engine/source/interfaces/interf/chkstfn3.F
4006!|| setmsr3 ../engine/source/interfaces/interf/chkstfn3.F
4007!|| spmd_exch_idel_seglo ../engine/source/mpi/interfaces/spmd_exch_idel_seglo.F
4008!||====================================================================
4009 SUBROUTINE i24_remove_global_segment(IND_SEGLO,NIND_SEGLO,NIN, NRTM,MSEGLO,MVOISIN,FLAG)
4010C-----------------------------------------------
4011C I m p l i c i t T y p e s
4012C-----------------------------------------------
4013#include "implicit_f.inc"
4014C-----------------------------------------------
4015C D u m m y A r g u m e n t s
4016C-----------------------------------------------
4017 INTEGER MA_SURF,MSEGLO(*),MVOISIN(4,*),NRTM,IND_SEGLO(NRTM),FLAG,
4018 * nind_seglo,i
4019C-----------------------------------------------
4020C L o c a l V a r i a b l e s
4021C-----------------------------------------------
4022 INTEGER NIN,K,GLOB_ID
4023C-----------------------------------------------
4024 DO i=1,nind_seglo
4025 ma_surf=ind_seglo(i)
4026 glob_id = ma_surf
4027 IF (flag==1)glob_id = mseglo(ma_surf)
4028 DO k=1,nrtm
4029 IF (mvoisin(1,k)==glob_id) mvoisin(1,k)=0
4030 IF (mvoisin(2,k)==glob_id) mvoisin(2,k)=0
4031 IF (mvoisin(3,k)==glob_id) mvoisin(3,k)=0
4032 IF (mvoisin(4,k)==glob_id) mvoisin(4,k)=0
4033 IF(mseglo(k)==glob_id)THEN
4034 mvoisin(1,k)=0
4035 mvoisin(2,k)=0
4036 mvoisin(3,k)=0
4037 mvoisin(4,k)=0
4038 ENDIF
4039 ENDDO
4040 ENDDO
4041 END
4042!||====================================================================
4043!|| i25_remove_global_segment ../engine/source/interfaces/interf/chkstfn3.F
4044!||--- called by ------------------------------------------------------
4045!|| chkmsr3n ../engine/source/interfaces/interf/chkstfn3.F
4046!|| chkmsr3nb ../engine/source/interfaces/interf/chkstfn3.F
4047!|| setmsr3 ../engine/source/interfaces/interf/chkstfn3.F
4048!|| spmd_exch_idel_seglo ../engine/source/mpi/interfaces/spmd_exch_idel_seglo.F
4049!||====================================================================
4050 SUBROUTINE i25_remove_global_segment(IND_SEGLO,NIND_SEGLO,NIN, NRTM,MSEGLO,MVOISIN,FLAG)
4051C-----------------------------------------------
4052C I m p l i c i t T y p e s
4053C-----------------------------------------------
4054#include "implicit_f.inc"
4055C-----------------------------------------------
4056C D u m m y A r g u m e n t s
4057C-----------------------------------------------
4058 INTEGER MA_SURF,MSEGLO(*),MVOISIN(4,*),NRTM,IND_SEGLO(NRTM),FLAG,
4059 * NIND_SEGLO,I
4060C-----------------------------------------------
4061C L o c a l V a r i a b l e s
4062C-----------------------------------------------
4063 INTEGER NIN,K,GLOB_ID
4064C-----------------------------------------------
4065 DO I=1,nind_seglo
4066 IF(flag==1)THEN
4067 ma_surf = ind_seglo(i)
4068 glob_id = mseglo(ma_surf)
4069 DO k=1,nrtm
4070 IF (mvoisin(1,k)==ma_surf) mvoisin(1,k)=0
4071 IF (mvoisin(2,k)==ma_surf) mvoisin(2,k)=0
4072 IF (mvoisin(3,k)==ma_surf) mvoisin(3,k)=0
4073 IF (mvoisin(4,k)==ma_surf) mvoisin(4,k)=0
4074c IF(MSEGLO(K)==GLOB_ID)THEN
4075c MVOISIN(1,K)=0
4076c MVOISIN(2,K)=0
4077c MVOISIN(3,K)=0
4078c MVOISIN(4,K)=0
4079c ENDIF
4080 ENDDO
4081 ELSE
4082 ma_surf = ind_seglo(i)
4083 glob_id = ma_surf
4084 DO k=1,nrtm
4085 IF (mvoisin(1,k) < 0)THEN
4086 IF(mvoisin(1,k)==-glob_id) mvoisin(1,k)=0
4087 ENDIF
4088 IF (mvoisin(2,k) < 0)THEN
4089 IF(mvoisin(2,k)==-glob_id) mvoisin(2,k)=0
4090 ENDIF
4091 IF (mvoisin(3,k) < 0)THEN
4092 IF(mvoisin(3,k)==-glob_id) mvoisin(3,k)=0
4093 ENDIF
4094 IF (mvoisin(4,k) < 0)THEN
4095 IF(mvoisin(4,k)==-glob_id) mvoisin(4,k)=0
4096 ENDIF
4097 ENDDO
4098 END IF
4099 ENDDO
4100 END
chkslv3b
subroutine chkslv3b(nsn, nsv, stfn, itag, itask)
Definition chkstfn3.F:127
chkinit
subroutine chkinit(ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixs10, ixs20, ixs16, ixtg1, geo, addcnel, cnel, adsky, iparg)
Definition chkstfn3.F:265
chk2msr3n
subroutine chk2msr3n(nsn, nsv, itag, itask, irect, irtl, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, ms, in, smas, siner, adm, cnel, addcnel, ofc, oft, oftg, ofur, tagel, ilev)
Definition chkstfn3.F:3155
chk11msr3n
subroutine chk11msr3n(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, newfront, ixt, ixp, ixr, geo, ifl, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, ofr, ofp, nindg, bufs, nindex, tagel)
Definition chkstfn3.F:2643
chk20emsr3n
subroutine chk20emsr3n(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, newfront, ixt, ixp, ixr, geo, ifl, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, ofr, ofp, nindg, bufs, nindex, nlg, tagel)
Definition chkstfn3.F:2794
chk20emsr3nb
subroutine chk20emsr3nb(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, newfront, ixt, ixp, ixr, geo, ifl, cnel, addcnel, ofc, oft, oftg, ofur, ofr, ofp, nindg, bufs, nindex, nlg, tagel)
Definition chkstfn3.F:2975
chkslv3_t24
subroutine chkslv3_t24(nsn, nsv, stfn, itag, itask, is2se, irtse, newfront)
Definition chkstfn3.F:75
chkstfn3n
subroutine chkstfn3n(nodes, ipari, geo, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, itag, iparg, itask, newfront, itagl, ms, in, adm, itab, itabm1, addcnel, cnel, ind, nindex1, nindex2, nindex3, nindex4, tagel, int24use, ibufseglo, indseglo, ibufs, intbuf_tab, iad_elem)
Definition chkstfn3.F:1281
i24_remove_global_segment
subroutine i24_remove_global_segment(ind_seglo, nind_seglo, nin, nrtm, mseglo, mvoisin, flag)
Definition chkstfn3.F:4010
chk2msr3np
subroutine chk2msr3np(nsn, nsv, itag, itask, irect, irtl, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, ms, in, smas, siner, adm, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, index, idel)
Definition chkstfn3.F:3434
chk23msr3n
subroutine chk23msr3n(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, tagel)
Definition chkstfn3.F:3537
chk11msr3nb
subroutine chk11msr3nb(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, newfront, ixt, ixp, ixr, geo, ifl, cnel, addcnel, ofc, oft, oftg, ofur, ofr, ofp, nindg, bufs, nindex, tagel)
Definition chkstfn3.F:2717
chk20msr3n
subroutine chk20msr3n(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, nlg, tagel)
Definition chkstfn3.F:2320
chk20msr3nb
subroutine chk20msr3nb(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, nlg, tagel)
Definition chkstfn3.F:2480
chkipari
subroutine chkipari(ipari)
Definition chkstfn3.F:211
chkmsr3n
subroutine chkmsr3n(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, tagel, ng, mseglo, mvoisin, indseglo, ibufseglo)
Definition chkstfn3.F:1936
tagoff3n
subroutine tagoff3n(nodes, geo, ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, itag, nodft, nodlt, iparg, ev, itask, ixtg1, iad_elem, fr_elem, itab, addcnel, cnel, kxsp, elbuf_tab, tagel, iexlnk, igrnod, dd_r2r, dd_r2r_elem, sdd_r2r_elem, idel7nok_sav, idel7nok_r2r, tagtrimc, tagtrimtg, s_elem_state, elem_state, shoot_struct, global_nb_elem_off)
Definition chkstfn3.F:577
chkmsr3nb
subroutine chkmsr3nb(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, tagel, ng, mseglo, mvoisin, indseglo, ibufseglo)
Definition chkstfn3.F:2138
setmsr3
subroutine setmsr3(stf, nindg, bufs, nindex, nty, idel, ifl, newfront, ng, nrtm, mseglo, mvoisin, indseglo, ibufseglo)
Definition chkstfn3.F:3833
i25_remove_global_segment
subroutine i25_remove_global_segment(ind_seglo, nind_seglo, nin, nrtm, mseglo, mvoisin, flag)
Definition chkstfn3.F:4051
chkslv3
subroutine chkslv3(nsn, nsv, stfn, itag, itask, newfront)
Definition chkstfn3.F:31
chk2msr3nb
subroutine chk2msr3nb(nsn, nsv, itag, itask, irect, irtl, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, ms, in, smas, siner, adm, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, tagel, itab, ilev)
Definition chkstfn3.F:3282
setmsr2
subroutine setmsr2(nindg, bufs, nindex, nsv, ms, smas, in, siner, idel)
Definition chkstfn3.F:3952
chk23msr3nb
subroutine chk23msr3nb(nmn, msr, itag, itask, irect, nrtm, stf, itag2, ixs, ixc, ixtg, ixq, iparg, itagl, nty, itab, itabm1, cnel, addcnel, ofc, oft, oftg, ofur, nindg, bufs, nindex, tagel)
Definition chkstfn3.F:3687
chkslv3c
subroutine chkslv3c(nsn, nsv, stfa, itag, itask, newfront, nlg)
Definition chkstfn3.F:169
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:668
rad2r_mod
Definition rad2r.F:46
rad2r_mod::tagel_r2r_send
integer, dimension(:), allocatable tagel_r2r_send
Definition rad2r.F:53
remesh_mod
Definition remesh_mod.F:50
r2r_exch_itag
subroutine r2r_exch_itag(iexlnk, igrnod, itag, flag)
Definition r2r_exchange.F:490
r2r_tagel
subroutine r2r_tagel(ntagel_r2r_send, id_el, id_node, ity, ofur, tagel_size)
Definition r2r_exchange.F:429
get_shmbuf_c
void get_shmbuf_c(int *val1, int *val2)
Definition rad2rad_c.c:2787
exch_tagel_c
void exch_tagel_c(int *ntagel, int *tagel, int *flag)
Definition rad2rad_c.c:2749
send_ibuf_c
void send_ibuf_c(int *ibuf, int *len)
Definition rad2rad_c.c:940
send_shmbuf_c
void send_shmbuf_c(int *val1, int *val2)
Definition rad2rad_c.c:2805
get_ibuf_c
void get_ibuf_c(int *ibuf, int *len)
Definition rad2rad_c.c:1031
spmd_allglob_isum9
subroutine spmd_allglob_isum9(v, len)
Definition spmd_allglob_isum9.F:46
spmd_exch_idel
subroutine spmd_exch_idel(itag, iad_elem, fr_elem, size, lenr)
Definition spmd_exch_idel.F:33
spmd_exchmsr_idel
subroutine spmd_exchmsr_idel(bufs, lbufs, ixs, ixc, ixtg, ixq, iparg, itagl, nodes, irsize, irecv, cnel, addcnel, ofc, oft, oftg, ofur, ofr, ofp, lindex, ixp, ixr, ixt, geo, tagel, iad_elem)
Definition spmd_exchmsr_idel.F:41
spmd_ibcast
subroutine spmd_ibcast(tabi, tabr, n1, n2, from, add)
Definition spmd_ibcast.F:57
spmd_init_idel
subroutine spmd_init_idel(nindex, irsize, irecv, iad_elem)
Definition spmd_init_idel.F:34
spmd_exch_r2r_itag
subroutine spmd_exch_r2r_itag(itag, iad_elem, fr_elem, dd_r2r, dd_r2r_elem, lenr)
Definition spmd_r2r.F:1870
spmd_r2r_tagel
subroutine spmd_r2r_tagel(tagelg, tagel, len)
Definition spmd_r2r.F:1805
my_barrier
subroutine my_barrier
Definition machine.F:31