OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
domdec2.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!|| domdec2 ../starter/source/spmd/domdec2.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| c_doms10 ../starter/source/spmd/domdec2.F
30!|| check_skew ../starter/source/spmd/domain_decomposition/check_skew.F
31!|| domain_decomposition_pcyl ../starter/source/loads/general/load_pcyl/domain_decomposition_pcyl.F
32!|| frontplus_rm ../starter/source/spmd/node/frontplus.F
33!|| ifrontplus ../starter/source/spmd/node/frontplus.F
34!|| nlocal ../starter/source/spmd/node/ddtools.F
35!|| split_joint ../starter/source/constraints/general/cyl_joint/split_joint.F
36!||--- uses -----------------------------------------------------
37!|| front_mod ../starter/share/modules1/front_mod.F
38!|| message_mod ../starter/share/message_module/message_mod.f
39!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
40!|| submodel_mod ../starter/share/modules1/submodel_mod.F
41!||====================================================================
42 SUBROUTINE domdec2(
43 1 DD_IAD ,IPARI ,IB ,NPBY ,
44 2 LPBY ,IXRI ,IBVEL ,LBVEL ,
45 3 IPARG ,CEL ,IXS ,IXS10 ,IXS20 ,
46 4 IXS16 ,IXQ ,IXC ,IXT ,IXP ,
47 5 IXR ,IXTG ,IXTG6 ,T_MONVOL,
48 6 IGRSURF,ADDCNE ,LCNE ,GEO ,
49 7 NPRW ,LPRW ,LCNI2 ,ADSKYI2,CEPI2,
50 8 CELI2 ,I2NSNT ,ISKN ,ISKWP,NSKWP ,
51 9 ISENSP ,NSENSP ,IACCP ,NACCP ,
52 A LACCELM,IBCV ,IRBE3 ,LRBE3 ,FRONT_RM,
53 B IRBYM ,LCRBYM ,CEP ,IBCR ,IRBE2 ,
54 C LRBE2 ,CEPSP ,CELSPH ,ILOADP,LLOADP,
55 D LGAUGE ,IGAUP ,NGAUP ,INTBUF_TAB,IBFFLUX,
56 E ICNDS10,ITAGND ,IGEO ,TAG_SKN,MULTIPLE_SKEW,
57 F IBFV ,IBCSCYC,LBCSCYC,R_SKEW,IPM ,
58 G SENSORS, LEN_CEP,EBCS_TAB,LOADS,IFRAME,
59 H NICONV ,NIRADIA ,NITFLUX,NUMCONV,NUMRADIA,NFXFLUX,
60 I SENSOR_USER_STRUCT)
61C
62C-----------------------------------------------
63C M o d u l e s
64C-----------------------------------------------
65 USE message_mod
66 USE front_mod
67 USE intbufdef_mod
68 USE groupdef_mod
69 USE skew_mod
70 USE monvol_struct_mod
71 USE sensor_mod
72 USE ale_ebcs_mod
73 USE ebcs_mod
74 USE loads_mod
75 USE submodel_mod , ONLY : nsubmod
76 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
77C-----------------------------------------------
78C I m p l i c i t T y p e s
79C-----------------------------------------------
80#include "implicit_f.inc"
81C-----------------------------------------------
82C C o m m o n B l o c k s
83C-----------------------------------------------
84#include "com01_c.inc"
85#include "com04_c.inc"
86#include "param_c.inc"
87#include "sphcom.inc"
88C-----------------------------------------------
89C D u m m y A r g u m e n t s
90C-----------------------------------------------
91 INTEGER ,INTENT(IN) :: NICONV
92 INTEGER ,INTENT(IN) :: NIRADIA
93 INTEGER ,INTENT(IN) :: NITFLUX
94 INTEGER ,INTENT(IN) :: NUMCONV
95 INTEGER ,INTENT(IN) :: NUMRADIA
96 INTEGER ,INTENT(IN) :: NFXFLUX
97 INTEGER IPARI(NPARI,NINTER),
98 . DD_IAD(NSPMD+1,NSPGROUP), NPRW(*), LPRW(*),
99 . NPBY(NNPBY,*), LPBY(*), IXRI(4,*),
100 . IBVEL(NBVELP,*), LBVEL(*), IPARG(NPARG,*), CEL(*),
101 . IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),
102 . IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),
103 . IXS10(6,*),IXS20(12,*),IXS16(8,*),IXTG6(4,*),IB(NIBCLD,*),
104 . I2NSNT,ISKN(LISKN,*),ISKWP(*),NSKWP(*),
105 . ADDCNE(0:*), LCNE, LCNI2, ADSKYI2(0:*),CEPI2(*),CELI2(*),
106 . ISENSP(2,*), NSENSP(*), IACCP(*), NACCP(*),
107 . LACCELM(3,*),IBCV(NICONV, *),IRBE3(NRBE3L,*), LRBE3(*),
108 . FRONT_RM(NRBYM,NSPMD), IRBYM(NIRBYM,*) ,LCRBYM(*), CEP(LEN_CEP),
109 . ibcr(niradia,*),irbe2(nrbe2l,*), lrbe2(*),
110 . cepsp(numsph), celsph(numsph),iloadp(sizloadp,*),lloadp(*),
111 . lgauge(3,*), igaup(*), ngaup(*), ibfflux(nitflux,*),
112 . icnds10(3,*),itagnd(*),ibfv(nifv,*),ibcscyc(4,*),lbcscyc(2,*),
113 . r_skew(*),ipm(npropmi,*),len_cep
114 INTEGER, DIMENSION(NPROPGI,*), INTENT(IN) :: IGEO
115 INTEGER, DIMENSION(NUMSKW+NSUBMOD+1), INTENT(INOUT) :: TAG_SKN
116 TYPE(PLIST_SKEW_), DIMENSION(NUMSKW+1), INTENT(INOUT) :: MULTIPLE_SKEW
117! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
118! TAG_SKN : integer ; dimension=NUMSKW+NSUBMOD+1
119! tag array --> tag the i SKEW if a SPRING uses it
120! tag array=0 --> the SKEW is not used by a SPRING
121! tag array=1 --> the SKEW is used by one SPRING
122! tag array>1 --> the SKEW is used by several SPRING
123! MULTIPLE_SKEW : SKEW_TYPE ; dimension=NUMSKW+1
124! MULTIPLE_SKEW(I)%PLIST(:) is a list of processor
125! where the SKEW is stuck
126! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
127 my_real :: GEO(NPROPG,*)
128
129 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
130 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
131 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
132 TYPE(sensors_) ,INTENT(IN) :: SENSORS
133 TYPE(t_ebcs_tab), INTENT(INOUT) :: EBCS_TAB ! ebcs data structure
134 TYPE (LOADS_), INTENT(INOUT) :: LOADS ! load data structure
135 INTEGER ,DIMENSION(LISKN,NUMFRAM+1) ,INTENT(IN) :: IFRAME ! frame data structure
136 LOGICAL IS_EBCS_PARALLEL
137 TYPE(SENSOR_USER_STRUCT_) ,INTENT(INOUT) :: SENSOR_USER_STRUCT
138C-----------------------------------------------
139C E x t e r n a l F u n c t i o n s
140C-----------------------------------------------
141 INTEGER NLOCAL
142 EXTERNAL NLOCAL
143C-----------------------------------------------
144C L o c a l V a r i a b l e s
145C-----------------------------------------------
146 INTEGER IP,IPROC,IF1, IF2, TYP,
147 . insnmax, ipmax, sum, insnp, lastm,
148 . k, i, is, nn_s, iad, j, k1, k3, nn, nl,nl_l,
149 . nsn,nmn,p,n,n1,n2,n3,n4,nty,ngrou,nel,ng,l,m,nir,
150 . imain,kk,nrts,nrtm,pm,
151 . off, proc, nin, ity_old, ity, msr, nsl_l, nsl,
152 . iels(nspmd), p_sph, int2flag,int2frplus,
153 . ilev,cnt,offset,fingeo,iad1,iad2,numloadp,ite2frplus
154 INTEGER :: ISENS
155 my_real
156 . ect_ak,fr_ak
157 INTEGER :: IJK
158 INTEGER :: SURF_ID,NUMBER_NODE,NODE_ID
159 INTEGER :: NUMBER_PROC,NUMBER_SEGMENT
160C-----------------------------------------------------
161C S o u r c e L i n e s
162C-----------------------------------------------------
163 int2flag=0
164 cnt = 0
165 5000 CONTINUE
166c count flag, how many times we redo this task
167c CNT = CNT+1
168c print*,'Count:',CNT
169 int2frplus=0
170C-----------------------------------------------------
171
172 CALL domain_decomposition_pcyl(loads,iframe)
173 ! ------------------------
174 DO isens=1,sensors%NSENSOR
175 ! ------------------------
176 ! dist-surf sensor : for plane defined by 3 nodes,
177 ! add the 3 nodes and the reference node
178 ! on all spmd processors
179 IF (sensors%SENSOR_TAB(isens)%TYPE==15) THEN
180 ! -------------
181 ! reference node : %IPARAM(1)
182 n1 = sensors%SENSOR_TAB(isens)%IPARAM(1)
183 DO p=1,nspmd
184 CALL ifrontplus(n1,p)
185 ENDDO
186 ! -------------
187 IF(sensors%SENSOR_TAB(isens)%IPARAM(2)==0) THEN
188 ! Nodes: %iParam (3: 5)
189 DO i=1,3
190 n1 = sensors%SENSOR_TAB(isens)%IPARAM(3+i-1)
191 DO p=1,nspmd
192 CALL ifrontplus(n1,p)
193 ENDDO
194 ENDDO
195 ! -------------
196 ENDIF
197 ENDIF
198 ! ------------------------
199 ENDDO
200 ! ------------------------
201 ! check if a user sensor is used
202 IF(sensor_user_struct%IS_USED) THEN
203 ! ------------------------
204 ! add all the nodes on the NSPMD domains
205 IF(sensor_user_struct%POINTER_NODE>0) THEN
206 DO i=1,sensor_user_struct%NUMBER_NODE
207 n1 = sensor_user_struct%NODE_LIST(i)
208 DO p=1,nspmd
209 CALL ifrontplus(n1,p)
210 ENDDO
211 ENDDO
212 ENDIF
213 ! ------------------------
214 ENDIF
215 ! ------------------------
216 IF(numskw>0)THEN
217C skew global fixe
218 iskwp(1)=1
219 DO p = 1, nspmd
220 nskwp(p) = 0
221 END DO
222 IF(n2d==0 .AND. len_cep > 0)THEN
223 offset = numels + numelq + numelc + numelt + numelp
224! check if a SPRING is linked with a SKEW
225 CALL check_skew(ixr,igeo,iskn,cep,iskwp,nskwp,tag_skn,multiple_skew,
226 . r_skew,ipm,offset)
227
228
229 DO i=1,numskw
230 IF(tag_skn(i+1) > 0) cycle ! tag/=0 --> already done in CHECK_SKEW
231 n1=iskn(1,i+1)
232 n2=iskn(2,i+1)
233 n3=iskn(3,i+1)
234 insnmax = 0
235 imain = 1
236 IF(n1+n2+n3/=0) THEN
237 DO p = 1, nspmd
238 nn = nlocal(n1,p)+
239 + nlocal(n2,p)+
240 + nlocal(n3,p)
241 IF(nn>insnmax)THEN
242 insnmax=nn
243 imain=p
244 END IF
245 END DO
246 IF(insnmax/=3)THEN
247 CALL ifrontplus(n1,imain)
248 CALL ifrontplus(n2,imain)
249 CALL ifrontplus(n3,imain)
250 END IF
251 END IF
252 iskwp(i+1) = imain
253 nskwp(imain) = nskwp(imain)+1
254 END DO
255 ELSE
256 DO i=1,numskw
257 n1=iskn(1,i+1)
258 n2=iskn(2,i+1)
259 insnmax = 0
260 imain = 1
261 IF(n1+n2/=0) THEN
262 DO p = 1, nspmd
263 nn = nlocal(n1,p)+
264 . nlocal(n2,p)
265 IF(nn>insnmax)THEN
266 insnmax=nn
267 imain=p
268 END IF
269 END DO
270 IF(insnmax/=2)THEN
271 CALL ifrontplus(n1,imain)
272 CALL ifrontplus(n2,imain)
273 END IF
274 END IF
275 iskwp(i+1) = imain
276 nskwp(imain) = nskwp(imain)+1
277 END DO
278 END IF
279 END IF
280C-----------------------------------------------------
281C Traitement special rigid wall moving
282C-----------------------------------------------------
283 k = 0
284 DO n = 1, nrwall
285 n3 = 2*nrwall+n
286 nsl=nprw(n)
287 msr = nprw(n3)
288 IF(msr/=0) THEN
289 DO p = 1, nspmd
290 nsl_l = 0
291 DO kk = 1, nsl
292 nn = lprw(k+kk)
293 IF(nlocal(nn,p)==1)THEN
294 nsl_l = nsl_l + 1
295 ENDIF
296 ENDDO
297 IF(nsl_l>0) CALL ifrontplus(msr,p)
298 ENDDO
299 ENDIF
300 k = k + nsl
301 ENDDO
302C
303C-----------------------------------------------------
304C Special treatment pressure loads + concentrated forces
305C-----------------------------------------------------
306 DO n = 1, nconld
307 n1 = ib(1,n)
308 n2 = ib(2,n)
309 n3 = ib(3,n)
310 n4 = ib(4,n)
311 IF(n4/=-1.AND.n2d==0.AND.n4/=0)THEN
312 DO p = 1, nspmd
313 IF(nlocal(n1,p)==1.AND.
314 + nlocal(n2,p)==1.AND.
315 + nlocal(n3,p)==1.AND.
316 + nlocal(n4,p)==1)THEN
317 GOTO 9999
318 ENDIF
319 ENDDO
320 ENDIF
321 IF(n4/=-1.AND.n2d==0)THEN
322 DO p = 1, nspmd
323 IF(nlocal(n1,p)==1.AND.
324 + nlocal(n2,p)==1.AND.
325 + nlocal(n3,p)==1)THEN
326 IF(n4/=0) THEN
327 CALL ifrontplus(n4,p)
328 ENDIF
329 GOTO 9999
330 ENDIF
331 ENDDO
332 ENDIF
333 IF(n4/=-1)THEN
334 DO p = 1, nspmd
335 IF(nlocal(n1,p)==1.AND.
336 + nlocal(n2,p)==1)THEN
337 IF(n2d==0.AND.n4/=0) THEN
338 CALL ifrontplus(n4,p)
339 ENDIF
340 IF(n2d==0) THEN
341 CALL ifrontplus(n3,p)
342 ENDIF
343 GOTO 9999
344 ENDIF
345 ENDDO
346 ENDIF
347 DO p = 1, nspmd
348 IF(nlocal(n1,p)==1) THEN
349 IF(n2d==0.AND.n4/=0.AND.n4/=-1) THEN
350 CALL ifrontplus(n4,p)
351 ENDIF
352 IF(n2d==0.AND.n4/=-1) THEN
353 CALL ifrontplus(n3,p)
354 ENDIF
355 IF(n4/=-1) THEN
356 CALL ifrontplus(n2,p)
357 ENDIF
358 GOTO 9999
359 ENDIF
360 ENDDO
361 IF(n4/=0.AND.n4/=0.AND.n4/=-1) THEN
362 CALL ifrontplus(n4,1)
363 ENDIF
364 IF(n2d==0.AND.n4/=-1) THEN
365 CALL ifrontplus(n3,1)
366 ENDIF
367 IF(n4/=-1) THEN
368 CALL ifrontplus(n2,1)
369 ENDIF
370 CALL ifrontplus(n1,1)
371 9999 CONTINUE
372 ENDDO
373C-----------------------------------------------------
374C Traitement special flux conv for heat transfert
375C-----------------------------------------------------
376 DO n = 1, numconv
377 n1 = ibcv(1,n)
378 n2 = ibcv(2,n)
379 n3 = ibcv(3,n)
380 n4 = ibcv(4,n)
381 IF(n2d==0.AND.n4/=0)THEN
382 DO p = 1, nspmd
383 IF(nlocal(n1,p)==1.AND.
384 + nlocal(n2,p)==1.AND.
385 + nlocal(n3,p)==1.AND.
386 + nlocal(n4,p)==1)THEN
387 GOTO 9191
388 ENDIF
389 ENDDO
390 ENDIF
391 IF(n2d==0)THEN
392 DO p = 1, nspmd
393 IF(nlocal(n1,p)==1.AND.
394 + nlocal(n2,p)==1.AND.
395 + nlocal(n3,p)==1)THEN
396 IF(n4/=0) THEN
397 CALL ifrontplus(n4,p)
398 ENDIF
399 GOTO 9191
400 ENDIF
401 ENDDO
402 ENDIF
403 DO p = 1, nspmd
404 IF(nlocal(n1,p)==1.AND.
405 + nlocal(n2,p)==1)THEN
406 IF(n2d==0.AND.n4/=0) THEN
407 CALL ifrontplus(n4,p)
408 ENDIF
409 IF(n2d==0) THEN
410 CALL ifrontplus(n3,p)
411 ENDIF
412 GOTO 9191
413 ENDIF
414 ENDDO
415 DO p = 1, nspmd
416 IF(nlocal(n1,p)==1) THEN
417 IF(n2d==0.AND.n4/=0) THEN
418 CALL ifrontplus(n4,p)
419 ENDIF
420 IF(n2d==0) THEN
421 CALL ifrontplus(n3,p)
422 ENDIF
423 CALL ifrontplus(n2,p)
424 GOTO 9191
425 ENDIF
426 ENDDO
427 IF(n4/=0) THEN
428 CALL ifrontplus(n4,1)
429 ENDIF
430 IF(n2d==0) THEN
431 CALL ifrontplus(n3,1)
432 ENDIF
433 CALL ifrontplus(n2,1)
434 CALL ifrontplus(n1,1)
435 9191 CONTINUE
436 ENDDO
437C
438C-----------------------------------------------------
439C Traitement special radiative flux for heat transfert
440C-----------------------------------------------------
441 DO n = 1, numradia
442 n1 = ibcr(1,n)
443 n2 = ibcr(2,n)
444 n3 = ibcr(3,n)
445 n4 = ibcr(4,n)
446 IF(n2d==0.AND.n4/=0)THEN
447 DO p = 1, nspmd
448 IF(nlocal(n1,p)==1.AND.
449 + nlocal(n2,p)==1.AND.
450 + nlocal(n3,p)==1.AND.
451 + nlocal(n4,p)==1)THEN
452 GOTO 9192
453 ENDIF
454 ENDDO
455 ENDIF
456 IF(n2d==0)THEN
457 DO p = 1, nspmd
458 IF(nlocal(n1,p)==1.AND.
459 + nlocal(n2,p)==1.AND.
460 + nlocal(n3,p)==1)THEN
461 IF(n4/=0) THEN
462 CALL ifrontplus(n4,p)
463 ENDIF
464 GOTO 9192
465 ENDIF
466 ENDDO
467 ENDIF
468 DO p = 1, nspmd
469 IF(nlocal(n1,p)==1.AND.
470 + nlocal(n2,p)==1)THEN
471 IF(n2d==0.AND.n4/=0) THEN
472 CALL ifrontplus(n4,p)
473 ENDIF
474 IF(n2d==0) THEN
475 CALL ifrontplus(n3,p)
476 ENDIF
477 GOTO 9192
478 ENDIF
479 ENDDO
480 DO p = 1, nspmd
481 IF(nlocal(n1,p)==1) THEN
482 IF(n2d==0.AND.n4/=0) THEN
483 CALL ifrontplus(n4,p)
484 ENDIF
485 IF(n2d==0) THEN
486 CALL ifrontplus(n3,p)
487 ENDIF
488 CALL ifrontplus(n2,p)
489 GOTO 9192
490 ENDIF
491 ENDDO
492 IF(n4/=0) THEN
493 CALL ifrontplus(n4,1)
494 ENDIF
495 IF(n2d==0) THEN
496 CALL ifrontplus(n3,1)
497 ENDIF
498 CALL ifrontplus(n2,1)
499 CALL ifrontplus(n1,1)
500 9192 CONTINUE
501 ENDDO
502C---------------------------------------------------------
503C Traitement special imposed heat flux for heat transfert
504C---------------------------------------------------------
505 DO n = 1, nfxflux
506 IF(ibfflux(10,n) == 1) cycle
507 n1 = ibfflux(1,n)
508 n2 = ibfflux(2,n)
509 n3 = ibfflux(3,n)
510 n4 = ibfflux(4,n)
511 IF(n2d==0.AND.n4/=0)THEN
512 DO p = 1, nspmd
513 IF(nlocal(n1,p)==1.AND.
514 + nlocal(n2,p)==1.AND.
515 + nlocal(n3,p)==1.AND.
516 + nlocal(n4,p)==1) GOTO 9193
517 ENDDO
518 ENDIF
519 IF(n2d==0)THEN
520 DO p = 1, nspmd
521 IF(nlocal(n1,p)==1.AND.
522 + nlocal(n2,p)==1.AND.
523 + nlocal(n3,p)==1)THEN
524 IF(n4/=0) CALL ifrontplus(n4,p)
525 GOTO 9193
526 ENDIF
527 ENDDO
528 ENDIF
529 DO p = 1, nspmd
530 IF(nlocal(n1,p)==1.AND.nlocal(n2,p)==1)THEN
531 IF(n2d==0.AND.n4/=0) CALL ifrontplus(n4,p)
532 IF(n2d==0) CALL ifrontplus(n3,p)
533 GOTO 9193
534 ENDIF
535 ENDDO
536 DO p = 1, nspmd
537 IF(nlocal(n1,p)==1) THEN
538 IF(n2d==0.AND.n4/=0) CALL ifrontplus(n4,p)
539 IF(n2d==0) CALL ifrontplus(n3,p)
540 CALL ifrontplus(n2,p)
541 GOTO 9193
542 ENDIF
543 ENDDO
544 IF(n4/=0) CALL ifrontplus(n4,1)
545 IF(n2d==0) CALL ifrontplus(n3,1)
546 CALL ifrontplus(n2,1)
547 CALL ifrontplus(n1,1)
548 9193 CONTINUE
549 ENDDO
550C-----------------------------------------------------
551C Traitement special load/Pfluid
552C-----------------------------------------------------
553 DO n = 1, nloadp
554 DO i = 1,iloadp(1,n)/4
555 n1=lloadp(iloadp(4,n)+4*(i-1))
556 n2=lloadp(iloadp(4,n)+4*(i-1)+1)
557 n3=lloadp(iloadp(4,n)+4*(i-1)+2)
558 n4=lloadp(iloadp(4,n)+4*(i-1)+3)
559 IF(n4/=-1.AND.n2d==0.AND.n4/=0)THEN
560 DO p = 1, nspmd
561 IF(nlocal(n1,p)==1.AND.
562 + nlocal(n2,p)==1.AND.
563 + nlocal(n3,p)==1.AND.
564 + nlocal(n4,p)==1)THEN
565 GOTO 8888
566 ENDIF
567 ENDDO
568 ENDIF
569 IF(n4/=-1.AND.n2d==0)THEN
570 DO p = 1, nspmd
571 IF(nlocal(n1,p)==1.AND.
572 + nlocal(n2,p)==1.AND.
573 + nlocal(n3,p)==1)THEN
574 IF(n4/=0) THEN
575 CALL ifrontplus(n4,p)
576 ENDIF
577 GOTO 8888
578 ENDIF
579 ENDDO
580 ENDIF
581 IF(n4/=-1)THEN
582 DO p = 1, nspmd
583 IF(nlocal(n1,p)==1.AND.
584 + nlocal(n2,p)==1)THEN
585 IF(n2d==0.AND.n4/=0) THEN
586 CALL ifrontplus(n4,p)
587 ENDIF
588 IF(n2d==0) THEN
589 CALL ifrontplus(n3,p)
590 ENDIF
591 GOTO 8888
592 ENDIF
593 ENDDO
594 ENDIF
595 DO p = 1, nspmd
596 IF(nlocal(n1,p)==1) THEN
597 IF(n2d==0.AND.n4/=0.AND.n4/=-1) THEN
598 CALL ifrontplus(n4,p)
599 ENDIF
600 IF(n2d==0.AND.n4/=-1) THEN
601 CALL ifrontplus(n3,p)
602 ENDIF
603 IF(n4/=-1) THEN
604 CALL ifrontplus(n2,p)
605 ENDIF
606 GOTO 8888
607 ENDIF
608 ENDDO
609 IF(n4/=0.AND.n4/=0.AND.n4/=-1) THEN
610 CALL ifrontplus(n4,1)
611 ENDIF
612 IF(n2d==0.AND.n4/=-1) THEN
613 CALL ifrontplus(n3,1)
614 ENDIF
615 IF(n4/=-1) THEN
616 CALL ifrontplus(n2,1)
617 ENDIF
618 CALL ifrontplus(n1,1)
619 8888 CONTINUE
620 ENDDO
621 ENDDO
622C
623C-----------------------------------------------------
624C Rivets additional treatment
625C-----------------------------------------------------
626 DO p = 1, nspmd
627 DO j=1,nrivet
628 if1 = nlocal(ixri(2,j),p)
629 if2 = nlocal(ixri(3,j),p)
630 IF (if1==1.OR.if2==1) THEN
631 CALL ifrontplus(ixri(2,j),p)
632 CALL ifrontplus(ixri(3,j),p)
633 ENDIF
634 ENDDO
635 ENDDO
636
637C
638C-----------------------------------------------------
639C Additional RBE2 treatment
640C-----------------------------------------------------
641 IF (nrbe2>0.AND.nspmd>1) THEN
642 DO n = 1, nrbe2
643 nsn = irbe2(5,n)
644 m = irbe2(3,n)
645 iad = irbe2(1,n)
646 DO p = 1, nspmd
647 IF (nlocal(m,p)==0) THEN
648 imain = 0
649 DO j = 1, nsn
650 l = lrbe2(iad+j)
651 IF(nlocal(l,p)/=0)THEN
652 imain = 1
653 GO TO 186
654 ENDIF
655 ENDDO
656 186 CONTINUE
657 IF(imain==1)THEN
658 CALL ifrontplus(m,p)
659 ENDIF
660 ENDIF
661 ENDDO
662 ENDDO
663C treatment of unconnected nodes
664 DO n = 1, nrbe2
665 nsn = irbe2(5,n)
666 m = irbe2(3,n)
667 iad = irbe2(1,n)
668 sum = 0
669 insnmax = 0
670 ipmax = 1
671 lastm = 0
672 DO p=1,nspmd
673 IF(nlocal(m,p)/=0) THEN
674 sum = sum + 1
675 lastm = p
676 ENDIF
677 insnp = 0
678 DO j = 1, nsn
679 l = lrbe2(iad+j)
680 IF(nlocal(l,p)/=0)THEN
681 insnp = insnp + 1
682 ENDIF
683 ENDDO
684 IF (insnp>insnmax) THEN
685 ipmax = p
686 insnmax = insnp
687 ENDIF
688 END DO
689 IF(sum==0) THEN
690 IF(insnmax==0) THEN
691 CALL ifrontplus(m,1)
692 ELSE
693 CALL ifrontplus(m,ipmax)
694 ENDIF
695 ELSEIF(insnmax==0) THEN
696 ipmax = lastm
697 ENDIF
698C
699 DO j = 1, nsn
700 l = lrbe2(iad+j)
701 sum = 0
702 DO p=1,nspmd
703 IF(nlocal(l,p)/=0)THEN
704 sum = sum + 1
705 ENDIF
706 ENDDO
707 IF(sum==0) THEN
708 CALL ifrontplus(l,ipmax)
709 ENDIF
710 ENDDO
711 ENDDO
712 ENDIF
713C
714C-----------------------------------------------------
715C Traitement RBE3 : Idem int2
716C-----------------------------------------------------
717 IF (nrbe3>0.AND.nspmd>1) THEN
718 DO n = 1, nrbe3
719 nir = irbe3(5,n)
720 k = irbe3(3,n)
721 iad = irbe3(1,n)
722 imain = 0
723 DO p = 1, nspmd
724 IF (nlocal(k,p)/=0) THEN
725 imain = 1
726 ENDIF
727 ENDDO
728 IF (imain==0) THEN
729 imain = 1
730 DO j=1,nir
731 kk = lrbe3(iad+j)
732 DO p = 1, nspmd
733 IF (nlocal(kk,p)/=0) THEN
734 imain = p
735 GOTO 51
736 ENDIF
737 ENDDO
738 ENDDO
739 51 CONTINUE
740 CALL ifrontplus(k,imain)
741 ENDIF
742 DO p = 1, nspmd
743 IF (nlocal(k,p)==0) THEN
744 GO TO 201
745 ENDIF
746C No optimization possible
747 DO j=1,nir
748 kk = lrbe3(iad+j)
749 IF (nlocal(kk,p)==0) THEN
750 CALL ifrontplus(kk,p)
751 ENDIF
752 ENDDO
753C possible optimization
754 201 CONTINUE
755 ENDDO
756 ENDDO
757 ENDIF
758
759
760C
761C-----------------------------------------------------
762C Rigid bodies additional treatment
763C-----------------------------------------------------
764 IF (nrbykin>0.AND.nspmd>1) THEN
765C--------------------------------------------------------------
766C In case of SECONDARY nodes of unconnected Rigid bodies
767C assign them to PMAIN
768C--------------------------------------------------------------
769 k=0
770 DO n = 1, nrbykin
771 nsn = npby(2,n)
772 m = npby(1,n)
773C Search for the 1st proc that has the main node
774 DO p=1,nspmd
775 IF (nlocal(m,p)/=0) GOTO 86
776 ENDDO
777 86 CONTINUE
778 pm = p
779
780 DO j = 1, nsn
781 l = lpby(k+j)
782 DO p=1,nspmd
783 IF(nlocal(l,p)/=0) GOTO 87
784 ENDDO
785 CALL ifrontplus(l,pm)
786 87 CONTINUE
787 ENDDO
788 k = k + nsn
789 ENDDO
790C--------------------------------------------------------------
791 k=0
792 DO n = 1, nrbykin
793 nsn = npby(2,n)
794 m = npby(1,n)
795 DO p = 1, nspmd
796 IF(nlocal(m,p)==0)THEN
797 imain = 0
798 DO j = 1, nsn
799 l = lpby(k+j)
800 IF(nlocal(l,p)/=0)THEN
801 imain = 1
802 GO TO 85
803 ENDIF
804 ENDDO
805 85 CONTINUE
806 IF(imain==1)THEN
807 CALL ifrontplus(m,p)
808 ENDIF
809 ENDIF
810 ENDDO
811 k = k + nsn
812 ENDDO
813C treatment of unconnected nodes
814 k=0
815 DO n = 1, nrbykin
816 nsn = npby(2,n)
817 m = npby(1,n)
818 sum = 0
819 insnmax = 0
820 ipmax = 1
821 lastm = 0
822 DO p=1,nspmd
823 IF(nlocal(m,p)/=0) THEN
824 sum = sum + 1
825 lastm = p
826 ENDIF
827 insnp = 0
828 DO j = 1, nsn
829 l = lpby(k+j)
830 IF(nlocal(l,p)/=0)THEN
831 insnp = insnp + 1
832 ENDIF
833 ENDDO
834 IF (insnp>insnmax) THEN
835 ipmax = p
836 insnmax = insnp
837 ENDIF
838 END DO
839C
840 IF(sum==0) THEN
841 IF(insnmax==0) THEN
842 CALL ifrontplus(m,1)
843 ELSE
844 CALL ifrontplus(m,ipmax)
845 ENDIF
846C case at least one main connected but no SECONDARY node connected
847 ELSEIF(insnmax==0) THEN
848 ipmax = lastm
849 ENDIF
850C
851 DO j = 1, nsn
852 l = lpby(k+j)
853 sum = 0
854 DO p=1,nspmd
855 IF(nlocal(l,p)/=0)THEN
856 sum = sum + 1
857 ENDIF
858 ENDDO
859 IF(sum==0) THEN
860 CALL ifrontplus(l,ipmax)
861 ENDIF
862 ENDDO
863 k = k + nsn
864 ENDDO
865
866 ENDIF
867C
868
869C-----------------------------------------------------
870C RBM supplementary treatment: Ditto RB
871C-----------------------------------------------------
872 IF(nfxvel > 0 .AND. nspmd > 1)THEN
873
874 DO n=1,nfxvel
875 fingeo = ibfv(13,n)
876 IF (fingeo == 2)THEN ! FINGEO=2 option /IMPVEL/FGEO
877 n1 = ibfv(1,n) ! This impvel option has 2 nodes,
878 n2 = ibfv(14,n) ! ensure that the Nodes are on same domain.
879
880 iad1 = ifront%IENTRY(n1)
881 iad2 = ifront%IENTRY(n2)
882
883 IF (iad1 == -1 .AND. iad2 == -1)THEN ! Case Both nodes are free
884 CALL ifrontplus(n1,1) ! Stick them on processor 1 to avoid them
885 CALL ifrontplus(n2,1) ! to be sticked on different DOMAINS
886 ELSE
887 IF(iad1 /= -1 ) THEN
888 DO WHILE (iad1 /= 0) ! IAD1 is the pointer of Node1
889 p = ifront%P(1,iad1)
890 CALL ifrontplus(n2,p) ! Stick Node2 where Node1 is
891 iad1=ifront%P(2,iad1) ! NEXT
892 ENDDO
893 ENDIF
894
895 IF(iad2 /= -1 ) THEN
896 DO WHILE (iad2 /= 0) ! IAD2 is the pointer of Node2
897 p = ifront%P(1,iad2)
898 CALL ifrontplus(n1,p) ! Stick Node1 where Node2 is
899 iad2=ifront%P(2,iad2) ! NEXT
900 ENDDO
901 ENDIF
902
903 ENDIF
904 ENDIF
905 ENDDO
906 ENDIF ! IF(NFXVEL > 0 .AND. NSPMD > 1)THEN
907
908 IF (nibvel>0.AND.nspmd>1) THEN
909 k=0
910 DO n = 1, nibvel
911 nsn = ibvel(3,n)
912 m = ibvel(4,n)
913 DO p = 1, nspmd
914 IF (nlocal(m,p)==0) THEN
915 imain = 0
916 DO j = 1, nsn
917 l = lbvel(k+j)
918 IF(nlocal(l,p)/=0)THEN
919 imain = 1
920 GO TO 185
921 ENDIF
922 ENDDO
923 185 CONTINUE
924 IF(imain==1)THEN
925 CALL ifrontplus(m,p)
926 ENDIF
927 ENDIF
928 ENDDO
929 k = k + nsn
930 ENDDO
931C treatment of unconnected nodes
932 k=0
933 DO n = 1, nibvel
934 nsn = ibvel(3,n)
935 m = ibvel(4,n)
936 sum = 0
937 insnmax = 0
938 ipmax = 1
939 lastm = 0
940 DO p=1,nspmd
941 IF(nlocal(m,p)/=0) THEN
942 sum = sum + 1
943 lastm = p
944 ENDIF
945 insnp = 0
946 DO j = 1, nsn
947 l = lbvel(k+j)
948 IF(nlocal(l,p)/=0)THEN
949 insnp = insnp + 1
950 ENDIF
951 ENDDO
952 IF (insnp>insnmax) THEN
953 ipmax = p
954 insnmax = insnp
955 ENDIF
956 END DO
957 IF(sum==0) THEN
958 IF(insnmax==0) THEN
959 CALL ifrontplus(m,1)
960 ELSE
961 CALL ifrontplus(m,ipmax)
962 ENDIF
963 ELSEIF(insnmax==0) THEN
964 ipmax = lastm
965 ENDIF
966C
967 DO j = 1, nsn
968 l = lbvel(k+j)
969 sum = 0
970 DO p=1,nspmd
971 IF(nlocal(l,p)/=0)THEN
972 sum = sum + 1
973 ENDIF
974 ENDDO
975 IF(sum==0) THEN
976 CALL ifrontplus(l,ipmax)
977 ENDIF
978 ENDDO
979 k = k + nsn
980 ENDDO
981 ENDIF
982C
983C-----------------------------------------------------
984C Traitement rigid materials
985C-----------------------------------------------------
986 IF (irigid_mat>0.AND.nspmd>1) THEN
987 k=0
988 DO n = 1, nrbym
989 nsn = irbym(2,n)
990 DO p = 1, nspmd
991 imain = 0
992 DO j = 1, nsn
993 l = lcrbym(k+j)
994 IF(nlocal(l,p)/=0)THEN
995 imain = 1
996 GO TO 195
997 ENDIF
998 ENDDO
999 195 CONTINUE
1000 IF(imain==1)THEN
1001 CALL frontplus_rm(front_rm(n,p),1)
1002 ENDIF
1003 ENDDO
1004 k = k + nsn
1005 ENDDO
1006C Non -connect CDG treatment
1007 k=0
1008 DO n = 1, nrbym
1009 nsn = irbym(2,n)
1010 m = irbym(1,n)
1011 sum = 0
1012 insnmax = 0
1013 ipmax = 1
1014 lastm = 0
1015 DO p=1,nspmd
1016 IF(front_rm(m,p)/=0.AND.front_rm(m,p)/=100) THEN
1017 sum = sum + 1
1018 lastm = p
1019 ENDIF
1020 insnp = 0
1021 DO j = 1, nsn
1022 l = lcrbym(k+j)
1023 IF(nlocal(l,p)/=0)THEN
1024 insnp = insnp + 1
1025 ENDIF
1026 ENDDO
1027 IF (insnp>insnmax) THEN
1028 ipmax = p
1029 insnmax = insnp
1030 ENDIF
1031 END DO
1032C
1033 IF(sum==0) THEN
1034 IF(insnmax==0) THEN
1035 CALL frontplus_rm(front_rm(m,1),1)
1036 ELSE
1037 CALL frontplus_rm(front_rm(m,ipmax),1)
1038 ENDIF
1039C case at least one main connected but no SECONDARY node connected
1040 ELSEIF(insnmax==0) THEN
1041 ipmax = lastm
1042 ENDIF
1043C
1044 DO j = 1, nsn
1045 l = lcrbym(k+j)
1046 sum = 0
1047 DO p=1,nspmd
1048 IF(nlocal(l,p)/=0)THEN
1049 sum = sum + 1
1050 ENDIF
1051 ENDDO
1052 IF(sum==0) THEN
1053 CALL ifrontplus(l,ipmax)
1054 ENDIF
1055 ENDDO
1056 k = k + nsn
1057 ENDDO
1058 ELSEIF(irigid_mat > 0) THEN
1059 DO n = 1, nrbym
1060 CALL frontplus_rm(front_rm(n,1),1)
1061 ENDDO
1062 ENDIF
1063C-----------------------------------------------------
1064C Traitement special /BSC/CYCLIC
1065C-----------------------------------------------------
1066 DO n = 1, nbcscyc
1067 k = ibcscyc(1,n)
1068 nsn=ibcscyc(3,n)
1069 DO j = 1, nsn
1070 n1 = lbcscyc(1,k+j)
1071 n2 = lbcscyc(2,k+j)
1072 DO p = 1, nspmd
1073 IF(nlocal(n1,p)==1 .AND. nlocal(n2,p)==0)CALL ifrontplus(n2,p)
1074 IF(nlocal(n2,p)==1 .AND. nlocal(n1,p)==0)CALL ifrontplus(n1,p)
1075 ENDDO
1076 ENDDO
1077 ENDDO
1078C-----------------------------------------------------
1079C Traitement Itet=2 of S10
1080C-----------------------------------------------------
1081 IF (ns10e>0.AND.nspmd>1) THEN
1082 CALL c_doms10(icnds10,itagnd,ite2frplus)
1083 IF (ite2frplus > 0 ) GOTO 5000
1084 ENDIF
1085C-----------------------------------------------------
1086C Additional treatment Type 2 interface
1087C-----------------------------------------------------
1088 IF (ninter>0.AND.nspmd>1) THEN
1089 IF (n2d==0) THEN
1090 nir = 4
1091 ELSE
1092 nir = 2
1093 ENDIF
1094 DO n = 1, ninter
1095 nty = ipari(7,n)
1096 IF (nty==2) THEN
1097 nrts = ipari(3,n)
1098 nrtm = ipari(4,n)
1099 nsn = ipari(5,n)
1100 nmn = ipari(6,n)
1101 ilev = ipari(20,n)
1102 IF (ilev == 25 .or. ilev == 26 .or. ilev == 27 .or. ilev == 28) int2flag=1
1103 DO i=1,nsn
1104 l = intbuf_tab(n)%IRTLM(i)
1105 k = intbuf_tab(n)%NSV(i)
1106C
1107 imain = 0
1108 DO p = 1, nspmd
1109 IF (nlocal(k,p)/=0) THEN
1110 imain = 1
1111 ENDIF
1112 ENDDO
1113 IF (imain==0) THEN
1114 imain = 1
1115 DO j=1,nir
1116 kk = intbuf_tab(n)%IRECTM((l-1)*4+j)
1117 DO p = 1, nspmd
1118 IF (nlocal(kk,p)/=0) THEN
1119 imain = p
1120 GOTO 50
1121 ENDIF
1122 ENDDO
1123 ENDDO
1124 50 CONTINUE
1125 CALL ifrontplus(k,imain)
1126 int2frplus=1
1127
1128 ENDIF
1129 DO p = 1, nspmd
1130 IF (nlocal(k,p)==0) THEN
1131 GO TO 200
1132 ENDIF
1133C No optimization possible
1134 DO j=1,nir
1135 kk = intbuf_tab(n)%IRECTM((l-1)*4+j)
1136 IF (nlocal(kk,p)==0) THEN
1137 CALL ifrontplus(kk,p)
1138 int2frplus=1
1139 ENDIF
1140 ENDDO
1141C possible optimization
1142 200 CONTINUE
1143 ENDDO
1144 ENDDO
1145 ENDIF
1146 ENDDO
1147 ENDIF
1148 IF (int2frplus /= 0 .AND. int2flag/=0)GOTO 5000
1149C-----------------------------------------------------
1150C Special treatment of nodes not yet assigned
1151C-----------------------------------------------------
1152C assigning unassigned nodes to Pi (round robin)
1153 iproc = 1
1154 DO i = 1,numnod
1155 sum = 0
1156 IF(ifront%IENTRY(i)==-1) THEN
1157 ifront%IENTRY(i)=i
1158 ifront%P(1,i) = iproc
1159 ifront%P(2,i) = 0
1160 iproc = mod(iproc,nspmd)+1
1161 ENDIF
1162 END DO
1163C-----------------------------------------------------
1164C Traitement special sensor type2
1165C-----------------------------------------------------
1166 IF(sensors%NSENSOR>0) THEN
1167 DO p = 1, nspmd
1168 nsensp(p) = 0
1169 END DO
1170 DO i=1,sensors%NSENSOR
1171 typ = sensors%SENSOR_TAB(i)%TYPE
1172 isensp(1,i) = 0
1173 isensp(2,i) = 0
1174C
1175 IF(typ==0)THEN
1176 ELSEIF(typ==1)THEN
1177 ELSEIF(typ==2)THEN
1178C--------------------------------
1179C SENSOR - DISPLACEMENT
1180C--------------------------------
1181 n1 = sensors%SENSOR_TAB(i)%IPARAM(1)
1182 DO p = 1, nspmd
1183 IF(nlocal(n1,p)==1)THEN
1184 isensp(1,i) = p
1185 nsensp(p) = nsensp(p)+1
1186 GOTO 500
1187 END IF
1188 END DO
1189 500 CONTINUE
1190 n2 = sensors%SENSOR_TAB(i)%IPARAM(2)
1191 DO p = 1, nspmd
1192 IF(nlocal(n2,p)==1)THEN
1193 isensp(2,i) = p
1194 nsensp(p) = nsensp(p)+1
1195 GOTO 600
1196 END IF
1197 END DO
1198 600 CONTINUE
1199 ELSEIF(typ==3)THEN
1200 ELSEIF(typ==4)THEN
1201 ELSEIF(typ==5)THEN
1202 ELSEIF(typ==6)THEN
1203 ELSEIF(typ==7)THEN
1204 ELSEIF(typ==8)THEN
1205c
1206 ELSEIF(typ==13)THEN ! SENSOR WORK
1207 n1 = sensors%SENSOR_TAB(i)%IPARAM(1)
1208 DO p = 1, nspmd
1209 IF (nlocal(n1,p)==1) THEN
1210 isensp(1,i) = p
1211 nsensp(p) = nsensp(p)+1
1212 EXIT
1213 END IF
1214 END DO
1215 n2 = sensors%SENSOR_TAB(i)%IPARAM(2)
1216 IF (n2 > 0) THEN
1217 DO p = 1, nspmd
1218 IF (nlocal(n2,p)==1) THEN
1219 isensp(2,i) = p
1220 nsensp(p) = nsensp(p)+1
1221 EXIT
1222 END IF
1223 END DO
1224 ENDIF
1225c
1226 ELSEIF(typ==14)THEN
1227 ELSEIF(typ>=29.AND.typ<=31) THEN
1228 ELSE
1229 ENDIF
1230 ENDDO
1231 END IF
1232C
1233C-----------------------------------------------------
1234C Traitement special accelerometres
1235C-----------------------------------------------------
1236 IF(naccelm>0) THEN
1237 DO p = 1, nspmd
1238 naccp(p) = 0
1239 END DO
1240C
1241 DO i=1,naccelm
1242 n1 = laccelm(1,i)
1243 DO p = 1, nspmd
1244 IF(nlocal(n1,p)==1)THEN
1245 iaccp(i) = p
1246 naccp(p) = naccp(p)+1
1247 EXIT
1248 END IF
1249 END DO
1250 END DO
1251 END IF
1252C
1253C-----------------------------------------------------
1254C Traitement special gauges
1255C-----------------------------------------------------
1256 IF(nbgauge>0) THEN
1257 DO p = 1, nspmd
1258 ngaup(p) = 0
1259 END DO
1260C
1261 DO i=1,nbgauge
1262 n1=lgauge(3,i)
1263 IF(n1>0)THEN
1264 DO p = 1, nspmd
1265 IF(nlocal(n1,p)==1)THEN
1266 igaup(i) = p
1267 ngaup(p) = ngaup(p)+1
1268 EXIT
1269 END IF
1270 END DO
1271 !!ELSE
1272 ELSEIF(n1<0)THEN
1273 n1 = -n1 + numels
1274 p = cep(n1 ) + 1
1275 igaup(i) = p
1276 ngaup(p) = ngaup(p) + 1
1277 ENDIF
1278 END DO
1279 END IF
1280
1281 IF(njoint>0) CALL split_joint( )
1282
1283C-----------------------------------------------------
1284C dd_iad => dd_grp : number of groups per subdomain
1285 ngrou = 0
1286 DO i = 1, nspgroup
1287 DO p = 1, nspmd
1288c IF (DD_IAD(P+1,I)>0) THEN
1289c NEL = DD_IAD(P+1,I) - DD_IAD(P,I)
1290c IF (NEL>0) THEN
1291c NG = (NEL-1)/NVSIZ + 1
1292c NGROU = NGROU + NG
1293c ELSE
1294c NG = 0
1295c ENDIF
1296c DD_IAD(P,I) = NG
1297c ELSE
1298c DD_IAD(P,I) = 0
1299c ENDIF
1300C only verification is preserved, dd_iad replacement is done directly in xtails routines
1301 ngrou = ngrou + dd_iad(p,i)
1302 ENDDO
1303 ENDDO
1304 IF (ngrou/=ngroup) THEN
1305C WRITE(IOUT,*)'** ERROR : DOMAIN DEC AND NGROUP DIFFER'
1306C WRITE(ISTDO,*)'** ERROR : DOMAIN DEC AND NGROUP DIFFER'
1307C IERR = IERR + 1
1308 CALL ancmsg(msgid=363,
1309 . msgtype=msgerror,
1310 . anmode=aninfo_blind_1,
1311 . i1=ngrou,
1312 . i2=ngroup)
1313 ENDIF
1314C
1315C-----------------------------------------------------
1316C Preparing ADDCNE : CNE matrix address
1317C-----------------------------------------------------
1318 DO n=0,numnod+1
1319 addcne(n) = 0
1320 ENDDO
1321C
1322 DO k=2,9
1323 DO i=1,numels
1324 n = ixs(k,i) + 1
1325 addcne(n) = addcne(n) + 1
1326 ENDDO
1327 ENDDO
1328C
1329 IF(numels10>0) THEN
1330 DO k=1,6
1331 DO i=1,numels10
1332 n = ixs10(k,i) + 1
1333 addcne(n) = addcne(n) + 1
1334 ENDDO
1335 ENDDO
1336 ENDIF
1337 IF(numels20>0)THEN
1338 DO k=1,12
1339 DO i=1,numels20
1340 n = ixs20(k,i) + 1
1341 addcne(n) = addcne(n) + 1
1342 ENDDO
1343 ENDDO
1344 ENDIF
1345C
1346 IF(numels16>0)THEN
1347 DO k=1,8
1348 DO i=1,numels16
1349 n = ixs16(k,i) + 1
1350 addcne(n) = addcne(n) + 1
1351 ENDDO
1352 ENDDO
1353 ENDIF
1354C
1355 DO k=2,5
1356 DO i=1,numelq
1357 n = ixq(k,i) + 1
1358 addcne(n) = addcne(n) + 1
1359 ENDDO
1360 ENDDO
1361C
1362
1363 DO k=2,5
1364 DO i=1,numelc
1365 n = ixc(k,i) + 1
1366 addcne(n) = addcne(n) + 1
1367 ENDDO
1368 ENDDO
1369C
1370 DO k=2,3
1371 DO i=1,numelt
1372 n = ixt(k,i) + 1
1373 addcne(n) = addcne(n) + 1
1374 ENDDO
1375 ENDDO
1376C
1377 DO k=2,3
1378 DO i=1,numelp
1379 n = ixp(k,i) + 1
1380 addcne(n) = addcne(n) + 1
1381 ENDDO
1382 ENDDO
1383C
1384C separate treatment of 3rd optional node except type 12
1385 DO k=2,3
1386 DO i=1,numelr
1387 n = ixr(k,i) + 1
1388 addcne(n) = addcne(n) + 1
1389 ENDDO
1390 ENDDO
1391 DO i=1,numelr
1392 n = ixr(4,i) + 1
1393 IF(igeo(11,ixr(1,i))/=12) n = 0
1394 addcne(n) = addcne(n) + 1
1395 ENDDO
1396C
1397 DO k=2,4
1398 DO i=1,numeltg
1399 n = ixtg(k,i) + 1
1400 addcne(n) = addcne(n) + 1
1401 ENDDO
1402 ENDDO
1403C elem penta6
1404 IF(numeltg6>0)THEN
1405 DO k=1,3
1406 DO i=1,numeltg6
1407 n = ixtg6(k,i)+1
1408 addcne(n) = addcne(n) + 1
1409 END DO
1410 END DO
1411 END IF
1412C
1413C--------------------------------------
1414C taking into account mv forces
1415C--------------------------------------
1416 IF (nvolu>0) THEN
1417 k3 = 1 + nimv * nvolu + nicbag * nvolu * nvolu
1418 k1 = 1
1419 DO n = 1, nvolu
1420 is = t_monvol(n)%EXT_SURFID
1421 nn_s = igrsurf(is)%NSEG
1422 DO j = 1, nn_s
1423 ity=igrsurf(is)%ELTYP(j)
1424 i = igrsurf(is)%ELEM(j)
1425 IF (ity==3) THEN
1426 DO k = 2,5
1427 nn = ixc(k,i) + 1
1428 addcne(nn) = addcne(nn) + 1
1429 ENDDO
1430 ELSE
1431 DO k=2,4
1432 nn = ixtg(k,i) + 1
1433 addcne(nn) = addcne(nn) + 1
1434 END DO
1435 ENDIF
1436 ENDDO
1437 k1 = k1 + nimv
1438 ENDDO
1439 ENDIF
1440C--------------------------------------
1441C taking into account concentrated forces + pressure loads
1442C--------------------------------------
1443 IF(nconld>0) THEN
1444 DO nl = 1, nconld
1445 n1=ib(1,nl)
1446 n2=ib(2,nl)
1447 n3=ib(3,nl)
1448 n4=ib(4,nl)
1449 nn = n1 + 1
1450 addcne(nn) = addcne(nn) + 1
1451 IF(n4/=-1)THEN
1452 nn = n2 + 1
1453 addcne(nn) = addcne(nn) + 1
1454 IF(n2d==0)THEN
1455 nn = n3 + 1
1456 addcne(nn) = addcne(nn) + 1
1457 IF(n4/=0) THEN
1458 nn = n4 + 1
1459 addcne(nn) = addcne(nn) + 1
1460 ENDIF
1461 ENDIF
1462 ENDIF
1463 ENDDO
1464 ENDIF
1465C-----------------------------------------------
1466C pseudo element BC for heat transfert
1467C-----------------------------------------------
1468 IF(numconv>0) THEN
1469 DO nl = 1, numconv
1470 n1=ibcv(1,nl)
1471 n2=ibcv(2,nl)
1472 n3=ibcv(3,nl)
1473 n4=ibcv(4,nl)
1474 nn = n1 + 1
1475 addcne(nn) = addcne(nn) + 1
1476 IF(n4/=-1)THEN
1477 nn = n2 + 1
1478 addcne(nn) = addcne(nn) + 1
1479 IF(n2d==0)THEN
1480 nn = n3 + 1
1481 addcne(nn) = addcne(nn) + 1
1482 IF(n4/=0) THEN
1483 nn = n4 + 1
1484 addcne(nn) = addcne(nn) + 1
1485 ENDIF
1486 ENDIF
1487 ENDIF
1488 ENDDO
1489 ENDIF
1490C-----------------------------------------------
1491C pseudo element BR for radiative heat transfert
1492C-----------------------------------------------
1493 IF(numradia>0) THEN
1494 DO nl = 1, numradia
1495 n1=ibcr(1,nl)
1496 n2=ibcr(2,nl)
1497 n3=ibcr(3,nl)
1498 n4=ibcr(4,nl)
1499 nn = n1 + 1
1500 addcne(nn) = addcne(nn) + 1
1501 nn = n2 + 1
1502 addcne(nn) = addcne(nn) + 1
1503 IF(n2d==0)THEN
1504 nn = n3 + 1
1505 addcne(nn) = addcne(nn) + 1
1506 IF(n4/=0) THEN
1507 nn = n4 + 1
1508 addcne(nn) = addcne(nn) + 1
1509 ENDIF
1510 ENDIF
1511 ENDDO
1512 ENDIF
1513C-----------------------------------------------
1514C pseudo element for imposed heat flux
1515C-----------------------------------------------
1516 IF(nfxflux>0) THEN
1517 DO nl = 1, nfxflux
1518 IF(ibfflux(10,nl) == 1) cycle
1519 n1=ibfflux(1,nl)
1520 n2=ibfflux(2,nl)
1521 n3=ibfflux(3,nl)
1522 n4=ibfflux(4,nl)
1523 nn = n1 + 1
1524 addcne(nn) = addcne(nn) + 1
1525 IF(n4/=-1)THEN
1526 nn = n2 + 1
1527 addcne(nn) = addcne(nn) + 1
1528 IF(n2d==0)THEN
1529 nn = n3 + 1
1530 addcne(nn) = addcne(nn) + 1
1531 IF(n4/=0) THEN
1532 nn = n4 + 1
1533 addcne(nn) = addcne(nn) + 1
1534 ENDIF
1535 ENDIF
1536 ENDIF
1537 ENDDO
1538 ENDIF
1539C--------------------------------------
1540C prise en compte des load/pfluid
1541C--------------------------------------
1542 IF(nloadp>0) THEN
1543 DO nl = 1, nloadp
1544 DO i = 1,iloadp(1,nl)/4
1545 n1=lloadp(iloadp(4,nl)+4*(i-1))
1546 n2=lloadp(iloadp(4,nl)+4*(i-1)+1)
1547 n3=lloadp(iloadp(4,nl)+4*(i-1)+2)
1548 n4=lloadp(iloadp(4,nl)+4*(i-1)+3)
1549 nn = n1 + 1
1550 addcne(nn) = addcne(nn) + 1
1551 IF(n4/=-1)THEN
1552 nn = n2 + 1
1553 addcne(nn) = addcne(nn) + 1
1554 IF(n2d==0)THEN
1555 nn = n3 + 1
1556 addcne(nn) = addcne(nn) + 1
1557 IF(n4/=0) THEN
1558 nn = n4 + 1
1559 addcne(nn) = addcne(nn) + 1
1560 ENDIF
1561 ENDIF
1562 ENDIF
1563 ENDDO
1564 ENDDO
1565 ENDIF
1566
1567! -------------------------------------
1568! Euler boundary conditions : non-relecting frontier
1569! add 1 contribution per node of element
1570! ------------
1571 IF(nebcs>0) THEN
1572 DO i=1,nebcs
1573 is_ebcs_parallel = .false.
1574 IF(ebcs_tab%tab(i)%poly%type == 10 .or. ebcs_tab%tab(i)%poly%type == 11)is_ebcs_parallel=.true.
1575 IF(is_ebcs_parallel) THEN
1576 surf_id = ebcs_tab%tab(i)%poly%surf_id ! surface id
1577 number_node = 4
1578 IF(n2d/=0) number_node = 2
1579 ! ------------
1580 ! loop over the elements of the EBCS
1581 DO j=1,ebcs_tab%tab(i)%poly%nb_elem
1582 ! loop over the 4 nodes of the surfaces
1583 DO ijk=1,number_node
1584 node_id = igrsurf(surf_id)%NODES(j,ijk) + 1
1585 addcne(node_id) = addcne(node_id) + 1
1586 ENDDO
1587 ENDDO
1588 ! ------------
1589 ENDIF
1590 ENDDO
1591 ENDIF
1592! -------------------------------------
1593! /LOAD/PCYL : add 1 contribution per node per segment
1594! ------------
1595! ! loop over the /LOAD/PCYL
1596 DO i=1,loads%NLOAD_CYL
1597 number_segment = loads%LOAD_CYL(i)%NSEG ! number of segment for the PCYL I
1598 ! ------------
1599 DO j=1,number_segment ! loop over the segments of the surface
1600 DO k=1,4
1601 node_id = loads%LOAD_CYL(i)%SEGNOD(j,k) + 1! get the node id + 1 (if the segment is a triangle, NODE_ID(node 4) = 0))
1602 number_proc = 0
1603 IF(node_id/=0) addcne(node_id) = addcne(node_id) + 1
1604 ENDDO
1605 ENDDO
1606 ! ------------
1607 ENDDO
1608! -------------------------------------
1609
1610C-----------------------------------------------
1611C CALCULATING SKYLINE VECTOR ADDRESSES
1612C-----------------------------------------------
1613 addcne(1) = 1
1614 DO i=2,numnod+1
1615 addcne(i)=addcne(i)+addcne(i-1)
1616 ENDDO
1617C
1618 lcne = addcne(numnod+1)-1
1619C
1620C-----------------------------------------------
1621C Filling Cel: Element/Local Connection
1622C-----------------------------------------------
1623 off = 0
1624 nin = 0
1625 ity_old = 0
1626 DO proc = 1, nspmd
1627 off = 0
1628 nin = 0
1629 ity_old = 0
1630 DO ng = 1, ngroup
1631 nel = iparg(2,ng)
1632 p = iparg(32,ng)+1
1633 ity = iparg(5,ng)
1634 IF (ity/=ity_old) THEN
1635 nin = 0
1636 ity_old = ity
1637 ENDIF
1638C SPH not taken in comp
1639 IF(ity/=51) THEN
1640 IF (p==proc) THEN
1641 DO i = 1, nel
1642 cel(i+off) = nin+i
1643 ENDDO
1644 nin = nin + nel
1645 ENDIF
1646 off = off + nel
1647 ENDIF
1648 ENDDO
1649 ENDDO
1650
1651c IELS array initialized to 0 (for SPH treatment)
1652 DO proc = 1,nspmd
1653 iels(proc) = 0
1654 ENDDO
1655
1656c filling CELSPH array for SPH treatment
1657 DO j = 1, numsph
1658 p_sph = cepsp(j) + 1
1659 iels(p_sph) = iels(p_sph) + 1
1660 celsph(j) = iels(p_sph)
1661 ENDDO
1662C-----------------------------------------------
1663C Adding pseudo element BCL
1664C-----------------------------------------------
1665 IF(nconld>0) THEN
1666 DO nl = 1, nconld
1667 cel(off+nl) = 0
1668 ENDDO
1669C
1670 DO proc = 1, nspmd
1671 nl_l = 0
1672 DO nl = 1, nconld
1673 IF(cel(off+nl)==0) THEN
1674 n1=ib(1,nl)
1675 n2=ib(2,nl)
1676 n3=ib(3,nl)
1677 n4=ib(4,nl)
1678 IF(n4/=-1)THEN
1679 IF(n2d==0)THEN
1680 IF(n4/=0) THEN
1681 IF(nlocal(n1,proc)==1.AND.
1682 + nlocal(n2,proc)==1.AND.
1683 + nlocal(n3,proc)==1.AND.
1684 + nlocal(n4,proc)==1)THEN
1685 nl_l = nl_l + 1
1686 cel(nl+off) = nl_l
1687 ENDIF
1688 ELSE
1689 IF(nlocal(n1,proc)==1.AND.
1690 + nlocal(n2,proc)==1.AND.
1691 + nlocal(n3,proc)==1)THEN
1692 nl_l = nl_l + 1
1693 cel(nl+off) = nl_l
1694 ENDIF
1695 ENDIF
1696 ELSE
1697 IF(nlocal(n1,proc)==1.AND.
1698 + nlocal(n2,proc)==1)THEN
1699 nl_l = nl_l + 1
1700 cel(nl+off) = nl_l
1701 ENDIF
1702 ENDIF
1703 ELSE
1704 IF(nlocal(n1,proc)==1) THEN
1705 nl_l = nl_l + 1
1706 cel(nl+off) = nl_l
1707 ENDIF
1708 ENDIF
1709 ENDIF
1710 ENDDO
1711C
1712 ENDDO
1713 off = off + nconld
1714 ENDIF
1715C-----------------------------------------------
1716C Adding pseudo element bc for heat transfer
1717C-----------------------------------------------
1718 IF(numconv>0) THEN
1719 DO nl = 1, numconv
1720 cel(off+nl) = 0
1721 ENDDO
1722C
1723 DO proc = 1, nspmd
1724 nl_l = 0
1725 DO nl = 1, numconv
1726 IF(cel(off+nl)==0) THEN
1727 n1=ibcv(1,nl)
1728 n2=ibcv(2,nl)
1729 n3=ibcv(3,nl)
1730 n4=ibcv(4,nl)
1731 IF(ibcv(7,nl) == 1) THEN
1732 IF(proc-1 == cep(ibcv(8,nl))) THEN
1733 nl_l = nl_l + 1
1734 cel(nl+off) = nl_l
1735 ENDIF
1736 ELSE
1737 IF(n2d==0)THEN
1738 IF(n4/=0) THEN
1739 IF(nlocal(n1,proc)==1.AND.
1740 + nlocal(n2,proc)==1.AND.
1741 + nlocal(n3,proc)==1.AND.
1742 + nlocal(n4,proc)==1)THEN
1743 nl_l = nl_l + 1
1744 cel(nl+off) = nl_l
1745 ENDIF
1746 ELSE
1747 IF(nlocal(n1,proc)==1.AND.
1748 + nlocal(n2,proc)==1.AND.
1749 + nlocal(n3,proc)==1)THEN
1750 nl_l = nl_l + 1
1751 cel(nl+off) = nl_l
1752 ENDIF
1753 ENDIF
1754 ELSE
1755 IF(nlocal(n1,proc)==1.AND.
1756 + nlocal(n2,proc)==1)THEN
1757 nl_l = nl_l + 1
1758 cel(nl+off) = nl_l
1759 ENDIF
1760 ENDIF
1761 ENDIF
1762 ENDIF
1763 ENDDO
1764 ENDDO
1765 off = off + numconv
1766 ENDIF
1767C-----------------------------------------------
1768C Adding pseudo element br for radiative heat transfer
1769C-----------------------------------------------
1770 IF(numradia>0) THEN
1771 DO nl = 1, numradia
1772 cel(off+nl) = 0
1773 ENDDO
1774C
1775 DO proc = 1, nspmd
1776 nl_l = 0
1777 DO nl = 1, numradia
1778 IF(cel(off+nl)==0) THEN
1779 n1=ibcr(1,nl)
1780 n2=ibcr(2,nl)
1781 n3=ibcr(3,nl)
1782 n4=ibcr(4,nl)
1783 IF(ibcr(7,nl) == 1) THEN
1784 IF(proc-1== cep(ibcr(8,nl))) THEN
1785 nl_l = nl_l + 1
1786 cel(nl+off) = nl_l
1787 ENDIF
1788 ELSE
1789 IF(n2d==0)THEN
1790 IF(n4/=0) THEN
1791 IF(nlocal(n1,proc)==1.AND.
1792 + nlocal(n2,proc)==1.AND.
1793 + nlocal(n3,proc)==1.AND.
1794 + nlocal(n4,proc)==1)THEN
1795 nl_l = nl_l + 1
1796 cel(nl+off) = nl_l
1797 ENDIF
1798 ELSE
1799 IF(nlocal(n1,proc)==1.AND.
1800 + nlocal(n2,proc)==1.AND.
1801 + nlocal(n3,proc)==1)THEN
1802 nl_l = nl_l + 1
1803 cel(nl+off) = nl_l
1804 ENDIF
1805 ENDIF
1806 ELSE
1807 IF(nlocal(n1,proc)==1.AND.
1808 + nlocal(n2,proc)==1)THEN
1809 nl_l = nl_l + 1
1810 cel(nl+off) = nl_l
1811 ENDIF
1812 ENDIF
1813 ENDIF
1814 ENDIF
1815 ENDDO
1816 ENDDO
1817 off = off + numradia
1818 ENDIF
1819C-----------------------------------------------
1820C Adding pseudo element for imposed heat flux
1821C-----------------------------------------------
1822 IF(nfxflux>0) THEN
1823 DO nl = 1, nfxflux
1824 cel(off+nl) = 0
1825 ENDDO
1826C
1827 DO proc = 1, nspmd
1828 nl_l = 0
1829 DO nl = 1, nfxflux
1830 IF(ibfflux(10,nl) == 1) cycle
1831 IF(cel(off+nl)==0) THEN
1832 n1=ibfflux(1,nl)
1833 n2=ibfflux(2,nl)
1834 n3=ibfflux(3,nl)
1835 n4=ibfflux(4,nl)
1836 IF(n2d==0)THEN
1837 IF(n4/=0) THEN
1838 IF(nlocal(n1,proc)==1.AND.
1839 + nlocal(n2,proc)==1.AND.
1840 + nlocal(n3,proc)==1.AND.
1841 + nlocal(n4,proc)==1)THEN
1842 nl_l = nl_l + 1
1843 cel(nl+off) = nl_l
1844 ENDIF
1845 ELSE
1846 IF(nlocal(n1,proc)==1.AND.
1847 + nlocal(n2,proc)==1.AND.
1848 + nlocal(n3,proc)==1)THEN
1849 nl_l = nl_l + 1
1850 cel(nl+off) = nl_l
1851 ENDIF
1852 ENDIF
1853 ELSE
1854 IF(nlocal(n1,proc)==1.AND.nlocal(n2,proc)==1)THEN
1855 nl_l = nl_l + 1
1856 cel(nl+off) = nl_l
1857 ENDIF
1858 ENDIF
1859 ENDIF
1860 ENDDO
1861 ENDDO
1862 off = off + nfxflux
1863 ENDIF
1864C-----------------------------------------------
1865C Adding pseudo element pfluid
1866C-----------------------------------------------
1867 IF(nloadp>0) THEN
1868 numloadp=0
1869 DO nl = 1, nloadp
1870 DO i = 1,iloadp(1,nl)/4
1871 cel(off+numloadp+i) = 0
1872 ENDDO
1873 numloadp=numloadp+iloadp(1,nl)/4
1874 ENDDO
1875C
1876 DO proc = 1, nspmd
1877 nl_l = 0
1878 numloadp=0
1879 DO nl = 1, nloadp
1880 DO i = 1,iloadp(1,nl)/4
1881 IF(cel(off+numloadp+i)==0) THEN
1882 n1=lloadp(iloadp(4,nl)+4*(i-1))
1883 n2=lloadp(iloadp(4,nl)+4*(i-1)+1)
1884 n3=lloadp(iloadp(4,nl)+4*(i-1)+2)
1885 n4=lloadp(iloadp(4,nl)+4*(i-1)+3)
1886 IF(n4/=-1)THEN
1887 IF(n2d==0)THEN
1888 IF(n4/=0) THEN
1889 IF(nlocal(n1,proc)==1.AND.
1890 + nlocal(n2,proc)==1.AND.
1891 + nlocal(n3,proc)==1.AND.
1892 + nlocal(n4,proc)==1)THEN
1893 nl_l = nl_l + 1
1894 cel(off+numloadp+i) = nl_l
1895 ENDIF
1896 ELSE
1897 IF(nlocal(n1,proc)==1.AND.
1898 + nlocal(n2,proc)==1.AND.
1899 + nlocal(n3,proc)==1)THEN
1900 nl_l = nl_l + 1
1901 cel(off+numloadp+i) = nl_l
1902 ENDIF
1903 ENDIF
1904 ELSE
1905 IF(nlocal(n1,proc)==1.AND.
1906 + nlocal(n2,proc)==1)THEN
1907 nl_l = nl_l + 1
1908 cel(off+numloadp+i) = nl_l
1909 ENDIF
1910 ENDIF
1911 ELSE
1912 IF(nlocal(n1,proc)==1) THEN
1913 nl_l = nl_l + 1
1914 cel(off+numloadp+i) = nl_l
1915 ENDIF
1916 ENDIF
1917 ENDIF
1918 ENDDO
1919 numloadp=numloadp+iloadp(1,nl)/4
1920 ENDDO
1921 ENDDO
1922 off = off + numloadp
1923 ENDIF
1924C
1925C Assembly treatment // int2
1926C
1927 IF(i2nsnt>0) THEN
1928C
1929C-----------------------------------------------------
1930C Preparing ADDCNI2 : CNI2 matrix address (type 2 interface connectivity)
1931C-----------------------------------------------------
1932 DO n=0,numnod+1
1933 adskyi2(n) = 0
1934 ENDDO
1935C
1936 IF (n2d==0) THEN
1937 nir = 4
1938 ELSE
1939 nir = 2
1940 ENDIF
1941 DO n = 1, ninter
1942 nty = ipari(7,n)
1943 IF (nty==2) THEN
1944 nrts = ipari(3,n)
1945 nrtm = ipari(4,n)
1946 nsn = ipari(5,n)
1947 nmn = ipari(6,n)
1948 DO i=1,nsn
1949 l = intbuf_tab(n)%IRTLM(i)
1950 k = intbuf_tab(n)%NSV(i)
1951 DO j=1,nir
1952 kk = intbuf_tab(n)%IRECTM((l-1)*4+j) + 1
1953 adskyi2(kk) = adskyi2(kk) + 1
1954 END DO
1955 END DO
1956 END IF
1957 END DO
1958C-----------------------------------------------
1959C CALCULATING SKYLINE VECTOR ADDRESSES
1960C-----------------------------------------------
1961 adskyi2(1) = 1
1962 DO i=2,numnod+1
1963 adskyi2(i)=adskyi2(i)+adskyi2(i-1)
1964 ENDDO
1965 lcni2 = adskyi2(numnod+1)-1
1966C-----------------------------------------------
1967C Fill for CEPI2: Element/Local Connection
1968C-----------------------------------------------
1969 off = 0
1970 DO n = 1, ninter
1971 nty = ipari(7,n)
1972 IF (nty==2) THEN
1973 nrts = ipari(3,n)
1974 nrtm = ipari(4,n)
1975 nsn = ipari(5,n)
1976 nmn = ipari(6,n)
1977 DO i=1,nsn
1978 l = intbuf_tab(n)%IRTLM(i)
1979 k = intbuf_tab(n)%NSV(i)
1980 celi2(off+i) = 0
1981 DO p = 1, nspmd
1982 IF(nlocal(k,p)==1)THEN
1983 cepi2(off+i) = p-1
1984 GO TO 102
1985 ENDIF
1986 ENDDO
1987 102 CONTINUE
1988 ENDDO
1989 off = off + nsn
1990 END IF
1991 END DO
1992C-----------------------------------------------
1993C Filling Cel: Element/Local Connection
1994C-----------------------------------------------
1995 DO p = 1, nspmd
1996 off = 0
1997 nl_l = 0
1998 DO n = 1, ninter
1999 nty = ipari(7,n)
2000 IF (nty==2) THEN
2001 nrts = ipari(3,n)
2002 nrtm = ipari(4,n)
2003 nsn = ipari(5,n)
2004 nmn = ipari(6,n)
2005 DO i=1,nsn
2006 l = intbuf_tab(n)%IRTLM(i)
2007 k = intbuf_tab(n)%NSV(i)
2008 IF(celi2(off+i)==0) THEN
2009 IF(nlocal(k,p)==1)THEN
2010 nl_l = nl_l + 1
2011 celi2(off+i) = nl_l
2012 END IF
2013 END IF
2014 END DO
2015 off = off + nsn
2016 END IF
2017 END DO
2018 END DO
2019 END IF
2020C
2021 RETURN
2022 END
2023C
2024!||====================================================================
2025!|| fillcne ../starter/source/spmd/domdec2.F
2026!||--- called by ------------------------------------------------------
2027!|| lectur ../starter/source/starter/lectur.F
2028!||--- calls -----------------------------------------------------
2029!|| nlocal ../starter/source/spmd/node/ddtools.F
2030!||--- uses -----------------------------------------------------
2031!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
2032!||====================================================================
2033 SUBROUTINE fillcne(
2034 1 CNE ,LCNE ,IXS ,IXS10 ,IXS20 ,
2035 2 IXS16 ,IXQ ,IXC ,IXT ,IXP ,
2036 3 IXR ,IXTG ,IXTG6 ,T_MONVOL ,
2037 4 IGRSURF,IB ,ADDCNE ,CEP ,
2038 5 ILEN ,GEO ,IBCV ,IBCR ,IBFFLUX,
2039 6 ILOADP ,LLOADP ,CEL ,EBCS_TAB,LOADS,
2040 7 NICONV ,NIRADIA ,NITFLUX,NUMCONV,NUMRADIA,NFXFLUX)
2041C-----------------------------------------------
2042C M o d u l e s
2043C-----------------------------------------------
2044 USE groupdef_mod
2045 USE monvol_struct_mod
2046 USE ale_ebcs_mod
2047 USE ebcs_mod
2048 USE loads_mod
2049 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
2050C-----------------------------------------------
2051C I m p l i c i t T y p e s
2052C-----------------------------------------------
2053#include "implicit_f.inc"
2054C-----------------------------------------------
2055C C o m m o n B l o c k s
2056C-----------------------------------------------
2057#include "com01_c.inc"
2058#include "com04_c.inc"
2059#include "param_c.inc"
2060C-----------------------------------------------
2061C D u m m y A r g u m e n t s
2062C-----------------------------------------------
2063 INTEGER ,INTENT(IN) :: NICONV
2064 INTEGER ,INTENT(IN) :: NIRADIA
2065 INTEGER ,INTENT(IN) :: NITFLUX
2066 INTEGER ,INTENT(IN) :: NUMCONV
2067 INTEGER ,INTENT(IN) :: NUMRADIA
2068 INTEGER ,INTENT(IN) :: NFXFLUX
2069 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),
2070 . ixt(nixt,*),ixp(nixp,*),ixr(nixr,*),cep(*),
2071 . ixs10(6,*),ixs20(12,*),ixs16(8,*),ixtg6(4,*),
2072 . ib(nibcld,*),
2073 . addcne(0:*), cne(*), lcne, ilen,
2074 . ibcv(niconv,*), ibcr(niradia,*),ibfflux(nitflux,*),
2075 . iloadp(sizloadp,*),lloadp(*)
2076 INTEGER CEL(*)
2077 my_real
2078 . GEO(NPROPG,*)
2079 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
2080 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
2081 TYPE(T_EBCS_TAB), INTENT(INOUT) :: EBCS_TAB ! ebcs data structure
2082 TYPE (LOADS_), INTENT(INOUT) :: LOADS ! load data structure
2083C-----------------------------------------------
2084C F u n c t i o n
2085C-----------------------------------------------
2086 INTEGER NLOCAL
2087 EXTERNAL NLOCAL
2088C-----------------------------------------------
2089C L o c a l V a r i a b l e s
2090C-----------------------------------------------
2091 INTEGER I, J, K, N, IDEB, OFF, OFFC, OFFTG, K1, K3, NL, NUMLOADP,
2092 . n1, n2, n3, n4, nn, p, nl_l, is, nn_s, iad, ity,
2093 . work(70000)
2094
2095 INTEGER, DIMENSION(:), ALLOCATABLE :: ADSKY, ITRI, INDEX
2096 INTEGER :: IJK,NUMBER_NODE
2097 INTEGER :: NELEM,ELEM_ID,NODE_ID
2098 INTEGER :: SURF_ID ! surface id
2099 INTEGER :: LOCAL_SEGMENT,NUMBER_SEGMENT ! number of segment for /LOAD
2100 INTEGER :: PROC_ID ! processor id
2101 LOGICAL :: IS_EBCS_PARALLEL
2102C-----------------------------------------------
2103C S o u r c e L i n e s
2104C-----------------------------------------------
2105C CALCULATION OF CNE ADDCNE
2106C-----------------------------------------------
2107 ALLOCATE(adsky(0:numnod+1))
2108 ALLOCATE(itri(ilen))
2109 ALLOCATE(index(2*ilen))
2110 DO i = 0, numnod+1
2111 adsky(i) = addcne(i)
2112 ENDDO
2113C
2114C sorting the following local elements Num User
2115C
2116 DO i = 1, numels
2117 itri(i) = ixs(11,i)
2118 ENDDO
2119C Addition Condition Type Solid element
2120 CALL my_orders(0,work,itri,index,numels8,1)
2121 ideb = numels8+1
2122 IF(numels10>0)
2123 . CALL my_orders(0,work,itri(ideb),index(ideb),numels10,1)
2124C
2125 DO j=1, numels10
2126 index(ideb+j-1) = index(ideb+j-1)+numels8
2127 ENDDO
2128C
2129 ideb = ideb + numels10
2130 IF(numels20>0)
2131 . CALL my_orders(0,work,itri(ideb),index(ideb),numels20,1)
2132C
2133 DO j=1, numels20
2134 index(ideb+j-1) = index(ideb+j-1)+numels8+numels10
2135 ENDDO
2136C
2137 ideb = ideb + numels20
2138 IF(numels16>0)
2139 . CALL my_orders(0,work,itri(ideb),index(ideb),numels16,1)
2140C
2141 DO j=1, numels16
2142 index(ideb+j-1) = index(ideb+j-1)+numels8+numels10+numels20
2143 ENDDO
2144C
2145 DO j=1,numels
2146 i = index(j)
2147 DO k=1,8
2148 n = ixs(k+1,i)
2149 IF(n/=0) THEN
2150 cne(adsky(n)) = i
2151 adsky(n) = adsky(n) + 1
2152 ENDIF
2153 ENDDO
2154 ENDDO
2155C
2156 IF(numels10>0) THEN
2157 DO j=1,numels10
2158 i = index(numels8+j)
2159 DO k=1,6
2160 n = ixs10(k,i-numels8)
2161 IF(n/=0) THEN
2162 cne(adsky(n)) = i
2163 adsky(n) = adsky(n) + 1
2164 ENDIF
2165 ENDDO
2166 ENDDO
2167 ENDIF
2168 IF(numels20>0)THEN
2169 DO j=1,numels20
2170 i = index(numels8+numels10+j)
2171 DO k=1,12
2172 n = ixs20(k,i-numels8-numels10)
2173 IF(n/=0) THEN
2174 cne(adsky(n)) = i
2175 adsky(n) = adsky(n) + 1
2176 ENDIF
2177 ENDDO
2178 ENDDO
2179 ENDIF
2180C
2181 IF(numels16>0)THEN
2182 DO j=1,numels16
2183 i = index(numels8+numels10+numels20+j)
2184 DO k=1,8
2185 n = ixs16(k,i-numels8-numels10-numels20)
2186 IF(n/=0) THEN
2187 cne(adsky(n)) = i
2188 adsky(n) = adsky(n) + 1
2189 ENDIF
2190 ENDDO
2191 ENDDO
2192 ENDIF
2193C
2194 off = numels
2195C
2196 DO i = 1, numelq
2197 itri(i) = ixq(7,i)
2198 ENDDO
2199 CALL my_orders(0,work,itri,index,numelq,1)
2200 DO j=1,numelq
2201 i = index(j)
2202 DO k=1,4
2203 n = ixq(k+1,i)
2204 cne(adsky(n)) = i+off
2205 adsky(n) = adsky(n) + 1
2206 ENDDO
2207 ENDDO
2208 off = off + numelq
2209C
2210C sorting the following local elements Num User
2211C
2212 DO i = 1, numelc
2213 itri(i) = ixc(7,i)
2214 ENDDO
2215 CALL my_orders(0,work,itri,index,numelc,1)
2216 DO j=1,numelc
2217 i = index(j)
2218 DO k=1,4
2219 n = ixc(k+1,i)
2220 cne(adsky(n)) = i+off
2221 adsky(n) = adsky(n) + 1
2222 ENDDO
2223 ENDDO
2224 offc = off
2225 off = off + numelc
2226C
2227 DO i = 1, numelt
2228 itri(i) = ixt(5,i)
2229 ENDDO
2230 CALL my_orders(0,work,itri,index,numelt,1)
2231 DO j=1,numelt
2232 i = index(j)
2233 DO k=1,2
2234 n = ixt(k+1,i)
2235 cne(adsky(n)) = i+off
2236 adsky(n) = adsky(n) + 1
2237 ENDDO
2238 ENDDO
2239 off = off + numelt
2240C
2241 DO i = 1, numelp
2242 itri(i) = ixp(6,i)
2243 ENDDO
2244 CALL my_orders(0,work,itri,index,numelp,1)
2245 DO j=1,numelp
2246 i = index(j)
2247 DO k=1,2
2248 n = ixp(k+1,i)
2249 cne(adsky(n)) = i+off
2250 adsky(n) = adsky(n) + 1
2251 ENDDO
2252 ENDDO
2253 off = off + numelp
2254C
2255 DO i = 1, numelr
2256 itri(i) = ixr(6,i)
2257 ENDDO
2258 CALL my_orders(0,work,itri,index,numelr,1)
2259 DO j=1,numelr
2260 i = index(j)
2261 DO k=1,2
2262 n = ixr(k+1,i)
2263 cne(adsky(n)) = i+off
2264 adsky(n) = adsky(n) + 1
2265 ENDDO
2266 IF(nint(geo(12,ixr(1,i)))==12) THEN
2267 n = ixr(4,i)
2268 cne(adsky(n)) = i+off
2269 adsky(n) = adsky(n) + 1
2270 ENDIF
2271 ENDDO
2272 off = off + numelr
2273C
2274 DO i = 1, numeltg
2275 itri(i) = ixtg(6,i)
2276 ENDDO
2277C Addition Condition Type Element Triangle
2278 CALL my_orders(0,work,itri,index,numeltg-numeltg6,1)
2279 ideb = numeltg-numeltg6+1
2280 IF (numeltg6/=0)
2281 . CALL my_orders(0,work,itri(ideb),index(ideb),numeltg6,1)
2282 DO j=1, numeltg6
2283 index(ideb+j-1) = index(ideb+j-1)+numeltg-numeltg6
2284 ENDDO
2285C
2286 DO j=1,numeltg
2287 i = index(j)
2288 DO k=1,3
2289 n = ixtg(k+1,i)
2290 cne(adsky(n)) = i+off
2291 adsky(n) = adsky(n) + 1
2292 ENDDO
2293 ENDDO
2294C
2295 IF(numeltg6>0)THEN
2296 DO j=1,numeltg6
2297 i = index(numeltg-numeltg6+j)
2298 DO k=1,3
2299 n = ixtg6(k,i-numeltg+numeltg6)
2300 IF(n/=0) THEN
2301 cne(adsky(n)) = i
2302 adsky(n) = adsky(n) + 1
2303 ENDIF
2304 ENDDO
2305 ENDDO
2306 ENDIF
2307C
2308 offtg = off
2309 off = off + numeltg
2310 off = off + numelx
2311C
2312C---------------------------------------------
2313C mv
2314 IF (nvolu>0) THEN
2315 k1 = 1
2316 DO n = 1, nvolu
2317 is = t_monvol(n)%EXT_SURFID
2318 nn_s= igrsurf(is)%NSEG
2319 DO j = 1, nn_s
2320 ity= igrsurf(is)%ELTYP(j)
2321 i = igrsurf(is)%ELEM(j)
2322 IF (ity==3) THEN
2323 DO k = 2,5
2324 nn = ixc(k,i)
2325 cne(adsky(nn)) = i+offc
2326 adsky(nn) = adsky(nn) + 1
2327 ENDDO
2328 ELSE
2329 DO k=2,4
2330 nn = ixtg(k,i)
2331 cne(adsky(nn)) = i+offtg
2332 adsky(nn) = adsky(nn) + 1
2333 END DO
2334 ENDIF
2335 ENDDO
2336 k1 = k1 + nimv
2337 ENDDO
2338 ENDIF
2339C-----------------------------------------------
2340C pseudo element BCL
2341C-----------------------------------------------
2342 IF(nconld>0) THEN
2343 DO nl = 1, nconld
2344 n1=ib(1,nl)
2345 n2=ib(2,nl)
2346 n3=ib(3,nl)
2347 n4=ib(4,nl)
2348 nn = n1
2349 cne(adsky(nn)) = nl+off
2350 adsky(nn) = adsky(nn) + 1
2351 IF(n4/=-1)THEN
2352 nn = n2
2353 cne(adsky(nn)) = nl+off
2354 adsky(nn) = adsky(nn) + 1
2355 IF(n2d==0)THEN
2356 nn = n3
2357 cne(adsky(nn)) = nl+off
2358 adsky(nn) = adsky(nn) + 1
2359 IF(n4/=0) THEN
2360 nn = n4
2361 cne(adsky(nn)) = nl+off
2362 adsky(nn) = adsky(nn) + 1
2363 ENDIF
2364 ENDIF
2365 ENDIF
2366 ENDDO
2367 ENDIF
2368C-----------------------------------------------
2369C Pseudo element BCL: Assignment to a proc
2370C-----------------------------------------------
2371 IF(nconld>0) THEN
2372 DO nl = 1, nconld
2373 n1=ib(1,nl)
2374 n2=ib(2,nl)
2375 n3=ib(3,nl)
2376 n4=ib(4,nl)
2377 IF(n4/=-1)THEN
2378 IF(n2d==0)THEN
2379 IF(n4/=0) THEN
2380 DO p = 1, nspmd
2381 IF(nlocal(n1,p)==1.AND.
2382 + nlocal(n2,p)==1.AND.
2383 + nlocal(n3,p)==1.AND.
2384 + nlocal(n4,p)==1)THEN
2385 cep(nl+off) = p-1
2386 GOTO 9
2387 ENDIF
2388 ENDDO
2389 9 CONTINUE
2390 ELSE
2391 DO p = 1, nspmd
2392 IF(nlocal(n1,p)==1.AND.
2393 + nlocal(n2,p)==1.AND.
2394 + nlocal(n3,p)==1)THEN
2395 cep(nl+off) = p-1
2396 GOTO 99
2397 ENDIF
2398 ENDDO
2399 99 CONTINUE
2400 ENDIF
2401 ELSE
2402 DO p = 1, nspmd
2403 IF(nlocal(n1,p)==1.AND.
2404 + nlocal(n2,p)==1)THEN
2405 cep(nl+off) = p-1
2406 GOTO 999
2407 ENDIF
2408 ENDDO
2409 999 CONTINUE
2410 ENDIF
2411 ELSE
2412 DO p = 1, nspmd
2413 IF(nlocal(n1,p)==1) THEN
2414 cep(nl+off) = p-1
2415 GOTO 9999
2416 ENDIF
2417 ENDDO
2418 9999 CONTINUE
2419 ENDIF
2420 ENDDO
2421 off = off + nconld
2422 ENDIF
2423C
2424C-----------------------------------------------
2425C pseudo element BC for heat transfert
2426C-----------------------------------------------
2427 IF(numconv>0) THEN
2428 DO nl = 1, numconv
2429 n1=ibcv(1,nl)
2430 n2=ibcv(2,nl)
2431 n3=ibcv(3,nl)
2432 n4=ibcv(4,nl)
2433 nn = n1
2434 cne(adsky(nn)) = nl+off
2435 adsky(nn) = adsky(nn) + 1
2436 IF(n4/=-1)THEN
2437 nn = n2
2438 cne(adsky(nn)) = nl+off
2439 adsky(nn) = adsky(nn) + 1
2440 IF(n2d==0)THEN
2441 nn = n3
2442 cne(adsky(nn)) = nl+off
2443 adsky(nn) = adsky(nn) + 1
2444 IF(n4/=0) THEN
2445 nn = n4
2446 cne(adsky(nn)) = nl+off
2447 adsky(nn) = adsky(nn) + 1
2448 ENDIF
2449 ENDIF
2450 ENDIF
2451 ENDDO
2452 ENDIF
2453
2454C-----------------------------------------------
2455C pseudo element BC for heat transfert : affectation a un proc
2456C-----------------------------------------------
2457 IF(numconv>0) THEN
2458 DO nl = 1, numconv
2459 n1=ibcv(1,nl)
2460 n2=ibcv(2,nl)
2461 n3=ibcv(3,nl)
2462 n4=ibcv(4,nl)
2463 IF(ibcv(7,nl) == 1) THEN
2464 p = cep(ibcv(8,nl))
2465 cep(nl+off) = p
2466 ELSE
2467 IF(n2d==0)THEN
2468 IF(n4/=0) THEN
2469 DO p = 1, nspmd
2470 IF(nlocal(n1,p)==1.AND.
2471 + nlocal(n2,p)==1.AND.
2472 + nlocal(n3,p)==1.AND.
2473 + nlocal(n4,p)==1)THEN
2474 cep(nl+off) = p-1
2475 GOTO 1
2476 ENDIF
2477 ENDDO
2478 1 CONTINUE
2479 ELSE
2480 DO p = 1, nspmd
2481 IF(nlocal(n1,p)==1.AND.
2482 + nlocal(n2,p)==1.AND.
2483 + nlocal(n3,p)==1)THEN
2484 cep(nl+off) = p-1
2485 GOTO 11
2486 ENDIF
2487 ENDDO
2488 11 CONTINUE
2489 ENDIF
2490 ELSE
2491 DO p = 1, nspmd
2492 IF(nlocal(n1,p)==1.AND.
2493 + nlocal(n2,p)==1)THEN
2494 cep(nl+off) = p-1
2495 GOTO 111
2496 ENDIF
2497 ENDDO
2498 111 CONTINUE
2499 ENDIF
2500 ENDIF
2501 ENDDO
2502 off = off + numconv
2503 ENDIF
2504C
2505C-----------------------------------------------
2506C pseudo element BC for radiative heat transfert
2507C-----------------------------------------------
2508 IF(numradia>0) THEN
2509 DO nl = 1, numradia
2510 n1=ibcr(1,nl)
2511 n2=ibcr(2,nl)
2512 n3=ibcr(3,nl)
2513 n4=ibcr(4,nl)
2514 nn = n1
2515 cne(adsky(nn)) = nl+off
2516 adsky(nn) = adsky(nn) + 1
2517 nn = n2
2518 cne(adsky(nn)) = nl+off
2519 adsky(nn) = adsky(nn) + 1
2520 IF(n2d==0)THEN
2521 nn = n3
2522 cne(adsky(nn)) = nl+off
2523 adsky(nn) = adsky(nn) + 1
2524 IF(n4/=0) THEN
2525 nn = n4
2526 cne(adsky(nn)) = nl+off
2527 adsky(nn) = adsky(nn) + 1
2528 ENDIF
2529 ENDIF
2530 ENDDO
2531 ENDIF
2532C-----------------------------------------------
2533C pseudo element BC for heat transfert : affectation a un proc
2534C-----------------------------------------------
2535 IF(numradia>0) THEN
2536 DO nl = 1, numradia
2537 n1=ibcr(1,nl)
2538 n2=ibcr(2,nl)
2539 n3=ibcr(3,nl)
2540 n4=ibcr(4,nl)
2541 IF(ibcr(7,nl) == 1) THEN
2542 p = cep(ibcr(8,nl))
2543 cep(nl+off) = p
2544 ELSE
2545 IF(n2d==0)THEN
2546 IF(n4/=0) THEN
2547 DO p = 1, nspmd
2548 IF(nlocal(n1,p)==1.AND.
2549 + nlocal(n2,p)==1.AND.
2550 + nlocal(n3,p)==1.AND.
2551 + nlocal(n4,p)==1)THEN
2552 cep(nl+off) = p-1
2553 GOTO 2
2554 ENDIF
2555 ENDDO
2556 2 CONTINUE
2557 ELSE
2558 DO p = 1, nspmd
2559 IF(nlocal(n1,p)==1.AND.
2560 + nlocal(n2,p)==1.AND.
2561 + nlocal(n3,p)==1)THEN
2562 cep(nl+off) = p-1
2563 GOTO 22
2564 ENDIF
2565 ENDDO
2566 22 CONTINUE
2567 ENDIF
2568 ELSE
2569 DO p = 1, nspmd
2570 IF(nlocal(n1,p)==1.AND.
2571 + nlocal(n2,p)==1)THEN
2572 cep(nl+off) = p-1
2573 GOTO 222
2574 ENDIF
2575 ENDDO
2576 222 CONTINUE
2577 ENDIF
2578 ENDIF
2579 ENDDO
2580 off = off + numradia
2581 ENDIF
2582C-----------------------------------------------
2583C pseudo element BC for imposed heat flux
2584C-----------------------------------------------
2585 IF(nfxflux>0) THEN
2586 DO nl = 1, nfxflux
2587 IF(ibfflux(10,nl) == 1) cycle
2588 n1=ibfflux(1,nl)
2589 n2=ibfflux(2,nl)
2590 n3=ibfflux(3,nl)
2591 n4=ibfflux(4,nl)
2592 nn = n1
2593 cne(adsky(nn)) = nl+off
2594 adsky(nn) = adsky(nn) + 1
2595 IF(n4/=-1)THEN
2596 nn = n2
2597 cne(adsky(nn)) = nl+off
2598 adsky(nn) = adsky(nn) + 1
2599 IF(n2d==0)THEN
2600 nn = n3
2601 cne(adsky(nn)) = nl+off
2602 adsky(nn) = adsky(nn) + 1
2603 IF(n4/=0) THEN
2604 nn = n4
2605 cne(adsky(nn)) = nl+off
2606 adsky(nn) = adsky(nn) + 1
2607 ENDIF
2608 ENDIF
2609 ENDIF
2610 ENDDO
2611 ENDIF
2612
2613C-----------------------------------------------
2614C pseudo element BC for heat transfert : affectation a un proc
2615C-----------------------------------------------
2616 IF(nfxflux>0) THEN
2617 DO nl = 1, nfxflux
2618 IF(ibfflux(10,nl) == 0) THEN
2619C SURFACIC FLUX
2620 n1=ibfflux(1,nl)
2621 n2=ibfflux(2,nl)
2622 n3=ibfflux(3,nl)
2623 n4=ibfflux(4,nl)
2624 IF(n2d==0)THEN
2625 IF(n4/=0) THEN
2626 DO p = 1, nspmd
2627 IF(nlocal(n1,p)==1.AND.
2628 + nlocal(n2,p)==1.AND.
2629 + nlocal(n3,p)==1.AND.
2630 + nlocal(n4,p)==1)THEN
2631 cep(nl+off) = p-1
2632 GOTO 3
2633 ENDIF
2634 ENDDO
2635 3 CONTINUE
2636 ELSE
2637 DO p = 1, nspmd
2638 IF(nlocal(n1,p)==1.AND.
2639 + nlocal(n2,p)==1.AND.
2640 + nlocal(n3,p)==1)THEN
2641 cep(nl+off) = p-1
2642 GOTO 33
2643 ENDIF
2644 ENDDO
2645 33 CONTINUE
2646 ENDIF
2647 ELSE
2648 DO p = 1, nspmd
2649 IF(nlocal(n1,p)==1.AND.nlocal(n2,p)==1)THEN
2650 cep(nl+off) = p-1
2651 GOTO 333
2652 ENDIF
2653 ENDDO
2654 333 CONTINUE
2655 ENDIF
2656C VOLUMIC FLUX
2657 ELSEIF(ibfflux(10,nl) == 1) THEN
2658c N1 = IBFFLUX(1,NL)
2659 n1 = ibfflux(8,nl)
2660 ibfflux(2,nl) = 0
2661 IF(nspmd > 1) THEN
2662 ibfflux(1,nl) = cel(n1)
2663 ibfflux(2,nl) = cep(n1)
2664 ENDIF
2665 cep(nl+off) = cep(n1)
2666 ENDIF
2667 ENDDO
2668 off = off + nfxflux
2669 ENDIF
2670C-----------------------------------------------
2671C pseudo element BCL
2672C-----------------------------------------------
2673 IF(nloadp>0) THEN
2674 numloadp=0
2675 DO nl = 1, nloadp
2676 DO i = 1,iloadp(1,nl)/4
2677 n1=lloadp(iloadp(4,nl)+4*(i-1))
2678 n2=lloadp(iloadp(4,nl)+4*(i-1)+1)
2679 n3=lloadp(iloadp(4,nl)+4*(i-1)+2)
2680 n4=lloadp(iloadp(4,nl)+4*(i-1)+3)
2681 nn = n1
2682 cne(adsky(nn)) = off+numloadp+i
2683 adsky(nn) = adsky(nn) + 1
2684 IF(n4/=-1)THEN
2685 nn = n2
2686 cne(adsky(nn)) = off+numloadp+i
2687 adsky(nn) = adsky(nn) + 1
2688 IF(n2d==0)THEN
2689 nn = n3
2690 cne(adsky(nn)) = off+numloadp+i
2691 adsky(nn) = adsky(nn) + 1
2692 IF(n4/=0) THEN
2693 nn = n4
2694 cne(adsky(nn)) = off+numloadp+i
2695 adsky(nn) = adsky(nn) + 1
2696 ENDIF
2697 ENDIF
2698 ENDIF
2699 ENDDO
2700 numloadp=numloadp+iloadp(1,nl)/4
2701 ENDDO
2702 ENDIF
2703C-----------------------------------------------
2704C Pseudo element LLOADP: Assignment to a proc
2705C-----------------------------------------------
2706 IF(nloadp>0) THEN
2707 DO nl = 1, nloadp
2708 DO i = 1,iloadp(1,nl)/4
2709 n1=lloadp(iloadp(4,nl)+4*(i-1))
2710 n2=lloadp(iloadp(4,nl)+4*(i-1)+1)
2711 n3=lloadp(iloadp(4,nl)+4*(i-1)+2)
2712 n4=lloadp(iloadp(4,nl)+4*(i-1)+3)
2713 IF(n4/=-1)THEN
2714 IF(n2d==0)THEN
2715 IF(n4/=0) THEN
2716 DO p = 1, nspmd
2717 IF(nlocal(n1,p)==1.AND.
2718 + nlocal(n2,p)==1.AND.
2719 + nlocal(n3,p)==1.AND.
2720 + nlocal(n4,p)==1)THEN
2721 cep(i+off) = p-1
2722 GOTO 4
2723 ENDIF
2724 ENDDO
2725 4 CONTINUE
2726 ELSE
2727 DO p = 1, nspmd
2728 IF(nlocal(n1,p)==1.AND.
2729 + nlocal(n2,p)==1.AND.
2730 + nlocal(n3,p)==1)THEN
2731 cep(i+off) = p-1
2732 GOTO 44
2733 ENDIF
2734 ENDDO
2735 44 CONTINUE
2736 ENDIF
2737 ELSE
2738 DO p = 1, nspmd
2739 IF(nlocal(n1,p)==1.AND.
2740 + nlocal(n2,p)==1)THEN
2741 cep(i+off) = p-1
2742 GOTO 444
2743 ENDIF
2744 ENDDO
2745 444 CONTINUE
2746 ENDIF
2747 ELSE
2748 DO p = 1, nspmd
2749 IF(nlocal(n1,p)==1) THEN
2750 cep(i+off) = p-1
2751 GOTO 4444
2752 ENDIF
2753 ENDDO
2754 4444 CONTINUE
2755 ENDIF
2756 ENDDO
2757 off = off + iloadp(1,nl)/4
2758 ENDDO
2759 ENDIF
2760
2761! -------------------------------------
2762! Euler boundary conditions : non-relecting frontier
2763! ------------
2764 IF(nebcs>0) THEN
2765 DO i=1,nebcs
2766 is_ebcs_parallel = .false.
2767 IF(ebcs_tab%tab(i)%poly%type == 10 .or. ebcs_tab%tab(i)%poly%type == 11)is_ebcs_parallel=.true.
2768 IF(is_ebcs_parallel) THEN
2769 surf_id = ebcs_tab%tab(i)%poly%surf_id ! surface id
2770 number_node = 4
2771 IF(n2d /= 0) number_node = 2
2772
2773 ! ------------
2774 ! loop over the elements of the EBCS
2775 DO j=1,ebcs_tab%tab(i)%poly%nb_elem
2776 ! loop over the 4 nodes of the surfaces
2777 elem_id = ebcs_tab%tab(i)%poly%ielem(j) ! element id
2778 DO ijk=1,number_node
2779 node_id = igrsurf(surf_id)%NODES(j,ijk) ! node id
2780 cne(adsky(node_id)) = elem_id ! element id
2781 adsky(node_id) = adsky(node_id) + 1
2782 ENDDO
2783 ENDDO
2784 ! ------------
2785 ENDIF
2786 ENDDO
2787 ENDIF
2788! -------------------------------------
2789
2790! -------------------------------------
2791! /LOAD/PCYL : add 1 contribution per node per segment
2792! ------------
2793 ! loop over the /LOAD/PCYL
2794 local_segment = 0
2795 DO i=1,loads%NLOAD_CYL
2796 number_segment = loads%LOAD_CYL(i)%NSEG ! number of segment for the PCYL I
2797 ! ------------
2798 ! loop over the segments of the surface to find where the node are defined
2799 DO j=1,number_segment ! loop over the segments of the surface
2800 proc_id = loads%CYL_RESTART(i)%SEGMENT_TO_PROC(j)
2801 DO k=1,4
2802 node_id = loads%LOAD_CYL(i)%SEGNOD(j,k) ! get the node id (if the segment is a triangle, NODE_ID(node 4) = 0))
2803 IF(node_id/=0) THEN
2804 cep(off+local_segment+j) = proc_id - 1 ! force the proc for the fake element
2805 cne(adsky(node_id)) = off+local_segment+j ! fake element id
2806 adsky(node_id) = adsky(node_id) + 1
2807 ENDIF
2808 ENDDO
2809 ENDDO
2810 local_segment = local_segment + number_segment
2811 ! ------------
2812 ENDDO
2813! -------------------------------------
2814 DEALLOCATE(adsky)
2815 DEALLOCATE(itri)
2816 DEALLOCATE(index)
2817
2818 RETURN
2819 END
2820C
2821!||====================================================================
2822!|| fillcni2 ../starter/source/spmd/domdec2.F
2823!||--- called by ------------------------------------------------------
2824!|| lectur ../starter/source/starter/lectur.F
2825!||--- uses -----------------------------------------------------
2826!||====================================================================
2827 SUBROUTINE fillcni2(
2828 1 CNI2 ,LCNI2 ,ADDCNI2, IPARI, INTBUF_TAB)
2829C-----------------------------------------------
2830C M o d u l e s
2831C-----------------------------------------------
2832 USE intbufdef_mod
2833C-----------------------------------------------
2834C I m p l i c i t T y p e s
2835C-----------------------------------------------
2836#include "implicit_f.inc"
2837C-----------------------------------------------
2838C C o m m o n B l o c k s
2839C-----------------------------------------------
2840#include "com01_c.inc"
2841#include "com04_c.inc"
2842#include "param_c.inc"
2843C-----------------------------------------------
2844C D u m m y A r g u m e n t s
2845C-----------------------------------------------
2846 INTEGER ADDCNI2(0:*), CNI2(*),
2847 . LCNI2, IPARI(NPARI,NINTER)
2848
2849 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
2850C-----------------------------------------------
2851C L o c a l V a r i a b l e s
2852C-----------------------------------------------
2853 INTEGER I, J, L, K, N, OFF, NTY, NRTS, NRTM, NSN, NMN,
2854 . KK, NIR
2855 INTEGER, DIMENSION(:), ALLOCATABLE :: ADSKYI2 !(0:NUMNOD+1)
2856C-----------------------------------------------
2857C S o u r c e L i n e s
2858C-----------------------------------------------
2859C CALCULATION OF CNE ADDCNE
2860C-----------------------------------------------
2861 ALLOCATE(adskyi2(0:numnod+1))
2862 DO i = 0, numnod+1
2863 adskyi2(i) = addcni2(i)
2864 ENDDO
2865C
2866C order => order of elements in type 2 interface
2867C
2868C
2869 off = 0
2870 IF (n2d==0) THEN
2871 nir = 4
2872 ELSE
2873 nir = 2
2874 ENDIF
2875 DO n = 1, ninter
2876 nty = ipari(7,n)
2877 IF (nty==2) THEN
2878 nrts = ipari(3,n)
2879 nrtm = ipari(4,n)
2880 nsn = ipari(5,n)
2881 nmn = ipari(6,n)
2882 DO i=1,nsn
2883 l = intbuf_tab(n)%IRTLM(i)
2884 k = intbuf_tab(n)%NSV(i)
2885 DO j=1,nir
2886 kk = intbuf_tab(n)%IRECTM((l-1)*4+j)
2887 cni2(adskyi2(kk)) = off+i
2888 adskyi2(kk) = adskyi2(kk) + 1
2889 END DO
2890 END DO
2891 off = off + nsn
2892 END IF
2893 END DO
2894 DEALLOCATE(adskyi2)
2895C
2896 RETURN
2897 END
2898C
2899!||====================================================================
2900!|| ddprint ../starter/source/spmd/domdec2.F
2901!||--- called by ------------------------------------------------------
2902!|| lectur ../starter/source/starter/lectur.F
2903!||====================================================================
2904 SUBROUTINE ddprint(DDSTAT, MEMFLOW)
2905C-----------------------------------------------
2906C I m p l i c i t T y p e s
2907C-----------------------------------------------
2908#include "implicit_f.inc"
2909C-----------------------------------------------
2910C C o m m o n B l o c k s
2911C-----------------------------------------------
2912#include "com01_c.inc"
2913#include "com04_c.inc"
2914#include "commandline.inc"
2915#include "units_c.inc"
2916#include "sphcom.inc"
2917#include "scr05_c.inc"
2918C-----------------------------------------------
2919C D u m m y A r g u m e n t s
2920C-----------------------------------------------
2921 INTEGER DDSTAT(50,*)
2922 INTEGER(KIND=8) :: MEMFLOW(2,*)
2923C DDSTAT
2924C 1 : NUMNOD Local
2925C 2 : NELEM Local
2926C 3 : NUMELS_L
2927C 4 : NUMELQ_L
2928C 5 : NUMELC_L
2929C 6 : NUMELP_L
2930C 7 : NUMELT_L
2931C 8 : NUMELR_L
2932C 9 : -
2933C 10: NUMELTG_L
2934C 11: NUMELX_L
2935C 12: NBDDPROC: NB PORC BORD
2936C 13: NBDDBOUN : number of boundary nodes
2937C 14: NBDDNOD : size of comm in number of nodes
2938C 15: NBDDNRB : size of comm in number of main rby nodes
2939C 16: NRBYKIN_L : number of local MAIN rigid bodies
2940C 17: NUMSPH_L: Number of local sphine particles
2941C 18: memi: whole local memory size my
2942C 19: Memr: Size Local Real Memory AM
2943C 20: NSNT_L: Number of secondary contact interface nodes (7,10,11)
2944C 21: NMNT_L: Number of nodes Contact interface (7,10,11)
2945C 22: NSNT2_L: Number of secondary interface interface nodes
2946C 23: NMNT2_L: Number of Type2 Interface Main Nodes
2947C 24: Restaurants: Restart size in MB
2948C 24: NSLARB_L : number of SECONDARY rigid body nodes
2949C-----------------------------------------------
2950C L o c a l V a r i a b l e s
2951C-----------------------------------------------
2952 INTEGER P, NACTIVE, J
2953 INTEGER (KIND=8) MEMTOTAL,RTOBYTES,ITOBYTES,MBYTE
2954 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE ::AVERAGE,DEVIATION
2955 INTEGER STAVALUE
2956C-----------------------------------------------
2957 NACTIVE=50
2958C Double of float to Bytes conversion
2959C In double precision : one double = 8 bytes
2960C In single precision : one float = 4 bytes
2961 allocate( average(nactive) )
2962 ALLOCATE( deviation(nactive) )
2963 mbyte=1024*1024
2964 IF (iresp==1) THEN
2965 rtobytes = 4
2966 ELSE
2967 rtobytes = 8
2968 ENDIF
2969 itobytes = 4
2970
2971C
2972 IF(nspmd>1) THEN
2973 DO j=1, nactive
2974 average(j)=zero
2975 deviation(j)=zero
2976 END DO
2977 DO p=1,nspmd
2978 DO j=1, nactive
2979 average(j) = average(j) + ddstat(j,p)
2980 END DO
2981 ENDDO
2982 DO j=1, nactive
2983 average(j) = average(j) / nspmd
2984 END DO
2985C
2986 DO p=1,nspmd
2987 DO j=1, nactive
2988 deviation(j) = deviation(j) + (ddstat(j,p)-average(j))**2
2989 END DO
2990 ENDDO
2991 DO j=1, nactive
2992 deviation(j) = sqrt(deviation(j)/nspmd)
2993 END DO
2994
2995 WRITE(iout,*)
2996 WRITE(iout,*)
2997 WRITE(iout,*)'STATISTICS ON DOMAIN DECOMPOSITION '
2998 WRITE(iout,*)'---------------------------------- '
2999 WRITE(iout,*)
3000 WRITE(iout,'(A,I6)')
3001 . 'AVERAGE NB. OF BOUNDARY NODES :',nint(average(13))
3002 WRITE(iout,'(A,I6)')
3003 . 'STANDARD DEVIATION :',nint(deviation(13))
3004 WRITE(iout,*)
3005 WRITE(iout,'(A,I8)')
3006 . 'AVERAGE NUMBER OF LOCAL NODES :',nint(average(1))
3007 WRITE(iout,'(A,I8)')
3008 . 'STANDARD DEVIATION :',nint(deviation(1))
3009 WRITE(iout,*)
3010 IF(average(20)+average(21) >= one)THEN
3011 WRITE(iout,'(A,I8,A3,I8)')
3012 . 'AVERAGE NB. OF CONTACT NODES(SECONDARY/MAIN) :',
3013 . nint(average(20)),' / ',nint(average(21))
3014 WRITE(iout,'(A,I8,A3,I8)')
3015 . 'STANDARD DEVIATION :',
3016 . nint(deviation(20)),' / ',nint(deviation(21))
3017 WRITE(iout,*)
3018 END IF
3019
3020 IF(average(22)+average(23) >= one)THEN
3021 WRITE(iout,'(A,I8,A3,I8)')
3022 . 'AVERAGE NB. OF INT2 NODES(SECONDARY/MAIN):',
3023 . nint(average(22)),' / ',nint(average(23))
3024 WRITE(iout,'(A,I8,A3,I8)')
3025 . 'STANDARD DEVIATION :',
3026 . nint(deviation(22)),' / ',nint(deviation(23))
3027 WRITE(iout,*)
3028 END IF
3029 IF(numsph>0.AND.average(17) >= one) THEN
3030 WRITE(iout,'(A,I8,A3,I8)')
3031 . 'AVERAGE NB. OF SPH PARTICLES :',
3032 . nint(average(17))
3033 WRITE(iout,'(A,I8,A3,I8)')
3034 . 'STANDARD DEVIATION :',
3035 . nint(deviation(17))
3036 WRITE(iout,*)
3037 END IF
3038
3039 WRITE(iout,*)
3040 . 'PROC NB OF ELTS NB OF BOUND. NODES NB OF BOUND. PROCS'
3041 DO p=1,nspmd
3042 WRITE(iout,1000) p,ddstat(2,p),ddstat(13,p),ddstat(12,p)
3043 ENDDO
3044C
3045 DO p=1,nspmd
3046 WRITE(iout,*)
3047 WRITE(iout,'(1X,A,I4)')
3048 . 'DOMAIN DECOMPOSITION SUMMARY FOR SPMD PROCESSOR',p
3049 WRITE(iout,*)
3050 . '----------------------------------------------------'
3051 WRITE(iout,*) 'NUMBER OF NODES................. :',ddstat(1,p)
3052 IF(numels>0)
3053 . WRITE(iout,*)'NUMBER OF SOLID ELEMENTS........ :',ddstat(3,p)
3054 IF(numelq>0)
3055 . WRITE(iout,*)'NUMBER OF QUAD ELEMENTS......... :',ddstat(4,p)
3056 IF(numelc>0)
3057 . WRITE(iout,*)'NUMBER OF 4-N SHELL ELEMENTS.... :',ddstat(5,p)
3058 IF(numelp>0)
3059 . WRITE(iout,*)'NUMBER OF BEAM ELEMENTS......... :',ddstat(6,p)
3060 IF(numelt>0)
3061 . WRITE(iout,*)'NUMBER OF TRUSS ELEMENTS........ :',ddstat(7,p)
3062 IF(numelr>0)
3063 . WRITE(iout,*)'NUMBER OF SPRING ELEMENTS....... :',ddstat(8,p)
3064 IF(numeltg>0)
3065 . WRITE(iout,*)'NUMBER OF 3-N SHELL ELEMENTS.... :',ddstat(10,p)
3066 IF(numelx>0)
3067 . WRITE(iout,*)'NUMBER OF MULTIPURPOSE ELEMENTS. :',ddstat(11,p)
3068 WRITE(iout,*) 'TOTAL NUMBER OF NODES FOR COMM.. :',ddstat(14,p)
3069 IF(nrbykin>0)THEN
3070 WRITE(iout,*)'NUMBER OF RIGID BODY COMPONENTS. :',ddstat(16,p)
3071 WRITE(iout,*)'NUMBER OF R.B.M. NODES FOR COMM. :',ddstat(15,p)
3072 WRITE(iout,*)'NUMBER OF SECONDARY RIGID BODY NODES :',ddstat(24,p)
3073 ENDIF
3074 IF(ninter>0)THEN
3075 WRITE(iout,*)'NUMBER OF INT2 SECONDARY NODES...... :',ddstat(22,p)
3076 WRITE(iout,*)'NUMBER OF INT2 MAIN NODES..... :',ddstat(23,p)
3077 WRITE(iout,*)'NUMBER OF CONTACT SECONDARY NODES... :',ddstat(20,p)
3078 WRITE(iout,*)'NUMBER OF CONTACT MAIN NODES.. :',ddstat(21,p)
3079 END IF
3080 IF(numsph>0)
3081 . WRITE(iout,*)'NUMBER OF SMOOTH PARTICLES...... :',ddstat(17,p)
3082 WRITE(iout,*)
3083 ddstat(18,p)=max(ddstat(18,p),1310720) ! 5 Mo en entiers / 4 bytes
3084 stavalue=int(5242880/rtobytes)
3085 ddstat(19,p)=max(ddstat(19,p),stavalue) ! 5 Mo en flottants
3086 memtotal=ddstat(19,p)*rtobytes + ddstat(18,p) * itobytes
3087 IF( got_inspire_alm == 1)THEN
3088 WRITE(iout,1201)p,
3089 . ddstat(25,p)/1024
3090 ELSE
3091 WRITE(iout,1200)p,
3092 . ddstat(25,p)/1024
3093 ENDIF
3094
3095 IF (nflow>0) THEN
3096 WRITE(iout,*)
3097 IF( got_inspire_alm == 1)THEN
3098 WRITE(iout,'(A)')
3099 .' ADDITIONAL SOLVER STORAGE FOR BEM SOLUTIONS'
3100 ELSE
3101 WRITE(iout,'(A)')
3102 .' ADDITIONAL ENGINE STORAGE FOR BEM SOLUTIONS'
3103 ENDIF
3104 WRITE(iout,'(A)')
3105 .' -------------------------------------------'
3106 memtotal=memtotal+memflow(1,p)*4+memflow(2,p)*rtobytes
3107 WRITE(iout,1400) memflow(2,p)*rtobytes/1048576,
3108 * memflow(1,p)/1048576*4,
3109 * memtotal/1048576
3110 ENDIF
3111 ENDDO
3112 ELSE
3113 p=1
3114 ddstat(18,p)=max(ddstat(18,p),1310720) ! 5 Mo en entiers / 4 bytes
3115 stavalue=int(5242880/rtobytes)
3116 ddstat(19,p)=max(ddstat(19,p),5242880/rtobytes) ! 5 Mo en flottants
3117 memtotal=ddstat(19,p)*rtobytes+ddstat(18,p)*itobytes
3118
3119 IF( got_inspire_alm == 1)THEN
3120 WRITE(iout,1201)p,
3121 . ddstat(25,p)/1024
3122 ELSE
3123 WRITE(iout,1200)p,
3124 . ddstat(25,p)/1024
3125 ENDIF
3126
3127 IF (nflow>0) THEN
3128 WRITE(iout,*)
3129 IF( got_inspire_alm == 1)THEN
3130 WRITE(iout,'(A)')
3131 .' ADDITIONAL SOLVER STORAGE FOR BEM SOLUTIONS'
3132 ELSE
3133 WRITE(iout,'(A)')
3134 .' ADDITIONAL ENGINE STORAGE FOR BEM SOLUTIONS'
3135 ENDIF
3136 WRITE(iout,'(A)')
3137 .' -------------------------------------------'
3138 memtotal=memtotal+memflow(1,p)*4+memflow(2,p)*rtobytes
3139 WRITE(iout,1400) memflow(2,p)*rtobytes/1048576,
3140 . memflow(1,p)*4/1048576,
3141 . memtotal/1048576
3142 ENDIF
3143 END IF
3144 WRITE(iout,*)
3145C
3146 1000 FORMAT(i5,8x,i6,16x,i6,16x,i6)
3147 1200 FORMAT(/,
3148 . ' LOCAL ENGINE STORAGE EVALUATION FOR SPMD PROCESSOR',i6,/
3149 . ' --------------------------------------------------------'/
3150 . ' RESTART FILE SIZE',i10,' MB')
3151 1201 FORMAT(/,
3152 . ' LOCAL SOLVER STORAGE EVALUATION FOR SPMD PROCESSOR',i6,/
3153 . ' --------------------------------------------------------'/
3154 . ' RESTART FILE SIZE',i10,' MB')
3155
3156 1400 FORMAT(
3157 . ' ADD. MEMORY FOR REALS . ',i10,' MB',/
3158 . ' ADD. MEMORY FOR INTEGERS',i10,' MB',/
3159 . ' ---------'/
3160 . ' NEW TOTAL . . . . . . . ',i10,' MB'/)
3161C
3162 DEALLOCATE( average )
3163 DEALLOCATE( deviation )
3164 RETURN
3165 END
3166!||====================================================================
3167!|| c_doms10 ../starter/source/spmd/domdec2.F
3168!||--- called by ------------------------------------------------------
3169!|| domdec2 ../starter/source/spmd/domdec2.F
3170!||--- calls -----------------------------------------------------
3171!|| ifrontplus ../starter/source/spmd/node/frontplus.F
3172!|| nlocal ../starter/source/spmd/node/ddtools.F
3173!||====================================================================
3174 SUBROUTINE c_doms10(ICNDS10,ITAGND,IPLUS)
3175C-----------------------------------------------
3176C I m p l i c i t T y p e s
3177C-----------------------------------------------
3178#include "implicit_f.inc"
3179C-----------------------------------------------
3180C C o m m o n B l o c k s
3181C-----------------------------------------------
3182#include "com04_c.inc"
3183#include "com01_c.inc"
3184C-----------------------------------------------
3185C D u m m y A r g u m e n t s
3186C-----------------------------------------------
3187 INTEGER ICNDS10(3,*),ITAGND(*)
3188C-----------------------------------------------
3189C F u n c t i o n
3190C-----------------------------------------------
3191 INTEGER NLOCAL
3192 EXTERNAL NLOCAL
3193C-----------------------------------------------
3194C L o c a l V a r i a b l e s
3195C-----------------------------------------------
3196 INTEGER N, NN,N1,N2,P,NF,NS,NF0,NFMAX,IPLUS
3197 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGI,NNF
3198C-----------------------------------------------
3199! TAGI->N: NNF(N)=MAX_NF
3200 ALLOCATE( tagi(numnod),nnf(ns10e) )
3201 tagi(1:numnod) = 0
3202 nnf(1:ns10e) = 1
3203 iplus = 0
3204C-------------only one of the mid-node is chosen (max_nf) for 1er pass---------
3205 DO n = 1, ns10e
3206 nn = icnds10(1,n)
3207 IF(itagnd(nn)>ns10e) cycle
3208 n1 = icnds10(2,n)
3209 n2 = icnds10(3,n)
3210C----- normally N1,N2 are local as NN-----
3211 nf = 0
3212 DO p = 1, nspmd
3213 nf = nf +nlocal(nn,p)
3214 ENDDO
3215 nnf(n) = nf
3216c IF(NF <=1 ) CYCLE
3217 IF (tagi(n1)==0) THEN
3218 tagi(n1) = n
3219 ELSE
3220 ns = icnds10(1,tagi(n1))
3221 nf0 = 0
3222 DO p = 1, nspmd
3223 nf0 = nf0 +nlocal(ns,p)
3224 ENDDO
3225 IF (nf>nf0) tagi(n1)=n
3226 END IF
3227 IF (tagi(n2)==0) THEN
3228 tagi(n2) = n
3229 ELSE
3230 ns = icnds10(1,tagi(n2))
3231 nf0 = 0
3232 DO p = 1, nspmd
3233 nf0 = nf0 +nlocal(ns,p)
3234 ENDDO
3235 IF (nf>nf0) tagi(n2)=n
3236 END IF
3237 END DO
3238C-------------avoid non symmetry M/S S/M--------
3239 DO n = 1, ns10e
3240 nn = icnds10(1,n)
3241 IF(itagnd(nn)>ns10e) cycle
3242 n1 = icnds10(2,n)
3243 n2 = icnds10(3,n)
3244 IF (tagi(n1)==n) THEN
3245 DO p = 1, nspmd
3246 IF(nlocal(n1,p)==1.AND.nlocal(nn,p)/=1) CALL ifrontplus(nn,p)
3247 ENDDO
3248 END IF
3249 IF (tagi(n2)==n) THEN
3250 DO p = 1, nspmd
3251 IF(nlocal(n2,p)==1.AND.nlocal(nn,p)/=1) CALL ifrontplus(nn,p)
3252 ENDDO
3253 END IF
3254 END DO
3255C-------------3nd pass for the case- in certain proc--(not necessary)-----
3256C DO N = 1, NS10E
3257C NN = ICNDS10(1,N)
3258C IF(ITAGND(NN)>NS10E) CYCLE
3259C N1 = ICNDS10(2,N)
3260C N2 = ICNDS10(3,N)
3261C NFMAX = TAGI(N1)
3262C IF (NFMAX>0.AND.NFMAX/=N) THEN
3263C NS = ICNDS10(1,NFMAX)
3264C NF = 0
3265C DO P = 1, NSPMD
3266C IF(NLOCAL(NN,P)==1.OR.NLOCAL(NS,P)==1) NF = NF + 1
3267C ENDDO
3268C IF (NF > NNF(NFMAX)) THEN
3269C NF0 = 0
3270C DO P = 1, NSPMD
3271C IF(NLOCAL(N1,P)==1) NF0 = NF0 + 1
3272C ENDDO
3273C IF (NF0 > NF) THEN
3274C DO P = 1, NSPMD
3275C IF(NLOCAL(N1,P)==1.AND.NLOCAL(NN,P)/=1) CALL IFRONTPLUS(NN,P)
3276C ENDDO
3277C END IF !(NF0 > NF) THEN
3278C END IF
3279C END IF
3280C NFMAX = TAGI(N2)
3281C IF (NFMAX>0.AND.NFMAX/=N) THEN
3282C NS = ICNDS10(1,NFMAX)
3283C NF = 0
3284C DO P = 1, NSPMD
3285C IF(NLOCAL(NN,P)==1.OR.NLOCAL(NS,P)==1) NF = NF + 1
3286C ENDDO
3287C IF (NF > NNF(NFMAX)) THEN
3288C NF0 = 0
3289C DO P = 1, NSPMD
3290C IF(NLOCAL(N2,P)==1) NF0 = NF0 + 1
3291C ENDDO
3292C IF (NF0 > NF) THEN
3293C DO P = 1, NSPMD
3294C IF(NLOCAL(N2,P)==1.AND.NLOCAL(NN,P)/=1) CALL IFRONTPLUS(NN,P)
3295C ENDDO
3296C END IF !(NF0 > NF) THEN
3297C END IF
3298C END IF
3299C END DO
3300
3301 DO n = 1, ns10e
3302 nn = icnds10(1,n)
3303 IF(itagnd(nn)>ns10e) cycle
3304 n1 = icnds10(2,n)
3305 n2 = icnds10(3,n)
3306 DO p = 1, nspmd
3307 IF(nlocal(nn,p)==1)THEN
3308 IF(nlocal(n1,p)/=1) THEN
3309 CALL ifrontplus(n1,p)
3310 iplus =1
3311 END IF
3312 IF(nlocal(n2,p)/=1) THEN
3313 CALL ifrontplus(n2,p)
3314 iplus =1
3315 END IF
3316 END IF
3317 END DO
3318 END DO
3319C ----------------------------
3320 DEALLOCATE( tagi,nnf )
3321C ----------------------------
3322C
3323 RETURN
3324 END
check_skew
subroutine check_skew(ixr, igeo, iskn, cep, iskwp, nskwp, tag_skn, multiple_skew, r_skew, ipm, offset)
Definition check_skew.F:35
domain_decomposition_pcyl
subroutine domain_decomposition_pcyl(loads, iframe)
Definition domain_decomposition_pcyl.F:33
fillcni2
subroutine fillcni2(cni2, lcni2, addcni2, ipari, intbuf_tab)
Definition domdec2.F:2829
ddprint
subroutine ddprint(ddstat, memflow)
Definition domdec2.F:2905
domdec2
subroutine domdec2(dd_iad, ipari, ib, npby, lpby, ixri, ibvel, lbvel, iparg, cel, ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg6, t_monvol, igrsurf, addcne, lcne, geo, nprw, lprw, lcni2, adskyi2, cepi2, celi2, i2nsnt, iskn, iskwp, nskwp, isensp, nsensp, iaccp, naccp, laccelm, ibcv, irbe3, lrbe3, front_rm, irbym, lcrbym, cep, ibcr, irbe2, lrbe2, cepsp, celsph, iloadp, lloadp, lgauge, igaup, ngaup, intbuf_tab, ibfflux, icnds10, itagnd, igeo, tag_skn, multiple_skew, ibfv, ibcscyc, lbcscyc, r_skew, ipm, sensors, len_cep, ebcs_tab, loads, iframe, niconv, niradia, nitflux, numconv, numradia, nfxflux, sensor_user_struct)
Definition domdec2.F:61
fillcne
subroutine fillcne(cne, lcne, ixs, ixs10, ixs20, ixs16, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg6, t_monvol, igrsurf, ib, addcne, cep, ilen, geo, ibcv, ibcr, ibfflux, iloadp, lloadp, cel, ebcs_tab, loads, niconv, niradia, nitflux, numconv, numradia, nfxflux)
Definition domdec2.F:2041
c_doms10
subroutine c_doms10(icnds10, itagnd, iplus)
Definition domdec2.F:3175
ifrontplus
subroutine ifrontplus(n, p)
Definition frontplus.F:101
frontplus_rm
subroutine frontplus_rm(front, index)
Definition frontplus.F:29
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
ale_ebcs_mod
Definition ale_ebcs_mod.F:40
ale_ebcs_mod::nebcs
integer nebcs
Definition ale_ebcs_mod.F:43
front_mod
Definition front_mod.F:84
front_mod::ifront
type(my_front) ifront
Definition front_mod.F:93
groupdef_mod
Definition groupdef_mod.F:668
message_mod
Definition message_mod.F:1257
monvol_struct_mod
Definition monvol_struct_mod.F:66
submodel_mod
Definition submodel_mod.F:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
split_joint
subroutine split_joint()
Definition split_joint.F:35
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
nl
character *2 function nl()
Definition message.F:2360
starter
program starter
Definition starter.F:39