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 MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, THEROOT ) 14 IMPLICIT NONE 15 INTEGER, intent( in ) :: N 16 INTEGER, intent( in ) :: NFSIZ( N ) 17 INTEGER, intent( inout ) :: FRERE( N ), FILS( N ) 18 INTEGER, intent( out ) :: THEROOT 19 INTEGER INODE, IROOT, IFILS, IN, IROOTLAST, SIZE 20 IROOT = -9999 21 SIZE = 0 22 DO INODE = 1, N 23 IF ( FRERE( INODE ) .EQ. 0 ) THEN 24 IF ( NFSIZ( INODE ) .GT. SIZE ) THEN 25 SIZE = NFSIZ( INODE ) 26 IROOT = INODE 27 END IF 28 ENDIF 29 END DO 30 IN = IROOT 31 DO WHILE ( FILS( IN ) .GT. 0 ) 32 IN = FILS( IN ) 33 END DO 34 IROOTLAST = IN 35 IFILS = - FILS ( IN ) 36 DO INODE = 1, N 37 IF ( FRERE( INODE ) .eq. 0 .and. INODE .ne. IROOT ) THEN 38 IF ( IFILS .eq. 0 ) THEN 39 FILS( IROOTLAST ) = - INODE 40 FRERE( INODE ) = -IROOT 41 IFILS = INODE 42 ELSE 43 FRERE( INODE ) = -FILS( IROOTLAST ) 44 FILS( IROOTLAST ) = - INODE 45 END IF 46 END IF 47 END DO 48 THEROOT = IROOT 49 RETURN 50 END SUBROUTINE MUMPS_MAKE1ROOT 51 INTEGER FUNCTION MUMPS_TYPENODE(PROCINFO_INODE, SLAVEF) 52 IMPLICIT NONE 53 INTEGER SLAVEF 54 INTEGER PROCINFO_INODE, TPN 55 IF (PROCINFO_INODE <= SLAVEF ) THEN 56 MUMPS_TYPENODE = 1 57 ELSE 58 TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 59 IF ( TPN .LT. 1 ) TPN = 1 60 IF (TPN.EQ.4.OR.TPN.EQ.5.OR.TPN.EQ.6) TPN = 2 61 MUMPS_TYPENODE = TPN 62 END IF 63 RETURN 64 END FUNCTION MUMPS_TYPENODE 65 INTEGER FUNCTION MUMPS_PROCNODE(PROCINFO_INODE, SLAVEF) 66 IMPLICIT NONE 67 INTEGER SLAVEF 68 INTEGER PROCINFO_INODE 69 IF (SLAVEF == 1) THEN 70 MUMPS_PROCNODE = 0 71 ELSE 72 MUMPS_PROCNODE=mod(2*SLAVEF+PROCINFO_INODE-1,SLAVEF) 73 END IF 74 RETURN 75 END FUNCTION MUMPS_PROCNODE 76 INTEGER FUNCTION MUMPS_TYPESPLIT (PROCINFO_INODE, SLAVEF) 77 IMPLICIT NONE 78 INTEGER, intent(in) :: SLAVEF 79 INTEGER PROCINFO_INODE, TPN 80 IF (PROCINFO_INODE <= SLAVEF ) THEN 81 MUMPS_TYPESPLIT = 1 82 ELSE 83 TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 84 IF ( TPN .LT. 1 ) TPN = 1 85 MUMPS_TYPESPLIT = TPN 86 ENDIF 87 RETURN 88 END FUNCTION MUMPS_TYPESPLIT 89 LOGICAL FUNCTION MUMPS_ROOTSSARBR( PROCINFO_INODE, SLAVEF ) 90 IMPLICIT NONE 91 INTEGER SLAVEF 92 INTEGER TPN, PROCINFO_INODE 93 TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 94 MUMPS_ROOTSSARBR = ( TPN .eq. 0 ) 95 RETURN 96 END FUNCTION MUMPS_ROOTSSARBR 97 LOGICAL FUNCTION MUMPS_INSSARBR( PROCINFO_INODE, SLAVEF ) 98 IMPLICIT NONE 99 INTEGER SLAVEF 100 INTEGER TPN, PROCINFO_INODE 101 TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 102 MUMPS_INSSARBR = ( TPN .eq. -1 ) 103 RETURN 104 END FUNCTION MUMPS_INSSARBR 105 LOGICAL FUNCTION MUMPS_IN_OR_ROOT_SSARBR 106 & ( PROCINFO_INODE, SLAVEF ) 107 IMPLICIT NONE 108 INTEGER SLAVEF 109 INTEGER TPN, PROCINFO_INODE 110 TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 111 MUMPS_IN_OR_ROOT_SSARBR = 112 & ( TPN .eq. -1 .OR. TPN .eq. 0 ) 113 RETURN 114 END FUNCTION MUMPS_IN_OR_ROOT_SSARBR 115 LOGICAL FUNCTION MUMPS_I_AM_CANDIDATE( MYID, SLAVEF, INODE, 116 & NMB_PAR2, ISTEP_TO_INIV2 , K71, STEP, N, 117 & CANDIDATES, KEEP24 ) 118 IMPLICIT NONE 119 INTEGER MYID, SLAVEF, INODE, NMB_PAR2, KEEP24, I 120 INTEGER K71, N 121 INTEGER ISTEP_TO_INIV2 ( K71 ), STEP ( N ) 122 INTEGER CANDIDATES(SLAVEF+1, max(NMB_PAR2,1)) 123 INTEGER NCAND, POSINODE 124 MUMPS_I_AM_CANDIDATE = .FALSE. 125 IF (KEEP24 .eq. 0) RETURN 126 POSINODE = ISTEP_TO_INIV2 ( STEP (INODE) ) 127 NCAND = CANDIDATES( SLAVEF+1, POSINODE ) 128 DO I = 1, NCAND 129 IF (MYID .EQ. CANDIDATES( I, POSINODE )) 130 & MUMPS_I_AM_CANDIDATE = .TRUE. 131 END DO 132 RETURN 133 END FUNCTION MUMPS_I_AM_CANDIDATE 134 SUBROUTINE MUMPS_SECDEB(T) 135 DOUBLE PRECISION T 136 DOUBLE PRECISION MPI_WTIME 137 EXTERNAL MPI_WTIME 138 T=MPI_WTIME() 139 RETURN 140 END SUBROUTINE MUMPS_SECDEB 141 SUBROUTINE MUMPS_SECFIN(T) 142 DOUBLE PRECISION T 143 DOUBLE PRECISION MPI_WTIME 144 EXTERNAL MPI_WTIME 145 T=MPI_WTIME()-T 146 RETURN 147 END SUBROUTINE MUMPS_SECFIN 148 SUBROUTINE MUMPS_SORT_DOUBLES( N, VAL, ID ) 149 INTEGER N 150 INTEGER ID( N ) 151 DOUBLE PRECISION VAL( N ) 152 INTEGER I, ISWAP 153 DOUBLE PRECISION SWAP 154 LOGICAL DONE 155 DONE = .FALSE. 156 DO WHILE ( .NOT. DONE ) 157 DONE = .TRUE. 158 DO I = 1, N - 1 159 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN 160 DONE = .FALSE. 161 ISWAP = ID( I ) 162 ID ( I ) = ID ( I + 1 ) 163 ID ( I + 1 ) = ISWAP 164 SWAP = VAL( I ) 165 VAL( I ) = VAL( I + 1 ) 166 VAL( I + 1 ) = SWAP 167 END IF 168 END DO 169 END DO 170 RETURN 171 END SUBROUTINE MUMPS_SORT_DOUBLES 172 SUBROUTINE MUMPS_SORT_DOUBLES_DEC( N, VAL, ID ) 173 INTEGER N 174 INTEGER ID( N ) 175 DOUBLE PRECISION VAL( N ) 176 INTEGER I, ISWAP 177 DOUBLE PRECISION SWAP 178 LOGICAL DONE 179 DONE = .FALSE. 180 DO WHILE ( .NOT. DONE ) 181 DONE = .TRUE. 182 DO I = 1, N - 1 183 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN 184 DONE = .FALSE. 185 ISWAP = ID( I ) 186 ID ( I ) = ID ( I + 1 ) 187 ID ( I + 1 ) = ISWAP 188 SWAP = VAL( I ) 189 VAL( I ) = VAL( I + 1 ) 190 VAL( I + 1 ) = SWAP 191 END IF 192 END DO 193 END DO 194 RETURN 195 END SUBROUTINE MUMPS_SORT_DOUBLES_DEC 196#if defined (PESSL) 197 SUBROUTINE DESCINIT( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, 198 & LLD, INFO ) 199 INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB 200 INTEGER DESC( * ) 201 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, 202 & LLD_, MB_, M_, NB_, N_, RSRC_ 203# if defined(DESC8) 204 PARAMETER ( DLEN_ = 8, DTYPE_ = 1, 205 & CTXT_ = 7, M_ = 1, N_ = 2, MB_ = 3, NB_ = 4, 206 & RSRC_ = 5, CSRC_ = 6, LLD_ = 8 ) 207# else 208 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, 209 & CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, 210 & RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) 211# endif 212 INTEGER MYCOL, MYROW, NPCOL, NPROW 213 EXTERNAL blacs_gridinfo, PXERBLA 214 INTEGER NUMROC 215 EXTERNAL NUMROC 216 INTRINSIC max, min 217 CALL blacs_gridinfo( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 218 INFO = 0 219 IF( M.LT.0 ) THEN 220 INFO = -2 221 ELSE IF( N.LT.0 ) THEN 222 INFO = -3 223 ELSE IF( MB.LT.1 ) THEN 224 INFO = -4 225 ELSE IF( NB.LT.1 ) THEN 226 INFO = -5 227 ELSE IF( IRSRC.LT.0 .OR. IRSRC.GE.NPROW ) THEN 228 INFO = -6 229 ELSE IF( ICSRC.LT.0 .OR. ICSRC.GE.NPCOL ) THEN 230 INFO = -7 231 ELSE IF( NPROW.EQ.-1 ) THEN 232 INFO = -8 233 ELSE IF( LLD.LT.max( 1, numroc( M, MB, MYROW, IRSRC, 234 & NPROW ) ) ) THEN 235 INFO = -9 236 END IF 237 IF( INFO.NE.0 ) 238 & CALL PXERBLA( ICTXT, 'DESCINIT', -INFO ) 239# ifndef DESC8 240 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D 241# endif 242 DESC( M_ ) = max( 0, M ) 243 DESC( N_ ) = max( 0, N ) 244 DESC( MB_ ) = max( 1, MB ) 245 DESC( NB_ ) = max( 1, NB ) 246 DESC( RSRC_ ) = max( 0, min( IRSRC, NPROW-1 ) ) 247 DESC( CSRC_ ) = max( 0, min( ICSRC, NPCOL-1 ) ) 248 DESC( CTXT_ ) = ICTXT 249 DESC( LLD_ ) = max( LLD, max( 1, numroc( DESC( M_ ), DESC( MB_ ), 250 & MYROW, DESC( RSRC_ ), NPROW ) ) ) 251 RETURN 252 END SUBROUTINE DESCINIT 253 SUBROUTINE PXERBLA( ICTXT, SRNAME, INFO ) 254 INTEGER ICTXT, INFO 255 CHARACTER*(*) SRNAME 256 INTEGER MYCOL, MYROW, NPCOL, NPROW 257 EXTERNAL blacs_gridinfo 258 CALL blacs_gridinfo( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 259 WRITE( *, FMT = 9999 ) MYROW, MYCOL, SRNAME, INFO 260 9999 FORMAT( '{', I5, ',', I5, '}: On entry to ', A, 261 & ' parameter number', I4, ' had an illegal value' ) 262 END SUBROUTINE PXERBLA 263#endif 264 SUBROUTINE MUMPS_MEM_CENTRALIZE(MYID, COMM, INFO, INFOG, IRANK) 265 IMPLICIT NONE 266 INTEGER MYID, COMM, IRANK, INFO, INFOG(2) 267 INCLUDE 'mpif.h' 268 INTEGER IERR_MPI, MASTER 269#if defined(WORKAROUNDINTELILP64MPI2INTEGER) 270 INTEGER(4) :: TEMP1(2),TEMP2(2) 271#else 272 INTEGER :: TEMP1(2),TEMP2(2) 273#endif 274 PARAMETER( MASTER = 0 ) 275 CALL MPI_REDUCE( INFO, INFOG(1), 1, MPI_INTEGER, 276 & MPI_MAX, MASTER, COMM, IERR_MPI ) 277 CALL MPI_REDUCE( INFO, INFOG(2), 1, MPI_INTEGER, 278 & MPI_SUM, MASTER, COMM, IERR_MPI ) 279 TEMP1(1) = INFO 280 TEMP1(2) = MYID 281 CALL MPI_REDUCE( TEMP1, TEMP2, 1, MPI_2INTEGER, 282 & MPI_MAXLOC, MASTER, COMM, IERR_MPI ) 283 IF ( MYID.eq. MASTER ) THEN 284 IF ( INFOG(1) .ne. TEMP2(1) ) THEN 285 write(*,*) 'Error in MUMPS_MEM_CENTRALIZE' 286 CALL MUMPS_ABORT() 287 END IF 288 IRANK = TEMP2(2) 289 ELSE 290 IRANK = -1 291 END IF 292 RETURN 293 END SUBROUTINE MUMPS_MEM_CENTRALIZE 294 INTEGER FUNCTION MUMPS_GET_POOL_LENGTH 295 & (MAX_ACTIVE_NODES,KEEP,KEEP8) 296 IMPLICIT NONE 297 INTEGER MAX_ACTIVE_NODES 298 INTEGER KEEP(500) 299 INTEGER(8) KEEP8(150) 300 MUMPS_GET_POOL_LENGTH = MAX_ACTIVE_NODES + 1 + 3 301 RETURN 302 END FUNCTION MUMPS_GET_POOL_LENGTH 303 SUBROUTINE MUMPS_INIT_POOL_DIST(N, LEAF, 304 & MYID_NODES, 305 & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, 306 & PROCNODE_STEPS, IPOOL, LPOOL) 307 IMPLICIT NONE 308 INTEGER N, LEAF, MYID_NODES, 309 & SLAVEF, LPOOL, LNA 310 INTEGER KEEP(500) 311 INTEGER(8) KEEP8(150) 312 INTEGER STEP(N) 313 INTEGER PROCNODE_STEPS(KEEP(28)), NA(LNA), 314 & IPOOL(LPOOL) 315 INTEGER NBLEAF, INODE, I 316 INTEGER MUMPS_PROCNODE 317 EXTERNAL MUMPS_PROCNODE 318 NBLEAF = NA(1) 319 LEAF = 1 320 DO I = 1, NBLEAF 321 INODE = NA(I+2) 322 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 323 & .EQ.MYID_NODES) THEN 324 IPOOL(LEAF) = INODE 325 LEAF = LEAF + 1 326 ENDIF 327 ENDDO 328 RETURN 329 END SUBROUTINE MUMPS_INIT_POOL_DIST 330 SUBROUTINE MUMPS_INIT_NROOT_DIST(N, NBROOT, 331 & NROOT_LOC, MYID_NODES, 332 & SLAVEF, NA, LNA, KEEP, STEP, 333 & PROCNODE_STEPS) 334 INTEGER, INTENT( OUT ) :: NROOT_LOC 335 INTEGER, INTENT( OUT ) :: NBROOT 336 INTEGER, INTENT( IN ) :: KEEP( 500 ) 337 INTEGER, INTENT( IN ) :: SLAVEF 338 INTEGER, INTENT( IN ) :: N 339 INTEGER, INTENT( IN ) :: STEP(N) 340 INTEGER, INTENT( IN ) :: LNA 341 INTEGER, INTENT( IN ) :: NA(LNA) 342 INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28)) 343 INTEGER, INTENT( IN ) :: MYID_NODES 344 INTEGER MUMPS_PROCNODE 345 EXTERNAL MUMPS_PROCNODE 346 INTEGER :: INODE, I, NBLEAF 347 NBLEAF = NA(1) 348 NBROOT = NA(2) 349 NROOT_LOC = 0 350 DO I = 1, NBROOT 351 INODE = NA(I+2+NBLEAF) 352 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), 353 & SLAVEF).EQ.MYID_NODES) THEN 354 NROOT_LOC = NROOT_LOC + 1 355 END IF 356 ENDDO 357 RETURN 358 END SUBROUTINE MUMPS_INIT_NROOT_DIST 359 LOGICAL FUNCTION MUMPS_COMPARE_TAB(TAB1,TAB2,LEN1,LEN2) 360 IMPLICIT NONE 361 INTEGER LEN1 , LEN2 ,I 362 INTEGER TAB1(LEN1) 363 INTEGER TAB2(LEN2) 364 MUMPS_COMPARE_TAB=.FALSE. 365 IF(LEN1 .NE. LEN2) THEN 366 RETURN 367 ENDIF 368 DO I=1 , LEN1 369 IF(TAB1(I) .NE. TAB2(I)) THEN 370 RETURN 371 ENDIF 372 ENDDO 373 MUMPS_COMPARE_TAB=.TRUE. 374 RETURN 375 END FUNCTION MUMPS_COMPARE_TAB 376 SUBROUTINE MUMPS_SORT_INT( N, VAL, ID ) 377 INTEGER N 378 INTEGER ID( N ) 379 INTEGER VAL( N ) 380 INTEGER I, ISWAP 381 INTEGER SWAP 382 LOGICAL DONE 383 DONE = .FALSE. 384 DO WHILE ( .NOT. DONE ) 385 DONE = .TRUE. 386 DO I = 1, N - 1 387 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN 388 DONE = .FALSE. 389 ISWAP = ID( I ) 390 ID ( I ) = ID ( I + 1 ) 391 ID ( I + 1 ) = ISWAP 392 SWAP = VAL( I ) 393 VAL( I ) = VAL( I + 1 ) 394 VAL( I + 1 ) = SWAP 395 END IF 396 END DO 397 END DO 398 RETURN 399 END SUBROUTINE MUMPS_SORT_INT 400 SUBROUTINE MUMPS_SORT_INT_DEC( N, VAL, ID ) 401 INTEGER N 402 INTEGER ID( N ) 403 INTEGER VAL( N ) 404 INTEGER I, ISWAP 405 INTEGER SWAP 406 LOGICAL DONE 407 DONE = .FALSE. 408 DO WHILE ( .NOT. DONE ) 409 DONE = .TRUE. 410 DO I = 1, N - 1 411 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN 412 DONE = .FALSE. 413 ISWAP = ID( I ) 414 ID ( I ) = ID ( I + 1 ) 415 ID ( I + 1 ) = ISWAP 416 SWAP = VAL( I ) 417 VAL( I ) = VAL( I + 1 ) 418 VAL( I + 1 ) = SWAP 419 END IF 420 END DO 421 END DO 422 RETURN 423 END SUBROUTINE MUMPS_SORT_INT_DEC 424 SUBROUTINE MUMPS_ABORT() 425 IMPLICIT NONE 426 INCLUDE 'mpif.h' 427 INTEGER IERR, IERRCODE 428 IERRCODE = -99 429 CALL MPI_ABORT(MPI_COMM_WORLD, IERRCODE, IERR) 430 RETURN 431 END SUBROUTINE MUMPS_ABORT 432 SUBROUTINE MUMPS_GET_PERLU(KEEP12,ICNTL14, 433 & KEEP50,KEEP54,ICNTL6,ICNTL8) 434 IMPLICIT NONE 435 INTEGER, intent(out)::KEEP12 436 INTEGER, intent(in)::ICNTL14,KEEP50,KEEP54,ICNTL6,ICNTL8 437 KEEP12 = ICNTL14 438 IF(ICNTL6.EQ.0 .AND. ICNTL8.EQ.0) RETURN 439 IF ( (KEEP54.NE.0).AND. (KEEP50.NE.1) 440 & .AND. (KEEP12 .GT. 0) ) KEEP12= KEEP12+5 441 RETURN 442 END SUBROUTINE MUMPS_GET_PERLU 443 SUBROUTINE MUMPS_BCAST_I8( I8_VALUE, ROOT, MYID, COMM, IERR) 444 IMPLICIT NONE 445 INCLUDE 'mpif.h' 446 INTEGER ROOT, MYID, COMM, IERR 447 INTEGER(8) :: I8_VALUE 448 DOUBLE PRECISION :: DBLE_VALUE 449 IF (MYID .EQ. ROOT) THEN 450 DBLE_VALUE = dble(I8_VALUE) 451 ENDIF 452 CALL MPI_BCAST( DBLE_VALUE, 1, MPI_DOUBLE_PRECISION, 453 & ROOT, COMM, IERR ) 454 I8_VALUE = int( DBLE_VALUE,8) 455 RETURN 456 END SUBROUTINE MUMPS_BCAST_I8 457 SUBROUTINE MUMPS_REDUCEI8( IN, OUT, MPI_OP, ROOT, COMM) 458 IMPLICIT NONE 459 INCLUDE 'mpif.h' 460 INTEGER ROOT, COMM, MPI_OP 461 INTEGER(8) IN, OUT 462 INTEGER IERR 463 DOUBLE PRECISION DIN, DOUT 464 DIN =dble(IN) 465 DOUT=0.0D0 466 CALL MPI_REDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, 467 & MPI_OP, ROOT, COMM, IERR) 468 OUT=int(DOUT,kind=8) 469 RETURN 470 END SUBROUTINE MUMPS_REDUCEI8 471 SUBROUTINE MUMPS_ALLREDUCEI8( IN, OUT, MPI_OP, COMM) 472 IMPLICIT NONE 473 INCLUDE 'mpif.h' 474 INTEGER COMM, MPI_OP 475 INTEGER(8) IN, OUT 476 INTEGER IERR 477 DOUBLE PRECISION DIN, DOUT 478 DIN =dble(IN) 479 DOUT=0.0D0 480 CALL MPI_ALLREDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, 481 & MPI_OP, COMM, IERR) 482 OUT=int(DOUT,kind=8) 483 RETURN 484 END SUBROUTINE MUMPS_ALLREDUCEI8 485 SUBROUTINE MUMPS_SETI8TOI4(I8, I4) 486 IMPLICIT NONE 487 INTEGER , INTENT(OUT) :: I4 488 INTEGER(8), INTENT(IN) :: I8 489 IF ( I8 .GT. int(huge(I4),8) ) THEN 490 I4 = -int(I8/1000000_8,kind(I4)) 491 ELSE 492 I4 = int(I8,kind(I4)) 493 ENDIF 494 RETURN 495 END SUBROUTINE MUMPS_SETI8TOI4 496 SUBROUTINE MUMPS_ABORT_ON_OVERFLOW(I8, STRING) 497 IMPLICIT NONE 498 INTEGER(8), INTENT(IN) :: I8 499 CHARACTER(*), INTENT(IN) :: STRING 500 INTEGER I4 501 IF ( I8 .GT. int(huge(I4),8)) THEN 502 WRITE(*,*) STRING 503 CALL MUMPS_ABORT() 504 ENDIF 505 RETURN 506 END SUBROUTINE MUMPS_ABORT_ON_OVERFLOW 507 SUBROUTINE MUMPS_SET_IERROR( SIZE8, IERROR ) 508 INTEGER(8), INTENT(IN) :: SIZE8 509 INTEGER, INTENT(OUT) :: IERROR 510 CALL MUMPS_SETI8TOI4(SIZE8, IERROR) 511 RETURN 512 END SUBROUTINE MUMPS_SET_IERROR 513 SUBROUTINE MUMPS_STOREI8(I8, INT_ARRAY) 514 IMPLICIT NONE 515 INTEGER(8), intent(in) :: I8 516 INTEGER, intent(out) :: INT_ARRAY(2) 517 INTEGER(kind(0_4)) :: I32 518 INTEGER(8) :: IDIV, IPAR 519 PARAMETER (IPAR=int(huge(I32),8)) 520 PARAMETER (IDIV=IPAR+1_8) 521 IF ( I8 .LT. IDIV ) THEN 522 INT_ARRAY(1) = 0 523 INT_ARRAY(2) = int(I8) 524 ELSE 525 INT_ARRAY(1) = int(I8 / IDIV) 526 INT_ARRAY(2) = int(mod(I8,IDIV)) 527 ENDIF 528 RETURN 529 END SUBROUTINE MUMPS_STOREI8 530 SUBROUTINE MUMPS_GETI8(I8, INT_ARRAY) 531 IMPLICIT NONE 532 INTEGER(8), intent(out) :: I8 533 INTEGER, intent(in) :: INT_ARRAY(2) 534 INTEGER(kind(0_4)) :: I32 535 INTEGER(8) :: IDIV, IPAR 536 PARAMETER (IPAR=int(huge(I32),8)) 537 PARAMETER (IDIV=IPAR+1_8) 538 IF ( INT_ARRAY(1) .EQ. 0 ) THEN 539 I8=int(INT_ARRAY(2),8) 540 ELSE 541 I8=int(INT_ARRAY(1),8)*IDIV+int(INT_ARRAY(2),8) 542 ENDIF 543 RETURN 544 END SUBROUTINE MUMPS_GETI8 545 SUBROUTINE MUMPS_ADDI8TOARRAY( INT_ARRAY, I8 ) 546 IMPLICIT NONE 547 INTEGER(8), intent(in) :: I8 548 INTEGER, intent(inout) :: INT_ARRAY(2) 549 INTEGER(8) :: I8TMP 550 CALL MUMPS_GETI8(I8TMP, INT_ARRAY) 551 I8TMP = I8TMP + I8 552 CALL MUMPS_STOREI8(I8TMP, INT_ARRAY) 553 RETURN 554 END SUBROUTINE MUMPS_ADDI8TOARRAY 555 SUBROUTINE MUMPS_SUBTRI8TOARRAY( INT_ARRAY, I8 ) 556 IMPLICIT NONE 557 INTEGER(8), intent(in) :: I8 558 INTEGER, intent(inout) :: INT_ARRAY(2) 559 INTEGER(8) :: I8TMP 560 CALL MUMPS_GETI8(I8TMP, INT_ARRAY) 561 I8TMP = I8TMP - I8 562 CALL MUMPS_STOREI8(I8TMP, INT_ARRAY) 563 RETURN 564 END SUBROUTINE MUMPS_SUBTRI8TOARRAY 565 FUNCTION MUMPS_SEQANA_AVAIL(ICNTL7) 566 LOGICAL :: MUMPS_SEQANA_AVAIL 567 INTEGER, INTENT(IN) :: ICNTL7 568 LOGICAL :: SCOTCH=.FALSE. 569 LOGICAL :: METIS =.FALSE. 570#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) 571 METIS = .TRUE. 572#endif 573#if defined(scotch) || defined(ptscotch) 574 SCOTCH = .TRUE. 575#endif 576 IF ( ICNTL7 .LT. 0 .OR. ICNTL7 .GT. 7 ) THEN 577 MUMPS_SEQANA_AVAIL = .FALSE. 578 ELSE 579 MUMPS_SEQANA_AVAIL = .TRUE. 580 ENDIF 581 IF ( ICNTL7 .EQ. 5 ) MUMPS_SEQANA_AVAIL = METIS 582 IF ( ICNTL7 .EQ. 3 ) MUMPS_SEQANA_AVAIL = SCOTCH 583 RETURN 584 END FUNCTION MUMPS_SEQANA_AVAIL 585 FUNCTION MUMPS_PARANA_AVAIL(WHICH) 586 LOGICAL :: MUMPS_PARANA_AVAIL 587 CHARACTER :: WHICH*(*) 588 LOGICAL :: PTSCOTCH=.FALSE., PARMETIS=.FALSE. 589#if defined(ptscotch) 590 PTSCOTCH = .TRUE. 591#endif 592#if defined(parmetis) || defined(parmetis3) 593 PARMETIS = .TRUE. 594#endif 595 SELECT CASE(WHICH) 596 CASE('ptscotch','PTSCOTCH') 597 MUMPS_PARANA_AVAIL = PTSCOTCH 598 CASE('parmetis','PARMETIS') 599 MUMPS_PARANA_AVAIL = PARMETIS 600 CASE('both','BOTH') 601 MUMPS_PARANA_AVAIL = PTSCOTCH .AND. PARMETIS 602 CASE('any','ANY') 603 MUMPS_PARANA_AVAIL = PTSCOTCH .OR. PARMETIS 604 CASE default 605 write(*,'("Invalid input in MUMPS_PARANA_AVAIL")') 606 END SELECT 607 RETURN 608 END FUNCTION MUMPS_PARANA_AVAIL 609 SUBROUTINE MUMPS_SORT_STEP(N,FRERE,STEP,FILS, 610 & NA,LNA,NE,ND,DAD,LDAD,USE_DAD, 611 & NSTEPS,INFO,LP, 612 & PROCNODE,SLAVEF 613 & ) 614 IMPLICIT NONE 615 INTEGER N, NSTEPS, LNA, LP,LDAD 616 INTEGER FRERE(NSTEPS), FILS(N), STEP(N) 617 INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) 618 INTEGER DAD(LDAD) 619 LOGICAL USE_DAD 620 INTEGER INFO(40) 621 INTEGER SLAVEF,PROCNODE(NSTEPS) 622 INTEGER POSTORDER,TMP_SWAP 623 INTEGER, DIMENSION (:), ALLOCATABLE :: STEP_TO_NODE 624 INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK 625 INTEGER I,II,allocok 626 INTEGER NBLEAF,NBROOT,LEAF,IN,INODE,IFATH 627 EXTERNAL MUMPS_TYPENODE 628 INTEGER MUMPS_TYPENODE 629 POSTORDER=1 630 NBLEAF = NA(1) 631 NBROOT = NA(2) 632 ALLOCATE( IPOOL(NBLEAF), TNSTK(NSTEPS), stat=allocok ) 633 IF (allocok > 0) THEN 634 IF ( LP .GT. 0 ) 635 & WRITE(LP,*)'Memory allocation error in CMUMPS_SORT_STEP' 636 INFO(1)=-7 637 INFO(2)=NSTEPS 638 RETURN 639 ENDIF 640 DO I=1,NSTEPS 641 TNSTK(I) = NE(I) 642 ENDDO 643 ALLOCATE(STEP_TO_NODE(NSTEPS),stat=allocok) 644 IF (allocok > 0) THEN 645 IF ( LP .GT. 0 ) 646 & WRITE(LP,*)'Memory allocation error in 647 &CMUMPS_REORDER_TREE' 648 INFO(1)=-7 649 INFO(2)=NSTEPS 650 RETURN 651 ENDIF 652 DO I=1,N 653 IF(STEP(I).GT.0)THEN 654 STEP_TO_NODE(STEP(I))=I 655 ENDIF 656 ENDDO 657 IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) 658 LEAF = NBLEAF + 1 659 91 CONTINUE 660 IF (LEAF.NE.1) THEN 661 LEAF = LEAF -1 662 INODE = IPOOL(LEAF) 663 ENDIF 664 96 CONTINUE 665 IF (USE_DAD) THEN 666 IFATH = DAD( STEP(INODE) ) 667 ELSE 668 IN = INODE 669 113 IN = FRERE(IN) 670 IF (IN.GT.0) GO TO 113 671 IFATH = -IN 672 ENDIF 673 TMP_SWAP=FRERE(STEP(INODE)) 674 FRERE(STEP(INODE))=FRERE(POSTORDER) 675 FRERE(POSTORDER)=TMP_SWAP 676 TMP_SWAP=ND(STEP(INODE)) 677 ND(STEP(INODE))=ND(POSTORDER) 678 ND(POSTORDER)=TMP_SWAP 679 TMP_SWAP=NE(STEP(INODE)) 680 NE(STEP(INODE))=NE(POSTORDER) 681 NE(POSTORDER)=TMP_SWAP 682 TMP_SWAP=PROCNODE(STEP(INODE)) 683 PROCNODE(STEP(INODE))=PROCNODE(POSTORDER) 684 PROCNODE(POSTORDER)=TMP_SWAP 685 IF(USE_DAD)THEN 686 TMP_SWAP=DAD(STEP(INODE)) 687 DAD(STEP(INODE))=DAD(POSTORDER) 688 DAD(POSTORDER)=TMP_SWAP 689 ENDIF 690 TMP_SWAP=TNSTK(STEP(INODE)) 691 TNSTK(STEP(INODE))=TNSTK(POSTORDER) 692 TNSTK(POSTORDER)=TMP_SWAP 693 II=STEP_TO_NODE(POSTORDER) 694 TMP_SWAP=STEP(INODE) 695 STEP(STEP_TO_NODE(POSTORDER))=TMP_SWAP 696 STEP(INODE)=POSTORDER 697 STEP_TO_NODE(POSTORDER)=INODE 698 STEP_TO_NODE(TMP_SWAP)=II 699 IN=II 700 101 IN = FILS(IN) 701 IF (IN .GT. 0 ) THEN 702 STEP(IN)=-STEP(II) 703 GOTO 101 704 ENDIF 705 IN=INODE 706 102 IN = FILS(IN) 707 IF (IN .GT. 0 ) THEN 708 STEP(IN)=-STEP(INODE) 709 GOTO 102 710 ENDIF 711 POSTORDER = POSTORDER + 1 712 IF (IFATH.EQ.0) THEN 713 NBROOT = NBROOT - 1 714 IF (NBROOT.EQ.0) GOTO 116 715 GOTO 91 716 ENDIF 717 TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 718 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN 719 INODE = IFATH 720 GOTO 96 721 ELSE 722 GOTO 91 723 ENDIF 724 116 CONTINUE 725 DEALLOCATE(STEP_TO_NODE) 726 DEALLOCATE(IPOOL,TNSTK) 727 RETURN 728 END SUBROUTINE MUMPS_SORT_STEP 729#if ! defined(NO_XXNBPR) 730 SUBROUTINE CHECK_EQUAL(NBPR, IWNBPR) 731 IMPLICIT NONE 732 INTEGER, intent(in) :: NBPR, IWNBPR 733 IF (NBPR .NE. IWNBPR) THEN 734 WRITE(*,*) " NBPROCFILS(...), IW(..+XXNBPR_ = ", NBPR, IWNBPR 735#if ! defined(IBC_TEST) 736 CALL MUMPS_ABORT() 737#endif 738 ENDIF 739 RETURN 740 END SUBROUTINE CHECK_EQUAL 741#endif 742 SUBROUTINE MUMPS_GET_PROC_PER_NODE(K414, MyID, NbProcs, COMM) 743 IMPLICIT NONE 744 INCLUDE 'mpif.h' 745 INTEGER :: K414, MyID, NbProcs, COMM, ALLOCOK 746 INTEGER :: ierr,MyNAME_length,MyNAME_length_RCV,i,j 747 CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MyNAME 748 CHARACTER, dimension(:), allocatable :: MyNAME_TAB,MyName_TAB_RCV 749 logical :: SAME_NAME 750 call MPI_GET_PROCESSOR_NAME(MyNAME, MyNAME_length, ierr) 751 allocate(MyName_TAB(MyNAME_length), STAT=ALLOCOK) 752 IF(ALLOCOK.LT.0) THEN 753 write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE" 754 call MUMPS_ABORT() 755 ENDIF 756 DO i=1, MyNAME_length 757 MyNAME_TAB(i) = MyNAME(i:i) 758 ENDDO 759 K414=0 760 do i=0, NbProcs-1 761 if(MyID .eq. i) then 762 MyNAME_length_RCV = MyNAME_length 763 else 764 MyNAME_length_RCV = 0 765 endif 766 call MPI_BCAST(MyNAME_length_RCV,1,MPI_INTEGER, 767 & i,COMM,ierr) 768 allocate(MyNAME_TAB_RCV(MyNAME_length_RCV), STAT=ALLOCOK) 769 IF(ALLOCOK.LT.0) THEN 770 write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE" 771 call MUMPS_ABORT() 772 ENDIF 773 if(MyID .eq. i) then 774 MyNAME_TAB_RCV = MyNAME_TAB 775 endif 776 call MPI_BCAST(MyNAME_TAB_RCV,MyNAME_length_RCV,MPI_CHARACTER, 777 & i,COMM,ierr) 778 SAME_NAME=.FALSE. 779 IF(MyNAME_length .EQ. MyNAME_length_RCV) THEN 780 DO J=1, MyNAME_length 781 IF(MyNAME_TAB(J) .NE. MyNAME_TAB_RCV(J)) THEN 782 goto 100 783 ENDIF 784 ENDDO 785 SAME_NAME=.TRUE. 786 ENDIF 787 100 continue 788 IF(SAME_NAME) k414=k414+1 789 deallocate(MyName_TAB_RCV) 790 enddo 791 deallocate(MyName_TAB) 792 END SUBROUTINE MUMPS_GET_PROC_PER_NODE 793 SUBROUTINE MUMPS_COPY_INT_32TO64 (INTAB, SIZETAB, OUTTAB8) 794 INTEGER, intent(in) :: SIZETAB 795 INTEGER, intent(in) :: INTAB(SIZETAB) 796 INTEGER(8), intent(out) :: OUTTAB8(SIZETAB) 797 INTEGER :: I 798 DO I=1,SIZETAB 799 OUTTAB8(I) = int(INTAB(I),8) 800 ENDDO 801 RETURN 802 END SUBROUTINE MUMPS_COPY_INT_32TO64 803 SUBROUTINE MUMPS_COPY_INT_32TO64_64C(INTAB, SIZETAB8, OUTTAB8) 804 INTEGER(8), intent(in) :: SIZETAB8 805 INTEGER, intent(in) :: INTAB(SIZETAB8) 806 INTEGER(8), intent(out) :: OUTTAB8(SIZETAB8) 807 INTEGER(8) :: I8 808 LOGICAL :: OMP_FLAG 809 OMP_FLAG = (SIZETAB8 .GE.500000_8 ) 810!$OMP PARALLEL DO PRIVATE(I8) 811!$OMP& IF(OMP_FLAG) 812 DO I8=1_8, SIZETAB8 813 OUTTAB8(I8) = int(INTAB(I8),8) 814 ENDDO 815!$OMP END PARALLEL DO 816 RETURN 817 END SUBROUTINE MUMPS_COPY_INT_32TO64_64C 818 SUBROUTINE MUMPS_COPY_INT_64TO32 (INTAB8, SIZETAB, OUTTAB) 819 INTEGER, intent(in) :: SIZETAB 820 INTEGER(8), intent(in) :: INTAB8(SIZETAB) 821 INTEGER, intent(out) :: OUTTAB(SIZETAB) 822 INTEGER :: I 823 DO I=1,SIZETAB 824 OUTTAB(I) = int(INTAB8(I)) 825 ENDDO 826 RETURN 827 END SUBROUTINE MUMPS_COPY_INT_64TO32 828 SUBROUTINE MUMPS_GET_NNZ_INTERNAL( NNZ, NZ, NNZ_i ) 829 INTEGER , INTENT(IN) :: NZ 830 INTEGER(8), INTENT(IN) :: NNZ 831 INTEGER(8), INTENT(OUT) :: NNZ_i 832 IF (NNZ > 0_8) THEN 833 NNZ_i = NNZ 834 ELSE 835 NNZ_i = int(NZ, 8) 836 ENDIF 837 END SUBROUTINE MUMPS_GET_NNZ_INTERNAL 838