OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
grid2mat.F File Reference
#include "implicit_f.inc"
#include "assert.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "scr12_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "scr15_c.inc"
#include "scr05_c.inc"
#include "scr17_c.inc"
#include "scr23_c.inc"
#include "sms_c.inc"
#include "r2r_c.inc"
#include "kincod_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

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)
subroutine spdometis (kxsp, ixsp, nod2sp, cepsp, reservep, sph2sol, cep)
subroutine interlagran (tab, lx, ltab, x, y)
subroutine i2wcontdd (nsv, msr, nsn, nmn, iwcont, nsnt, nmnt)
subroutine iwcontdd_new (nsv, msr, nsn, nmn, iwcont, cost)
subroutine iwcontdd (nsv, msr, nsn, nmn, iwcont, nsnt, nmnt)
subroutine iwcontdd_151 (bufbric, nbric, msr, nmn, iwcont, nsnt, nmnt, numnod, ixs, numels, nale)
subroutine i20wcontdd (nsv, msr, nsn, nmn, iwcont, nsnt, nmnt)
subroutine dd_bfs (xadj, adjncy, nelem, nedges, nconnx, colors, roots)
subroutine prelec_ddw (filnam, len_filnam, marqueur3)
subroutine lec_ddw (filnam, len_filnam, tab_ump_old, cputime_mp_old)
subroutine prelec_ddw_poin (filnam, len_filnam)
subroutine lec_ddw_poin (filnam, len_filnam, poin_ump_old)
subroutine reini_matprop (taille, taille2, tab_ump_loc, tab_ump_loc2, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, isolnod, poin_ump)
subroutine reini_matprop2 (taille, taille2, tab_ump_loc, tab_ump_loc2, tab_ump, tab_sol, poin_ump)
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)
subroutine find_nodes (elemn0, elemnodes, tagelem, ixs, ixs10, ixq, ixc, ixt, ixp, ixr, ixtg, kxx, ixx, kxig3d, ixig3d, geo, offelem, nelmin)
subroutine fvbag_vertex (ixc, ixtg, nelem, wd, wd_max, fvm_elem, fvm_domdec, itab, igrsurf, t_monvol)

Function/Subroutine Documentation

◆ dd_bfs()

subroutine dd_bfs ( integer, dimension(nelem+1) xadj,
integer, dimension(2*nedges) adjncy,
integer nelem,
integer nedges,
integer nconnx,
integer, dimension(nelem) colors,
integer, dimension(nelem) roots )

Definition at line 3128 of file grid2mat.F.

3129C-----------------------------------------------
3130C I m p l i c i t T y p e s
3131C-----------------------------------------------
3132#include "implicit_f.inc"
3133C-----------------------------------------------
3134C D u m m y A r g u m e n t s
3135C-----------------------------------------------
3136 INTEGER NELEM, NEDGES, NCONNX,
3137 . XADJ(NELEM+1), ADJNCY(2*NEDGES),
3138 . COLORS(NELEM), ROOTS(NELEM)
3139C-----------------------------------------------
3140C L o c a l V a r i a b l e s
3141C-----------------------------------------------
3142 INTEGER NVISIT, N, I
3143 INTEGER FILE_NEXT, ROOT, CURRENT
3144 INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_V
3145C-----------------------------------------------
3146 ALLOCATE(file_v(nelem))
3147 DO n = 1, nelem
3148 colors(n)=0
3149 END DO
3150 nvisit=0
3151 root=1 ! first element of the graph == first vertex available
3152 nconnx=0
3153
3154 DO WHILE (nvisit < nelem) ! loop until all vertices are visited
3155 nconnx = nconnx+1
3156 DO WHILE ((root <= nelem) .AND. (colors(root) /= 0))
3157 root = root + 1
3158 END DO
3159c IF (ROOT > NELEM) THEN
3160c print*,'** FATAL ERROR DURING BFS'
3161c NCONNX=-1
3162c EXIT
3163c END IF
3164 roots(nconnx)=root ! record roots for fatest treatments
3165 file_v(1)=root
3166 file_next=2 ! new file initialized with root
3167 colors(root)=nconnx ! root marked
3168 nvisit=nvisit+1
3169 DO WHILE (file_next > 1) ! test file not nill
3170 current = file_v(file_next-1)
3171 file_next = file_next-1
3172 DO n = xadj(current), xadj(current+1)-1
3173 i = adjncy(n)
3174 IF(colors(i) == 0) THEN ! vertex not treated before
3175 file_v(file_next)=i
3176 file_next = file_next+1
3177 colors(i) = nconnx
3178 nvisit=nvisit+1
3179 END IF
3180 END DO
3181 END DO
3182 END DO
3183 DEALLOCATE(file_v)
3184 RETURN

◆ dometis()

subroutine dometis ( integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) cep,
geo,
integer, dimension(*) itri1,
integer, dimension(*) itri2,
integer, dimension(*) index1,
integer, dimension(*) index2,
integer, dimension(*) num,
real, dimension(*) wd,
integer, dimension(5,*) iwcont,
integer nelem,
integer iddlevel,
integer nelemint,
type(inter_cand_), intent(in) inter_cand,
pm,
x,
integer, dimension(nixx,numelx) kxx,
integer, dimension(*) ixx,
integer, dimension(0:*) adsky,
integer, dimension(npropgi,numgeo) igeo,
integer, dimension(*) isolnod,
integer, dimension(2,*) iwcin2,
integer, dimension(*) dsdof,
integer, dimension(*) isoloff,
integer, dimension(*) isheoff,
integer, dimension(*) itrioff,
integer, dimension(*) itruoff,
integer, dimension(*) ipouoff,
integer, dimension(*) iresoff,
integer, dimension(*) ielem21,
integer, dimension(npropmi,nummat) ipm,
integer, dimension(6,*) ixs10,
integer, dimension(*) ikine,
type (cluster_), dimension(*) clusters,
integer, dimension(nixig3d,numelig3d) kxig3d,
integer, dimension(*) ixig3d,
cost_r2r,
bufmat,
integer taille,
integer, dimension(nummat) poin_ump,
integer, dimension(7,taille) tab_ump,
integer, dimension(nummat_old) poin_ump_old,
integer, dimension(7,taille_old) tab_ump_old,
dimension(taille_old) cputime_mp_old,
integer nsnt,
integer nmnt,
integer tabmp_l,
integer, dimension(*) iquaoff,
type (surf_), dimension(nsurf) igrsurf,
integer, dimension(nvolu) fvmain,
integer, dimension(*) itab,
integer, dimension(lipart1,*), intent(in) ipart,
integer, dimension(*), intent(in) ipartc,
integer, dimension(*), intent(in) ipartg,
integer, dimension(*), intent(in) iparts,
integer, dimension(2,npart), intent(in) poin_part_shell,
integer, dimension(2,npart), intent(in) poin_part_tri,
integer, dimension(2,npart,7), intent(in) poin_part_sol,
type(mid_pid_type), dimension(nummat), intent(in) mid_pid_shell,
type(mid_pid_type), dimension(nummat), intent(in) mid_pid_tri,
type(mid_pid_type), dimension(nummat,7), intent(in) mid_pid_sol,
type(monvol_struct_), dimension(nvolu), intent(in) t_monvol,
integer, dimension(numelq+numeltg+numels), intent(in) ebcs_tag_cell_spmd,
integer, dimension(nnpby,*), intent(in) npby,
integer, dimension(*), intent(in) lpby,
type(matparam_struct_), dimension(nummat), intent(in) mat_param )

