OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
grid2mat.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!|| dometis ../starter/source/spmd/domain_decomposition/grid2mat.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| c_enforce_constraints ../starter/source/spmd/domain_decomposition/c_domain_decomposition.cpp
30!|| c_enforce_constraints_rbody ../starter/source/spmd/domain_decomposition/c_domain_decomposition_rbody.cpp
31!|| c_iddconnect ../starter/source/spmd/node/ddtools.F
32!|| c_prevent_decomposition_rbody ../starter/source/spmd/domain_decomposition/c_domain_decomposition_rbody.cpp
33!|| consider_edge ../starter/source/spmd/domain_decomposition/consider_edge.F
34!|| dd_bfs ../starter/source/spmd/domain_decomposition/grid2mat.F
35!|| find_nodes ../starter/source/spmd/domain_decomposition/grid2mat.F
36!|| fvbag_vertex ../starter/source/spmd/domain_decomposition/grid2mat.F
37!|| iddconnectplus ../starter/source/spmd/node/frontplus.F
38!|| ini_iddconnect ../starter/source/spmd/node/ddtools.F
39!|| initwg ../starter/source/spmd/domain_decomposition/initwg.f
40!|| plist_bfs ../starter/source/spmd/node/ddtools.F
41!|| plist_iddconnect ../starter/source/spmd/node/ddtools.F
42!|| sort_descending ../starter/source/spmd/domain_decomposition/consider_edge.F
43!|| stat_domdec ../starter/source/spmd/domain_decomposition/grid2mat.f
44!||--- uses -----------------------------------------------------
45!|| cluster_mod ../starter/share/modules1/cluster_mod.F
46!|| consider_edge_mod ../starter/source/spmd/domain_decomposition/consider_edge.F
47!|| format_mod ../starter/share/modules1/format_mod.f90
48!|| front_mod ../starter/share/modules1/front_mod.F
49!|| inter_cand_mod ../starter/share/modules1/inter_cand_mod.F
50!|| message_mod ../starter/share/message_module/message_mod.F
51!|| mid_pid_mod ../starter/share/modules1/mid_pid_mod.F
52!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
53!|| r2r_mod ../starter/share/modules1/r2r_mod.F
54!|| reorder_mod ../starter/share/modules1/reorder_mod.F
55!||====================================================================
56 SUBROUTINE dometis(
57 1 IXS ,IXQ ,IXC ,IXT ,IXP ,
58 2 IXR ,IXTG ,CEP ,GEO ,
59 3 ITRI1 ,ITRI2 ,INDEX1 ,INDEX2 ,NUM ,
60 4 WD ,IWCONT ,NELEM ,IDDLEVEL,NELEMINT,
61 5 INTER_CAND,PM ,X ,KXX ,IXX ,
62 6 ADSKY ,IGEO ,ISOLNOD,IWCIN2 ,DSDOF ,
63 7 ISOLOFF,ISHEOFF,ITRIOFF,ITRUOFF ,IPOUOFF ,
64 8 IRESOFF,IELEM21,IPM ,IXS10 ,IKINE ,
65 9 CLUSTERS,KXIG3D ,IXIG3D,COST_R2R,BUFMAT,
66 1 TAILLE,POIN_UMP,TAB_UMP,
67 2 POIN_UMP_OLD,TAB_UMP_OLD,CPUTIME_MP_OLD,
68 3 NSNT, NMNT,TABMP_L,IQUAOFF,
69 4 IGRSURF,FVMAIN,
70 5 ITAB ,IPART ,IPARTC ,IPARTG ,IPARTS ,
71 6 POIN_PART_SHELL,POIN_PART_TRI,POIN_PART_SOL,
72 7 MID_PID_SHELL,MID_PID_TRI,MID_PID_SOL,T_MONVOL,
73 8 EBCS_TAG_CELL_SPMD,NPBY,LPBY,MAT_PARAM)
74C-----------------------------------------------
75C M o d u l e s
76C-----------------------------------------------
77 USE consider_edge_mod , ONLY : consider_edge, max_nb_nodes_per_elt, sort_descending
78 USE message_mod
79 USE r2r_mod
80 USE cluster_mod
81 USE front_mod
82 USE reorder_mod
83 USE fvmbag_meshcontrol_mod
84 USE groupdef_mod
85 USE mid_pid_mod
86 USE monvol_struct_mod
87 USE inter_cand_mod
88 USE matparam_def_mod
89 USE format_mod , ONLY : fmw_a_i
90C-----------------------------------------------
91C I m p l i c i t T y p e s
92C-----------------------------------------------
93#include "implicit_f.inc"
94C-----------------------------------------------
95C C o m m o n B l o c k s
96C-----------------------------------------------
97#include "assert.inc"
98#include "com01_c.inc"
99#include "com04_c.inc"
100#include "scr12_c.inc"
101#include "param_c.inc"
102#include "units_c.inc"
103#include "scr15_c.inc"
104#include "scr05_c.inc"
105#include "scr17_c.inc"
106#include "scr23_c.inc"
107#include "sms_c.inc"
108#include "r2r_c.inc"
109#include "kincod_c.inc"
110#include "sphcom.inc"
111C-----------------------------------------------
112C D u m m y A r g u m e n t s
113C-----------------------------------------------
114 INTEGER IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*), IXT(NIXT,*),
115 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*),
116 . CEP(*), ITRI1(*), ITRI2(*), INDEX1(*),INDEX2(*),
117 . NUM(*), NELEM,IDDLEVEL, NELEMINT,
118 . KXX(NIXX,NUMELX),IXX(*), ADSKY(0:*),IGEO(NPROPGI,NUMGEO),
119 . ISOLNOD(*), IWCONT(5,*), IWCIN2(2,*), DSDOF(*),
120 . ISOLOFF(*), ISHEOFF(*), ITRIOFF(*), IKINE(*),
121 . ITRUOFF(*), IPOUOFF(*), IRESOFF(*), IELEM21(*),
122 . IPM(NPROPMI,NUMMAT),IXS10(6,*),KXIG3D(NIXIG3D,NUMELIG3D),
123 . IQUAOFF(*),
124 . IXIG3D(*),NSNT, NMNT,TABMP_L,
125 . FVMAIN(NVOLU)
126 INTEGER :: ITAB(*)
127 INTEGER, DIMENSION(LIPART1,*), INTENT(IN) :: IPART
128 INTEGER, DIMENSION(*), INTENT(IN) :: IPARTC,IPARTG,IPARTS
129 TYPE (CLUSTER_) ,DIMENSION(*) :: CLUSTERS
130 my_real GEO(NPROPG,NUMGEO), PM(NPROPM,NUMMAT), X(3,*), COST_R2R,BUFMAT(*)
131 REAL WD(*)
132 INTEGER TAILLE
133 INTEGER, DIMENSION(NUMMAT_OLD) :: POIN_UMP_OLD
134 INTEGER, DIMENSION(7,TAILLE_OLD) :: TAB_UMP_OLD
135 INTEGER, DIMENSION(NUMMAT) :: POIN_UMP
136 INTEGER, DIMENSION(7,TAILLE) :: TAB_UMP
137 my_real, DIMENSION(TAILLE_OLD) :: CPUTIME_MP_OLD
138 INTEGER, DIMENSION(2,NPART), INTENT(IN) :: POIN_PART_SHELL,POIN_PART_TRI
139 INTEGER, DIMENSION(2,NPART,7), INTENT(IN) :: POIN_PART_SOL
140 TYPE(MID_PID_TYPE), DIMENSION(NUMMAT), INTENT(IN) :: MID_PID_SHELL,MID_PID_TRI
141 TYPE(MID_PID_TYPE), DIMENSION(NUMMAT,7), INTENT(IN) :: MID_PID_SOL
142 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
143 TYPE(monvol_struct_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
144 INTEGER,INTENT(IN) :: EBCS_TAG_CELL_SPMD(NUMELQ+NUMELTG+NUMELS)
145 INTEGER, DIMENSION(NNPBY,*), INTENT(in) :: NPBY
146 INTEGER, DIMENSION(*), INTENT(in) :: LPBY
147 TYPE(inter_cand_), INTENT(in) :: INTER_CAND
148 TYPE(matparam_struct_) ,DIMENSION(NUMMAT), INTENT(IN) :: MAT_PARAM
149C-----------------------------------------------
150C L o c a l V a r i a b l e s
151C-----------------------------------------------
152 INTEGER NCRITMAX
153 parameter(ncritmax = 20)
154 INTEGER NSEG, I, J, UTIL, K, NUSE, ELEMD_OLD,
155 . lcne,io_err1,ish1,ish2,ii, nnc, it,
156 . nedges, elk, off,cc1, cc2, numg1, numg2,
157 . ined,l,m,n,newedge,nedges_old,
158 . lenwork,nod1, nod2, mode, nelem0, mm,
159 . work(70000), numl, ierror,
160 . elemd, immnul, neddel, itypint, iwarn1,
161 . maxi, maxj, max, i1, i2, i3, n1, n2, numg3, numg4,
162 . nelx,addx,mid,pid,jale,mln,nshift,nnode, nn,
163 . options(40),ncond,nflag,iwflg,nodc,icur,ierr1,nec,
164 . inwdcount,iccand,icnod_sms,isolbar, ickin, nk, nki,
165 . icelem, icints, icintm, icint2, icddl, icfsi, icdel, icsol,
166 . icr2r,numel_r2r, cepcluster,
167 . nconnx, curr, prev, next, i1old, i2old, inc, idb_metis,
168 . nelig3d,ncond2,lsms,
169 . offc,offtg,k0,ityp,
170 . nn_l,is,iad,ity,kad,jale_from_mat, jale_from_prop
171 INTEGER, DIMENSION(:),ALLOCATABLE :: XADJ, ADJNCY,IWD,IWD2,
172 . IENDT,ITRI,INDEX,DOMCLUSTER,ELEMCLUST,
173 . XADJ_OLD, ADJNCY_OLD, COLORS, ROOTS,
174 . POINTER_NEIGH,CONNECT_WEIGHT,TAGELEM,CNE,
175 . IWD_COPY
176 INTEGER, DIMENSION(:), ALLOCATABLE :: IWKIN ! NUMNOD
177 INTEGER TAILLE_LOCAL,PREV_NEIGH,C_NEIGH,POINT_DELETE,
178 . ELEMNODES(MAX_NB_NODES_PER_ELT),OFFELEM(10),WGHT
179 INTEGER, DIMENSION(:,:), ALLOCATABLE :: CONNECTIVITY
180 INTEGER, DIMENSION(:), ALLOCATABLE :: NB_NODES_MINI
181 REAL, DIMENSION(:),ALLOCATABLE :: RWD,WD_COPY
182 CHARACTER FILNAM*109, KEYA*80, CHLEVEL*1
183 REAL FAC, UBVEC(15), SCAL
184 DOUBLE PRECISION
185 . AVERAGE(NCRITMAX), DEVIATION(NCRITMAX), DMIN(NCRITMAX), DMAX(NCRITMAX),
186 . W(NSPMD), WIS(NSPMD),WIM(NSPMD),WI2(NSPMD), WDDL(NSPMD),
187 . WFSI(NSPMD), WCAND(NSPMD), WSOL(NSPMD), WKIN(NSPMD),
188 . wdel(nspmd), wr2r(nspmd), wnod_sms(nspmd)
189 DOUBLE PRECISION :: WS, WD_MAX,WD_MAX0
190C metis5 null pointers
191
192 INTEGER METIS_PartGraphKway, METIS_PartGraphRecursive,
193 . metis_setdefaultoptions,wrap_metis_partgraphkway,
194 . wrap_metis_partgraphrecursive
195 INTEGER NNO,NNS,NTG,NNI,NTGT,NTGI
196 INTEGER NELMIN
197 INTEGER NFVMBAG,NB_FVMBAG_TRIM,DD_FVMBAG_TRY
198 INTEGER FVM_ELEM(NVOLU),AVG,MAX_TRY
199 INTEGER WD_MAX_FACTOR
200 INTEGER NB_ELEM_ALE,MAIN_TARGET
201 CHARACTER (LEN=255) :: STR
202 LOGICAL :: FVM_DOMDEC,DD_UNBALANCED
203 LOGICAL, DIMENSION(:), ALLOCATABLE :: TAGGED_ELEM
204 INTEGER, DIMENSION(:), ALLOCATABLE :: ISORT,INDEX_SORT
205
206 INTEGER (kind=8) :: NEDGES_8
207 INTEGER :: CLUSTER_TYP,OFFSET_CLUSTER
208 my_real, DIMENSION(:,:), ALLOCATABLE :: COORDS
209 my_real, DIMENSION(:), ALLOCATABLE :: min_dist
210 my_real :: dist
211 my_real :: xmin(3),xmax(3)
212 INTEGER :: CEP_MIN
213 INTEGER :: C1,C2
214 INTEGER :: OFFSET
215
216
217C ---- statistics for edges added for contact interface
218 INTEGER :: number_of_added_edges
219 INTEGER :: refused_cep0, refused_numg,refused_numg0
220 INTEGER :: switch_tried, switch_done
221
222 integer, pointer :: null_int(:)
223 real, pointer :: null_real(:)
224 integer :: int_bidon
225 real :: real_bidon
226
227 INTEGER :: IJK
228 INTEGER :: NSN
229 INTEGER :: NUMBER_OF_ELEMENT_RBODY,NUMEL
230 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_ELEMENT_RBODY
231 LOGICAL :: BOOL_RBODY
232C-----------------------------------------------
233C E x t e r n a l F u n c t i o n s
234C-----------------------------------------------
235 EXTERNAL metis_partgraphkway, metis_partgraphrecursive,
236 . metis_setdefaultoptions,wrap_metis_partgraphkway,
237 . wrap_metis_partgraphrecursive
238C-----------------------------------------------
239C S o u r c e L i n e s
240C-----------------------------------------------
241 ALLOCATE(iwkin(numnod))
242 number_of_added_edges = 0
243 refused_numg = 0
244 refused_numg0 = 0
245
246 refused_cep0 = 0
247 switch_tried = 0
248 switch_done = 0
249
250 nec=0
251 nfvmbag = 0
252 fvmain(1:nvolu) = -1
253 fvm_elem(1:nvolu) = 0
254 fvm_domdec = .false.
255 wd_max = 0.0d0
256 wd_max0= 0.0d0
257 nnode = nspmd
258
259C----------------------------------
260C global NEDGE counting
261C----------------------------------
262 DO i=1,numnod+1
263 adsky(i) = 0
264 END DO
265C.....necessary memory
266 DO 110 k=2,9
267 DO 110 i=1,numels
268 n = ixs(k,i) + 1
269 adsky(n) = adsky(n) + 1
270 110 CONTINUE
271
272C add Tetra10
273 IF(numels10>0) THEN
274 DO j=1,numels10
275 DO k=1,6
276 n = ixs10(k,j) + 1
277 adsky(n) = adsky(n) + 1
278 ENDDO
279 ENDDO
280 ENDIF
281C
282 DO 120 k=2,5
283 DO 120 i=1,numelq
284 n = ixq(k,i) + 1
285 adsky(n) = adsky(n) + 1
286 120 CONTINUE
287C
288 DO 130 k=2,5
289 DO 130 i=1,numelc
290 n = ixc(k,i) + 1
291 adsky(n) = adsky(n) + 1
292 130 CONTINUE
293C
294 DO 140 k=2,3
295 DO 140 i=1,numelt
296 n = ixt(k,i) + 1
297 adsky(n) = adsky(n) + 1
298 140 CONTINUE
299C
300 DO 150 k=2,3
301 DO 150 i=1,numelp
302 n = ixp(k,i) + 1
303 adsky(n) = adsky(n) + 1
304 150 CONTINUE
305C
306C separate treatment of optional 3rd node except type 12
307 DO k=2,3
308 DO i=1,numelr
309 n = ixr(k,i) + 1
310 adsky(n) = adsky(n) + 1
311 ENDDO
312 ENDDO
313 DO i=1,numelr
314 n = ixr(4,i) + 1
315 IF(nint(geo(12,ixr(1,i)))==12) THEN
316 adsky(n) = adsky(n) + 1
317 ENDIF
318 ENDDO
319C
320 DO 170 k=2,4
321 DO 170 i=1,numeltg
322 n = ixtg(k,i) + 1
323 adsky(n) = adsky(n) + 1
324 170 CONTINUE
325
326C
327C Elements Multibrins
328 DO i=1,numelx
329 nelx=kxx(3,i)
330 DO k=1,nelx
331 addx = kxx(4,i)+k-1
332 n=ixx(addx)+1
333 adsky(n)= adsky(n)+1
334 ENDDO
335 ENDDO
336C
337C Elements Iso-geo
338 DO i=1,numelig3d
339 nelig3d=kxig3d(3,i)
340 DO k=1,nelig3d
341 addx = kxig3d(4,i)+k-1
342 n=ixig3d(addx)+1
343 adsky(n)= adsky(n)+1
344 ENDDO
345 ENDDO
346C
347 adsky(1) = 1
348 DO i=2,numnod+1
349 adsky(i) = adsky(i) + adsky(i-1)
350 END DO
351C
352 lcne = adsky(numnod+1)
353 ALLOCATE(cne(lcne),stat=ierr1)
354C
355 IF(ierr1/=0)THEN
356 CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,
357 . c1='DOMDEC')
358 END IF
359C
360C-----------------------------------------------
361C Optimization on deleted elements from _0001.rad
362C-----------------------------------------------
363C weights in real format for old RSB compatibility
364 DO i = 1, nelem
365 wd(i) = 0.
366 ENDDO
367 elemd = 0
368 filnam=rootnam(1:rootlen)//'_0001.rad'
369 OPEN(unit=71,file=filnam(1:rootlen+9),
370 . access='SEQUENTIAL',status='OLD',iostat=io_err1)
371C
372 IF (io_err1/=0) THEN
373 filnam=rootnam(1:rootlen)//'d01'
374 OPEN(UNIT=71,FILE=FILNAM(1:ROOTLEN+3),
375 . ACCESS='sequential',STATUS='old',IOSTAT=IO_ERR1)
376 ENDIF
377C
378 IF (IO_ERR1==0) THEN
379 OPEN(UNIT=72,FORM='formatted',status='SCRATCH')
380 elemd = 0
381 10 READ(71,'(A)',END=20) keya
382 11 CONTINUE
383 IF(keya(1:12)=='/DEL/SHELL/1') THEN
384 30 READ(71,'(A)',END=20) keya
385 IF(keya(1:1)=='#')GOTO 30
386 IF(keya(1:1)=='$')GOTO 30
387 IF(keya(1:1)=='/')GOTO 11
388C ko sur cray READ(KEYA,*,END=20)ISH1,ISH2
389 rewind(72)
390 WRITE(72,'(A)')keya
391 rewind(72)
392 READ(72,*,END=20)ISH1,ish2
393 DO i = 1, numelc
394 IF(ixc(nixc,i)>=ish1.AND.ixc(nixc,i)<=ish2) THEN
395 DO j = ish1, ish2
396 IF(ixc(nixc,i)==j) THEN
397 wd(i+numels+numelq) = 0.0001
398 elemd = elemd + 1
399 GOTO 35
400 ENDIF
401 ENDDO
402 ENDIF
403 35 CONTINUE
404 ENDDO
405 GOTO 30
406 ELSEIF(keya(1:12)=='/DEL/BRICK/1') THEN
407 60 READ(71,'(A)',END=20) keya
408 IF(keya(1:1)=='#')GOTO 60
409 IF(keya(1:1)=='$')GOTO 60
410 IF(keya(1:1)=='/')GOTO 11
411C ko sur cray READ(KEYA,*,END=20)ISH1,ISH2
412 rewind(72)
413 WRITE(72,'(A)')keya
414 rewind(72)
415 READ(72,*,END=20)ISH1,ish2
416 DO i = 1, numels
417 IF(ixs(nixs,i)>=ish1.AND.ixs(nixs,i)<=ish2) THEN
418 DO j = ish1, ish2
419 IF(ixs(nixs,i)==j) THEN
420 wd(i) = 0.0001
421 elemd = elemd + 1
422 GOTO 65
423 ENDIF
424 ENDDO
425 ENDIF
426 65 CONTINUE
427 ENDDO
428 GOTO 60
429C
430 ELSEIF(keya(1:12)=='/DEL/SH_3N/1') THEN
431 90 READ(71,'(A)',END=20) keya
432 IF(keya(1:1)=='#')GOTO 90
433 IF(keya(1:1)=='$')GOTO 90
434 IF(keya(1:1)=='/')GOTO 11
435C ko sur cray READ(KEYA,*,END=20)ISH1,ISH2
436 rewind(72)
437 WRITE(72,'(A)')keya
438 rewind(72)
439 READ(72,*,END=20)ISH1,ish2
440 DO i = 1, numeltg
441 IF(ixtg(nixtg,i)>=ish1
442 . .AND.ixtg(nixtg,i)<=ish2) THEN
443 DO j = ish1, ish2
444 IF(ixtg(nixtg,i)==j) THEN
445 wd(i+numels+numelq+numelc+numelt
446 . +numelp+numelr) = 0.0001
447 elemd = elemd + 1
448 GOTO 95
449 ENDIF
450 ENDDO
451 ENDIF
452 95 CONTINUE
453 ENDDO
454 GOTO 90
455 ENDIF
456 GOTO 10
457 20 CONTINUE
458 CLOSE(71)
459 CLOSE(72)
460C message on D01 read (delete optimized)
461 IF(iddlevel==0) THEN
462 WRITE(iout,*)' '
463 WRITE(iout,'(A)')
464 . ' SPMD IS CHECKING FOR ELEMENT DELETION IN : ',' '//filnam
465 ENDIF
466C
467 ELSE
468C message on D01 not read (delete not optimized)
469 IF(iddlevel==0) THEN
470 WRITE(iout,*)' '
471 WRITE(iout,'(A)')
472 . ' SPMD IS NOT ABLE TO CHECK FOR ELEMENT DELETION IN'//
473 . ' RADIOSS ENGINE INPUT FILE'
474 ENDIF
475 ENDIF
476
477C-----------------------------------------------
478C Optimization on RBYON from _0000.rad
479C-----------------------------------------------
480 elemd_old = elemd
481 isolbar=0
482 DO ii = 1, numels
483 IF((isoloff(ii)==1.OR.isoloff(ii)==3).AND.
484 * wd(ii)/=0.0001)THEN
485 wd(ii) = 0.0001
486 elemd = elemd + 1
487 END IF
488C additional test for barrier
489 mid = abs(ixs(1,ii))
490 pid = abs(ixs(10,ii))
491 jale_from_mat = nint(pm(72,mid)) !old way to enable ALE/EULER framework (backward compatibility)
492 jale_from_prop = igeo(62,pid) !new way to enable ALE/EULER framework
493 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
494 mln = nint(pm(19,mid))
495 IF(jale==0.AND.(mln==28.OR.mln==68))THEN
496 isolbar=isolbar+1
497 ENDIF
498 END DO
499C
500 DO ii = 1, numelq
501 IF((iquaoff(ii)==1.OR.iquaoff(ii)==3).AND.
502 * wd(ii+numels)/=0.0001)THEN
503 wd(ii+numels) = 0.0001
504 elemd = elemd + 1
505 END IF
506 END DO
507C
508 DO ii = 1, numelc
509 IF((isheoff(ii)==1.OR.isheoff(ii)==3).AND.
510 * wd(ii+numels+numelq)/=0.0001)THEN
511 wd(ii+numels+numelq) = 0.0001
512 elemd = elemd + 1
513 END IF
514 END DO
515C
516 DO ii = 1, numelt
517 IF((itruoff(ii)==3 ).AND.
518 * wd(ii+numels+numelq+numelc)/=0.0001 )THEN
519 wd(ii+numels+numelq+numelc) = 0.0001
520 elemd = elemd + 1
521 END IF
522 END DO
523C
524 DO ii = 1, numelp
525 IF((ipouoff(ii)==3 ).AND.
526 * wd(ii+numels+numelq+numelc+numelt)/=0.0001 )THEN
527 wd(ii+numels+numelq+numelc+numelt) = 0.0001
528 elemd = elemd + 1
529 END IF
530 END DO
531C
532 DO ii = 1, numelr
533 IF((iresoff(ii)==3 ).AND.
534 * wd(ii+numels+numelq+numelc+numelt+numelp)/=0.0001 )THEN
535 wd(ii+numels+numelq+numelc+numelt+numelp) = 0.0001
536 elemd = elemd + 1
537 END IF
538 END DO
539C
540 DO ii = 1, numeltg
541 IF(itrioff(ii)==1.AND.wd(ii+numels+numelq+numelc+numelt
542 . +numelp+numelr)/=0.0001)THEN
543 wd(ii+numels+numelq+numelc+numelt
544 . +numelp+numelr) = 0.0001
545 elemd = elemd + 1
546 END IF
547 END DO
548C
549C test to bypass creation of "deleted elem" level and avoid crash cases if elemd=1
550C
551 IF (nelem > 0) THEN
552 IF(float(nelem-elemd)/float(nelem)>zep95) elemd = 0
553 END IF
554 IF(iddlevel==0.AND.elemd>elemd_old) THEN
555 WRITE(iout,*)' '
556 WRITE(iout,'(A)')
557 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR ELEMENT DEACTIVATION'//
558 . ' IN /RBODY OPTIONS'
559 ENDIF
560C
561C-----------------------------------------------
562 IF (iddlevel==1) THEN
563 WRITE(iout,'(A)')' '
564 WRITE(iout,'(A)')
565 . ' --------------------------------------'
566 WRITE(iout,'(A)')
567 . ' NEW DOMAIN DECOMPOSITION FOR OPTIMIZATION'
568 WRITE(iout,'(A)')
569 . ' --------------------------------------'
570 ENDIF
571 WRITE(istdo,'(A)')' .. DOMAIN DECOMPOSITION'
572 WRITE(iout,'(A)')' '
573 IF(dectyp==3)THEN
574 WRITE(iout,'(A)')
575 . ' DOMAIN DECOMPOSITION USING MULTILEVEL KWAY'
576 ELSEIF(dectyp==4)THEN
577 WRITE(iout,'(A)')
578 . ' DOMAIN DECOMPOSITION USING MULTILEVEL RSB'
579 ELSEIF(dectyp==5)THEN
580 WRITE(iout,'(A)')
581 . ' DOMAIN DECOMPOSITION USING MULTILEVEL KWAY FOR IMPLICIT AND AMS'
582 ELSEIF(dectyp==4)THEN
583 WRITE(iout,'(A)')
584 . ' DOMAIN DECOMPOSITION USING MULTILEVEL RSB FOR IMPLICIT'
585 END IF
586 WRITE(iout,'(A)')
587 . ' ------------------------------------------'
588 IF (ipari0==1) THEN
589 WRITE(iout,'(A)')
590 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR PARALLEL ARITHMETIC ON'
591 ELSE
592 WRITE(iout,'(A)')
593 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR PARALLEL ARITHMETIC OFF'
594 ENDIF
595
596 IF(iddlevel == 1 .AND. ddnod_sms /= 0)THEN
597 WRITE(iout,'(A)')
598 . ' ADDITIONAL OPTIMIZATION OF DOMAIN DECOMPOSITION FOR AMS (DOMDEC=7)'
599 END IF
600C-----------------------------------------------
601C CNE CALCULATION
602C-----------------------------------------------
603C We have to tag elements for know theirs number of nodes
604 ALLOCATE(tagelem(nelem))
605 DO i = 1,nelem
606 tagelem(i)=0
607 END DO
608 DO i=1,numels
609 tagelem(i)=1
610 DO k=1,8
611 n = ixs(k+1,i)
612 IF(n /= 0) THEN
613 cne(adsky(n)) = i
614 adsky(n) = adsky(n) + 1
615 END IF
616 ENDDO
617 ENDDO
618C add Tetra10
619 IF(numels10>0) THEN
620 DO j=1,numels10
621 tagelem(abs(-(numels8+j)))=2
622 DO k=1,6
623 n = ixs10(k,j)
624 IF(n /= 0) THEN
625 cne(adsky(n)) = -(numels8+j) ! to treat extra node only for contacts
626 adsky(n) = adsky(n) + 1
627 ENDIF
628 ENDDO
629 ENDDO
630 ENDIF
631C
632C-----------------------------------------------
633C
634 offelem(1)=numels
635 off = numels
636C
637 DO i = 1, numelq
638 tagelem(i+off)=3
639 DO k=1,4
640 n = ixq(k+1,i)
641 cne(adsky(n)) = i+off
642 adsky(n) = adsky(n) + 1
643 ENDDO
644 ENDDO
645C
646 offelem(2)=numelq
647 off = off + numelq
648C
649 DO i = 1, numelc
650 tagelem(i+off)=4
651 DO k=1,4
652 n = ixc(k+1,i)
653 cne(adsky(n)) = i+off
654 adsky(n) = adsky(n) + 1
655 ENDDO
656 ENDDO
657C
658
659 offelem(3)=numelc
660 off = off + numelc
661C
662 DO i = 1, numelt
663 tagelem(i+off)=5
664 DO k=1,2
665 n = ixt(k+1,i)
666 cne(adsky(n)) = i+off
667 adsky(n) = adsky(n) + 1
668 ENDDO
669 ENDDO
670C
671 offelem(4)= numelt
672 off = off + numelt
673C
674 DO i = 1, numelp
675 tagelem(i+off)=6
676 DO k=1,2
677 n = ixp(k+1,i)
678 cne(adsky(n)) = i+off
679 adsky(n) = adsky(n) + 1
680 ENDDO
681 ENDDO
682C
683 offelem(5) = numelp
684 off = off + numelp
685C
686 DO i = 1, numelr
687 tagelem(i+off)=7
688 DO k=1,2
689 n = ixr(k+1,i)
690 cne(adsky(n)) = i+off
691 adsky(n) = adsky(n) + 1
692 ENDDO
693 IF(nint(geo(12,ixr(1,i)))==12) THEN
694 n = ixr(4,i)
695 cne(adsky(n)) = i+off
696 adsky(n) = adsky(n) + 1
697 ENDIF
698 ENDDO
699C
700 offelem(6)=numelr
701 off = off + numelr
702C
703 DO i = 1, numeltg
704 tagelem(i+off)=8
705 DO k=1,3
706 n = ixtg(k+1,i)
707 cne(adsky(n)) = i+off
708 adsky(n) = adsky(n) + 1
709 ENDDO
710 ENDDO
711C
712 offelem(7)=numeltg
713 off = off + numeltg
714
715C Old obsolete & removed element
716 offelem(8) = 0
717C
718 DO i=1, numelx
719 tagelem(i+off)=10
720 nelx=kxx(3,i)
721 DO k=1,nelx
722 addx = kxx(4,i)+k-1
723 n=ixx(addx)
724 cne(adsky(n)) = i+off
725 adsky(n) = adsky(n) + 1
726 ENDDO
727 ENDDO
728C
729 offelem(9)=numelx
730 off = off + numelx
731C
732 DO i=1, numelig3d
733 tagelem(i+off)=11
734 nelig3d=kxig3d(3,i)
735 DO k=1,nelig3d
736 addx = kxig3d(4,i)+k-1
737 n=ixig3d(addx)
738 cne(adsky(n)) = i+off
739 adsky(n) = adsky(n) + 1
740 ENDDO
741 ENDDO
742C
743 offelem(10)=numelig3d
744 off = off + numelig3d
745C
746C reset addresses to beginning
747 DO i=numnod+1,2,-1
748 adsky(i) = adsky(i-1)
749 END DO
750
751 adsky(1) = 1
752C Weight calculation taking into account connectivity ratio
753
754 icelem=1
755 icints=0
756 icintm=0
757 icint2=0
758 iccand=0
759 icnod_sms=0
760 icddl=0
761 icfsi=0
762 icsol=0
763 icdel=0
764 icr2r=0
765 ickin=0
766 ncond=1
767C
768 DO i = 1, nelemint
769 itypint=abs(inter_cand%IXINT(6,i))
770 IF(itypint == 2)THEN
771 icint2 = icint2+1
772 ELSEIF(itypint == 7 .OR. itypint == 11)THEN
773 icints = icints+1
774 icintm = icintm+1
775 iccand = iccand+1
776 ELSEIF(itypint == 24 .OR. itypint == 25)THEN
777 icints = icints+1
778 icintm = icintm+1
779 iccand = iccand+1
780 END IF
781 END DO
782C
783 IF(ddnod_sms/=0)THEN
784 ncond=ncond+1
785 icnod_sms=ncond
786 ELSE
787 icnod_sms=0
788 END IF
789C
790 IF(nelem > 0) THEN
791 IF((icints+icintm>100) .AND.
792 + (nelem < icints+icintm .OR.
793 + float(nelem-icints-icintm)/float(nelem)<=zep95)) THEN
794 ncond=ncond+1
795 icints=ncond
796 ncond=ncond+1
797 icintm=ncond
798 ELSE
799 IF(nsnt+nmnt>100) THEN
800 ncond=ncond+1
801 icints=ncond
802 ncond=ncond+1
803 icintm=ncond
804 ELSE
805 icints=0
806 icintm=0
807 ENDIF
808 END IF
809 IF((icint2>100) .AND.
810 + (nelem < icint2 .OR.
811 + float(nelem-icint2)/float(nelem)<=zep98)) THEN
812 ncond=ncond+1
813 icint2=ncond
814 ELSE
815 icint2=0
816 END IF
817C test bypass contact for small test cases
818 IF((iccand>100) .AND.
819 + (nelem < iccand .OR.
820 + float(nelem-iccand)/float(nelem)<=zep95)) THEN
821 ncond=ncond+1
822 iccand=ncond
823 ELSE
824 iccand=0
825 END IF
826 ELSE ! nelem = 0 (full sph)
827 icints = 0
828 icintm = 0
829 icint2 = 0
830 iccand = 0
831 ENDIF
832C
833 nk=0
834c IF(NK > 0) THEN ! Test To bypass load-balancing of Kin.Cond. temporarily
835 IF(elemd == 0) THEN ! Test To bypass load-balancing of Kin.Cond. if element deletion already active (large RB)
836 DO i = 1, numnod
837c NKI=IWL(IKINE(I))+2*IRB(IKINE(I))+2*IRB2(IKINE(I))
838c + +2*IRBM(IKINE(I))+2*IRLK(IKINE(I))+2*IJO(IKINE(I))
839c + +2*IKRBE2(IKINE(I))+2*IKRBE3(IKINE(I))
840c IWKIN(I)=NKI
841c NK = NK+NKI
842 nki=iwl(ikine(i))+irb(ikine(i))+irb2(ikine(i))
843 + +irbm(ikine(i))+irlk(ikine(i))+ijo(ikine(i))
844 + +ikrbe2(ikine(i))+ikrbe3(ikine(i))
845 iwkin(i)=nki
846 nk = nk+min(nki,1)
847 END DO
848c print *,'n cond=',NK,FLOAT(NUMNOD-NK)/FLOAT(NUMNOD)
849 IF(float(numnod-nk)/float(numnod)>zep95) nk = 0
850 IF(nk > 20000) THEN ! needs a sufficient number of kin.cond.
851 ncond = ncond+1
852 ickin = ncond
853 END IF
854 END IF
855C
856 IF(dectyp==5.OR.dectyp==6)THEN
857C weight permutation element <=> dof
858 ncond = ncond+1
859 icddl=1
860 icelem=ncond
861 IF(elemd>0) THEN
862 ncond = ncond+1
863 icdel = ncond
864 END IF
865
866 ELSE
867 IF(ilag==1.AND.(iale==1.OR.ieuler==1))THEN
868C if FSI
869 ncond = ncond+1
870 nb_elem_ale = 0
871 DO i = 1, numels
872 mid = abs(ixs(1,i))
873 pid = abs(ixs(10,i))
874 jale_from_mat = nint(pm(72,mid)) !old way to enable ALE/EULER framework (backward compatibility)
875 jale_from_prop = igeo(62,pid) !new way to enable ALE/EULER framework
876 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader MLN = NINT(PM(19,MID))
877 IF(jale==0.AND.mln/=18)THEN
878
879 ELSE
880 nb_elem_ale = nb_elem_ale + 1
881 END IF
882 ENDDO
883
884 IF (nelem - nb_elem_ale < 128 * nspmd) THEN
885C Priority is FSI
886 icfsi = 1
887 icelem = ncond
888 WRITE(iout,'(A)')
889 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR ALE (1)'
890 ELSEIF( nb_elem_ale*2 > nelem ) THEN
891C Priority is FSI then ELEM
892 icfsi = 1
893 icelem = 2
894 IF(icddl/=0) icddl = icddl + 1
895 IF(icints/=0) icints = icints + 1
896 IF(icintm/=0) icintm = icintm + 1
897 IF(icint2/=0) icint2 = icint2 + 1
898 IF(ickin/=0) ickin = ickin + 1
899 IF(icnod_sms/=0) icnod_sms = icnod_sms +1
900 IF(icdel/=0) icdel = icdel + 1
901 IF(iccand/=0) iccand = iccand + 1
902 WRITE(iout,'(A)')
903 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR ALE (2)'
904 ELSEIF ( nb_elem_ale*4 > nelem) THEN
905C Priority is ELEM then FSI
906 icfsi = 2
907 icelem = 1
908 IF(icddl/=0) icddl = icddl + 1
909 IF(icints/=0) icints = icints + 1
910 IF(icintm/=0) icintm = icintm + 1
911 IF(icint2/=0) icint2 = icint2 + 1
912 IF(ickin/=0) ickin = ickin + 1
913 IF(icnod_sms/=0) icnod_sms = icnod_sms +1
914 IF(icdel/=0) icdel = icdel + 1
915 IF(iccand/=0) iccand = iccand + 1
916 WRITE(iout,'(A)')
917 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR FSI (3)'
918 ELSE
919 icfsi = ncond
920 END IF
921 END IF
922 IF(isolbar > 10000 .AND. icfsi == 0 .AND. numelc > numels)THEN
923C if more than 10K solid law28/LAW68, decompose solid like there is a barrier
924C IF(IDDLEVEL==1.) THEN
925 WRITE(iout,'(A)')
926 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR BARRIER '
927C ENDIF
928 ncond = ncond+1
929 icsol=ncond
930 END IF
931 IF(elemd>0) THEN
932 ncond = ncond+1
933 icdel = ncond
934 END IF
935 END IF
936 IF(nsubdom>0)THEN
937 numel_r2r = 0
938 DO i = 1, numels
939 IF (tag_elsf(i) /= 0) numel_r2r = numel_r2r+1
940 END DO
941 DO i = 1, numelc
942 IF (tag_elcf(i) /= 0) numel_r2r = numel_r2r+1
943 END DO
944 IF (numel_r2r>=nspmd) THEN
945 WRITE(iout,'(A)')
946 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR MULTIDOMAINS '
947 ncond = ncond+1
948 icr2r=ncond
949 ENDIF
950 END IF
951C
952 ALLOCATE(rwd(nelem*ncond),stat=ierr1)
953C Metis weights following
954 DO i = 1, ncond*nelem
955 rwd(i) = 0
956 ENDDO
957C default weight optimization
958 CALL initwg(wd,pm,geo,ixs,ixq,
959 . ixc,ixt,ixp,ixr,ixtg,
960 . kxx,igeo,isolnod,iarch,
961 . numels,numelq,numelc,numelt,numelp,
962 . numelr,numeltg,numelx,ipm,
963 . bufmat,nummat,numgeo,taille,poin_ump,
964 . tab_ump,poin_ump_old,tab_ump_old,cputime_mp_old,
965 . tabmp_l,ipart,ipartc,ipartg,
966 . iparts,npart,poin_part_shell,poin_part_tri,poin_part_sol,
967 . mid_pid_shell,mid_pid_tri,mid_pid_sol,iddlevel,
968 . mat_param)
969C
970 IF(nsubdom>0)THEN
971 cost_r2r = zero
972 DO i=1,nelem
973 scal = one
974 IF (i<=numels) THEN
975 mid = abs(ixs(1,i))
976 pid = abs(ixs(10,i))
977 jale_from_mat = nint(pm(72,mid)) !new way to enable ALE/EULER framework (backward compatibility)
978 jale_from_prop = igeo(62,pid) !old way to enable ALE/EULER framework
979 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
980 mln = nint(pm(19,mid))
981 IF (jale/=0) scal = 2.5
982 IF (mln==51) scal = 4.5
983 ENDIF
984 cost_r2r = cost_r2r + wd(i)
985 END DO
986 ENDIF
987C
988 DO i=1,numels
989 nnc=0
990 IF ((icr2r /= 0)) THEN
991 IF((tag_elsf(i) /= 0))THEN
992 rwd(ncond*(i-1)+icr2r) = 1
993 ENDIF
994 ENDIF
995 IF(icsol /= 0) rwd(ncond*(i-1)+icsol) = 1
996 IF(isolnod(i)==4.OR.isolnod(i)==10)THEN
997 DO k=1,8
998 n = ixs(k+1,i)
999 IF(n/=0)THEN
1000 fac=one/(adsky(n+1)-adsky(n))
1001 nnc = nnc+adsky(n+1)-adsky(n)
1002 IF(icddl/=0)rwd(ncond*(i-1)+icddl)=rwd(ncond*(i-1)+icddl)
1003 + +dsdof(n)*fac
1004 IF(icints/=0)
1005 + rwd(ncond*(i-1)+icints)=rwd(ncond*(i-1)+icints)
1006 + +iwcont(1,n)*fac
1007 IF(icintm/=0)
1008 + rwd(ncond*(i-1)+icintm) = rwd(ncond*(i-1)+icintm)
1009 + + iwcont(2,n)*fac
1010 IF(icint2/=0)
1011 + rwd(ncond*(i-1)+icint2)=rwd(ncond*(i-1)+icint2)
1012 + +(iwcin2(1,n)+iwcin2(2,n))*fac
1013 IF(ickin/=0)rwd(ncond*(i-1)+ickin)=rwd(ncond*(i-1)+ickin)
1014 + +iwkin(n)*fac
1015 IF(icnod_sms/=0)rwd(ncond*(i-1)+icnod_sms)=rwd(ncond*(i-1)+icnod_sms)
1016 + +min(dsdof(n),1)*fac
1017 END IF
1018 END DO
1019 IF(isolnod(i)==10)THEN
1020 ii = i-numels8
1021 DO k=1,6
1022 n = ixs10(k,ii)
1023 IF(n/=0)THEN
1024C take care of non connected node
1025 fac=one/max(adsky(n+1)-adsky(n),1)
1026 nnc = nnc+adsky(n+1)-adsky(n)
1027 IF(icddl/=0)rwd(ncond*(i-1)+icddl)=rwd(ncond*(i-1)+icddl)
1028 + +dsdof(n)*fac
1029 IF(icints/=0)
1030 + rwd(ncond*(i-1)+icints)=rwd(ncond*(i-1)+icints)
1031 + +iwcont(1,n)*fac
1032 IF(icintm/=0)
1033 + rwd(ncond*(i-1)+icintm) = rwd(ncond*(i-1)+icintm)
1034 + + iwcont(2,n)*fac
1035 IF(icint2/=0)
1036 + rwd(ncond*(i-1)+icint2)=rwd(ncond*(i-1)+icint2)
1037 + +(iwcin2(1,n)+iwcin2(2,n))*fac
1038 IF(ickin/=0)rwd(ncond*(i-1)+ickin)=rwd(ncond*(i-1)+ickin)
1039 + +iwkin(n)*fac
1040 IF(icnod_sms/=0)rwd(ncond*(i-1)+icnod_sms)=rwd(ncond*(i-1)+icnod_sms)
1041 + +min(dsdof(n),1)*fac
1042 ENDIF
1043 ENDDO
1044cc IF(ICNOD /= 0) RWD(NCOND*(I-1)+ICNOD) = ONE ! to define if needed
1045 ELSE
1046cc IF(ICNOD /= 0) RWD(NCOND*(I-1)+ICNOD) = ONE/FIVE ! to define if needed
1047 ENDIF
1048 ELSE
1049 DO k=1,8
1050 n = ixs(k+1,i)
1051 IF(n/=0)THEN
1052C take care of non connected node
1053 fac=one/max(adsky(n+1)-adsky(n),1)
1054 nnc = nnc+adsky(n+1)-adsky(n)
1055 IF(icddl/=0)rwd(ncond*(i-1)+icddl)=rwd(ncond*(i-1)+icddl)
1056 + +dsdof(n)*fac
1057 IF(icints/=0)
1058 + rwd(ncond*(i-1)+icints)=rwd(ncond*(i-1)+icints)
1059 + +iwcont(1,n)*fac
1060 IF(icintm/=0)
1061 + rwd(ncond*(i-1)+icintm) = rwd(ncond*(i-1)+icintm)
1062 + + iwcont(2,n)*fac
1063 IF(icint2/=0)
1064 + rwd(ncond*(i-1)+icint2)=rwd(ncond*(i-1)+icint2)
1065 + +(iwcin2(1,n)+iwcin2(2,n))*fac
1066 IF(ickin/=0)rwd(ncond*(i-1)+ickin)=rwd(ncond*(i-1)+ickin)
1067 + +iwkin(n)*fac
1068 IF(icnod_sms/=0)rwd(ncond*(i-1)+icnod_sms)=rwd(ncond*(i-1)+icnod_sms)
1069 + +min(dsdof(n),1)*fac
1070 END IF
1071 ENDDO
1072cc IF(ICNOD /= 0) RWD(NCOND*(I-1)+ICNOD) = (EIGHT*EIGHT)/NNC
1073 ENDIF
1074 ENDDO
1075C
1076C-----------------------------------------------
1077C
1078 off = numels
1079C interface weight = 0 in 2D
1080C
1081 off = off + numelq
1082C
1083 DO i = 1, numelc
1084 nnc=0
1085 IF (icr2r /= 0) THEN
1086 IF (tag_elcf(i) /= 0) THEN
1087 rwd(ncond*(i+off-1)+icr2r) = 1
1088 ENDIF
1089 ENDIF
1090 DO k=1,4
1091 n = ixc(k+1,i)
1092 IF(n/=0)THEN
1093 fac=one/(adsky(n+1)-adsky(n))
1094 nnc = nnc+adsky(n+1)-adsky(n)
1095 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1096 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1097 IF(icints/=0)
1098 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1099 + + iwcont(1,n)*fac
1100 IF(icintm/=0)
1101 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1102 + + iwcont(2,n)*fac
1103 IF(icint2/=0)
1104 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1105 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1106 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1107 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1108 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1109 + +min(dsdof(n),1)*fac
1110 END IF
1111 ENDDO
1112cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD)=(FOUR*FOUR)/NNC
1113 ENDDO
1114C
1115 off = off + numelc
1116C
1117 DO i = 1, numelt
1118 nnc=0
1119 DO k=1,2
1120 n = ixt(k+1,i)
1121 IF(n/=0)THEN
1122 fac=one/(adsky(n+1)-adsky(n))
1123 nnc = nnc+adsky(n+1)-adsky(n)
1124 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1125 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1126 IF(icints/=0)
1127 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1128 + + iwcont(1,n)*fac
1129 IF(icintm/=0)
1130 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1131 + + iwcont(2,n)*fac
1132 IF(icint2/=0)
1133 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1134 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1135 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1136 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1137 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1138 + +min(dsdof(n),1)*fac
1139 END IF
1140 ENDDO
1141cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = (TWO*TWO)/NNC
1142 ENDDO
1143C
1144 off = off + numelt
1145C
1146 DO i = 1, numelp
1147 nnc=0
1148 DO k=1,2
1149 n = ixp(k+1,i)
1150 IF(n/=0)THEN
1151 fac=one/(adsky(n+1)-adsky(n))
1152 nnc = nnc+adsky(n+1)-adsky(n)
1153 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1154 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1155 IF(icints/=0)
1156 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1157 + + iwcont(1,n)*fac
1158 IF(icintm/=0)
1159 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1160 + + iwcont(2,n)*fac
1161 IF(icint2/=0)
1162 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1163 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1164 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1165 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1166 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1167 + +min(dsdof(n),1)*fac
1168 END IF
1169 ENDDO
1170cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = (TWO*TWO)/NNC
1171 ENDDO
1172C
1173 off = off + numelp
1174C
1175 DO i = 1, numelr
1176 nnc=0
1177 DO k=1,2
1178 n = ixr(k+1,i)
1179 IF(n/=0)THEN
1180 fac=one/(adsky(n+1)-adsky(n))
1181 nnc = nnc+adsky(n+1)-adsky(n)
1182 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1183 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1184 IF(icints/=0)
1185 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1186 + + iwcont(1,n)*fac
1187 IF(icintm/=0)
1188 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1189 + + iwcont(2,n)*fac
1190 IF(icint2/=0)
1191 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1192 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1193 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1194 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1195 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1196 + +min(dsdof(n),1)*fac
1197 END IF
1198 ENDDO
1199 IF(nint(geo(12,ixr(1,i)))==12) THEN
1200 n = ixr(4,i)
1201 IF(n/=0)THEN
1202 fac=one/(adsky(n+1)-adsky(n))
1203 nnc = nnc+adsky(n+1)-adsky(n)
1204 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1205 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1206 IF(icints/=0)
1207 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1208 + + iwcont(1,n)*fac
1209 IF(icintm/=0)
1210 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1211 + + iwcont(2,n)*fac
1212 IF(icint2/=0)
1213 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1214 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1215 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1216 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1217 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1218 + +min(dsdof(n),1)*fac
1219 END IF
1220 ENDIF
1221cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = (TWO*TWO)/NNC
1222 ENDDO
1223C
1224 off = off + numelr
1225C
1226 DO i = 1, numeltg
1227 nnc=0
1228 DO k=1,3
1229 n = ixtg(k+1,i)
1230 IF(n/=0)THEN
1231 fac=one/(adsky(n+1)-adsky(n))
1232 nnc = nnc+adsky(n+1)-adsky(n)
1233 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1234 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1235 IF(icints/=0)
1236 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1237 + + iwcont(1,n)*fac
1238 IF(icintm/=0)
1239 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1240 + + iwcont(2,n)*fac
1241 IF(icint2/=0)
1242 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1243 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1244 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1245 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1246 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1247 + +min(dsdof(n),1)*fac
1248 END IF
1249 ENDDO
1250cc IF(ICNOD /= 0)
1251cc + RWD(NCOND*(I+OFF-1)+ICNOD) = (ONE/TWO)*(SIX*THREE)/NNC
1252 ENDDO
1253C
1254 off = off + numeltg
1255C
1256 DO i=1, numelx
1257 nelx=kxx(3,i)
1258 nnc=0
1259 DO k=1,nelx
1260 addx = kxx(4,i)+k-1
1261 n=ixx(addx)
1262 IF(n/=0)THEN
1263 fac=one/(adsky(n+1)-adsky(n))
1264 nnc = nnc+adsky(n+1)-adsky(n)
1265 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1266 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1267 IF(icints/=0)
1268 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1269 + + iwcont(1,n)*fac
1270 IF(icintm/=0)
1271 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1272 + + iwcont(2,n)*fac
1273 IF(icint2/=0)
1274 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1275 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1276 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1277 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1278 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1279 + +min(dsdof(n),1)*fac
1280 END IF
1281 ENDDO
1282cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = ONE ! to be defined if needed
1283 ENDDO
1284C
1285 off = off + numelx
1286
1287C interface & dof weight normalization
1288
1289 ALLOCATE(iwd(nelem*ncond),stat=ierr1)
1290
1291 DO i = 1, ncond*nelem
1292 iwd(i) = 0
1293 ENDDO
1294 DO i = 1, nelem
1295C no longer need normalization to 1
1296 IF(icints/=0)
1297 . iwd(ncond*(i-1)+icints) = nint(rwd(ncond*(i-1)+icints))
1298 IF(icintm/=0)
1299 . iwd(ncond*(i-1)+icintm) = nint(rwd(ncond*(i-1)+icintm))
1300 IF(iccand/=0)
1301 . iwd(ncond*(i-1)+iccand) = nint(rwd(ncond*(i-1)+iccand))
1302 IF(icint2/=0)
1303 . iwd(ncond*(i-1)+icint2) = nint(rwd(ncond*(i-1)+icint2))
1304 IF(icddl/=0)
1305 . iwd(ncond*(i-1)+icddl)= nint(rwd(ncond*(i-1)+icddl))
1306 IF(icsol/=0)
1307 . iwd(ncond*(i-1)+icsol)= nint(rwd(ncond*(i-1)+icsol))
1308 IF(ickin/=0)
1309 . iwd(ncond*(i-1)+ickin)= nint(rwd(ncond*(i-1)+ickin))
1310 IF(icr2r/=0)
1311 . iwd(ncond*(i-1)+icr2r)= nint(rwd(ncond*(i-1)+icr2r))
1312c IF(ICNOD/=0)
1313c . IWD(NCOND*(I-1)+ICNOD)= NINT(RWD(NCOND*(I-1)+ICNOD)*10)
1314 IF(icnod_sms/=0)
1315 . iwd(ncond*(i-1)+icnod_sms) = nint(rwd(ncond*(i-1)+icnod_sms))
1316 END DO
1317
1318 DEALLOCATE(rwd)
1319
1320C.....construction of Ei Ej pairs connected by a point
1321
1322 nedges = 0
1323 DO n = 1, numnod
1324 DO cc1 = adsky(n), adsky(n+1)-1
1325 numg1 = cne(cc1)
1326 IF(numg1 > 0) THEN ! by-pass extra nodes
1327 DO cc2 = cc1+1, adsky(n+1)-1
1328 numg2 = cne(cc2)
1329 IF(numg2 > 0 .AND. numg1 /= numg2) THEN ! by-pass extra nodes
1330 nedges = nedges + 1
1331 END IF
1332 ENDDO
1333 END IF
1334 ENDDO
1335 ENDDO
1336C
1337 IF (iddlevel==1) nedges = nedges+nelemint
1338C
1339C----------------------------------------------
1340! SIDDCONNECT minimum size NELEM. Value set to 10*NELEM
1341 IF(nelem < 100 000 000) THEN
1342 siddconnect = 2*10*nelem
1343 ELSE
1344 ! For very large model
1345 ! edge filtering is forced
1346 siddconnect = 2 000 000 000
1347 edge_filtering = 1
1348 ENDIF
1349! Linked-list IDDCONNECT
1350! IDDCONNECT%IENTRYDOM : entry in IDDCONNECT for element N
1351! IDDCONNECT%PDOM(1,N) : connected element to element N
1352! IDDCONNECT%PDOM(2,N) : next index in IDDCONNECT for element N
1353! allocation IDDCONNECT % PDOM et % IENTRYDOM
1354 ALLOCATE(iddconnect%PDOM(2,siddconnect),stat=ierr1)
1355 ALLOCATE(iddconnect%IENTRYDOM(2,nelem),stat=ierr1)
1356! initialisation de IDDCONNECT%IENTRYDOM
1357 CALL ini_iddconnect(nelem)
1358C
1359 nedges_old = nedges
1360
1361 IF(edge_filtering == 1 .AND. (numels > nelem / 3 .OR. icfsi > 0 )) THEN
1362 WRITE(iout,'(A)') "** INFO: SIMPLIFIED DOMAIN DECOMPOSITION"
1363C+------------------------------------------------------------+
1364C| Domain decomposition for models with solids |
1365C| dectivated via Domdec = -3 in /SPMD card |
1366C+------------------------------------------------------------+
1367 ALLOCATE(connectivity(max_nb_nodes_per_elt,nelem))
1368 ALLOCATE(nb_nodes_mini(nelem)) ! minimum number of shared nodes to consider the edge
1369 connectivity(1:max_nb_nodes_per_elt,1:nelem) = 0
1370 nb_nodes_mini(1:nelem) = 3
1371 DO i = 1 , nelem
1372 CALL find_nodes(i ,connectivity(1,i),tagelem,ixs,ixs10,
1373 1 ixq ,ixc ,ixt ,ixp,ixr,
1374 2 ixtg ,kxx ,ixx,kxig3d,
1375 3 ixig3d,geo ,offelem,nb_nodes_mini(i))
1376 CALL sort_descending(connectivity(1,i))
1377 ENDDO
1378
1379 ALLOCATE(connect_weight(nelem))
1380 ALLOCATE(pointer_neigh(nelem))
1381 DO i =1,nelem
1382 connect_weight(i)=0
1383 pointer_neigh(i)=0
1384 ENDDO
1385 nelmin = 0
1386 DO i = 1 , nelem
1387 nelmin = nb_nodes_mini(i)
1388 elemnodes(1:max_nb_nodes_per_elt) = connectivity(1:max_nb_nodes_per_elt,i)
1389 prev_neigh = 0
1390 c_neigh = 0
1391 j = 0
1392 DO k=1,max_nb_nodes_per_elt
1393 IF ( elemnodes(k)/=0 ) THEN
1394 DO l=adsky(elemnodes(k)), adsky(elemnodes(k)+1)-1
1395 IF( cne(l) > 0 .AND. cne(l) > i) THEN
1396 connect_weight(cne(l)) =
1397 . connect_weight(cne(l)) + 1
1398 IF( connect_weight(cne(l)) == 1 ) THEN
1399 pointer_neigh(cne(l))=prev_neigh
1400 c_neigh = c_neigh + 1
1401 prev_neigh = cne(l)
1402 ENDIF
1403 ENDIF
1404 ENDDO
1405 j=j+1
1406 ENDIF
1407 ENDDO
1408 ! if NELMIN is not defined by FIND_NODES, we keep edges
1409 ! between elements that have 3 or more nodes in common
1410 IF(nelmin == 0) nelmin = 3
1411 IF (c_neigh > 0 ) THEN
1412 DO j=1,c_neigh
1413 IF(i /= prev_neigh) THEN
1414 IF(consider_edge(connectivity,nb_nodes_mini,nelem,i,prev_neigh)) THEN
1415 CALL iddconnectplus(i,prev_neigh,nelem)
1416 CALL iddconnectplus(prev_neigh,i,nelem)
1417 ENDIF
1418 ENDIF
1419 point_delete=prev_neigh
1420 prev_neigh = pointer_neigh(prev_neigh)
1421 pointer_neigh(point_delete) = 0
1422 connect_weight(point_delete) = 0
1423 ENDDO
1424 ENDIF
1425 ENDDO
1426 DEALLOCATE(connect_weight)
1427 DEALLOCATE(pointer_neigh)
1428 DEALLOCATE(nb_nodes_mini)
1429 DEALLOCATE(connectivity)
1430
1431 ELSE
1432C+------------------------------------------------------------+
1433C| Classical domain decomposition without edge filtering |
1434C+------------------------------------------------------------+
1435 DO n = 1, numnod
1436 DO cc1 = adsky(n), adsky(n+1)-1
1437 numg1 = cne(cc1)
1438 IF(numg1 > 0) THEN ! by-pass extra nodes
1439 DO cc2 = cc1+1, adsky(n+1)-1
1440 numg2 = cne(cc2)
1441 IF(numg2 > 0 .AND. numg1 /= numg2) THEN ! by-pass extra nodes
1442 CALL iddconnectplus(numg1,numg2,nelem)
1443 CALL iddconnectplus(numg2,numg1,nelem)
1444 END IF
1445 ENDDO
1446 END IF
1447 ENDDO
1448 ENDDO
1449 ENDIF !(EDGE_FILTERING == 0 )
1450
1451 nedges = 0
1452 nedges_8 = 0
1453 DO i=1,nelem
1454 CALL c_iddconnect(i,taille_local)
1455 nedges = nedges + taille_local
1456 nedges_8 = nedges_8 + taille_local
1457 ENDDO
1458 nedges = nedges/2
1459
1460
1461C DEALLOCATE(TAGELEM)
1462 IF (iddlevel==1) THEN
1463C-----------------------------------------------
1464C by pass des elements outils
1465C-----------------------------------------------
1466 iwarn1 = 0
1467 DO i = 1, nelem
1468 IF(ielem21(i)==1)THEN
1469 IF(wd(i)>0.01)THEN
1470 iwarn1 = 1
1471 END IF
1472 END IF
1473 END DO
1474 IF(iwarn1/=0)THEN
1475 WRITE(iout,*)' '
1476 WRITE(iout,'(A)')
1477 . ' ONE OR MORE ELEMENT OF MAIN SIDE OF INTERF. TYPE21',
1478 . ' NEEDS TO BE DEACTIVATED'
1479 END IF
1480
1481C=======================================================================
1482C FVMBAG Super ELEMENT Connectivity
1483C=======================================================================
1484 wd_max = 0
1485 IF(nvolu > 0 .AND. iddlevel == 1 .AND. icfsi == 0) THEN
1486 CALL fvbag_vertex(ixc ,ixtg ,nelem, wd,
1487 . wd_max,fvm_elem,fvm_domdec,itab,igrsurf,t_monvol)
1488 ENDIF
1489
1490
1491C-----------------------------------------------
1492C CONNECTIVITES INTERFACES
1493C-----------------------------------------------
1494C
1495C seulement rajouter une connectivite entre noeud et facette
1496C
1497C eviter conflit entre type 2 et type 7
1498C
1499C cep temporairement utilise comme flag
1500 DO i = 1, nelem
1501 cep(i) = 0
1502 ENDDO
1503C
1504 DO i = 1, nelemint ! Loop over the the pair of candidates
1505 n=inter_cand%IXINT(5,i) !N is the secondary node
1506 IF (n<=numnod) THEN !
1507 numg1=abs(cne(adsky(n))) ! NUMG1 is the first element found connected to node N
1508 numg2=numg1
1509 itypint=abs(inter_cand%IXINT(6,i))
1510 IF(itypint==2) THEN ! Type 2 interface (tied contact)
1511 IF(adsky(n+1)-adsky(n)>0)THEN ! number of elements connected to node N
1512 n=inter_cand%IXINT(1,i) ! 1st node of the main segment
1513 n1=inter_cand%IXINT(2,i) ! 2nd node of the main segment
1514 n2=inter_cand%IXINT(3,i) ! 3td ode of the main segment
1515 DO i1 = adsky(n), adsky(n+1)-1 ! loop over the elements connected to node N
1516 numg2=abs(cne(i1)) ! NUMG2 = id of the current element connected to node N
1517 DO i2 = adsky(n1), adsky(n1+1)-1 ! loop over elts connected to N1
1518 numg3=abs(cne(i2))
1519 IF(numg3==numg2) THEN
1520 DO i3 = adsky(n2), adsky(n2+1)-1
1521 numg4=abs(cne(i3))
1522 IF(numg4==numg2) GOTO 100 !Found one element connected to N,N1,N2
1523 ENDDO
1524 ENDIF
1525 ENDDO
1526 ENDDO
1527 100 CONTINUE
1528 IF(numg1 /= numg2) THEN
1529 CALL iddconnectplus(numg1,numg2,nelem)
1530 CALL iddconnectplus(numg2,numg1,nelem)
1531 cep(numg1) = 1
1532 cep(numg2) = 1
1533 ENDIF
1534 ENDIF
1535 ENDIF
1536 ENDIF
1537 ENDDO
1538
1539
1540 IF(iccand > 0) THEN
1541 DO n = 1,numnod
1542 IF( iwcont(4,n) > 0) THEN
1543 DO i1 = adsky(n), adsky(n+1)-1
1544 numg2=abs(cne(i1))
1545 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+iwcont(4,n)
1546 ENDDO
1547 ENDIF
1548 ENDDO
1549 ENDIF
1550
1551
1552
1553 ALLOCATE(isort(nelemint))
1554 ALLOCATE(index_sort(2*nelemint))
1555
1556C sorting of NELEMINT : negative value for IXINT(6) means that distance is small
1557 DO i=1,nelemint
1558 isort(i)=(-inter_cand%IXINT(6,i)) + 100
1559 index_sort(i)=i
1560 itypint=abs(inter_cand%IXINT(6,i))
1561 ENDDO
1562 CALL my_orders(0,work,isort,index_sort,nelemint,1)
1563
1564
1565C
1566C hierarchy : type 2 before, contact now
1567 DO ii = 1, nelemint
1568 i = index_sort(ii)
1569 n=inter_cand%IXINT(5,i)
1570 IF (n<=numnod) THEN ! FOR ISOGEOMETRIC ELEMENTS (FICTITIOUS PART NOT TO BE CONSIDERED)
1571 numg1=-1
1572C searching for the first connected element not seen
1573 cep_min = huge(cep_min)
1574 DO i1 = adsky(n), adsky(n+1)-1
1575 numg3=abs(cne(i1))
1576 IF(cep_min > cep(numg3)) THEN
1577 numg1 = numg3
1578 cep_min = cep(numg1)
1579 ENDIF
1580 IF(cep_min == 0) EXIT
1581 END DO
1582C initialization numg2 for case where facet not found (error)
1583 numg2=-1
1584 itypint=abs(inter_cand%IXINT(6,i))
1585 IF(itypint==7) THEN
1586 IF(adsky(n+1)-adsky(n)>0)THEN
1587 n=inter_cand%IXINT(1,i)
1588 n1=inter_cand%IXINT(2,i)
1589 n2=inter_cand%IXINT(3,i)
1590 IF (n<=numnod) THEN ! FOR ISOGEOMETRIC ELEMENTS (FICTITIOUS PART NOT TO BE CONSIDERED)
1591 DO i1 = adsky(n), adsky(n+1)-1
1592 numg2=abs(cne(i1))
1593 IF(numg2 == numg1) THEN
1594 GOTO 107
1595! Avoid adding edges between element already connected
1596 ELSE
1597 DO i2 = adsky(n1), adsky(n1+1)-1
1598 numg3=abs(cne(i2))
1599 IF(numg3 == numg1) GOTO 107
1600 IF(numg3==numg2) THEN
1601 DO i3 = adsky(n2), adsky(n2+1)-1
1602 numg4=abs(cne(i3))
1603 IF(numg4 == numg1) GOTO 107
1604 IF(numg4==numg2) GOTO 107
1605 ENDDO
1606 ENDIF
1607 ENDDO
1608 END IF
1609 ENDDO
1610 ENDIF
1611 107 CONTINUE
1612
1613 IF(numg1 /= numg2 .AND. (numg1 >0 ) .AND. (numg2 > 0)) THEN
1614 IF(cep(numg1)==0.OR.cep(numg2)==0) THEN
1615 number_of_added_edges = number_of_added_edges + 1
1616C test to limit number of edges added for contact interfaces
1617 CALL iddconnectplus(numg1,numg2,nelem)
1618 CALL iddconnectplus(numg2,numg1,nelem)
1619
1620 cep(numg1) = cep(numg1) + 1
1621 cep(numg2) = cep(numg2) + 1
1622 ELSE
1623 refused_cep0 = refused_cep0 + 1
1624 ENDIF
1625 ELSE
1626 if(numg1 == numg2) refused_numg = refused_numg + 1
1627 if(numg1<=0 .OR. numg2<=0) refused_numg0 = refused_numg0 + 1
1628
1629 ENDIF
1630 IF(iccand > 0 .AND. numg2 > 0) THEN
1631C load-balancing contact force -- incremental needed for multiple interface
1632cc IWD(NCOND*(NUMG2-1)+ICCAND)=IWD(NCOND*(NUMG2-1)+ICCAND)+1
1633 IF(inter_cand%IXINT(6,i)<0)THEN
1634C 5:1 ratio between potential impact and just candidat
1635 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+5
1636 ELSE
1637 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1638 ENDIF
1639 END IF
1640
1641 ENDIF
1642 ELSEIF(itypint==11) THEN
1643 IF(adsky(n+1)-adsky(n)>0)THEN
1644 n1=inter_cand%IXINT(3,i)
1645 n2=inter_cand%IXINT(4,i)
1646 DO i1 = adsky(n1), adsky(n1+1)-1
1647 numg2=abs(cne(i1))
1648 IF(numg2 /= numg1) THEN
1649 DO i2 = adsky(n2), adsky(n2+1)-1
1650 numg3=abs(cne(i2))
1651 IF(numg3==numg2) GOTO 111
1652 ENDDO
1653 END IF
1654 ENDDO
1655 111 CONTINUE
1656 IF(numg1 /= numg2 .AND.(numg1>0 .AND. numg2 > 0)) THEN
1657 IF(cep(numg1)==0.OR.cep(numg2)==0) THEN
1658C test to limit number of edges added for contact interfaces
1659 number_of_added_edges = number_of_added_edges + 1
1660
1661 CALL iddconnectplus(numg1,numg2,nelem)
1662 CALL iddconnectplus(numg2,numg1,nelem)
1663 cep(numg1) = cep(numg1) + 1
1664 cep(numg2) = cep(numg2) + 1
1665 ELSE
1666 refused_cep0 = refused_cep0 + 1
1667 ENDIF
1668 ELSE
1669 if(numg1 == numg2) refused_numg = refused_numg + 1
1670 if(numg1<=0 .OR. numg2<=0) refused_numg0 = refused_numg0 + 1
1671 ENDIF
1672 IF(iccand > 0 .AND. numg2 > 0) THEN
1673C load-balancing contact force -- incremental needed for multiple interface
1674 IF(inter_cand%IXINT(6,i)<0)THEN
1675 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1676 ELSE
1677 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1678 ENDIF
1679 END IF
1680
1681 ENDIF
1682 ELSEIF(itypint==24.OR.itypint==25)THEN
1683 IF(adsky(n+1)-adsky(n)>0)THEN
1684 n=inter_cand%IXINT(1,i)
1685 n1=inter_cand%IXINT(2,i)
1686 n2=inter_cand%IXINT(3,i)
1687 DO i1 = adsky(n), adsky(n+1)-1
1688 numg2=abs(cne(i1))
1689 IF(numg2 == numg1) GOTO 124
1690 IF(numg2 /= numg1) THEN
1691 DO i2 = adsky(n1), adsky(n1+1)-1
1692 numg3=abs(cne(i2))
1693 IF(numg3 == numg1) GOTO 124
1694 IF(numg3==numg2) THEN
1695 DO i3 = adsky(n2), adsky(n2+1)-1
1696 numg4=abs(cne(i3))
1697 IF(numg4 == numg1) GOTO 124
1698 IF(numg4==numg2) GOTO 124
1699 ENDDO
1700 ENDIF
1701 ENDDO
1702 END IF
1703 ENDDO
1704 124 CONTINUE
1705 IF(numg1 /= numg2 .AND. (numg1>0 .AND. numg2 > 0)) THEN
1706 IF(cep(numg1)==0.OR.cep(numg2)==0) THEN
1707 number_of_added_edges = number_of_added_edges + 1
1708
1709 CALL iddconnectplus(numg1,numg2,nelem)
1710 CALL iddconnectplus(numg2,numg1,nelem)
1711 cep(numg1) = cep(numg1) + 1
1712 cep(numg2) = cep(numg2) + 1
1713 ELSE
1714 refused_cep0 = refused_cep0 + 1
1715 ENDIF
1716 ELSE
1717 if(numg1 == numg2) refused_numg = refused_numg + 1
1718 if(numg1<=0 .OR. numg2<=0) refused_numg0 = refused_numg0 + 1
1719 ENDIF
1720 IF(iccand > 0 .AND. numg2 > 0) THEN
1721 IF(inter_cand%IXINT(6,i)<0)THEN
1722 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+5
1723 ELSE
1724 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1725 END IF
1726 END IF
1727
1728 ENDIF
1729 ENDIF
1730 ENDIF ! if isogeometric element
1731 ENDDO
1732
1733C ================================================================
1734C Add connectivity between disconnected parts
1735C according to the distance
1736 ALLOCATE(colors(nelem+1),stat=ierr1)
1737 ALLOCATE(roots(nelem),stat=ierr1)
1738 CALL plist_bfs(nelem,nconnx,colors,roots)
1739
1740 !NUMG1 id of the root element of the larest connected part
1741 ALLOCATE(min_dist(nconnx))
1742 ALLOCATE(coords(3,nconnx))
1743 DO i = 1,nconnx
1744
1745 CALL find_nodes(roots(i) ,elemnodes,tagelem,ixs,ixs10,
1746 1 ixq ,ixc ,ixt ,ixp,ixr,
1747 2 ixtg ,kxx ,ixx,kxig3d,
1748 3 ixig3d,geo ,offelem,nelmin)
1749
1750 IF(elemnodes(1) /= 0) THEN
1751 coords(1:3,i) = x(1:3,elemnodes(1))
1752 ELSE
1753 coords(1:3,i) = zero
1754 ENDIF
1755 ENDDO
1756
1757 DO i = 1, nconnx
1758 numg1 = roots(i)
1759 min_dist(1:nconnx) = huge(1.0)
1760 DO j = 1, nconnx
1761 numg2 = roots(j)
1762 IF(numg1 /= numg2) THEN
1763 min_dist(j) = (coords(1,i)-coords(1,j))**2
1764 . + (coords(2,i)-coords(2,j))**2
1765 . + (coords(3,i)-coords(3,j))**2
1766
1767 ENDIF
1768 ENDDO
1769 dist = minval(min_dist(1:nconnx))
1770 k = 0
1771 DO j = 1, nconnx
1772 numg2 = roots(j)
1773 IF(numg1 /= numg2 .AND. min_dist(j) < 2.0*dist) THEN
1774C connectivity added between roots of the distance is < 2 x the minimum
1775C distance between the current root, and its closest neighbor
1776 CALL iddconnectplus(numg1,numg2,nelem)
1777 CALL iddconnectplus(numg2,numg1,nelem)
1778 k = k + 1
1779 ENDIF
1780 ENDDO
1781 ENDDO
1782 DEALLOCATE(min_dist)
1783 DEALLOCATE(coords)
1784 DEALLOCATE(index_sort,isort)
1785C ================================================================
1786C WRITE(6,*) "STATISTIC ON CONTACT INTERFACE"
1787C WRITE(6,"(6(A,X,I10))") " added:",number_of_added_edges,
1788C . " refused_numg: ",refused_numg,
1789C . " refused_numg0: ",refused_numg0,
1790C . " refused_cep0: ",refused_cep0,
1791C . " switch_tried: ",switch_tried,
1792C . " switch_done: ",switch_done
1793C
1794! nombre de edge
1795 nedges = 0
1796 nedges_8 = 0
1797 DO i=1,nelem
1798 CALL c_iddconnect(i,taille_local)
1799 nedges = nedges + taille_local
1800 nedges_8 = nedges_8 + taille_local
1801 ENDDO
1802 nedges = nedges/2
1803 nedges_8 = nedges_8 / 2
1804 ENDIF
1805
1806 IF(ALLOCATED(tagelem)) DEALLOCATE(tagelem)
1807
1808
1809! ----------------------------------------------------------------
1810! Check if there are some small rigid bodies (ie. with less than 40 secondary nodes)
1811! in order to force the rigid body elements on a given processor
1812! loop over the rigid bodies
1813! if small rigid body : save the element list in a vector (c_prevent_decomposition_rbody function)
1814! if more than 1 small rigid body : force the domain decomposition (c_enforce_constraints_rbody function)
1815!
1816! if more than 1 small rigid body : BOOL_RBODY logical = true
1817!
1818 bool_rbody=.false.
1819
1820 IF(iddlevel/=0) THEN
1821 numel = numels+numelq+numelc+numelt+numelp+numelr
1822 . + numeltg+numelx+numsph+numelig3d
1823
1824! ------------------------
1825 k = 0
1826 DO n = 1, nrbykin
1827 nsn = npby(2,n) ! number of secondary nodes
1828
1829 IF(nsn<40) THEN
1830 m = npby(1,n) ! main nodes
1831 ! -----------------------------
1832 ! find the number of element in the rigid body
1833 number_of_element_rbody = 0 ! number of element in the current RBODY
1834 ! ----------------
1835 ! secondary nodes
1836 DO j=1,nsn
1837 i = lpby(j+k)
1838 DO ijk = adsky(i),adsky(i+1)-1
1839 number_of_element_rbody = number_of_element_rbody + 1
1840 ENDDO
1841 ENDDO
1842 ! ----------------
1843 ! main node
1844 DO ijk = adsky(m),adsky(m+1)-1
1845 number_of_element_rbody = number_of_element_rbody + 1
1846 ENDDO
1847 ! ----------------
1848 ALLOCATE( list_element_rbody(number_of_element_rbody) )
1849 ! -----------------------------
1850
1851 number_of_element_rbody = 0 ! number of element in the current RBODY
1852 ! ----------------
1853 ! secondary nodes
1854 DO j=1,nsn
1855 i = lpby(j+k)
1856 DO ijk = adsky(i),adsky(i+1)-1
1857 cc2 = ijk
1858 numg2 = abs(cne(cc2))
1859 number_of_element_rbody = number_of_element_rbody + 1
1860 list_element_rbody( number_of_element_rbody ) = numg2
1861 bool_rbody=.true.
1862 ENDDO
1863 ENDDO
1864 ! ----------------
1865 ! main node
1866 DO ijk = adsky(m),adsky(m+1)-1
1867 cc2 = ijk
1868 numg2 = abs(cne(cc2))
1869 number_of_element_rbody = number_of_element_rbody + 1
1870 list_element_rbody( number_of_element_rbody ) = numg2
1871 ENDDO
1872 ! ----------------
1873 ! save the element list
1874 IF(number_of_element_rbody>0)
1875 . CALL c_prevent_decomposition_rbody(number_of_element_rbody,list_element_rbody)
1876 DEALLOCATE( list_element_rbody )
1877 ! ----------------
1878 ENDIF
1879 k = k + nsn
1880 ENDDO
1881
1882! ------------------------
1883 ENDIF
1884! ----------------------------------------------------------------
1885
1886 IF (nedges>0 .AND. nspmd > 1) THEN
1887! structures Metis 1/2
1888 ALLOCATE(xadj(nelem+1),stat=ierr1)
1889! init XADJ
1890 xadj(1:nelem+1)=0
1891! deallocation de CNE
1892 DEALLOCATE(cne)
1893! Nombre de edges
1894 nedges = 0
1895 DO i=1,nelem
1896 CALL c_iddconnect(i,taille_local)
1897 nedges = nedges + taille_local
1898 ENDDO
1899 nedges = nedges/2
1900! structures Metis 2/2
1901 ALLOCATE(adjncy(2*nedges),stat=ierr1)
1902
1903 xadj(1) = 1
1904 DO i=1,nelem
1905 CALL c_iddconnect(i,taille_local)
1906 xadj(i+1) = xadj(i) + taille_local
1907 IF(taille_local>0) THEN
1908 CALL plist_iddconnect(adjncy,xadj,i)
1909 ENDIF
1910 ENDDO
1911! deallocation de IDDCONNECT % PDOM et % IENTRYDOM
1912 DEALLOCATE(iddconnect%PDOM)
1913 DEALLOCATE(iddconnect%IENTRYDOM)
1914
1915C Determine connectivity components
1916 IF(ALLOCATED(colors)) DEALLOCATE(colors)
1917 IF(ALLOCATED(roots)) DEALLOCATE(roots)
1918 ALLOCATE(colors(nelem+1),stat=ierr1)
1919 ALLOCATE(roots(nelem),stat=ierr1)
1920 CALL dd_bfs(xadj,adjncy,nelem,nedges,nconnx,colors,roots)
1921 IF(nconnx > 1) THEN
1922 WRITE(iout,'(A,I8)')
1923 . ' NUMBER OF DISCONNECTED COMPONENTS FIXED FOR DOMAIN DECOMP:'
1924 . ,nconnx
1925C Metis Workaround to create additional connectivities between non connected graphs
1926 ALLOCATE(xadj_old(nelem+1),stat=ierr1)
1927 ALLOCATE(adjncy_old(2*nedges),stat=ierr1)
1928 xadj_old(1:nelem+1)=xadj(1:nelem+1)
1929 adjncy_old(1:2*nedges)=adjncy(1:2*nedges)
1930 newedge = nedges+nconnx-1
1931 DEALLOCATE(adjncy)
1932 ALLOCATE(adjncy(2*newedge),stat=ierr1)
1933C 1) recompute new XADJ and fill new ADJCNY
1934 inc=0
1935 DO i = 1, nconnx
1936 curr=roots(i) ! roots(1)=1
1937 i1=xadj(curr)
1938 i1old=xadj_old(curr)
1939 i2old=xadj_old(curr+1)-1
1940 IF(i>1)THEN
1941C insert 1 edge to previous connex component
1942 prev=roots(i-1) ! PREV < CURR < NEXT
1943 IF(i1old <= 2*nedges) THEN
1944 DO WHILE ((i1old <= i2old) .AND.
1945 + (adjncy_old(i1old) < prev))
1946 adjncy(i1) = adjncy_old(i1old)
1947 i1 = i1+1
1948 i1old=i1old+1
1949 IF(i1old > 2*nedges) EXIT
1950 END DO
1951 ENDIF
1952 adjncy(i1) = prev
1953 i1=i1+1
1954 inc=inc+1 ! recall to swap INC+1 next addresses in XADJ
1955 END IF
1956 IF(i<nconnx)THEN
1957C insert 1 edge to next connex component
1958 next=roots(i+1)
1959 IF(i1old <= 2*nedges) THEN
1960 DO WHILE ((i1old <= i2old) .AND.
1961 + (adjncy_old(i1old) < next))
1962 adjncy(i1) = adjncy_old(i1old)
1963 i1 = i1+1
1964 i1old=i1old+1
1965 IF(i1old > 2*nedges) EXIT
1966 END DO
1967 ENDIF
1968 adjncy(i1) = next
1969 i1=i1+1
1970 inc=inc+1 ! increase shift value for next addresses in XADJ
1971 ELSE
1972 next = nelem+1 ! special value to stop recopy of remaining edges
1973 END IF
1974C finish to recopy the rest of the edges for CURR
1975 DO WHILE (i1old <= i2old)
1976 adjncy(i1) = adjncy_old(i1old)
1977 i1 = i1+1
1978 i1old=i1old+1
1979 END DO
1980C recopy the rest of the edges for all the vertices till NEXT or NELEM+1
1981 n=curr+1
1982 DO WHILE (n /= next)
1983 xadj(n)=xadj(n)+inc
1984 i1=xadj(n)
1985 i1old=xadj_old(n)
1986 i2old=xadj_old(n+1)-1
1987 DO WHILE (i1old <= i2old)
1988 adjncy(i1) = adjncy_old(i1old)
1989 i1 = i1+1
1990 i1old=i1old+1
1991 END DO
1992 n = n+1
1993 END DO
1994C set correct XADJ for NEXT of NELEM+1
1995 xadj(next)=xadj(next)+inc
1996 END DO
1997C
1998 nedges=newedge
1999 DEALLOCATE(xadj_old,adjncy_old)
2000C 2) recompute connexity to verify it is ok now
2001 CALL dd_bfs(xadj,adjncy,nelem,nedges,nconnx,colors,roots)
2002 IF(nconnx > 1) THEN
2003 WRITE(iout,'(A,I8)')
2004 . '** INFO: REMAINING DISCONNECTED COMPONENTS:',nconnx
2005 END IF
2006 END IF
2007 DEALLOCATE(colors,roots)
2008
2009 WRITE(iout,*)' '
2010 WRITE(iout,fmt=fmw_a_i)
2011 . ' ELEMENT NUMBER = ',nelem
2012 WRITE(iout,fmt=fmw_a_i)' EDGES FOUND = ',nedges
2013 WRITE(iout,*)' '
2014
2015 iwflg=2
2016 nflag=1
2017C old metis option kept for compatibility
2018 options(1)=0
2019C new Metis5 Definition
2020 ierror = metis_setdefaultoptions(options)
2021c DO I = 1, 40
2022c OPTIONS(I) = -1
2023c END DO
2024C OPTIONS(METIS_OPTION_NUMBERING) = 1 ! Fortran numbering -- position 17 en 5.0.2 et 18 en 5.1
2025
2026 options(18)=1
2027! OPTIONS(8) = 3 ! METIS NCUTS options
2028
2029C OPTIONS(METIS OPTION CONTIG) = 1 ! Option for contiguous sub domains
2030C OPTIONS(12)=1
2031C OPTIONS(METIS OPTION OBJTYPE) = 1
2032C OPTIONS(2)=0 ! 0 => CUT (default); 1 => VOL ;
2033C OPTIONS(METIS OPTION CTYPE) = 1
2034C OPTIONS(3)=1 ! 0 => METIS CTYPE RM (default); 1 => METIS CTYPE SHEM (default) ;
2035C OPTIONS(METIS OPTION IPTYPE) = 1 ! ignore
2036C OPTIONS(4)=2 ! 0 => GROW ; 1 => RANDOM to try ; 2 => EDGE ; 3 => NODE
2037C OPTIONS(METIS OPTION IRTYPE) = 1 ! ignore
2038C OPTIONS(5)=0 ! 0 => FM ; 1 => Greedy to try ; 2 => 1 S NODE ; 3 => 2 S NODE
2039C OPTIONS(METIS OPTION NITER) = 10 (default) !
2040C OPTIONS(7)=20 ! 20 tres leger mieux
2041C OPTIONS(METIS MIN CONN) = 0 (default) !
2042C OPTIONS(11)=1 ! 1 minimize max connectivity
2043C OPTIONS(METIS NO2HOP) = 0 (default) !
2044C OPTIONS(10)=1 ! 20 ! ignore
2045C OPTIONS(METIS UFACTOR) = 30 (default) !
2046C OPTIONS(17)=1 ! ignore
2047C OPTIONS(METIS NCUTS) = 1 (default) !
2048C OPTIONS(8) = 4
2049C OPTIONS(8)=1
2050C Domain decomposition CRASH ou FSI
2051 IF(icfsi==0)THEN
2052 DO i = 1, nelem
2053C weight normalization (deleted elem to 0)
2054 iwd(ncond*(i-1)+icelem) = nint(wd(i)*100)
2055C interface weight already calculated
2056 END DO
2057 ELSE
2058 DO i = 1, nelem
2059 IF(i<=numels)THEN
2060 mid = abs(ixs(1,i))
2061 pid = abs(ixs(10,i))
2062 jale_from_mat = nint(pm(72,mid)) !old way to enable ALE/EULER framework (backward compatibility)
2063 jale_from_prop = igeo(62,pid) !new way to enable ALE/EULER framework
2064 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader MLN = NINT(PM(19,MID))
2065 mln = nint(pm(19,mid))
2066 IF(jale==0.AND.mln/=18)THEN
2067 iwd(ncond*(i-1)+icelem) = nint(wd(i)*100)
2068 iwd(ncond*(i-1)+icfsi) = 0
2069 ELSE
2070 iwd(ncond*(i-1)+icelem) = 0
2071 iwd(ncond*(i-1)+icfsi) = nint(wd(i)*100)
2072 END IF
2073 ELSE
2074C weight normalization (deleted elem to 0)
2075 iwd(ncond*(i-1)+icelem) = nint(wd(i)*100)
2076 END IF
2077C interface weight already calculated
2078 END DO
2079 END IF
2080 IF(icdel>0)THEN
2081 DO i = 1, nelem
2082C em delete
2083 IF(wd(i)==0.0001)THEN
2084 iwd(ncond*(i-1)+icdel) = 1
2085 ELSE
2086 iwd(ncond*(i-1)+icdel) = 0
2087 END IF
2088C interface weight already calculated
2089 END DO
2090 END IF
2091
2092
2093C In case of cluster, transfer the weight to the first cluster element
2094 IF(ncluster > 0) THEN
2095 DO i = 1, ncluster
2096 cluster_typ = clusters(i)%TYPE
2097 offset_cluster = 0
2098 IF(cluster_typ==2.OR.cluster_typ==3) offset_cluster = numels+numelq+numelc+numelt+numelp
2099 DO j = 2, clusters(i)%NEL
2100 DO k =1, ncond
2101 iwd((clusters(i)%ELEM(1)-1) * ncond+k +offset_cluster) =
2102 . iwd((clusters(i)%ELEM(1)-1) * ncond+k +offset_cluster) +
2103 . iwd((clusters(i)%ELEM(j)-1) * ncond+k +offset_cluster)
2104 iwd((clusters(i)%ELEM(j)-1) * ncond+k +offset_cluster) = 0
2105 ENDDO
2106 END DO
2107 END DO
2108 ENDIF
2109
2110
2111C
2112C Specific treatment for integer weight overflow
2113C
2114 DO i = 1, ncond
2115 1024 CONTINUE
2116 ws = zero
2117 DO j = 1, nelem
2118 ws = ws + iwd(ncond*(j-1)+i)
2119 END DO
2120 IF(ws>2*ep9)THEN
2121 WRITE(iout,'(A,I4)')
2122 . ' WEIGHT PRECISION DECREASED TO ENABLE CRITERION',i
2123 DO j = 1, nelem
2124 iwd(ncond*(j-1)+i) = iwd(ncond*(j-1)+i)/10
2125 END DO
2126 GO TO 1024
2127 END IF
2128 END DO
2129
2130C
2131 ubvec(1:15) = 0
2132 ubvec(icelem) = 1.02
2133 IF(icints/=0) ubvec(icints) = 1.05
2134 IF(icintm/=0) ubvec(icintm) = 1.05
2135 IF(icint2/=0) ubvec(icint2) = 1.05
2136 IF(icddl/=0) ubvec(icddl) = 1.02
2137 IF(icsol/=0) ubvec(icsol) = 1.05
2138 IF(icfsi/=0) ubvec(icfsi) = 1.02
2139 IF(icdel/=0) ubvec(icdel) = 1.10
2140 IF(iccand/=0) ubvec(iccand) = 1.10
2141 IF(ickin/=0) ubvec(ickin) = 1.10
2142 IF(icr2r/=0) ubvec(icr2r) = 1.30
2143 IF(icnod_sms/=0) ubvec(icnod_sms) = 1.05
2144c i=0
2145c call METIS_EstimateMemory(NELEM,XADJ,ADJNCY,0,2,I)
2146c print *,'estimate memory=',i,nelem,XADJ(NELEM+1)
2147 1999 CONTINUE
2148 IF(dectyp==3.OR.dectyp==5)THEN
2149C KWAY METIS
2150
2151 ierr1 = wrap_metis_partgraphkway(
2152 1 nelem,ncond,xadj,adjncy,
2153 2 iwd,nnode,
2154 3 ubvec,options,nec,cep)
2155 idb_metis = 0
2156
2157 IF(idb_metis == 1) THEN
2158C write graph for Metis debug
2159 it=0
2160 WRITE(chlevel,'(I1)')iddlevel
2161C weight only on vertices
2162 OPEN(99,file="input.graph"//chlevel,form='FORMATTED',recl=8192)
2163 write(99,*) nelem,nedges,"010",ncond
2164 do i = 1, nelem
2165 write(99,*)iwd(ncond*(i-1)+1:ncond*(i-1)+ncond),
2166 + adjncy(xadj(i):xadj(i+1)-1)
2167 it = it + xadj(i+1)-xadj(i)
2168 end do
2169 print *,'writing graph with check:',it,'/',nedges*2
2170 CLOSE(99)
2171 END IF
2172 ELSEIF(dectyp==4.OR.dectyp==6)THEN
2173C RSB METIS
2174 ierr1 = wrap_metis_partgraphrecursive(
2175 1 nelem,ncond,xadj,adjncy,
2176 2 iwd,nnode,
2177 3 ubvec,options,nec,cep)
2178 END IF
2179 CALL stat_domdec(
2180 1 wis ,wi2 ,wfsi ,wdel ,wddl ,
2181 2 wcand ,wsol ,wr2r ,wkin ,iwd ,
2182 3 ncond ,icelem ,icints ,icint2 ,iccand ,
2183 4 icddl ,icsol ,icfsi ,icdel ,icr2r ,
2184 5 ickin ,average ,deviation ,dmax ,dmin ,
2185 6 cep ,nelem ,w ,icintm ,wim ,
2186 7 ncritmax ,wnod_sms,icnod_sms)
2187
2188
2189 IF(icfsi > 0 .AND. icfsi < icelem) THEN
2190! the order in DMIN,DMAX is independent of the order of constraints
2191 main_target = 7
2192 ELSE
2193 main_target = 1
2194 ENDIF
2195
2196C CHECK Quality of Domain Decomp on elements
2197C If ( ALE .or. first domdec) .and. (first try)) then check load balance
2198 IF( ( main_target == 7 .OR. iddlevel==1) .AND. (dectyp==3 .OR. dectyp==5) )THEN
2199 IF(dmin(main_target) < average(main_target)*0.90 )THEN
2200 WRITE(iout,'(A)')
2201 . '** INFO: DECOMPOSITION UNBALANCING DETECTED'
2202 WRITE(iout,'(A,I5,A,2X,I8,2X,I8,2X,I8)')
2203 . ' DOMAINS:',nspmd,' MIN/MAX/AVERAGE:',
2204 . nint(dmin(main_target)),nint(dmax(main_target)),nint(average(main_target))
2205c IF(.NOT. FVM_DOMDEC) THEN
2206 WRITE(iout,'(A)')' REVERT TO RECURSIVE BISSECTION'
2207c ENDIF
2208 dectyp=dectyp+1
2209
2210 IF(fvm_domdec) THEN
2211 ubvec(icelem) = 1.01
2212 IF(icints/=0) ubvec(icints) = 1.02
2213 IF(icintm/=0) ubvec(icintm) = 1.02
2214 IF(icint2/=0) ubvec(icint2) = 1.02
2215 IF(icddl/=0) ubvec(icddl) = 1.05
2216 IF(icsol/=0) ubvec(icsol) = 1.05
2217 IF(icfsi/=0) ubvec(icfsi) = 1.05
2218 IF(icdel/=0) ubvec(icdel) = 1.05
2219 IF(iccand/=0) ubvec(iccand) = 1.05
2220 IF(ickin/=0) ubvec(ickin) = 1.05
2221 IF(icr2r/=0) ubvec(icr2r) = 1.30
2222 IF(icnod_sms/=0) ubvec(icnod_sms) = 1.0
2223 ELSE
2224 ubvec(icelem) = 1.001
2225 IF(icints/=0) ubvec(icints) = 1.02
2226 IF(icintm/=0) ubvec(icintm) = 1.02
2227 IF(icint2/=0) ubvec(icint2) = 1.02
2228 IF(icddl/=0) ubvec(icddl) = 1.01
2229 IF(icsol/=0) ubvec(icsol) = 1.03
2230 IF(icfsi/=0) ubvec(icfsi) = 1.01
2231 IF(icdel/=0) ubvec(icdel) = 1.03
2232 IF(iccand/=0) ubvec(iccand) = 1.03
2233 IF(ickin/=0) ubvec(ickin) = 1.03
2234 IF(icr2r/=0) ubvec(icr2r) = 1.30
2235 IF(icnod_sms/=0) ubvec(icnod_sms) = 1.0
2236 ENDIF
2237 GOTO 1999
2238 END IF
2239 END IF
2240C---------------------------------------------------------------------
2241C Loop over domain decomposition until satisfactory load balancing for element
2242C---------------------------------------------------------------------
2243 max_try = 3
2244 wd_max_factor = 2
2245 ALLOCATE(iwd_copy(ncond*nelem))
2246 ALLOCATE(wd_copy(nelem))
2247 IF((dectyp==4 .OR. dectyp==6) .AND. iddlevel==1 .AND. nelem>10*nspmd )THEN
2248
2249 IF(icdel /= 0 ) THEN
2250 IF(elemd > 9*nelem/10 .AND. dmin(main_target) < average(main_target)*0.80 ) THEN
2251 ! If the model is mainly deleted elements
2252 ! Then we equilibrate first on deleted elements
2253 DO i= 1, nelem
2254 wght=iwd(ncond*(i-1)+1)
2255 iwd(ncond*(i-1)+1) = iwd(ncond*(i-1)+icdel)
2256 iwd(ncond*(i-1)+icdel)=wght
2257 ENDDO
2258 ENDIF
2259 ENDIF
2260
2261 ncond2=ncond
2262 dd_fvmbag_try = 0
2263 wd_max0 = wd_max
2264 wd_copy(1:nelem) = wd(1:nelem)
2265 iwd_copy(1:ncond * nelem) = iwd(1:ncond*nelem)
2266
2267 dd_unbalanced = (dmin(main_target) < average(main_target)*0.80)
2268 IF(fvm_domdec) THEN
2269 dd_unbalanced = dd_unbalanced .OR. (dmax(main_target) > average(main_target)*1.1)
2270 wd_max0 = 0.0
2271 DO n = 1, nvolu
2272 IF(fvm_elem(n) /= 0) THEN
2273 wd_max0= max(wd_max0,dble(wd(fvm_elem(n))))
2274 ENDIF
2275 ENDDO
2276 wd_max0 = min(wd_max,wd_max0)
2277 wd_max = wd_max0
2278 ENDIF
2279
2280 DO WHILE(dd_unbalanced .AND. ncond2 > 1 )
2281C CHECK Quality of Domain Decomp on elements
2282 WRITE(iout,'(A)')
2283 . '** INFO: DECOMPOSITION UNBALANCING DETECTED'
2284 WRITE(iout,'(A,I5,A,2X,I8,2X,I8,2X,I8)')
2285 . ' DOMAINS:',nspmd,' MIN/MAX/AVERAGE:',
2286 . nint(dmin(main_target)),nint(dmax(main_target)),nint(average(main_target))
2287
2288 !==========================================
2289 ! REVIEW WEIGHTS OF FVMBAGS
2290 !
2291 ! Try to trim the weight of FVMBAG
2292 ! if the domain decomposition fails
2293 nb_fvmbag_trim = 0
2294 IF(fvm_domdec .AND. dd_fvmbag_try <= max_try) THEN
2295 wd_max = wd_max / (0.1d0 * wd_max_factor)
2296 DO n = 1, nvolu
2297 IF(fvm_elem(n) /= 0) THEN
2298 IF(wd(fvm_elem(n)) > wd_max) THEN
2299 wd(fvm_elem(n)) = wd_max
2300 iwd(ncond*(fvm_elem(n)-1)+icelem) = nint(wd_max*100)
2301 nb_fvmbag_trim = nb_fvmbag_trim + 1
2302 ENDIF
2303 ENDIF
2304 ENDDO
2305 ENDIF
2306 IF(nb_fvmbag_trim > 0) THEN
2307 ! Try to reduce the weight of the FVMBAG vertex
2308 ! before reducing the number of constraints
2309 dd_fvmbag_try = dd_fvmbag_try + 1
2310 ELSE
2311 ! Reducing the number of constraints
2312 ! Resetting weights
2313 ncond2= ncond2 - 1
2314 dd_fvmbag_try = 0
2315 max_try = max_try + 1
2316 wd_max = wd_max0
2317 wd(1:nelem) = wd_copy(1:nelem)
2318 iwd(1:ncond*nelem) = iwd_copy(1:ncond*nelem)
2319 ENDIF
2320 !==============================================
2321
2322
2323
2324 WRITE(iout,'(A,I5)') 'RETRY KWAY WITH NCOND =',ncond2
2325
2326 ALLOCATE(iwd2(ncond2*nelem))
2327 DO i= 1, nelem
2328 DO j = 1, ncond2
2329 iwd2( ncond2*(i-1) +j ) = iwd( ncond*(i-1) + j)
2330 ENDDO
2331 ENDDO
2332C KWAY METIS
2333 ierr1 = wrap_metis_partgraphkway(
2334 1 nelem,ncond2,xadj,adjncy,
2335 2 iwd2,nnode,
2336 3 ubvec,options,nec,cep)
2337 CALL stat_domdec(
2338 1 wis ,wi2 ,wfsi ,wdel ,wddl ,
2339 2 wcand ,wsol ,wr2r ,wkin ,iwd ,
2340 3 ncond ,icelem ,icints ,icint2 ,iccand ,
2341 4 icddl ,icsol ,icfsi ,icdel ,icr2r ,
2342 5 ickin ,average ,deviation ,dmax ,dmin ,
2343 6 cep ,nelem ,w ,icintm ,wim ,
2344 7 ncritmax ,wnod_sms,icnod_sms)
2345
2346! CHECK Quality of Domain Decomp on elements
2347 dd_unbalanced = (dmin(main_target) < average(main_target)*0.80)
2348 IF(fvm_domdec) THEN
2349 dd_unbalanced = dd_unbalanced .OR. (dmax(main_target) > average(main_target)*1.1)
2350 ENDIF
2351
2352
2353 IF(dd_unbalanced)THEN
2354
2355 WRITE(iout,'(A)')
2356 . '** INFO: DECOMPOSITION UNBALANCING DETECTED'
2357 WRITE(iout,'(A,I5,A,2X,I8,2X,I8,2X,I8)')
2358 . ' DOMAINS:',nspmd,' MIN/MAX/AVERAGE:',
2359 . nint(dmin(main_target)),nint(dmax(main_target)),nint(average(main_target))
2360
2361C RSB METIS
2362
2363 ierr1 = wrap_metis_partgraphrecursive(
2364 1 nelem,ncond2,xadj,adjncy,
2365 2 iwd2,nnode,
2366 3 ubvec,options,nec,cep)
2367 CALL stat_domdec(
2368 1 wis ,wi2 ,wfsi ,wdel ,wddl ,
2369 2 wcand ,wsol ,wr2r ,wkin ,iwd ,
2370 3 ncond ,icelem ,icints ,icint2 ,iccand ,
2371 4 icddl ,icsol ,icfsi ,icdel ,icr2r ,
2372 5 ickin ,average ,deviation ,dmax ,dmin ,
2373 6 cep ,nelem ,w ,icintm ,wim ,
2374 7 ncritmax ,wnod_sms,icnod_sms)
2375
2376 ENDIF
2377 DEALLOCATE(iwd2)
2378
2379 dd_unbalanced = (dmin(main_target) < average(main_target)*0.80)
2380 IF(fvm_domdec) THEN
2381 dd_unbalanced = dd_unbalanced .OR. (dmax(main_target) > average(main_target)*1.1)
2382 ENDIF
2383
2384 ENDDO ! ( DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.80 .AND. NCOND2 > 1 )
2385 ENDIF
2386 DEALLOCATE(iwd_copy)
2387 DEALLOCATE(wd_copy)
2388C---------------------------------------------------------------------
2389C End of loop over domain decomposition
2390C---------------------------------------------------------------------
2391 ! stick the list of rigid body element on a given processor
2392 IF(iddlevel/=0.AND.bool_rbody) CALL c_enforce_constraints_rbody(cep,nspmd,nrbykin)
2393
2394 ! make sure that lists of elements in C_PREVENT_DECOMPOSITION are on the same domain
2395 CALL c_enforce_constraints(cep)
2396
2397C Put all the elements of the cluster on the same proc
2398 IF (ncluster > 0) THEN
2399 DO i = 1, ncluster
2400 cluster_typ = clusters(i)%TYPE
2401 offset_cluster = 0
2402 IF(cluster_typ==2.OR.cluster_typ==3) offset_cluster = numels+numelq+numelc+numelt+numelp
2403 cepcluster=cep( clusters(i)%ELEM(1)+offset_cluster )
2404 DO j = 2,clusters(i)%NEL
2405 cep( clusters(i)%ELEM(j)+offset_cluster ) = cepcluster
2406 END DO
2407 END DO ! I = 1, NCLUSTER
2408 END IF ! NCLUSTER > 0
2409
2410
2411C
2412C Save the PMAIN in FVMAIN
2413 IF(nvolu > 0 .AND. iddlevel==1 .AND. fvm_domdec) THEN
2414
2415 offc = numels+numelq
2416 offtg =numels+numelq+ numelc+numelt+numelp+numelr
2417 nn_l = 0
2418 cepcluster = 1
2419 nfvmbag = 0
2420 DO n = 1, nvolu
2421 ityp = t_monvol(n)%TYPE
2422 nn = t_monvol(n)%NNS
2423! find location of the first element
2424! i.e. the element with all the weight
2425 IF(ityp == 6 .OR. ityp == 8) nfvmbag = nfvmbag + 1
2426
2427 IF(nn > 0 .AND. (ityp == 6 .OR. ityp == 8)) THEN
2428 cepcluster = cep(fvm_elem(n))
2429 fvmain(nfvmbag) = cepcluster
2430 ENDIF
2431 ENDDO
2432 ENDIF
2433
2434C
2435 DEALLOCATE(xadj,adjncy)
2436! IF(ASSOCIATED(ADJWGT2)) DEALLOCATE(ADJWGT2)
2437
2438 DO i = 1, nelem
2439 cep(i) = cep(i)-1
2440 END DO
2441
2442 !---------------------!
2443 !2D - EBCS : send boundary cells in domain 1
2444 DO i=1,numelq
2445 IF(ebcs_tag_cell_spmd(i)==1)THEN
2446 cep(numels+i)=0
2447 ENDIF
2448 ENDDO
2449 DO i=1,numeltg
2450 IF(ebcs_tag_cell_spmd(numelq+i)==1)THEN
2451 cep(numels+numelq+numelc+numelt+numelp+numelr+i)=0
2452 ENDIF
2453 ENDDO
2454 !3D - EBCS : send boundary cells in domain 1
2455 DO i=1,numels
2456 IF(ebcs_tag_cell_spmd(numelq+numeltg+i)==1)THEN
2457 cep(i)=0
2458 ENDIF
2459 ENDDO
2460 !---------------------!
2461C
2462 IF(dectyp==5.OR.dectyp==6)THEN
2463 IF(ddnod_sms==0)THEN
2464 WRITE(iout,1000)
2465 ELSE
2466 WRITE(iout,1100)
2467 END IF
2468 ELSEIF(icfsi==0) THEN
2469 IF(icsol==0.AND.icdel==0)THEN
2470 WRITE(iout,2000)
2471 ELSEIF(icsol/=0.AND.icdel==0)THEN
2472 WRITE(iout,3000)
2473 ELSEIF(icsol/=0.AND.icdel/=0)THEN
2474 WRITE(iout,4000)
2475 ELSEIF(icsol==0.AND.icdel/=0)THEN
2476 WRITE(iout,5000)
2477 END IF
2478 ELSEIF(icfsi/=0)THEN
2479 IF(icdel==0)THEN
2480 WRITE(iout,6000)
2481 ELSE
2482 WRITE(iout,7000)
2483 END IF
2484 END IF
2485 DO i = 1, nspmd
2486 IF(dectyp==5.OR.dectyp==6)THEN
2487 IF(ddnod_sms==0)THEN
2488 WRITE(iout,'(I4,8F15.0)')
2489 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wddl(i)
2490 ELSE
2491 WRITE(iout,'(I4,8F15.0)')
2492 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wddl(i),wnod_sms(i)
2493 END IF
2494 ELSEIF(icfsi==0)THEN
2495 IF(icsol==0.AND.icdel==0)THEN
2496 WRITE(iout,'(I4,8F15.0)')
2497 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wkin(i)
2498 ELSEIF(icsol/=0.AND.icdel==0)THEN
2499 WRITE(iout,'(I4,8F15.0)')
2500 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wsol(i),wkin(i)
2501 ELSEIF(icsol/=0.AND.icdel/=0)THEN
2502 WRITE(iout,'(I4,8F15.0)')
2503 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wsol(i),wdel(i),wkin(i)
2504 ELSEIF(icsol==0.AND.icdel/=0)THEN
2505 WRITE(iout,'(I4,8F15.0)')
2506 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wdel(i),wkin(i)
2507 ENDIF
2508 ELSEIF(icfsi/=0.AND.icdel==0)THEN
2509 WRITE(iout,'(I4,8F15.0)')
2510 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wfsi(i)
2511 ELSEIF(icfsi/=0.AND.icdel/=0)THEN
2512 WRITE(iout,'(I4,8F15.0)')
2513 . i,w(i),wis(i),wim(i),wcand(i),wi2(i),wfsi(i),wdel(i)
2514 ENDIF
2515 ENDDO
2516 WRITE(iout,*)' '
2517 DEALLOCATE(iwd)
2518 WRITE(iout,*)'STATISTICS ON DECOMPOSITION WEIGHTS'
2519 WRITE(iout,*)'-----------------------------------'
2520 WRITE(iout,8000)
2521 WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2522 . ' ELEMENTS ',
2523 . nint(dmin(1)),nint(dmax(1)),
2524 . nint(average(1)),nint(deviation(1))
2525 IF(icints/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2526 . ' SECO. NODES',
2527 . nint(dmin(2)),nint(dmax(2)),
2528 . nint(average(2)),nint(deviation(2))
2529 IF(icintm/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2530 . ' MAIN NODES',
2531 . nint(dmin(11)),nint(dmax(11)),
2532 . nint(average(11)),nint(deviation(11))
2533 IF(iccand/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2534 . ' CONT. CAND.',
2535 . nint(dmin(4)),nint(dmax(4)),
2536 . nint(average(4)),nint(deviation(4))
2537 IF(icint2/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2538 . ' int. type2 ',
2539 . NINT(DMIN(3)),NINT(DMAX(3)),
2540 . NINT(AVERAGE(3)),NINT(DEVIATION(3))
2541 IF(ICSOL/=0) WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2542 . ' solid bar. ',
2543 . NINT(DMIN(6)),NINT(DMAX(6)),
2544 . NINT(AVERAGE(6)),NINT(DEVIATION(6))
2545 IF(ICDEL/=0) WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2546 . ' elt. del. ',
2547 . NINT(DMIN(8)),NINT(DMAX(8)),
2548 . NINT(AVERAGE(8)),NINT(DEVIATION(8))
2549 IF(ICKIN/=0) WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2550 . ' kin. cond. ',
2551 . NINT(DMIN(10)),NINT(DMAX(10)),
2552 . NINT(AVERAGE(10)),NINT(DEVIATION(10))
2553 IF(ICDDL/=0)THEN
2554 IF(ISMS==0)THEN ! Implicit
2555 WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2556 . ' dof(impl) ',
2557 . NINT(DMIN(5)),NINT(DMAX(5)),
2558 . NINT(AVERAGE(5)),NINT(DEVIATION(5))
2559 ELSE ! AMS
2560 WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2561 . ' ams matrix ',
2562 . NINT(DMIN(5)),NINT(DMAX(5)),
2563 . NINT(AVERAGE(5)),NINT(DEVIATION(5))
2564 END IF
2565 END IF
2566 IF(ICFSI/=0) WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2567 . ' ale elts. ',
2568 . NINT(DMIN(7)),NINT(DMAX(7)),
2569 . NINT(AVERAGE(7)),NINT(DEVIATION(7))
2570 IF(ICR2R/=0) WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2571 . ' r2r ',
2572 . NINT(DMIN(9)),NINT(DMAX(9)),
2573 . NINT(AVERAGE(9)),NINT(DEVIATION(9))
2574 IF(ICNOD_SMS/=0) WRITE(IOUT,'(a,i8,2x,i8,2x,i8,4x,i8)')
2575 . ' ams nodes ',
2576 . NINT(DMIN(12)),NINT(DMAX(12)),
2577 . NINT(AVERAGE(12)),NINT(DEVIATION(12))
2578 ELSE
2579C un seul element ou elements non connectes ou un seul proc
2580 DEALLOCATE(CNE)
2581 DEALLOCATE(IDDCONNECT%PDOM)
2582 DEALLOCATE(IDDCONNECT%IENTRYDOM)
2583 DO I = 1, NELEM
2584 CEP(I) = 0
2585 ENDDO
2586 ENDIF
2587 DEALLOCATE(IWKIN)
2588C
2589 1000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2590 . ' INT2 W. DOF W.')
2591 1100 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2592 . ' INT2 W. DOF W. AMS CONT ELT W')
2593 2000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2594 . ' INT2 W. KIN COND W.')
2595 3000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2596 . ' INT2 W. SOL W. KIN COND W.')
2597 4000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2598 . ' INT2 W. SOL W. ELT DEL W.',
2599 . ' KIN COND W.')
2600 5000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2601 . ' INT2 W. ELT DEL W. KIN COND W.')
2602 6000 FORMAT('#PROC ELT LAG W. SECND NOD W. MAST NOD W. CONT ELT W.',
2603 . ' INT2 W. ELT ALE W.')
2604 7000 FORMAT('#PROC ELT LAG W. SECND NOD W. MAST NOD W. CONT ELT W.',
2605 . ' INT2 W. ELT ALE W. ELT DEL W.')
2606 8000 FORMAT(' METRIC MINIMUM MAXIMUM AVERAGE',
2607 . ' STANDARD DEVIATION')
2608C
2609 RETURN
2610 END
2611!||====================================================================
2612!|| spdometis ../starter/source/spmd/domain_decomposition/grid2mat.f
2613!||--- called by ------------------------------------------------------
2614!|| lectur ../starter/source/starter/lectur.F
2615!||--- calls -----------------------------------------------------
2616!||--- uses -----------------------------------------------------
2617!|| format_mod ../starter/share/modules1/format_mod.F90
2618!||====================================================================
2619 SUBROUTINE spdometis(KXSP, IXSP, NOD2SP, CEPSP, RESERVEP,
2620 . SPH2SOL, CEP)
2621
2622 USE format_mod , ONLY : fmw_a_i
2623C-----------------------------------------------
2624C I m p l i c i t T y p e s
2625C-----------------------------------------------
2626#include "implicit_f.inc"
2627C-----------------------------------------------
2628C C o m m o n B l o c k s
2629C-----------------------------------------------
2630#include "units_c.inc"
2631#include "sphcom.inc"
2632#include "com01_c.inc"
2633#include "scr12_c.inc"
2634#include "scr17_c.inc"
2635C-----------------------------------------------
2636C D u m m y A r g u m e n t s
2637C-----------------------------------------------
2638 INTEGER KXSP(NISP,*), IXSP(KVOISPH,*), NOD2SP(*), CEPSP(*),
2639 . SPH2SOL(*), CEP(*)
2640C-----------------------------------------------
2641C L o c a l V a r i a b l e s
2642C-----------------------------------------------
2643 INTEGER NEDGES, CC, N, N1, N2, NI, I, J, ADDX,
2644 . NUMSPHA, P, NCOND, NNODE, NEC, IERR1, MODE, NOD1, NOD2,
2645 . IWFLG, NFLAG, NEWEDGE
2646 INTEGER(kind=8) :: IW
2647 INTEGER IWD(NUMSPH), RESERVEP(NBPARTINLET),
2648 . WORK(70000), OPTIONS(40), CEPSL(NUMSPH)
2649 INTEGER, DIMENSION(:),ALLOCATABLE :: IEND, XADJ, ADJNCY,
2650 . ITRIM,INDEXM, EDGE
2651 REAL UBVEC(15)
2652C metis5 null pointers
2653 INTEGER, POINTER :: adjwgt(:)=>null(),vsize(:)=>null()
2654 REAL, POINTER :: tpwgts(:)=>null()
2655 INTEGER METIS_PartGraphKway, METIS_PartGraphRecursive,
2656 . metis_setdefaultoptions,wrap_metis_partgraphkway,
2657 . wrap_metis_partgraphrecursive
2658C-----------------------------------------------
2659C E x t e r n a l F u n c t i o n s
2660C-----------------------------------------------
2661 EXTERNAL metis_partgraphkway, metis_partgraphrecursive,
2662 . metis_setdefaultoptions,wrap_metis_partgraphkway,
2663 . wrap_metis_partgraphrecursive
2664C-----------------------------------------------
2665C S o u r c e L i n e s
2666C-----------------------------------------------
2667C
2668C Connectivite cellules SPH
2669C
2670c NUMSPH ACTIVE less SPH2SOL/=0
2671 numspha = numsph - nsphres - nsphsol
2672
2673 nedges = 0
2674 DO n = 1, numspha
2675 DO cc = 1, min(12,kxsp(4,n))
2676 n2 = nod2sp(ixsp(cc,n))
2677 IF (n/=n2)THEN
2678 IF ((n2 < first_sphsol .OR. n2 >= first_sphsol+nsphsol)) THEN
2679 nedges = nedges + 1
2680 END IF
2681 ENDIF
2682 END DO
2683 END DO
2684C
2685
2686 IF (nedges>0) THEN
2687 ALLOCATE(iend(2*nedges))
2688 ni = 0
2689 DO n = 1, numspha
2690 DO cc = 1, min(12,kxsp(4,n))
2691 n2 = nod2sp(ixsp(cc,n))
2692 IF (n/=n2)THEN
2693 IF((n2 < first_sphsol .OR. n2 >= first_sphsol+nsphsol)) THEN
2694 IF ( n < n2 ) THEN
2695 ni = ni + 1
2696 iend(2*ni-1)=n
2697 iend(2*ni)=n2
2698 ELSE
2699 ni = ni + 1
2700 iend(2*ni-1)=n2
2701 iend(2*ni)=n
2702 END IF
2703 END IF
2704 ENDIF
2705 END DO
2706 END DO
2707C
2708C METIS ADDITIONAL TREATMENT
2709C
2710 ALLOCATE(itrim(2*nedges),stat=ierr1)
2711 ALLOCATE(indexm(2*nedges),stat=ierr1)
2712
2713 DO i = 1, nedges
2714 itrim(2*i-1) = iend(2*i-1)
2715 itrim(2*i) = iend(2*i)
2716 indexm(i) = i
2717 ENDDO
2718 mode = 0
2719 CALL my_orders(mode,work,itrim,indexm,nedges,2)
2720
2721 DO i = 1, nedges
2722 iend(2*i-1)= itrim(2*indexm(i)-1)
2723 iend(2*i) = itrim(2*indexm(i))
2724 ENDDO
2725
2726C structures Metis 1/2
2727 ALLOCATE(xadj(numspha+1),stat=ierr1)
2728C init XADJ
2729 xadj(1:numspha+1)=0
2730C first node
2731 i = 1
2732 nod1 = iend(2*i-1)
2733 nod2 = iend(2*i)
2734 newedge = 1
2735 xadj(nod1+1)=xadj(nod1+1)+1
2736 xadj(nod2+1)=xadj(nod2+1)+1
2737 DO i = 2, nedges
2738C test to suppress duplicate entry
2739 IF (nod1/=iend(2*i-1).OR.nod2/=iend(2*i)) THEN
2740 newedge = newedge + 1
2741 iend(2*newedge-1) = iend(2*i-1)
2742 iend(2*newedge) = iend(2*i)
2743 nod1 = iend(2*i-1)
2744 nod2 = iend(2*i)
2745C count xadj
2746 xadj(nod1+1)=xadj(nod1+1)+1
2747 xadj(nod2+1)=xadj(nod2+1)+1
2748 ENDIF
2749 ENDDO
2750
2751 DEALLOCATE(itrim)
2752 DEALLOCATE(indexm)
2753C
2754 nedges = newedge
2755
2756C structures Metis 2/2
2757 ALLOCATE(adjncy(2*nedges),stat=ierr1)
2758
2759C build xadj & adjcny in a simple pass
2760
2761C compute XADJ addresses
2762 xadj(1)=1
2763 DO i=1,numspha
2764 xadj(i+1)=xadj(i+1)+xadj(i)
2765 END DO
2766C fill adjncy
2767 DO i=1,nedges
2768 nod1=iend(2*i-1)
2769 nod2=iend(2*i)
2770 addx=xadj(nod1)
2771 adjncy(addx)=nod2
2772 xadj(nod1)=xadj(nod1)+1
2773 addx=xadj(nod2)
2774 adjncy(addx)=nod1
2775 xadj(nod2)=xadj(nod2)+1
2776 END DO
2777C reset XADJ
2778 DO i=numspha+1,2,-1
2779 xadj(i)=xadj(i-1)
2780 END DO
2781 xadj(1)=1
2782 DEALLOCATE(iend)
2783 ENDIF
2784C----------------------
2785C
2786C Initialize uniform weights
2787c init for every SPH cells
2788C
2789 DO n = 1, numspha
2790 iwd(n) = 1
2791 END DO
2792C
2793 iwflg=2
2794 nflag=1
2795C old metis option kept for compatibility
2796 options(1)=0
2797 ncond=1
2798 nnode=nspmd
2799 ubvec(1)=1.01 ! tolerance on loadbalancing SPH cell
2800C new Metis5 Definition
2801 ierr1 = metis_setdefaultoptions(options)
2802C OPTIONS(METIS_OPTION_NUMBERING) = 1 ! Fortran numbering -- position 17 en 5.0.2 et 18 en 5.1
2803 options(18)=1
2804C
2805C Proc attribution on NUMSPA cells
2806C
2807 IF (nedges > 0 .AND. nspmd > 1) THEN
2808C KWAY METIS
2809 IF(dectyp==3.OR.dectyp==5)THEN
2810 ierr1 = wrap_metis_partgraphkway(
2811 1 numspha,ncond,xadj,adjncy,
2812 2 iwd,nnode,
2813 3 ubvec,options,nec,cepsl)
2814 ELSEIF(dectyp==4.OR.dectyp==6)THEN
2815C RSB METIS
2816 ierr1 = wrap_metis_partgraphrecursive(
2817 1 numspha,ncond,xadj,adjncy,
2818 2 iwd,nnode,
2819 3 ubvec,options,nec,cepsl)
2820 END IF
2821C
2822 DO n = 1, numspha
2823 cepsp(n) = cepsl(n)-1
2824 END DO
2825 DEALLOCATE(xadj,adjncy)
2826 ELSE IF (nspmd == 1) THEN
2827 DO n = 1, numspha
2828 cepsp(n) = 0
2829 END DO
2830 ELSE
2831C Could be improved by geometric domain decomposition
2832 DO n = 1, numspha
2833 cepsp(n) = int( (dble(n-1)/dble(numspha))*dble(nspmd) )
2834 cepsp(n) = max(0,min(cepsp(n),nspmd-1))
2835 END DO
2836 END IF
2837
2838C Repartition by part
2839C for each part, KRESERV was saved, we put KRESERV RESERVE by proc by part
2840 n = first_sphres
2841
2842 DO i = 1, nbpartinlet
2843 DO p = 0, nspmd-1
2844 DO j = 1, reservep(i)
2845 cepsp(n) = p
2846 n = n+1
2847 ENDDO
2848 ENDDO
2849 ENDDO
2850C
2851C SPH generated from solids are enforced on the same proc as the solid
2852 DO n = first_sphsol, first_sphsol+nsphsol-1
2853 cepsp(n) = cep(sph2sol(n))
2854 END DO
2855C
2856 WRITE(iout,'(A)')' '
2857 IF(dectyp==3.OR.dectyp==5)THEN
2858 WRITE(iout,'(A)')
2859 . ' SPH DOMAIN DECOMPOSITION USING MULTILEVEL KWAY'
2860 ELSEIF(dectyp==4.OR.dectyp==6)THEN
2861 WRITE(iout,'(A)')
2862 . ' SPH DOMAIN DECOMPOSITION USING MULTILEVEL RSB'
2863 END IF
2864 WRITE(iout,*)' '
2865 WRITE(iout,fmt=fmw_a_i)
2866 . ' CELLS NUMBER = ',numsph
2867 WRITE(iout,fmt=fmw_a_i)
2868 . ' EDGES FOUND = ',nedges
2869 WRITE(iout,*)' '
2870 WRITE(iout,*)'#PROC ELT WEIGHT'
2871 DO i = 1, nspmd
2872 iw = 0
2873 DO j = 1, numsph
2874 IF (cepsp(j)+1==i .AND. iwd(j) > 0) THEN
2875 iw = iw + iwd(j)
2876 ENDIF
2877 ENDDO
2878 WRITE(iout,'(I4,I8)')i,iw
2879 END DO
2880 WRITE(iout,*)' '
2881C
2882 RETURN
2883 END
2884
2885!||====================================================================
2886!|| interlagran ../starter/source/spmd/domain_decomposition/grid2mat.F
2887!||--- called by ------------------------------------------------------
2888!|| initwg_shell ../starter/source/spmd/domain_decomposition/initwg_shell.F
2889!|| initwg_tri ../starter/source/spmd/domain_decomposition/initwg_tri.F
2890!||====================================================================
2891 SUBROUTINE interlagran(TAB,LX,LTAB,X,Y)
2892C-----------------------------------------------
2893C I m p l i c i t T y p e s
2894C-----------------------------------------------
2895#include "implicit_f.inc"
2896C-----------------------------------------------
2897C D u m m y A r g u m e n t s
2898C-----------------------------------------------
2899 REAL TAB(LTAB),LX(LTAB),X,Y
2900 INTEGER LTAB
2901C-----------------------------------------------
2902C L o c a l V a r i a b l e s
2903C-----------------------------------------------
2904 INTEGER I,J
2905 REAL MUL,ALPHA
2906 Y = 0
2907
2908 if (x<=10)THEN
2909
2910 DO i=1,ltab
2911
2912 mul = 1.
2913 DO j=1,ltab
2914 IF (i/=j) THEN
2915 mul= mul * (x-lx(j))/(lx(i)-lx(j))
2916 ENDIF
2917 ENDDO
2918
2919 y = y + tab(i)*mul
2920
2921 ENDDO
2922 ENDIF
2923 IF(x>10.or.y<=0)THEN
2924 alpha = (tab(3)-tab(1))/(lx(3)-lx(1))
2925 y = x*alpha + tab(3)-alpha*lx(3)
2926 ENDIF
2927 END
2928C
2929!||====================================================================
2930!|| i2wcontdd ../starter/source/spmd/domain_decomposition/grid2mat.F
2931!||--- called by ------------------------------------------------------
2932!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
2933!||====================================================================
2934 SUBROUTINE i2wcontdd(NSV,MSR,NSN,NMN,IWCONT,NSNT,NMNT)
2935C-----------------------------------------------
2936C I m p l i c i t T y p e s
2937C-----------------------------------------------
2938#include "implicit_f.inc"
2939C-----------------------------------------------
2940C D u m m y A r g u m e n t s
2941C-----------------------------------------------
2942 INTEGER NSV(*), MSR(*), IWCONT(2,*), NSN, NMN, NSNT, NMNT
2943 INTEGER :: COST
2944C-----------------------------------------------
2945C L o c a l V a r i a b l e s
2946C-----------------------------------------------
2947 INTEGER I, N
2948C-----------------------------------------------
2949 DO I = 1, nsn
2950 n = nsv(i)
2951 iwcont(1,n) = iwcont(1,n)+1
2952 nsnt = nsnt + 1
2953 ENDDO
2954C
2955 DO i = 1, nmn
2956 n = msr(i)
2957C IWCONT(1,N) = IWCONT(1,N)+1
2958 iwcont(2,n) = iwcont(2,n)+1
2959 nmnt = nmnt + 1
2960 ENDDO
2961C
2962 RETURN
2963 END
2964!||====================================================================
2965!|| iwcontdd_new ../starter/source/spmd/domain_decomposition/grid2mat.F
2966!||--- called by ------------------------------------------------------
2967!|| inintr ../starter/source/interfaces/interf1/inintr.F
2968!||====================================================================
2969 SUBROUTINE iwcontdd_new(NSV,MSR,NSN,NMN,IWCONT,COST)
2970C-----------------------------------------------
2971C I m p l i c i t T y p e s
2972C-----------------------------------------------
2973#include "implicit_f.inc"
2974C-----------------------------------------------
2975C D u m m y A r g u m e n t s
2976C-----------------------------------------------
2977 INTEGER NSV(*), MSR(*), IWCONT(5,*), NSN, NMN
2978 INTEGER :: COST
2979C-----------------------------------------------
2980C L o c a l V a r i a b l e s
2981C-----------------------------------------------
2982 INTEGER I, N
2983C-----------------------------------------------
2984 DO I = 1, nsn
2985 n = nsv(i)
2986 iwcont(3,n) = iwcont(3,n)+cost
2987 ENDDO
2988C
2989 DO i = 1, nmn
2990 n = msr(i)
2991 iwcont(4,n) = iwcont(4,n)+cost
2992 ENDDO
2993C
2994 RETURN
2995 END
2996
2997!||====================================================================
2998!|| iwcontdd ../starter/source/spmd/domain_decomposition/grid2mat.F
2999!||--- called by ------------------------------------------------------
3000!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
3001!||====================================================================
3002 SUBROUTINE iwcontdd(NSV,MSR,NSN,NMN,IWCONT,NSNT,NMNT)
3003C-----------------------------------------------
3004C I m p l i c i t T y p e s
3005C-----------------------------------------------
3006#include "implicit_f.inc"
3007C-----------------------------------------------
3008C D u m m y A r g u m e n t s
3009C-----------------------------------------------
3010 INTEGER NSV(*), MSR(*), IWCONT(5,*), NSN, NMN, NSNT, NMNT
3011C-----------------------------------------------
3012C L o c a l V a r i a b l e s
3013C-----------------------------------------------
3014 INTEGER I, N
3015C-----------------------------------------------
3016 DO I = 1, nsn
3017 n = nsv(i)
3018 iwcont(1,n) = iwcont(1,n)+1
3019 nsnt = nsnt + 1
3020 ENDDO
3021C
3022 DO i = 1, nmn
3023 n = msr(i)
3024C IWCONT(1,N) = IWCONT(1,N)+1
3025 iwcont(2,n) = iwcont(2,n)+1
3026 nmnt = nmnt + 1
3027 ENDDO
3028C
3029 RETURN
3030 END
3031
3032
3033
3034!||====================================================================
3035!|| iwcontdd_151 ../starter/source/spmd/domain_decomposition/grid2mat.F
3036!||--- called by ------------------------------------------------------
3037!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
3038!||====================================================================
3039 SUBROUTINE iwcontdd_151(BUFBRIC,NBRIC,MSR,NMN,IWCONT,NSNT,NMNT,NUMNOD,IXS,NUMELS,NALE)
3040C-----------------------------------------------
3041C D e s c r i p t i o n
3042C-----------------------------------------------
3043C Equivalent treatment than IWCONTDD() BUT FOR SPECIFIC CASE OF INTER18+LAW151 (COLLOCATED SCHEME)
3044C-----------------------------------------------
3045C I m p l i c i t T y p e s
3046C-----------------------------------------------
3047#include "implicit_f.inc"
3048C-----------------------------------------------
3049C D u m m y A r g u m e n t s
3050C-----------------------------------------------
3051 INTEGER,INTENT(IN) :: NMN, NUMNOD,NUMELS
3052 INTEGER,INTENT(IN) :: MSR(NMN),IXS(NIXS,NUMELS),NALE(NUMNOD)
3053 INTEGER,INTENT(INOUT) :: IWCONT(5,NUMNOD),NSNT, NMNT
3054 INTEGER,INTENT(IN) :: NBRIC
3055 INTEGER,INTENT(IN) :: BUFBRIC(NBRIC)
3056C-----------------------------------------------
3057C L o c a l V a r i a b l e s
3058C-----------------------------------------------
3059 INTEGER I, N, IELEM, INOD, J
3060C-----------------------------------------------
3061
3062 DO I = 1, nbric
3063 ielem = bufbric(i)
3064 DO j=2,9
3065 inod = ixs(j,ielem)
3066 IF(nale(inod) /= 0 .AND. inod > 0)THEN
3067 iwcont(1,inod) = iwcont(1,inod)+1
3068 nsnt = nsnt + 1
3069 endif!NALE(node_i)==0 <=> lagrangian node_i
3070 ENDDO
3071 ENDDO
3072
3073 DO i = 1, nmn
3074 n = msr(i)
3075 iwcont(2,n) = iwcont(2,n)+1
3076 nmnt = nmnt + 1
3077 ENDDO
3078C
3079 RETURN
3080 END
3081
3082C
3083!||====================================================================
3084!|| i20wcontdd ../starter/source/spmd/domain_decomposition/grid2mat.F
3085!||--- called by ------------------------------------------------------
3086!|| i20ini3 ../starter/source/interfaces/inter3d1/i20ini3.F
3087!||====================================================================
3088 SUBROUTINE i20wcontdd(NSV,MSR,NSN,NMN,IWCONT,NSNT,NMNT)
3089C-----------------------------------------------
3090C I m p l i c i t T y p e s
3091C-----------------------------------------------
3092#include "implicit_f.inc"
3093C-----------------------------------------------
3094C D u m m y A r g u m e n t s
3095C-----------------------------------------------
3096 INTEGER NSV(*), MSR(*), IWCONT(5,*), NSN, NMN, NSNT, NMNT
3097C-----------------------------------------------
3098C L o c a l V a r i a b l e s
3099C-----------------------------------------------
3100 INTEGER I, N
3101C-----------------------------------------------
3102 DO I = 1, nsn
3103 n = nsv(i)
3104 iwcont(1,n) = iwcont(1,n)+2
3105 nsnt = nsnt + 1
3106 ENDDO
3107C
3108 DO i = 1, nmn
3109 n = msr(i)
3110C IWCONT(1,N) = IWCONT(1,N)+2
3111 iwcont(2,n) = iwcont(2,n)+2
3112 nmnt = nmnt + 1
3113 ENDDO
3114C
3115 RETURN
3116 END
3117!||====================================================================
3118!|| dd_bfs ../starter/source/spmd/domain_decomposition/grid2mat.F
3119!||--- called by ------------------------------------------------------
3120!|| dometis ../starter/source/spmd/domain_decomposition/grid2mat.F
3121!||====================================================================
3122 SUBROUTINE dd_bfs(XADJ,ADJNCY,NELEM,NEDGES,NCONNX,COLORS,ROOTS)
3123C-----------------------------------------------
3124C I m p l i c i t T y p e s
3125C-----------------------------------------------
3126#include "implicit_f.inc"
3127C-----------------------------------------------
3128C D u m m y A r g u m e n t s
3129C-----------------------------------------------
3130 INTEGER NELEM, NEDGES, NCONNX,
3131 . xadj(nelem+1), adjncy(2*nedges),
3132 . colors(nelem), roots(nelem)
3133C-----------------------------------------------
3134C L o c a l V a r i a b l e s
3135C-----------------------------------------------
3136 INTEGER NVISIT, N, I
3137 INTEGER FILE_NEXT, ROOT, CURRENT
3138 INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_V
3139C-----------------------------------------------
3140 ALLOCATE(file_v(nelem))
3141 DO n = 1, nelem
3142 colors(n)=0
3143 END DO
3144 nvisit=0
3145 root=1 ! first element of the graph == first vertex available
3146 nconnx=0
3147
3148 DO WHILE (nvisit < nelem) ! loop until all vertices are visited
3149 nconnx = nconnx+1
3150 DO WHILE ((root <= nelem) .AND. (colors(root) /= 0))
3151 root = root + 1
3152 END DO
3153c IF (ROOT > NELEM) THEN
3154c print*,'** FATAL ERROR DURING BFS'
3155c NCONNX=-1
3156c EXIT
3157c END IF
3158 roots(nconnx)=root ! record roots for fatest treatments
3159 file_v(1)=root
3160 file_next=2 ! new file initialized with root
3161 colors(root)=nconnx ! root marked
3162 nvisit=nvisit+1
3163 DO WHILE (file_next > 1) ! test file not nill
3164 current = file_v(file_next-1)
3165 file_next = file_next-1
3166 DO n = xadj(current), xadj(current+1)-1
3167 i = adjncy(n)
3168 IF(colors(i) == 0) THEN ! vertex not treated before
3169 file_v(file_next)=i
3170 file_next = file_next+1
3171 colors(i) = nconnx
3172 nvisit=nvisit+1
3173 END IF
3174 END DO
3175 END DO
3176 END DO
3177 DEALLOCATE(file_v)
3178 RETURN
3179 END
3180
3181!||====================================================================
3182!|| prelec_ddw ../starter/source/spmd/domain_decomposition/grid2mat.F
3183!||--- called by ------------------------------------------------------
3184!|| lectur ../starter/source/starter/lectur.F
3185!||--- uses -----------------------------------------------------
3186!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
3187!||====================================================================
3188 SUBROUTINE prelec_ddw(FILNAM,LEN_FILNAM,MARQUEUR3)
3189C-----------------------------------------------
3190C M o d u l e s
3191C-----------------------------------------------
3192 USE reader_old_mod , ONLY : line
3193C-----------------------------------------------
3194C I m p l i c i t T y p e s
3195C-----------------------------------------------
3196#include "implicit_f.inc"
3197C-----------------------------------------------
3198C C o m m o n B l o c k s
3199C-----------------------------------------------
3200#include "com01_c.inc"
3201#include "param_c.inc"
3202#include "scr15_c.inc"
3203#include "scr17_c.inc"
3204C-----------------------------------------------
3205C D u m m y A r g u m e n t s
3206C-----------------------------------------------
3207 LOGICAL MARQUEUR3
3208C Dynamical User Library
3209 CHARACTER FILNAM*512
3210 INTEGER LEN_FILNAM
3211C-----------------------------------------------
3212C L o c a l V a r i a b l e s
3213C-----------------------------------------------
3214 INTEGER MARQUEUR,MARQUEUR2
3215C-----------------------------------------------
3216 FILNAM =rootnam(1:rootlen)//'_0001.ddw'
3217 len_filnam=len_trim(filnam)
3218 line=' '
3219 marqueur2 = 0
3220 test_poids = 0
3221 INQUIRE(file=filnam(1:len_filnam), exist=marqueur3)
3222
3223 IF(marqueur3) THEN
3224 test_poids = 1
3225C Nombre de lignes
3226 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED')
3227 DO WHILE(line(1:12) /= ' POINTER')
3228 marqueur2=marqueur2+1
3229 READ(30,fmt='(A)')line
3230 ENDDO
3231 CLOSE(unit=30)
3232 marqueur2 = marqueur2 - 3
3233
3234 marqueur = 0
3235C Pre-reading of Mat/Prop coupled weights
3236 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED',
3237 . position='REWIND')
3238 line = ' '
3239 DO WHILE(line(1:12) /= ' LAW_NUMB')
3240 marqueur=marqueur+1
3241 READ(30,fmt='(A)')line
3242 ENDDO
3243 CLOSE(unit=30)
3244 marqueur = marqueur + 1
3245 taille_old= marqueur2 - marqueur
3246 ELSE
3247 nummat_old = 0
3248 numgeo_old = 0
3249 taille_old = 0
3250 ENDIF
3251 RETURN
3252 END
3253!||====================================================================
3254!|| lec_ddw ../starter/source/spmd/domain_decomposition/grid2mat.F
3255!||--- called by ------------------------------------------------------
3256!|| lectur ../starter/source/starter/lectur.F
3257!||--- uses -----------------------------------------------------
3258!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
3259!||====================================================================
3260 SUBROUTINE lec_ddw(FILNAM,LEN_FILNAM,TAB_UMP_OLD,CPUTIME_MP_OLD)
3261C-----------------------------------------------
3262C M o d u l e s
3263C-----------------------------------------------
3264 USE reader_old_mod , ONLY : line
3265C-----------------------------------------------
3266C I m p l i c i t T y p e s
3267C-----------------------------------------------
3268#include "implicit_f.inc"
3269C-----------------------------------------------
3270C C o m m o n B l o c k s
3271C-----------------------------------------------
3272#include "param_c.inc"
3273#include "scr17_c.inc"
3274C-----------------------------------------------
3275C D u m m y A r g u m e n t s
3276C-----------------------------------------------
3277 INTEGER, DIMENSION(7,TAILLE_OLD) :: TAB_UMP_OLD
3278 my_real, DIMENSION(TAILLE_OLD) :: cputime_mp_old
3279C Dynamical User Library
3280 CHARACTER FILNAM*512
3281 INTEGER LEN_FILNAM
3282C-----------------------------------------------
3283C L o c a l V a r i a b l e s
3284C-----------------------------------------------
3285 INTEGER J
3286C-----------------------------------------------
3287C Reading of Mat/Prop coupled weights
3288 OPEN(UNIT=30,file=filnam(1:len_filnam),form='FORMATTED')
3289 line = ' '
3290 DO WHILE(line(1:12) /= ' LAW_NUMB')
3291 READ(30,fmt='(A)')line
3292 ENDDO
3293 DO j=1,taille_old
3294 READ(30,'(I12,A,I12,A,I12,A,
3295 . I12,A,I12,A,I12,A,
3296 . I12,A,E15.5)')
3297 . tab_ump_old(6,j),line(1:2),tab_ump_old(7,j),line(1:2),tab_ump_old(5,j),line(1:2),
3298 . tab_ump_old(3,j),line(1:2),tab_ump_old(1,j),line(1:2),tab_ump_old(4,j),line(1:2),
3299 . tab_ump_old(2,j),line(1:2),cputime_mp_old(j)
3300
3301 ENDDO
3302 CLOSE(unit=30)
3303 RETURN
3304 END
3305!||====================================================================
3306!|| prelec_ddw_poin ../starter/source/spmd/domain_decomposition/grid2mat.F
3307!||--- called by ------------------------------------------------------
3308!|| lectur ../starter/source/starter/lectur.F
3309!||--- uses -----------------------------------------------------
3310!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
3311!||====================================================================
3312 SUBROUTINE prelec_ddw_poin(FILNAM,LEN_FILNAM)
3313C-----------------------------------------------
3314C M o d u l e s
3315C-----------------------------------------------
3316 USE reader_old_mod , ONLY : line
3317C-----------------------------------------------
3318C I m p l i c i t T y p e s
3319C-----------------------------------------------
3320#include "implicit_f.inc"
3321C-----------------------------------------------
3322C C o m m o n B l o c k s
3323C-----------------------------------------------
3324#include "param_c.inc"
3325#include "scr17_c.inc"
3326C-----------------------------------------------
3327C D u m m y A r g u m e n t s
3328C-----------------------------------------------
3329C Dynamical User Library
3330 CHARACTER FILNAM*512
3331 INTEGER LEN_FILNAM
3332C-----------------------------------------------
3333C L o c a l V a r i a b l e s
3334C-----------------------------------------------
3335C Lecture du pointer
3336 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED')
3337 line = ' '
3338 DO WHILE(line(1:12) /= ' POINTER')
3339 READ(30,fmt='(A)')line
3340 ENDDO
3341 READ(30,'(A,I10)') line(1:47),nummat_old
3342 READ(30,'(A,I10)') line(1:47),numgeo_old
3343 CLOSE(unit=30)
3344 RETURN
3345 END
3346!||====================================================================
3347!|| lec_ddw_poin ../starter/source/spmd/domain_decomposition/grid2mat.F
3348!||--- called by ------------------------------------------------------
3349!|| lectur ../starter/source/starter/lectur.F
3350!||--- uses -----------------------------------------------------
3351!|| reader_old_mod ../starter/share/modules1/reader_old_mod.F90
3352!||====================================================================
3353 SUBROUTINE lec_ddw_poin(FILNAM,LEN_FILNAM,POIN_UMP_OLD)
3354C-----------------------------------------------
3355C M o d u l e s
3356C-----------------------------------------------
3357 USE reader_old_mod , ONLY : line
3358C-----------------------------------------------
3359C I m p l i c i t T y p e s
3360C-----------------------------------------------
3361#include "implicit_f.inc"
3362C-----------------------------------------------
3363C C o m m o n B l o c k s
3364C-----------------------------------------------
3365#include "param_c.inc"
3366#include "scr17_c.inc"
3367C-----------------------------------------------
3368C D u m m y A r g u m e n t s
3369C-----------------------------------------------
3370C Dynamical User Library
3371 CHARACTER FILNAM*512
3372 INTEGER LEN_FILNAM
3373 INTEGER, DIMENSION(NUMMAT_OLD) :: POIN_UMP_OLD
3374C-----------------------------------------------
3375C L o c a l V a r i a b l e s
3376C-----------------------------------------------
3377 INTEGER I
3378C-----------------------------------------------
3379C Lecture du pointer
3380 OPEN(UNIT=30,file=filnam(1:len_filnam),form='FORMATTED')
3381 line = ' '
3382 DO WHILE(line(1:12) /= ' POINTER')
3383 READ(30,fmt='(A)')line
3384 ENDDO
3385 READ(30,'(A,I10)') line(1:47),nummat_old
3386 READ(30,'(A,I10)') line(1:47),numgeo_old
3387 DO i=1,nummat_old
3388 READ(30,'(I8)') poin_ump_old(i)
3389 ENDDO
3390 CLOSE(unit=30)
3391 RETURN
3392 END
3393!||====================================================================
3394!|| reini_matprop ../starter/source/spmd/domain_decomposition/grid2mat.F
3395!||--- called by ------------------------------------------------------
3396!|| lectur ../starter/source/starter/lectur.F
3397!||====================================================================
3398 SUBROUTINE reini_matprop(TAILLE,TAILLE2,TAB_UMP_LOC,TAB_UMP_LOC2,
3399 . IXS,IXQ,IXC,IXT,IXP,IXR,IXTG,ISOLNOD,POIN_UMP)
3400C-----------------------------------------------
3401C I m p l i c i t T y p e s
3402C-----------------------------------------------
3403#include "implicit_f.inc"
3404C-----------------------------------------------
3405C C o m m o n B l o c k s
3406C-----------------------------------------------
3407#include "com04_c.inc"
3408C-----------------------------------------------
3409C D u m m y A r g u m e n t s
3410C-----------------------------------------------
3411 INTEGER TAILLE,TAILLE2
3412 INTEGER, DIMENSION(NUMMAT) :: POIN_UMP
3413 INTEGER, DIMENSION(7+6,TAILLE2,2) :: TAB_UMP_LOC2
3414 INTEGER, DIMENSION(5,NPART) :: TAB_UMP_LOC
3415 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),
3416 . IXP(NIXP,*),IXR(NIXR,*),IXTG(NIXTG,*),ISOLNOD(*)
3417C-----------------------------------------------
3418C L o c a l V a r i a b l e s
3419C-----------------------------------------------
3420 INTEGER MARQUEUR,K1,K2,K3,K4,
3421 . I,J,ITY,TEST
3422C-----------------------------------------------
3423 TAB_UMP_LOC2 = 0
3424 if(numels>0) THEN
3425 ity = 1
3426 DO i=1,numels
3427 k1 = ixs(1,i)
3428 k2 = ixs(10,i)
3429 k3 = poin_ump(k1)! + POIN_UMP(NUMMAT+K2)
3430 marqueur = isolnod(i)
3431 k4 = 0
3432 IF(marqueur==4) THEN
3433 k4 = 1
3434 ELSEIF(marqueur==6) THEN
3435 k4 = 2
3436 ELSEIF(marqueur==8) THEN
3437 k4 = 3
3438 ELSEIF(marqueur==10) THEN
3439 k4 = 4
3440 ELSEIF(marqueur==16) THEN
3441 k4 = 5
3442 ELSEIF(marqueur==20) THEN
3443 k4 = 6
3444 ENDIF
3445C
3446 IF(k3/=0) THEN
3447 test=0
3448 DO WHILE((k3<=taille2).AND.(test==0))
3449 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3450 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3451 tab_ump_loc2(ity+k4,k3,2) = 1
3452 test=1
3453 ELSE
3454 k3=k3+1
3455 ENDIF
3456 ENDDO
3457 ENDIF
3458 ENDDO
3459 ENDIF
3460
3461! stop
3462 IF(numelq>0) THEN
3463 k4 = 6
3464 ity = 2
3465 DO i =1,numelq
3466 k1 = ixq(1,i)
3467 k2 = ixq(6,i)
3468 k3 = 1!POIN_UMP(K1) !+ POIN_UMP(NUMMAT+K2)
3469 IF(k3/=0) THEN
3470 test=0
3471 DO WHILE((k3<=taille2).AND.(test==0))
3472 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3473 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3474 tab_ump_loc2(ity+k4,k3,2) = 1
3475 test=1
3476 ELSE
3477 k3=k3+1
3478 ENDIF
3479 ENDDO
3480 ENDIF
3481 ENDDO
3482 ENDIF
3483 IF(numelc>0) THEN
3484 k4 = 6
3485 ity = 3
3486 DO i=1,numelc
3487 k1 = ixc(1,i)
3488 k2 = ixc(6,i)
3489 k3 = poin_ump(k1)! + POIN_UMP(NUMMAT+K2)
3490 IF(k3/=0) THEN
3491 test=0
3492 DO WHILE((k3<=taille2).AND.(test==0))
3493 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3494 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3495 tab_ump_loc2(ity+k4,k3,2) = 1
3496 test=1
3497 ELSE
3498 k3=k3+1
3499 ENDIF
3500 ENDDO
3501 ENDIF
3502 ENDDO
3503 ENDIF
3504 IF(numelt>0) THEN
3505 k4 = 6
3506 ity = 4
3507 DO i=1,numelt
3508 k1 = ixt(1,i)
3509 k2 = ixt(4,i)
3510 k3 = poin_ump(k1)! + POIN_UMP(NUMMAT+K2)
3511 IF(k3/=0) THEN
3512 test=0
3513 DO WHILE((k3<=taille2).AND.(test==0))
3514 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3515 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3516 tab_ump_loc2(ity+k4,k3,2) = 1
3517 test=1
3518 ELSE
3519 k3=k3+1
3520 ENDIF
3521 ENDDO
3522 ENDIF
3523 ENDDO
3524 ENDIF
3525 IF(numelp>0) THEN
3526 k4 = 6
3527 ity = 5
3528 DO i=1,numelp
3529 k1 = ixp(1,i)
3530 k2 = ixp(5,i)
3531 k3 = 1!POIN_UMP(K1)! + POIN_UMP(NUMMAT+K2)
3532 IF(k3/=0) THEN
3533 test=0
3534 DO WHILE((k3<=taille2).AND.(test==0))
3535 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3536 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3537 tab_ump_loc2(ity+k4,k3,2) = 1
3538 test=1
3539 ELSE
3540 k3=k3+1
3541 ENDIF
3542 ENDDO
3543 ENDIF
3544 ENDDO
3545 ENDIF
3546 IF(numelr>0) THEN
3547 k4 = 6
3548 k1 = 0
3549 ity = 6
3550 DO i=1,numelr
3551 k2 = ixr(1,i)
3552 k3 = k1 + 1
3553 IF(k3/=0) THEN
3554 test=0
3555 DO WHILE((k3<=taille2).AND.(test==0))
3556 IF((tab_ump_loc(1,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3557 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3558 tab_ump_loc2(ity+k4,k3,2) = 1
3559 test=1
3560 ELSE
3561 k3=k3+1
3562 ENDIF
3563 ENDDO
3564 ENDIF
3565 ENDDO
3566 ENDIF
3567 IF(numeltg>0) THEN
3568 k4 = 6
3569 ity = 7
3570 DO i=1,numeltg
3571 k1 = ixtg(1,i)
3572 k2 = ixtg(5,i)
3573 k3 = 1!POIN_UMP(K1) !+ POIN_UMP(NUMMAT+K2)
3574 IF(k3/=0) THEN
3575 test=0
3576 DO WHILE((k3<=taille2).AND.(test==0))
3577 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3578 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3579 tab_ump_loc2(ity+k4,k3,2) = 1
3580 test=1
3581 ELSE
3582 k3=k3+1
3583 ENDIF
3584 ENDDO
3585 ENDIF
3586 ENDDO
3587 ENDIF
3588
3589 taille = 0
3590 DO j=1,taille2
3591 marqueur = 0
3592 DO i=1,13
3593 IF(tab_ump_loc2(i,j,2)>0) THEN
3594 marqueur = marqueur + 1
3595 ENDIF
3596 ENDDO
3597 taille = taille + marqueur
3598 ENDDO
3599
3600 RETURN
3601 END
3602
3603!||====================================================================
3604!|| reini_matprop2 ../starter/source/spmd/domain_decomposition/grid2mat.f
3605!||--- called by ------------------------------------------------------
3606!|| lectur ../starter/source/starter/lectur.F
3607!||====================================================================
3608 SUBROUTINE reini_matprop2(TAILLE,TAILLE2,
3609 . TAB_UMP_LOC,TAB_UMP_LOC2,TAB_UMP,TAB_SOL,
3610 . POIN_UMP)
3611C-----------------------------------------------
3612C I m p l i c i t T y p e s
3613C-----------------------------------------------
3614#include "implicit_f.inc"
3615C-----------------------------------------------
3616C C o m m o n B l o c k s
3617C-----------------------------------------------
3618#include "com04_c.inc"
3619C-----------------------------------------------
3620C D u m m y A r g u m e n t s
3621C-----------------------------------------------
3622 INTEGER TAILLE,TAILLE2,MARQUEUR2
3623 INTEGER, DIMENSION(7+6,TAILLE2,2) :: TAB_UMP_LOC2
3624 INTEGER, DIMENSION(6) :: TAB_SOL
3625 INTEGER, DIMENSION(NUMMAT) :: POIN_UMP
3626 INTEGER, DIMENSION(7,TAILLE) :: TAB_UMP
3627 INTEGER, DIMENSION(5,NPART) :: TAB_UMP_LOC
3628C-----------------------------------------------
3629C L o c a l V a r i a b l e s
3630C-----------------------------------------------
3631 INTEGER MARQUEUR,I,J,K
3632C-----------------------------------------------
3633
3634 TAB_SOL(1) = 1004
3635 tab_sol(2) = 1006
3636 tab_sol(3) = 1008
3637 tab_sol(4) = 1010
3638 tab_sol(5) = 1016
3639 tab_sol(6) = 1020
3640 marqueur = 1
3641 DO j=1,taille2
3642 DO i=1,13
3643 IF(tab_ump_loc2(i,j,2)>0) THEN
3644 DO k=1,4
3645 tab_ump(k,marqueur) = tab_ump_loc(k,j)
3646 ENDDO
3647 tab_ump(5,marqueur) = tab_ump_loc2(i,j,1)
3648 tab_ump(6,marqueur) = tab_ump_loc(5,j)
3649 IF(i>7) THEN
3650 tab_ump(7,marqueur) = i-6
3651 ELSEIF(i==1) THEN
3652 tab_ump(7,marqueur) = i
3653 ELSE
3654 tab_ump(7,marqueur) = tab_sol(i-1)
3655 ENDIF
3656 marqueur = marqueur + 1
3657 ENDIF
3658 ENDDO
3659 ENDDO
3660
3661 poin_ump(tab_ump(3,1)) = 1
3662 DO i=2,taille
3663 IF(tab_ump(3,i-1)/=tab_ump(3,i)) THEN
3664 poin_ump(tab_ump(3,i)) = i
3665 ENDIF
3666 ENDDO
3667
3668 RETURN
3669 END
3670!||====================================================================
3671!|| stat_domdec ../starter/source/spmd/domain_decomposition/grid2mat.F
3672!||--- called by ------------------------------------------------------
3673!|| dometis ../starter/source/spmd/domain_decomposition/grid2mat.F
3674!||====================================================================
3675 SUBROUTINE stat_domdec(WIS ,WI2 ,WFSI ,WDEL ,WDDL ,
3676 2 WCAND ,WSOL ,WR2R ,WKIN ,IWD ,
3677 3 NCOND ,ICELEM ,ICINTS ,ICINT2 ,ICCAND ,
3678 4 ICDDL ,ICSOL ,ICFSI ,ICDEL ,ICR2R ,
3679 5 ICKIN ,AVERAGE ,DEVIATION ,DMAX ,DMIN ,
3680 6 CEP ,NELEM ,W ,ICINTM ,WIM ,
3681 7 NCRITMAX ,WNOD_SMS,ICNOD_SMS)
3682
3683C-----------------------------------------------
3684C I m p l i c i t T y p e s
3685C-----------------------------------------------
3686#include "implicit_f.inc"
3687C-----------------------------------------------
3688C C o m m o n B l o c k s
3689C-----------------------------------------------
3690#include "com01_c.inc"
3691C-----------------------------------------------
3692C D u m m y A r g u m e n t s
3693C-----------------------------------------------
3694 INTEGER ICKIN,ICR2R,ICDEL,ICFSI,ICSOL,ICDDL,ICCAND,
3695 . icints,icintm,icint2,ncond,nelem,icelem,ncritmax,icnod_sms,
3696 . cep(nelem),iwd(ncond*nelem)
3697 DOUBLE PRECISION AVERAGE(NCRITMAX), DEVIATION(NCRITMAX), DMIN(NCRITMAX),DMAX(NCRITMAX),
3698 . W(NSPMD), WIS(NSPMD), WI2(NSPMD), WDDL(NSPMD),
3699 . WFSI(NSPMD),WCAND(NSPMD),WSOL(NSPMD),WKIN(NSPMD),
3700 . WDEL(NSPMD), WR2R(NSPMD), WIM(NSPMD),WNOD_SMS(NSPMD)
3701
3702C-----------------------------------------------
3703C L o c a l V a r i a b l e s
3704C-----------------------------------------------
3705 INTEGER I,J
3706C----------------------------------------------
3707
3708 DO I = 1, nspmd
3709 w(i) = zero
3710 wis(i) = zero
3711 wim(i) = zero
3712 wi2(i) = zero
3713 wfsi(i) = zero
3714 wdel(i) = zero
3715 wddl(i) = zero
3716 wcand(i) = zero
3717 wsol(i) = zero
3718 wr2r(i) = zero
3719 wkin(i) = zero
3720 wnod_sms(i) = zero
3721 END DO
3722 DO j = 1, nelem
3723 i = cep(j)
3724 w(i) = w(i) + iwd(ncond*(j-1)+icelem)
3725 IF(icints/=0)wis(i) = wis(i) + iwd(ncond*(j-1)+icints)
3726 IF(icintm/=0)wim(i) = wim(i) + iwd(ncond*(j-1)+icintm)
3727 IF(icint2/=0)wi2(i) = wi2(i) + iwd(ncond*(j-1)+icint2)
3728 IF(iccand/=0)wcand(i) = wcand(i) + iwd(ncond*(j-1)+iccand)
3729 IF(icddl/=0)wddl(i) = wddl(i) + iwd(ncond*(j-1)+icddl)
3730 IF(icsol/=0)wsol(i) = wsol(i) + iwd(ncond*(j-1)+icsol)
3731 IF(icfsi/=0)wfsi(i) = wfsi(i) + iwd(ncond*(j-1)+icfsi)
3732 IF(icdel/=0)wdel(i) = wdel(i) + iwd(ncond*(j-1)+icdel)
3733 IF(icr2r/=0)wr2r(i) = wr2r(i) + iwd(ncond*(j-1)+icr2r)
3734 IF(ickin/=0)wkin(i) = wkin(i) + iwd(ncond*(j-1)+ickin)
3735 IF(icnod_sms/=0)wnod_sms(i) = wnod_sms(i) + iwd(ncond*(j-1)+icnod_sms)
3736 ENDDO
3737C
3738C compute Average and Standard deviation
3739C
3740 DO i=1,ncritmax
3741 average(i)=zero
3742 deviation(i)=zero
3743 dmax(i)=zero
3744 dmin(i)=2147483647
3745 END DO
3746 DO i = 1, nspmd
3747 average(1)=average(1)+w(i)
3748 average(2)=average(2)+wis(i)
3749 average(3)=average(3)+wi2(i)
3750 average(4)=average(4)+wcand(i)
3751 average(5)=average(5)+wddl(i)
3752 average(6)=average(6)+wsol(i)
3753 average(7)=average(7)+wfsi(i)
3754 average(8)=average(8)+wdel(i)
3755 average(9)=average(9)+wr2r(i)
3756 average(10)=average(10)+wkin(i)
3757 average(11)=average(11)+wim(i)
3758 average(12)=average(12)+wnod_sms(i)
3759 dmin(1)=min(dmin(1),w(i))
3760 dmin(2)=min(dmin(2),wis(i))
3761 dmin(3)=min(dmin(3),wi2(i))
3762 dmin(4)=min(dmin(4),wcand(i))
3763 dmin(5)=min(dmin(5),wddl(i))
3764 dmin(6)=min(dmin(6),wsol(i))
3765 dmin(7)=min(dmin(7),wfsi(i))
3766 dmin(8)=min(dmin(8),wdel(i))
3767 dmin(9)=min(dmin(9),wr2r(i))
3768 dmin(10)=min(dmin(10),wkin(i))
3769 dmin(11)=min(dmin(11),wim(i))
3770 dmin(12)=min(dmin(12),wnod_sms(i))
3771 dmax(1)=max(dmax(1),w(i))
3772 dmax(2)=max(dmax(2),wis(i))
3773 dmax(3)=max(dmax(3),wi2(i))
3774 dmax(4)=max(dmax(4),wcand(i))
3775 dmax(5)=max(dmax(5),wddl(i))
3776 dmax(6)=max(dmax(6),wsol(i))
3777 dmax(7)=max(dmax(7),wfsi(i))
3778 dmax(8)=max(dmax(8),wdel(i))
3779 dmax(9)=max(dmax(9),wr2r(i))
3780 dmax(10)=max(dmax(10),wkin(i))
3781 dmax(11)=max(dmax(11),wim(i))
3782 dmax(12)=max(dmax(12),wnod_sms(i))
3783 END DO
3784 DO i=1,ncritmax
3785 average(i)=average(i)/nspmd
3786 END DO
3787 DO i = 1, nspmd
3788 deviation(1)=deviation(1)+(w(i) -average(1))**2
3789 deviation(2)=deviation(2)+(wis(i) -average(2))**2
3790 deviation(3)=deviation(3)+(wi2(i) -average(3))**2
3791 deviation(4)=deviation(4)+(wcand(i) -average(4))**2
3792 deviation(5)=deviation(5)+(wddl(i) -average(5))**2
3793 deviation(6)=deviation(6)+(wsol(i) -average(6))**2
3794 deviation(7)=deviation(7)+(wfsi(i) -average(7))**2
3795 deviation(8)=deviation(8)+(wdel(i) -average(8))**2
3796 deviation(9)=deviation(9)+(wr2r(i) -average(9))**2
3797 deviation(10)=deviation(10)+(wkin(i)-average(10))**2
3798 deviation(11)=deviation(11)+(wim(i)-average(11))**2
3799 deviation(12)=deviation(12)+(wnod_sms(i)-average(12))**2
3800 END DO
3801 DO i=1,ncritmax
3802 deviation(i)=sqrt(deviation(i)/nspmd)
3803 END DO
3804 END
3805!||====================================================================
3806!|| find_nodes ../starter/source/spmd/domain_decomposition/grid2mat.F
3807!||--- called by ------------------------------------------------------
3808!|| dometis ../starter/source/spmd/domain_decomposition/grid2mat.F
3809!||--- uses -----------------------------------------------------
3810!|| consider_edge_mod ../starter/source/spmd/domain_decomposition/consider_edge.F
3811!||====================================================================
3812 SUBROUTINE find_nodes(ELEMN0,ELEMNODES,TAGELEM,IXS, IXS10 ,
3813 2 IXQ ,IXC ,IXT ,IXP, IXR ,
3814 3 IXTG ,KXX ,IXX, KXIG3D,
3815 4 IXIG3D,GEO ,OFFELEM,NELMIN)
3816C-----------------------------------------------
3817C M o d u l e s
3818C-----------------------------------------------
3819 USE consider_edge_mod , ONLY : max_nb_nodes_per_elt
3820C-----------------------------------------------
3821C I m p l i c i t T y p e s
3822C-----------------------------------------------
3823#include "implicit_f.inc"
3824C-----------------------------------------------
3825C C o m m o n B l o c k s
3826C-----------------------------------------------
3827#include "com04_c.inc"
3828#include "param_c.inc"
3829#include "scr23_c.inc"
3830C-----------------------------------------------
3831C D u m m y A r g u m e n t s
3832C-----------------------------------------------
3833 INTEGER IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*), IXT(NIXT,*),
3834 . ixp(nixp,*), ixr(nixr,*), ixtg(nixtg,*),
3835 . kxx(nixx,numelx),ixx(*),ixs10(6,*),kxig3d(nixig3d,numelig3d),
3836 . ixig3d(*),elemnodes(max_nb_nodes_per_elt),tagelem(*),offelem(10)
3837 INTEGER ELEMN0,NELMIN
3838 my_real GEO(NPROPG,*)
3839C----------------------------------------------
3840C L o c a l V a r i a b l e s
3841C---------------------------------------------
3842 INTEGER K,N,ADDX,NELX,J,NELIG3D,I,ELEM
3843C---------------------------------------------
3844 NELMIN = 3
3845 do i=1,max_nb_nodes_per_elt
3846 elemnodes(i)=0
3847 ENDDO
3848
3849 elem = elemn0
3850 SELECT CASE(tagelem(elem))
3851
3852 CASE(1)
3853 DO k=1,8
3854 n = ixs(k+1,elem)
3855 elemnodes(k)= n
3856 ENDDO
3857 CASE(2)
3858! Tetra 10 nodes
3859 elemnodes(1) = ixs(2,elem)
3860 elemnodes(2) = ixs(6,elem)
3861 elemnodes(3) = ixs(4,elem)
3862 elemnodes(4) = ixs(7,elem)
3863 CASE(3)
3864 nelmin = 1
3865 elem = elem - offelem(1)
3866 DO k=1,4
3867 n = ixq(k+1,elem)
3868 elemnodes(k) = n
3869 ENDDO
3870 CASE(4)
3871 nelmin = 2
3872 DO i=1,2
3873 elem = elem - offelem(i)
3874 ENDDO
3875 DO k=1,4
3876 n = ixc(k+1,elem)
3877 elemnodes(k) = n
3878 ENDDO
3879 CASE(5)
3880 nelmin = 1
3881 DO i=1,3
3882 elem = elem - offelem(i)
3883 ENDDO
3884 DO k=1,2
3885 n = ixt(k+1,elem)
3886 elemnodes(k) = n
3887 ENDDO
3888 CASE(6)
3889 nelmin = 1
3890 DO i=1,4
3891 elem = elem - offelem(i)
3892 ENDDO
3893 DO k=1,2
3894 n = ixp(k+1,elem)
3895 elemnodes(k) = n
3896 ENDDO
3897 CASE(7)
3898 nelmin = 1
3899 DO i=1,5
3900 elem = elem - offelem(i)
3901 ENDDO
3902 DO k=1,2
3903 n = ixr(k+1,elem)
3904 elemnodes(k) = n
3905 ENDDO
3906 IF(nint(geo(12,ixr(1,elem)))==12) THEN
3907 n = ixr(4,elem)
3908 elemnodes(3) = n
3909 ENDIF
3910 CASE(8)
3911 nelmin = 2
3912 DO i=1,6
3913 elem = elem - offelem(i)
3914 ENDDO
3915 DO k=1,3
3916 n = ixtg(k+1,elem)
3917 elemnodes(k) = n
3918 ENDDO
3919 CASE(9)
3920 nelmin = 1
3921 DO i=1,7
3922 elem = elem - offelem(i)
3923 ENDDO
3924 CASE(10)
3925 nelmin = 1
3926 DO i=1,8
3927 elem = elem - offelem(i)
3928 ENDDO
3929 nelx=kxx(3,elem)
3930 DO k=1,min(nelx,10)
3931 addx = kxx(4,elem)+k-1
3932 n=ixx(addx)
3933 elemnodes(k) = n
3934 ENDDO
3935 CASE(11)
3936 DO i=1,9
3937 elem = elem - offelem(i)
3938 ENDDO
3939 nelig3d=kxig3d(3,elem)
3940 DO k=1,min(nelig3d,10)
3941 addx = kxig3d(4,elem)+k-1
3942 n=ixig3d(addx)
3943 elemnodes(k) = n
3944 ENDDO
3945 END SELECT
3946C Set duplicates to 0
3947 DO k=2,max_nb_nodes_per_elt
3948 DO i=1,k-1
3949 IF(elemnodes(k) == elemnodes(i)) elemnodes(k) = 0
3950 ENDDO
3951 ENDDO
3952
3953 END
3954
3955!||====================================================================
3956!|| fvbag_vertex ../starter/source/spmd/domain_decomposition/grid2mat.F
3957!||--- called by ------------------------------------------------------
3958!|| dometis ../starter/source/spmd/domain_decomposition/grid2mat.F
3959!||--- calls -----------------------------------------------------
3960!|| fvelsurf ../starter/source/airbag/fvelsurf.F
3961!||--- uses -----------------------------------------------------
3962!|| message_mod ../starter/share/message_module/message_mod.F
3963!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
3964!||====================================================================
3965 SUBROUTINE fvbag_vertex(IXC ,IXTG , NELEM, WD,
3966 . WD_MAX,FVM_ELEM, FVM_DOMDEC, ITAB,
3967 . IGRSURF, T_MONVOL)
3968C Description: computes a weight for each FVMBAG
3969C this weight is added to an element of the skin of the airbag
3970C PMAIN will be the processor in charge of this element
3971C FVM_DOMDEC set to .TRUE. if an FVMBAGS contains less than NUMNOD/2
3972C nodes. Specific domain decomposition parameters will be used in that
3973C case
3974C-----------------------------------------------
3975C M o d u l e s
3976C-----------------------------------------------
3977 USE message_mod
3978 USE fvmbag_meshcontrol_mod
3979 USE groupdef_mod
3980 USE monvol_struct_mod
3981C-----------------------------------------------
3982C I m p l i c i t T y p e s
3983C-----------------------------------------------
3984#include "implicit_f.inc"
3985C-----------------------------------------------
3986C C o m m o n B l o c k s
3987C-----------------------------------------------
3988#include "com01_c.inc"
3989#include "com04_c.inc"
3990#include "units_c.inc"
3991C-----------------------------------------------
3992C D u m m y A r g u m e n t s
3993C-----------------------------------------------
3994 INTEGER, INTENT(IN) :: IXC(NIXC,*), IXTG(NIXTG,*)
3995 INTEGER,INTENT(IN) :: NELEM
3996 INTEGER, INTENT(INOUT) :: FVM_ELEM(NVOLU)
3997 DOUBLE PRECISION ,INTENT(INOUT) :: WD_MAX ! maximum weight for fvmbags
3998 REAL,INTENT(INOUT) :: WD(*) ! weights
3999 LOGICAL, INTENT(OUT) :: FVM_DOMDEC
4000 INTEGER,INTENT(IN) :: ITAB(*)
4001 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
4002 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
4003C----------------------------------------------
4004C L o c a l V a r i a b l e s
4005C---------------------------------------------
4006 LOGICAL, DIMENSION(:), ALLOCATABLE :: TAGGED_ELEM
4007 INTEGER, DIMENSION(:), ALLOCATABLE :: ELTG,MATTG
4008 INTEGER :: I,J,K,N,K0,K1,K2,K6
4009 INTEGER :: ITYP,S
4010 INTEGER :: OFFC,OFFTG
4011 INTEGER :: NNS,NTG,NNI,NTGI,NNO,NN,NTGT
4012 INTEGER :: RADALE, IBID
4013
4014C---------------------------------------------
4015C
4016C---------------------------------------------
4017
4018
4019C WD_MAX is the maximum weight of the super elt
4020C In order to be able to compute a partition
4021 OFFC = numels+numelq
4022 offtg =numels+numelq+ numelc+numelt+numelp+numelr
4023 i = 0
4024 DO n = 1, nvolu
4025 ityp = t_monvol(n)%TYPE
4026 nn = t_monvol(n)%NNS
4027 IF(nn > 0 .AND. (ityp == 8 .OR. ityp==6)) THEN
4028 IF(2 * nn < numnod) fvm_domdec = .true.
4029 i = i + 1
4030 ENDIF
4031 ENDDO ! 1,NVOLU
4032
4033 wd_max = 0.0d0
4034 DO n = 1,nelem
4035 wd_max = wd_max + (1.0d0*wd(n)) / (1.0d0 * nspmd)
4036 ENDDO
4037C================================================================================
4038C Arbitrary: limit the weight of one FVMBAG to 25% of the weight of one subdomain
4039 wd_max = wd_max / 4.0d0
4040C================================================================================
4041
4042 IF(i > 0) WRITE(iout,'(A)')
4043 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR FVMBAGS '
4044
4045 ALLOCATE(tagged_elem(nelem))
4046 offc = numels+numelq
4047 offtg = numels+numelq+ numelc+numelt+numelp+numelr
4048 DO n = 1, nvolu
4049 tagged_elem(1:nelem) = .false.
4050 ityp = t_monvol(n)%TYPE
4051 nn = t_monvol(n)%NNS
4052
4053 IF(nn > 0 .AND. (ityp == 8 .OR. ityp==6)) THEN
4054 ! Tag elements of the fvmbag
4055 nns = t_monvol(n)%NNS
4056 ntg = t_monvol(n)%NTG
4057 nni = t_monvol(n)%NNI
4058 ntgi = t_monvol(n)%NTGI
4059 nno=3
4060 ntgt=ntg+ntgi
4061
4062 ALLOCATE(eltg(ntgt))
4063 ALLOCATE(mattg(ntgt))
4064
4065 CALL fvelsurf(
4066 . t_monvol(n)%NODES, t_monvol(n)%ELEM, ibid, ixc, ixtg, ntgt,
4067 . eltg, mattg, max(numnod, nb_total_node), .false.)
4068
4069 IF(ntgt > 1) THEN
4070 ! The first element of the FVMBAG will become the super-element
4071 ! i.e. the element that holds the weight of the finite volumes
4072 j = eltg(1) ! ELTG
4073
4074 k0 = 0
4075 IF ( j<= numelc) THEN
4076 k0 = j - numelq
4077 k0 = offc +k0
4078 ELSE
4079 k0 = (j-numelc-numelq)
4080 k0 = offtg+ k0
4081
4082 ENDIF
4083
4084 fvm_elem(n) = k0
4085
4086 IF(k0 == 0) THEN
4087
4088 ELSE
4089 tagged_elem(k0) = .true.
4090 DO i=2,ntgt
4091 j = eltg(i)! ELTG
4092 IF (j<=numelc) THEN
4093 k = offc + j
4094 ! The weight of the super element is incremented
4095 IF(.NOT.(tagged_elem(k))) THEN
4096 ! the weight of each element is doubled
4097c CALL IDDCONNECTPLUS(K,K0,NELEM)
4098 wd(k0) = wd(k0) +1.0d0* wd(k)
4099 tagged_elem(k) = .true.
4100 ENDIF
4101 ELSEIF (j>numelc) THEN
4102 k = offtg+ (j-numelc)
4103 ! The weight of the super element is incremented
4104 IF(.NOT.(tagged_elem(k))) THEN
4105 wd(k0) = wd(k0) + 1.0d0*wd(k)
4106 tagged_elem(k) = .true.
4107 ENDIF
4108 ENDIF
4109 ENDDO !2,NTGT
4110 ENDIF
4111 ENDIF ! NTGT > 0
4112
4113 IF(wd(fvm_elem(n)) > wd_max) THEN
4114 wd(fvm_elem(n)) = wd_max
4115 ENDIF
4116 DEALLOCATE(eltg)
4117 DEALLOCATE(mattg)
4118 ENDIF
4119 ENDDO ! 1,NVOLU
4120 DEALLOCATE(tagged_elem)
4121
4122 RETURN
4123 END
c_enforce_constraints
void c_enforce_constraints(int *cep)
Definition c_domain_decomposition.cpp:76
c_enforce_constraints_rbody
void c_enforce_constraints_rbody(int *cep, int *nspmd, int *nrby)
Definition c_domain_decomposition_rbody.cpp:140
c_prevent_decomposition_rbody
void c_prevent_decomposition_rbody(int *rbodysize, int *elements)
Definition c_domain_decomposition_rbody.cpp:127
my_real
#define my_real
Definition cppsort.cpp:32
c_iddconnect
subroutine c_iddconnect(n, cpt)
Definition ddtools.F:1207
plist_bfs
subroutine plist_bfs(nelem, nconnx, colors, roots)
Definition ddtools.F:1310
plist_iddconnect
subroutine plist_iddconnect(adjncy, xadj, n)
Definition ddtools.F:1257
ini_iddconnect
subroutine ini_iddconnect(nelem)
Definition ddtools.F:1114
if
if(complex_arithmetic) id
the
end diagonal values have been computed in the(sparse) matrix id.SOL
iddconnectplus
subroutine iddconnectplus(n, p, numel)
Definition frontplus.F:210
fvelsurf
subroutine fvelsurf(ibuf, elem, elem_id, ixc, ixtg, nel, eltg, mattg, nb_node, flag)
Definition fvelsurf.F:32
wrap_metis_partgraphkway
int wrap_metis_partgraphkway(int *NELEM, int *NCOND, int *XADJ, int *ADJNCY, int *IWD, int *NNODE, float *UBVEC, int *OPTIONS, int *NEC, int *CEP)
Definition grid2m_wrap.c:61
wrap_metis_partgraphrecursive
int wrap_metis_partgraphrecursive(int *NELEM, int *NCOND, int *XADJ, int *ADJNCY, int *IWD, int *NNODE, float *UBVEC, int *OPTIONS, int *NEC, int *CEP)
Definition grid2m_wrap.c:147
lec_ddw
subroutine lec_ddw(filnam, len_filnam, tab_ump_old, cputime_mp_old)
Definition grid2mat.F:3261
iwcontdd
subroutine iwcontdd(nsv, msr, nsn, nmn, iwcont, nsnt, nmnt)
Definition grid2mat.F:3003
prelec_ddw_poin
subroutine prelec_ddw_poin(filnam, len_filnam)
Definition grid2mat.F:3313
lec_ddw_poin
subroutine lec_ddw_poin(filnam, len_filnam, poin_ump_old)
Definition grid2mat.F:3354
reini_matprop2
subroutine reini_matprop2(taille, taille2, tab_ump_loc, tab_ump_loc2, tab_ump, tab_sol, poin_ump)
Definition grid2mat.F:3611
interlagran
subroutine interlagran(tab, lx, ltab, x, y)
Definition grid2mat.F:2892
dometis
subroutine dometis(ixs, ixq, ixc, ixt, ixp, ixr, ixtg, cep, geo, itri1, itri2, index1, index2, num, wd, iwcont, nelem, iddlevel, nelemint, inter_cand, pm, x, kxx, ixx, adsky, igeo, isolnod, iwcin2, dsdof, isoloff, isheoff, itrioff, itruoff, ipouoff, iresoff, ielem21, ipm, ixs10, ikine, clusters, kxig3d, ixig3d, cost_r2r, bufmat, taille, poin_ump, tab_ump, poin_ump_old, tab_ump_old, cputime_mp_old, nsnt, nmnt, tabmp_l, iquaoff, igrsurf, fvmain, itab, ipart, ipartc, ipartg, iparts, poin_part_shell, poin_part_tri, poin_part_sol, mid_pid_shell, mid_pid_tri, mid_pid_sol, t_monvol, ebcs_tag_cell_spmd, npby, lpby, mat_param)
Definition grid2mat.F:74
dd_bfs
subroutine dd_bfs(xadj, adjncy, nelem, nedges, nconnx, colors, roots)
Definition grid2mat.F:3123
iwcontdd_151
subroutine iwcontdd_151(bufbric, nbric, msr, nmn, iwcont, nsnt, nmnt, numnod, ixs, numels, nale)
Definition grid2mat.F:3040
reini_matprop
subroutine reini_matprop(taille, taille2, tab_ump_loc, tab_ump_loc2, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, isolnod, poin_ump)
Definition grid2mat.F:3400
iwcontdd_new
subroutine iwcontdd_new(nsv, msr, nsn, nmn, iwcont, cost)
Definition grid2mat.F:2970
find_nodes
subroutine find_nodes(elemn0, elemnodes, tagelem, ixs, ixs10, ixq, ixc, ixt, ixp, ixr, ixtg, kxx, ixx, kxig3d, ixig3d, geo, offelem, nelmin)
Definition grid2mat.F:3816
i2wcontdd
subroutine i2wcontdd(nsv, msr, nsn, nmn, iwcont, nsnt, nmnt)
Definition grid2mat.F:2935
i20wcontdd
subroutine i20wcontdd(nsv, msr, nsn, nmn, iwcont, nsnt, nmnt)
Definition grid2mat.F:3089
fvbag_vertex
subroutine fvbag_vertex(ixc, ixtg, nelem, wd, wd_max, fvm_elem, fvm_domdec, itab, igrsurf, t_monvol)
Definition grid2mat.F:3968
spdometis
subroutine spdometis(kxsp, ixsp, nod2sp, cepsp, reservep, sph2sol, cep)
Definition grid2mat.F:2621
stat_domdec
subroutine stat_domdec(wis, wi2, wfsi, wdel, wddl, wcand, wsol, wr2r, wkin, iwd, ncond, icelem, icints, icint2, iccand, icddl, icsol, icfsi, icdel, icr2r, ickin, average, deviation, dmax, dmin, cep, nelem, w, icintm, wim, ncritmax, wnod_sms, icnod_sms)
Definition grid2mat.F:3682
prelec_ddw
subroutine prelec_ddw(filnam, len_filnam, marqueur3)
Definition grid2mat.F:3189
initwg
subroutine initwg(wd, pm, geo, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, kxx, igeo, isolnod, idarch, numels, numelq, numelc, numelt, numelp, numelr, numeltg, numelx, ipm, bufmat, nummat, numgeo, taille, poin_ump, tab_ump, poin_ump_old, tab_ump_old, cputime_mp_old, tabmp_l, ipart, ipartc, ipartg, iparts, npart, poin_part_shell, poin_part_tri, poin_part_sol, mid_pid_shell, mid_pid_tri, mid_pid_sol, iddlevel, mat_param)
Definition initwg.F:53
min
#define min(a, b)
Definition macros.h:20
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
cluster_mod
Definition cluster_mod.F:40
consider_edge_mod
Definition consider_edge.F:29
consider_edge_mod::consider_edge
logical function consider_edge(connectivity, nb_nodes_mini, nelem, e1, e2)
Definition consider_edge.F:47
consider_edge_mod::sort_descending
subroutine sort_descending(array)
Definition consider_edge.F:96
consider_edge_mod::max_nb_nodes_per_elt
integer, parameter max_nb_nodes_per_elt
Definition consider_edge.F:33
front_mod
Definition front_mod.F:84
fvmbag_meshcontrol_mod
Definition fvmbag_meshcontrol_mod.F:46
fvmbag_meshcontrol_mod::nb_total_node
integer nb_total_node
Definition fvmbag_meshcontrol_mod.F:50
groupdef_mod
Definition groupdef_mod.F:662
inter_cand_mod
Definition inter_cand_mod.F:38
message_mod
Definition message_mod.F:1249
mid_pid_mod
Definition mid_pid_mod.F:36
monvol_struct_mod
Definition monvol_struct_mod.F:66
r2r_mod
Definition r2r_mod.F:125
reorder_mod
Definition reorder_mod.F:45
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
starter
program starter
Definition starter.F:39
inter_cand_mod::inter_cand_
Definition inter_cand_mod.F:40
monvol_struct_mod::monvol_struct_
Definition monvol_struct_mod.F:84