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