Definition at line 56 of file grid2mat.F.

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
90 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
91C-----------------------------------------------
92C I m p l i c i t T y p e s
93C-----------------------------------------------
94#include "implicit_f.inc"
95C-----------------------------------------------
96C C o m m o n B l o c k s
97C-----------------------------------------------
98#include "assert.inc"
99#include "com01_c.inc"
100#include "com04_c.inc"
101#include "scr12_c.inc"
102#include "param_c.inc"
103#include "units_c.inc"
104#include "scr15_c.inc"
105#include "scr05_c.inc"
106#include "scr17_c.inc"
107#include "scr23_c.inc"
108#include "sms_c.inc"
109#include "r2r_c.inc"
110#include "kincod_c.inc"
111#include "sphcom.inc"
112C-----------------------------------------------
113C D u m m y A r g u m e n t s
114C-----------------------------------------------
115 INTEGER IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*), IXT(NIXT,*),
116 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*),
117 . CEP(*), ITRI1(*), ITRI2(*), INDEX1(*),INDEX2(*),
118 . NUM(*), NELEM,IDDLEVEL, NELEMINT,
119 . KXX(NIXX,NUMELX),IXX(*), ADSKY(0:*),IGEO(NPROPGI,NUMGEO),
120 . ISOLNOD(*), IWCONT(5,*), IWCIN2(2,*), DSDOF(*),
121 . ISOLOFF(*), ISHEOFF(*), ITRIOFF(*), IKINE(*),
122 . ITRUOFF(*), IPOUOFF(*), IRESOFF(*), IELEM21(*),
123 . IPM(NPROPMI,NUMMAT),IXS10(6,*),KXIG3D(NIXIG3D,NUMELIG3D),
124 . IQUAOFF(*),
125 . IXIG3D(*),NSNT, NMNT,TABMP_L,
126 . FVMAIN(NVOLU)
127 INTEGER :: ITAB(*)
128 INTEGER, DIMENSION(LIPART1,*), INTENT(IN) :: IPART
129 INTEGER, DIMENSION(*), INTENT(IN) :: IPARTC,IPARTG,IPARTS
130 TYPE (CLUSTER_) ,DIMENSION(*) :: CLUSTERS
131 my_real geo(npropg,numgeo), pm(npropm,nummat), x(3,*), cost_r2r,bufmat(*)
132 REAL WD(*)
133 INTEGER TAILLE
134 INTEGER, DIMENSION(NUMMAT_OLD) :: POIN_UMP_OLD
135 INTEGER, DIMENSION(7,TAILLE_OLD) :: TAB_UMP_OLD
136 INTEGER, DIMENSION(NUMMAT) :: POIN_UMP
137 INTEGER, DIMENSION(7,TAILLE) :: TAB_UMP
138 my_real, DIMENSION(TAILLE_OLD) :: cputime_mp_old
139 INTEGER, DIMENSION(2,NPART), INTENT(IN) :: POIN_PART_SHELL,POIN_PART_TRI
140 INTEGER, DIMENSION(2,NPART,7), INTENT(IN) :: POIN_PART_SOL
141 TYPE(MID_PID_TYPE), DIMENSION(NUMMAT), INTENT(IN) :: MID_PID_SHELL,MID_PID_TRI
142 TYPE(MID_PID_TYPE), DIMENSION(NUMMAT,7), INTENT(IN) :: MID_PID_SOL
143 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
144 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
145 INTEGER,INTENT(IN) :: EBCS_TAG_CELL_SPMD(NUMELQ+NUMELTG+NUMELS)
146 INTEGER, DIMENSION(NNPBY,*), INTENT(in) :: NPBY
147 INTEGER, DIMENSION(*), INTENT(in) :: LPBY
148 TYPE(INTER_CAND_), INTENT(in) :: INTER_CAND
149 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT), INTENT(IN) :: MAT_PARAM
150C-----------------------------------------------
151C L o c a l V a r i a b l e s
152C-----------------------------------------------
153 INTEGER NCRITMAX
154 parameter(ncritmax = 20)
155 INTEGER NSEG, I, J, UTIL, K, NUSE, ELEMD_OLD,
156 . LCNE,IO_ERR1,ISH1,ISH2,II, NNC, IT,
157 . NEDGES, ELK, OFF,CC1, CC2, NUMG1, NUMG2,
158 . INED,L,M,N,NEWEDGE,NEDGES_OLD,
159 . LENWORK,NOD1, NOD2, MODE, NELEM0, MM,
160 . WORK(70000), NUML, IERROR,
161 . ELEMD, IMMNUL, NEDDEL, ITYPINT, IWARN1,
162 . MAXI, MAXJ, MAX, I1, I2, I3, N1, N2, NUMG3, NUMG4,
163 . NELX,ADDX,MID,PID,JALE,MLN,NSHIFT,NNODE, NN,
164 . OPTIONS(40),NCOND,NFLAG,IWFLG,NODC,ICUR,IERR1,NEC,
165 . INWDCOUNT,ICCAND,ICNOD_SMS,ISOLBAR, ICKIN, NK, NKI,
166 . ICELEM, ICINTS, ICINTM, ICINT2, ICDDL, ICFSI, ICDEL, ICSOL,
167 . ICR2R,NUMEL_R2R, CEPCLUSTER,
168 . NCONNX, CURR, PREV, NEXT, I1OLD, I2OLD, INC, IDB_METIS,
169 . NELIG3D,NCOND2,LSMS,
170 . OFFC,OFFTG,K0,ITYP,
171 . NN_L,IS,IAD,ITY,KAD,JALE_FROM_MAT, JALE_FROM_PROP
172 INTEGER, DIMENSION(:),ALLOCATABLE :: XADJ, ADJNCY,IWD,IWD2,
173 . IENDT,ITRI,INDEX,DOMCLUSTER,ELEMCLUST,
174 . XADJ_OLD, ADJNCY_OLD, COLORS, ROOTS,
175 . POINTER_NEIGH,CONNECT_WEIGHT,TAGELEM,CNE,
176 . IWD_COPY
177 INTEGER, DIMENSION(:), ALLOCATABLE :: IWKIN ! NUMNOD
178 INTEGER TAILLE_LOCAL,PREV_NEIGH,C_NEIGH,POINT_DELETE,
179 . ELEMNODES(MAX_NB_NODES_PER_ELT),OFFELEM(10),WGHT
180 INTEGER, DIMENSION(:,:), ALLOCATABLE :: CONNECTIVITY
181 INTEGER, DIMENSION(:), ALLOCATABLE :: NB_NODES_MINI
182 REAL, DIMENSION(:),ALLOCATABLE :: RWD,WD_COPY
183 CHARACTER FILNAM*109, KEYA*80, CHLEVEL*1
184 REAL FAC, UBVEC(15), SCAL
185 DOUBLE PRECISION
186 . AVERAGE(NCRITMAX), DEVIATION(NCRITMAX), DMIN(NCRITMAX), DMAX(NCRITMAX),
187 . W(NSPMD), WIS(NSPMD),WIM(NSPMD),WI2(NSPMD), WDDL(NSPMD),
188 . WFSI(NSPMD), WCAND(NSPMD), WSOL(NSPMD), WKIN(NSPMD),
189 . WDEL(NSPMD), WR2R(NSPMD), WNOD_SMS(NSPMD)
190 DOUBLE PRECISION :: WS, WD_MAX,WD_MAX0
191C metis5 null pointers
192
193 INTEGER METIS_PartGraphKway, METIS_PartGraphRecursive,
194 . METIS_SetDefaultOptions,Wrap_METIS_PartGraphKway,
195 . WRAP_METIS_PARTGRAPHRECURSIVE
196 INTEGER NNO,NNS,NTG,NNI,NTGT,NTGI
197 INTEGER NELMIN
198 INTEGER NFVMBAG,NB_FVMBAG_TRIM,DD_FVMBAG_TRY
199 INTEGER FVM_ELEM(NVOLU),AVG,MAX_TRY
200 INTEGER WD_MAX_FACTOR
201 INTEGER NB_ELEM_ALE,MAIN_TARGET
202 CHARACTER (LEN=255) :: STR
203 LOGICAL :: FVM_DOMDEC,DD_UNBALANCED
204 LOGICAL, DIMENSION(:), ALLOCATABLE :: TAGGED_ELEM
205 INTEGER, DIMENSION(:), ALLOCATABLE :: ISORT,INDEX_SORT
206
207 INTEGER (kind=8) :: NEDGES_8
208 INTEGER :: CLUSTER_TYP,OFFSET_CLUSTER
209 my_real, DIMENSION(:,:), ALLOCATABLE :: coords
210 my_real, DIMENSION(:), ALLOCATABLE :: min_dist
211 my_real :: dist
212 my_real :: xmin(3),xmax(3)
213 INTEGER :: CEP_MIN
214 INTEGER :: C1,C2
215 INTEGER :: OFFSET
216
217
218C ---- statistics for edges added for contact interface
219 INTEGER :: number_of_added_edges
220 INTEGER :: refused_cep0, refused_numg,refused_numg0
221 INTEGER :: switch_tried, switch_done
222
223 integer, pointer :: null_int(:)
224 real, pointer :: null_real(:)
225 integer :: int_bidon
226 real :: real_bidon
227
228 INTEGER :: IJK
229 INTEGER :: NSN
230 INTEGER :: NUMBER_OF_ELEMENT_RBODY,NUMEL
231 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_ELEMENT_RBODY
232 LOGICAL :: BOOL_RBODY
233C-----------------------------------------------
234C E x t e r n a l F u n c t i o n s
235C-----------------------------------------------
236 EXTERNAL metis_partgraphkway, metis_partgraphrecursive,
237 . metis_setdefaultoptions,wrap_metis_partgraphkway,
238 . wrap_metis_partgraphrecursive
239C-----------------------------------------------
240C S o u r c e L i n e s
241C-----------------------------------------------
242 ALLOCATE(iwkin(numnod))
243 number_of_added_edges = 0
244 refused_numg = 0
245 refused_numg0 = 0
246
247 refused_cep0 = 0
248 switch_tried = 0
249 switch_done = 0
250
251 nec=0
252 nfvmbag = 0
253 fvmain(1:nvolu) = -1
254 fvm_elem(1:nvolu) = 0
255 fvm_domdec = .false.
256 wd_max = 0.0d0
257 wd_max0= 0.0d0
258 nnode = nspmd
259
260C----------------------------------
261C global NEDGE counting
262C----------------------------------
263 DO i=1,numnod+1
264 adsky(i) = 0
265 END DO
266C.....necessary memory
267 DO 110 k=2,9
268 DO 110 i=1,numels
269 n = ixs(k,i) + 1
270 adsky(n) = adsky(n) + 1
271 110 CONTINUE
272
273C add Tetra10
274 IF(numels10>0) THEN
275 DO j=1,numels10
276 DO k=1,6
277 n = ixs10(k,j) + 1
278 adsky(n) = adsky(n) + 1
279 ENDDO
280 ENDDO
281 ENDIF
282C
283 DO 120 k=2,5
284 DO 120 i=1,numelq
285 n = ixq(k,i) + 1
286 adsky(n) = adsky(n) + 1
287 120 CONTINUE
288C
289 DO 130 k=2,5
290 DO 130 i=1,numelc
291 n = ixc(k,i) + 1
292 adsky(n) = adsky(n) + 1
293 130 CONTINUE
294C
295 DO 140 k=2,3
296 DO 140 i=1,numelt
297 n = ixt(k,i) + 1
298 adsky(n) = adsky(n) + 1
299 140 CONTINUE
300C
301 DO 150 k=2,3
302 DO 150 i=1,numelp
303 n = ixp(k,i) + 1
304 adsky(n) = adsky(n) + 1
305 150 CONTINUE
306C
307C separate treatment of optional 3rd node except type 12
308 DO k=2,3
309 DO i=1,numelr
310 n = ixr(k,i) + 1
311 adsky(n) = adsky(n) + 1
312 ENDDO
313 ENDDO
314 DO i=1,numelr
315 n = ixr(4,i) + 1
316 IF(nint(geo(12,ixr(1,i)))==12) THEN
317 adsky(n) = adsky(n) + 1
318 ENDIF
319 ENDDO
320C
321 DO 170 k=2,4
322 DO 170 i=1,numeltg
323 n = ixtg(k,i) + 1
324 adsky(n) = adsky(n) + 1
325 170 CONTINUE
326
327C
328C Elements Multibrins
329 DO i=1,numelx
330 nelx=kxx(3,i)
331 DO k=1,nelx
332 addx = kxx(4,i)+k-1
333 n=ixx(addx)+1
334 adsky(n)= adsky(n)+1
335 ENDDO
336 ENDDO
337C
338C Elements Iso-geo
339 DO i=1,numelig3d
340 nelig3d=kxig3d(3,i)
341 DO k=1,nelig3d
342 addx = kxig3d(4,i)+k-1
343 n=ixig3d(addx)+1
344 adsky(n)= adsky(n)+1
345 ENDDO
346 ENDDO
347C
348 adsky(1) = 1
349 DO i=2,numnod+1
350 adsky(i) = adsky(i) + adsky(i-1)
351 END DO
352C
353 lcne = adsky(numnod+1)
354 ALLOCATE(cne(lcne),stat=ierr1)
355C
356 IF(ierr1/=0)THEN
357 CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,
358 . c1='DOMDEC')
359 END IF
360C
361C-----------------------------------------------
362C Optimization on deleted elements from _0001.rad
363C-----------------------------------------------
364C weights in real format for old RSB compatibility
365 DO i = 1, nelem
366 wd(i) = 0.
367 ENDDO
368 elemd = 0
369 filnam=rootnam(1:rootlen)//'_0001.rad'
370 OPEN(unit=71,file=filnam(1:rootlen+9),
371 . access='SEQUENTIAL',status='OLD',iostat=io_err1)
372C
373 IF (io_err1/=0) THEN
374 filnam=rootnam(1:rootlen)//'D01'
375 OPEN(unit=71,file=filnam(1:rootlen+3),
376 . access='SEQUENTIAL',status='OLD',iostat=io_err1)
377 ENDIF
378C
379 IF (io_err1==0) THEN
380 OPEN(unit=72,form='FORMATTED',status='SCRATCH')
381 elemd = 0
382 10 READ(71,'(A)',END=20) keya
383 11 CONTINUE
384 IF(keya(1:12)=='/DEL/SHELL/1') THEN
385 30 READ(71,'(A)',END=20) keya
386 IF(keya(1:1)=='#')GOTO 30
387 IF(keya(1:1)=='$')GOTO 30
388 IF(keya(1:1)=='/')GOTO 11
389C ko sur cray READ(KEYA,*,END=20)ISH1,ISH2
390 rewind(72)
391 WRITE(72,'(A)')keya
392 rewind(72)
393 READ(72,*,END=20)ISH1,ish2
394 DO i = 1, numelc
395 IF(ixc(nixc,i)>=ish1.AND.ixc(nixc,i)<=ish2) THEN
396 DO j = ish1, ish2
397 IF(ixc(nixc,i)==j) THEN
398 wd(i+numels+numelq) = 0.0001
399 elemd = elemd + 1
400 GOTO 35
401 ENDIF
402 ENDDO
403 ENDIF
404 35 CONTINUE
405 ENDDO
406 GOTO 30
407 ELSEIF(keya(1:12)=='/DEL/BRICK/1') THEN
408 60 READ(71,'(A)',END=20) keya
409 IF(keya(1:1)=='#')GOTO 60
410 IF(keya(1:1)=='$')GOTO 60
411 IF(keya(1:1)=='/')GOTO 11
412C ko sur cray READ(KEYA,*,END=20)ISH1,ISH2
413 rewind(72)
414 WRITE(72,'(A)')keya
415 rewind(72)
416 READ(72,*,END=20)ISH1,ish2
417 DO i = 1, numels
418 IF(ixs(nixs,i)>=ish1.AND.ixs(nixs,i)<=ish2) THEN
419 DO j = ish1, ish2
420 IF(ixs(nixs,i)==j) THEN
421 wd(i) = 0.0001
422 elemd = elemd + 1
423 GOTO 65
424 ENDIF
425 ENDDO
426 ENDIF
427 65 CONTINUE
428 ENDDO
429 GOTO 60
430C
431 ELSEIF(keya(1:12)=='/DEL/SH_3N/1') THEN
432 90 READ(71,'(A)',END=20) keya
433 IF(keya(1:1)=='#')GOTO 90
434 IF(keya(1:1)=='$')GOTO 90
435 IF(keya(1:1)=='/')GOTO 11
436C ko sur cray READ(KEYA,*,END=20)ISH1,ISH2
437 rewind(72)
438 WRITE(72,'(A)')keya
439 rewind(72)
440 READ(72,*,END=20)ISH1,ish2
441 DO i = 1, numeltg
442 IF(ixtg(nixtg,i)>=ish1
443 . .AND.ixtg(nixtg,i)<=ish2) THEN
444 DO j = ish1, ish2
445 IF(ixtg(nixtg,i)==j) THEN
446 wd(i+numels+numelq+numelc+numelt
447 . +numelp+numelr) = 0.0001
448 elemd = elemd + 1
449 GOTO 95
450 ENDIF
451 ENDDO
452 ENDIF
453 95 CONTINUE
454 ENDDO
455 GOTO 90
456 ENDIF
457 GOTO 10
458 20 CONTINUE
459 CLOSE(71)
460 CLOSE(72)
461C message on D01 read (delete optimized)
462 IF(iddlevel==0) THEN
463 WRITE(iout,*)' '
464 WRITE(iout,'(A)')
465 . ' SPMD IS CHECKING FOR ELEMENT DELETION IN : ',' '//filnam
466 ENDIF
467C
468 ELSE
469C message on D01 not read (delete not optimized)
470 IF(iddlevel==0) THEN
471 WRITE(iout,*)' '
472 WRITE(iout,'(A)')
473 . ' SPMD IS NOT ABLE TO CHECK FOR ELEMENT DELETION IN'//
474 . ' RADIOSS ENGINE INPUT FILE'
475 ENDIF
476 ENDIF
477
478C-----------------------------------------------
479C Optimization on RBYON from _0000.rad
480C-----------------------------------------------
481 elemd_old = elemd
482 isolbar=0
483 DO ii = 1, numels
484 IF((isoloff(ii)==1.OR.isoloff(ii)==3).AND.
485 * wd(ii)/=0.0001)THEN
486 wd(ii) = 0.0001
487 elemd = elemd + 1
488 END IF
489C additional test for barrier
490 mid = abs(ixs(1,ii))
491 pid = abs(ixs(10,ii))
492 jale_from_mat = nint(pm(72,mid)) !old way to enable ALE/EULER framework (backward compatibility)
493 jale_from_prop = igeo(62,pid) !new way to enable ALE/EULER framework
494 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
495 mln = nint(pm(19,mid))
496 IF(jale==0.AND.(mln==28.OR.mln==68))THEN
497 isolbar=isolbar+1
498 ENDIF
499 END DO
500C
501 DO ii = 1, numelq
502 IF((iquaoff(ii)==1.OR.iquaoff(ii)==3).AND.
503 * wd(ii+numels)/=0.0001)THEN
504 wd(ii+numels) = 0.0001
505 elemd = elemd + 1
506 END IF
507 END DO
508C
509 DO ii = 1, numelc
510 IF((isheoff(ii)==1.OR.isheoff(ii)==3).AND.
511 * wd(ii+numels+numelq)/=0.0001)THEN
512 wd(ii+numels+numelq) = 0.0001
513 elemd = elemd + 1
514 END IF
515 END DO
516C
517 DO ii = 1, numelt
518 IF((itruoff(ii)==3 ).AND.
519 * wd(ii+numels+numelq+numelc)/=0.0001 )THEN
520 wd(ii+numels+numelq+numelc) = 0.0001
521 elemd = elemd + 1
522 END IF
523 END DO
524C
525 DO ii = 1, numelp
526 IF((ipouoff(ii)==3 ).AND.
527 * wd(ii+numels+numelq+numelc+numelt)/=0.0001 )THEN
528 wd(ii+numels+numelq+numelc+numelt) = 0.0001
529 elemd = elemd + 1
530 END IF
531 END DO
532C
533 DO ii = 1, numelr
534 IF((iresoff(ii)==3 ).AND.
535 * wd(ii+numels+numelq+numelc+numelt+numelp)/=0.0001 )THEN
536 wd(ii+numels+numelq+numelc+numelt+numelp) = 0.0001
537 elemd = elemd + 1
538 END IF
539 END DO
540C
541 DO ii = 1, numeltg
542 IF(itrioff(ii)==1.AND.wd(ii+numels+numelq+numelc+numelt
543 . +numelp+numelr)/=0.0001)THEN
544 wd(ii+numels+numelq+numelc+numelt
545 . +numelp+numelr) = 0.0001
546 elemd = elemd + 1
547 END IF
548 END DO
549C
550C test to bypass creation of "deleted elem" level and avoid crash cases if elemd=1
551C
552 IF (nelem > 0) THEN
553 IF(float(nelem-elemd)/float(nelem)>zep95) elemd = 0
554 END IF
555 IF(iddlevel==0.AND.elemd>elemd_old) THEN
556 WRITE(iout,*)' '
557 WRITE(iout,'(A)')
558 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR ELEMENT DEACTIVATION'//
559 . ' IN /RBODY OPTIONS'
560 ENDIF
561C
562C-----------------------------------------------
563 IF (iddlevel==1) THEN
564 WRITE(iout,'(A)')' '
565 WRITE(iout,'(A)')
566 . ' --------------------------------------'
567 WRITE(iout,'(A)')
568 . ' NEW DOMAIN DECOMPOSITION FOR OPTIMIZATION'
569 WRITE(iout,'(A)')
570 . ' --------------------------------------'
571 ENDIF
572 WRITE(istdo,'(A)')' .. DOMAIN DECOMPOSITION'
573 WRITE(iout,'(A)')' '
574 IF(dectyp==3)THEN
575 WRITE(iout,'(A)')
576 . ' DOMAIN DECOMPOSITION USING MULTILEVEL KWAY'
577 ELSEIF(dectyp==4)THEN
578 WRITE(iout,'(A)')
579 . ' DOMAIN DECOMPOSITION USING MULTILEVEL RSB'
580 ELSEIF(dectyp==5)THEN
581 WRITE(iout,'(A)')
582 . ' DOMAIN DECOMPOSITION USING MULTILEVEL KWAY FOR IMPLICIT AND AMS'
583 ELSEIF(dectyp==4)THEN
584 WRITE(iout,'(A)')
585 . ' DOMAIN DECOMPOSITION USING MULTILEVEL RSB FOR IMPLICIT'
586 END IF
587 WRITE(iout,'(A)')
588 . ' ------------------------------------------'
589 IF (ipari0==1) THEN
590 WRITE(iout,'(A)')
591 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR PARALLEL ARITHMETIC ON'
592 ELSE
593 WRITE(iout,'(A)')
594 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR PARALLEL ARITHMETIC OFF'
595 ENDIF
596
597 IF(iddlevel == 1 .AND. ddnod_sms /= 0)THEN
598 WRITE(iout,'(A)')
599 . ' ADDITIONAL OPTIMIZATION OF DOMAIN DECOMPOSITION FOR AMS (DOMDEC=7)'
600 END IF
601C-----------------------------------------------
602C CNE CALCULATION
603C-----------------------------------------------
604C We have to tag elements for know theirs number of nodes
605 ALLOCATE(tagelem(nelem))
606 DO i = 1,nelem
607 tagelem(i)=0
608 END DO
609 DO i=1,numels
610 tagelem(i)=1
611 DO k=1,8
612 n = ixs(k+1,i)
613 IF(n /= 0) THEN
614 cne(adsky(n)) = i
615 adsky(n) = adsky(n) + 1
616 END IF
617 ENDDO
618 ENDDO
619C add Tetra10
620 IF(numels10>0) THEN
621 DO j=1,numels10
622 tagelem(abs(-(numels8+j)))=2
623 DO k=1,6
624 n = ixs10(k,j)
625 IF(n /= 0) THEN
626 cne(adsky(n)) = -(numels8+j) ! to treat extra node only for contacts
627 adsky(n) = adsky(n) + 1
628 ENDIF
629 ENDDO
630 ENDDO
631 ENDIF
632C
633C-----------------------------------------------
634C
635 offelem(1)=numels
636 off = numels
637C
638 DO i = 1, numelq
639 tagelem(i+off)=3
640 DO k=1,4
641 n = ixq(k+1,i)
642 cne(adsky(n)) = i+off
643 adsky(n) = adsky(n) + 1
644 ENDDO
645 ENDDO
646C
647 offelem(2)=numelq
648 off = off + numelq
649C
650 DO i = 1, numelc
651 tagelem(i+off)=4
652 DO k=1,4
653 n = ixc(k+1,i)
654 cne(adsky(n)) = i+off
655 adsky(n) = adsky(n) + 1
656 ENDDO
657 ENDDO
658C
659
660 offelem(3)=numelc
661 off = off + numelc
662C
663 DO i = 1, numelt
664 tagelem(i+off)=5
665 DO k=1,2
666 n = ixt(k+1,i)
667 cne(adsky(n)) = i+off
668 adsky(n) = adsky(n) + 1
669 ENDDO
670 ENDDO
671C
672 offelem(4)= numelt
673 off = off + numelt
674C
675 DO i = 1, numelp
676 tagelem(i+off)=6
677 DO k=1,2
678 n = ixp(k+1,i)
679 cne(adsky(n)) = i+off
680 adsky(n) = adsky(n) + 1
681 ENDDO
682 ENDDO
683C
684 offelem(5) = numelp
685 off = off + numelp
686C
687 DO i = 1, numelr
688 tagelem(i+off)=7
689 DO k=1,2
690 n = ixr(k+1,i)
691 cne(adsky(n)) = i+off
692 adsky(n) = adsky(n) + 1
693 ENDDO
694 IF(nint(geo(12,ixr(1,i)))==12) THEN
695 n = ixr(4,i)
696 cne(adsky(n)) = i+off
697 adsky(n) = adsky(n) + 1
698 ENDIF
699 ENDDO
700C
701 offelem(6)=numelr
702 off = off + numelr
703C
704 DO i = 1, numeltg
705 tagelem(i+off)=8
706 DO k=1,3
707 n = ixtg(k+1,i)
708 cne(adsky(n)) = i+off
709 adsky(n) = adsky(n) + 1
710 ENDDO
711 ENDDO
712C
713 offelem(7)=numeltg
714 off = off + numeltg
715
716C Old obsolete & removed element
717 offelem(8) = 0
718C
719 DO i=1, numelx
720 tagelem(i+off)=10
721 nelx=kxx(3,i)
722 DO k=1,nelx
723 addx = kxx(4,i)+k-1
724 n=ixx(addx)
725 cne(adsky(n)) = i+off
726 adsky(n) = adsky(n) + 1
727 ENDDO
728 ENDDO
729C
730 offelem(9)=numelx
731 off = off + numelx
732C
733 DO i=1, numelig3d
734 tagelem(i+off)=11
735 nelig3d=kxig3d(3,i)
736 DO k=1,nelig3d
737 addx = kxig3d(4,i)+k-1
738 n=ixig3d(addx)
739 cne(adsky(n)) = i+off
740 adsky(n) = adsky(n) + 1
741 ENDDO
742 ENDDO
743C
744 offelem(10)=numelig3d
745 off = off + numelig3d
746C
747C reset addresses to beginning
748 DO i=numnod+1,2,-1
749 adsky(i) = adsky(i-1)
750 END DO
751
752 adsky(1) = 1
753C Weight calculation taking into account connectivity ratio
754
755 icelem=1
756 icints=0
757 icintm=0
758 icint2=0
759 iccand=0
760 icnod_sms=0
761 icddl=0
762 icfsi=0
763 icsol=0
764 icdel=0
765 icr2r=0
766 ickin=0
767 ncond=1
768C
769 DO i = 1, nelemint
770 itypint=abs(inter_cand%IXINT(6,i))
771 IF(itypint == 2)THEN
772 icint2 = icint2+1
773 ELSEIF(itypint == 7 .OR. itypint == 11)THEN
774 icints = icints+1
775 icintm = icintm+1
776 iccand = iccand+1
777 ELSEIF(itypint == 24 .OR. itypint == 25)THEN
778 icints = icints+1
779 icintm = icintm+1
780 iccand = iccand+1
781 END IF
782 END DO
783C
784 IF(ddnod_sms/=0)THEN
785 ncond=ncond+1
786 icnod_sms=ncond
787 ELSE
788 icnod_sms=0
789 END IF
790C
791 IF(nelem > 0) THEN
792 IF((icints+icintm>100) .AND.
793 + (nelem < icints+icintm .OR.
794 + float(nelem-icints-icintm)/float(nelem)<=zep95)) THEN
795 ncond=ncond+1
796 icints=ncond
797 ncond=ncond+1
798 icintm=ncond
799 ELSE
800 IF(nsnt+nmnt>100) THEN
801 ncond=ncond+1
802 icints=ncond
803 ncond=ncond+1
804 icintm=ncond
805 ELSE
806 icints=0
807 icintm=0
808 ENDIF
809 END IF
810 IF((icint2>100) .AND.
811 + (nelem < icint2 .OR.
812 + float(nelem-icint2)/float(nelem)<=zep98)) THEN
813 ncond=ncond+1
814 icint2=ncond
815 ELSE
816 icint2=0
817 END IF
818C test bypass contact for small test cases
819 IF((iccand>100) .AND.
820 + (nelem < iccand .OR.
821 + float(nelem-iccand)/float(nelem)<=zep95)) THEN
822 ncond=ncond+1
823 iccand=ncond
824 ELSE
825 iccand=0
826 END IF
827 ELSE ! nelem = 0 (full sph)
828 icints = 0
829 icintm = 0
830 icint2 = 0
831 iccand = 0
832 ENDIF
833C
834 nk=0
835c IF(NK > 0) THEN ! Test To bypass load-balancing of Kin.Cond. temporarily
836 IF(elemd == 0) THEN ! Test To bypass load-balancing of Kin.Cond. if element deletion already active (large RB)
837 DO i = 1, numnod
838c NKI=IWL(IKINE(I))+2*IRB(IKINE(I))+2*IRB2(IKINE(I))
839c + +2*IRBM(IKINE(I))+2*IRLK(IKINE(I))+2*IJO(IKINE(I))
840c + +2*IKRBE2(IKINE(I))+2*IKRBE3(IKINE(I))
841c IWKIN(I)=NKI
842c NK = NK+NKI
843 nki=iwl(ikine(i))+irb(ikine(i))+irb2(ikine(i))
844 + +irbm(ikine(i))+irlk(ikine(i))+ijo(ikine(i))
845 + +ikrbe2(ikine(i))+ikrbe3(ikine(i))
846 iwkin(i)=nki
847 nk = nk+min(nki,1)
848 END DO
849c print *,'n cond=',NK,FLOAT(NUMNOD-NK)/FLOAT(NUMNOD)
850 IF(float(numnod-nk)/float(numnod)>zep95) nk = 0
851 IF(nk > 20000) THEN ! needs a sufficient number of kin.cond.
852 ncond = ncond+1
853 ickin = ncond
854 END IF
855 END IF
856C
857 IF(dectyp==5.OR.dectyp==6)THEN
858C weight permutation element <=> dof
859 ncond = ncond+1
860 icddl=1
861 icelem=ncond
862 IF(elemd>0) THEN
863 ncond = ncond+1
864 icdel = ncond
865 END IF
866
867 ELSE
868 IF(ilag==1.AND.(iale==1.OR.ieuler==1))THEN
869C if FSI
870 ncond = ncond+1
871 nb_elem_ale = 0
872 DO i = 1, numels
873 mid = abs(ixs(1,i))
874 pid = abs(ixs(10,i))
875 jale_from_mat = nint(pm(72,mid)) !old way to enable ALE/EULER framework (backward compatibility)
876 jale_from_prop = igeo(62,pid) !new way to enable ALE/EULER framework
877 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader MLN = NINT(PM(19,MID))
878 IF(jale==0.AND.mln/=18)THEN
879
880 ELSE
881 nb_elem_ale = nb_elem_ale + 1
882 END IF
883 ENDDO
884
885 IF (nelem - nb_elem_ale < 128 * nspmd) THEN
886C Priority is FSI
887 icfsi = 1
888 icelem = ncond
889 WRITE(iout,'(A)')
890 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR ALE (1)'
891 ELSEIF( nb_elem_ale*2 > nelem ) THEN
892C Priority is FSI then ELEM
893 icfsi = 1
894 icelem = 2
895 IF(icddl/=0) icddl = icddl + 1
896 IF(icints/=0) icints = icints + 1
897 IF(icintm/=0) icintm = icintm + 1
898 IF(icint2/=0) icint2 = icint2 + 1
899 IF(ickin/=0) ickin = ickin + 1
900 IF(icnod_sms/=0) icnod_sms = icnod_sms +1
901 IF(icdel/=0) icdel = icdel + 1
902 IF(iccand/=0) iccand = iccand + 1
903 WRITE(iout,'(A)')
904 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR ALE (2)'
905 ELSEIF ( nb_elem_ale*4 > nelem) THEN
906C Priority is ELEM then FSI
907 icfsi = 2
908 icelem = 1
909 IF(icddl/=0) icddl = icddl + 1
910 IF(icints/=0) icints = icints + 1
911 IF(icintm/=0) icintm = icintm + 1
912 IF(icint2/=0) icint2 = icint2 + 1
913 IF(ickin/=0) ickin = ickin + 1
914 IF(icnod_sms/=0) icnod_sms = icnod_sms +1
915 IF(icdel/=0) icdel = icdel + 1
916 IF(iccand/=0) iccand = iccand + 1
917 WRITE(iout,'(A)')
918 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR FSI (3)'
919 ELSE
920 icfsi = ncond
921 END IF
922 END IF
923 IF(isolbar > 10000 .AND. icfsi == 0 .AND. numelc > numels)THEN
924C if more than 10K solid law28/LAW68, decompose solid like there is a barrier
925C IF(IDDLEVEL==1.) THEN
926 WRITE(iout,'(A)')
927 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR BARRIER '
928C ENDIF
929 ncond = ncond+1
930 icsol=ncond
931 END IF
932 IF(elemd>0) THEN
933 ncond = ncond+1
934 icdel = ncond
935 END IF
936 END IF
937 IF(nsubdom>0)THEN
938 numel_r2r = 0
939 DO i = 1, numels
940 IF (tag_elsf(i) /= 0) numel_r2r = numel_r2r+1
941 END DO
942 DO i = 1, numelc
943 IF (tag_elcf(i) /= 0) numel_r2r = numel_r2r+1
944 END DO
945 IF (numel_r2r>=nspmd) THEN
946 WRITE(iout,'(A)')
947 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR MULTIDOMAINS '
948 ncond = ncond+1
949 icr2r=ncond
950 ENDIF
951 END IF
952C
953 ALLOCATE(rwd(nelem*ncond),stat=ierr1)
954C Metis weights following
955 DO i = 1, ncond*nelem
956 rwd(i) = 0
957 ENDDO
958C default weight optimization
959 CALL initwg(wd,pm,geo,ixs,ixq,
960 . ixc,ixt,ixp,ixr,ixtg,
961 . kxx,igeo,isolnod,iarch,
962 . numels,numelq,numelc,numelt,numelp,
963 . numelr,numeltg,numelx,ipm,
964 . bufmat,nummat,numgeo,taille,poin_ump,
965 . tab_ump,poin_ump_old,tab_ump_old,cputime_mp_old,
966 . tabmp_l,ipart,ipartc,ipartg,
967 . iparts,npart,poin_part_shell,poin_part_tri,poin_part_sol,
968 . mid_pid_shell,mid_pid_tri,mid_pid_sol,iddlevel,
969 . mat_param)
970C
971 IF(nsubdom>0)THEN
972 cost_r2r = zero
973 DO i=1,nelem
974 scal = one
975 IF (i<=numels) THEN
976 mid = abs(ixs(1,i))
977 pid = abs(ixs(10,i))
978 jale_from_mat = nint(pm(72,mid)) !new way to enable ALE/EULER framework (backward compatibility)
979 jale_from_prop = igeo(62,pid) !old way to enable ALE/EULER framework
980 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
981 mln = nint(pm(19,mid))
982 IF (jale/=0) scal = 2.5
983 IF (mln==51) scal = 4.5
984 ENDIF
985 cost_r2r = cost_r2r + wd(i)
986 END DO
987 ENDIF
988C
989 DO i=1,numels
990 nnc=0
991 IF ((icr2r /= 0)) THEN
992 IF((tag_elsf(i) /= 0))THEN
993 rwd(ncond*(i-1)+icr2r) = 1
994 ENDIF
995 ENDIF
996 IF(icsol /= 0) rwd(ncond*(i-1)+icsol) = 1
997 IF(isolnod(i)==4.OR.isolnod(i)==10)THEN
998 DO k=1,8
999 n = ixs(k+1,i)
1000 IF(n/=0)THEN
1001 fac=one/(adsky(n+1)-adsky(n))
1002 nnc = nnc+adsky(n+1)-adsky(n)
1003 IF(icddl/=0)rwd(ncond*(i-1)+icddl)=rwd(ncond*(i-1)+icddl)
1004 + +dsdof(n)*fac
1005 IF(icints/=0)
1006 + rwd(ncond*(i-1)+icints)=rwd(ncond*(i-1)+icints)
1007 + +iwcont(1,n)*fac
1008 IF(icintm/=0)
1009 + rwd(ncond*(i-1)+icintm) = rwd(ncond*(i-1)+icintm)
1010 + + iwcont(2,n)*fac
1011 IF(icint2/=0)
1012 + rwd(ncond*(i-1)+icint2)=rwd(ncond*(i-1)+icint2)
1013 + +(iwcin2(1,n)+iwcin2(2,n))*fac
1014 IF(ickin/=0)rwd(ncond*(i-1)+ickin)=rwd(ncond*(i-1)+ickin)
1015 + +iwkin(n)*fac
1016 IF(icnod_sms/=0)rwd(ncond*(i-1)+icnod_sms)=rwd(ncond*(i-1)+icnod_sms)
1017 + +min(dsdof(n),1)*fac
1018 END IF
1019 END DO
1020 IF(isolnod(i)==10)THEN
1021 ii = i-numels8
1022 DO k=1,6
1023 n = ixs10(k,ii)
1024 IF(n/=0)THEN
1025C take care of non connected node
1026 fac=one/max(adsky(n+1)-adsky(n),1)
1027 nnc = nnc+adsky(n+1)-adsky(n)
1028 IF(icddl/=0)rwd(ncond*(i-1)+icddl)=rwd(ncond*(i-1)+icddl)
1029 + +dsdof(n)*fac
1030 IF(icints/=0)
1031 + rwd(ncond*(i-1)+icints)=rwd(ncond*(i-1)+icints)
1032 + +iwcont(1,n)*fac
1033 IF(icintm/=0)
1034 + rwd(ncond*(i-1)+icintm) = rwd(ncond*(i-1)+icintm)
1035 + + iwcont(2,n)*fac
1036 IF(icint2/=0)
1037 + rwd(ncond*(i-1)+icint2)=rwd(ncond*(i-1)+icint2)
1038 + +(iwcin2(1,n)+iwcin2(2,n))*fac
1039 IF(ickin/=0)rwd(ncond*(i-1)+ickin)=rwd(ncond*(i-1)+ickin)
1040 + +iwkin(n)*fac
1041 IF(icnod_sms/=0)rwd(ncond*(i-1)+icnod_sms)=rwd(ncond*(i-1)+icnod_sms)
1042 + +min(dsdof(n),1)*fac
1043 ENDIF
1044 ENDDO
1045cc IF(ICNOD /= 0) RWD(NCOND*(I-1)+ICNOD) = ONE ! to define if needed
1046 ELSE
1047cc IF(ICNOD /= 0) RWD(NCOND*(I-1)+ICNOD) = ONE/FIVE ! to define if needed
1048 ENDIF
1049 ELSE
1050 DO k=1,8
1051 n = ixs(k+1,i)
1052 IF(n/=0)THEN
1053C take care of non connected node
1054 fac=one/max(adsky(n+1)-adsky(n),1)
1055 nnc = nnc+adsky(n+1)-adsky(n)
1056 IF(icddl/=0)rwd(ncond*(i-1)+icddl)=rwd(ncond*(i-1)+icddl)
1057 + +dsdof(n)*fac
1058 IF(icints/=0)
1059 + rwd(ncond*(i-1)+icints)=rwd(ncond*(i-1)+icints)
1060 + +iwcont(1,n)*fac
1061 IF(icintm/=0)
1062 + rwd(ncond*(i-1)+icintm) = rwd(ncond*(i-1)+icintm)
1063 + + iwcont(2,n)*fac
1064 IF(icint2/=0)
1065 + rwd(ncond*(i-1)+icint2)=rwd(ncond*(i-1)+icint2)
1066 + +(iwcin2(1,n)+iwcin2(2,n))*fac
1067 IF(ickin/=0)rwd(ncond*(i-1)+ickin)=rwd(ncond*(i-1)+ickin)
1068 + +iwkin(n)*fac
1069 IF(icnod_sms/=0)rwd(ncond*(i-1)+icnod_sms)=rwd(ncond*(i-1)+icnod_sms)
1070 + +min(dsdof(n),1)*fac
1071 END IF
1072 ENDDO
1073cc IF(ICNOD /= 0) RWD(NCOND*(I-1)+ICNOD) = (EIGHT*EIGHT)/NNC
1074 ENDIF
1075 ENDDO
1076C
1077C-----------------------------------------------
1078C
1079 off = numels
1080C interface weight = 0 in 2D
1081C
1082 off = off + numelq
1083C
1084 DO i = 1, numelc
1085 nnc=0
1086 IF (icr2r /= 0) THEN
1087 IF (tag_elcf(i) /= 0) THEN
1088 rwd(ncond*(i+off-1)+icr2r) = 1
1089 ENDIF
1090 ENDIF
1091 DO k=1,4
1092 n = ixc(k+1,i)
1093 IF(n/=0)THEN
1094 fac=one/(adsky(n+1)-adsky(n))
1095 nnc = nnc+adsky(n+1)-adsky(n)
1096 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1097 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1098 IF(icints/=0)
1099 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1100 + + iwcont(1,n)*fac
1101 IF(icintm/=0)
1102 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1103 + + iwcont(2,n)*fac
1104 IF(icint2/=0)
1105 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1106 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1107 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1108 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1109 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1110 + +min(dsdof(n),1)*fac
1111 END IF
1112 ENDDO
1113cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD)=(FOUR*FOUR)/NNC
1114 ENDDO
1115C
1116 off = off + numelc
1117C
1118 DO i = 1, numelt
1119 nnc=0
1120 DO k=1,2
1121 n = ixt(k+1,i)
1122 IF(n/=0)THEN
1123 fac=one/(adsky(n+1)-adsky(n))
1124 nnc = nnc+adsky(n+1)-adsky(n)
1125 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1126 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1127 IF(icints/=0)
1128 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1129 + + iwcont(1,n)*fac
1130 IF(icintm/=0)
1131 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1132 + + iwcont(2,n)*fac
1133 IF(icint2/=0)
1134 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1135 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1136 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1137 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1138 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1139 + +min(dsdof(n),1)*fac
1140 END IF
1141 ENDDO
1142cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = (TWO*TWO)/NNC
1143 ENDDO
1144C
1145 off = off + numelt
1146C
1147 DO i = 1, numelp
1148 nnc=0
1149 DO k=1,2
1150 n = ixp(k+1,i)
1151 IF(n/=0)THEN
1152 fac=one/(adsky(n+1)-adsky(n))
1153 nnc = nnc+adsky(n+1)-adsky(n)
1154 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1155 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1156 IF(icints/=0)
1157 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1158 + + iwcont(1,n)*fac
1159 IF(icintm/=0)
1160 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1161 + + iwcont(2,n)*fac
1162 IF(icint2/=0)
1163 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1164 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1165 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1166 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1167 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1168 + +min(dsdof(n),1)*fac
1169 END IF
1170 ENDDO
1171cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = (TWO*TWO)/NNC
1172 ENDDO
1173C
1174 off = off + numelp
1175C
1176 DO i = 1, numelr
1177 nnc=0
1178 DO k=1,2
1179 n = ixr(k+1,i)
1180 IF(n/=0)THEN
1181 fac=one/(adsky(n+1)-adsky(n))
1182 nnc = nnc+adsky(n+1)-adsky(n)
1183 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1184 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1185 IF(icints/=0)
1186 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1187 + + iwcont(1,n)*fac
1188 IF(icintm/=0)
1189 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1190 + + iwcont(2,n)*fac
1191 IF(icint2/=0)
1192 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1193 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1194 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1195 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1196 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1197 + +min(dsdof(n),1)*fac
1198 END IF
1199 ENDDO
1200 IF(nint(geo(12,ixr(1,i)))==12) THEN
1201 n = ixr(4,i)
1202 IF(n/=0)THEN
1203 fac=one/(adsky(n+1)-adsky(n))
1204 nnc = nnc+adsky(n+1)-adsky(n)
1205 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1206 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1207 IF(icints/=0)
1208 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1209 + + iwcont(1,n)*fac
1210 IF(icintm/=0)
1211 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1212 + + iwcont(2,n)*fac
1213 IF(icint2/=0)
1214 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1215 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1216 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1217 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1218 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1219 + +min(dsdof(n),1)*fac
1220 END IF
1221 ENDIF
1222cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = (TWO*TWO)/NNC
1223 ENDDO
1224C
1225 off = off + numelr
1226C
1227 DO i = 1, numeltg
1228 nnc=0
1229 DO k=1,3
1230 n = ixtg(k+1,i)
1231 IF(n/=0)THEN
1232 fac=one/(adsky(n+1)-adsky(n))
1233 nnc = nnc+adsky(n+1)-adsky(n)
1234 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1235 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1236 IF(icints/=0)
1237 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1238 + + iwcont(1,n)*fac
1239 IF(icintm/=0)
1240 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1241 + + iwcont(2,n)*fac
1242 IF(icint2/=0)
1243 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1244 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1245 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1246 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1247 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1248 + +min(dsdof(n),1)*fac
1249 END IF
1250 ENDDO
1251cc IF(ICNOD /= 0)
1252cc + RWD(NCOND*(I+OFF-1)+ICNOD) = (ONE/TWO)*(SIX*THREE)/NNC
1253 ENDDO
1254C
1255 off = off + numeltg
1256C
1257 DO i=1, numelx
1258 nelx=kxx(3,i)
1259 nnc=0
1260 DO k=1,nelx
1261 addx = kxx(4,i)+k-1
1262 n=ixx(addx)
1263 IF(n/=0)THEN
1264 fac=one/(adsky(n+1)-adsky(n))
1265 nnc = nnc+adsky(n+1)-adsky(n)
1266 IF(icddl/=0)rwd(ncond*(i+off-1)+icddl) =
1267 + rwd(ncond*(i+off-1)+icddl) + dsdof(n)*fac
1268 IF(icints/=0)
1269 + rwd(ncond*(i+off-1)+icints) = rwd(ncond*(i+off-1)+icints)
1270 + + iwcont(1,n)*fac
1271 IF(icintm/=0)
1272 + rwd(ncond*(i+off-1)+icintm) = rwd(ncond*(i+off-1)+icintm)
1273 + + iwcont(2,n)*fac
1274 IF(icint2/=0)
1275 + rwd(ncond*(i+off-1)+icint2) = rwd(ncond*(i+off-1)+icint2)
1276 + + (iwcin2(1,n)+iwcin2(2,n))*fac
1277 IF(ickin/=0)rwd(ncond*(i+off-1)+ickin)=
1278 + rwd(ncond*(i+off-1)+ickin) + iwkin(n)*fac
1279 IF(icnod_sms/=0)rwd(ncond*(i+off-1)+icnod_sms)=rwd(ncond*(i+off-1)+icnod_sms)
1280 + +min(dsdof(n),1)*fac
1281 END IF
1282 ENDDO
1283cc IF(ICNOD /= 0) RWD(NCOND*(I+OFF-1)+ICNOD) = ONE ! to be defined if needed
1284 ENDDO
1285C
1286 off = off + numelx
1287
1288C interface & dof weight normalization
1289
1290 ALLOCATE(iwd(nelem*ncond),stat=ierr1)
1291
1292 DO i = 1, ncond*nelem
1293 iwd(i) = 0
1294 ENDDO
1295 DO i = 1, nelem
1296C no longer need normalization to 1
1297 IF(icints/=0)
1298 . iwd(ncond*(i-1)+icints) = nint(rwd(ncond*(i-1)+icints))
1299 IF(icintm/=0)
1300 . iwd(ncond*(i-1)+icintm) = nint(rwd(ncond*(i-1)+icintm))
1301 IF(iccand/=0)
1302 . iwd(ncond*(i-1)+iccand) = nint(rwd(ncond*(i-1)+iccand))
1303 IF(icint2/=0)
1304 . iwd(ncond*(i-1)+icint2) = nint(rwd(ncond*(i-1)+icint2))
1305 IF(icddl/=0)
1306 . iwd(ncond*(i-1)+icddl)= nint(rwd(ncond*(i-1)+icddl))
1307 IF(icsol/=0)
1308 . iwd(ncond*(i-1)+icsol)= nint(rwd(ncond*(i-1)+icsol))
1309 IF(ickin/=0)
1310 . iwd(ncond*(i-1)+ickin)= nint(rwd(ncond*(i-1)+ickin))
1311 IF(icr2r/=0)
1312 . iwd(ncond*(i-1)+icr2r)= nint(rwd(ncond*(i-1)+icr2r))
1313c IF(ICNOD/=0)
1314c . IWD(NCOND*(I-1)+ICNOD)= NINT(RWD(NCOND*(I-1)+ICNOD)*10)
1315 IF(icnod_sms/=0)
1316 . iwd(ncond*(i-1)+icnod_sms) = nint(rwd(ncond*(i-1)+icnod_sms))
1317 END DO
1318
1319 DEALLOCATE(rwd)
1320
1321C.....construction of Ei Ej pairs connected by a point
1322
1323 nedges = 0
1324 DO n = 1, numnod
1325 DO cc1 = adsky(n), adsky(n+1)-1
1326 numg1 = cne(cc1)
1327 IF(numg1 > 0) THEN ! by-pass extra nodes
1328 DO cc2 = cc1+1, adsky(n+1)-1
1329 numg2 = cne(cc2)
1330 IF(numg2 > 0 .AND. numg1 /= numg2) THEN ! by-pass extra nodes
1331 nedges = nedges + 1
1332 END IF
1333 ENDDO
1334 END IF
1335 ENDDO
1336 ENDDO
1337C
1338 IF (iddlevel==1) nedges = nedges+nelemint
1339C
1340C----------------------------------------------
1341! SIDDCONNECT minimum size NELEM. Value set to 10*NELEM
1342 IF(nelem < 100 000 000) THEN
1343 siddconnect = 2*10*nelem
1344 ELSE
1345 ! For very large model
1346 ! edge filtering is forced
1347 siddconnect = 2 000 000 000
1348 edge_filtering = 1
1349 ENDIF
1350! Linked-list IDDCONNECT
1351! IDDCONNECT%IENTRYDOM : entry in IDDCONNECT for element N
1352! IDDCONNECT%PDOM(1,N) : connected element to element N
1353! IDDCONNECT%PDOM(2,N) : next index in IDDCONNECT for element N
1354! allocation iddconnect % PDOM et % IENTRYDOM
1355 ALLOCATE(iddconnect%PDOM(2,siddconnect),stat=ierr1)
1356 ALLOCATE(iddconnect%IENTRYDOM(2,nelem),stat=ierr1)
1357! initialization of IDDCONNECT%IENTRYDOM
1358 CALL ini_iddconnect(nelem)
1359C
1360 nedges_old = nedges
1361
1362 IF(edge_filtering == 1 .AND. (numels > nelem / 3 .OR. icfsi > 0 )) THEN
1363 WRITE(iout,'(A)') "** INFO: SIMPLIFIED DOMAIN DECOMPOSITION"
1364C+------------------------------------------------------------+
1365C| Domain decomposition for models with solids |
1366C| dectivated via Domdec = -3 in /SPMD card |
1367C+------------------------------------------------------------+
1368 ALLOCATE(connectivity(max_nb_nodes_per_elt,nelem))
1369 ALLOCATE(nb_nodes_mini(nelem)) ! minimum number of shared nodes to consider the edge
1370 connectivity(1:max_nb_nodes_per_elt,1:nelem) = 0
1371 nb_nodes_mini(1:nelem) = 3
1372 DO i = 1 , nelem
1373 CALL find_nodes(i ,connectivity(1,i),tagelem,ixs,ixs10,
1374 1 ixq ,ixc ,ixt ,ixp,ixr,
1375 2 ixtg ,kxx ,ixx,kxig3d,
1376 3 ixig3d,geo ,offelem,nb_nodes_mini(i))
1377 CALL sort_descending(connectivity(1,i))
1378 ENDDO
1379
1380 ALLOCATE(connect_weight(nelem))
1381 ALLOCATE(pointer_neigh(nelem))
1382 DO i =1,nelem
1383 connect_weight(i)=0
1384 pointer_neigh(i)=0
1385 ENDDO
1386 nelmin = 0
1387 DO i = 1 , nelem
1388 nelmin = nb_nodes_mini(i)
1389 elemnodes(1:max_nb_nodes_per_elt) = connectivity(1:max_nb_nodes_per_elt,i)
1390 prev_neigh = 0
1391 c_neigh = 0
1392 j = 0
1393 DO k=1,max_nb_nodes_per_elt
1394 IF ( elemnodes(k)/=0 ) THEN
1395 DO l=adsky(elemnodes(k)), adsky(elemnodes(k)+1)-1
1396 IF( cne(l) > 0 .AND. cne(l) > i) THEN
1397 connect_weight(cne(l)) =
1398 . connect_weight(cne(l)) + 1
1399 IF( connect_weight(cne(l)) == 1 ) THEN
1400 pointer_neigh(cne(l))=prev_neigh
1401 c_neigh = c_neigh + 1
1402 prev_neigh = cne(l)
1403 ENDIF
1404 ENDIF
1405 ENDDO
1406 j=j+1
1407 ENDIF
1408 ENDDO
1409 ! if NELMIN is not defined by FIND_NODES, we keep edges
1410 ! between elements that have 3 or more nodes in common
1411 IF(nelmin == 0) nelmin = 3
1412 IF (c_neigh > 0 ) THEN
1413 DO j=1,c_neigh
1414 IF(i /= prev_neigh) THEN
1415 IF(consider_edge(connectivity,nb_nodes_mini,nelem,i,prev_neigh)) THEN
1416 CALL iddconnectplus(i,prev_neigh,nelem)
1417 CALL iddconnectplus(prev_neigh,i,nelem)
1418 ENDIF
1419 ENDIF
1420 point_delete=prev_neigh
1421 prev_neigh = pointer_neigh(prev_neigh)
1422 pointer_neigh(point_delete) = 0
1423 connect_weight(point_delete) = 0
1424 ENDDO
1425 ENDIF
1426 ENDDO
1427 DEALLOCATE(connect_weight)
1428 DEALLOCATE(pointer_neigh)
1429 DEALLOCATE(nb_nodes_mini)
1430 DEALLOCATE(connectivity)
1431
1432 ELSE
1433C+------------------------------------------------------------+
1434C| Classical domain decomposition without edge filtering |
1435C+------------------------------------------------------------+
1436 DO n = 1, numnod
1437 DO cc1 = adsky(n), adsky(n+1)-1
1438 numg1 = cne(cc1)
1439 IF(numg1 > 0) THEN ! by-pass extra nodes
1440 DO cc2 = cc1+1, adsky(n+1)-1
1441 numg2 = cne(cc2)
1442 IF(numg2 > 0 .AND. numg1 /= numg2) THEN ! by-pass extra nodes
1443 CALL iddconnectplus(numg1,numg2,nelem)
1444 CALL iddconnectplus(numg2,numg1,nelem)
1445 END IF
1446 ENDDO
1447 END IF
1448 ENDDO
1449 ENDDO
1450 ENDIF !(EDGE_FILTERING == 0 )
1451
1452 nedges = 0
1453 nedges_8 = 0
1454 DO i=1,nelem
1455 CALL c_iddconnect(i,taille_local)
1456 nedges = nedges + taille_local
1457 nedges_8 = nedges_8 + taille_local
1458 ENDDO
1459 nedges = nedges/2
1460
1461
1462C DEALLOCATE(TAGELEM)
1463 IF (iddlevel==1) THEN
1464C-----------------------------------------------
1465C by pass of tools tools
1466C-----------------------------------------------
1467 iwarn1 = 0
1468 DO i = 1, nelem
1469 IF(ielem21(i)==1)THEN
1470 IF(wd(i)>0.01)THEN
1471 iwarn1 = 1
1472 END IF
1473 END IF
1474 END DO
1475 IF(iwarn1/=0)THEN
1476 WRITE(iout,*)' '
1477 WRITE(iout,'(A)')
1478 . ' ONE OR MORE ELEMENT OF MAIN SIDE OF INTERF. TYPE21',
1479 . ' NEEDS TO BE DEACTIVATED'
1480 END IF
1481
1482C=======================================================================
1483C FVMBAG Super ELEMENT Connectivity
1484C=======================================================================
1485 wd_max = 0
1486 IF(nvolu > 0 .AND. iddlevel == 1 .AND. icfsi == 0) THEN
1487 CALL fvbag_vertex(ixc ,ixtg ,nelem, wd,
1488 . wd_max,fvm_elem,fvm_domdec,itab,igrsurf,t_monvol)
1489 ENDIF
1490
1491
1492C-----------------------------------------------
1493C CONNECTIVITES INTERFACES
1494C-----------------------------------------------
1495C
1496C only add a connectivity between node and facet
1497C
1498C Avoid conflict between type 2 and type 7
1499C
1500C CEP temporarily used as flag
1501 DO i = 1, nelem
1502 cep(i) = 0
1503 ENDDO
1504C
1505 DO i = 1, nelemint ! Loop over the the pair of candidates
1506 n=inter_cand%IXINT(5,i) !N is the secondary node
1507 IF (n<=numnod) THEN !
1508 numg1=abs(cne(adsky(n))) ! NUMG1 is the first element found connected to node N
1509 numg2=numg1
1510 itypint=abs(inter_cand%IXINT(6,i))
1511 IF(itypint==2) THEN ! Type 2 interface (tied contact)
1512 IF(adsky(n+1)-adsky(n)>0)THEN ! number of elements connected to node N
1513 n=inter_cand%IXINT(1,i) ! 1st node of the main segment
1514 n1=inter_cand%IXINT(2,i) ! 2nd node of the main segment
1515 n2=inter_cand%IXINT(3,i) ! 3td ode of the main segment
1516 DO i1 = adsky(n), adsky(n+1)-1 ! loop over the elements connected to node N
1517 numg2=abs(cne(i1)) ! NUMG2 = id of the current element connected to node N
1518 DO i2 = adsky(n1), adsky(n1+1)-1 ! loop over elts connected to N1
1519 numg3=abs(cne(i2))
1520 IF(numg3==numg2) THEN
1521 DO i3 = adsky(n2), adsky(n2+1)-1
1522 numg4=abs(cne(i3))
1523 IF(numg4==numg2) GOTO 100 !Found one element connected to N,N1,N2
1524 ENDDO
1525 ENDIF
1526 ENDDO
1527 ENDDO
1528 100 CONTINUE
1529 IF(numg1 /= numg2) THEN
1530 CALL iddconnectplus(numg1,numg2,nelem)
1531 CALL iddconnectplus(numg2,numg1,nelem)
1532 cep(numg1) = 1
1533 cep(numg2) = 1
1534 ENDIF
1535 ENDIF
1536 ENDIF
1537 ENDIF
1538 ENDDO
1539
1540
1541 IF(iccand > 0) THEN
1542 DO n = 1,numnod
1543 IF( iwcont(4,n) > 0) THEN
1544 DO i1 = adsky(n), adsky(n+1)-1
1545 numg2=abs(cne(i1))
1546 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+iwcont(4,n)
1547 ENDDO
1548 ENDIF
1549 ENDDO
1550 ENDIF
1551
1552
1553
1554 ALLOCATE(isort(nelemint))
1555 ALLOCATE(index_sort(2*nelemint))
1556
1557C sorting of NELEMINT : negative value for IXINT(6) means that distance is small
1558 DO i=1,nelemint
1559 isort(i)=(-inter_cand%IXINT(6,i)) + 100
1560 index_sort(i)=i
1561 itypint=abs(inter_cand%IXINT(6,i))
1562 ENDDO
1563 CALL my_orders(0,work,isort,index_sort,nelemint,1)
1564
1565
1566C
1567C hierarchy : type 2 before, contact now
1568 DO ii = 1, nelemint
1569 i = index_sort(ii)
1570 n=inter_cand%IXINT(5,i)
1571 IF (n<=numnod) THEN ! FOR ISOGEOMETRIC ELEMENTS (FICTITIOUS PART NOT TO BE CONSIDERED)
1572 numg1=-1
1573C searching for the first connected element not seen
1574 cep_min = huge(cep_min)
1575 DO i1 = adsky(n), adsky(n+1)-1
1576 numg3=abs(cne(i1))
1577 IF(cep_min > cep(numg3)) THEN
1578 numg1 = numg3
1579 cep_min = cep(numg1)
1580 ENDIF
1581 IF(cep_min == 0) EXIT
1582 END DO
1583C initialization numg2 for case where facet not found (error)
1584 numg2=-1
1585 itypint=abs(inter_cand%IXINT(6,i))
1586 IF(itypint==7) THEN
1587 IF(adsky(n+1)-adsky(n)>0)THEN
1588 n=inter_cand%IXINT(1,i)
1589 n1=inter_cand%IXINT(2,i)
1590 n2=inter_cand%IXINT(3,i)
1591 IF (n<=numnod) THEN ! FOR ISOGEOMETRIC ELEMENTS (FICTITIOUS PART NOT TO BE CONSIDERED)
1592 DO i1 = adsky(n), adsky(n+1)-1
1593 numg2=abs(cne(i1))
1594 IF(numg2 == numg1) THEN
1595 GOTO 107
1596! Avoid adding edges between element already connected
1597 ELSE
1598 DO i2 = adsky(n1), adsky(n1+1)-1
1599 numg3=abs(cne(i2))
1600 IF(numg3 == numg1) GOTO 107
1601 IF(numg3==numg2) THEN
1602 DO i3 = adsky(n2), adsky(n2+1)-1
1603 numg4=abs(cne(i3))
1604 IF(numg4 == numg1) GOTO 107
1605 IF(numg4==numg2) GOTO 107
1606 ENDDO
1607 ENDIF
1608 ENDDO
1609 END IF
1610 ENDDO
1611 ENDIF
1612 107 CONTINUE
1613
1614 IF(numg1 /= numg2 .AND. (numg1 >0 ) .AND. (numg2 > 0)) THEN
1615 IF(cep(numg1)==0.OR.cep(numg2)==0) THEN
1616 number_of_added_edges = number_of_added_edges + 1
1617C test to limit number of edges added for contact interfaces
1618 IF(cep(numg1) < 100 .AND. cep(numg2) < 100) THEN
1619 CALL iddconnectplus(numg1,numg2,nelem)
1620 CALL iddconnectplus(numg2,numg1,nelem)
1621 cep(numg1) = cep(numg1) + 1
1622 cep(numg2) = cep(numg2) + 1
1623 END IF
1624 ELSE
1625 refused_cep0 = refused_cep0 + 1
1626 ENDIF
1627 ELSE
1628 if(numg1 == numg2) refused_numg = refused_numg + 1
1629 if(numg1<=0 .OR. numg2<=0) refused_numg0 = refused_numg0 + 1
1630
1631 ENDIF
1632 IF(iccand > 0 .AND. numg2 > 0) THEN
1633C load-balancing contact force -- incremental needed for multiple interface
1634cc IWD(NCOND*(NUMG2-1)+ICCAND)=IWD(NCOND*(NUMG2-1)+ICCAND)+1
1635 IF(inter_cand%IXINT(6,i)<0)THEN
1636C 5:1 ratio between potential impact and just candidat
1637 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+5
1638 ELSE
1639 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1640 ENDIF
1641 END IF
1642
1643 ENDIF
1644 ELSEIF(itypint==11) THEN
1645 IF(adsky(n+1)-adsky(n)>0)THEN
1646 n1=inter_cand%IXINT(3,i)
1647 n2=inter_cand%IXINT(4,i)
1648 DO i1 = adsky(n1), adsky(n1+1)-1
1649 numg2=abs(cne(i1))
1650 IF(numg2 /= numg1) THEN
1651 DO i2 = adsky(n2), adsky(n2+1)-1
1652 numg3=abs(cne(i2))
1653 IF(numg3==numg2) GOTO 111
1654 ENDDO
1655 END IF
1656 ENDDO
1657 111 CONTINUE
1658 IF(numg1 /= numg2 .AND.(numg1>0 .AND. numg2 > 0)) THEN
1659 IF(cep(numg1)==0.OR.cep(numg2)==0) THEN
1660C test to limit number of edges added for contact interfaces
1661 number_of_added_edges = number_of_added_edges + 1
1662 IF(cep(numg1) < 100 .AND. cep(numg2) < 100) THEN
1663 CALL iddconnectplus(numg1,numg2,nelem)
1664 CALL iddconnectplus(numg2,numg1,nelem)
1665 cep(numg1) = cep(numg1) + 1
1666 cep(numg2) = cep(numg2) + 1
1667 END IF
1668 ELSE
1669 refused_cep0 = refused_cep0 + 1
1670 ENDIF
1671 ELSE
1672 if(numg1 == numg2) refused_numg = refused_numg + 1
1673 if(numg1<=0 .OR. numg2<=0) refused_numg0 = refused_numg0 + 1
1674 ENDIF
1675 IF(iccand > 0 .AND. numg2 > 0) THEN
1676C load-balancing contact force -- incremental needed for multiple interface
1677 IF(inter_cand%IXINT(6,i)<0)THEN
1678 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1679 ELSE
1680 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1681 ENDIF
1682 END IF
1683
1684 ENDIF
1685 ELSEIF(itypint==24.OR.itypint==25)THEN
1686 IF(adsky(n+1)-adsky(n)>0)THEN
1687 n=inter_cand%IXINT(1,i)
1688 n1=inter_cand%IXINT(2,i)
1689 n2=inter_cand%IXINT(3,i)
1690 DO i1 = adsky(n), adsky(n+1)-1
1691 numg2=abs(cne(i1))
1692 IF(numg2 == numg1) GOTO 124
1693 IF(numg2 /= numg1) THEN
1694 DO i2 = adsky(n1), adsky(n1+1)-1
1695 numg3=abs(cne(i2))
1696 IF(numg3 == numg1) GOTO 124
1697 IF(numg3==numg2) THEN
1698 DO i3 = adsky(n2), adsky(n2+1)-1
1699 numg4=abs(cne(i3))
1700 IF(numg4 == numg1) GOTO 124
1701 IF(numg4==numg2) GOTO 124
1702 ENDDO
1703 ENDIF
1704 ENDDO
1705 END IF
1706 ENDDO
1707 124 CONTINUE
1708 IF(numg1 /= numg2 .AND. (numg1>0 .AND. numg2 > 0)) THEN
1709 IF(cep(numg1)==0.OR.cep(numg2)==0) THEN
1710 number_of_added_edges = number_of_added_edges + 1
1711 IF(cep(numg1) < 100 .AND. cep(numg2) < 100) THEN
1712 CALL iddconnectplus(numg1,numg2,nelem)
1713 CALL iddconnectplus(numg2,numg1,nelem)
1714 cep(numg1) = cep(numg1) + 1
1715 cep(numg2) = cep(numg2) + 1
1716 ENDIF
1717 ELSE
1718 refused_cep0 = refused_cep0 + 1
1719 ENDIF
1720 ELSE
1721 if(numg1 == numg2) refused_numg = refused_numg + 1
1722 if(numg1<=0 .OR. numg2<=0) refused_numg0 = refused_numg0 + 1
1723 ENDIF
1724 IF(iccand > 0 .AND. numg2 > 0) THEN
1725 IF(inter_cand%IXINT(6,i)<0)THEN
1726 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+5
1727 ELSE
1728 iwd(ncond*(numg2-1)+iccand)=iwd(ncond*(numg2-1)+iccand)+1
1729 END IF
1730 END IF
1731
1732 ENDIF
1733 ENDIF
1734 ENDIF ! if isogeometric element
1735 ENDDO
1736
1737C ================================================================
1738C Add connectivity between disconnected parts
1739C according to the distance
1740 ALLOCATE(colors(nelem+1),stat=ierr1)
1741 ALLOCATE(roots(nelem),stat=ierr1)
1742 CALL plist_bfs(nelem,nconnx,colors,roots)
1743
1744 !NUMG1 id of the root element of the larest connected part
1745 ALLOCATE(min_dist(nconnx))
1746 ALLOCATE(coords(3,nconnx))
1747 DO i = 1,nconnx
1748
1749 CALL find_nodes(roots(i) ,elemnodes,tagelem,ixs,ixs10,
1750 1 ixq ,ixc ,ixt ,ixp,ixr,
1751 2 ixtg ,kxx ,ixx,kxig3d,
1752 3 ixig3d,geo ,offelem,nelmin)
1753
1754 IF(elemnodes(1) /= 0) THEN
1755 coords(1:3,i) = x(1:3,elemnodes(1))
1756 ELSE
1757 coords(1:3,i) = zero
1758 ENDIF
1759 ENDDO
1760
1761 DO i = 1, nconnx
1762 numg1 = roots(i)
1763 min_dist(1:nconnx) = huge(1.0)
1764 DO j = 1, nconnx
1765 numg2 = roots(j)
1766 IF(numg1 /= numg2) THEN
1767 min_dist(j) = (coords(1,i)-coords(1,j))**2
1768 . + (coords(2,i)-coords(2,j))**2
1769 . + (coords(3,i)-coords(3,j))**2
1770
1771 ENDIF
1772 ENDDO
1773 dist = minval(min_dist(1:nconnx))
1774 k = 0
1775 DO j = 1, nconnx
1776 numg2 = roots(j)
1777 IF(numg1 /= numg2 .AND. min_dist(j) < 2.0*dist) THEN
1778C connectivity added between roots of the distance is < 2 x the minimum
1779C distance between the current root, and its closest neighbor
1780 CALL iddconnectplus(numg1,numg2,nelem)
1781 CALL iddconnectplus(numg2,numg1,nelem)
1782 k = k + 1
1783 ENDIF
1784 ENDDO
1785 ENDDO
1786 DEALLOCATE(min_dist)
1787 DEALLOCATE(coords)
1788 DEALLOCATE(index_sort,isort)
1789C ================================================================
1790C WRITE(6,*) "STATISTIC ON CONTACT INTERFACE"
1791C WRITE(6,"(6(A,X,I10))") " added:",number_of_added_edges,
1792C . " refused_numg: ",refused_numg,
1793C . " refused_numg0: ",refused_numg0,
1794C . " refused_cep0: ",refused_cep0,
1795C . " switch_tried: ",switch_tried,
1796C . " switch_done: ",switch_done
1797C
1798! number of edge
1799 nedges = 0
1800 nedges_8 = 0
1801 DO i=1,nelem
1802 CALL c_iddconnect(i,taille_local)
1803 nedges = nedges + taille_local
1804 nedges_8 = nedges_8 + taille_local
1805 ENDDO
1806 nedges = nedges/2
1807 nedges_8 = nedges_8 / 2
1808 ENDIF
1809
1810 IF(ALLOCATED(tagelem)) DEALLOCATE(tagelem)
1811
1812
1813! ----------------------------------------------------------------
1814! Check if there are some small rigid bodies (ie. with less than 40 secondary nodes)
1815! in order to force the rigid body elements on a given processor
1816! loop over the rigid bodies
1817! if small rigid body : save the element list in a vector (c_prevent_decomposition_rbody function)
1818! if more than 1 small rigid body : force the domain decomposition (c_enforce_constraints_rbody function)
1819!
1820! if more than 1 small rigid body : BOOL_RBODY logical = true
1821!
1822 bool_rbody=.false.
1823
1824 IF(iddlevel/=0) THEN
1825 numel = numels+numelq+numelc+numelt+numelp+numelr
1826 . + numeltg+numelx+numsph+numelig3d
1827
1828! ------------------------
1829 k = 0
1830 DO n = 1, nrbykin
1831 nsn = npby(2,n) ! number of secondary nodes
1832
1833 IF(nsn<40) THEN
1834 m = npby(1,n) ! main nodes
1835 ! -----------------------------
1836 ! find the number of element in the rigid body
1837 number_of_element_rbody = 0 ! number of element in the current RBODY
1838 ! ----------------
1839 ! secondary nodes
1840 DO j=1,nsn
1841 i = lpby(j+k)
1842 DO ijk = adsky(i),adsky(i+1)-1
1843 number_of_element_rbody = number_of_element_rbody + 1
1844 ENDDO
1845 ENDDO
1846 ! ----------------
1847 ! main node
1848 DO ijk = adsky(m),adsky(m+1)-1
1849 number_of_element_rbody = number_of_element_rbody + 1
1850 ENDDO
1851 ! ----------------
1852 ALLOCATE( list_element_rbody(number_of_element_rbody) )
1853 ! -----------------------------
1854
1855 number_of_element_rbody = 0 ! number of element in the current RBODY
1856 ! ----------------
1857 ! secondary nodes
1858 DO j=1,nsn
1859 i = lpby(j+k)
1860 DO ijk = adsky(i),adsky(i+1)-1
1861 cc2 = ijk
1862 numg2 = abs(cne(cc2))
1863 number_of_element_rbody = number_of_element_rbody + 1
1864 list_element_rbody( number_of_element_rbody ) = numg2
1865 bool_rbody=.true.
1866 ENDDO
1867 ENDDO
1868 ! ----------------
1869 ! main node
1870 DO ijk = adsky(m),adsky(m+1)-1
1871 cc2 = ijk
1872 numg2 = abs(cne(cc2))
1873 number_of_element_rbody = number_of_element_rbody + 1
1874 list_element_rbody( number_of_element_rbody ) = numg2
1875 ENDDO
1876 ! ----------------
1877 ! save the element list
1878 IF(number_of_element_rbody>0)
1879 . CALL c_prevent_decomposition_rbody(number_of_element_rbody,list_element_rbody)
1880 DEALLOCATE( list_element_rbody )
1881 ! ----------------
1882 ENDIF
1883 k = k + nsn
1884 ENDDO
1885
1886! ------------------------
1887 ENDIF
1888! ----------------------------------------------------------------
1889
1890 IF (nedges>0 .AND. nspmd > 1) THEN
1891! metis structures 1/2
1892 ALLOCATE(xadj(nelem+1),stat=ierr1)
1893! init XADJ
1894 xadj(1:nelem+1)=0
1895! deallocation of CNE
1896 DEALLOCATE(cne)
1897! Number of edges
1898 nedges = 0
1899 DO i=1,nelem
1900 CALL c_iddconnect(i,taille_local)
1901 nedges = nedges + taille_local
1902 ENDDO
1903 nedges = nedges/2
1904! Metis structures 2/2
1905 ALLOCATE(adjncy(2*nedges),stat=ierr1)
1906
1907 xadj(1) = 1
1908 DO i=1,nelem
1909 CALL c_iddconnect(i,taille_local)
1910 xadj(i+1) = xadj(i) + taille_local
1911 IF(taille_local>0) THEN
1912 CALL plist_iddconnect(adjncy,xadj,i)
1913 ENDIF
1914 ENDDO
1915! deallocation of IDDCONNECT % PDOM and % IENTRYDOM
1916 DEALLOCATE(iddconnect%PDOM)
1917 DEALLOCATE(iddconnect%IENTRYDOM)
1918
1919C Determine connectivity components
1920 IF(ALLOCATED(colors)) DEALLOCATE(colors)
1921 IF(ALLOCATED(roots)) DEALLOCATE(roots)
1922 ALLOCATE(colors(nelem+1),stat=ierr1)
1923 ALLOCATE(roots(nelem),stat=ierr1)
1924 CALL dd_bfs(xadj,adjncy,nelem,nedges,nconnx,colors,roots)
1925 IF(nconnx > 1) THEN
1926 WRITE(iout,'(A,I8)')
1927 . ' NUMBER OF DISCONNECTED COMPONENTS FIXED FOR DOMAIN DECOMP:'
1928 . ,nconnx
1929C Metis Workaround to create additional connectivities between non connected graphs
1930 ALLOCATE(xadj_old(nelem+1),stat=ierr1)
1931 ALLOCATE(adjncy_old(2*nedges),stat=ierr1)
1932 xadj_old(1:nelem+1)=xadj(1:nelem+1)
1933 adjncy_old(1:2*nedges)=adjncy(1:2*nedges)
1934 newedge = nedges+nconnx-1
1935 DEALLOCATE(adjncy)
1936 ALLOCATE(adjncy(2*newedge),stat=ierr1)
1937C 1) recompute new XADJ and fill new ADJCNY
1938 inc=0
1939 DO i = 1, nconnx
1940 curr=roots(i) ! roots(1)=1
1941 i1=xadj(curr)
1942 i1old=xadj_old(curr)
1943 i2old=xadj_old(curr+1)-1
1944 IF(i>1)THEN
1945C insert 1 edge to previous connex component
1946 prev=roots(i-1) ! PREV < CURR < NEXT
1947 IF(i1old <= 2*nedges) THEN
1948 DO WHILE ((i1old <= i2old) .AND.
1949 + (adjncy_old(i1old) < prev))
1950 adjncy(i1) = adjncy_old(i1old)
1951 i1 = i1+1
1952 i1old=i1old+1
1953 IF(i1old > 2*nedges) EXIT
1954 END DO
1955 ENDIF
1956 adjncy(i1) = prev
1957 i1=i1+1
1958 inc=inc+1 ! recall to swap INC+1 next addresses in XADJ
1959 END IF
1960 IF(i<nconnx)THEN
1961C insert 1 edge to next connex component
1962 next=roots(i+1)
1963 IF(i1old <= 2*nedges) THEN
1964 DO WHILE ((i1old <= i2old) .AND.
1965 + (adjncy_old(i1old) < next))
1966 adjncy(i1) = adjncy_old(i1old)
1967 i1 = i1+1
1968 i1old=i1old+1
1969 IF(i1old > 2*nedges) EXIT
1970 END DO
1971 ENDIF
1972 adjncy(i1) = next
1973 i1=i1+1
1974 inc=inc+1 ! increase shift value for next addresses in XADJ
1975 ELSE
1976 next = nelem+1 ! special value to stop recopy of remaining edges
1977 END IF
1978C finish to recopy the rest of the edges for CURR
1979 DO WHILE (i1old <= i2old)
1980 adjncy(i1) = adjncy_old(i1old)
1981 i1 = i1+1
1982 i1old=i1old+1
1983 END DO
1984C recopy the rest of the edges for all the vertices till NEXT or NELEM+1
1985 n=curr+1
1986 DO WHILE (n /= next)
1987 xadj(n)=xadj(n)+inc
1988 i1=xadj(n)
1989 i1old=xadj_old(n)
1990 i2old=xadj_old(n+1)-1
1991 DO WHILE (i1old <= i2old)
1992 adjncy(i1) = adjncy_old(i1old)
1993 i1 = i1+1
1994 i1old=i1old+1
1995 END DO
1996 n = n+1
1997 END DO
1998C set correct XADJ for NEXT of NELEM+1
1999 xadj(next)=xadj(next)+inc
2000 END DO
2001C
2002 nedges=newedge
2003 DEALLOCATE(xadj_old,adjncy_old)
2004C 2) recompute connexity to verify it is ok now
2005 CALL dd_bfs(xadj,adjncy,nelem,nedges,nconnx,colors,roots)
2006 IF(nconnx > 1) THEN
2007 WRITE(iout,'(A,I8)')
2008 . '** INFO: REMAINING DISCONNECTED COMPONENTS:',nconnx
2009 END IF
2010 END IF
2011 DEALLOCATE(colors,roots)
2012
2013 WRITE(iout,*)' '
2014 WRITE(iout,fmt=fmw_a_i)
2015 . ' ELEMENT NUMBER = ',nelem
2016 WRITE(iout,fmt=fmw_a_i)' edges found = ',NEDGES
2017 WRITE(IOUT,*)' '
2018
2019 IWFLG=2
2020 NFLAG=1
2021C old metis option kept for compatibility
2022 OPTIONS(1)=0
2023C new Metis5 Definition
2024 IERROR = METIS_SetDefaultOptions(options)
2025c DO I = 1, 40
2026c OPTIONS(I) = -1
2027c END DO
2028C OPTIONS(METIS_OPTION_NUMBERING) = 1 ! Fortran numbering -- position 17 en 5.0.2 et 18 en 5.1
2029
2030 OPTIONS(18)=1
2031! OPTIONS(8) = 3 ! METIS NCUTS options
2032
2033C OPTIONS(METIS OPTION CONTIG) = 1 ! Option for contiguous sub domains
2034C OPTIONS(12)=1
2035C OPTIONS(METIS OPTION OBJTYPE) = 1
2036C OPTIONS(2)=0 ! 0 => CUT (default); 1 => VOL ;
2037C OPTIONS(METIS OPTION CTYPE) = 1
2038C OPTIONS(3)=1 ! 0 => METIS CTYPE RM (default); 1 => METIS CTYPE SHEM (default) ;
2039C OPTIONS(METIS OPTION IPTYPE) = 1 ! ignore
2040C OPTIONS(4)=2 ! 0 => GROW ; 1 => RANDOM to try ; 2 => EDGE ; 3 => NODE
2041C OPTIONS(METIS OPTION IRTYPE) = 1 ! ignore
2042C OPTIONS(5)=0 ! 0 => FM ; 1 => Greedy to try ; 2 => 1 S NODE ; 3 => 2 S NODE
2043C OPTIONS(METIS OPTION NITER) = 10 (default) !
2044C Options (7) = 20!20 very slight better
2045C OPTIONS(METIS MIN CONN) = 0 (default) !
2046C OPTIONS(11)=1 ! 1 minimize max connectivity
2047C OPTIONS(METIS NO2HOP) = 0 (default) !
2048C OPTIONS(10)=1 ! 20 ! ignore
2049C OPTIONS(METIS UFACTOR) = 30 (default) !
2050C OPTIONS(17)=1 ! ignore
2051C OPTIONS(METIS NCUTS) = 1 (default) !
2052C OPTIONS(8) = 4
2053C OPTIONS(8)=1
2054C Domain Decomposition Crash or FSI
2055 IF(ICFSI==0)THEN
2056 DO I = 1, NELEM
2057C weight normalization (deleted elem to 0)
2058 IWD(NCOND*(I-1)+ICELEM) = NINT(WD(I)*100)
2059C interface weight already calculated
2060 END DO
2061 ELSE
2062 DO I = 1, NELEM
2063 IF(I<=NUMELS)THEN
2064 MID = ABS(IXS(1,I))
2065 PID = ABS(IXS(10,I))
2066 JALE_FROM_MAT = NINT(PM(72,MID)) !old way to enable ALE/EULER framework (backward compatibility)
2067 JALE_FROM_PROP = IGEO(62,PID) !new way to enable ALE/EULER framework
2068 JALE = MAX(JALE_FROM_MAT, JALE_FROM_PROP) !if inconsistent, error message was displayed in PART reader MLN = NINT(PM(19,MID))
2069 MLN = NINT(PM(19,MID))
2070.AND. IF(JALE==0MLN/=18)THEN
2071 IWD(NCOND*(I-1)+ICELEM) = NINT(WD(I)*100)
2072 IWD(NCOND*(I-1)+ICFSI) = 0
2073 ELSE
2074 IWD(NCOND*(I-1)+ICELEM) = 0
2075 IWD(NCOND*(I-1)+ICFSI) = NINT(WD(I)*100)
2076 END IF
2077 ELSE
2078C weight normalization (deleted elem to 0)
2079 IWD(NCOND*(I-1)+ICELEM) = NINT(WD(I)*100)
2080 END IF
2081C interface weight already calculated
2082 END DO
2083 END IF
2084 IF(ICDEL>0)THEN
2085 DO I = 1, NELEM
2086C em delete
2087 IF(WD(I)==0.0001)THEN
2088 IWD(NCOND*(I-1)+ICDEL) = 1
2089 ELSE
2090 IWD(NCOND*(I-1)+ICDEL) = 0
2091 END IF
2092C interface weight already calculated
2093 END DO
2094 END IF
2095
2096
2097C In case of cluster, transfer the weight to the first cluster element
2098 IF(NCLUSTER > 0) THEN
2099 DO I = 1, NCLUSTER
2100 CLUSTER_TYP = CLUSTERS(I)%TYPE
2101 OFFSET_CLUSTER = 0
2102.OR. IF(CLUSTER_TYP==2CLUSTER_TYP==3) OFFSET_CLUSTER = NUMELS+NUMELQ+NUMELC+NUMELT+NUMELP
2103 DO J = 2, CLUSTERS(I)%NEL
2104 DO K =1, NCOND
2105 IWD((CLUSTERS(I)%ELEM(1)-1) * NCOND+K +OFFSET_CLUSTER) =
2106 . IWD((CLUSTERS(I)%ELEM(1)-1) * NCOND+K +OFFSET_CLUSTER) +
2107 . IWD((CLUSTERS(I)%ELEM(J)-1) * NCOND+K +OFFSET_CLUSTER)
2108 IWD((CLUSTERS(I)%ELEM(J)-1) * NCOND+K +OFFSET_CLUSTER) = 0
2109 ENDDO
2110 END DO
2111 END DO
2112 ENDIF
2113
2114
2115C
2116C Specific treatment for integer weight overflow
2117C
2118 DO I = 1, NCOND
2119 1024 CONTINUE
2120 WS = ZERO
2121 DO J = 1, NELEM
2122 WS = WS + IWD(NCOND*(J-1)+I)
2123 END DO
2124 IF(WS>2*EP9)THEN
2125 WRITE(IOUT,'(a,i4)')
2126 . ' weight precision decreased to enable criterion',I
2127 DO J = 1, NELEM
2128 IWD(NCOND*(J-1)+I) = IWD(NCOND*(J-1)+I)/10
2129 END DO
2130 GO TO 1024
2131 END IF
2132 END DO
2133
2134C
2135 UBVEC(1:15) = 0
2136 UBVEC(ICELEM) = 1.02
2137 IF(ICINTS/=0) UBVEC(ICINTS) = 1.05
2138 IF(ICINTM/=0) UBVEC(ICINTM) = 1.05
2139 IF(ICINT2/=0) UBVEC(ICINT2) = 1.05
2140 IF(ICDDL/=0) UBVEC(ICDDL) = 1.02
2141 IF(ICSOL/=0) UBVEC(ICSOL) = 1.05
2142 IF(ICFSI/=0) UBVEC(ICFSI) = 1.02
2143 IF(ICDEL/=0) UBVEC(ICDEL) = 1.10
2144 IF(ICCAND/=0) UBVEC(ICCAND) = 1.10
2145 IF(ICKIN/=0) UBVEC(ICKIN) = 1.10
2146 IF(ICR2R/=0) UBVEC(ICR2R) = 1.30
2147 IF(ICNOD_SMS/=0) UBVEC(ICNOD_SMS) = 1.05
2148c i=0
2149c call METIS_EstimateMemory(NELEM,XADJ,ADJNCY,0,2,I)
2150c print *,'estimate memory=',i,nelem,XADJ(NELEM+1)
2151 1999 CONTINUE
2152.OR. IF(DECTYP==3DECTYP==5)THEN
2153C KWAY METIS
2154
2155 IERR1 = Wrap_METIS_PartGraphKway(
2156 1 NELEM,NCOND,XADJ,ADJNCY,
2157 2 IWD,NNODE,
2158 3 UBVEC,OPTIONS,NEC,CEP)
2159 IDB_METIS = 0
2160
2161 IF(IDB_METIS == 1) THEN
2162C write graph for Metis debug
2163 it=0
2164 WRITE(CHLEVEL,'(i1)')IDDLEVEL
2165C weight only on vertices
2166 OPEN(99,file="input.graph"//CHLEVEL,FORM='formatted',RECL=8192)
2167 write(99,*) nelem,nedges,"010",ncond
2168 do i = 1, nelem
2169 write(99,*)iwd(NCOND*(I-1)+1:NCOND*(I-1)+ncond),
2170 + adjncy(xadj(i):xadj(i+1)-1)
2171 it = it + xadj(i+1)-xadj(i)
2172 end do
2173 print *,'writing graph with check:',it,'/',nedges*2
2174 CLOSE(99)
2175 END IF
2176.OR. ELSEIF(DECTYP==4DECTYP==6)THEN
2177C RSB METIS
2178 IERR1 = Wrap_METIS_PartGraphRecursive(
2179 1 NELEM,NCOND,XADJ,ADJNCY,
2180 2 IWD,NNODE,
2181 3 UBVEC,OPTIONS,NEC,CEP)
2182 END IF
2183 CALL STAT_DOMDEC(
2184 1 WIS ,WI2 ,WFSI ,WDEL ,WDDL ,
2185 2 WCAND ,WSOL ,WR2R ,WKIN ,IWD ,
2186 3 NCOND ,ICELEM ,ICINTS ,ICINT2 ,ICCAND ,
2187 4 ICDDL ,ICSOL ,ICFSI ,ICDEL ,ICR2R ,
2188 5 ICKIN ,AVERAGE ,DEVIATION ,DMAX ,DMIN ,
2189 6 CEP ,NELEM ,W ,ICINTM ,WIM ,
2190 7 NCRITMAX ,WNOD_SMS,ICNOD_SMS)
2191
2192
2193.AND. IF(ICFSI > 0 ICFSI < ICELEM) THEN
2194! the order in DMIN,DMAX is independent of the order of constraints
2195 MAIN_TARGET = 7
2196 ELSE
2197 MAIN_TARGET = 1
2198 ENDIF
2199
2200C CHECK Quality of Domain Decomp on elements
2201C If ( ALE .or. first domdec) .and. (first try)) then check load balance
2202.OR..AND..OR. IF( ( MAIN_TARGET == 7 IDDLEVEL==1) (DECTYP==3 DECTYP==5) )THEN
2203 IF(DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.90 )THEN
2204 WRITE(IOUT,'(a)')
2205 . '** info: decomposition unbalancing detected'
2206 WRITE(IOUT,'(a,i5,a,2x,i8,2x,i8,2x,i8)')
2207 . ' domains:',NSPMD,' min/max/average:',
2208 . NINT(DMIN(MAIN_TARGET)),NINT(DMAX(MAIN_TARGET)),NINT(AVERAGE(MAIN_TARGET))
2209c IF(.NOT. FVM_DOMDEC) THEN
2210 WRITE(IOUT,'(a)')' revert to RECURSIVE bissection'
2211c ENDIF
2212 DECTYP=DECTYP+1
2213
2214 IF(FVM_DOMDEC) THEN
2215 UBVEC(ICELEM) = 1.01
2216 IF(ICINTS/=0) UBVEC(ICINTS) = 1.02
2217 IF(ICINTM/=0) UBVEC(ICINTM) = 1.02
2218 IF(ICINT2/=0) UBVEC(ICINT2) = 1.02
2219 IF(ICDDL/=0) UBVEC(ICDDL) = 1.05
2220 IF(ICSOL/=0) UBVEC(ICSOL) = 1.05
2221 IF(ICFSI/=0) UBVEC(ICFSI) = 1.05
2222 IF(ICDEL/=0) UBVEC(ICDEL) = 1.05
2223 IF(ICCAND/=0) UBVEC(ICCAND) = 1.05
2224 IF(ICKIN/=0) UBVEC(ICKIN) = 1.05
2225 IF(ICR2R/=0) UBVEC(ICR2R) = 1.30
2226 IF(ICNOD_SMS/=0) UBVEC(ICNOD_SMS) = 1.0
2227 ELSE
2228 UBVEC(ICELEM) = 1.001
2229 IF(ICINTS/=0) UBVEC(ICINTS) = 1.02
2230 IF(ICINTM/=0) UBVEC(ICINTM) = 1.02
2231 IF(ICINT2/=0) UBVEC(ICINT2) = 1.02
2232 IF(ICDDL/=0) UBVEC(ICDDL) = 1.01
2233 IF(ICSOL/=0) UBVEC(ICSOL) = 1.03
2234 IF(ICFSI/=0) UBVEC(ICFSI) = 1.01
2235 IF(ICDEL/=0) UBVEC(ICDEL) = 1.03
2236 IF(ICCAND/=0) UBVEC(ICCAND) = 1.03
2237 IF(ICKIN/=0) UBVEC(ICKIN) = 1.03
2238 IF(ICR2R/=0) UBVEC(ICR2R) = 1.30
2239 IF(ICNOD_SMS/=0) UBVEC(ICNOD_SMS) = 1.0
2240 ENDIF
2241 GOTO 1999
2242 END IF
2243 END IF
2244C---------------------------------------------------------------------
2245C Loop over domain decomposition until satisfactory load balancing for element
2246C---------------------------------------------------------------------
2247 MAX_TRY = 3
2248 WD_MAX_FACTOR = 2
2249 ALLOCATE(IWD_COPY(NCOND*NELEM))
2250 ALLOCATE(WD_COPY(NELEM))
2251.OR..AND..AND. IF((DECTYP==4 DECTYP==6) IDDLEVEL==1 NELEM>10*NSPMD )THEN
2252
2253 IF(ICDEL /= 0 ) THEN
2254.AND. IF(ELEMD > 9*NELEM/10 DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.80 ) THEN
2255 ! If the model is mainly deleted elements
2256 ! Then we equilibrate first on deleted elements
2257 DO I= 1, NELEM
2258 WGHT=IWD(NCOND*(I-1)+1)
2259 IWD(NCOND*(I-1)+1) = IWD(NCOND*(I-1)+ICDEL)
2260 IWD(NCOND*(I-1)+ICDEL)=WGHT
2261 ENDDO
2262 ENDIF
2263 ENDIF
2264
2265 NCOND2=NCOND
2266 DD_FVMBAG_TRY = 0
2267 WD_MAX0 = WD_MAX
2268 WD_COPY(1:NELEM) = WD(1:NELEM)
2269 IWD_COPY(1:NCOND * NELEM) = IWD(1:NCOND*NELEM)
2270
2271 DD_UNBALANCED = (DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.80)
2272 IF(FVM_DOMDEC) THEN
2273.OR. DD_UNBALANCED = DD_UNBALANCED (DMAX(MAIN_TARGET) > AVERAGE(MAIN_TARGET)*1.1)
2274 WD_MAX0 = 0.0
2275 DO N = 1, NVOLU
2276 IF(FVM_ELEM(N) /= 0) THEN
2277 WD_MAX0= MAX(WD_MAX0,DBLE(WD(FVM_ELEM(N))))
2278 ENDIF
2279 ENDDO
2280 WD_MAX0 = MIN(WD_MAX,WD_MAX0)
2281 WD_MAX = WD_MAX0
2282 ENDIF
2283
2284.AND. DO WHILE(DD_UNBALANCED NCOND2 > 1 )
2285C CHECK Quality of Domain Decomp on elements
2286 WRITE(IOUT,'(a)')
2287 . '** info: decomposition unbalancing detected'
2288 WRITE(IOUT,'(a,i5,a,2x,i8,2x,i8,2x,i8)')
2289 . ' domains:',NSPMD,' min/max/average:',
2290 . NINT(DMIN(MAIN_TARGET)),NINT(DMAX(MAIN_TARGET)),NINT(AVERAGE(MAIN_TARGET))
2291
2292 !==========================================
2293 ! REVIEW WEIGHTS OF FVMBAGS
2294 !
2295 ! Try to trim the weight of FVMBAG
2296 ! if the domain decomposition fails
2297 NB_FVMBAG_TRIM = 0
2298.AND. IF(FVM_DOMDEC DD_FVMBAG_TRY <= MAX_TRY) THEN
2299 WD_MAX = WD_MAX / (0.1D0 * WD_MAX_FACTOR)
2300 DO N = 1, NVOLU
2301 IF(FVM_ELEM(N) /= 0) THEN
2302 IF(WD(FVM_ELEM(N)) > WD_MAX) THEN
2303 WD(FVM_ELEM(N)) = WD_MAX
2304 IWD(NCOND*(FVM_ELEM(N)-1)+ICELEM) = NINT(WD_MAX*100)
2305 NB_FVMBAG_TRIM = NB_FVMBAG_TRIM + 1
2306 ENDIF
2307 ENDIF
2308 ENDDO
2309 ENDIF
2310 IF(NB_FVMBAG_TRIM > 0) THEN
2311 ! Try to reduce the weight of the FVMBAG vertex
2312 ! before reducing the number of constraints
2313 DD_FVMBAG_TRY = DD_FVMBAG_TRY + 1
2314 ELSE
2315 ! Reducing the number of constraints
2316 ! Resetting weights
2317 NCOND2= NCOND2 - 1
2318 DD_FVMBAG_TRY = 0
2319 MAX_TRY = MAX_TRY + 1
2320 WD_MAX = WD_MAX0
2321 WD(1:NELEM) = WD_COPY(1:NELEM)
2322 IWD(1:NCOND*NELEM) = IWD_COPY(1:NCOND*NELEM)
2323 ENDIF
2324 !==============================================
2325
2326
2327
2328 WRITE(IOUT,'(a,i5)') 'retry kway with ncond =',NCOND2
2329
2330 ALLOCATE(IWD2(NCOND2*NELEM))
2331 DO I= 1, NELEM
2332 DO J = 1, NCOND2
2333 IWD2( NCOND2*(I-1) +J ) = IWD ( NCOND*(I-1) + J)
2334 ENDDO
2335 ENDDO
2336C KWAY METIS
2337 IERR1 = WRAP_METIS_PartGraphKway(
2338 1 NELEM,NCOND2,XADJ,ADJNCY,
2339 2 IWD2,NNODE,
2340 3 UBVEC,OPTIONS,NEC,CEP)
2341 CALL STAT_DOMDEC(
2342 1 WIS ,WI2 ,WFSI ,WDEL ,WDDL ,
2343 2 WCAND ,WSOL ,WR2R ,WKIN ,IWD ,
2344 3 NCOND ,ICELEM ,ICINTS ,ICINT2 ,ICCAND ,
2345 4 ICDDL ,ICSOL ,ICFSI ,ICDEL ,ICR2R ,
2346 5 ICKIN ,AVERAGE ,DEVIATION ,DMAX ,DMIN ,
2347 6 CEP ,NELEM ,W ,ICINTM ,WIM ,
2348 7 NCRITMAX ,WNOD_SMS,ICNOD_SMS)
2349
2350! CHECK Quality of Domain Decomp on elements
2351 DD_UNBALANCED = (DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.80)
2352 IF(FVM_DOMDEC) THEN
2353.OR. DD_UNBALANCED = DD_UNBALANCED (DMAX(MAIN_TARGET) > AVERAGE(MAIN_TARGET)*1.1)
2354 ENDIF
2355
2356
2357 IF(DD_UNBALANCED)THEN
2358
2359 WRITE(IOUT,'(a)')
2360 . '** info: decomposition unbalancing detected'
2361 WRITE(IOUT,'(a,i5,a,2x,i8,2x,i8,2x,i8)')
2362 . ' domains:',NSPMD,' min/max/average:',
2363 . NINT(DMIN(MAIN_TARGET)),NINT(DMAX(MAIN_TARGET)),NINT(AVERAGE(MAIN_TARGET))
2364
2365C RSB METIS
2366
2367 IERR1 = WRAP_METIS_PartGraphRecursive(
2368 1 NELEM,NCOND2,XADJ,ADJNCY,
2369 2 IWD2,NNODE,
2370 3 UBVEC,OPTIONS,NEC,CEP)
2371 CALL STAT_DOMDEC(
2372 1 WIS ,WI2 ,WFSI ,WDEL ,WDDL ,
2373 2 WCAND ,WSOL ,WR2R ,WKIN ,IWD ,
2374 3 NCOND ,ICELEM ,ICINTS ,ICINT2 ,ICCAND ,
2375 4 ICDDL ,ICSOL ,ICFSI ,ICDEL ,ICR2R ,
2376 5 ICKIN ,AVERAGE ,DEVIATION ,DMAX ,DMIN ,
2377 6 CEP ,NELEM ,W ,ICINTM ,WIM ,
2378 7 NCRITMAX ,WNOD_SMS,ICNOD_SMS)
2379
2380 ENDIF
2381 DEALLOCATE(IWD2)
2382
2383 DD_UNBALANCED = (DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.80)
2384 IF(FVM_DOMDEC) THEN
2385.OR. DD_UNBALANCED = DD_UNBALANCED (DMAX(MAIN_TARGET) > AVERAGE(MAIN_TARGET)*1.1)
2386 ENDIF
2387
2388.AND. ENDDO ! ( DMIN(MAIN_TARGET) < AVERAGE(MAIN_TARGET)*0.80 NCOND2 > 1 )
2389 ENDIF
2390 DEALLOCATE(IWD_COPY)
2391 DEALLOCATE(WD_COPY)
2392C---------------------------------------------------------------------
2393C End of loop over domain decomposition
2394C---------------------------------------------------------------------
2395 ! stick the list of rigid body element on a given processor
2396.AND. IF(IDDLEVEL/=0BOOL_RBODY) CALL C_ENFORCE_CONSTRAINTS_RBODY(CEP,NSPMD,NRBYKIN)
2397
2398 ! make sure that lists of elements in C_PREVENT_DECOMPOSITION are on the same domain
2399 CALL C_ENFORCE_CONSTRAINTS(CEP)
2400
2401C Put all the elements of the cluster on the same proc
2402 IF (NCLUSTER > 0) THEN
2403 DO I = 1, NCLUSTER
2404 CLUSTER_TYP = CLUSTERS(I)%TYPE
2405 OFFSET_CLUSTER = 0
2406.OR. IF(CLUSTER_TYP==2CLUSTER_TYP==3) OFFSET_CLUSTER = NUMELS+NUMELQ+NUMELC+NUMELT+NUMELP
2407 CEPCLUSTER=CEP( CLUSTERS(I)%ELEM(1)+OFFSET_CLUSTER )
2408 DO J = 2,CLUSTERS(I)%NEL
2409 CEP( CLUSTERS(I)%ELEM(J)+OFFSET_CLUSTER ) = CEPCLUSTER
2410 END DO
2411 END DO ! I = 1, NCLUSTER
2412 END IF ! NCLUSTER > 0
2413
2414
2415C
2416C Save the PMAIN in FVMAIN
2417.AND..AND. IF(NVOLU > 0 IDDLEVEL==1 FVM_DOMDEC) THEN
2418
2419 OFFC = NUMELS+NUMELQ
2420 OFFTG =NUMELS+NUMELQ+ NUMELC+NUMELT+NUMELP+NUMELR
2421 NN_L = 0
2422 CEPCLUSTER = 1
2423 NFVMBAG = 0
2424 DO N = 1, NVOLU
2425 ITYP = T_MONVOL(N)%TYPE
2426 NN = T_MONVOL(N)%NNS
2427! find location of the first element
2428! i.e. the element with all the weight
2429.OR. IF(ITYP == 6 ITYP == 8) NFVMBAG = NFVMBAG + 1
2430
2431.AND..OR. IF(NN > 0 (ITYP == 6 ITYP == 8)) THEN
2432 CEPCLUSTER = CEP(FVM_ELEM(N))
2433 FVMAIN(NFVMBAG) = CEPCLUSTER
2434 ENDIF
2435 ENDDO
2436 ENDIF
2437
2438C
2439 DEALLOCATE(XADJ,ADJNCY)
2440! IF(ASSOCIATED(ADJWGT2)) DEALLOCATE(ADJWGT2)
2441
2442 DO I = 1, NELEM
2443 CEP(I) = CEP(I)-1
2444 END DO
2445
2446 !---------------------!
2447 !2D - EBCS : send boundary cells in domain 1
2448 DO I=1,NUMELQ
2449 IF(EBCS_TAG_CELL_SPMD(I)==1)THEN
2450 CEP(NUMELS+I)=0
2451 ENDIF
2452 ENDDO
2453 DO I=1,NUMELTG
2454 IF(EBCS_TAG_CELL_SPMD(NUMELQ+I)==1)THEN
2455 CEP(NUMELS+NUMELQ+NUMELC+NUMELT+NUMELP+NUMELR+I)=0
2456 ENDIF
2457 ENDDO
2458 !3D - EBCS : send boundary cells in domain 1
2459 DO I=1,NUMELS
2460 IF(EBCS_TAG_CELL_SPMD(NUMELQ+NUMELTG+I)==1)THEN
2461 CEP(I)=0
2462 ENDIF
2463 ENDDO
2464 !---------------------!
2465C
2466.OR. IF(DECTYP==5DECTYP==6)THEN
2467 IF(DDNOD_SMS==0)THEN
2468 WRITE(IOUT,1000)
2469 ELSE
2470 WRITE(IOUT,1100)
2471 END IF
2472 ELSEIF(ICFSI==0) THEN
2473.AND. IF(ICSOL==0ICDEL==0)THEN
2474 WRITE(IOUT,2000)
2475.AND. ELSEIF(ICSOL/=0ICDEL==0)THEN
2476 WRITE(IOUT,3000)
2477.AND. ELSEIF(ICSOL/=0ICDEL/=0)THEN
2478 WRITE(IOUT,4000)
2479.AND. ELSEIF(ICSOL==0ICDEL/=0)THEN
2480 WRITE(IOUT,5000)
2481 END IF
2482 ELSEIF(ICFSI/=0)THEN
2483 IF(ICDEL==0)THEN
2484 WRITE(IOUT,6000)
2485 ELSE
2486 WRITE(IOUT,7000)
2487 END IF
2488 END IF
2489 DO I = 1, NSPMD
2490.OR. IF(DECTYP==5DECTYP==6)THEN
2491 IF(DDNOD_SMS==0)THEN
2492 WRITE(IOUT,'(i4,8f15.0)')
2493 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WDDL(I)
2494 ELSE
2495 WRITE(IOUT,'(i4,8f15.0)')
2496 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WDDL(I),WNOD_SMS(I)
2497 END IF
2498 ELSEIF(ICFSI==0)THEN
2499.AND. IF(ICSOL==0ICDEL==0)THEN
2500 WRITE(IOUT,'(i4,8f15.0)')
2501 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WKIN(I)
2502.AND. ELSEIF(ICSOL/=0ICDEL==0)THEN
2503 WRITE(IOUT,'(i4,8f15.0)')
2504 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WSOL(I),WKIN(I)
2505.AND. ELSEIF(ICSOL/=0ICDEL/=0)THEN
2506 WRITE(IOUT,'(i4,8f15.0)')
2507 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WSOL(I),WDEL(I),WKIN(I)
2508.AND. ELSEIF(ICSOL==0ICDEL/=0)THEN
2509 WRITE(IOUT,'(i4,8f15.0)')
2510 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WDEL(I),WKIN(I)
2511 ENDIF
2512.AND. ELSEIF(ICFSI/=0ICDEL==0)THEN
2513 WRITE(IOUT,'(i4,8f15.0)')
2514 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WFSI(I)
2515.AND. ELSEIF(ICFSI/=0ICDEL/=0)THEN
2516 WRITE(IOUT,'(i4,8f15.0)')
2517 . I,W(I),WIS(I),WIM(I),WCAND(I),WI2(I),WFSI(I),WDEL(I)
2518 ENDIF
2519 ENDDO
2520 WRITE(IOUT,*)' '
2521 DEALLOCATE(IWD)
2522 WRITE(IOUT,*)'statistics on decomposition weights'
2523 WRITE(iout,*)'-----------------------------------'
2524 WRITE(iout,8000)
2525 WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2526 . ' ELEMENTS ',
2527 . nint(dmin(1)),nint(dmax(1)),
2528 . nint(average(1)),nint(deviation(1))
2529 IF(icints/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2530 . ' SECO. NODES',
2531 . nint(dmin(2)),nint(dmax(2)),
2532 . nint(average(2)),nint(deviation(2))
2533 IF(icintm/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2534 . ' MAIN NODES',
2535 . nint(dmin(11)),nint(dmax(11)),
2536 . nint(average(11)),nint(deviation(11))
2537 IF(iccand/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2538 . ' CONT. CAND.',
2539 . nint(dmin(4)),nint(dmax(4)),
2540 . nint(average(4)),nint(deviation(4))
2541 IF(icint2/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2542 . ' INT. TYPE2 ',
2543 . nint(dmin(3)),nint(dmax(3)),
2544 . nint(average(3)),nint(deviation(3))
2545 IF(icsol/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2546 . ' SOLID BAR. ',
2547 . nint(dmin(6)),nint(dmax(6)),
2548 . nint(average(6)),nint(deviation(6))
2549 IF(icdel/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2550 . ' ELT. DEL. ',
2551 . nint(dmin(8)),nint(dmax(8)),
2552 . nint(average(8)),nint(deviation(8))
2553 IF(ickin/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2554 . ' KIN. COND. ',
2555 . nint(dmin(10)),nint(dmax(10)),
2556 . nint(average(10)),nint(deviation(10))
2557 IF(icddl/=0)THEN
2558 IF(isms==0)THEN ! Implicit
2559 WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2560 . ' DOF (IMPL) ',
2561 . nint(dmin(5)),nint(dmax(5)),
2562 . nint(average(5)),nint(deviation(5))
2563 ELSE ! AMS
2564 WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2565 . ' AMS MATRIX ',
2566 . nint(dmin(5)),nint(dmax(5)),
2567 . nint(average(5)),nint(deviation(5))
2568 END IF
2569 END IF
2570 IF(icfsi/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2571 . ' ALE ELTS. ',
2572 . nint(dmin(7)),nint(dmax(7)),
2573 . nint(average(7)),nint(deviation(7))
2574 IF(icr2r/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2575 . ' R2R ',
2576 . nint(dmin(9)),nint(dmax(9)),
2577 . nint(average(9)),nint(deviation(9))
2578 IF(icnod_sms/=0) WRITE(iout,'(A,I8,2X,I8,2X,I8,4X,I8)')
2579 . ' AMS NODES ',
2580 . nint(dmin(12)),nint(dmax(12)),
2581 . nint(average(12)),nint(deviation(12))
2582 ELSE
2583C a single element or unconnected elements or a single processor
2584 DEALLOCATE(cne)
2585 DEALLOCATE(iddconnect%PDOM)
2586 DEALLOCATE(iddconnect%IENTRYDOM)
2587 DO i = 1, nelem
2588 cep(i) = 0
2589 ENDDO
2590 ENDIF
2591 DEALLOCATE(iwkin)
2592C
2593 1000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2594 . ' INT2 W. DOF W.')
2595 1100 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2596 . ' INT2 W. DOF W. AMS CONT ELT W')
2597 2000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2598 . ' INT2 W. KIN COND W.')
2599 3000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2600 . ' INT2 W. SOL W. KIN COND W.')
2601 4000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2602 . ' INT2 W. SOL W. ELT DEL W.',
2603 . ' KIN COND W.')
2604 5000 FORMAT('#PROC ELEMENT W. SECND NOD W. MAST NOD W. CONT ELT W.',
2605 . ' INT2 W. ELT DEL W. KIN COND W.')
2606 6000 FORMAT('#PROC ELT LAG W. SECND NOD W. MAST NOD W. CONT ELT W.',
2607 . ' INT2 W. ELT ALE W.')
2608 7000 FORMAT('#PROC ELT LAG W. SECND NOD W. MAST NOD W. CONT ELT W.',
2609 . ' INT2 W. ELT ALE W. ELT DEL W.')
2610 8000 FORMAT(' METRIC MINIMUM MAXIMUM AVERAGE',
2611 . ' STANDARD DEVIATION')
2612C
2613 RETURN
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:1208
plist_bfs
subroutine plist_bfs(nelem, nconnx, colors, roots)
Definition ddtools.F:1311
plist_iddconnect
subroutine plist_iddconnect(adjncy, xadj, n)
Definition ddtools.F:1258
ini_iddconnect
subroutine ini_iddconnect(nelem)
Definition ddtools.F:1115
iddconnectplus
subroutine iddconnectplus(n, p, numel)
Definition frontplus.F:211
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
dd_bfs
subroutine dd_bfs(xadj, adjncy, nelem, nedges, nconnx, colors, roots)
Definition grid2mat.F:3129
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:3824
fvbag_vertex
subroutine fvbag_vertex(ixc, ixtg, nelem, wd, wd_max, fvm_elem, fvm_domdec, itab, igrsurf, t_monvol)
Definition grid2mat.F:3977
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
front_mod::siddconnect
integer siddconnect
Definition front_mod.F:102
front_mod::iddconnect
type(my_connectdom) iddconnect
Definition front_mod.F:101
fvmbag_meshcontrol_mod
Definition fvmbag_meshcontrol_mod.F:46
groupdef_mod
Definition groupdef_mod.F:668
inter_cand_mod
Definition inter_cand_mod.F:38
message_mod
Definition message_mod.F:1257
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
r2r_mod::tag_elcf
integer, dimension(:), allocatable tag_elcf
Definition r2r_mod.F:141
r2r_mod::tag_elsf
integer, dimension(:), allocatable tag_elsf
Definition r2r_mod.F:141
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:895

◆ find_nodes()

subroutine find_nodes ( integer elemn0,
integer, dimension(max_nb_nodes_per_elt) elemnodes,
integer, dimension(*) tagelem,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(nixx,numelx) kxx,
integer, dimension(*) ixx,
integer, dimension(nixig3d,numelig3d) kxig3d,
integer, dimension(*) ixig3d,
geo,
integer, dimension(10) offelem,
integer nelmin )

Definition at line 3820 of file grid2mat.F.

3824C-----------------------------------------------
3825C M o d u l e s
3826C-----------------------------------------------
3827 USE consider_edge_mod , ONLY : max_nb_nodes_per_elt
3828 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
3829C-----------------------------------------------
3830C I m p l i c i t T y p e s
3831C-----------------------------------------------
3832#include "implicit_f.inc"
3833C-----------------------------------------------
3834C C o m m o n B l o c k s
3835C-----------------------------------------------
3836#include "com04_c.inc"
3837#include "param_c.inc"
3838#include "scr23_c.inc"
3839C-----------------------------------------------
3840C D u m m y A r g u m e n t s
3841C-----------------------------------------------
3842 INTEGER IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*), IXT(NIXT,*),
3843 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*),
3844 . KXX(NIXX,NUMELX),IXX(*),IXS10(6,*),KXIG3D(NIXIG3D,NUMELIG3D),
3845 . IXIG3D(*),ELEMNODES(MAX_NB_NODES_PER_ELT),TAGELEM(*),OFFELEM(10)
3846 INTEGER ELEMN0,NELMIN
3847 my_real geo(npropg,*)
3848C----------------------------------------------
3849C L o c a l V a r i a b l e s
3850C---------------------------------------------
3851 INTEGER K,N,ADDX,NELX,J,NELIG3D,I,ELEM
3852C---------------------------------------------
3853 nelmin = 3
3854 DO i=1,max_nb_nodes_per_elt
3855 elemnodes(i)=0
3856 ENDDO
3857
3858 elem = elemn0
3859 SELECT CASE(tagelem(elem))
3860
3861 CASE(1)
3862 DO k=1,8
3863 n = ixs(k+1,elem)
3864 elemnodes(k)= n
3865 ENDDO
3866 CASE(2)
3867! Tetra 10 nodes
3868 elemnodes(1) = ixs(2,elem)
3869 elemnodes(2) = ixs(6,elem)
3870 elemnodes(3) = ixs(4,elem)
3871 elemnodes(4) = ixs(7,elem)
3872 CASE(3)
3873 nelmin = 1
3874 elem = elem - offelem(1)
3875 DO k=1,4
3876 n = ixq(k+1,elem)
3877 elemnodes(k) = n
3878 ENDDO
3879 CASE(4)
3880 nelmin = 2
3881 DO i=1,2
3882 elem = elem - offelem(i)
3883 ENDDO
3884 DO k=1,4
3885 n = ixc(k+1,elem)
3886 elemnodes(k) = n
3887 ENDDO
3888 CASE(5)
3889 nelmin = 1
3890 DO i=1,3
3891 elem = elem - offelem(i)
3892 ENDDO
3893 DO k=1,2
3894 n = ixt(k+1,elem)
3895 elemnodes(k) = n
3896 ENDDO
3897 CASE(6)
3898 nelmin = 1
3899 DO i=1,4
3900 elem = elem - offelem(i)
3901 ENDDO
3902 DO k=1,2
3903 n = ixp(k+1,elem)
3904 elemnodes(k) = n
3905 ENDDO
3906 CASE(7)
3907 nelmin = 1
3908 DO i=1,5
3909 elem = elem - offelem(i)
3910 ENDDO
3911 DO k=1,2
3912 n = ixr(k+1,elem)
3913 elemnodes(k) = n
3914 ENDDO
3915 IF(nint(geo(12,ixr(1,elem)))==12) THEN
3916 n = ixr(4,elem)
3917 elemnodes(3) = n
3918 ENDIF
3919 CASE(8)
3920 nelmin = 2
3921 DO i=1,6
3922 elem = elem - offelem(i)
3923 ENDDO
3924 DO k=1,3
3925 n = ixtg(k+1,elem)
3926 elemnodes(k) = n
3927 ENDDO
3928 CASE(9)
3929 nelmin = 1
3930 DO i=1,7
3931 elem = elem - offelem(i)
3932 ENDDO
3933 CASE(10)
3934 nelmin = 1
3935 DO i=1,8
3936 elem = elem - offelem(i)
3937 ENDDO
3938 nelx=kxx(3,elem)
3939 DO k=1,min(nelx,10)
3940 addx = kxx(4,elem)+k-1
3941 n=ixx(addx)
3942 elemnodes(k) = n
3943 ENDDO
3944 CASE(11)
3945 DO i=1,9
3946 elem = elem - offelem(i)
3947 ENDDO
3948 nelig3d=kxig3d(3,elem)
3949 DO k=1,min(nelig3d,10)
3950 addx = kxig3d(4,elem)+k-1
3951 n=ixig3d(addx)
3952 elemnodes(k) = n
3953 ENDDO
3954 END SELECT
3955C Duplicate set to 0
3956 DO k=2,max_nb_nodes_per_elt
3957 DO i=1,k-1
3958 IF(elemnodes(k) == elemnodes(i)) elemnodes(k) = 0
3959 ENDDO
3960 ENDDO
3961

◆ fvbag_vertex()

subroutine fvbag_vertex ( integer, dimension(nixc,*), intent(in) ixc,
integer, dimension(nixtg,*), intent(in) ixtg,
integer, intent(in) nelem,
real, dimension(*), intent(inout) wd,
double precision, intent(inout) wd_max,
integer, dimension(nvolu), intent(inout) fvm_elem,
logical, intent(out) fvm_domdec,
integer, dimension(*), intent(in) itab,
type (surf_), dimension(nsurf) igrsurf,
type(monvol_struct_), dimension(nvolu), intent(in) t_monvol )

Definition at line 3974 of file grid2mat.F.

3977C Description: computes a weight for each FVMBAG
3978C this weight is added to an element of the skin of the airbag
3979C PMAIN will be the processor in charge of this element
3980C FVM_DOMDEC set to .TRUE. if an FVMBAGS contains less than NUMNOD/2
3981C nodes. Specific domain decomposition parameters will be used in that
3982C case
3983C-----------------------------------------------
3984C M o d u l e s
3985C-----------------------------------------------
3986 USE message_mod
3987 USE fvmbag_meshcontrol_mod
3988 USE groupdef_mod
3989 USE monvol_struct_mod
3990 use element_mod , only : nixc,nixtg
3991C-----------------------------------------------
3992C I m p l i c i t T y p e s
3993C-----------------------------------------------
3994#include "implicit_f.inc"
3995C-----------------------------------------------
3996C C o m m o n B l o c k s
3997C-----------------------------------------------
3998#include "com01_c.inc"
3999#include "com04_c.inc"
4000#include "units_c.inc"
4001C-----------------------------------------------
4002C D u m m y A r g u m e n t s
4003C-----------------------------------------------
4004 INTEGER, INTENT(IN) :: IXC(NIXC,*), IXTG(NIXTG,*)
4005 INTEGER,INTENT(IN) :: NELEM
4006 INTEGER, INTENT(INOUT) :: FVM_ELEM(NVOLU)
4007 DOUBLE PRECISION ,INTENT(INOUT) :: WD_MAX ! maximum weight for fvmbags
4008 REAL,INTENT(INOUT) :: WD(*) ! weights
4009 LOGICAL, INTENT(OUT) :: FVM_DOMDEC
4010 INTEGER,INTENT(IN) :: ITAB(*)
4011 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
4012 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
4013C----------------------------------------------
4014C L o c a l V a r i a b l e s
4015C---------------------------------------------
4016 LOGICAL, DIMENSION(:), ALLOCATABLE :: TAGGED_ELEM
4017 INTEGER, DIMENSION(:), ALLOCATABLE :: ELTG,MATTG
4018 INTEGER :: I,J,K,N,K0,K1,K2,K6
4019 INTEGER :: ITYP,S
4020 INTEGER :: OFFC,OFFTG
4021 INTEGER :: NNS,NTG,NNI,NTGI,NNO,NN,NTGT
4022 INTEGER :: RADALE, IBID
4023
4024C---------------------------------------------
4025C
4026C---------------------------------------------
4027
4028
4029C WD_MAX is the maximum weight of the super elt
4030C In order to be able to compute a partition
4031 offc = numels+numelq
4032 offtg =numels+numelq+ numelc+numelt+numelp+numelr
4033 i = 0
4034 DO n = 1, nvolu
4035 ityp = t_monvol(n)%TYPE
4036 nn = t_monvol(n)%NNS
4037 IF(nn > 0 .AND. (ityp == 8 .OR. ityp==6)) THEN
4038 IF(2 * nn < numnod) fvm_domdec = .true.
4039 i = i + 1
4040 ENDIF
4041 ENDDO ! 1,NVOLU
4042
4043 wd_max = 0.0d0
4044 DO n = 1,nelem
4045 wd_max = wd_max + (1.0d0*wd(n)) / (1.0d0 * nspmd)
4046 ENDDO
4047C================================================================================
4048C Arbitrary: limit the weight of one FVMBAG to 25% of the weight of one subdomain
4049 wd_max = wd_max / 4.0d0
4050C================================================================================
4051
4052 IF(i > 0) WRITE(iout,'(A)')
4053 . ' DOMAIN DECOMPOSITION OPTIMIZED FOR FVMBAGS '
4054
4055 ALLOCATE(tagged_elem(nelem))
4056 offc = numels+numelq
4057 offtg = numels+numelq+ numelc+numelt+numelp+numelr
4058 DO n = 1, nvolu
4059 tagged_elem(1:nelem) = .false.
4060 ityp = t_monvol(n)%TYPE
4061 nn = t_monvol(n)%NNS
4062
4063 IF(nn > 0 .AND. (ityp == 8 .OR. ityp==6)) THEN
4064 ! Tag elements of the fvmbag
4065 nns = t_monvol(n)%NNS
4066 ntg = t_monvol(n)%NTG
4067 nni = t_monvol(n)%NNI
4068 ntgi = t_monvol(n)%NTGI
4069 nno=3
4070 ntgt=ntg+ntgi
4071
4072 ALLOCATE(eltg(ntgt))
4073 ALLOCATE(mattg(ntgt))
4074
4075 CALL fvelsurf(
4076 . t_monvol(n)%NODES, t_monvol(n)%ELEM, ibid, ixc, ixtg, ntgt,
4077 . eltg, mattg, max(numnod, nb_total_node), .false.)
4078
4079 IF(ntgt > 1) THEN
4080 ! The first element of the FVMBAG will become the super-element
4081 ! i.e. the element that holds the weight of the finite volumes
4082 j = eltg(1) ! ELTG
4083
4084 k0 = 0
4085 IF ( j<= numelc) THEN
4086 k0 = j - numelq
4087 k0 = offc +k0
4088 ELSE
4089 k0 = (j-numelc-numelq)
4090 k0 = offtg+ k0
4091
4092 ENDIF
4093
4094 fvm_elem(n) = k0
4095
4096 IF(k0 == 0) THEN
4097
4098 ELSE
4099 tagged_elem(k0) = .true.
4100 DO i=2,ntgt
4101 j = eltg(i)! ELTG
4102 IF (j<=numelc) THEN
4103 k = offc + j
4104 ! The weight of the super element is incremented
4105 IF(.NOT.(tagged_elem(k))) THEN
4106 ! the weight of each element is doubled
4107c CALL IDDCONNECTPLUS(K,K0,NELEM)
4108 wd(k0) = wd(k0) +1.0d0* wd(k)
4109 tagged_elem(k) = .true.
4110 ENDIF
4111 ELSEIF (j>numelc) THEN
4112 k = offtg+ (j-numelc)
4113 ! The weight of the super element is incremented
4114 IF(.NOT.(tagged_elem(k))) THEN
4115 wd(k0) = wd(k0) + 1.0d0*wd(k)
4116 tagged_elem(k) = .true.
4117 ENDIF
4118 ENDIF
4119 ENDDO !2,NTGT
4120 ENDIF
4121 ENDIF ! NTGT > 0
4122
4123 IF(wd(fvm_elem(n)) > wd_max) THEN
4124 wd(fvm_elem(n)) = wd_max
4125 ENDIF
4126 DEALLOCATE(eltg)
4127 DEALLOCATE(mattg)
4128 ENDIF
4129 ENDDO ! 1,NVOLU
4130 DEALLOCATE(tagged_elem)
4131
4132 RETURN
fvelsurf
subroutine fvelsurf(ibuf, elem, elem_id, ixc, ixtg, nel, eltg, mattg, nb_node, flag)
Definition fvelsurf.F:33
fvmbag_meshcontrol_mod::nb_total_node
integer nb_total_node
Definition fvmbag_meshcontrol_mod.F:50

◆ i20wcontdd()

subroutine i20wcontdd ( integer, dimension(*) nsv,
integer, dimension(*) msr,
integer nsn,
integer nmn,
integer, dimension(5,*) iwcont,
integer nsnt,
integer nmnt )

Definition at line 3094 of file grid2mat.F.

3095C-----------------------------------------------
3096C I m p l i c i t T y p e s
3097C-----------------------------------------------
3098#include "implicit_f.inc"
3099C-----------------------------------------------
3100C D u m m y A r g u m e n t s
3101C-----------------------------------------------
3102 INTEGER NSV(*), MSR(*), IWCONT(5,*), NSN, NMN, NSNT, NMNT
3103C-----------------------------------------------
3104C L o c a l V a r i a b l e s
3105C-----------------------------------------------
3106 INTEGER I, N
3107C-----------------------------------------------
3108 DO i = 1, nsn
3109 n = nsv(i)
3110 iwcont(1,n) = iwcont(1,n)+2
3111 nsnt = nsnt + 1
3112 ENDDO
3113C
3114 DO i = 1, nmn
3115 n = msr(i)
3116C IWCONT(1,N) = IWCONT(1,N)+2
3117 iwcont(2,n) = iwcont(2,n)+2
3118 nmnt = nmnt + 1
3119 ENDDO
3120C
3121 RETURN

◆ i2wcontdd()

subroutine i2wcontdd ( integer, dimension(*) nsv,
integer, dimension(*) msr,
integer nsn,
integer nmn,
integer, dimension(2,*) iwcont,
integer nsnt,
integer nmnt )

Definition at line 2938 of file grid2mat.F.

2939C-----------------------------------------------
2940C I m p l i c i t T y p e s
2941C-----------------------------------------------
2942#include "implicit_f.inc"
2943C-----------------------------------------------
2944C D u m m y A r g u m e n t s
2945C-----------------------------------------------
2946 INTEGER NSV(*), MSR(*), IWCONT(2,*), NSN, NMN, NSNT, NMNT
2947 INTEGER :: COST
2948C-----------------------------------------------
2949C L o c a l V a r i a b l e s
2950C-----------------------------------------------
2951 INTEGER I, N
2952C-----------------------------------------------
2953 DO i = 1, nsn
2954 n = nsv(i)
2955 iwcont(1,n) = iwcont(1,n)+1
2956 nsnt = nsnt + 1
2957 ENDDO
2958C
2959 DO i = 1, nmn
2960 n = msr(i)
2961C IWCONT(1,N) = IWCONT(1,N)+1
2962 iwcont(2,n) = iwcont(2,n)+1
2963 nmnt = nmnt + 1
2964 ENDDO
2965C
2966 RETURN

◆ interlagran()

subroutine interlagran ( real, dimension(ltab) tab,
real, dimension(ltab) lx,
integer ltab,
real x,
real y )

Definition at line 2895 of file grid2mat.F.

2896C-----------------------------------------------
2897C I m p l i c i t T y p e s
2898C-----------------------------------------------
2899#include "implicit_f.inc"
2900C-----------------------------------------------
2901C D u m m y A r g u m e n t s
2902C-----------------------------------------------
2903 REAL TAB(LTAB),LX(LTAB),X,Y
2904 INTEGER LTAB
2905C-----------------------------------------------
2906C L o c a l V a r i a b l e s
2907C-----------------------------------------------
2908 INTEGER I,J
2909 REAL MUL,ALPHA
2910 y = 0
2911
2912 IF (x<=10)THEN
2913
2914 DO i=1,ltab
2915
2916 mul = 1.
2917 DO j=1,ltab
2918 IF (i/=j) THEN
2919 mul= mul * (x-lx(j))/(lx(i)-lx(j))
2920 ENDIF
2921 ENDDO
2922
2923 y = y + tab(i)*mul
2924
2925 ENDDO
2926 ENDIF
2927 IF(x>10.or.y<=0)THEN
2928 alpha = (tab(3)-tab(1))/(lx(3)-lx(1))
2929 y = x*alpha + tab(3)-alpha*lx(3)
2930 ENDIF
alpha
#define alpha
Definition eval.h:35

◆ iwcontdd()

subroutine iwcontdd ( integer, dimension(*) nsv,
integer, dimension(*) msr,
integer nsn,
integer nmn,
integer, dimension(5,*) iwcont,
integer nsnt,
integer nmnt )

Definition at line 3006 of file grid2mat.F.

3007C-----------------------------------------------
3008C I m p l i c i t T y p e s
3009C-----------------------------------------------
3010#include "implicit_f.inc"
3011C-----------------------------------------------
3012C D u m m y A r g u m e n t s
3013C-----------------------------------------------
3014 INTEGER NSV(*), MSR(*), IWCONT(5,*), NSN, NMN, NSNT, NMNT
3015C-----------------------------------------------
3016C L o c a l V a r i a b l e s
3017C-----------------------------------------------
3018 INTEGER I, N
3019C-----------------------------------------------
3020 DO i = 1, nsn
3021 n = nsv(i)
3022 iwcont(1,n) = iwcont(1,n)+1
3023 nsnt = nsnt + 1
3024 ENDDO
3025C
3026 DO i = 1, nmn
3027 n = msr(i)
3028C IWCONT(1,N) = IWCONT(1,N)+1
3029 iwcont(2,n) = iwcont(2,n)+1
3030 nmnt = nmnt + 1
3031 ENDDO
3032C
3033 RETURN

◆ iwcontdd_151()

subroutine iwcontdd_151 ( integer, dimension(nbric), intent(in) bufbric,
integer, intent(in) nbric,
integer, dimension(nmn), intent(in) msr,
integer, intent(in) nmn,
integer, dimension(5,numnod), intent(inout) iwcont,
integer, intent(inout) nsnt,
integer, intent(inout) nmnt,
integer, intent(in) numnod,
integer, dimension(nixs,numels), intent(in) ixs,
integer, intent(in) numels,
integer, dimension(numnod), intent(in) nale )

Definition at line 3044 of file grid2mat.F.

3045 use element_mod , only : nixs
3046C-----------------------------------------------
3047C D e s c r i p t i o n
3048C-----------------------------------------------
3049C Equivalent treatment than IWCONTDD() BUT FOR SPECIFIC CASE OF INTER18+LAW151 (COLLOCATED SCHEME)
3050C-----------------------------------------------
3051C I m p l i c i t T y p e s
3052C-----------------------------------------------
3053#include "implicit_f.inc"
3054C-----------------------------------------------
3055C D u m m y A r g u m e n t s
3056C-----------------------------------------------
3057 INTEGER,INTENT(IN) :: NMN, NUMNOD,NUMELS
3058 INTEGER,INTENT(IN) :: MSR(NMN),IXS(NIXS,NUMELS),NALE(NUMNOD)
3059 INTEGER,INTENT(INOUT) :: IWCONT(5,NUMNOD),NSNT, NMNT
3060 INTEGER,INTENT(IN) :: NBRIC
3061 INTEGER,INTENT(IN) :: BUFBRIC(NBRIC)
3062C-----------------------------------------------
3063C L o c a l V a r i a b l e s
3064C-----------------------------------------------
3065 INTEGER I, N, IELEM, INOD, J
3066C-----------------------------------------------
3067
3068 DO i = 1, nbric
3069 ielem = bufbric(i)
3070 DO j=2,9
3071 inod = ixs(j,ielem)
3072 IF(nale(inod) /= 0 .AND. inod > 0)THEN
3073 iwcont(1,inod) = iwcont(1,inod)+1
3074 nsnt = nsnt + 1
3075 endif!NALE(node_i)==0 <=> lagrangian node_i
3076 ENDDO
3077 ENDDO
3078
3079 DO i = 1, nmn
3080 n = msr(i)
3081 iwcont(2,n) = iwcont(2,n)+1
3082 nmnt = nmnt + 1
3083 ENDDO
3084C
3085 RETURN

◆ iwcontdd_new()

subroutine iwcontdd_new ( integer, dimension(*) nsv,
integer, dimension(*) msr,
integer nsn,
integer nmn,
integer, dimension(5,*) iwcont,
integer cost )

Definition at line 2973 of file grid2mat.F.

2974C-----------------------------------------------
2975C I m p l i c i t T y p e s
2976C-----------------------------------------------
2977#include "implicit_f.inc"
2978C-----------------------------------------------
2979C D u m m y A r g u m e n t s
2980C-----------------------------------------------
2981 INTEGER NSV(*), MSR(*), IWCONT(5,*), NSN, NMN
2982 INTEGER :: COST
2983C-----------------------------------------------
2984C L o c a l V a r i a b l e s
2985C-----------------------------------------------
2986 INTEGER I, N
2987C-----------------------------------------------
2988 DO i = 1, nsn
2989 n = nsv(i)
2990 iwcont(3,n) = iwcont(3,n)+cost
2991 ENDDO
2992C
2993 DO i = 1, nmn
2994 n = msr(i)
2995 iwcont(4,n) = iwcont(4,n)+cost
2996 ENDDO
2997C
2998 RETURN

◆ lec_ddw()

subroutine lec_ddw ( character filnam,
integer len_filnam,
integer, dimension(7,taille_old) tab_ump_old,
dimension(taille_old) cputime_mp_old )

Definition at line 3266 of file grid2mat.F.

3267C-----------------------------------------------
3268C M o d u l e s
3269C-----------------------------------------------
3270 USE reader_old_mod , ONLY : line
3271C-----------------------------------------------
3272C I m p l i c i t T y p e s
3273C-----------------------------------------------
3274#include "implicit_f.inc"
3275C-----------------------------------------------
3276C C o m m o n B l o c k s
3277C-----------------------------------------------
3278#include "param_c.inc"
3279#include "scr17_c.inc"
3280C-----------------------------------------------
3281C D u m m y A r g u m e n t s
3282C-----------------------------------------------
3283 INTEGER, DIMENSION(7,TAILLE_OLD) :: TAB_UMP_OLD
3284 my_real, DIMENSION(TAILLE_OLD) :: cputime_mp_old
3285C Dynamical User Library
3286 CHARACTER FILNAM*512
3287 INTEGER LEN_FILNAM
3288C-----------------------------------------------
3289C L o c a l V a r i a b l e s
3290C-----------------------------------------------
3291 INTEGER J
3292C-----------------------------------------------
3293C Reading of Mat/Prop coupled weights
3294 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED')
3295 line = ' '
3296 DO WHILE(line(1:12) /= ' LAW_NUMB')
3297 READ(30,fmt='(A)')line
3298 ENDDO
3299 DO j=1,taille_old
3300 READ(30,'(I12,A,I12,A,I12,A,
3301 . I12,A,I12,A,I12,A,
3302 . I12,A,E15.5)')
3303 . tab_ump_old(6,j),line(1:2),tab_ump_old(7,j),line(1:2),tab_ump_old(5,j),line(1:2),
3304 . tab_ump_old(3,j),line(1:2),tab_ump_old(1,j),line(1:2),tab_ump_old(4,j),line(1:2),
3305 . tab_ump_old(2,j),line(1:2),cputime_mp_old(j)
3306
3307 ENDDO
3308 CLOSE(unit=30)
3309 RETURN

◆ lec_ddw_poin()

subroutine lec_ddw_poin ( character filnam,
integer len_filnam,
integer, dimension(nummat_old) poin_ump_old )

Definition at line 3359 of file grid2mat.F.

3360C-----------------------------------------------
3361C M o d u l e s
3362C-----------------------------------------------
3363 USE reader_old_mod , ONLY : line
3364C-----------------------------------------------
3365C I m p l i c i t T y p e s
3366C-----------------------------------------------
3367#include "implicit_f.inc"
3368C-----------------------------------------------
3369C C o m m o n B l o c k s
3370C-----------------------------------------------
3371#include "param_c.inc"
3372#include "scr17_c.inc"
3373C-----------------------------------------------
3374C D u m m y A r g u m e n t s
3375C-----------------------------------------------
3376C Dynamical User Library
3377 CHARACTER FILNAM*512
3378 INTEGER LEN_FILNAM
3379 INTEGER, DIMENSION(NUMMAT_OLD) :: POIN_UMP_OLD
3380C-----------------------------------------------
3381C L o c a l V a r i a b l e s
3382C-----------------------------------------------
3383 INTEGER I
3384C-----------------------------------------------
3385C Reading the pointer
3386 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED')
3387 line = ' '
3388 DO WHILE(line(1:12) /= ' POINTER')
3389 READ(30,fmt='(a)')LINE
3390 ENDDO
3391 READ(30,'(a,i10)') LINE(1:47),NUMMAT_OLD
3392 READ(30,'(a,i10)') LINE(1:47),NUMGEO_OLD
3393 DO I=1,NUMMAT_OLD
3394 READ(30,'(i8)') POIN_UMP_OLD(I)
3395 ENDDO
3396 CLOSE(UNIT=30)
3397 RETURN

◆ prelec_ddw()

subroutine prelec_ddw ( character filnam,
integer len_filnam,
logical marqueur3 )

Definition at line 3194 of file grid2mat.F.

3195C-----------------------------------------------
3196C M o d u l e s
3197C-----------------------------------------------
3198 USE reader_old_mod , ONLY : line
3199C-----------------------------------------------
3200C I m p l i c i t T y p e s
3201C-----------------------------------------------
3202#include "implicit_f.inc"
3203C-----------------------------------------------
3204C C o m m o n B l o c k s
3205C-----------------------------------------------
3206#include "com01_c.inc"
3207#include "param_c.inc"
3208#include "scr15_c.inc"
3209#include "scr17_c.inc"
3210C-----------------------------------------------
3211C D u m m y A r g u m e n t s
3212C-----------------------------------------------
3213 LOGICAL MARQUEUR3
3214C Dynamical User Library
3215 CHARACTER FILNAM*512
3216 INTEGER LEN_FILNAM
3217C-----------------------------------------------
3218C L o c a l V a r i a b l e s
3219C-----------------------------------------------
3220 INTEGER MARQUEUR,MARQUEUR2
3221C-----------------------------------------------
3222 filnam =rootnam(1:rootlen)//'_0001.ddw'
3223 len_filnam=len_trim(filnam)
3224 line=' '
3225 marqueur2 = 0
3226 test_poids = 0
3227 INQUIRE(file=filnam(1:len_filnam), exist=marqueur3)
3228
3229 IF(marqueur3) THEN
3230 test_poids = 1
3231C Number of lines
3232 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED')
3233 DO WHILE(line(1:12) /= ' POINTER')
3234 marqueur2=marqueur2+1
3235 READ(30,fmt='(A)')line
3236 ENDDO
3237 CLOSE(unit=30)
3238 marqueur2 = marqueur2 - 3
3239
3240 marqueur = 0
3241C Pre-reading of Mat/Prop coupled weights
3242 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED',
3243 . position='REWIND')
3244 line = ' '
3245 DO WHILE(line(1:12) /= ' LAW_NUMB')
3246 marqueur=marqueur+1
3247 READ(30,fmt='(A)')line
3248 ENDDO
3249 CLOSE(unit=30)
3250 marqueur = marqueur + 1
3251 taille_old= marqueur2 - marqueur
3252 ELSE
3253 nummat_old = 0
3254 numgeo_old = 0
3255 taille_old = 0
3256 ENDIF
3257 RETURN

◆ prelec_ddw_poin()

subroutine prelec_ddw_poin ( character filnam,
integer len_filnam )

Definition at line 3318 of file grid2mat.F.

3319C-----------------------------------------------
3320C M o d u l e s
3321C-----------------------------------------------
3322 USE reader_old_mod , ONLY : line
3323C-----------------------------------------------
3324C I m p l i c i t T y p e s
3325C-----------------------------------------------
3326#include "implicit_f.inc"
3327C-----------------------------------------------
3328C C o m m o n B l o c k s
3329C-----------------------------------------------
3330#include "param_c.inc"
3331#include "scr17_c.inc"
3332C-----------------------------------------------
3333C D u m m y A r g u m e n t s
3334C-----------------------------------------------
3335C Dynamical User Library
3336 CHARACTER FILNAM*512
3337 INTEGER LEN_FILNAM
3338C-----------------------------------------------
3339C L o c a l V a r i a b l e s
3340C-----------------------------------------------
3341C Reading the pointer
3342 OPEN(unit=30,file=filnam(1:len_filnam),form='FORMATTED')
3343 line = ' '
3344 DO WHILE(line(1:12) /= ' POINTER')
3345 READ(30,fmt='(A)')line
3346 ENDDO
3347 READ(30,'(A,I10)') line(1:47),nummat_old
3348 READ(30,'(A,I10)') line(1:47),numgeo_old
3349 CLOSE(unit=30)
3350 RETURN

◆ reini_matprop()

subroutine reini_matprop ( integer taille,
integer taille2,
integer, dimension(5,npart) tab_ump_loc,
integer, dimension(7+6,taille2,2) tab_ump_loc2,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) isolnod,
integer, dimension(nummat) poin_ump )

