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