OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cana_aux_par.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 MODULE cmumps_parallel_analysis
15 USE cmumps_struc_def
16 USE mumps_memory_mod
17 USE mumps_ana_ord_wrappers
18 include 'mpif.h'
19 PUBLIC cmumps_ana_f_par
20 INTERFACE cmumps_ana_f_par
21 MODULE PROCEDURE cmumps_ana_f_par
22 END INTERFACE
23 PRIVATE
24 TYPE ord_type
25 INTEGER :: cblknbr, n
26 INTEGER, POINTER :: permtab(:) => null()
27 INTEGER, POINTER :: peritab(:) => null()
28 INTEGER, POINTER :: rangtab(:) => null()
29 INTEGER, POINTER :: treetab(:) => null()
30 INTEGER, POINTER :: brother(:) => null()
31 INTEGER, POINTER :: son(:) => null()
32 INTEGER, POINTER :: nw(:) => null()
33 INTEGER, POINTER :: first(:) => null()
34 INTEGER, POINTER :: last(:) => null()
35 INTEGER, POINTER :: topnodes(:) => null()
36 INTEGER :: comm, comm_nodes, nprocs, nslaves, myid
37 INTEGER :: topstrat, substrat, ORDTOOL, topvars
38 LOGICAL :: ido
39 END TYPE ord_type
40 TYPE graph_type
41 INTEGER(8) :: nz_loc
42 INTEGER :: n, comm
43 INTEGER, POINTER :: irn_loc(:) => null()
44 INTEGER, POINTER :: jcn_loc(:) => null()
45 END TYPE graph_type
46 TYPE arrpnt
47 INTEGER, POINTER :: buf(:) => null()
48 END TYPE arrpnt
49 INTEGER :: mp, mpg, lp, nrl, toprows
50 INTEGER(8) :: memcnt, MAXMEM
51 LOGICAL :: prok, prokg, lpok
52 CONTAINS
53 SUBROUTINE cmumps_ana_f_par(id, WORK1, WORK2, NFSIZ, FILS,
54 & FRERE)
55 USE cmumps_struc_def
56 IMPLICIT NONE
57 TYPE(cmumps_struc) :: id
58 INTEGER, TARGET :: WORK1(:), WORK2(:)
59 INTEGER :: NFSIZ(:), FILS(:), FRERE(:)
60 TYPE(ord_type) :: ord
61 INTEGER, POINTER :: IPE(:), NV(:),
62 & ne(:), na(:), node(:),
63 & nd(:), subord(:), namalg(:),
64 & ips(:), cumul(:),
65 & saveirn(:), savejcn(:)
66 INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG
67 LOGICAL :: SPLITROOT
68 INTEGER(8), PARAMETER :: K79REF=12000000_8
69 INTEGER, PARAMETER :: LIDUMMY = 1
70 INTEGER :: IDUMMY(1)
71 DOUBLE PRECISION :: TIMEB
72 nullify(ipe, nv, ne, na, node, nd, subord, namalg, ips,
73 & cumul, saveirn, savejcn)
74 CALL mpi_comm_rank (id%COMM, myid, ierr)
75 CALL mpi_comm_size (id%COMM, nprocs, ierr)
76 lp = id%ICNTL(1)
77 mp = id%ICNTL(2)
78 mpg = id%ICNTL(3)
79 prok = (mp.GT.0)
80 prokg = (mpg.GT.0) .AND. (myid .EQ. 0)
81 lpok = (lp.GT.0) .AND. (id%ICNTL(4).GE.1)
82 ldiag = id%ICNTL(4)
83 ord%PERMTAB => work1(1 : id%N)
84 ord%PERITAB => work1(id%N+1 : 2*id%N)
85 ord%TREETAB => work1(2*id%N+1 : 3*id%N)
86 IF(id%KEEP(54) .NE. 3) THEN
87 IF(myid.EQ.0) THEN
88 saveirn => id%IRN_loc
89 savejcn => id%JCN_loc
90 id%IRN_loc => id%IRN
91 id%JCN_loc => id%JCN
92 id%KEEP8(29) = id%KEEP8(28)
93 ELSE
94 id%KEEP8(29)=0_8
95 END IF
96 END IF
97 maxmem=0
98 IF(memcnt .GT. maxmem) maxmem=memcnt
99 CALL cmumps_set_par_ord(id, ord)
100 id%INFOG(7) = id%KEEP(245)
101 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
102 & id%COMM, id%MYID )
103 IF ( id%INFO(1) .LT. 0 ) RETURN
104 IF (prokg) CALL mumps_secdeb( timeb )
105 CALL cmumps_do_par_ord(id, ord, work2)
106 IF (prokg) THEN
107 CALL mumps_secfin( timeb )
108 WRITE(mpg,
109 & '(" ELAPSED time in parallel ordering =",F12.4)')
110 & timeb
111 ENDIF
112 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
113 & id%COMM, id%MYID )
114 IF ( id%INFO(1) .LT. 0 ) RETURN
115 IF(id%MYID .EQ. 0) THEN
116 CALL mumps_realloc(ipe, id%N, id%INFO, lp, force=.false.,
117 & copy=.false., string='',
118 & memcnt=memcnt, errcode=-7)
119 CALL mumps_realloc(nv, id%N, id%INFO, lp,
120 & memcnt=memcnt, errcode=-7)
121 IF(memcnt .GT. maxmem) maxmem=memcnt
122 END IF
123 ord%SUBSTRAT = 0
124 ord%TOPSTRAT = 0
125 CALL cmumps_parsymfact(id, ord, ipe, nv, work2)
126 IF(id%KEEP(54) .NE. 3) THEN
127 IF(myid.EQ.0) THEN
128 id%IRN_loc => saveirn
129 id%JCN_loc => savejcn
130 END IF
131 END IF
132 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
133 & id%COMM, id%MYID )
134 IF ( id%INFO(1) .LT. 0 ) RETURN
135 NULLIFY(ord%PERMTAB)
136 NULLIFY(ord%PERITAB)
137 NULLIFY(ord%TREETAB)
138 CALL mumps_idealloc(ord%FIRST, ord%LAST, memcnt=memcnt)
139 IF (myid .EQ. 0) THEN
140 ips => work1(1:id%N)
141 ne => work1(id%N+1 : 2*id%N)
142 na => work1(2*id%N+1 : 3*id%N)
143 node => work2(1 : id%N )
144 nd => work2(id%N+1 : 2*id%N)
145 subord => work2(2*id%N+1 : 3*id%N)
146 namalg => work2(3*id%N+1 : 4*id%N)
147 CALL mumps_realloc(cumul, id%N, id%INFO, lp,
148 & string='CUMUL', memcnt=memcnt, errcode=-7)
149 IF(memcnt .GT. maxmem) maxmem=memcnt
150 nemin = id%KEEP(1)
151 CALL cmumps_ana_lnew(id%N, ipe(1), nv(1), ips(1), ne(1),
152 & na(1), nfsiz(1), node(1), id%INFOG(6), fils(1), frere(1),
153 & nd(1), nemin, subord(1), id%KEEP(60), id%KEEP(20),
154 & id%KEEP(38), namalg(1), id%KEEP(104), cumul(1),
155 & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%KEEP(197),
156 & id%NSLAVES, id%KEEP(250).EQ.1, .false., idummy, lidummy)
157 CALL mumps_dealloc(cumul, nv, ipe, memcnt=memcnt)
158 CALL cmumps_ana_m(ne(1), nd(1), id%INFOG(6), id%INFOG(5),
159 & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108),
160 & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253))
161 IF ( id%KEEP(53) .NE. 0 ) THEN
162 CALL mumps_make1root(id%N, frere(1), fils(1), nfsiz(1),
163 & id%KEEP(20))
164 END IF
165 IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8)
166 & .OR.
167 & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 )
168 & .OR.
169 & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN
170 CALL cmumps_set_k821_surface(id%KEEP8(21), id%KEEP(2),
171 & id%KEEP(48), id%KEEP(50), id%NSLAVES)
172 END IF
173 IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2))
174 & id%KEEP(210)=0
175 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0))
176 & id%KEEP(210)=1
177 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0))
178 & id%KEEP(210)=2
179 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79))
180 IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN
181 id%KEEP8(79)=k79ref * int(id%NSLAVES,8)
182 ENDIF
183 IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR.
184 & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR.
185 & (id%KEEP(79).EQ.6)
186 & ) THEN
187 IF (id%KEEP(210).EQ.1) THEN
188 splitroot = .false.
189 IF ( id%KEEP(62).GE.1) THEN
190 idummy(1) = -1
191 CALL cmumps_cutnodes(id%N, frere(1), fils(1),
192 & nfsiz(1), idummy, lidummy, id%INFOG(6),
193 & id%NSLAVES, id%KEEP(1), id%KEEP8(1), splitroot,
194 & mp, ldiag, id%INFOG(1), id%INFOG(2))
195 IF (id%INFOG(1).LT.0) RETURN
196 ENDIF
197 ENDIF
198 ENDIF
199 splitroot = (((id%ICNTL(13).GT.0) .AND.
200 & (id%NSLAVES.GT.id%ICNTL(13))) .OR.
201 & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0)
202 IF (splitroot) THEN
203 idummy(1) = -1
204 CALL cmumps_cutnodes(id%N, frere(1), fils(1), nfsiz(1),
205 & idummy, lidummy, id%INFOG(6),
206 & id%NSLAVES, id%KEEP(1), id%KEEP8(1),
207 & splitroot, mp, ldiag, id%INFOG(1), id%INFOG(2))
208 IF (id%INFOG(1).LT.0) RETURN
209 ENDIF
210 END IF
211 RETURN
212 END SUBROUTINE cmumps_ana_f_par
213 SUBROUTINE cmumps_set_par_ord(id, ord)
214 TYPE(cmumps_struc) :: id
215 TYPE(ord_type) :: ord
216 INTEGER :: IERR
217#if defined(parmetis) || defined(parmetis3)
218 INTEGER :: I, COLOR, BASE, WORKERS
219 LOGICAL :: IDO
220#endif
221 IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29)
222 CALL mpi_bcast( id%KEEP(245), 1,
223 & mpi_integer, 0, id%COMM, ierr )
224 IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN
225 id%KEEP(245) = 0
226 END IF
227 IF (id%KEEP(245) .EQ. 0) THEN
228#if defined(ptscotch)
229 IF(id%NSLAVES .LT. 2) THEN
230 IF(prokg) WRITE(mpg,'("Warning: older versions
231 &of PT-SCOTCH require at least 2 processors.")')
232 END IF
233 ord%ORDTOOL = 1
234 ord%TOPSTRAT = 0
235 ord%SUBSTRAT = 0
236 ord%COMM = id%COMM
237 ord%COMM_NODES = id%COMM_NODES
238 ord%NPROCS = id%NPROCS
239 ord%NSLAVES = id%NSLAVES
240 ord%MYID = id%MYID
241 ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1)
242 id%KEEP(245) = 1
243 IF(prokg) WRITE(mpg,
244 & '("Parallel ordering tool set to PT-SCOTCH.")')
245 RETURN
246#endif
247#if defined(parmetis) || defined(parmetis3)
248 IF(id%N.LE.100) THEN
249 workers = 2
250 ELSE
251 workers = min(id%NSLAVES,id%N/16)
252 END IF
253 i=1
254 DO
255 IF (i .GT. workers) EXIT
256 ord%NSLAVES = i
257 i = i*2
258 END DO
259 base = id%NPROCS-id%NSLAVES
260 ord%NPROCS = ord%NSLAVES + base
261 ido = (id%MYID .GE. base) .AND.
262 & (id%MYID .LE. base+ord%NSLAVES-1)
263 ord%IDO = ido
264 IF ( ido ) THEN
265 color = 1
266 ELSE
267 color = mpi_undefined
268 END IF
269 CALL mpi_comm_split( id%COMM, color, 0,
270 & ord%COMM_NODES, ierr )
271 ord%ORDTOOL = 2
272 ord%TOPSTRAT = 0
273 ord%SUBSTRAT = 0
274 ord%MYID = id%MYID
275 IF(prokg) WRITE(mpg,
276 & '("Parallel ordering tool set to ParMETIS.")')
277 id%KEEP(245) = 2
278 RETURN
279#endif
280 id%INFO(1) = -38
281 id%INFOG(1) = -38
282 IF(id%MYID .EQ.0 ) THEN
283 WRITE(lp,
284 & '("No parallel ordering tools available.")')
285 WRITE(lp,
286 & '("Please install PT-SCOTCH or ParMETIS.")')
287 END IF
288 RETURN
289 ELSE IF (id%KEEP(245) .EQ. 1) THEN
290#if defined(ptscotch)
291 IF(id%NSLAVES .LT. 2) THEN
292 IF(prokg) WRITE(mpg,'("Warning: older versions
293 &of PT-SCOTCH require at least 2 processors.")')
294 END IF
295 ord%ORDTOOL = 1
296 ord%TOPSTRAT = 0
297 ord%SUBSTRAT = 0
298 ord%COMM = id%COMM
299 ord%COMM_NODES = id%COMM_NODES
300 ord%NPROCS = id%NPROCS
301 ord%NSLAVES = id%NSLAVES
302 ord%MYID = id%MYID
303 ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1)
304 IF(prokg) WRITE(mpg,
305 & '(" Using PT-SCOTCH for parallel ordering")')
306 RETURN
307#else
308 id%INFOG(1) = -38
309 id%INFO(1) = -38
310 IF(id%MYID .EQ.0 ) WRITE(lp,
311 & '(" PT-SCOTCH not available")')
312 RETURN
313#endif
314 ELSE IF (id%KEEP(245) .EQ. 2) THEN
315#if defined(parmetis) || defined(parmetis3)
316 IF(id%N.LE.100) THEN
317 workers = 2
318 ELSE
319 workers = min(id%NSLAVES,id%N/16)
320 END IF
321 i=1
322 DO
323 IF (i .GT. workers) EXIT
324 ord%NSLAVES = i
325 i = i*2
326 END DO
327 base = id%NPROCS-id%NSLAVES
328 ord%NPROCS = ord%NSLAVES + base
329 ido = (id%MYID .GE. base) .AND.
330 & (id%MYID .LE. base+ord%NSLAVES-1)
331 ord%IDO = ido
332 IF ( ido ) THEN
333 color = 1
334 ELSE
335 color = mpi_undefined
336 END IF
337 CALL mpi_comm_split( id%COMM, color, 0, ord%COMM_NODES,
338 & ierr )
339 ord%ORDTOOL = 2
340 ord%TOPSTRAT = 0
341 ord%SUBSTRAT = 0
342 ord%MYID = id%MYID
343 IF(prokg) WRITE(mpg,
344 & '(" Using ParMETIS for parallel ordering")')
345 RETURN
346#else
347 id%INFOG(1) = -38
348 id%INFO(1) = -38
349 IF(id%MYID .EQ.0 ) WRITE(lp,
350 & '(" ParMETIS not available.")')
351 RETURN
352#endif
353 END IF
354 END SUBROUTINE cmumps_set_par_ord
355 SUBROUTINE cmumps_do_par_ord(id, ord, WORK)
356 IMPLICIT NONE
357 TYPE(cmumps_struc) :: id
358 TYPE(ord_type) :: ord
359 INTEGER :: WORK(:)
360#if defined(parmetis) || defined(parmetis3)
361 INTEGER :: IERR
362#endif
363 IF (ord%ORDTOOL .EQ. 1) THEN
364#if defined(ptscotch)
365 CALL cmumps_ptscotch_ord(id, ord, work)
366#else
367 id%INFOG(1) = -38
368 id%INFO(1) = -38
369 WRITE(lp,*)'PT-SCOTCH not available. Aborting...'
370 CALL mumps_abort()
371#endif
372 ELSE IF (ord%ORDTOOL .EQ. 2) THEN
373#if defined(parmetis) || defined(parmetis3)
374 CALL cmumps_parmetis_ord(id, ord, work)
375 if(ord%IDO) CALL mpi_comm_free(ord%COMM_NODES, ierr)
376#else
377 id%INFOG(1) = -38
378 id%INFO(1) = -38
379 WRITE(lp,*)'ParMETIS not available. Aborting...'
380 CALL mumps_abort()
381#endif
382 END IF
383 RETURN
384 END SUBROUTINE cmumps_do_par_ord
385#if defined(parmetis) || defined(parmetis3)
386 SUBROUTINE cmumps_parmetis_ord(id, ord, WORK)
387 IMPLICIT NONE
388 TYPE(cmumps_struc) :: id
389 TYPE(ord_type) :: ord
390 INTEGER, TARGET :: WORK(:)
391 INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE
392 INTEGER, POINTER :: FIRST(:),
393 & last(:), swork(:)
394 INTEGER :: BASEVAL, VERTLOCNBR,
395 & options(10)
396 INTEGER(8), POINTER :: VERTLOCTAB(:)
397 INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:)
398 INTEGER(8) :: EDGELOCNBR
399 INTEGER, POINTER :: SIZES(:), ORDER(:)
400 nullify(first, last, swork, vertloctab, edgeloctab, rcvcnts,
401 & sizes, order)
402 CALL mpi_comm_rank (id%COMM, myid, ierr)
403 CALL mpi_comm_size (id%COMM, nprocs, ierr)
404 ierr=0
405 IF(size(work) .LT. id%N*3) THEN
406 WRITE(lp,
407 & '("Insufficient workspace inside CMUMPS_PARMETIS_ORD")')
408 CALL mumps_abort()
409 END IF
410 IF(memcnt .GT. maxmem) maxmem=memcnt
411 baseval = 1
412 base = id%NPROCS-id%NSLAVES
413 CALL mumps_realloc(first, nprocs+1, id%INFO, lp,
414 & memcnt=memcnt, errcode=-7)
415 CALL mumps_realloc(last, nprocs+1, id%INFO, lp,
416 & memcnt=memcnt, errcode=-7)
417 IF(memcnt .GT. maxmem) maxmem=memcnt
418 CALL cmumps_graph_dist(id, ord, first,
419 & last, base, nprocs, work(1: 2*id%N), type=2)
420 vertlocnbr = last(myid+1)-first(myid+1) + 1
421 CALL mumps_i8realloc(vertloctab, vertlocnbr+1, id%INFO,
422 & lp, string='VERTLOCTAB', memcnt=memcnt, errcode=-7)
423 IF(memcnt .GT. maxmem) maxmem=memcnt
424 swork => work(id%N+1:3*id%N)
425 CALL cmumps_build_dist_graph(id, first, last, vertloctab,
426 & edgeloctab, swork)
427 IF(id%INFO(1).LT.0) RETURN
428 edgelocnbr = vertloctab(vertlocnbr+1)-1_8
429 options(:) = 0
430 order => work(1:id%N)
431 CALL mumps_realloc(sizes, 2*ord%NSLAVES, id%INFO, lp,
432 & memcnt=memcnt, errcode=-7)
433 IF(memcnt .GT. maxmem) maxmem=memcnt
434 IF(ord%IDO) THEN
435 CALL mumps_metis_idxsize(metis_idx_size)
436 IF (metis_idx_size.EQ.32) THEN
437 IF (id%KEEP(10).EQ.1) THEN
438 id%INFO(1) = -52
439 id%INFO(2) = 1
440 ELSE
441 CALL mumps_parmetis_mixedto32(id, base, vertlocnbr, first,
442 & vertloctab, edgeloctab, baseval, options, order,
443 & sizes, ord%COMM_NODES, ierr)
444 ENDIF
445 ELSE IF (metis_idx_size.EQ.64) THEN
446 CALL mumps_parmetis_mixedto64
447 & (id, base, vertlocnbr, first,
448 & vertloctab, edgeloctab, baseval, options, order,
449 & sizes, ord%COMM_NODES, ierr)
450 ELSE
451 WRITE(*,*)
452 & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=",
453 & metis_idx_size
454 CALL mumps_abort()
455 END IF
456 END IF
457 CALL mumps_idealloc(edgeloctab, memcnt=memcnt)
458 IF(memcnt .GT. maxmem) maxmem=memcnt
459 CALL mumps_i8dealloc(vertloctab)
460 IF(ierr.GT.0) THEN
461 id%INFO(1:2) = -50
462 END IF
463 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
464 & id%COMM, id%MYID )
465 IF ( id%INFO(1) .LT. 0 ) GOTO 20
466 CALL mpi_bcast(sizes(1), 2*ord%NSLAVES, mpi_integer,
467 & base, id%COMM, ierr)
468 ord%CBLKNBR = 2*ord%NSLAVES-1
469 CALL mumps_realloc(rcvcnts, id%NPROCS, id%INFO, lp,
470 & memcnt=memcnt, errcode=-7)
471 IF(memcnt .GT. maxmem) maxmem=memcnt
472 DO i=1, id%NPROCS
473 rcvcnts(i) = max(last(i)-first(i)+1,0)
474 END DO
475 first = first-1
476 IF(first(1) .LT. 0) THEN
477 first(1) = 0
478 END IF
479 CALL mpi_allgatherv ( order(1), vertlocnbr, mpi_integer,
480 & ord%PERMTAB(1),
481 & rcvcnts(1), first(1), mpi_integer, id%COMM, ierr )
482 DO i=1, id%N
483 ord%PERITAB(ord%PERMTAB(i)) = i
484 END DO
485 CALL mumps_realloc(ord%RANGTAB, 2*ord%NSLAVES, id%INFO,
486 & lp, string='RANGTAB', memcnt=memcnt, errcode=-7)
487 IF(memcnt .GT. maxmem) maxmem=memcnt
488 CALL cmumps_build_treetab(ord%TREETAB, ord%RANGTAB,
489 & sizes, ord%CBLKNBR)
490 CALL mumps_dealloc(sizes, first, last,
491 & rcvcnts, memcnt=memcnt)
492 CALL mumps_realloc(ord%SON, ord%CBLKNBR, id%INFO,
493 & lp, string='SON', memcnt=memcnt, errcode=-7)
494 CALL mumps_realloc(ord%BROTHER, ord%CBLKNBR, id%INFO,
495 & lp, string='BROTHER', memcnt=memcnt, errcode=-7)
496 CALL mumps_realloc(ord%NW, ord%CBLKNBR, id%INFO,
497 & lp, string='NW', memcnt=memcnt, errcode=-7)
498 IF(memcnt .GT. maxmem) maxmem=memcnt
499 CALL cmumps_build_tree(ord)
500 ord%N = id%N
501 ord%COMM = id%COMM
502 RETURN
503 20 CONTINUE
504 CALL mumps_dealloc(first , memcnt=memcnt)
505 CALL mumps_dealloc(last , memcnt=memcnt)
506 CALL mumps_dealloc(sizes , memcnt=memcnt)
507 CALL mumps_dealloc(ord%RANGTAB, memcnt=memcnt)
508 RETURN
509 END SUBROUTINE cmumps_parmetis_ord
510#endif
511#if defined(ptscotch)
512 SUBROUTINE cmumps_ptscotch_ord(id, ord, WORK)
513!$ USE OMP_LIB
514 IMPLICIT NONE
515 include 'ptscotchf.h'
516 TYPE(cmumps_struc) :: id
517 TYPE(ORD_TYPE) :: ord
518 INTEGER, TARGET :: WORK(:)
519 INTEGER :: MYID, NPROCS, IERR
520 INTEGER, POINTER :: FIRST(:),
521 & last(:), swork(:)
522 INTEGER :: BASEVAL, VERTLOCNBR,
523 & base, scotch_int_size
524 INTEGER(8) :: EDGELOCNBR
525 INTEGER(8), POINTER :: VERTLOCTAB(:)
526 INTEGER, POINTER :: EDGELOCTAB(:)
527 INTEGER :: PTHREAD_NUMBER, NOMP
528 nullify(first, last, swork, vertloctab, edgeloctab)
529 IF (size(work) .LT. id%N*3) THEN
530 WRITE(lp,
531 & '("Insufficient workspace inside CMUMPS_PTSCOTCH_ORD")')
532 CALL mumps_abort()
533 END IF
534 CALL mpi_barrier(id%COMM, ierr)
535 CALL mpi_comm_rank (id%COMM, myid, ierr)
536 CALL mpi_comm_size (id%COMM, nprocs, ierr)
537 base = id%NPROCS-id%NSLAVES
538 baseval = 1
539 CALL mumps_realloc(first, nprocs+1, id%INFO, lp,
540 & memcnt=memcnt, errcode=-7)
541 CALL mumps_realloc(last, nprocs+1, id%INFO, lp,
542 & memcnt=memcnt, errcode=-7)
543 IF(memcnt .GT. maxmem) maxmem=memcnt
544 CALL cmumps_graph_dist(id, ord, first,
545 & last, base, nprocs, work(1: 2*id%N), type=2)
546 vertlocnbr = last(myid+1)-first(myid+1) + 1
547 CALL mumps_i8realloc(vertloctab, vertlocnbr+1, id%INFO,
548 & lp, string='VERTLOCTAB', memcnt=memcnt, errcode=-7)
549 IF(memcnt .GT. maxmem) maxmem=memcnt
550 swork => work(id%N+1:3*id%N)
551 CALL cmumps_build_dist_graph(id, first, last, vertloctab,
552 & edgeloctab, swork)
553 IF(id%INFO(1).LT.0) RETURN
554 edgelocnbr = vertloctab(vertlocnbr+1)-1_8
555 CALL mumps_realloc(ord%PERMTAB, id%N, id%INFO,
556 & lp, string='PERMTAB', memcnt=memcnt, errcode=-7)
557 CALL mumps_realloc(ord%PERITAB, id%N, id%INFO,
558 & lp, string='PERITAB', memcnt=memcnt, errcode=-7)
559 CALL mumps_realloc(ord%RANGTAB, id%N+1, id%INFO,
560 & lp, string='RANGTAB', memcnt=memcnt, errcode=-7)
561 CALL mumps_realloc(ord%TREETAB, id%N, id%INFO,
562 & lp, string='TREETAB', memcnt=memcnt, errcode=-7)
563 IF(memcnt .GT. maxmem) maxmem=memcnt
564 IF(ord%IDO) THEN
565 CALL mumps_scotch_intsize(scotch_int_size)
566 nomp=0
567!$ NOMP=omp_get_max_threads()
568 IF (nomp .GT. 0) THEN
569 CALL mumps_scotch_get_pthread_number (pthread_number)
570 CALL mumps_scotch_set_pthread_number (nomp)
571 ENDIF
572 IF(scotch_int_size.EQ.32) THEN
573 IF (id%KEEP(10).EQ.1) THEN
574 id%INFO(1) = -52
575 id%INFO(2) = 2
576 ELSE
577 CALL mumps_ptscotch_mixedto32(id, ord,
578 & baseval,
579 & vertlocnbr, vertloctab,
580 & edgelocnbr, edgeloctab,
581 & ierr)
582 ENDIF
583 ELSE
584 CALL mumps_ptscotch_mixedto64(id, ord,
585 & baseval,
586 & vertlocnbr, vertloctab,
587 & edgelocnbr, edgeloctab,
588 & ierr)
589 END IF
590 IF (nomp .GT. 0) THEN
591 CALL mumps_scotch_set_pthread_number (pthread_number)
592 ENDIF
593 END IF
594 IF(ierr.NE.0) THEN
595 id%INFO(1:2) = -50
596 END IF
597 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
598 & id%COMM, id%MYID )
599 IF ( id%INFO(1) .LT. 0 ) GOTO 11
600 CALL mpi_bcast (ord%CBLKNBR, 1, mpi_integer,
601 & base, id%COMM, ierr)
602 CALL mpi_bcast (ord%PERMTAB(1), id%N, mpi_integer,
603 & base, id%COMM, ierr)
604 CALL mpi_bcast (ord%PERITAB(1), id%N, mpi_integer,
605 & base, id%COMM, ierr)
606 CALL mpi_bcast (ord%RANGTAB(1), id%N+1, mpi_integer,
607 & base, id%COMM, ierr)
608 CALL mpi_bcast (ord%TREETAB(1), id%N, mpi_integer,
609 & base, id%COMM, ierr)
610 CALL mumps_realloc(ord%SON, ord%CBLKNBR, id%INFO,
611 & lp, string='SON', memcnt=memcnt, errcode=-7)
612 CALL mumps_realloc(ord%BROTHER, ord%CBLKNBR, id%INFO,
613 & lp, string='BROTHER', memcnt=memcnt, errcode=-7)
614 CALL mumps_realloc(ord%NW, ord%CBLKNBR, id%INFO,
615 & lp, string='NW', memcnt=memcnt, errcode=-7)
616 CALL cmumps_build_tree(ord)
617 IF(memcnt .GT. maxmem) maxmem=memcnt
618 ord%N = id%N
619 ord%COMM = id%COMM
620 CALL mumps_dealloc(edgeloctab, memcnt=memcnt)
621 CALL mumps_dealloc(first , memcnt=memcnt)
622 CALL mumps_dealloc(last , memcnt=memcnt)
623 CALL mumps_i8dealloc(vertloctab, memcnt=memcnt)
624 RETURN
625 11 CONTINUE
626 CALL mumps_dealloc(first , memcnt=memcnt)
627 CALL mumps_dealloc(last , memcnt=memcnt)
628 CALL mumps_dealloc(ord%RANGTAB, memcnt=memcnt)
629 CALL mumps_dealloc(edgeloctab, memcnt=memcnt)
630 RETURN
631 END SUBROUTINE cmumps_ptscotch_ord
632#endif
633 FUNCTION cmumps_stop_descent(id, ord, NACTIVE, ANODE, RPROC,
634 & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM)
635 IMPLICIT NONE
636 LOGICAL :: cmumps_stop_descent
637 INTEGER :: nactive, rproc, anode, peakmem, nnodes
638 INTEGER :: alist(NNODES), list(nnodes)
639 TYPE(ord_type) :: ord
640 TYPE(cmumps_struc) :: id
641 LOGICAL, OPTIONAL :: checkmem
642 INTEGER :: ipeakmem, big, max_nrows, min_nrows
643 INTEGER :: TOPROWS, nrl, hostmem, submem
644 INTEGER :: i, nz_row, weight
645 LOGICAL :: icheckmem
646 INTEGER :: nz4
647 IF(present(checkmem)) THEN
648 icheckmem = checkmem
649 ELSE
650 icheckmem = .false.
651 END IF
652 cmumps_stop_descent = .false.
653 IF(nactive .GE. rproc) THEN
654 cmumps_stop_descent = .true.
655 RETURN
656 END IF
657 IF(nactive .EQ. 0) THEN
658 cmumps_stop_descent = .true.
659 RETURN
660 END IF
661 IF(.NOT. icheckmem) RETURN
662 big = alist(nactive)
663 IF(nactive .GT. 1) THEN
664 max_nrows = ord%NW(alist(nactive-1))
665 min_nrows = ord%NW(alist(1))
666 ELSE
667 max_nrows = 0
668 min_nrows = id%N
669 END IF
670 DO i=1, anode
671 weight = ord%NW(list(i))
672 IF(weight .GT. max_nrows) max_nrows = weight
673 IF(weight .LT. min_nrows) min_nrows = weight
674 END DO
675 i = ord%SON(big)
676 DO
677 weight = ord%NW(i)
678 IF(weight .GT. max_nrows) max_nrows = weight
679 IF(weight .LT. min_nrows) min_nrows = weight
680 IF(ord%BROTHER(i) .EQ. -1) EXIT
681 i = ord%BROTHER(i)
682 END DO
683 toprows = ord%TOPNODES(2)+ord%RANGTAB(big+1)-ord%RANGTAB(big)
684 submem = 7 *id%N
685 hostmem = 12*id%N
686 nz4=int(id%KEEP8(28))
687 nz_row = 2*(nz4/id%N)
688 IF(id%KEEP(46) .EQ. 0) THEN
689 nrl = 0
690 ELSE
691 nrl = min_nrows
692 END IF
693 hostmem = hostmem + 2*toprows*nz_row
694 hostmem = hostmem +nrl
695 hostmem = hostmem + max(nrl,toprows)*(nz_row+2)
696 hostmem = hostmem + 6*max(nrl,toprows)
697 hostmem = hostmem + 3*toprows
698 nrl = max_nrows
699 submem = submem +nrl
700 submem = submem + nrl*(nz_row+2)
701 submem = submem + 6*nrl
702 ipeakmem = max(hostmem, submem)
703 IF((ipeakmem .GT. peakmem) .AND.
704 & (peakmem .NE. 0)) THEN
705 cmumps_stop_descent = .true.
706 RETURN
707 ELSE
708 cmumps_stop_descent = .false.
709 peakmem = ipeakmem
710 RETURN
711 END IF
712 END FUNCTION cmumps_stop_descent
713 FUNCTION cmumps_cnt_kids(NODE, ord)
714 IMPLICIT NONE
715 INTEGER :: cmumps_cnt_kids
716 INTEGER :: node
717 TYPE(ord_type) :: ord
718 INTEGER :: curr
719 cmumps_cnt_kids = 0
720 IF(ord%SON(node) .EQ. -1) THEN
721 RETURN
722 ELSE
723 cmumps_cnt_kids = 1
724 curr = ord%SON(node)
725 DO
726 IF(ord%BROTHER(curr) .NE. -1) THEN
727 cmumps_cnt_kids = cmumps_cnt_kids+1
728 curr = ord%BROTHER(curr)
729 ELSE
730 EXIT
731 END IF
732 END DO
733 END IF
734 RETURN
735 END FUNCTION cmumps_cnt_kids
736 SUBROUTINE cmumps_get_subtrees(ord, id)
737 IMPLICIT NONE
738 TYPE(ord_type) :: ord
739 TYPE(cmumps_struc) :: id
740 INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:)
741 INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I,
742 & nk, peakmem, allocok
743 LOGICAL :: SD
744 NNODES = ord%NSLAVES
745 CALL mumps_realloc(ord%TOPNODES, 2*max(nnodes,2), id%INFO, lp,
746 & memcnt=memcnt, errcode=-7)
747 CALL mumps_realloc(ord%FIRST, id%NPROCS, id%INFO, lp,
748 & memcnt=memcnt, errcode=-7)
749 CALL mumps_realloc(ord%LAST, id%NPROCS, id%INFO, lp,
750 & memcnt=memcnt, errcode=-7)
751 IF(memcnt .GT. maxmem) maxmem=memcnt
752 ALLOCATE(alist(nnodes), aweights(nnodes), list(nnodes),
753 & work(0:nnodes+1), stat=allocok)
754 IF(allocok.GT.0) THEN
755 id%INFO(1)=-13
756 id%INFO(2)=4*nnodes+2
757 ENDIF
758 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
759 IF ( id%INFO(1) .LT. 0 ) GO TO 90
760 nactive = 0
761 DO i=1, ord%CBLKNBR
762 IF (ord%TREETAB(i).EQ.-1) THEN
763 nactive = nactive+1
764 IF(nactive.LE.nnodes) THEN
765 alist(nactive) = i
766 aweights(nactive) = ord%NW(i)
767 END IF
768 END IF
769 END DO
770 IF((ord%CBLKNBR .EQ. 1) .OR.
771 & (nactive.GT.nnodes) .OR.
772 & ( nnodes .LT. cmumps_cnt_kids(ord%CBLKNBR, ord) )) THEN
773 ord%TOPNODES(1) = 1
774 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1)
775 ord%TOPNODES(3) = ord%RANGTAB(1)
776 ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1
777 ord%FIRST = 0
778 ord%LAST = -1
779 RETURN
780 END IF
781 CALL cmumps_mergesort(nactive, aweights(1:nactive),
782 & work(0:nactive+1))
783 CALL cmumps_mergeswap(nactive, work(0:nactive+1),
784 & aweights(1:nactive),
785 & alist(1:nactive))
786 rproc = nnodes
787 anode = 0
788 peakmem = 0
789 ord%TOPNODES = 0
790 DO
791 IF(nactive .EQ. 0) EXIT
792 big = alist(nactive)
793 nk = cmumps_cnt_kids(big, ord)
794 IF((nk .GT. (rproc-nactive+1)) .OR. (nk .EQ. 0)) THEN
795 anode = anode+1
796 list(anode) = big
797 nactive = nactive-1
798 rproc = rproc-1
799 cycle
800 END IF
801 sd = cmumps_stop_descent(id, ord, nactive, anode,
802 & rproc, alist, list, peakmem, nnodes, checkmem=.true.)
803 IF ( sd )
804 & THEN
805 IF(nactive.GT.0) THEN
806 list(anode+1:anode+nactive) = alist(1:nactive)
807 anode = anode+nactive
808 END IF
809 EXIT
810 END IF
811 ord%TOPNODES(1) = ord%TOPNODES(1)+1
812 ord%TOPNODES(2) = ord%TOPNODES(2) +
813 & ord%RANGTAB(big+1) - ord%RANGTAB(big)
814 ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(big)
815 ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) =
816 & ord%RANGTAB(big+1)-1
817 curr = ord%SON(big)
818 alist(nactive) = curr
819 aweights(nactive) = ord%NW(curr)
820 DO
821 IF(ord%BROTHER(curr) .EQ. -1) EXIT
822 nactive = nactive+1
823 curr = ord%BROTHER(curr)
824 alist(nactive) = curr
825 aweights(nactive) = ord%NW(curr)
826 END DO
827 CALL cmumps_mergesort(nactive, aweights(1:nactive),
828 & work(0:nactive+1))
829 CALL cmumps_mergeswap(nactive, work(0:nactive+1),
830 & aweights(1:nactive),
831 & alist(1:nactive))
832 END DO
833 DO i=1, anode
834 aweights(i) = ord%NW(list(i))
835 END DO
836 CALL cmumps_mergesort(anode, aweights(1:anode), work(0:anode+1))
837 CALL cmumps_mergeswap(anode, work(0:anode+1), aweights(1:anode),
838 & alist(1:anode))
839 IF (id%KEEP(46) .EQ. 1) THEN
840 base = 0
841 ELSE
842 ord%FIRST(1) = 0
843 ord%LAST(1) = -1
844 base = 1
845 END IF
846 DO i=1, anode
847 curr = list(i)
848 nd = curr
849 IF(ord%SON(nd) .NE. -1) THEN
850 nd = ord%SON(nd)
851 DO
852 IF((ord%SON(nd) .EQ. -1) .AND.
853 & (ord%BROTHER(nd).EQ.-1)) THEN
854 EXIT
855 ELSE IF(ord%BROTHER(nd) .EQ. -1) THEN
856 nd = ord%SON(nd)
857 ELSE
858 nd = ord%BROTHER(nd)
859 END IF
860 END DO
861 END IF
862 ord%FIRST(base+i) = ord%RANGTAB(nd)
863 ord%LAST(base+i) = ord%RANGTAB(curr+1)-1
864 END DO
865 DO i=anode+1, id%NSLAVES
866 ord%FIRST(base+i) = id%N+1
867 ord%LAST(base+i) = id%N
868 END DO
869 DEALLOCATE(list, alist, aweights, work)
870 90 continue
871 RETURN
872 END SUBROUTINE cmumps_get_subtrees
873 SUBROUTINE cmumps_parsymfact(id, ord, GPE, GNV, WORK)
874 IMPLICIT NONE
875 TYPE(cmumps_struc) :: id
876 TYPE(ord_type) :: ord
877 INTEGER, POINTER :: GPE(:), GNV(:)
878 INTEGER, TARGET :: WORK(:)
879 TYPE(graph_type) :: top_graph
880 INTEGER(8), POINTER :: IPE(:), IPET(:),
881 & buf_pe1(:), buf_pe2(:), tmp1(:)
882 INTEGER, POINTER :: PE(:),
883 & LENG(:), I_HALO_MAP(:)
884 INTEGER, POINTER :: NDENSE(:), LAST(:),
885 & DEGREE(:), W(:), PERM(:),
886 & listvar_schur(:), next(:),
887 & head(:), nv(:), elen(:),
888 & lstvar(:)
889 INTEGER, POINTER :: MYLIST(:),
890 & LPERM(:),
891 & liperm(:),
892 & nvt(:), buf_nv1(:),
893 & buf_nv2(:), rootperm(:),
894 & tmp2(:), bwork(:), ncliques(:)
895 INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES,
896 & TOTNCLIQUES
897 INTEGER(8) :: MYNVARS, TOTNVARS
898 INTEGER(8), POINTER :: LVARPT(:)
899 INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID,
900 & nprocs, ierr, nrows_loc, glob_idx, tmp,
901 & ntvar, tgsize, maxs, rhandpe,
902 & rhandnv, ridx, proc, job, k
903 INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE
904 INTEGER :: STATUSPE(MPI_STATUS_SIZE)
905 INTEGER :: STATUSNV(MPI_STATUS_SIZE)
906 INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE)
907 INTEGER, PARAMETER :: ITAG=30
908 LOGICAL :: AGG6
909 INTEGER :: THRESH
910 nullify(pe, ipe, leng, i_halo_map, ncliques)
911 nullify(ndense, last, degree, w, perm, listvar_schur,
912 & next, head, nv, elen, lstvar)
913 nullify(mylist, lvarpt,
914 & lperm, liperm, ipet, nvt, buf_pe1, buf_pe2,
915 & buf_nv1, buf_nv2, rootperm, tmp1, tmp2, bwork)
916 CALL mpi_comm_rank (id%COMM, myid, ierr)
917 CALL mpi_comm_size (id%COMM, nprocs, ierr)
918 IF(size(work) .LT. 4*id%N) THEN
919 WRITE(lp,*)'Insufficient workspace in CMUMPS_PARSYMFACT'
920 CALL mumps_abort()
921 ELSE
922 head => work( 1 : id%N)
923 elen => work( id%N+1 : 2*id%N)
924 leng => work(2*id%N+1 : 3*id%N)
925 perm => work(3*id%N+1 : 4*id%N)
926 END IF
927 CALL cmumps_get_subtrees(ord, id)
928 CALL mumps_idealloc(ord%SON, ord%BROTHER, ord%NW,
929 & ord%RANGTAB, memcnt=memcnt)
930 nrows_loc = ord%LAST(myid+1)-ord%FIRST(myid+1)+1
931 nrl = nrows_loc
932 toprows = ord%TOPNODES(2)
933 bwork => work(1 : 2*id%N)
934 CALL cmumps_build_loc_graph(id, ord, hidx, ipe, pe, leng,
935 & i_halo_map, top_graph, bwork)
936 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
937 & id%COMM, id%MYID )
938 IF(id%INFO(1).lt.0) RETURN
939 tmp = id%N
940 DO i=1, nprocs
941 tmp = tmp-(ord%LAST(i)-ord%FIRST(i)+1)
942 END DO
943 tmp = ceiling(real(tmp)*1.10e0)
944 IF(myid .EQ. 0) THEN
945 tmp = max(max(tmp, hidx),1)
946 ELSE
947 tmp = max(hidx,1)
948 END IF
949 size_schur = hidx - nrows_loc
950 CALL mumps_realloc(ndense, tmp, id%INFO, lp,
951 & memcnt=memcnt, errcode=-7)
952 CALL mumps_realloc(last, tmp, id%INFO, lp,
953 & memcnt=memcnt, errcode=-7)
954 CALL mumps_realloc(next, tmp, id%INFO, lp,
955 & memcnt=memcnt, errcode=-7)
956 CALL mumps_realloc(degree, tmp, id%INFO, lp,
957 & memcnt=memcnt, errcode=-7)
958 CALL mumps_realloc(w, tmp, id%INFO, lp,
959 & memcnt=memcnt, errcode=-7)
960 CALL mumps_realloc(nv, tmp, id%INFO, lp,
961 & memcnt=memcnt, errcode=-7)
962 CALL mumps_realloc(listvar_schur, max(size_schur,1), id%INFO, lp,
963 & memcnt=memcnt, errcode=-7)
964 IF(memcnt .GT. maxmem) maxmem=memcnt
965 DO i=1, size_schur
966 listvar_schur(i) = nrows_loc+i
967 END DO
968 thresh = -1
969 agg6 = .false.
970 pfrees = ipe(nrows_loc+1)
971 pfs_save = pfrees
972 pelen = pfrees-1 + 2_8*int(nrows_loc+ord%TOPNODES(2),8)
973 DO i=1, hidx
974 perm(i) = i
975 END DO
976 IF(size_schur.EQ.0) THEN
977 job = 0
978 ELSE
979 job = 1
980 END IF
981 IF(hidx .GT.0) CALL mumps_symqamd_new(job, thresh, ndense(1),
982 & hidx, pelen, ipe(1), pfrees, leng(1), pe(1), nv(1),
983 & elen(1), last(1), ncmpa, degree(1), head(1), next(1),
984 & w(1), perm(1), listvar_schur(1), size_schur, agg6)
985 myncliques = 0
986 mynvars = 0
987 mymaxvars = 0
988 DO i=1, hidx
989 IF(ipe(i) .GT. 0) THEN
990 mymaxvars = max(mymaxvars,leng(i))
991 mynvars = mynvars+leng(i)
992 myncliques = myncliques+1
993 END IF
994 END DO
995 CALL mpi_reduce(mynvars, totnvars, 1, mpi_integer8,
996 & mpi_sum, 0, id%COMM, ierr)
997 CALL mumps_realloc(ncliques, nprocs, id%INFO,
998 & lp, string='NCLIQUES', memcnt=memcnt, errcode=-7)
999 CALL mpi_gather(myncliques, 1, mpi_integer, ncliques(1), 1,
1000 & mpi_integer, 0, id%COMM, ierr)
1001 IF(id%MYID.EQ.0) THEN
1002 totncliques = sum(ncliques)
1003 CALL mumps_i8realloc(lvarpt, totncliques+1, id%INFO,
1004 & lp, string='LVARPT', memcnt=memcnt, errcode=-7)
1005 CALL mumps_irealloc8(lstvar, totnvars, id%INFO,
1006 & lp, string='LSTVAR', memcnt=memcnt, errcode=-7)
1007 lvarpt(1) = 1_8
1008 icliques = 0
1009 DO i=1, hidx
1010 IF(ipe(i) .GT. 0) THEN
1011 icliques = icliques+1
1012 lvarpt(icliques+1) = lvarpt(icliques)+leng(i)
1013 DO j=0, leng(i)-1
1014 lstvar(lvarpt(icliques)+j) =
1015 & i_halo_map(pe(ipe(i)+j)-nrows_loc)
1016 END DO
1017 END IF
1018 END DO
1019 DO proc=1, nprocs-1
1020 DO i=1, ncliques(proc+1)
1021 icliques = icliques+1
1022 CALL mpi_recv(k, 1, mpi_integer, proc, itag, id%COMM,
1023 & statuscliques, ierr)
1024 lvarpt(icliques+1) = lvarpt(icliques)+k
1025 CALL mpi_recv(lstvar(lvarpt(icliques)), k, mpi_integer,
1026 & proc, itag, id%COMM, statuscliques, ierr)
1027 END DO
1028 END DO
1029 lperm => work(3*id%N+1 : 4*id%N)
1030 ntvar = ord%TOPNODES(2)
1031 CALL cmumps_make_loc_idx(id, ord%TOPNODES, lperm, liperm, ord)
1032 CALL cmumps_assemble_top_graph(id, ord%TOPNODES(2), lperm,
1033 & top_graph, totncliques, lstvar, lvarpt, ipet, pe,
1034 & leng, elen)
1035 tgsize = ord%TOPNODES(2)+totncliques
1036 pfreet = ipet(tgsize+1)
1037 pft_save = pfreet
1038 nullify(lperm)
1039 ELSE
1040 CALL mumps_realloc(mylist, mymaxvars, id%INFO,
1041 & lp, string='MYLIST', memcnt=memcnt, errcode=-7)
1042 IF(memcnt .GT. maxmem) maxmem=memcnt
1043 DO i=1, hidx
1044 IF(ipe(i) .GT. 0) THEN
1045 DO j=1, leng(i)
1046 mylist(j) = i_halo_map(pe(ipe(i)+j-1)-nrows_loc)
1047 END DO
1048 CALL mpi_send(leng(i), 1, mpi_integer, 0, itag,
1049 & id%COMM, ierr)
1050 CALL mpi_send(mylist(1), leng(i), mpi_integer, 0, itag,
1051 & id%COMM, ierr)
1052 END IF
1053 END DO
1054 END IF
1055 CALL mumps_idealloc(top_graph%IRN_LOC,
1056 & top_graph%JCN_LOC, ord%TOPNODES, memcnt=memcnt)
1057 IF(myid .EQ. 0) THEN
1058 CALL mumps_irealloc8(pe, max(pfreet+int(tgsize,8),1_8),id%INFO,
1059 & lp, copy=.true., string='J2:PE', memcnt=memcnt,
1060 & errcode=-7)
1061 CALL mumps_realloc(ndense, max(tgsize,1), id%INFO, lp,
1062 & string='J2:NDENSE', memcnt=memcnt, errcode=-7)
1063 CALL mumps_realloc(nvt, max(tgsize,1), id%INFO, lp,
1064 & string='J2:NVT', memcnt=memcnt, errcode=-7)
1065 CALL mumps_realloc(last, max(tgsize,1), id%INFO, lp,
1066 & string='J2:LAST', memcnt=memcnt, errcode=-7)
1067 CALL mumps_realloc(degree, max(tgsize,1), id%INFO, lp,
1068 & string='J2:DEGREE', memcnt=memcnt, errcode=-7)
1069 CALL mumps_realloc(next, max(tgsize,1), id%INFO, lp,
1070 & string='J2:NEXT', memcnt=memcnt, errcode=-7)
1071 CALL mumps_realloc(w, max(tgsize,1), id%INFO, lp,
1072 & string='J2:W', memcnt=memcnt, errcode=-7)
1073 CALL mumps_realloc(listvar_schur, max(totncliques,1), id%INFO,
1074 & lp, string='J2:LVSCH', memcnt=memcnt, errcode=-7)
1075 IF(memcnt .GT. maxmem) maxmem=memcnt
1076 DO i=1, totncliques
1077 listvar_schur(i) = ntvar+i
1078 END DO
1079 thresh = -1
1080 CALL mumps_realloc(head, max(tgsize,1), id%INFO,
1081 & lp, string='J2:HEAD', memcnt=memcnt, errcode=-7)
1082 CALL mumps_realloc(perm, max(tgsize,1), id%INFO,
1083 & lp, copy=.true., string='J2:PERM',
1084 & memcnt=memcnt, errcode=-7)
1085 IF(memcnt .GT. maxmem) maxmem=memcnt
1086 DO i=1, tgsize
1087 perm(i) = i
1088 END DO
1089 pelen = max(pfreet+int(tgsize,8),1_8)
1090 IF(tgsize.GT.0) CALL mumps_symqamd_new(2, -1, ndense(1),
1091 & tgsize, pelen, ipet(1), pfreet, leng(1), pe(1),
1092 & nvt(1), elen(1), last(1), ncmpa, degree(1), head(1),
1093 & next(1), w(1), perm(1), listvar_schur(1), totncliques,
1094 & agg6)
1095 END IF
1096 CALL mpi_barrier(id%COMM, ierr)
1097 CALL mpi_barrier(id%COMM, ierr)
1098 CALL mumps_dealloc(listvar_schur, memcnt=memcnt)
1099 CALL mumps_dealloc(pe, memcnt=memcnt)
1100 IF(myid .EQ. 0) THEN
1101 maxs = nrows_loc
1102 DO i=2, nprocs
1103 IF((ord%LAST(i)-ord%FIRST(i)+1) .GT. maxs)
1104 & maxs = (ord%LAST(i)-ord%FIRST(i)+1)
1105 END DO
1106 CALL mumps_i8realloc(buf_pe1, max(maxs,1), id%INFO,
1107 & lp, string='BUF_PE1', memcnt=memcnt, errcode=-7)
1108 CALL mumps_i8realloc(buf_pe2, max(maxs,1), id%INFO,
1109 & lp, string='BUF_PE2', memcnt=memcnt, errcode=-7)
1110 CALL mumps_realloc(buf_nv1, max(maxs,1), id%INFO,
1111 & lp, string='BUF_NV1', memcnt=memcnt, errcode=-7)
1112 CALL mumps_realloc(buf_nv2, max(maxs,1), id%INFO,
1113 & lp, string='BUF_NV2', memcnt=memcnt, errcode=-7)
1114 CALL mumps_realloc(gpe, id%N, id%INFO,
1115 & lp, string='gpe', MEMCNT=MEMCNT, ERRCODE=-7)
1116 CALL MUMPS_REALLOC(GNV, id%N, id%INFO,
1117 & LP, STRING='gnv', MEMCNT=MEMCNT, ERRCODE=-7)
1118 CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO,
1119 & LP, STRING='rootperm', MEMCNT=MEMCNT, ERRCODE=-7)
1120.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1121 RIDX = 0
1122 TMP1 => BUF_PE1
1123 TMP2 => BUF_NV1
1124 NULLIFY(BUF_PE1, BUF_NV1)
1125 BUF_PE1 => IPE
1126 BUF_NV1 => NV
1127 DO PROC=0, NPROCS-2
1128 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)-
1129 & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1,
1130 & id%COMM, RHANDPE, IERR)
1131 CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)-
1132 & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1,
1133 & id%COMM, RHANDNV, IERR)
1134 DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1
1135 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1)
1136.GT. IF(BUF_PE1(I) 0) THEN
1137 RIDX=RIDX+1
1138 ROOTPERM(RIDX) = GLOB_IDX
1139 GNV(GLOB_IDX) = BUF_NV1(I)
1140.EQ. ELSE IF (BUF_PE1(I) 0) THEN
1141 GPE(GLOB_IDX) = 0
1142 GNV(GLOB_IDX) = BUF_NV1(I)
1143 ELSE
1144 GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+
1145 & ord%FIRST(PROC+1)-1)
1146 GNV(GLOB_IDX) = BUF_NV1(I)
1147 END IF
1148 END DO
1149 CALL MPI_WAIT(RHANDPE, STATUSPE, IERR)
1150 CALL MPI_WAIT(RHANDNV, STATUSNV, IERR)
1151.NE. IF(PROC 0) THEN
1152 TMP1 => BUF_PE1
1153 TMP2 => BUF_NV1
1154 END IF
1155 BUF_PE1 => BUF_PE2
1156 BUF_NV1 => BUF_NV2
1157 NULLIFY(BUF_PE2, BUF_NV2)
1158 BUF_PE2 => TMP1
1159 BUF_NV2 => TMP2
1160 NULLIFY(TMP1, TMP2)
1161 END DO
1162 DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1
1163 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1)
1164.GT. IF(BUF_PE1(I) 0) THEN
1165 RIDX=RIDX+1
1166 ROOTPERM(RIDX) = GLOB_IDX
1167 GNV(GLOB_IDX) = BUF_NV1(I)
1168.EQ. ELSE IF (BUF_PE1(I) 0) THEN
1169 GPE(GLOB_IDX) = 0
1170 GNV(GLOB_IDX) = BUF_NV1(I)
1171 ELSE
1172 GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+
1173 & ord%FIRST(PROC+1)-1)
1174 GNV(GLOB_IDX) = BUF_NV1(I)
1175 END IF
1176 END DO
1177 DO I=1, NTVAR
1178 GLOB_IDX = LIPERM(I)
1179.EQ. IF(IPET(I) 0) THEN
1180 GPE(GLOB_IDX) = 0
1181 GNV(GLOB_IDX) = NVT(I)
1182 ELSE
1183 GPE(GLOB_IDX) = -LIPERM(-IPET(I))
1184 GNV(GLOB_IDX) = NVT(I)
1185 END IF
1186 END DO
1187 DO I=1, TOTNCLIQUES
1188 GLOB_IDX = ROOTPERM(I)
1189 GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I))
1190 END DO
1191 ELSE
1192 CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1,
1193 & MPI_INTEGER8, 0, MYID, id%COMM, IERR)
1194 CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1,
1195 & MPI_INTEGER, 0, MYID, id%COMM, IERR)
1196 END IF
1197 CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT)
1198 CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET,
1199 & TMP1, LVARPT, MEMCNT=MEMCNT)
1200 CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE,
1201 & LAST, DEGREE, MEMCNT=MEMCNT)
1202 CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT,
1203 & NV, MEMCNT=MEMCNT)
1204 CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST,
1205 & MEMCNT=MEMCNT)
1206 CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT)
1207 CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT)
1208 NULLIFY(HEAD, ELEN, LENG, PERM)
1209 RETURN
1210 END SUBROUTINE CMUMPS_PARSYMFACT
1211 SUBROUTINE CMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord)
1212 IMPLICIT NONE
1213 TYPE(CMUMPS_STRUC) :: id
1214 INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:)
1215 TYPE(ORD_TYPE) :: ord
1216 INTEGER :: I, J, K, GIDX
1217 CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO,
1218 & LP, STRING='lidx:lperm', MEMCNT=MEMCNT, ERRCODE=-7)
1219 CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO,
1220 & LP, STRING='lidx:liperm', MEMCNT=MEMCNT, ERRCODE=-7)
1221.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1222 LPERM = 0
1223 K = 1
1224 DO I=TOPNODES(1), 1, -1
1225 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2)
1226 GIDX = ord%PERITAB(J)
1227 LPERM(GIDX) = K
1228 LIPERM(K) = GIDX
1229 K = K+1
1230 END DO
1231 END DO
1232 RETURN
1233 END SUBROUTINE CMUMPS_MAKE_LOC_IDX
1234 SUBROUTINE CMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM,
1235 & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN)
1236 IMPLICIT NONE
1237 TYPE(CMUMPS_STRUC) :: id
1238 TYPE(GRAPH_TYPE) :: top_graph
1239 INTEGER, POINTER :: LPERM(:), LSTVAR(:),
1240 & PE(:), LENG(:), ELEN(:)
1241 INTEGER(8) :: LVARPT(:)
1242 INTEGER :: NCLIQUES
1243 INTEGER(8), POINTER :: IPE(:)
1244 INTEGER :: I, IDX, NLOCVARS
1245 INTEGER(8) :: INNZ, PNT, SAVEPNT
1246 CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO,
1247 & LP, STRING='atg:leng', MEMCNT=MEMCNT, ERRCODE=-7)
1248 CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO,
1249 & LP, STRING='atg:elen', MEMCNT=MEMCNT, ERRCODE=-7)
1250 CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO,
1251 & LP, STRING='atg:ipe', MEMCNT=MEMCNT, ERRCODE=-7)
1252.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1253 LENG = 0
1254 ELEN = 0
1255 DO INNZ=1, top_graph%NZ_LOC
1256.NE..AND. IF((LPERM(top_graph%JCN_LOC(INNZ)) 0)
1257.NE. & (top_graph%JCN_LOC(INNZ) top_graph%IRN_LOC(INNZ)))
1258 & THEN
1259 LENG(LPERM(top_graph%IRN_LOC(INNZ))) =
1260 & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1
1261 END IF
1262 END DO
1263 DO I=1, NCLIQUES
1264 DO INNZ=LVARPT(I), LVARPT(I+1)-1
1265 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1
1266 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1
1267 END DO
1268 END DO
1269 IPE(1) = 1
1270 DO I=1, NLOCVARS+NCLIQUES
1271 IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8)
1272 END DO
1273 CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+
1274 & int(NLOCVARS,8)+int(NCLIQUES,8),
1275 & id%INFO, LP, STRING='atg:pe', MEMCNT=MEMCNT, ERRCODE=-7)
1276.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1277 LENG = 0
1278 ELEN = 0
1279 DO I=1, NCLIQUES
1280 DO INNZ=LVARPT(I), LVARPT(I+1)-1
1281 IDX = LPERM(LSTVAR(INNZ))
1282 PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I
1283 PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX
1284 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1
1285 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1
1286 end do
1287 end do
1288 DO INNZ=1, top_graph%NZ_LOC
1289.NE..AND. IF((LPERM(top_graph%JCN_LOC(INNZ)) 0)
1290.NE. & (top_graph%JCN_LOC(INNZ) top_graph%IRN_LOC(INNZ)))
1291 & THEN
1292 PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+
1293 & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) +
1294 & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) =
1295 & LPERM(top_graph%JCN_LOC(INNZ))
1296 LENG(LPERM(top_graph%IRN_LOC(INNZ))) =
1297 & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1
1298 END IF
1299 END DO
1300 DO I=1, NLOCVARS+NCLIQUES
1301 LENG(I) = LENG(I)+ELEN(I)
1302 END DO
1303 SAVEPNT = 1
1304 PNT = 0
1305 LPERM(1:NLOCVARS+NCLIQUES) = 0
1306 DO I=1, NLOCVARS+NCLIQUES
1307 DO INNZ=IPE(I), IPE(I+1)-1
1308.EQ. IF(LPERM(PE(INNZ)) I) THEN
1309 LENG(I) = LENG(I)-1
1310 ELSE
1311 LPERM(PE(INNZ)) = I
1312 PNT = PNT+1
1313 PE(PNT) = PE(INNZ)
1314 END IF
1315 END DO
1316 IPE(I) = SAVEPNT
1317 SAVEPNT = PNT+1
1318 END DO
1319 IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT
1320 RETURN
1321 END SUBROUTINE CMUMPS_ASSEMBLE_TOP_GRAPH
1322#if defined(parmetis) || defined(parmetis3)
1323 SUBROUTINE CMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR)
1324 INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:)
1325 INTEGER :: CBLKNBR,allocok
1326 INTEGER :: LCHILD, RCHILD, K, I
1327 INTEGER, POINTER :: PERM(:)
1328 ALLOCATE(PERM(CBLKNBR),stat=allocok)
1329.GT. if(allocok0) then
1330 write(*,*) "Allocation error of PERM in CMUMPS_BUILD_TREETAB"
1331 return
1332 endif
1333 TREETAB(CBLKNBR) = -1
1334.EQ. IF(CBLKNBR 1) THEN
1335 DEALLOCATE(PERM)
1336 TREETAB(1) = -1
1337 RANGTAB(1) = 1
1338 RANGTAB(2)= SIZES(1)+1
1339 RETURN
1340 END IF
1341 LCHILD = CBLKNBR - (CBLKNBR+1)/2
1342 RCHILD = CBLKNBR-1
1343 K = 1
1344 PERM(CBLKNBR) = CBLKNBR
1345 PERM(LCHILD) = CBLKNBR+1 - (2*K+1)
1346 PERM(RCHILD) = CBLKNBR+1 - (2*K)
1347 TREETAB(RCHILD) = CBLKNBR
1348 TREETAB(LCHILD) = CBLKNBR
1349.GT. IF(CBLKNBR 3) THEN
1350 CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2,
1351 & LCHILD, CBLKNBR, 2*K+1)
1352 CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2,
1353 & RCHILD, CBLKNBR, 2*K)
1354 END IF
1355 RANGTAB(1)=1
1356 DO I=1, CBLKNBR
1357 RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I))
1358 END DO
1359 DEALLOCATE(PERM)
1360 RETURN
1361 CONTAINS
1362 RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES,
1363 & ROOTN, CBLKNBR, K)
1364 INTEGER, POINTER :: TREETAB(:), PERM(:)
1365 INTEGER :: SUBNODES, ROOTN, K, CBLKNBR
1366 INTEGER :: LCHILD, RCHILD
1367 LCHILD = ROOTN - (SUBNODES+1)/2
1368 RCHILD = ROOTN-1
1369 PERM(LCHILD) = CBLKNBR+1 - (2*K+1)
1370 PERM(RCHILD) = CBLKNBR+1 - (2*K)
1371 TREETAB(RCHILD) = ROOTN
1372 TREETAB(LCHILD) = ROOTN
1373.GT. IF(SUBNODES 3) THEN
1374 CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD,
1375 & CBLKNBR, 2*K+1)
1376 CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD,
1377 & CBLKNBR, 2*K)
1378 END IF
1379 END SUBROUTINE REC_TREETAB
1380 END SUBROUTINE CMUMPS_BUILD_TREETAB
1381#endif
1382#if defined(ptscotch) || defined(parmetis) || defined(parmetis3)
1383 SUBROUTINE CMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, IPE,
1384 & PE, WORK)
1385 IMPLICIT NONE
1386 TYPE(CMUMPS_STRUC) :: id
1387 INTEGER(8), POINTER :: IPE(:)
1388 INTEGER, POINTER :: FIRST(:), LAST(:), PE(:),
1389 & WORK(:)
1390 INTEGER :: IERR, MYID, NPROCS
1391 INTEGER :: I, PROC, J, LOC_ROW
1392 INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG,
1393 & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS
1394 INTEGER :: NROWS_LOC
1395 INTEGER :: STATUS(MPI_STATUS_SIZE)
1396 INTEGER, POINTER :: MAPTAB(:)
1397 INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:)
1398 INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:),
1399 & SIPES(:,:), LENG(:)
1400 INTEGER, POINTER :: TSENDI(:),
1401 & TSENDJ(:), RCVBUF(:)
1402 TYPE(ARRPNT), POINTER :: APNT(:)
1403 INTEGER :: BUFSIZE, SOURCE, MAXS, allocok
1404 INTEGER, PARAMETER :: ITAG=30
1405 LOGICAL :: FLAG
1406 DOUBLE PRECISION :: SYMMETRY
1407 INTEGER(KIND=8) :: TLEN
1408#if defined(DETERMINISTIC_PARALLEL_GRAPH)
1409 INTEGER :: L
1410#endif
1411 nullify(MAPTAB, SNDCNT, RCVCNT)
1412 nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL)
1413 nullify(TSENDI, TSENDJ, RCVBUF, APNT)
1414 CALL MPI_COMM_RANK (id%COMM, MYID, IERR)
1415 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR)
1416.LT. IF(MUMPS_GETSIZE(WORK) id%N*2) THEN
1417 WRITE(LP,
1418 & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")')
1419 CALL MUMPS_ABORT()
1420 END IF
1421 CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP,
1422 & MEMCNT=MEMCNT, ERRCODE=-7)
1423 CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP,
1424 & MEMCNT=MEMCNT, ERRCODE=-7)
1425 CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP,
1426 & MEMCNT=MEMCNT, ERRCODE=-7)
1427 CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP,
1428 & MEMCNT=MEMCNT, ERRCODE=-7)
1429.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1430 ALLOCATE(APNT(NPROCS), stat=allocok)
1431.GT. IF(allocok0) THEN
1432 id%INFO(1)=-13
1433 id%INFO(2)=NPROCS
1434 ENDIF
1435 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
1436.LT. IF ( id%INFO(1) 0 ) GO TO 90
1437 SNDCNT = 0
1438 BUFSIZE = 1000
1439 BUFSIZE = id%KEEP(39)
1440 LOCNNZ = id%KEEP8(29)
1441 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1
1442 MAPTAB => WORK( 1 : id%N)
1443 LENG => WORK(id%N+1 : 2*id%N)
1444 MAXS = 0
1445 DO I=1, NPROCS
1446.GT. IF((LAST(I)-FIRST(I)+1) MAXS) THEN
1447 MAXS = LAST(I)-FIRST(I)+1
1448 END IF
1449 DO J=FIRST(I), LAST(I)
1450 MAPTAB(J) = I
1451 END DO
1452 END DO
1453 ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok)
1454.GT. IF(allocok0) THEN
1455 id%INFO(1)=-13
1456 id%INFO(2)=max(1,MAXS)*NPROCS
1457 ENDIF
1458 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
1459.LT. IF ( id%INFO(1) 0 ) GO TO 90
1460 OFFDIAG=0
1461 SIPES=0
1462 DO INNZ=1, LOCNNZ
1463.NE. IF(id%IRN_loc(INNZ) id%JCN_loc(INNZ)) THEN
1464 OFFDIAG = OFFDIAG+1
1465 PROC = MAPTAB(id%IRN_loc(INNZ))
1466 LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1
1467 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1
1468 SNDCNT(PROC) = SNDCNT(PROC)+1
1469 PROC = MAPTAB(id%JCN_loc(INNZ))
1470 LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1
1471 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1
1472 SNDCNT(PROC) = SNDCNT(PROC)+1
1473 END IF
1474 END DO
1475 CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8,
1476 & MPI_SUM, id%COMM, IERR)
1477 id%KEEP8(127) = id%KEEP8(127)+3*id%N
1478 id%KEEP8(126) = id%KEEP8(127)-2*id%N
1479 CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1,
1480 & MPI_INTEGER8, id%COMM, IERR)
1481 CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT)
1482 RDISPL(:) = MAXS
1483 CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1),
1484 & MPI_INTEGER, MPI_SUM, id%COMM, IERR )
1485 DEALLOCATE(SIPES)
1486 TLEN = 0_8
1487 IPE(1) = 1_8
1488 DO I=1, NROWS_LOC
1489 IPE(I+1) = IPE(I) + int(LENG(I),8)
1490 TLEN = TLEN+int(LENG(I),8)
1491 END DO
1492 CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO,
1493 & LP, STRING='pe', MEMCNT=MEMCNT, ERRCODE=-7)
1494.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1495 LENG(:) = 0
1496 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP,
1497 & MEMCNT=MEMCNT, ERRCODE=-7)
1498 CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG,
1499 & RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1500 NEW_LOCNNZ = 0
1501 DO I=1, NPROCS
1502 NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I)
1503 MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8)
1504 END DO
1505 RCVPNT = 1
1506 BUFLEVEL = 0
1507 DO INNZ=1, LOCNNZ
1508.EQ. IF(mod(INNZ,int(BUFSIZE,8)/10_8) 0) THEN
1509 CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM,
1510 & FLAG, STATUS, IERR )
1511 IF(FLAG) THEN
1512 SOURCE = STATUS(MPI_SOURCE)
1513 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE,
1514 & ITAG, id%COMM, STATUS, IERR)
1515 CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG)
1516 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1
1517 RCVPNT = RCVPNT + BUFSIZE
1518 END IF
1519 END IF
1520.NE. IF(id%IRN_loc(INNZ) id%JCN_loc(INNZ)) THEN
1521 PROC = MAPTAB(id%IRN_loc(INNZ))
1522 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)-
1523 & FIRST(PROC)+1
1524 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ)
1525 BUFLEVEL(PROC) = BUFLEVEL(PROC)+1
1526.EQ. IF(BUFLEVEL(PROC) BUFSIZE) THEN
1527 CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE,
1528 & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1529 END IF
1530 PROC = MAPTAB(id%JCN_loc(INNZ))
1531 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)-
1532 & FIRST(PROC)+1
1533 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ)
1534 BUFLEVEL(PROC) = BUFLEVEL(PROC)+1
1535.EQ. IF(BUFLEVEL(PROC) BUFSIZE) THEN
1536 CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE,
1537 & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1538 END IF
1539 END IF
1540 END DO
1541 CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG,
1542 & RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1543 DUPS = 0
1544 PNT = 0
1545 SAVEPNT = 1
1546 MAPTAB = 0
1547 DO I=1, NROWS_LOC
1548 DO INNZ=IPE(I),IPE(I+1)-1
1549.EQ. IF(MAPTAB(PE(INNZ)) I) THEN
1550 DUPS = DUPS+1
1551 ELSE
1552 MAPTAB(PE(INNZ)) = I
1553 PNT = PNT+1
1554 PE(PNT) = PE(INNZ)
1555 END IF
1556 END DO
1557 IPE(I) = SAVEPNT
1558 SAVEPNT = PNT+1
1559 END DO
1560 CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM,
1561 & 0, id%COMM, IERR )
1562.EQ. IF(MYID 0) THEN
1563 SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(id%N))
1564 SYMMETRY = min(SYMMETRY,1.0d0)
1565.GE. IF(id%KEEP(50) 1) SYMMETRY = 1.d0
1566 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")')
1567 & ceiling(SYMMETRY*100.d0)
1568 id%INFOG(8) = ceiling(SYMMETRY*100.0d0)
1569 END IF
1570 IPE(NROWS_LOC+1) = SAVEPNT
1571 CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT)
1572 CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT)
1573 DEALLOCATE(APNT)
1574#if defined(DETERMINISTIC_PARALLEL_GRAPH)
1575 DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1
1576 L = int(IPE(I+1)-IPE(I))
1577 CALL CMUMPS_MERGESORT(L,
1578 & PE(IPE(I):IPE(I+1)-1),
1579 & WORK(:))
1580 CALL CMUMPS_MERGESWAP1(L, WORK(:),
1581 & PE(IPE(I):IPE(I+1)-1))
1582 END DO
1583#endif
1584 90 continue
1585 RETURN
1586 END SUBROUTINE CMUMPS_BUILD_DIST_GRAPH
1587#endif
1588 SUBROUTINE CMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG,
1589 & I_HALO_MAP, top_graph, WORK)
1590 IMPLICIT NONE
1591 TYPE(CMUMPS_STRUC) :: id
1592 TYPE(ORD_TYPE) :: ord
1593 TYPE(GRAPH_TYPE) :: top_graph
1594 INTEGER(8), POINTER :: IPE(:)
1595 INTEGER, POINTER :: PE(:), LENG(:),
1596 & I_HALO_MAP(:), WORK(:)
1597 INTEGER :: GSIZE
1598 INTEGER :: IERR, MYID, NPROCS
1599 INTEGER :: I, PROC, J, LOC_ROW
1600 INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX,
1601 & RCVPNT
1602 INTEGER :: IIDX,JJDX
1603 INTEGER :: HALO_SIZE, NROWS_LOC, DUPS
1604 INTEGER :: STATUS(MPI_STATUS_SIZE)
1605 INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:)
1606 INTEGER, POINTER :: MAPTAB(:),
1607 & HALO_MAP(:), BUFLEVEL(:)
1608 INTEGER, POINTER :: RDISPL(:),
1609 & SIPES(:,:)
1610 INTEGER, POINTER :: TSENDI(:),
1611 & TSENDJ(:), RCVBUF(:)
1612 TYPE(ARRPNT), POINTER :: APNT(:)
1613 INTEGER :: BUFSIZE, SOURCE, MAXS, allocok
1614 INTEGER(8) :: PNT, SAVEPNT
1615 INTEGER, PARAMETER :: ITAG=30
1616 INTEGER(KIND=8) :: TLEN
1617 LOGICAL :: FLAG
1618 nullify(MAPTAB, SNDCNT, RCVCNT, HALO_MAP)
1619 nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL)
1620 nullify(TSENDI, TSENDJ, RCVBUF, APNT)
1621 CALL MPI_COMM_RANK (id%COMM, MYID, IERR)
1622 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR)
1623.LT. IF(MUMPS_GETSIZE(WORK) id%N*2) THEN
1624 WRITE(LP,
1625 & '("Insufficient workspace inside BUILD_LOC_GRAPH")')
1626 CALL MUMPS_ABORT()
1627 END IF
1628 MAPTAB => WORK( 1 : id%N)
1629 HALO_MAP => WORK(id%N+1 : 2*id%N)
1630 CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP,
1631 & MEMCNT=MEMCNT, ERRCODE=-7)
1632 CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP,
1633 & MEMCNT=MEMCNT, ERRCODE=-7)
1634 CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP,
1635 & MEMCNT=MEMCNT, ERRCODE=-7)
1636 CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP,
1637 & MEMCNT=MEMCNT, ERRCODE=-7)
1638.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1639 ALLOCATE(APNT(NPROCS), stat=allocok)
1640.GT. IF(allocok0) THEN
1641 id%INFO(1)=-13
1642 id%INFO(2)=NPROCS
1643 ENDIF
1644 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
1645.LT. IF ( id%INFO(1) 0 ) GO TO 90
1646 SNDCNT = 0
1647 TOP_CNT = 0
1648 BUFSIZE = 10000
1649 LOCNNZ = id%KEEP8(29)
1650 NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1
1651 MAPTAB = 0
1652 MAXS = 0
1653 DO I=1, NPROCS
1654.GT. IF((ord%LAST(I)-ord%FIRST(I)+1) MAXS) THEN
1655 MAXS = ord%LAST(I)-ord%FIRST(I)+1
1656 END IF
1657 DO J=ord%FIRST(I), ord%LAST(I)
1658 MAPTAB(ord%PERITAB(J)) = I
1659 END DO
1660 END DO
1661 ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok)
1662.GT. IF(allocok0) THEN
1663 id%INFO(1)=-13
1664 id%INFO(2)=max(1,MAXS)*NPROCS
1665 ENDIF
1666 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
1667.LT. IF ( id%INFO(1) 0 ) GO TO 90
1668 SIPES(:,:) = 0
1669 TOP_CNT = 0
1670 DO INNZ=1, LOCNNZ
1671.NE. IF(id%IRN_loc(INNZ) id%JCN_loc(INNZ)) THEN
1672 PROC = MAPTAB(id%IRN_loc(INNZ))
1673.EQ. IF(PROC 0) THEN
1674 TOP_CNT = TOP_CNT+1
1675 ELSE
1676 IIDX = ord%PERMTAB(id%IRN_loc(INNZ))
1677 LOC_ROW = IIDX-ord%FIRST(PROC)+1
1678 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1
1679 SNDCNT(PROC) = SNDCNT(PROC)+1
1680 END IF
1681 PROC = MAPTAB(id%JCN_loc(INNZ))
1682.EQ. IF(PROC 0) THEN
1683 TOP_CNT = TOP_CNT+1
1684 ELSE
1685 IIDX = ord%PERMTAB(id%JCN_loc(INNZ))
1686 LOC_ROW = IIDX-ord%FIRST(PROC)+1
1687 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1
1688 SNDCNT(PROC) = SNDCNT(PROC)+1
1689 END IF
1690 END IF
1691 END DO
1692 CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1,
1693 & MPI_INTEGER8, id%COMM, IERR)
1694 I = ceiling(real(MAXS)*1.20E0)
1695 CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO,
1696 & LP, STRING='b_l_g:leng', MEMCNT=MEMCNT, ERRCODE=-7)
1697.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1698 CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT)
1699 RDISPL(:) = MAXS
1700 CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1),
1701 & MPI_INTEGER, MPI_SUM, id%COMM, IERR )
1702 DEALLOCATE(SIPES)
1703 I = ceiling(real(NROWS_LOC+1)*1.20E0)
1704 CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO,
1705 & LP, STRING='b_l_g:ipe', MEMCNT=MEMCNT, ERRCODE=-7)
1706.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1707 TLEN = 0_8
1708 IPE(1) = 1_8
1709 DO I=1, NROWS_LOC
1710 IPE(I+1) = IPE(I) + int(LENG(I),8)
1711 TLEN = TLEN+int(LENG(I),8)
1712 END DO
1713 CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP,
1714 & MEMCNT=MEMCNT, ERRCODE=-7)
1715 CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP,
1716 & MEMCNT=MEMCNT, ERRCODE=-7)
1717.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1718 LENG(:) = 0
1719 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP,
1720 & MEMCNT=MEMCNT, ERRCODE=-7)
1721 CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE,
1722 & LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1723 NEW_LOCNNZ = 0
1724 DO I=1, NPROCS
1725 NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I)
1726 MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8)
1727 END DO
1728 CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+
1729 & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8),
1730 & id%INFO, LP, STRING='b_l_g:pe', MEMCNT=MEMCNT, ERRCODE=-7)
1731.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1732 RCVPNT = 1
1733 BUFLEVEL = 0
1734 TIDX = 0
1735 DO INNZ=1, LOCNNZ
1736.EQ. IF(mod(INNZ,int(BUFSIZE/10,8)) 0) THEN
1737 CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM,
1738 & FLAG, STATUS, IERR )
1739 IF(FLAG) THEN
1740 SOURCE = STATUS(MPI_SOURCE)
1741 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE,
1742 & ITAG, id%COMM, STATUS, IERR)
1743 CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG)
1744 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1
1745 RCVPNT = RCVPNT + BUFSIZE
1746 END IF
1747 END IF
1748.NE. IF(id%IRN_loc(INNZ) id%JCN_loc(INNZ)) THEN
1749 PROC = MAPTAB(id%IRN_loc(INNZ))
1750.NE..AND. IF((MAPTAB(id%JCN_loc(INNZ))PROC)
1751.NE..AND. & (MAPTAB(id%JCN_loc(INNZ))0)
1752.NE. & (PROC0)) THEN
1753 IERR = -50
1754 id%INFO(1) = IERR
1755 END IF
1756.EQ. IF(PROC 0) THEN
1757 TIDX = TIDX+1
1758 TSENDI(TIDX) = id%IRN_loc(INNZ)
1759 TSENDJ(TIDX) = id%JCN_loc(INNZ)
1760 ELSE
1761 IIDX = ord%PERMTAB(id%IRN_loc(INNZ))
1762 JJDX = ord%PERMTAB(id%JCN_loc(INNZ))
1763 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1
1764.GE..AND. IF( (JJDX ord%FIRST(PROC))
1765.LE. & (JJDX ord%LAST(PROC)) ) THEN
1766 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) =
1767 & JJDX-ord%FIRST(PROC)+1
1768 ELSE
1769 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ)
1770 END IF
1771 BUFLEVEL(PROC) = BUFLEVEL(PROC)+1
1772.EQ. IF(BUFLEVEL(PROC) BUFSIZE) THEN
1773 CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE,
1774 & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1775 END IF
1776 END IF
1777 PROC = MAPTAB(id%JCN_loc(INNZ))
1778.EQ. IF(PROC 0) THEN
1779 TIDX = TIDX+1
1780 TSENDI(TIDX) = id%JCN_loc(INNZ)
1781 TSENDJ(TIDX) = id%IRN_loc(INNZ)
1782 ELSE
1783 IIDX = ord%PERMTAB(id%JCN_loc(INNZ))
1784 JJDX = ord%PERMTAB(id%IRN_loc(INNZ))
1785 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) =
1786 & IIDX-ord%FIRST(PROC)+1
1787.GE..AND. IF( (JJDX ord%FIRST(PROC))
1788.LE. & (JJDX ord%LAST(PROC)) ) THEN
1789 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) =
1790 & JJDX-ord%FIRST(PROC)+1
1791 ELSE
1792 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ)
1793 END IF
1794 BUFLEVEL(PROC) = BUFLEVEL(PROC)+1
1795.EQ. IF(BUFLEVEL(PROC) BUFSIZE) THEN
1796 CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE,
1797 & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1798 END IF
1799 END IF
1800 END IF
1801 END DO
1802 CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG,
1803 & RCVBUF, MSGCNT, BUFLEVEL, id%COMM)
1804 DUPS = 0
1805 PNT = 0
1806 SAVEPNT = 1
1807 MAPTAB(:) = 0
1808 HALO_MAP(:) = 0
1809 HALO_SIZE = 0
1810 DO I=1, NROWS_LOC
1811 DO INNZ=IPE(I),IPE(I+1)-1
1812.LT. IF(PE(INNZ) 0) THEN
1813.EQ. IF(HALO_MAP(-PE(INNZ)) 0) THEN
1814 HALO_SIZE = HALO_SIZE+1
1815 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE
1816 END IF
1817 PE(INNZ) = HALO_MAP(-PE(INNZ))
1818 END IF
1819.EQ. IF(MAPTAB(PE(INNZ)) I) THEN
1820 DUPS = DUPS+1
1821 LENG(I) = LENG(I)-1
1822 ELSE
1823 MAPTAB(PE(INNZ)) = I
1824 PNT = PNT+1
1825 PE(PNT) = PE(INNZ)
1826 END IF
1827 END DO
1828 IPE(I) = SAVEPNT
1829 SAVEPNT = PNT+1
1830 END DO
1831 IPE(NROWS_LOC+1) = SAVEPNT
1832 CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP,
1833 & MEMCNT=MEMCNT, ERRCODE=-7)
1834.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1835 J=0
1836 DO I=1, id%N
1837.GT. IF(HALO_MAP(I) 0) THEN
1838 J = J+1
1839 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I
1840 END IF
1841.EQ. IF(J HALO_SIZE) EXIT
1842 END DO
1843 CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO,
1844 & LP, COPY=.TRUE.,
1845 & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7)
1846 LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0
1847 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO,
1848 & LP, COPY=.TRUE.,
1849 & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7)
1850.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1851 IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1)
1852 GSIZE = NROWS_LOC + HALO_SIZE
1853 CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1,
1854 & MPI_INTEGER8, 0, id%COMM, IERR)
1855.EQ. IF(MYID0) THEN
1856 NEW_LOCNNZ = sum(RCVCNT)
1857 top_graph%NZ_LOC = NEW_LOCNNZ
1858 top_graph%COMM = id%COMM
1859 CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ),
1860 & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7)
1861 CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ),
1862 & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7)
1863.GT. IF(MEMCNT MAXMEM) MAXMEM=MEMCNT
1864 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID)
1865.LT. IF ( id%INFO(1) 0 ) GO TO 90
1866 ELSE
1867 ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1),
1868 & stat=allocok)
1869.GT. IF(allocok0) THEN
1870 id%INFO(1)=-13
1871 id%INFO(2)=2
1872 ENDIF
1873 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID)
1874.LT. IF ( id%INFO(1) 0 ) GO TO 90
1875 END IF
1876.EQ. IF(MYID0) THEN
1877 top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT)
1878 top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT)
1879 DO PROC=2, NPROCS
1880.GT. DO WHILE (RCVCNT(PROC) 0)
1881 I = int(min(int(BUFSIZE,8), RCVCNT(PROC)))
1882 CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I,
1883 & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR)
1884 CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I,
1885 & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR)
1886 RCVCNT(PROC) = RCVCNT(PROC)-I
1887 TOP_CNT = TOP_CNT+I
1888 END DO
1889 END DO
1890 ELSE
1891.GT. DO WHILE (TOP_CNT 0)
1892 I = int(MIN(int(BUFSIZE,8), TOP_CNT))
1893 CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I,
1894 & MPI_INTEGER, 0, ITAG, id%COMM, IERR)
1895 CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I,
1896 & MPI_INTEGER, 0, ITAG, id%COMM, IERR)
1897 TOP_CNT = TOP_CNT-I
1898 END DO
1899 END IF
1900 CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI,
1901 & TSENDJ, MEMCNT=MEMCNT)
1902 CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT)
1903 DEALLOCATE(APNT)
1904 90 continue
1905 RETURN
1906 END SUBROUTINE CMUMPS_BUILD_LOC_GRAPH
1907 SUBROUTINE CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE,
1908 & LENG, RCVBUF, MSGCNT, SNDCNT, COMM)
1909 IMPLICIT NONE
1910 INTEGER :: NPROCS, PROC, COMM, allocok
1911 TYPE(ARRPNT) :: APNT(:)
1912 INTEGER :: BUFSIZE
1913 INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:)
1914 INTEGER :: SNDCNT(:)
1915 INTEGER(8) :: MSGCNT(:), IPE(:)
1916 LOGICAL, SAVE :: INIT = .TRUE.
1917 INTEGER, POINTER, SAVE :: SPACE(:,:,:)
1918 LOGICAL, POINTER, SAVE :: PENDING(:)
1919 INTEGER, POINTER, SAVE :: REQ(:), CPNT(:)
1920 INTEGER :: IERR, MYID, I, SOURCE
1921 INTEGER(8) :: TOTMSG
1922 LOGICAL :: FLAG, TFLAG
1923 INTEGER :: STATUS(MPI_STATUS_SIZE)
1924 INTEGER :: TSTATUS(MPI_STATUS_SIZE)
1925 INTEGER, PARAMETER :: ITAG=30, FTAG=31
1926 INTEGER, POINTER :: TMPI(:), RCVCNT(:)
1927 CALL MPI_COMM_RANK (COMM, MYID, IERR)
1928 CALL MPI_COMM_SIZE (COMM, NPROCS, IERR)
1929 IF(INIT) THEN
1930 ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok)
1931.GT. IF(allocok0) THEN
1932 write(*,*) "Allocation error of SPACE in CMUMPS_SEND_BUF"
1933 return
1934 ENDIF
1935 ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok)
1936.GT. IF(allocok0) THEN
1937 write(*,*) "Allocation error of RCVBUF in CMUMPS_SEND_BUF"
1938 return
1939 ENDIF
1940 ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok)
1941.GT. IF(allocok0) THEN
1942 write(*,*) "Allocation error of PENDING/CPNT"
1943 & ," in CMUMPS_SEND_BUF"
1944 return
1945 ENDIF
1946 ALLOCATE(REQ(NPROCS), stat=allocok)
1947.GT. IF(allocok0) THEN
1948 write(*,*) "Allocation error of REQ in CMUMPS_SEND_BUF"
1949 return
1950 ENDIF
1951 PENDING = .FALSE.
1952 DO I=1, NPROCS
1953 APNT(I)%BUF => SPACE(:,1,I)
1954 CPNT(I) = 1
1955 END DO
1956 INIT = .FALSE.
1957 RETURN
1958 END IF
1959.EQ. IF(PROC -1) THEN
1960 TOTMSG = sum(MSGCNT)
1961 DO
1962.EQ. IF(TOTMSG 0) EXIT
1963 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER,
1964 & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR)
1965 CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG)
1966 SOURCE = STATUS(MPI_SOURCE)
1967 TOTMSG = TOTMSG-1
1968 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1
1969 END DO
1970 DO I=1, NPROCS
1971 IF(PENDING(I)) THEN
1972 CALL MPI_WAIT(REQ(I), TSTATUS, IERR)
1973 END IF
1974 END DO
1975 ALLOCATE(RCVCNT(NPROCS), stat=allocok)
1976.GT. IF(allocok0) THEN
1977 write(*,*) "Allocation error of RCVCNT in CMUMPS_SEND_BUF"
1978 return
1979 ENDIF
1980 CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1,
1981 & MPI_INTEGER, COMM, IERR)
1982 DO I=1, NPROCS
1983.GT. IF(SNDCNT(I) 0) THEN
1984 TMPI => APNT(I)%BUF(:)
1985 CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1,
1986 & FTAG, COMM, REQ(I), IERR)
1987 END IF
1988 END DO
1989 DO I=1, NPROCS
1990.GT. IF(RCVCNT(I) 0) THEN
1991 CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1,
1992 & FTAG, COMM, STATUS, IERR)
1993 CALL CMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF,
1994 & IPE, PE, LENG)
1995 END IF
1996 END DO
1997 DO I=1, NPROCS
1998.GT. IF(SNDCNT(I) 0) THEN
1999 CALL MPI_WAIT(REQ(I), TSTATUS, IERR)
2000 END IF
2001 END DO
2002 DEALLOCATE(SPACE)
2003 DEALLOCATE(PENDING, CPNT)
2004 DEALLOCATE(REQ)
2005 DEALLOCATE(RCVBUF, RCVCNT)
2006 nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT)
2007 INIT = .TRUE.
2008 RETURN
2009 END IF
2010 IF(PENDING(PROC)) THEN
2011 DO
2012 CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR)
2013 IF(TFLAG) THEN
2014 PENDING(PROC) = .FALSE.
2015 EXIT
2016 ELSE
2017 CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM,
2018 & FLAG, STATUS, IERR )
2019 IF(FLAG) THEN
2020 SOURCE = STATUS(MPI_SOURCE)
2021 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER,
2022 & SOURCE, ITAG, COMM, STATUS, IERR)
2023 CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE,
2024 & PE, LENG)
2025 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1
2026 END IF
2027 END IF
2028 END DO
2029 END IF
2030 TMPI => APNT(PROC)%BUF(:)
2031 CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1,
2032 & ITAG, COMM, REQ(PROC), IERR)
2033 PENDING(PROC) = .TRUE.
2034 CPNT(PROC) = mod(CPNT(PROC),2)+1
2035 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC)
2036 SNDCNT(PROC) = 0
2037 RETURN
2038 END SUBROUTINE CMUMPS_SEND_BUF
2039 SUBROUTINE CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG)
2040 IMPLICIT NONE
2041 INTEGER :: BUFSIZE
2042 INTEGER :: RCVBUF(:), PE(:), LENG(:)
2043 INTEGER(8) :: IPE(:)
2044 INTEGER :: I, ROW, COL
2045 DO I=1, 2*BUFSIZE, 2
2046 ROW = RCVBUF(I)
2047 COL = RCVBUF(I+1)
2048 PE(IPE(ROW)+LENG(ROW)) = COL
2049 LENG(ROW) = LENG(ROW) + 1
2050 END DO
2051 RETURN
2052 END SUBROUTINE CMUMPS_ASSEMBLE_MSG
2053#if defined(ptscotch) || defined(parmetis) || defined(parmetis3)
2054 SUBROUTINE CMUMPS_BUILD_TREE(ord)
2055 TYPE(ORD_TYPE) :: ord
2056 INTEGER :: I
2057 ord%SON = -1
2058 ord%BROTHER = -1
2059 ord%NW = 0
2060 DO I=1, ord%CBLKNBR
2061 ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I)
2062.NE. IF (ord%TREETAB(I) -1) THEN
2063.EQ. IF (ord%SON(ord%TREETAB(I)) -1) THEN
2064 ord%SON(ord%TREETAB(I)) = I
2065 ELSE
2066 ord%BROTHER(I) = ord%SON(ord%TREETAB(I))
2067 ord%SON(ord%TREETAB(I)) = I
2068 END IF
2069 ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I)
2070 END IF
2071 END DO
2072 RETURN
2073 END SUBROUTINE CMUMPS_BUILD_TREE
2074 SUBROUTINE CMUMPS_GRAPH_DIST(id, ord, FIRST,
2075 & LAST, BASE, NPROCS, WORK, TYPE)
2076 IMPLICIT NONE
2077 TYPE(CMUMPS_STRUC) :: id
2078 TYPE(ORD_TYPE) :: ord
2079 INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE
2080 INTEGER, TARGET :: WORK(:)
2081 INTEGER, POINTER :: TMP(:), NZ_ROW(:)
2082 INTEGER :: I, IERR, P, F, J
2083 INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG,
2084 & OFFDIAG, T, SHARE
2085 DO I=0, BASE-1
2086 FIRST(I+1) = 0
2087 LAST(I+1) = -1
2088 END DO
2089.EQ. IF(TYPE1) THEN
2090 SHARE = int(id%N/ord%NSLAVES,8)
2091 DO I=1, ord%NSLAVES
2092 FIRST(BASE+I) = (I-1)*int(SHARE)+1
2093 LAST (BASE+I) = (I)*int(SHARE)
2094 END DO
2095 LAST(BASE+ord%NSLAVES) = MAX(LAST(BASE+ord%NSLAVES), id%N)
2096 DO I = ord%NSLAVES+1, id%NSLAVES+1
2097 FIRST(BASE+I) = id%N+1
2098 LAST (BASE+I) = id%N
2099 END DO
2100.EQ. ELSE IF (TYPE2) THEN
2101 TMP => WORK(1:id%N)
2102 NZ_ROW => WORK(id%N+1:2*id%N)
2103 TMP = 0
2104 LOCOFFDIAG = 0_8
2105 LOCNNZ = id%KEEP8(29)
2106 DO INNZ=1, LOCNNZ
2107.NE. IF(id%IRN_loc(INNZ) id%JCN_loc(INNZ)) THEN
2108 TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1
2109 LOCOFFDIAG = LOCOFFDIAG+1
2110.GT. IF(id%SYM0) THEN
2111 TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1
2112 LOCOFFDIAG = LOCOFFDIAG+1
2113 END IF
2114 END IF
2115 END DO
2116 CALL MPI_ALLREDUCE(TMP(1), NZ_ROW(1), id%N,
2117 & MPI_INTEGER, MPI_SUM, id%COMM, IERR)
2118 CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1,
2119 & MPI_INTEGER8, MPI_SUM, id%COMM, IERR)
2120 nullify(TMP)
2121 SHARE = (OFFDIAG-1_8)/int(ord%NSLAVES,8) + 1_8
2122 P = 0
2123 T = 0_8
2124 F = 1
2125 DO I=1, id%N
2126 T = T+int(NZ_ROW(I),8)
2127 IF (
2128.GE..OR. & (T SHARE)
2129.EQ..OR. & ((id%N-I)(ord%NSLAVES-P-1))
2130.EQ. & (Iid%N)
2131 & ) THEN
2132 P = P+1
2133.EQ. IF(Pord%NSLAVES) THEN
2134 FIRST(BASE+P) = F
2135 LAST(BASE+P) = id%N
2136 EXIT
2137 ELSE
2138 FIRST(BASE+P) = F
2139 LAST(BASE+P) = I
2140 F = I+1
2141 T = 0_8
2142 END IF
2143 END IF
2144 END DO
2145 DO J=P+1, NPROCS+1-BASE
2146 FIRST(BASE+J) = id%N+1
2147 LAST(BASE+J) = id%N
2148 END DO
2149 END IF
2150 RETURN
2151 END SUBROUTINE CMUMPS_GRAPH_DIST
2152#endif
2153 SUBROUTINE CMUMPS_MERGESWAP(N, L, A1, A2)
2154 INTEGER :: I, LP, ISWAP, N
2155 INTEGER :: L(0:), A1(:), A2(:)
2156 LP = L(0)
2157 I = 1
2158 DO
2159.OR. IF ((LP==0)(I>N)) EXIT
2160 DO
2161 IF (LP >= I) EXIT
2162 LP = L(LP)
2163 END DO
2164 ISWAP = A1(LP)
2165 A1(LP) = A1(I)
2166 A1(I) = ISWAP
2167 ISWAP = A2(LP)
2168 A2(LP) = A2(I)
2169 A2(I) = ISWAP
2170 ISWAP = L(LP)
2171 L(LP) = L(I)
2172 L(I) = LP
2173 LP = ISWAP
2174 I = I + 1
2175 ENDDO
2176 END SUBROUTINE CMUMPS_MERGESWAP
2177#if defined(DETERMINISTIC_PARALLEL_GRAPH)
2178 SUBROUTINE CMUMPS_MERGESWAP1(N, L, A)
2179 INTEGER :: I, LP, ISWAP, N
2180 INTEGER :: L(0:), A(:)
2181 LP = L(0)
2182 I = 1
2183 DO
2184.OR. IF ((LP==0)(I>N)) EXIT
2185 DO
2186 IF (LP >= I) EXIT
2187 LP = L(LP)
2188 END DO
2189 ISWAP = A(LP)
2190 A(LP) = A(I)
2191 A(I) = ISWAP
2192 ISWAP = L(LP)
2193 L(LP) = L(I)
2194 L(I) = LP
2195 LP = ISWAP
2196 I = I + 1
2197 ENDDO
2198 END SUBROUTINE CMUMPS_MERGESWAP1
2199#endif
2200 SUBROUTINE CMUMPS_MERGESORT(N, K, L)
2201 INTEGER :: N
2202 INTEGER :: K(:), L(0:)
2203 INTEGER :: P, Q, S, T
2204 CONTINUE
2205 L(0) = 1
2206 T = N + 1
2207 DO P = 1,N - 1
2208 IF (K(P) <= K(P+1)) THEN
2209 L(P) = P + 1
2210 ELSE
2211 L(T) = - (P+1)
2212 T = P
2213 END IF
2214 END DO
2215 L(T) = 0
2216 L(N) = 0
2217 IF (L(N+1) == 0) THEN
2218 RETURN
2219 ELSE
2220 L(N+1) = iabs(L(N+1))
2221 END IF
2222 200 CONTINUE
2223 S = 0
2224 T = N+1
2225 P = L(S)
2226 Q = L(T)
2227.EQ. IF(Q 0) RETURN
2228 300 CONTINUE
2229.GT. IF(K(P) K(Q)) GOTO 600
2230 CONTINUE
2231 L(S) = sign(P,L(S))
2232 S = P
2233 P = L(P)
2234.GT. IF (P 0) GOTO 300
2235 CONTINUE
2236 L(S) = Q
2237 S = T
2238 DO
2239 T = Q
2240 Q = L(Q)
2241.LE. IF (Q 0) EXIT
2242 END DO
2243 GOTO 800
2244 600 CONTINUE
2245 L(S) = sign(Q, L(S))
2246 S = Q
2247 Q = L(Q)
2248.GT. IF (Q 0) GOTO 300
2249 CONTINUE
2250 L(S) = P
2251 S = T
2252 DO
2253 T = P
2254 P = L(P)
2255.LE. IF (P 0) EXIT
2256 END DO
2257 800 CONTINUE
2258 P = -P
2259 Q = -Q
2260.EQ. IF(Q0) THEN
2261 L(S) = sign(P, L(S))
2262 L(T) = 0
2263 GOTO 200
2264 END IF
2265 GOTO 300
2266 END SUBROUTINE CMUMPS_MERGESORT
2267 FUNCTION MUMPS_GETSIZE(A)
2268 INTEGER, POINTER :: A(:)
2269 INTEGER :: MUMPS_GETSIZE
2270 IF(associated(A)) THEN
2271 MUMPS_GETSIZE = size(A)
2272 ELSE
2273 MUMPS_GETSIZE = 0_8
2274 END IF
2275 RETURN
2276 END FUNCTION MUMPS_GETSIZE
2277#if defined(parmetis) || defined(parmetis3)
2278 SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST,
2279 & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER,
2280 & SIZES, COMM, IERR)
2281 IMPLICIT NONE
2282 TYPE(CMUMPS_STRUC) :: id
2283 INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:)
2284 INTEGER :: SIZES(:), ORDER(:)
2285 INTEGER(8) :: VERTLOCTAB(:)
2286 INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE
2287 INTEGER, POINTER :: VERTLOCTAB_I4(:)
2288.GT. IF( VERTLOCTAB(VERTLOCNBR+1)huge(VERTLOCNBR)) THEN
2289 id%INFO(1) = -51
2290 CALL MUMPS_SET_IERROR(
2291 & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2))
2292 RETURN
2293 END IF
2294 nullify(VERTLOCTAB_I4)
2295 CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO,
2296 & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2297 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2298 & COMM, id%MYID )
2299.LT. IF ( id%INFO(1) 0 ) RETURN
2300 CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1),
2301 & VERTLOCNBR+1, VERTLOCTAB_I4(1))
2302 CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1),
2303 & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1),
2304 & SIZES(1), COMM, IERR)
2305.NE. IF(IERR0) THEN
2306 id%INFO(1:2) = -50
2307 END IF
2308 CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT)
2309 RETURN
2310 END SUBROUTINE MUMPS_PARMETIS_MIXEDto32
2311 SUBROUTINE MUMPS_PARMETIS_MIXEDto64
2312 & (id, BASE, VERTLOCNBR, FIRST,
2313 & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER,
2314 & SIZES, COMM, IERR)
2315 IMPLICIT NONE
2316 TYPE(CMUMPS_STRUC) :: id
2317 INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:)
2318 INTEGER :: SIZES(:), ORDER(:)
2319 INTEGER(8) :: VERTLOCTAB(:)
2320 INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE
2321 INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:),
2322 & SIZES_I8(:), ORDER_I8(:)
2323#if defined(parmetis)
2324 INTEGER(8), POINTER :: OPTIONS_I8(:)
2325 INTEGER(8) :: BASEVAL_I8
2326 nullify(OPTIONS_I8)
2327.NE. IF (id%KEEP(10)1) THEN
2328 CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO,
2329 & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2330.LT. IF ( id%INFO(1) 0 ) RETURN
2331 CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS)
2332 & , OPTIONS_I8(1))
2333 BASEVAL_I8 = int(BASEVAL,8)
2334 END IF
2335#endif
2336 nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8)
2337.EQ. IF (id%KEEP(10)1) THEN
2338 CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1),
2339 & EDGELOCTAB(1),
2340 & BASEVAL, OPTIONS(1),
2341 & ORDER(1),
2342 & SIZES(1), COMM, IERR)
2343 ELSE
2344 CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO,
2345 & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2346.LT. IF ( id%INFO(1) 0 ) GOTO 5
2347 CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8,
2348 & VERTLOCTAB(VERTLOCNBR+1)-1_8,
2349 & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2350.LT. IF ( id%INFO(1) 0 ) GOTO 5
2351 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO,
2352 & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2353.LT. IF ( id%INFO(1) 0 ) GOTO 5
2354 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO,
2355 & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2356.LT. IF ( id%INFO(1) 0 ) GOTO 5
2357 5 CONTINUE
2358 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2359 & COMM, id%MYID )
2360.LT. IF ( id%INFO(1) 0 ) RETURN
2361 CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1))
2362 CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1),
2363 & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1))
2364 CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1),
2365 & EDGELOCTAB_I8(1),
2366#if defined(parmetis3)
2367 & BASEVAL, OPTIONS(1),
2368#else
2369 & BASEVAL_I8, OPTIONS_I8(1),
2370#endif
2371 & ORDER_I8(1),
2372 & SIZES_I8(1), COMM, IERR)
2373 END IF
2374.NE. IF(IERR0) THEN
2375 id%INFO(1:2) = -50
2376 END IF
2377 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2378 & COMM, id%MYID )
2379.LT. IF ( id%INFO(1) 0 ) GOTO 10
2380.NE. IF ( id%KEEP(10) 1 ) THEN
2381 CALL MUMPS_ICOPY_64TO32(ORDER_I8(1),
2382 & size(ORDER), ORDER(1))
2383 CALL MUMPS_ICOPY_64TO32(SIZES_I8(1),
2384 & size(SIZES), SIZES(1))
2385 ENDIF
2386 10 CONTINUE
2387 CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT)
2388 CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT)
2389 CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT)
2390 CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT)
2391#if defined(parmetis)
2392 CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT)
2393#endif
2394 RETURN
2395 END SUBROUTINE MUMPS_PARMETIS_MIXEDto64
2396#endif
2397#if defined(ptscotch)
2398 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord,
2399 & BASEVAL,
2400 & VERTLOCNBR, VERTLOCTAB,
2401 & EDGELOCNBR, EDGELOCTAB,
2402 & IERR)
2403 IMPLICIT NONE
2404 INCLUDE 'ptscotchf.h'
2405 TYPE(CMUMPS_STRUC) :: id
2406 TYPE(ORD_TYPE) :: ord
2407 INTEGER :: BASEVAL, VERTLOCNBR
2408 INTEGER(8) :: EDGELOCNBR
2409 INTEGER(8) :: VERTLOCTAB(:)
2410 INTEGER :: EDGELOCTAB(:)
2411 INTEGER :: IERR
2412 INTEGER, POINTER :: VERTLOCTAB_I4(:)
2413 INTEGER :: EDGELOCNBR_I4, MYWORKID
2414 DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM),
2415 & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM),
2416 & CORDEDAT(SCOTCH_ORDERDIM)
2417 CHARACTER STRSTRING*1024
2418 nullify(VERTLOCTAB_I4)
2419 CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP,
2420 & MEMCNT=MEMCNT, ERRCODE=-7)
2421 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2422 & ord%COMM_NODES, id%MYID )
2423.LT. IF ( id%INFO(1) 0 ) RETURN
2424 CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1),
2425 & VERTLOCNBR+1, VERTLOCTAB_I4(1))
2426 EDGELOCNBR_I4 = int(EDGELOCNBR)
2427.NE. IF(ord%SUBSTRAT 0) THEN
2428 STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'//
2429 & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'//
2430 & 'proc=1,seq=q{strat=m{type=h,vert=100,'//
2431 & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'//
2432 & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}'
2433 END IF
2434 IF(ord%IDO) THEN
2435 CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR)
2436 ELSE
2437 MYWORKID = -1
2438 END IF
2439 CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR)
2440.NE. IF(IERR0) THEN
2441 id%INFO(1:2) = -50
2442 END IF
2443 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2444 & ord%COMM_NODES, id%MYID )
2445.LT. IF ( id%INFO(1) 0 ) GOTO 10
2446 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR,
2447 & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2),
2448 & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4,
2449 & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1),
2450 & EDGELOCTAB(1), IERR)
2451.NE. IF(IERR0) THEN
2452 id%INFO(1:2) = -50
2453 END IF
2454 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2455 & ord%COMM_NODES, id%MYID )
2456.LT. IF ( id%INFO(1) 0 ) GOTO 10
2457 CALL SCOTCHFSTRATINIT(STRADAT, IERR)
2458.NE. IF(IERR0) THEN
2459 id%INFO(1:2) = -50
2460 END IF
2461 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2462 & ord%COMM_NODES, id%MYID )
2463.LT. IF ( id%INFO(1) 0 ) GOTO 10
2464.NE. IF(ord%SUBSTRAT 0) THEN
2465 CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR)
2466 END IF
2467.NE. IF(IERR0) THEN
2468 id%INFO(1:2) = -50
2469 END IF
2470 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2471 & ord%COMM_NODES, id%MYID )
2472.LT. IF ( id%INFO(1) 0 ) GOTO 10
2473 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR)
2474.NE. IF(IERR0) THEN
2475 id%INFO(1:2) = -50
2476 END IF
2477 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2478 & ord%COMM_NODES, id%MYID )
2479.LT. IF ( id%INFO(1) 0 ) GOTO 10
2480 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT,
2481 & IERR)
2482.NE. IF(IERR0) THEN
2483 id%INFO(1:2) = -50
2484 END IF
2485 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2486 & ord%COMM_NODES, id%MYID )
2487.LT. IF ( id%INFO(1) 0 ) GOTO 10
2488.EQ. IF(MYWORKID 0) THEN
2489 CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT,
2490 & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR,
2491 & ord%RANGTAB(1), ord%TREETAB(1), IERR)
2492.NE. IF(IERR0) THEN
2493 id%INFO(1:2) = -50
2494 END IF
2495 END IF
2496 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2497 & ord%COMM_NODES, id%MYID )
2498.LT. IF ( id%INFO(1) 0 ) GOTO 10
2499.EQ. IF(MYWORKID 0) THEN
2500 CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT,
2501 & CORDEDAT, IERR)
2502.NE. IF(IERR0) THEN
2503 id%INFO(1:2) = -50
2504 END IF
2505 ELSE
2506 CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT,
2507 & ORDEDAT, IERR)
2508.NE. IF(IERR0) THEN
2509 id%INFO(1:2) = -50
2510 END IF
2511 END IF
2512 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2513 & ord%COMM_NODES, id%MYID )
2514.LT. IF ( id%INFO(1) 0 ) GOTO 10
2515.EQ. IF(MYWORKID 0)
2516 & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT)
2517 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT)
2518 CALL SCOTCHFSTRATEXIT(STRADAT)
2519 CALL SCOTCHFDGRAPHEXIT(GRAPHDAT)
2520 10 CONTINUE
2521 CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT)
2522 RETURN
2523 END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32
2524 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord,
2525 & BASEVAL,
2526 & VERTLOCNBR, VERTLOCTAB,
2527 & EDGELOCNBR, EDGELOCTAB,
2528 & IERR)
2529 IMPLICIT NONE
2530 INCLUDE 'ptscotchf.h'
2531 TYPE(CMUMPS_STRUC) :: id
2532 TYPE(ORD_TYPE) :: ord
2533 INTEGER :: BASEVAL, VERTLOCNBR
2534 INTEGER(8) :: EDGELOCNBR
2535 INTEGER(8) :: VERTLOCTAB(:)
2536 INTEGER :: EDGELOCTAB(:)
2537 INTEGER :: IERR
2538 INTEGER :: MYWORKID
2539 DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM),
2540 & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM),
2541 & CORDEDAT(SCOTCH_ORDERDIM)
2542 CHARACTER STRSTRING*1024
2543 INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:),
2544 & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:)
2545 INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8
2546.NE. IF(ord%SUBSTRAT 0) THEN
2547 STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'//
2548 & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'//
2549 & 'proc=1,seq=q{strat=m{type=h,vert=100,'//
2550 & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'//
2551 & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}'
2552 END IF
2553 IF(ord%IDO) THEN
2554 CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR)
2555 ELSE
2556 MYWORKID = -1
2557 END IF
2558 nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8,
2559 & RANGTAB_I8, TREETAB_I8)
2560.NE. IF (id%KEEP(10)1) THEN
2561 CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8,
2562 & VERTLOCTAB(VERTLOCNBR+1)-1_8,
2563 & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2564.LT. IF ( id%INFO(1) 0 ) GOTO 5
2565.EQ. IF (MYWORKID 0) THEN
2566 CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB),
2567 & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2568.LT. IF ( id%INFO(1) 0 ) GOTO 5
2569 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB),
2570 & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2571.LT. IF ( id%INFO(1) 0 ) GOTO 5
2572 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB),
2573 & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2574.LT. IF ( id%INFO(1) 0 ) GOTO 5
2575 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB),
2576 & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7)
2577 END IF
2578 5 CONTINUE
2579 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2580 & ord%COMM_NODES, id%MYID )
2581.LT. IF ( id%INFO(1) 0 ) RETURN
2582 CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1),
2583 & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1))
2584 BASEVAL_I8 = int(BASEVAL,8)
2585 VERTLOCNBR_I8 = int(VERTLOCNBR,8)
2586 ENDIF
2587 CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR)
2588.NE. IF(IERR0) THEN
2589 id%INFO(1:2) = -50
2590 END IF
2591 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2592 & ord%COMM_NODES, id%MYID )
2593.LT. IF ( id%INFO(1) 0 ) GOTO 10
2594.NE. IF (id%KEEP(10)1) THEN
2595 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8,
2596 & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2),
2597 & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR,
2598 & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1),
2599 & EDGELOCTAB_I8(1), IERR)
2600 ELSE
2601 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR,
2602 & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2),
2603 & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR,
2604 & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1),
2605 & EDGELOCTAB(1), IERR)
2606 ENDIF
2607.NE. IF(IERR0) THEN
2608 id%INFO(1:2) = -50
2609 END IF
2610 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2611 & ord%COMM_NODES, id%MYID )
2612.LT. IF ( id%INFO(1) 0 ) GOTO 10
2613 CALL SCOTCHFSTRATINIT(STRADAT, IERR)
2614.NE. IF(IERR0) THEN
2615 id%INFO(1:2) = -50
2616 END IF
2617 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2618 & ord%COMM_NODES, id%MYID )
2619.LT. IF ( id%INFO(1) 0 ) GOTO 10
2620.NE. IF(ord%SUBSTRAT 0) THEN
2621 CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR)
2622 END IF
2623.NE. IF(IERR0) THEN
2624 id%INFO(1:2) = -50
2625 END IF
2626 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2627 & ord%COMM_NODES, id%MYID )
2628.LT. IF ( id%INFO(1) 0 ) GOTO 10
2629 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR)
2630.NE. IF(IERR0) THEN
2631 id%INFO(1:2) = -50
2632 END IF
2633 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2634 & ord%COMM_NODES, id%MYID )
2635.LT. IF ( id%INFO(1) 0 ) GOTO 10
2636 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT,
2637 & IERR)
2638.NE. IF(IERR0) THEN
2639 id%INFO(1:2) = -50
2640 END IF
2641 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2642 & ord%COMM_NODES, id%MYID )
2643.LT. IF ( id%INFO(1) 0 ) GOTO 10
2644.EQ. IF(MYWORKID 0) THEN
2645.NE. IF (id%KEEP(10)1) THEN
2646 CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT,
2647 & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1),
2648 & TREETAB_I8(1), IERR)
2649 ELSE
2650 CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT,
2651 & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR,
2652 & ord%RANGTAB(1),ord%TREETAB(1), IERR)
2653 ENDIF
2654.NE. IF(IERR0) THEN
2655 id%INFO(1:2) = -50
2656 END IF
2657 END IF
2658 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2659 & ord%COMM_NODES, id%MYID )
2660.LT. IF ( id%INFO(1) 0 ) GOTO 10
2661.EQ. IF(MYWORKID 0) THEN
2662 CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT,
2663 & CORDEDAT, IERR)
2664.NE. IF(IERR0) THEN
2665 id%INFO(1:2) = -50
2666 END IF
2667 ELSE
2668 CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT,
2669 & ORDEDAT, IERR)
2670.NE. IF(IERR0) THEN
2671 id%INFO(1:2) = -50
2672 END IF
2673 END IF
2674 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
2675 & ord%COMM_NODES, id%MYID )
2676.LT. IF ( id%INFO(1) 0 ) GOTO 10
2677 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT)
2678 CALL SCOTCHFSTRATEXIT(STRADAT)
2679 CALL SCOTCHFDGRAPHEXIT(GRAPHDAT)
2680 10 CONTINUE
2681.NE. IF (id%KEEP(10)1) THEN
2682 CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT)
2683.EQ. IF(MYWORKID 0) THEN
2684 CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT)
2685 CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1),
2686 & size(ord%PERMTAB), ord%PERMTAB(1))
2687 CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1),
2688 & size(ord%PERITAB), ord%PERITAB(1))
2689 CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1),
2690 & size(ord%TREETAB), ord%TREETAB(1))
2691 CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1),
2692 & size(ord%RANGTAB), ord%RANGTAB(1))
2693 ord%CBLKNBR = int(CBLKNBR_I8)
2694 CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT)
2695 CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT)
2696 CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT)
2697 CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT)
2698 END IF
2699 ENDIF
2700 RETURN
2701 END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64
2702#endif
2703 END MODULE
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mumps_symqamd_new
subroutine mumps_symqamd_new(job, thresh, ndense, n, iwlen, pe, pfree, len, iw, nv, elen, last, ncmpa, degree, head, next, w, perm, complem_list, size_complem_list, agg6)
Definition ana_AMDMF.F:20
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
cmumps_set_k821_surface
subroutine cmumps_set_k821_surface(keep821, keep2, keep48, keep50, nslaves)
Definition cana_aux.F:3554
cmumps_cutnodes
subroutine cmumps_cutnodes(n, frere, fils, nfsiz, sizeofblocks, lsizeofblocks, nsteps, nslaves, keep, keep8, splitroot, mp, ldiag, info1, info2)
Definition cana_aux.F:2919
cmumps_ana_m
subroutine cmumps_ana_m(ne, nd, nsteps, maxfr, maxelim, k50, sizefac_tot, maxnpiv, k5, k6, panel_size, k253)
Definition cana_aux.F:2780
cmumps_ana_lnew
subroutine cmumps_ana_lnew(n, ipe, nv, ips, ne, na, nfsiz, node, nsteps, fils, frere, nd, nemin, subord, keep60, keep20, keep38, namalg, namalgmax, cumul, keep50, icntl13, keep37, keep197, nslaves, allow_amalg_tiny_nodes, blkon, sizeofblocks, lsizeofblocks)
Definition cana_aux.F:2412
cmumps_parallel_analysis::cmumps_ana_f_par
Definition cana_aux_par.F:20
mumps_memory_mod::mumps_dealloc
Definition mumps_memory_mod.F:15
mumps_memory_mod::mumps_realloc
Definition mumps_memory_mod.F:18
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_reduce
subroutine mpi_reduce(sendbuf, recvbuf, cnt, datatype, op, root, comm, ierr)
Definition mpi.f:120
mpi_comm_split
subroutine mpi_comm_split(comm, color, key, comm2, ierr)
Definition mpi.f:272
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_barrier
subroutine mpi_barrier(comm, ierr)
Definition mpi.f:188
mpi_comm_size
subroutine mpi_comm_size(comm, size, ierr)
Definition mpi.f:263
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
mpi_gather
subroutine mpi_gather(sendbuf, cnt, datatype, recvbuf, reccnt, rectype, root, comm, ierr)
Definition mpi.f:56
mpi_comm_free
subroutine mpi_comm_free(comm, ierr)
Definition mpi.f:238
mpi_comm_rank
subroutine mpi_comm_rank(comm, rank, ierr)
Definition mpi.f:254
id
initmumps id
Definition multiplerhs_example.m:4
cmumps_parallel_analysis
Definition cana_aux_par.F:14
cmumps_parallel_analysis::cmumps_get_subtrees
subroutine cmumps_get_subtrees(ord, id)
Definition cana_aux_par.F:737
cmumps_parallel_analysis::cmumps_make_loc_idx
subroutine cmumps_make_loc_idx(id, topnodes, lperm, liperm, ord)
Definition cana_aux_par.F:1212
cmumps_parallel_analysis::cmumps_cnt_kids
integer function cmumps_cnt_kids(node, ord)
Definition cana_aux_par.F:714
cmumps_parallel_analysis::cmumps_stop_descent
logical function cmumps_stop_descent(id, ord, nactive, anode, rproc, alist, list, peakmem, nnodes, checkmem)
Definition cana_aux_par.F:635
cmumps_parallel_analysis::nrl
integer nrl
Definition cana_aux_par.F:49
cmumps_parallel_analysis::cmumps_mergesort
subroutine cmumps_mergesort(n, k, l)
Definition cana_aux_par.F:2201
cmumps_parallel_analysis::maxmem
integer(8) maxmem
Definition cana_aux_par.F:50
cmumps_parallel_analysis::mp
integer mp
Definition cana_aux_par.F:49
cmumps_parallel_analysis::prokg
logical prokg
Definition cana_aux_par.F:51
cmumps_parallel_analysis::cmumps_parsymfact
subroutine cmumps_parsymfact(id, ord, gpe, gnv, work)
Definition cana_aux_par.F:874
cmumps_parallel_analysis::cmumps_assemble_top_graph
subroutine cmumps_assemble_top_graph(id, nlocvars, lperm, top_graph, ncliques, lstvar, lvarpt, ipe, pe, leng, elen)
Definition cana_aux_par.F:1236
cmumps_parallel_analysis::cmumps_set_par_ord
subroutine cmumps_set_par_ord(id, ord)
Definition cana_aux_par.F:214
cmumps_parallel_analysis::cmumps_do_par_ord
subroutine cmumps_do_par_ord(id, ord, work)
Definition cana_aux_par.F:356
cmumps_parallel_analysis::lp
integer lp
Definition cana_aux_par.F:49
cmumps_parallel_analysis::cmumps_build_loc_graph
subroutine cmumps_build_loc_graph(id, ord, gsize, ipe, pe, leng, i_halo_map, top_graph, work)
Definition cana_aux_par.F:1590
cmumps_parallel_analysis::memcnt
integer(8) memcnt
Definition cana_aux_par.F:50
cmumps_parallel_analysis::mpg
integer mpg
Definition cana_aux_par.F:49
cmumps_parallel_analysis::toprows
integer toprows
Definition cana_aux_par.F:49
cmumps_parallel_analysis::cmumps_mergeswap
subroutine cmumps_mergeswap(n, l, a1, a2)
Definition cana_aux_par.F:2154
cmumps_parallel_analysis::lpok
logical lpok
Definition cana_aux_par.F:51
cmumps_parallel_analysis::prok
logical prok
Definition cana_aux_par.F:51
cmumps_struc_def
Definition cmumps_struc_def.F:14
mumps_ana_ord_wrappers
Definition ana_orderings_wrappers_m.F:19
mumps_memory_mod
Definition mumps_memory_mod.F:14
mumps_memory_mod::mumps_i8realloc
subroutine mumps_i8realloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:141
mumps_memory_mod::mumps_idealloc
subroutine mumps_idealloc(a1, a2, a3, a4, a5, a6, a7, memcnt)
Definition mumps_memory_mod.F:833
mumps_memory_mod::mumps_i8dealloc
subroutine mumps_i8dealloc(a1, a2, a3, a4, a5, a6, a7, memcnt)
Definition mumps_memory_mod.F:890
mumps_memory_mod::mumps_irealloc8
subroutine mumps_irealloc8(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:240
cmumps_parallel_analysis::arrpnt
Definition cana_aux_par.F:46
cmumps_parallel_analysis::graph_type
Definition cana_aux_par.F:40
cmumps_parallel_analysis::ord_type
Definition cana_aux_par.F:24
mumps_secfin
subroutine mumps_secfin(t)
Definition tools_common.F:277
mumps_secdeb
subroutine mumps_secdeb(t)
Definition tools_common.F:270
mumps_make1root
subroutine mumps_make1root(n, frere, fils, nfsiz, theroot)
Definition tools_common.F:32