Definition at line 3405 of file grid2mat.F.

3407 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
3408C-----------------------------------------------
3409C I m p l i c i t T y p e s
3410C-----------------------------------------------
3411#include "implicit_f.inc"
3412C-----------------------------------------------
3413C C o m m o n B l o c k s
3414C-----------------------------------------------
3415#include "com04_c.inc"
3416C-----------------------------------------------
3417C D u m m y A r g u m e n t s
3418C-----------------------------------------------
3419 INTEGER TAILLE,TAILLE2
3420 INTEGER, DIMENSION(NUMMAT) :: POIN_UMP
3421 INTEGER, DIMENSION(7+6,TAILLE2,2) :: TAB_UMP_LOC2
3422 INTEGER, DIMENSION(5,NPART) :: TAB_UMP_LOC
3423 INTEGER IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),
3424 . IXP(NIXP,*),IXR(NIXR,*),IXTG(NIXTG,*),ISOLNOD(*)
3425C-----------------------------------------------
3426C L o c a l V a r i a b l e s
3427C-----------------------------------------------
3428 INTEGER MARQUEUR,K1,K2,K3,K4,
3429 . I,J,ITY,TEST
3430C-----------------------------------------------
3431 tab_ump_loc2 = 0
3432 IF(numels>0) THEN
3433 ity = 1
3434 DO i=1,numels
3435 k1 = ixs(1,i)
3436 k2 = ixs(10,i)
3437 k3 = poin_ump(k1)! + POIN_UMP(NUMMAT+K2)
3438 marqueur = isolnod(i)
3439 k4 = 0
3440 IF(marqueur==4) THEN
3441 k4 = 1
3442 ELSEIF(marqueur==6) THEN
3443 k4 = 2
3444 ELSEIF(marqueur==8) THEN
3445 k4 = 3
3446 ELSEIF(marqueur==10) THEN
3447 k4 = 4
3448 ELSEIF(marqueur==16) THEN
3449 k4 = 5
3450 ELSEIF(marqueur==20) THEN
3451 k4 = 6
3452 ENDIF
3453C
3454 IF(k3/=0) THEN
3455 test=0
3456 DO WHILE((k3<=taille2).AND.(test==0))
3457 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3458 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3459 tab_ump_loc2(ity+k4,k3,2) = 1
3460 test=1
3461 ELSE
3462 k3=k3+1
3463 ENDIF
3464 ENDDO
3465 ENDIF
3466 ENDDO
3467 ENDIF
3468
3469! stop
3470 IF(numelq>0) THEN
3471 k4 = 6
3472 ity = 2
3473 DO i =1,numelq
3474 k1 = ixq(1,i)
3475 k2 = ixq(6,i)
3476 k3 = 1!POIN_UMP(K1) !+ POIN_UMP(NUMMAT+K2)
3477 IF(k3/=0) THEN
3478 test=0
3479 DO WHILE((k3<=taille2).AND.(test==0))
3480 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3481 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3482 tab_ump_loc2(ity+k4,k3,2) = 1
3483 test=1
3484 ELSE
3485 k3=k3+1
3486 ENDIF
3487 ENDDO
3488 ENDIF
3489 ENDDO
3490 ENDIF
3491 IF(numelc>0) THEN
3492 k4 = 6
3493 ity = 3
3494 DO i=1,numelc
3495 k1 = ixc(1,i)
3496 k2 = ixc(6,i)
3497 k3 = poin_ump(k1)! + POIN_UMP(NUMMAT+K2)
3498 IF(k3/=0) THEN
3499 test=0
3500 DO WHILE((k3<=taille2).AND.(test==0))
3501 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3502 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3503 tab_ump_loc2(ity+k4,k3,2) = 1
3504 test=1
3505 ELSE
3506 k3=k3+1
3507 ENDIF
3508 ENDDO
3509 ENDIF
3510 ENDDO
3511 ENDIF
3512 IF(numelt>0) THEN
3513 k4 = 6
3514 ity = 4
3515 DO i=1,numelt
3516 k1 = ixt(1,i)
3517 k2 = ixt(4,i)
3518 k3 = poin_ump(k1)! + POIN_UMP(NUMMAT+K2)
3519 IF(k3/=0) THEN
3520 test=0
3521 DO WHILE((k3<=taille2).AND.(test==0))
3522 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3523 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3524 tab_ump_loc2(ity+k4,k3,2) = 1
3525 test=1
3526 ELSE
3527 k3=k3+1
3528 ENDIF
3529 ENDDO
3530 ENDIF
3531 ENDDO
3532 ENDIF
3533 IF(numelp>0) THEN
3534 k4 = 6
3535 ity = 5
3536 DO i=1,numelp
3537 k1 = ixp(1,i)
3538 k2 = ixp(5,i)
3539 k3 = 1!POIN_UMP(K1)! + POIN_UMP(NUMMAT+K2)
3540 IF(k3/=0) THEN
3541 test=0
3542 DO WHILE((k3<=taille2).AND.(test==0))
3543 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3544 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3545 tab_ump_loc2(ity+k4,k3,2) = 1
3546 test=1
3547 ELSE
3548 k3=k3+1
3549 ENDIF
3550 ENDDO
3551 ENDIF
3552 ENDDO
3553 ENDIF
3554 IF(numelr>0) THEN
3555 k4 = 6
3556 k1 = 0
3557 ity = 6
3558 DO i=1,numelr
3559 k2 = ixr(1,i)
3560 k3 = k1 + 1
3561 IF(k3/=0) THEN
3562 test=0
3563 DO WHILE((k3<=taille2).AND.(test==0))
3564 IF((tab_ump_loc(1,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3565 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3566 tab_ump_loc2(ity+k4,k3,2) = 1
3567 test=1
3568 ELSE
3569 k3=k3+1
3570 ENDIF
3571 ENDDO
3572 ENDIF
3573 ENDDO
3574 ENDIF
3575 IF(numeltg>0) THEN
3576 k4 = 6
3577 ity = 7
3578 DO i=1,numeltg
3579 k1 = ixtg(1,i)
3580 k2 = ixtg(5,i)
3581 k3 = 1!POIN_UMP(K1) !+ POIN_UMP(NUMMAT+K2)
3582 IF(k3/=0) THEN
3583 test=0
3584 DO WHILE((k3<=taille2).AND.(test==0))
3585 IF((tab_ump_loc(3,k3)==k1).AND.(tab_ump_loc(4,k3)==k2)) THEN
3586 tab_ump_loc2(ity+k4,k3,1) = tab_ump_loc2(ity+k4,k3,1) + 1
3587 tab_ump_loc2(ity+k4,k3,2) = 1
3588 test=1
3589 ELSE
3590 k3=k3+1
3591 ENDIF
3592 ENDDO
3593 ENDIF
3594 ENDDO
3595 ENDIF
3596
3597 taille = 0
3598 DO j=1,taille2
3599 marqueur = 0
3600 DO i=1,13
3601 IF(tab_ump_loc2(i,j,2)>0) THEN
3602 marqueur = marqueur + 1
3603 ENDIF
3604 ENDDO
3605 taille = taille + marqueur
3606 ENDDO
3607
3608 RETURN

◆ reini_matprop2()

subroutine reini_matprop2 ( integer taille,
integer taille2,
integer, dimension(5,npart) tab_ump_loc,
integer, dimension(7+6,taille2,2) tab_ump_loc2,
integer, dimension(7,taille) tab_ump,
integer, dimension(6) tab_sol,
integer, dimension(nummat) poin_ump )

Definition at line 3616 of file grid2mat.F.

3619C-----------------------------------------------
3620C I m p l i c i t T y p e s
3621C-----------------------------------------------
3622#include "implicit_f.inc"
3623C-----------------------------------------------
3624C C o m m o n B l o c k s
3625C-----------------------------------------------
3626#include "com04_c.inc"
3627C-----------------------------------------------
3628C D u m m y A r g u m e n t s
3629C-----------------------------------------------
3630 INTEGER TAILLE,TAILLE2,MARQUEUR2
3631 INTEGER, DIMENSION(7+6,TAILLE2,2) :: TAB_UMP_LOC2
3632 INTEGER, DIMENSION(6) :: TAB_SOL
3633 INTEGER, DIMENSION(NUMMAT) :: POIN_UMP
3634 INTEGER, DIMENSION(7,TAILLE) :: TAB_UMP
3635 INTEGER, DIMENSION(5,NPART) :: TAB_UMP_LOC
3636C-----------------------------------------------
3637C L o c a l V a r i a b l e s
3638C-----------------------------------------------
3639 INTEGER MARQUEUR,I,J,K
3640C-----------------------------------------------
3641
3642 tab_sol(1) = 1004
3643 tab_sol(2) = 1006
3644 tab_sol(3) = 1008
3645 tab_sol(4) = 1010
3646 tab_sol(5) = 1016
3647 tab_sol(6) = 1020
3648 marqueur = 1
3649 DO j=1,taille2
3650 DO i=1,13
3651 IF(tab_ump_loc2(i,j,2)>0) THEN
3652 DO k=1,4
3653 tab_ump(k,marqueur) = tab_ump_loc(k,j)
3654 ENDDO
3655 tab_ump(5,marqueur) = tab_ump_loc2(i,j,1)
3656 tab_ump(6,marqueur) = tab_ump_loc(5,j)
3657 IF(i>7) THEN
3658 tab_ump(7,marqueur) = i-6
3659 ELSEIF(i==1) THEN
3660 tab_ump(7,marqueur) = i
3661 ELSE
3662 tab_ump(7,marqueur) = tab_sol(i-1)
3663 ENDIF
3664 marqueur = marqueur + 1
3665 ENDIF
3666 ENDDO
3667 ENDDO
3668
3669 poin_ump(tab_ump(3,1)) = 1
3670 DO i=2,taille
3671 IF(tab_ump(3,i-1)/=tab_ump(3,i)) THEN
3672 poin_ump(tab_ump(3,i)) = i
3673 ENDIF
3674 ENDDO
3675
3676 RETURN

◆ spdometis()

subroutine spdometis ( integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) nod2sp,
integer, dimension(*) cepsp,
integer, dimension(nbpartinlet) reservep,
integer, dimension(*) sph2sol,
integer, dimension(*) cep )

Definition at line 2623 of file grid2mat.F.

2625
2626 USE format_mod , ONLY : fmw_a_i
2627C-----------------------------------------------
2628C I m p l i c i t T y p e s
2629C-----------------------------------------------
2630#include "implicit_f.inc"
2631C-----------------------------------------------
2632C C o m m o n B l o c k s
2633C-----------------------------------------------
2634#include "units_c.inc"
2635#include "sphcom.inc"
2636#include "com01_c.inc"
2637#include "scr12_c.inc"
2638#include "scr17_c.inc"
2639C-----------------------------------------------
2640C D u m m y A r g u m e n t s
2641C-----------------------------------------------
2642 INTEGER KXSP(NISP,*), IXSP(KVOISPH,*), NOD2SP(*), CEPSP(*),
2643 . SPH2SOL(*), CEP(*)
2644C-----------------------------------------------
2645C L o c a l V a r i a b l e s
2646C-----------------------------------------------
2647 INTEGER NEDGES, CC, N, N1, N2, NI, I, J, ADDX,
2648 . NUMSPHA, P, NCOND, NNODE, NEC, IERR1, MODE, NOD1, NOD2,
2649 . IWFLG, NFLAG, NEWEDGE
2650 INTEGER(kind=8) :: IW
2651 INTEGER IWD(NUMSPH), RESERVEP(NBPARTINLET),
2652 . WORK(70000), OPTIONS(40), CEPSL(NUMSPH)
2653 INTEGER, DIMENSION(:),ALLOCATABLE :: IEND, XADJ, ADJNCY,
2654 . ITRIM,INDEXM, EDGE
2655 REAL UBVEC(15)
2656C metis5 null pointers
2657 INTEGER, POINTER :: adjwgt(:)=>null(),vsize(:)=>null()
2658 REAL, POINTER :: tpwgts(:)=>null()
2659 INTEGER METIS_PartGraphKway, METIS_PartGraphRecursive,
2660 . METIS_SetDefaultOptions,Wrap_METIS_PartGraphKway,
2661 . Wrap_METIS_PartGraphRecursive
2662C-----------------------------------------------
2663C E x t e r n a l F u n c t i o n s
2664C-----------------------------------------------
2665 EXTERNAL metis_partgraphkway, metis_partgraphrecursive,
2666 . metis_setdefaultoptions,wrap_metis_partgraphkway,
2667 . wrap_metis_partgraphrecursive
2668C-----------------------------------------------
2669C S o u r c e L i n e s
2670C-----------------------------------------------
2671C
2672C Connectivitis cells SPH
2673C
2674c Numsph Active Less Sph2sol/= 0
2675 numspha = numsph - nsphres - nsphsol
2676
2677 nedges = 0
2678 DO n = 1, numspha
2679 DO cc = 1, min(12,kxsp(4,n))
2680 n2 = nod2sp(ixsp(cc,n))
2681 IF (n/=n2)THEN
2682 IF ((n2 < first_sphsol .OR. n2 >= first_sphsol+nsphsol)) THEN
2683 nedges = nedges + 1
2684 END IF
2685 ENDIF
2686 END DO
2687 END DO
2688C
2689
2690 IF (nedges>0) THEN
2691 ALLOCATE(iend(2*nedges))
2692 ni = 0
2693 DO n = 1, numspha
2694 DO cc = 1, min(12,kxsp(4,n))
2695 n2 = nod2sp(ixsp(cc,n))
2696 IF (n/=n2)THEN
2697 IF((n2 < first_sphsol .OR. n2 >= first_sphsol+nsphsol)) THEN
2698 IF ( n < n2 ) THEN
2699 ni = ni + 1
2700 iend(2*ni-1)=n
2701 iend(2*ni)=n2
2702 ELSE
2703 ni = ni + 1
2704 iend(2*ni-1)=n2
2705 iend(2*ni)=n
2706 END IF
2707 END IF
2708 ENDIF
2709 END DO
2710 END DO
2711C
2712C METIS ADDITIONAL TREATMENT
2713C
2714 ALLOCATE(itrim(2*nedges),stat=ierr1)
2715 ALLOCATE(indexm(2*nedges),stat=ierr1)
2716
2717 DO i = 1, nedges
2718 itrim(2*i-1) = iend(2*i-1)
2719 itrim(2*i) = iend(2*i)
2720 indexm(i) = i
2721 ENDDO
2722 mode = 0
2723 CALL my_orders(mode,work,itrim,indexm,nedges,2)
2724
2725 DO i = 1, nedges
2726 iend(2*i-1)= itrim(2*indexm(i)-1)
2727 iend(2*i) = itrim(2*indexm(i))
2728 ENDDO
2729
2730C Metis structures 1/2
2731 ALLOCATE(xadj(numspha+1),stat=ierr1)
2732C init XADJ
2733 xadj(1:numspha+1)=0
2734C first node
2735 i = 1
2736 nod1 = iend(2*i-1)
2737 nod2 = iend(2*i)
2738 newedge = 1
2739 xadj(nod1+1)=xadj(nod1+1)+1
2740 xadj(nod2+1)=xadj(nod2+1)+1
2741 DO i = 2, nedges
2742C test to suppress duplicate entry
2743 IF (nod1/=iend(2*i-1).OR.nod2/=iend(2*i)) THEN
2744 newedge = newedge + 1
2745 iend(2*newedge-1) = iend(2*i-1)
2746 iend(2*newedge) = iend(2*i)
2747 nod1 = iend(2*i-1)
2748 nod2 = iend(2*i)
2749C count xadj
2750 xadj(nod1+1)=xadj(nod1+1)+1
2751 xadj(nod2+1)=xadj(nod2+1)+1
2752 ENDIF
2753 ENDDO
2754
2755 DEALLOCATE(itrim)
2756 DEALLOCATE(indexm)
2757C
2758 nedges = newedge
2759
2760C Metis structures 2/2
2761 ALLOCATE(adjncy(2*nedges),stat=ierr1)
2762
2763C build xadj & adjcny in a simple pass
2764
2765C compute XADJ addresses
2766 xadj(1)=1
2767 DO i=1,numspha
2768 xadj(i+1)=xadj(i+1)+xadj(i)
2769 END DO
2770C fill adjncy
2771 DO i=1,nedges
2772 nod1=iend(2*i-1)
2773 nod2=iend(2*i)
2774 addx=xadj(nod1)
2775 adjncy(addx)=nod2
2776 xadj(nod1)=xadj(nod1)+1
2777 addx=xadj(nod2)
2778 adjncy(addx)=nod1
2779 xadj(nod2)=xadj(nod2)+1
2780 END DO
2781C reset XADJ
2782 DO i=numspha+1,2,-1
2783 xadj(i)=xadj(i-1)
2784 END DO
2785 xadj(1)=1
2786 DEALLOCATE(iend)
2787 ENDIF
2788C----------------------
2789C
2790C Initialize uniform weights
2791c init for every SPH cells
2792C
2793 DO n = 1, numspha
2794 iwd(n) = 1
2795 END DO
2796C
2797 iwflg=2
2798 nflag=1
2799C old metis option kept for compatibility
2800 options(1)=0
2801 ncond=1
2802 nnode=nspmd
2803 ubvec(1)=1.01 ! tolerance on loadbalancing SPH cell
2804C new Metis5 Definition
2805 ierr1 = metis_setdefaultoptions(options)
2806C OPTIONS(METIS_OPTION_NUMBERING) = 1 ! Fortran numbering -- position 17 en 5.0.2 et 18 en 5.1
2807 options(18)=1
2808C
2809C Proc attribution on NUMSPA cells
2810C
2811 IF (nedges > 0 .AND. nspmd > 1) THEN
2812C KWAY METIS
2813 IF(dectyp==3.OR.dectyp==5)THEN
2814 ierr1 = wrap_metis_partgraphkway(
2815 1 numspha,ncond,xadj,adjncy,
2816 2 iwd,nnode,
2817 3 ubvec,options,nec,cepsl)
2818 ELSEIF(dectyp==4.OR.dectyp==6)THEN
2819C RSB METIS
2820 ierr1 = wrap_metis_partgraphrecursive(
2821 1 numspha,ncond,xadj,adjncy,
2822 2 iwd,nnode,
2823 3 ubvec,options,nec,cepsl)
2824 END IF
2825C
2826 DO n = 1, numspha
2827 cepsp(n) = cepsl(n)-1
2828 END DO
2829 DEALLOCATE(xadj,adjncy)
2830 ELSE IF (nspmd == 1) THEN
2831 DO n = 1, numspha
2832 cepsp(n) = 0
2833 END DO
2834 ELSE
2835C Could be improved by geometric domain decomposition
2836 DO n = 1, numspha
2837 cepsp(n) = int( (dble(n-1)/dble(numspha))*dble(nspmd) )
2838 cepsp(n) = max(0,min(cepsp(n),nspmd-1))
2839 END DO
2840 END IF
2841
2842C Repartition by part
2843C for each part, KRESERV was saved, we put KRESERV RESERVE by proc by part
2844 n = first_sphres
2845
2846 DO i = 1, nbpartinlet
2847 DO p = 0, nspmd-1
2848 DO j = 1, reservep(i)
2849 cepsp(n) = p
2850 n = n+1
2851 ENDDO
2852 ENDDO
2853 ENDDO
2854C
2855C SPH generated from solids are enforced on the same proc as the solid
2856 DO n = first_sphsol, first_sphsol+nsphsol-1
2857 cepsp(n) = cep(sph2sol(n))
2858 END DO
2859C
2860 WRITE(iout,'(A)')' '
2861 IF(dectyp==3.OR.dectyp==5)THEN
2862 WRITE(iout,'(A)')
2863 . ' SPH DOMAIN DECOMPOSITION USING MULTILEVEL KWAY'
2864 ELSEIF(dectyp==4.OR.dectyp==6)THEN
2865 WRITE(iout,'(A)')
2866 . ' SPH DOMAIN DECOMPOSITION USING MULTILEVEL RSB'
2867 END IF
2868 WRITE(iout,*)' '
2869 WRITE(iout,fmt=fmw_a_i)
2870 . ' CELLS NUMBER = ',numsph
2871 WRITE(iout,fmt=fmw_a_i)
2872 . ' EDGES FOUND = ',nedges
2873 WRITE(iout,*)' '
2874 WRITE(iout,*)'#PROC ELT WEIGHT'
2875 DO i = 1, nspmd
2876 iw = 0
2877 DO j = 1, numsph
2878 IF (cepsp(j)+1==i .AND. iwd(j) > 0) THEN
2879 iw = iw + iwd(j)
2880 ENDIF
2881 ENDDO
2882 WRITE(iout,'(I4,I8)')i,iw
2883 END DO
2884 WRITE(iout,*)' '
2885C
2886 RETURN

◆ stat_domdec()

subroutine stat_domdec ( double precision, dimension(nspmd) wis,
double precision, dimension(nspmd) wi2,
double precision, dimension(nspmd) wfsi,
double precision, dimension(nspmd) wdel,
double precision, dimension(nspmd) wddl,
double precision, dimension(nspmd) wcand,
double precision, dimension(nspmd) wsol,
double precision, dimension(nspmd) wr2r,
double precision, dimension(nspmd) wkin,
integer, dimension(ncond*nelem) iwd,
integer ncond,
integer icelem,
integer icints,
integer icint2,
integer iccand,
integer icddl,
integer icsol,
integer icfsi,
integer icdel,
integer icr2r,
integer ickin,
double precision, dimension(ncritmax) average,
double precision, dimension(ncritmax) deviation,
double precision, dimension(ncritmax) dmax,
double precision, dimension(ncritmax) dmin,
integer, dimension(nelem) cep,
integer nelem,
double precision, dimension(nspmd) w,
integer icintm,
double precision, dimension(nspmd) wim,
integer ncritmax,
double precision, dimension(nspmd) wnod_sms,
integer icnod_sms )

Definition at line 3683 of file grid2mat.F.

3690
3691C-----------------------------------------------
3692C I m p l i c i t T y p e s
3693C-----------------------------------------------
3694#include "implicit_f.inc"
3695C-----------------------------------------------
3696C C o m m o n B l o c k s
3697C-----------------------------------------------
3698#include "com01_c.inc"
3699C-----------------------------------------------
3700C D u m m y A r g u m e n t s
3701C-----------------------------------------------
3702 INTEGER ICKIN,ICR2R,ICDEL,ICFSI,ICSOL,ICDDL,ICCAND,
3703 . ICINTS,ICINTM,ICINT2,NCOND,NELEM,ICELEM,NCRITMAX,ICNOD_SMS,
3704 . CEP(NELEM),IWD(NCOND*NELEM)
3705 DOUBLE PRECISION AVERAGE(NCRITMAX), DEVIATION(NCRITMAX), DMIN(NCRITMAX),DMAX(NCRITMAX),
3706 . W(NSPMD), WIS(NSPMD), WI2(NSPMD), WDDL(NSPMD),
3707 . WFSI(NSPMD),WCAND(NSPMD),WSOL(NSPMD),WKIN(NSPMD),
3708 . WDEL(NSPMD), WR2R(NSPMD), WIM(NSPMD),WNOD_SMS(NSPMD)
3709
3710C-----------------------------------------------
3711C L o c a l V a r i a b l e s
3712C-----------------------------------------------
3713 INTEGER I,J
3714C----------------------------------------------
3715
3716 DO i = 1, nspmd
3717 w(i) = zero
3718 wis(i) = zero
3719 wim(i) = zero
3720 wi2(i) = zero
3721 wfsi(i) = zero
3722 wdel(i) = zero
3723 wddl(i) = zero
3724 wcand(i) = zero
3725 wsol(i) = zero
3726 wr2r(i) = zero
3727 wkin(i) = zero
3728 wnod_sms(i) = zero
3729 END DO
3730 DO j = 1, nelem
3731 i = cep(j)
3732 w(i) = w(i) + iwd(ncond*(j-1)+icelem)
3733 IF(icints/=0)wis(i) = wis(i) + iwd(ncond*(j-1)+icints)
3734 IF(icintm/=0)wim(i) = wim(i) + iwd(ncond*(j-1)+icintm)
3735 IF(icint2/=0)wi2(i) = wi2(i) + iwd(ncond*(j-1)+icint2)
3736 IF(iccand/=0)wcand(i) = wcand(i) + iwd(ncond*(j-1)+iccand)
3737 IF(icddl/=0)wddl(i) = wddl(i) + iwd(ncond*(j-1)+icddl)
3738 IF(icsol/=0)wsol(i) = wsol(i) + iwd(ncond*(j-1)+icsol)
3739 IF(icfsi/=0)wfsi(i) = wfsi(i) + iwd(ncond*(j-1)+icfsi)
3740 IF(icdel/=0)wdel(i) = wdel(i) + iwd(ncond*(j-1)+icdel)
3741 IF(icr2r/=0)wr2r(i) = wr2r(i) + iwd(ncond*(j-1)+icr2r)
3742 IF(ickin/=0)wkin(i) = wkin(i) + iwd(ncond*(j-1)+ickin)
3743 IF(icnod_sms/=0)wnod_sms(i) = wnod_sms(i) + iwd(ncond*(j-1)+icnod_sms)
3744 ENDDO
3745C
3746C compute Average and Standard deviation
3747C
3748 DO i=1,ncritmax
3749 average(i)=zero
3750 deviation(i)=zero
3751 dmax(i)=zero
3752 dmin(i)=2147483647
3753 END DO
3754 DO i = 1, nspmd
3755 average(1)=average(1)+w(i)
3756 average(2)=average(2)+wis(i)
3757 average(3)=average(3)+wi2(i)
3758 average(4)=average(4)+wcand(i)
3759 average(5)=average(5)+wddl(i)
3760 average(6)=average(6)+wsol(i)
3761 average(7)=average(7)+wfsi(i)
3762 average(8)=average(8)+wdel(i)
3763 average(9)=average(9)+wr2r(i)
3764 average(10)=average(10)+wkin(i)
3765 average(11)=average(11)+wim(i)
3766 average(12)=average(12)+wnod_sms(i)
3767 dmin(1)=min(dmin(1),w(i))
3768 dmin(2)=min(dmin(2),wis(i))
3769 dmin(3)=min(dmin(3),wi2(i))
3770 dmin(4)=min(dmin(4),wcand(i))
3771 dmin(5)=min(dmin(5),wddl(i))
3772 dmin(6)=min(dmin(6),wsol(i))
3773 dmin(7)=min(dmin(7),wfsi(i))
3774 dmin(8)=min(dmin(8),wdel(i))
3775 dmin(9)=min(dmin(9),wr2r(i))
3776 dmin(10)=min(dmin(10),wkin(i))
3777 dmin(11)=min(dmin(11),wim(i))
3778 dmin(12)=min(dmin(12),wnod_sms(i))
3779 dmax(1)=max(dmax(1),w(i))
3780 dmax(2)=max(dmax(2),wis(i))
3781 dmax(3)=max(dmax(3),wi2(i))
3782 dmax(4)=max(dmax(4),wcand(i))
3783 dmax(5)=max(dmax(5),wddl(i))
3784 dmax(6)=max(dmax(6),wsol(i))
3785 dmax(7)=max(dmax(7),wfsi(i))
3786 dmax(8)=max(dmax(8),wdel(i))
3787 dmax(9)=max(dmax(9),wr2r(i))
3788 dmax(10)=max(dmax(10),wkin(i))
3789 dmax(11)=max(dmax(11),wim(i))
3790 dmax(12)=max(dmax(12),wnod_sms(i))
3791 END DO
3792 DO i=1,ncritmax
3793 average(i)=average(i)/nspmd
3794 END DO
3795 DO i = 1, nspmd
3796 deviation(1)=deviation(1)+(w(i) -average(1))**2
3797 deviation(2)=deviation(2)+(wis(i) -average(2))**2
3798 deviation(3)=deviation(3)+(wi2(i) -average(3))**2
3799 deviation(4)=deviation(4)+(wcand(i) -average(4))**2
3800 deviation(5)=deviation(5)+(wddl(i) -average(5))**2
3801 deviation(6)=deviation(6)+(wsol(i) -average(6))**2
3802 deviation(7)=deviation(7)+(wfsi(i) -average(7))**2
3803 deviation(8)=deviation(8)+(wdel(i) -average(8))**2
3804 deviation(9)=deviation(9)+(wr2r(i) -average(9))**2
3805 deviation(10)=deviation(10)+(wkin(i)-average(10))**2
3806 deviation(11)=deviation(11)+(wim(i)-average(11))**2
3807 deviation(12)=deviation(12)+(wnod_sms(i)-average(12))**2
3808 END DO
3809 DO i=1,ncritmax
3810 deviation(i)=sqrt(deviation(i)/nspmd)
3811 END DO