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 SUBROUTINE ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, 14 & IRN_loc, JCN_loc, NZ_loc, 15 & IPARTVEC, ISZ, OSZ, 16 & IWRK, IWSZ) 17C 18 IMPLICIT NONE 19 EXTERNAL ZMUMPS_BUREDUCE 20 INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM 21 INTEGER(8), INTENT(IN) :: NZ_loc 22 INTEGER, INTENT(IN) :: IWSZ 23 INTEGER, INTENT(IN) :: ISZ, OSZ 24 INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) 25C OUTPUT 26C IPARTVEC(I) = proc number with largest number of entries 27C in row/col I 28 INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) 29C 30C INTERNAL WORKING ARRAY 31C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries 32C on my proc and in row/col I) for I=1,ISZ 33C (2*ISZ+1: 4*ISZ) is then set to 34C the processor with largest number of entries in its row/col 35C and its value (that is copied back into IPARTVEC(I) 36#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 37 INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) 38#else 39 INTEGER, INTENT(OUT) :: IWRK(IWSZ) 40#endif 41 INCLUDE 'mpif.h' 42C 43C LOCAL VARS 44 INTEGER I 45 INTEGER(8) :: I8 46 INTEGER OP, IERROR 47 INTEGER IR, IC 48C 49 IF(NUMPROCS.NE.1) THEN 50C CHECK done outsize 51C IF(IWSZ < 4*ISZ) THEN 52C CHECK ENDS 53 CALL MPI_OP_CREATE(ZMUMPS_BUREDUCE, .TRUE., OP, IERROR) 54C PERFORM THE REDUCTION 55#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 56 CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) 57#else 58 CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) 59#endif 60C WE FIRST ZERO OUT 61 DO I=1,ISZ 62 IWRK(2*I-1) = 0 63 IWRK(2*I) = MYID 64 ENDDO 65 DO I8=1_8,NZ_loc 66 IR = IRN_loc(I8) 67 IC = JCN_loc(I8) 68 IF((IR.GE.1).AND.(IR.LE.ISZ).AND. 69 & (IC.GE.1).AND.(IC.LE.OSZ)) THEN 70 IWRK(2*IR-1) = IWRK(2*IR-1) + 1 71 ENDIF 72 ENDDO 73 CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, 74 & MPI_2INTEGER, OP, COMM, IERROR) 75 DO I=1,ISZ 76 IPARTVEC(I) = IWRK(2*I+2*ISZ) 77 ENDDO 78C FREE THE OPERATOR 79 CALL MPI_OP_FREE(OP, IERROR) 80 ELSE 81 DO I=1,ISZ 82 IPARTVEC(I) = 0 83 ENDDO 84 ENDIF 85 RETURN 86 END SUBROUTINE ZMUMPS_CREATEPARTVEC 87C 88C SEPARATOR: Another function begins 89C 90C 91 SUBROUTINE ZMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, 92 & IRN_loc, JCN_loc, NZ_loc, 93 & ROWPARTVEC, COLPARTVEC, M, N, 94 & INUMMYR, 95 & INUMMYC, 96 & IWRK, IWSZ) 97 IMPLICIT NONE 98 INTEGER(8), INTENT(IN) :: NZ_loc 99 INTEGER, INTENT(IN) :: MYID, NUMPROCS, M, N, IWSZ 100 INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) 101C [ROW/COL]PARTVEC(I) holds proc number with largest number of entries 102C in row/col I 103 INTEGER, INTENT(IN) :: ROWPARTVEC(M) 104 INTEGER, INTENT(IN) :: COLPARTVEC(N) 105 INTEGER, INTENT(IN) :: COMM 106C 107C OUTPUT PARAMETERS 108C INUMMYR < M and INUMMYC < N (CPA or <= ??) 109C INUMMYR holds the number of rows allocated to me 110C or non empty on my proc 111C INUMMYC idem with columns 112 INTEGER INUMMYR, INUMMYC 113C 114C INTERNAL working array 115 INTEGER IWRK(IWSZ) 116C 117C Local variables 118 INTEGER I, IR, IC 119 INTEGER(8) :: I8 120C check done outsize 121C IF(IWSZ < M) THEN ERROR 122C IF(IWSZ < N) THEN ERROR 123 INUMMYR = 0 124 INUMMYC = 0 125C MARK MY ROWS. FIRST COUNT, 126C IF DYNAMIC MEMORY ALLOCATIOn WILL USED 127C INUMMYR first counts number of rows affected to me 128C (that will be centralized on MYID) 129 DO I=1,M 130 IWRK(I) = 0 131 IF(ROWPARTVEC(I).EQ.MYID) THEN 132 IWRK(I)=1 133 INUMMYR = INUMMYR + 1 134 ENDIF 135 ENDDO 136 DO I8=1_8,NZ_loc 137 IR = IRN_loc(I8) 138 IC = JCN_loc(I8) 139 IF((IR.GE.1).AND.(IR.LE.M).AND. 140 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 141 IF(IWRK(IR) .EQ. 0) THEN 142 IWRK(IR)= 1 143 INUMMYR = INUMMYR + 1 144 ENDIF 145 ENDIF 146 ENDDO 147C DO THE SMAME THING FOR COLS 148 DO I=1,N 149 IWRK(I) = 0 150 IF(COLPARTVEC(I).EQ.MYID) THEN 151 IWRK(I)= 1 152 INUMMYC = INUMMYC + 1 153 ENDIF 154 ENDDO 155 DO I8=1_8,NZ_loc 156 IC = JCN_loc(I8) 157 IR = IRN_loc(I8) 158 IF((IR.GE.1).AND.(IR.LE.M).AND. 159 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 160 IF(IWRK(IC) .EQ. 0) THEN 161 IWRK(IC)= 1 162 INUMMYC = INUMMYC + 1 163 ENDIF 164 ENDIF 165 ENDDO 166C 167 RETURN 168 END SUBROUTINE ZMUMPS_FINDNUMMYROWCOL 169 SUBROUTINE ZMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, 170 & IRN_loc, JCN_loc, NZ_loc, 171 & ROWPARTVEC, COLPARTVEC, M, N, 172 & MYROWINDICES, INUMMYR, 173 & MYCOLINDICES, INUMMYC, 174 & IWRK, IWSZ ) 175 IMPLICIT NONE 176 INTEGER(8) :: NZ_loc 177 INTEGER MYID, NUMPROCS, M, N 178 INTEGER INUMMYR, INUMMYC, IWSZ 179 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 180 INTEGER ROWPARTVEC(M) 181 INTEGER COLPARTVEC(N) 182 INTEGER MYROWINDICES(INUMMYR) 183 INTEGER MYCOLINDICES(INUMMYC) 184 INTEGER IWRK(IWSZ) 185 INTEGER COMM 186C 187 INTEGER I, IR, IC, ITMP, MAXMN 188 INTEGER(8) :: I8 189C 190 MAXMN = M 191 IF(N > MAXMN) MAXMN = N 192C check done outsize 193C IF(IWSZ < MAXMN) THEN ERROR 194C MARK MY ROWS. 195 DO I=1,M 196 IWRK(I) = 0 197 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 198 ENDDO 199 DO I8=1,NZ_loc 200 IR = IRN_loc(I8) 201 IC = JCN_loc(I8) 202 IF((IR.GE.1).AND.(IR.LE.M).AND. 203 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 204 IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 205 ENDIF 206 ENDDO 207C PUT MY ROWS INTO MYROWINDICES 208 ITMP = 1 209 DO I=1,M 210 IF(IWRK(I).EQ.1) THEN 211 MYROWINDICES(ITMP) = I 212 ITMP = ITMP + 1 213 ENDIF 214 ENDDO 215C 216C 217C DO THE SMAME THING FOR COLS 218 DO I=1,N 219 IWRK(I) = 0 220 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 221 ENDDO 222 DO I8=1,NZ_loc 223 IR = IRN_loc(I8) 224 IC = JCN_loc(I8) 225 IF((IR.GE.1).AND.(IR.LE.M).AND. 226 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 227 IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 228 ENDIF 229 ENDDO 230C PUT MY ROWS INTO MYROWINDICES 231 ITMP = 1 232 DO I=1,N 233 IF(IWRK(I).EQ.1) THEN 234 MYCOLINDICES(ITMP) = I 235 ITMP = ITMP + 1 236 ENDIF 237 ENDDO 238C 239 RETURN 240 END SUBROUTINE ZMUMPS_FILLMYROWCOLINDICES 241C 242C SEPARATOR: Another function begins 243C 244C 245 INTEGER FUNCTION ZMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) 246 IMPLICIT NONE 247 INTEGER DSZ, INDXSZ 248 DOUBLE PRECISION D(DSZ) 249 INTEGER INDX(INDXSZ) 250 DOUBLE PRECISION EPS 251C LOCAL VARS 252 INTEGER I, IID 253 DOUBLE PRECISION RONE 254 PARAMETER(RONE=1.0D0) 255 ZMUMPS_CHK1LOC = 1 256 DO I=1, INDXSZ 257 IID = INDX(I) 258 IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. 259 & ((RONE-EPS).LE.D(IID)) )) THEN 260 ZMUMPS_CHK1LOC = 0 261 ENDIF 262 ENDDO 263 RETURN 264 END FUNCTION ZMUMPS_CHK1LOC 265 INTEGER FUNCTION ZMUMPS_CHK1CONV(D, DSZ, EPS) 266 IMPLICIT NONE 267 INTEGER DSZ 268 DOUBLE PRECISION D(DSZ) 269 DOUBLE PRECISION EPS 270C LOCAL VARS 271 INTEGER I 272 DOUBLE PRECISION RONE 273 PARAMETER(RONE=1.0D0) 274 ZMUMPS_CHK1CONV = 1 275 DO I=1, DSZ 276 IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. 277 & ((RONE-EPS).LE.D(I)) )) THEN 278 ZMUMPS_CHK1CONV = 0 279 ENDIF 280 ENDDO 281 RETURN 282 END FUNCTION ZMUMPS_CHK1CONV 283C 284C SEPARATOR: Another function begins 285C 286 INTEGER FUNCTION ZMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, 287 & DC, N, INDXC, INDXCSZ, EPS, COMM) 288 IMPLICIT NONE 289 INCLUDE 'mpif.h' 290 INTEGER M, N, INDXRSZ, INDXCSZ 291 DOUBLE PRECISION DR(M), DC(N) 292 INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) 293 DOUBLE PRECISION EPS 294 INTEGER COMM 295 EXTERNAL ZMUMPS_CHK1LOC 296 INTEGER ZMUMPS_CHK1LOC 297 INTEGER GLORES, MYRESR, MYRESC, MYRES 298 INTEGER IERR 299 MYRESR = ZMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) 300 MYRESC = ZMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) 301 MYRES = MYRESR + MYRESC 302 CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, 303 & MPI_SUM, COMM, IERR) 304 ZMUMPS_CHKCONVGLO = GLORES 305 RETURN 306 END FUNCTION ZMUMPS_CHKCONVGLO 307C 308C SEPARATOR: Another function begins 309C 310 DOUBLE PRECISION FUNCTION ZMUMPS_ERRSCALOC(D, TMPD, DSZ, 311 & INDX, INDXSZ) 312C THE VAR D IS NOT USED IN COMPUTATIONS. 313C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F 314 IMPLICIT NONE 315 INTEGER DSZ, INDXSZ 316 DOUBLE PRECISION D(DSZ) 317 DOUBLE PRECISION TMPD(DSZ) 318 INTEGER INDX(INDXSZ) 319C LOCAL VARS 320 DOUBLE PRECISION RONE 321 PARAMETER(RONE=1.0D0) 322 INTEGER I, IIND 323 DOUBLE PRECISION ERRMAX 324 INTRINSIC abs 325 ERRMAX = -RONE 326 DO I=1,INDXSZ 327 IIND = INDX(I) 328 IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN 329 ERRMAX = abs(RONE-TMPD(IIND)) 330 ENDIF 331 ENDDO 332 ZMUMPS_ERRSCALOC = ERRMAX 333 RETURN 334 END FUNCTION ZMUMPS_ERRSCALOC 335 DOUBLE PRECISION FUNCTION ZMUMPS_ERRSCA1(D, TMPD, DSZ) 336 IMPLICIT NONE 337 INTEGER DSZ 338 DOUBLE PRECISION D(DSZ) 339 DOUBLE PRECISION TMPD(DSZ) 340C LOCAL VARS 341 DOUBLE PRECISION RONE 342 PARAMETER(RONE=1.0D0) 343 INTEGER I 344 DOUBLE PRECISION ERRMAX1 345 INTRINSIC abs 346 ERRMAX1 = -RONE 347 DO I=1,DSZ 348 IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN 349 ERRMAX1 = abs(RONE-TMPD(I)) 350 ENDIF 351 ENDDO 352 ZMUMPS_ERRSCA1 = ERRMAX1 353 RETURN 354 END FUNCTION ZMUMPS_ERRSCA1 355C 356C SEPARATOR: Another function begins 357C 358 SUBROUTINE ZMUMPS_UPDATESCALE(D, TMPD, DSZ, 359 & INDX, INDXSZ) 360 IMPLICIT NONE 361 INTEGER DSZ, INDXSZ 362 DOUBLE PRECISION D(DSZ) 363 DOUBLE PRECISION TMPD(DSZ) 364 INTEGER INDX(INDXSZ) 365 INTRINSIC sqrt 366C LOCAL VARS 367 INTEGER I, IIND 368 DOUBLE PRECISION RZERO 369 PARAMETER(RZERO=0.0D0) 370 DO I=1,INDXSZ 371 IIND = INDX(I) 372 IF (TMPD(IIND).NE.RZERO) D(IIND) = D(IIND)/sqrt(TMPD(IIND)) 373 ENDDO 374 RETURN 375 END SUBROUTINE ZMUMPS_UPDATESCALE 376 SUBROUTINE ZMUMPS_UPSCALE1(D, TMPD, DSZ) 377 IMPLICIT NONE 378 INTEGER DSZ 379 DOUBLE PRECISION D(DSZ) 380 DOUBLE PRECISION TMPD(DSZ) 381 INTRINSIC sqrt 382C LOCAL VARS 383 INTEGER I 384 DOUBLE PRECISION RZERO 385 PARAMETER(RZERO=0.0D0) 386 DO I=1,DSZ 387 IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) 388 ENDDO 389 RETURN 390 END SUBROUTINE ZMUMPS_UPSCALE1 391C 392C SEPARATOR: Another function begins 393C 394 SUBROUTINE ZMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL) 395 IMPLICIT NONE 396 INTEGER DSZ, INDXSZ 397 DOUBLE PRECISION D(DSZ) 398 INTEGER INDX(INDXSZ) 399 DOUBLE PRECISION VAL 400C LOCAL VARS 401 INTEGER I, IIND 402 DO I=1,INDXSZ 403 IIND = INDX(I) 404 D(IIND) = VAL 405 ENDDO 406 RETURN 407 END SUBROUTINE ZMUMPS_INITREALLST 408C 409C SEPARATOR: Another function begins 410C 411 SUBROUTINE ZMUMPS_INVLIST(D, DSZ, INDX, INDXSZ) 412 IMPLICIT NONE 413 INTEGER DSZ, INDXSZ 414 DOUBLE PRECISION D(DSZ) 415 INTEGER INDX(INDXSZ) 416C LOCALS 417 INTEGER I, IIND 418 DO I=1,INDXSZ 419 IIND = INDX(I) 420 D(IIND) = 1.0D0/D(IIND) 421 ENDDO 422 RETURN 423 END SUBROUTINE ZMUMPS_INVLIST 424C 425C SEPARATOR: Another function begins 426C 427 SUBROUTINE ZMUMPS_INITREAL(D, DSZ, VAL) 428 IMPLICIT NONE 429 INTEGER DSZ 430 DOUBLE PRECISION D(DSZ) 431 DOUBLE PRECISION VAL 432C LOCAL VARS 433 INTEGER I 434 DO I=1,DSZ 435 D(I) = VAL 436 ENDDO 437 RETURN 438 END SUBROUTINE ZMUMPS_INITREAL 439C 440C SEPARATOR: Another function begins 441C 442 SUBROUTINE ZMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ) 443 IMPLICIT NONE 444 INTEGER TMPSZ,INDXSZ 445 DOUBLE PRECISION TMPD(TMPSZ) 446 INTEGER INDX(INDXSZ) 447C LOCAL VAR 448 INTEGER I 449 DOUBLE PRECISION DZERO 450 PARAMETER(DZERO=0.0D0) 451 DO I=1,INDXSZ 452 TMPD(INDX(I)) = DZERO 453 ENDDO 454 RETURN 455 END SUBROUTINE ZMUMPS_ZEROOUT 456C 457C SEPARATOR: Another function begins 458C 459 SUBROUTINE ZMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) 460C 461C Like MPI_MINLOC operation (with ties broken sometimes with min 462C and sometimes with max) 463C The objective is find for each entry row/col 464C the processor with largest number of entries in its row/col 465C When 2 procs have the same number of entries in the row/col 466C then 467C if this number of entries is odd we take the proc with largest id 468C if this number of entries is even we take the proc with smallest id 469C 470 IMPLICIT NONE 471#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 472 INTEGER(4) :: LEN 473 INTEGER(4) :: INV(2*LEN) 474 INTEGER(4) :: INOUTV(2*LEN) 475 INTEGER(4) :: DTYPE 476#else 477 INTEGER :: LEN 478 INTEGER :: INV(2*LEN) 479 INTEGER :: INOUTV(2*LEN) 480 INTEGER :: DTYPE 481#endif 482 INTEGER I 483#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 484 INTEGER(4) DIN, DINOUT, PIN, PINOUT 485#else 486 INTEGER DIN, DINOUT, PIN, PINOUT 487#endif 488 DO I=1,2*LEN-1,2 489 DIN = INV(I) ! nb of entries in row/col 490 PIN = INV(I+1) ! proc number 491C DINOUT 492 DINOUT = INOUTV(I) 493 PINOUT = INOUTV(I+1) 494 IF (DINOUT < DIN) THEN 495 INOUTV(I) = DIN 496 INOUTV(I+1) = PIN 497 ELSE IF (DINOUT == DIN) THEN 498C --INOUTV(I) = DIN 499C --even number I take smallest Process number (pin) 500 IF ((mod(DINOUT,2).EQ.0).AND.(PIN<PINOUT)) THEN 501 INOUTV(I+1) = PIN 502 ELSE IF ((mod(DINOUT,2).EQ.1).AND.(PIN>PINOUT)) THEN 503C --odd number I take largest Process number (pin) 504 INOUTV(I+1) = PIN 505 ENDIF 506 ENDIF 507 ENDDO 508 RETURN 509 END SUBROUTINE ZMUMPS_BUREDUCE 510C 511C SEPARATOR: Another function begins 512C 513 SUBROUTINE ZMUMPS_IBUINIT(IW, IWSZ, IVAL) 514 IMPLICIT NONE 515 INTEGER IWSZ 516#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 517 INTEGER(4) IW(IWSZ) 518 INTEGER(4) IVAL 519#else 520 INTEGER IW(IWSZ) 521 INTEGER IVAL 522#endif 523 INTEGER I 524 DO I=1,IWSZ 525 IW(I)=IVAL 526 ENDDO 527 RETURN 528 END SUBROUTINE ZMUMPS_IBUINIT 529C 530C SEPARATOR: Another function begins 531C 532C 533C SEPARATOR: Another function begins 534C 535 SUBROUTINE ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, 536 & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, 537 & OSNDRCVNUM,OSNDRCVVOL, 538 & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) 539 IMPLICIT NONE 540 INTEGER(8), INTENT(IN) :: NZ_loc 541 INTEGER, INTENT(IN) :: IWRKSZ 542 INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ 543 INTEGER, INTENT(IN) :: COMM 544C When INDX holds row indices O(ther)INDX hold col indices 545 INTEGER, INTENT(IN) :: INDX(NZ_loc) 546 INTEGER, INTENT(IN) :: OINDX(NZ_loc) 547C On entry IPARTVEC(I) holds proc number with largest number of entries 548C in row/col I 549 INTEGER, INTENT(IN) :: IPARTVEC(ISZ) 550C 551C OUTPUT PARAMETERS 552C SNDSZ (IPROC+1) is set to the number of rows (or col) that 553C MYID will have to send to IPROC 554C RCVSZ(IPROC+1) is set to the nb of row/cols that 555C MYID will receive from IPROC 556 INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) 557 INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) 558C OSNDRCVNUM is set to the total number of procs 559C destination of messages from MYID (< NUMPROCS) 560C ISNDRCVNUM is set to the total number procs 561C that will send messages to MYID (< NUMPROCS) 562C ISNDRCVVOL is set to the total number of row/col that 563C MYID will have to send to other procs 564C (bounded by N) 565C OSNDRCVVOL is set to the total number of row/col that 566C MYID will have to send to other procs 567C (bounded by N) 568C Knowing that for each row the process with the largest 569C number of entries will centralize all indices then 570C ISNDRCVVOL and OSNDRCVVOL are bounded by N 571 INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM 572 INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL 573C 574C INTERNAL WORKING ARRAY 575 INTEGER IWRK(IWRKSZ) 576 INCLUDE 'mpif.h' 577C LOCAL VARS 578 INTEGER I 579 INTEGER(8) :: I8 580 INTEGER IIND, IIND2, PIND 581 INTEGER IERROR 582C check done outsize 583C IF(ISZ>IWRKSZ) THEN ERROR 584 DO I=1,NUMPROCS 585 SNDSZ(I) = 0 586 RCVSZ(I) = 0 587 ENDDO 588 DO I=1,IWRKSZ 589 IWRK(I) = 0 590 ENDDO 591C 592C set SNDSZ 593 DO I8=1,NZ_loc 594 IIND = INDX(I8) 595 IIND2 = OINDX(I8) 596 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. 597 & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN 598 PIND = IPARTVEC(IIND) 599 IF(PIND .NE. MYID) THEN 600C MYID will send row/col IIND to proc PIND 601C (PIND has the largest nb of entries in row/con IIND 602 IF(IWRK(IIND).EQ.0) THEN 603 IWRK(IIND) = 1 604 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 605 ENDIF 606 ENDIF 607 ENDIF 608 ENDDO 609C 610C use SNDSZ to set RCVSZ 611 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, 612 & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 613C 614C compute number of procs destinations of messages from MYID 615C number of row/col sent by MYID. 616 ISNDRCVNUM = 0 617 ISNDRCVVOL = 0 618 OSNDRCVNUM = 0 619 OSNDRCVVOL = 0 620 DO I=1, NUMPROCS 621 IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 622 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) 623 IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 624 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) 625 ENDDO 626 RETURN 627 END SUBROUTINE ZMUMPS_NUMVOLSNDRCV 628C 629C SEPARATOR: Another function begins 630C 631 SUBROUTINE ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, 632 & NZ_loc, INDX, OSZ, OINDX, 633 & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, 634 & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, 635 & SNDSZ, RCVSZ, IWRK, 636 & ISTATUS, REQUESTS, 637 & ITAGCOMM, COMM ) 638 IMPLICIT NONE 639 INCLUDE 'mpif.h' 640 INTEGER(8) :: NZ_loc 641 INTEGER ISNDVOL, OSNDVOL 642 INTEGER MYID, NUMPROCS, ISZ, OSZ 643C ISZ is either M or N 644 INTEGER INDX(NZ_loc) 645 INTEGER OINDX(NZ_loc) 646C INDX is either IRN_loc or JCN_col 647 INTEGER IPARTVEC(ISZ) 648C IPARTVEC is either rowpartvec or colpartvec 649 INTEGER :: ISNDRCVNUM 650 INTEGER INGHBPRCS(ISNDRCVNUM) 651 INTEGER ISNDRCVIA(NUMPROCS+1) 652 INTEGER ISNDRCVJA(ISNDVOL) 653 INTEGER OSNDRCVNUM 654 INTEGER ONGHBPRCS(OSNDRCVNUM) 655 INTEGER OSNDRCVIA(NUMPROCS+1) 656 INTEGER OSNDRCVJA(OSNDVOL) 657 INTEGER SNDSZ(NUMPROCS) 658 INTEGER RCVSZ(NUMPROCS) 659 INTEGER IWRK(ISZ) 660 INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) 661 INTEGER REQUESTS(ISNDRCVNUM) 662 INTEGER ITAGCOMM, COMM 663C LOCAL VARS 664 INTEGER I, IIND, IIND2, IPID, OFFS 665 INTEGER IWHERETO, POFFS, ITMP, IERROR 666 INTEGER(8) :: I8 667C COMPUATIONs START 668 DO I=1,ISZ 669 IWRK(I) = 0 670 ENDDO 671C INITIALIZE ONGHBPRCS using SNDSZ 672C INITIALIZE THE OSNDRCVIA using SNDSZ 673 OFFS = 1 674 POFFS = 1 675 DO I=1,NUMPROCS 676 OSNDRCVIA(I) = OFFS + SNDSZ(I) 677 IF(SNDSZ(I) > 0) THEN 678 ONGHBPRCS(POFFS)=I 679 POFFS = POFFS + 1 680 ENDIF 681 OFFS = OFFS + SNDSZ(I) 682 ENDDO 683 OSNDRCVIA(NUMPROCS+1) = OFFS 684C CHECK STARTS 685C check done outsize 686C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR 687C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) 688 DO I8=1,NZ_loc 689 IIND = INDX(I8) 690 IIND2 = OINDX(I8) 691 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. 692 & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN 693 IPID=IPARTVEC(IIND) 694 IF(IPID.NE.MYID) THEN 695 IF(IWRK(IIND).EQ.0) THEN 696 IWHERETO = OSNDRCVIA(IPID+1)-1 697 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 698 OSNDRCVJA(IWHERETO) = IIND 699 IWRK(IIND) = 1 700 ENDIF 701 ENDIF 702 ENDIF 703 ENDDO 704C FILLED UP, WHAT I WILL RECEIVE (My requests from others) 705C FILL UP ISNDRCVJA. It will be received to fill up 706 CALL MPI_BARRIER(COMM,IERROR) 707 OFFS = 1 708 POFFS = 1 709 ISNDRCVIA(1) = 1 710 DO I=2,NUMPROCS+1 711 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) 712 IF(RCVSZ(I-1) > 0) THEN 713 INGHBPRCS(POFFS)=I-1 714 POFFS = POFFS + 1 715 ENDIF 716 OFFS = OFFS + RCVSZ(I-1) 717 ENDDO 718 CALL MPI_BARRIER(COMM,IERROR) 719 DO I=1, ISNDRCVNUM 720 IPID = INGHBPRCS(I) 721 OFFS = ISNDRCVIA(IPID) 722 ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) 723 CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, 724 & ITAGCOMM, COMM, REQUESTS(I),IERROR) 725 ENDDO 726 DO I=1,OSNDRCVNUM 727 IPID = ONGHBPRCS(I) 728 OFFS = OSNDRCVIA(IPID) 729 ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) 730 CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, 731 & ITAGCOMM, COMM,IERROR) 732 ENDDO 733 IF(ISNDRCVNUM > 0) THEN 734 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 735 ENDIF 736 CALL MPI_BARRIER(COMM,IERROR) 737 RETURN 738 END SUBROUTINE ZMUMPS_SETUPCOMMS 739C 740C SEPARATOR: Another function begins 741C 742 SUBROUTINE ZMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, 743 & ISNDRCVNUM, INGHBPRCS, 744 & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, 745 & OSNDRCVNUM, ONGHBPRCS, 746 & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, 747 & ISTATUS, REQUESTS, 748 & COMM) 749 IMPLICIT NONE 750 INCLUDE 'mpif.h' 751 INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM 752 INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL 753 DOUBLE PRECISION TMPD(IDSZ) 754 INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) 755 INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) 756 DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) 757 INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) 758 DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) 759 INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) 760 INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) 761 INTEGER COMM, IERROR 762C LOCAL VARS 763 INTEGER I, PID, OFFS, SZ, J, JS, JE, IID 764 DO I=1,ISNDRCVNUM 765 PID = INGHBPRCS(I) 766 OFFS = ISNDRCVIA(PID) 767 SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) 768 CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, 769 & MPI_DOUBLE_PRECISION, PID-1, 770 & ITAGCOMM,COMM,REQUESTS(I), IERROR) 771 ENDDO 772 DO I=1,OSNDRCVNUM 773 PID = ONGHBPRCS(I) 774 OFFS = OSNDRCVIA(PID) 775 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 776 JS = OSNDRCVIA(PID) 777 JE = OSNDRCVIA(PID+1) - 1 778 DO J=JS, JE 779 IID = OSNDRCVJA(J) 780 OSNDRCVA(J) = TMPD(IID) 781 ENDDO 782 CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, 783 & ITAGCOMM, COMM, IERROR) 784 ENDDO 785 IF(ISNDRCVNUM > 0) THEN 786 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 787 ENDIF 788C FOLD INTO MY D 789 DO I=1,ISNDRCVNUM 790 PID = INGHBPRCS(I) 791 JS = ISNDRCVIA(PID) 792 JE = ISNDRCVIA(PID+1)-1 793 DO J=JS,JE 794 IID = ISNDRCVJA(J) 795 IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) 796 ENDDO 797 ENDDO 798C COMMUNICATE THE UPDATED ONES 799 DO I=1,OSNDRCVNUM 800 PID = ONGHBPRCS(I) 801 OFFS = OSNDRCVIA(PID) 802 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 803 CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, 804 & MPI_DOUBLE_PRECISION, PID-1, 805 & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) 806 ENDDO 807 DO I=1,ISNDRCVNUM 808 PID = INGHBPRCS(I) 809 OFFS = ISNDRCVIA(PID) 810 SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) 811 JS = ISNDRCVIA(PID) 812 JE = ISNDRCVIA(PID+1) -1 813 DO J=JS, JE 814 IID = ISNDRCVJA(J) 815 ISNDRCVA(J) = TMPD(IID) 816 ENDDO 817 CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, 818 & ITAGCOMM+1, COMM, IERROR) 819 ENDDO 820 IF(OSNDRCVNUM > 0) THEN 821 CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 822 ENDIF 823 DO I=1,OSNDRCVNUM 824 PID = ONGHBPRCS(I) 825 JS = OSNDRCVIA(PID) 826 JE = OSNDRCVIA(PID+1) - 1 827 DO J=JS,JE 828 IID = OSNDRCVJA(J) 829 TMPD(IID)=OSNDRCVA(J) 830 ENDDO 831 ENDDO 832 RETURN 833 END SUBROUTINE ZMUMPS_DOCOMMINF 834C 835C SEPARATOR: Another function begins 836C 837 SUBROUTINE ZMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, 838 & ISNDRCVNUM, INGHBPRCS, 839 & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, 840 & OSNDRCVNUM, ONGHBPRCS, 841 & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, 842 & ISTATUS, REQUESTS, 843 & COMM) 844 IMPLICIT NONE 845 INCLUDE 'mpif.h' 846 INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM 847 INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL 848 DOUBLE PRECISION TMPD(IDSZ) 849 INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) 850 INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) 851 DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) 852 INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) 853 DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) 854 INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) 855 INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) 856 INTEGER COMM, IERROR 857C LOCAL VARS 858 INTEGER I, PID, OFFS, SZ, J, JS, JE, IID 859 DO I=1,ISNDRCVNUM 860 PID = INGHBPRCS(I) 861 OFFS = ISNDRCVIA(PID) 862 SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) 863 CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, 864 & MPI_DOUBLE_PRECISION, PID-1, 865 & ITAGCOMM,COMM,REQUESTS(I), IERROR) 866 ENDDO 867 DO I=1,OSNDRCVNUM 868 PID = ONGHBPRCS(I) 869 OFFS = OSNDRCVIA(PID) 870 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 871 JS = OSNDRCVIA(PID) 872 JE = OSNDRCVIA(PID+1) - 1 873 DO J=JS, JE 874 IID = OSNDRCVJA(J) 875 OSNDRCVA(J) = TMPD(IID) 876 ENDDO 877 CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, 878 & ITAGCOMM, COMM, IERROR) 879 ENDDO 880 IF(ISNDRCVNUM > 0) THEN 881 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 882 ENDIF 883C FOLD INTO MY D 884 DO I=1,ISNDRCVNUM 885 PID = INGHBPRCS(I) 886 JS = ISNDRCVIA(PID) 887 JE = ISNDRCVIA(PID+1)-1 888 DO J=JS,JE 889 IID = ISNDRCVJA(J) 890 TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) 891 ENDDO 892 ENDDO 893C COMMUNICATE THE UPDATED ONES 894 DO I=1,OSNDRCVNUM 895 PID = ONGHBPRCS(I) 896 OFFS = OSNDRCVIA(PID) 897 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 898 CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, 899 & MPI_DOUBLE_PRECISION, PID-1, 900 & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) 901 ENDDO 902 DO I=1,ISNDRCVNUM 903 PID = INGHBPRCS(I) 904 OFFS = ISNDRCVIA(PID) 905 SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) 906 JS = ISNDRCVIA(PID) 907 JE = ISNDRCVIA(PID+1) -1 908 DO J=JS, JE 909 IID = ISNDRCVJA(J) 910 ISNDRCVA(J) = TMPD(IID) 911 ENDDO 912 CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, 913 & ITAGCOMM+1, COMM, IERROR) 914 ENDDO 915 IF(OSNDRCVNUM > 0) THEN 916 CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 917 ENDIF 918 DO I=1,OSNDRCVNUM 919 PID = ONGHBPRCS(I) 920 JS = OSNDRCVIA(PID) 921 JE = OSNDRCVIA(PID+1) - 1 922 DO J=JS,JE 923 IID = OSNDRCVJA(J) 924 TMPD(IID)=OSNDRCVA(J) 925 ENDDO 926 ENDDO 927 RETURN 928 END SUBROUTINE ZMUMPS_DOCOMM1N 929 SUBROUTINE ZMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, 930 & IRN_loc, JCN_loc, NZ_loc, 931 & IPARTVEC, ISZ, 932 & IWRK, IWSZ) 933 IMPLICIT NONE 934 EXTERNAL ZMUMPS_BUREDUCE 935 INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM 936 INTEGER(8) :: NZ_loc 937 INTEGER, INTENT(IN) :: ISZ, IWSZ 938 INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) 939C 940C OUTPUT 941C IPARTVEC(I) = proc number with largest number of entries 942C in row/col I 943 INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) 944C 945C INTERNAL WORKING ARRAY 946C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries 947C on my proc and in row/col I) for I=1,ISZ 948C (2*ISZ+1: 4*ISZ) is then set to 949C the processor with largest number of entries in its row/col 950C and its value (that is copied back into IPARTVEC(I) 951#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 952 INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) 953#else 954 INTEGER, INTENT(OUT) :: IWRK(IWSZ) 955#endif 956 INCLUDE 'mpif.h' 957C 958C LOCAL VARS 959 INTEGER I 960 INTEGER(8) :: I8 961 INTEGER OP, IERROR 962 INTEGER IR, IC 963C 964 IF(NUMPROCS.NE.1) THEN 965C CHECK done outsize 966C IF(IWSZ < 2*ISZ) THEN 967C CHECK ENDS 968 CALL MPI_OP_CREATE(ZMUMPS_BUREDUCE, .TRUE., OP, IERROR) 969C PERFORM THE REDUCTION 970#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 971 CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) 972#else 973 CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) 974#endif 975 DO I=1,ISZ 976 IWRK(2*I-1) = 0 977 IWRK(2*I) = MYID 978 ENDDO 979 DO I8=1_8,NZ_loc 980 IR = IRN_loc(I8) 981 IC = JCN_loc(I8) 982 IF((IR.GE.1).AND.(IR.LE.ISZ).AND. 983 & (IC.GE.1).AND.(IC.LE.ISZ)) THEN 984 IWRK(2*IR-1) = IWRK(2*IR-1) + 1 985 IWRK(2*IC-1) = IWRK(2*IC-1) + 1 986 ENDIF 987 ENDDO 988 CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, 989 & MPI_2INTEGER, OP, COMM, IERROR) 990 DO I=1,ISZ 991 IPARTVEC(I) = IWRK(2*I+2*ISZ) 992 ENDDO 993C FREE THE OPERATOR 994 CALL MPI_OP_FREE(OP, IERROR) 995 ELSE 996 DO I=1,ISZ 997 IPARTVEC(I) = 0 998 ENDDO 999 ENDIF 1000 RETURN 1001 END SUBROUTINE ZMUMPS_CREATEPARTVECSYM 1002 SUBROUTINE ZMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, 1003 & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, 1004 & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) 1005 IMPLICIT NONE 1006 INTEGER(8), INTENT(IN) :: NZ_loc 1007 INTEGER, INTENT(IN) :: IWRKSZ 1008 INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ 1009 INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) 1010 INTEGER, INTENT(IN) :: IPARTVEC(ISZ) 1011 INTEGER, INTENT(IN) :: COMM 1012C 1013C OUTPUT PARAMETERS 1014C SNDSZ (IPROC+1) is set to the number of rows (or col) that 1015C MYID will have to send to IPROC 1016C RCVSZ(IPROC+1) is set to the nb of row/cols that 1017C MYID will receive from IPROC 1018 INTEGER :: SNDSZ(NUMPROCS) 1019 INTEGER :: RCVSZ(NUMPROCS) 1020C OSNDRCVNUM is set to the total number of procs 1021C destination of messages from MYID (< NUMPROCS) 1022C ISNDRCVNUM is set to the total number procs 1023C that will send messages to MYID (< NUMPROCS) 1024C ISNDRCVVOL is set to the total number of row/col that 1025C MYID will have to send to other procs 1026C (bounded by N) 1027C OSNDRCVVOL is set to the total number of row/col that 1028C MYID will have to send to other procs 1029C (bounded by N) 1030C Knowing that for each row the process with the largest 1031C number of entries will centralize all indices then 1032C ISNDRCVVOL and OSNDRCVVOL are bounded by N 1033 INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL 1034 INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL 1035C 1036C INTERNAL WORKING ARRAY 1037 INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) 1038 INCLUDE 'mpif.h' 1039C LOCAL VARS 1040 INTEGER I 1041 INTEGER(8) :: I8 1042 INTEGER IIND, IIND2, PIND 1043 INTEGER IERROR 1044C check done outsize 1045C IF(ISZ>IWRKSZ) THEN ERROR 1046 DO I=1,NUMPROCS 1047 SNDSZ(I) = 0 1048 RCVSZ(I) = 0 1049 ENDDO 1050 DO I=1,IWRKSZ 1051 IWRK(I) = 0 1052 ENDDO 1053C 1054C set SNDSZ 1055 DO I8=1_8,NZ_loc 1056 IIND = INDX(I8) 1057 IIND2 = OINDX(I8) 1058 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) 1059 & .AND.(IIND2.LE.ISZ)) THEN 1060 PIND = IPARTVEC(IIND) 1061 IF(PIND .NE. MYID) THEN 1062C MYID will send row/col IIND to proc PIND 1063C (PIND has the largest nb of entries in row/con IIND 1064 IF(IWRK(IIND).EQ.0) THEN 1065 IWRK(IIND) = 1 1066 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 1067 ENDIF 1068 ENDIF 1069 IIND = OINDX(I8) 1070 PIND = IPARTVEC(IIND) 1071 IF(PIND .NE. MYID) THEN 1072 IF(IWRK(IIND).EQ.0) THEN 1073 IWRK(IIND) = 1 1074 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 1075 ENDIF 1076 ENDIF 1077 ENDIF 1078 ENDDO 1079C 1080C use SNDSZ to set RCVSZ 1081 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, 1082 & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 1083C 1084C compute number of procs destinations of messages from MYID 1085C number of row/col sent by MYID. 1086 ISNDRCVNUM = 0 1087 ISNDRCVVOL = 0 1088 OSNDRCVNUM = 0 1089 OSNDRCVVOL = 0 1090 DO I=1, NUMPROCS 1091 IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 1092 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) 1093 IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 1094 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) 1095 ENDDO 1096 RETURN 1097 END SUBROUTINE ZMUMPS_NUMVOLSNDRCVSYM 1098 SUBROUTINE ZMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, 1099 & IRN_loc, JCN_loc, NZ_loc, 1100 & PARTVEC, N, 1101 & INUMMYR, 1102 & IWRK, IWSZ) 1103 IMPLICIT NONE 1104 INTEGER MYID, NUMPROCS, N 1105 INTEGER(8) :: NZ_loc 1106 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 1107 INTEGER PARTVEC(N) 1108 INTEGER INUMMYR 1109 INTEGER IWSZ 1110 INTEGER IWRK(IWSZ) 1111 INTEGER COMM 1112C 1113 INTEGER I, IR, IC 1114 INTEGER(8) :: I8 1115C check done outsize 1116C IF(IWSZ < M) THEN ERROR 1117C IF(IWSZ < N) THEN ERROR 1118 INUMMYR = 0 1119C MARK MY ROWS. FIRST COUNT, 1120C IF DYNAMIC MEMORY ALLOCATIOn WILL USED 1121 DO I=1,N 1122 IWRK(I) = 0 1123 IF(PARTVEC(I).EQ.MYID) THEN 1124 IWRK(I)=1 1125 INUMMYR = INUMMYR + 1 1126 ENDIF 1127 ENDDO 1128 DO I8=1_8,NZ_loc 1129 IR = IRN_loc(I8) 1130 IC = JCN_loc(I8) 1131 IF((IR.GE.1).AND.(IR.LE.N).AND. 1132 & ((IC.GE.1).AND.(IC.LE.N))) THEN 1133 IF(IWRK(IR) .EQ. 0) THEN 1134 IWRK(IR)= 1 1135 INUMMYR = INUMMYR + 1 1136 ENDIF 1137 ENDIF 1138 IF((IR.GE.1).AND.(IR.LE.N).AND. 1139 & ((IC.GE.1).AND.(IC.LE.N))) THEN 1140 IF(IWRK(IC).EQ.0) THEN 1141 IWRK(IC)= 1 1142 INUMMYR = INUMMYR + 1 1143 ENDIF 1144 ENDIF 1145 ENDDO 1146C THE SMAME THING APPLIES FOR COLS 1147C No need to do anything 1148C 1149 RETURN 1150 END SUBROUTINE ZMUMPS_FINDNUMMYROWCOLSYM 1151 INTEGER FUNCTION ZMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, 1152 & EPS, COMM) 1153 IMPLICIT NONE 1154 INCLUDE 'mpif.h' 1155 INTEGER N, INDXRSZ 1156 DOUBLE PRECISION D(N) 1157 INTEGER INDXR(INDXRSZ) 1158 DOUBLE PRECISION EPS 1159 INTEGER COMM 1160 EXTERNAL ZMUMPS_CHK1LOC 1161 INTEGER ZMUMPS_CHK1LOC 1162 INTEGER GLORES, MYRESR, MYRES 1163 INTEGER IERR 1164 MYRESR = ZMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) 1165 MYRES = 2*MYRESR 1166 CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, 1167 & MPI_SUM, COMM, IERR) 1168 ZMUMPS_CHKCONVGLOSYM = GLORES 1169 RETURN 1170 END FUNCTION ZMUMPS_CHKCONVGLOSYM 1171 SUBROUTINE ZMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, 1172 & IRN_loc, JCN_loc, NZ_loc, 1173 & PARTVEC, N, 1174 & MYROWINDICES, INUMMYR, 1175 & IWRK, IWSZ ) 1176 IMPLICIT NONE 1177 INTEGER MYID, NUMPROCS, N 1178 INTEGER(8) :: NZ_loc 1179 INTEGER INUMMYR, IWSZ 1180 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 1181 INTEGER PARTVEC(N) 1182 INTEGER MYROWINDICES(INUMMYR) 1183 INTEGER IWRK(IWSZ) 1184 INTEGER COMM 1185C 1186 INTEGER I, IR, IC, ITMP, MAXMN 1187 INTEGER(8) :: I8 1188C 1189 MAXMN = N 1190C check done outsize 1191C IF(IWSZ < MAXMN) THEN ERROR 1192C MARK MY ROWS. 1193 DO I=1,N 1194 IWRK(I) = 0 1195 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 1196 ENDDO 1197 DO I8=1_8,NZ_loc 1198 IR = IRN_loc(I8) 1199 IC = JCN_loc(I8) 1200 IF((IR.GE.1).AND.(IR.LE.N).AND. 1201 & ((IC.GE.1).AND.(IC.LE.N))) THEN 1202 IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 1203 ENDIF 1204 IF((IR.GE.1).AND.(IR.LE.N).AND. 1205 & ((IC.GE.1).AND.(IC.LE.N))) THEN 1206 IF(IWRK(IC) .EQ.0) IWRK(IC)=1 1207 ENDIF 1208 ENDDO 1209C PUT MY ROWS INTO MYROWINDICES 1210 ITMP = 1 1211 DO I=1,N 1212 IF(IWRK(I).EQ.1) THEN 1213 MYROWINDICES(ITMP) = I 1214 ITMP = ITMP + 1 1215 ENDIF 1216 ENDDO 1217C 1218C 1219C THE SMAME THING APPLY TO COLS 1220C 1221 RETURN 1222 END SUBROUTINE ZMUMPS_FILLMYROWCOLINDICESSYM 1223 SUBROUTINE ZMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, 1224 & NZ_loc, INDX, OINDX, 1225 & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, 1226 & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, 1227 & SNDSZ, RCVSZ, IWRK, 1228 & ISTATUS, REQUESTS, 1229 & ITAGCOMM, COMM ) 1230 IMPLICIT NONE 1231 INCLUDE 'mpif.h' 1232 INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL 1233 INTEGER(8) :: NZ_loc 1234C ISZ is either M or N 1235 INTEGER INDX(NZ_loc), OINDX(NZ_loc) 1236C INDX is either IRN_loc or JCN_col 1237 INTEGER IPARTVEC(ISZ) 1238C IPARTVEC is either rowpartvec or colpartvec 1239 INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) 1240 INTEGER ISNDRCVIA(NUMPROCS+1) 1241 INTEGER ISNDRCVJA(ISNDVOL) 1242 INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) 1243 INTEGER OSNDRCVIA(NUMPROCS+1) 1244 INTEGER OSNDRCVJA(OSNDVOL) 1245 INTEGER SNDSZ(NUMPROCS) 1246 INTEGER RCVSZ(NUMPROCS) 1247 INTEGER IWRK(ISZ) 1248 INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) 1249 INTEGER REQUESTS(ISNDRCVNUM) 1250 INTEGER ITAGCOMM, COMM 1251C LOCAL VARS 1252 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR 1253 INTEGER(8) :: I8 1254C COMPUATIONs START 1255 DO I=1,ISZ 1256 IWRK(I) = 0 1257 ENDDO 1258C INITIALIZE ONGHBPRCS using SNDSZ 1259C INITIALIZE THE OSNDRCVIA using SNDSZ 1260 OFFS = 1 1261 POFFS = 1 1262 DO I=1,NUMPROCS 1263 OSNDRCVIA(I) = OFFS + SNDSZ(I) 1264 IF(SNDSZ(I) > 0) THEN 1265 ONGHBPRCS(POFFS)=I 1266 POFFS = POFFS + 1 1267 ENDIF 1268 OFFS = OFFS + SNDSZ(I) 1269 ENDDO 1270 OSNDRCVIA(NUMPROCS+1) = OFFS 1271C CHECK STARTS 1272C check done outsize 1273C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR 1274C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) 1275 DO I8=1_8,NZ_loc 1276 IIND=INDX(I8) 1277 IIND2 = OINDX(I8) 1278 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) 1279 & .AND.(IIND2.LE.ISZ)) THEN 1280 IPID=IPARTVEC(IIND) 1281 IF(IPID.NE.MYID) THEN 1282 IF(IWRK(IIND).EQ.0) THEN 1283 IWHERETO = OSNDRCVIA(IPID+1)-1 1284 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 1285 OSNDRCVJA(IWHERETO) = IIND 1286 IWRK(IIND) = 1 1287 ENDIF 1288 ENDIF 1289 IIND = OINDX(I8) 1290 IPID=IPARTVEC(IIND) 1291 IF(IPID.NE.MYID) THEN 1292 IF(IWRK(IIND).EQ.0) THEN 1293 IWHERETO = OSNDRCVIA(IPID+1)-1 1294 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 1295 OSNDRCVJA(IWHERETO) = IIND 1296 IWRK(IIND) = 1 1297 ENDIF 1298 ENDIF 1299 ENDIF 1300 ENDDO 1301C FILLED UP, WHAT I WILL RECEIVE (My requests from others) 1302C FILL UP ISNDRCVJA. It will be received to fill up 1303 CALL MPI_BARRIER(COMM,IERROR) 1304 OFFS = 1 1305 POFFS = 1 1306 ISNDRCVIA(1) = 1 1307 DO I=2,NUMPROCS+1 1308 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) 1309 IF(RCVSZ(I-1) > 0) THEN 1310 INGHBPRCS(POFFS)=I-1 1311 POFFS = POFFS + 1 1312 ENDIF 1313 OFFS = OFFS + RCVSZ(I-1) 1314 ENDDO 1315 CALL MPI_BARRIER(COMM,IERROR) 1316 DO I=1, ISNDRCVNUM 1317 IPID = INGHBPRCS(I) 1318 OFFS = ISNDRCVIA(IPID) 1319 ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) 1320 CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, 1321 & ITAGCOMM, COMM, REQUESTS(I),IERROR) 1322 ENDDO 1323 DO I=1,OSNDRCVNUM 1324 IPID = ONGHBPRCS(I) 1325 OFFS = OSNDRCVIA(IPID) 1326 ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) 1327 CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, 1328 & ITAGCOMM, COMM,IERROR) 1329 ENDDO 1330 IF(ISNDRCVNUM > 0) THEN 1331 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 1332 ENDIF 1333 CALL MPI_BARRIER(COMM,IERROR) 1334 RETURN 1335 END SUBROUTINE ZMUMPS_SETUPCOMMSSYM 1336