1C 2C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 3C 4C 5C This version of MUMPS is provided to you free of charge. It is public 6C domain, based on public domain software developed during the Esprit IV 7C European project PARASOL (1996-1999). Since this first public domain 8C version in 1999, research and developments have been supported by the 9C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, 10C INRIA, and University of Bordeaux. 11C 12C The MUMPS team at the moment of releasing this version includes 13C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, 14C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora 15C Ucar and Clement Weisbecker. 16C 17C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil 18C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, 19C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire 20C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who 21C have been contributing to this project. 22C 23C Up-to-date copies of the MUMPS package can be obtained 24C from the Web pages: 25C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS 26C 27C 28C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY 29C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. 30C 31C 32C User documentation of any code that uses this software can 33C include this complete notice. You can acknowledge (using 34C references [1] and [2]) the contribution of this package 35C in any scientific publication dependent upon the use of the 36C package. You shall use reasonable endeavours to notify 37C the authors of the package of this publication. 38C 39C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 40C A fully asynchronous multifrontal solver using distributed dynamic 41C scheduling, SIAM Journal of Matrix Analysis and Applications, 42C Vol 23, No 1, pp 15-41 (2001). 43C 44C [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and 45C S. Pralet, Hybrid scheduling for the parallel solution of linear 46C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 47C 48 SUBROUTINE DMUMPS( id ) 49 USE DMUMPS_OOC 50 USE DMUMPS_STRUC_DEF 51 IMPLICIT NONE 52C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), 53 INTERFACE 54 SUBROUTINE DMUMPS_758 55 &(idRHS, idINFO, idN, idNRHS, idLRHS) 56 DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS 57 INTEGER, intent(in) :: idN, idNRHS, idLRHS 58 INTEGER, intent(inout) :: idINFO(:) 59 END SUBROUTINE DMUMPS_758 60 SUBROUTINE DMUMPS_26( id ) 61 USE DMUMPS_STRUC_DEF 62 TYPE (DMUMPS_STRUC), TARGET :: id 63 END SUBROUTINE DMUMPS_26 64 SUBROUTINE DMUMPS_142( id ) 65 USE DMUMPS_STRUC_DEF 66 TYPE (DMUMPS_STRUC), TARGET :: id 67 END SUBROUTINE DMUMPS_142 68 SUBROUTINE DMUMPS_301( id ) 69 USE DMUMPS_STRUC_DEF 70 TYPE (DMUMPS_STRUC), TARGET :: id 71 END SUBROUTINE DMUMPS_301 72 SUBROUTINE DMUMPS_349(id, LP) 73 USE DMUMPS_STRUC_DEF 74 TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id 75 INTEGER :: LP 76 END SUBROUTINE DMUMPS_349 77 END INTERFACE 78 INCLUDE 'mpif.h' 79 INTEGER MASTER, IERR 80 PARAMETER( MASTER = 0 ) 81 TYPE (DMUMPS_STRUC) :: id 82 INTEGER JOBMIN, JOBMAX, OLDJOB 83 INTEGER I, J, MP, LP, MPG, KEEP235SAVE, KEEP242SAVE, 84 & KEEP243SAVE 85 LOGICAL LANAL, LFACTO, LSOLVE, PROK, FLAG, PROKG 86 LOGICAL NOERRORBEFOREPERM 87 LOGICAL UNS_PERM_DONE 88 INTEGER COMM_SAVE 89 INTEGER JOB, N, NZ, NELT 90 INTEGER, PARAMETER :: ICNTL18DIST_MIN = 1 91 INTEGER, PARAMETER :: ICNTL18DIST_MAX = 3 92 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV 93 NOERRORBEFOREPERM = .FALSE. 94 UNS_PERM_DONE = .FALSE. 95 JOB = id%JOB 96 N = id%N 97 NZ = id%NZ 98 NELT = id%NELT 99 id%INFO(1) = 0 100 id%INFO(2) = 0 101 IF ( JOB .NE. -1 ) THEN 102 LP = id%ICNTL(1) 103 MP = id%ICNTL(2) 104 MPG = id%ICNTL(3) 105 PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.3)) 106 PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) 107 IF (PROKG) THEN 108 IF (id%ICNTL(5) .NE. 1) THEN 109 WRITE(MPG,'(A,I4,I12,I15)') 110 & 'Entering DMUMPS driver with JOB, N, NZ =', JOB,N,NZ 111 ELSE 112 WRITE(MPG,'(A,I4,I12,I15)') 113 & 'Entering DMUMPS driver with JOB, N, NELT =', JOB,N 114 & ,NELT 115 ENDIF 116 ENDIF 117 ELSE 118 MPG = 0 119 PROK = .FALSE. 120 PROKG = .FALSE. 121 LP = 6 122 MP = 6 123 END IF 124 CALL MPI_INITIALIZED( FLAG, IERR ) 125 IF ( .NOT. FLAG ) THEN 126 WRITE(LP,990) 127 990 FORMAT(' Error in DMUMPS initialization: MPI is not running.') 128 id%INFO(1) = -23 129 id%INFO(2) = 0 130 GOTO 500 131 END IF 132 COMM_SAVE = id%COMM 133 CALL MPI_COMM_DUP( COMM_SAVE, id%COMM, IERR ) 134 CALL MPI_ALLREDUCE(JOB,JOBMIN,1,MPI_INTEGER,MPI_MAX, 135 & id%COMM,IERR) 136 CALL MPI_ALLREDUCE(JOB,JOBMAX,1,MPI_INTEGER,MPI_MIN, 137 & id%COMM,IERR) 138 IF ( JOBMIN .NE. JOBMAX ) THEN 139 id%INFO(1) = -3 140 id%INFO(2) = JOB 141 GOTO 499 142 END IF 143 IF ( JOB .EQ. -1 ) THEN 144 id%INFO(1)=0 145 id%INFO(2)=0 146 IF ( id%KEEP(40) .EQ. 1 - 456789 .OR. 147 & id%KEEP(40) .EQ. 2 - 456789 .OR. 148 & id%KEEP(40) .EQ. 3 -456789 ) THEN 149 IF ( id%N > 0 ) THEN 150 id%INFO(1)=-3 151 id%INFO(2)=JOB 152 ENDIF 153 ENDIF 154 CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) 155 CALL MUMPS_276( id%ICNTL(1), 156 & id%INFO(1), 157 & id%COMM, id%MYID ) 158 IF ( id%INFO(1) .LT. 0 ) THEN 159 IF (id%KEEP(201).GT.0) THEN 160 CALL DMUMPS_587(id, IERR) 161 ENDIF 162 GOTO 499 163 ENDIF 164 CALL DMUMPS_163( id ) 165 GOTO 500 166 END IF 167 IF ( JOB .EQ. -2 ) THEN 168 id%KEEP(40)= -2 - 456789 169 CALL DMUMPS_136( id ) 170 GOTO 500 171 END IF 172 IF ((JOB.LT.1).OR.(JOB.GT.6)) THEN 173 id%INFO(1) = -3 174 id%INFO(2) = JOB 175 GOTO 499 176 END IF 177 IF (id%MYID.EQ.MASTER) THEN 178 IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN 179 & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN 180 IF ((N.LE.0).OR.((N+N+N)/3.NE.N)) THEN 181 id%INFO(1) = -16 182 id%INFO(2) = N 183 END IF 184 IF (id%ICNTL(5).NE.1) THEN 185 IF (NZ.LE.0) THEN 186 id%INFO(1) = -2 187 id%INFO(2) = NZ 188 END IF 189 ELSE 190 IF (NELT.LE.0) THEN 191 id%INFO(1) = -24 192 id%INFO(2) = NELT 193 END IF 194 ENDIF 195 END IF 196 IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) 197 & THEN 198 id%INFO(1) = -21 199 id%INFO(2) = id%NPROCS 200 ENDIF 201 END IF 202 CALL MUMPS_276( id%ICNTL(1), 203 & id%INFO(1), 204 & id%COMM, id%MYID ) 205 IF ( id%INFO(1) .LT. 0 ) GOTO 499 206 LANAL = .FALSE. 207 LFACTO = .FALSE. 208 LSOLVE = .FALSE. 209 IF ((JOB.EQ.1).OR.(JOB.EQ.4).OR. 210 & (JOB.EQ.6)) LANAL = .TRUE. 211 IF ((JOB.EQ.2).OR.(JOB.EQ.4).OR. 212 & (JOB.EQ.5).OR.(JOB.EQ.6)) LFACTO = .TRUE. 213 IF ((JOB.EQ.3).OR.(JOB.EQ.5).OR. 214 & (JOB.EQ.6)) LSOLVE = .TRUE. 215 IF (MP.GT.0) CALL DMUMPS_349(id, MP) 216 OLDJOB = id%KEEP( 40 ) + 456789 217 IF ( LANAL ) THEN 218 IF ( OLDJOB .EQ. 0 .OR. OLDJOB .GT. 3 .OR. OLDJOB .LT. -1 ) THEN 219 id%INFO(1) = -3 220 id%INFO(2) = JOB 221 GOTO 499 222 END IF 223 IF ( OLDJOB .GE. 2 ) THEN 224 IF (associated(id%IS)) THEN 225 DEALLOCATE (id%IS) 226 NULLIFY (id%IS) 227 END IF 228 IF (associated(id%S)) THEN 229 DEALLOCATE (id%S) 230 NULLIFY (id%S) 231 END IF 232 END IF 233 END IF 234 IF ( LFACTO ) THEN 235 IF ( OLDJOB .LT. 1 .and. .NOT. LANAL ) THEN 236 id%INFO(1) = -3 237 id%INFO(2) = JOB 238 GOTO 499 239 END IF 240 END IF 241 IF ( LSOLVE ) THEN 242 IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN 243 id%INFO(1) = -3 244 id%INFO(2) = JOB 245 GOTO 499 246 END IF 247 END IF 248#if ! defined (LARGEMATRICES) 249 NOERRORBEFOREPERM =.TRUE. 250 UNS_PERM_DONE=.FALSE. 251 IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN 252 IF ( id%JOB .EQ. 2 .OR. id%JOB .EQ. 5 .OR. 253 & (id%JOB .EQ. 3 .AND. (id%ICNTL(10) .NE.0 .OR. 254 & id%ICNTL(11).NE. 0))) THEN 255 UNS_PERM_DONE = .TRUE. 256 ALLOCATE(UNS_PERM_INV(id%N),stat=IERR) 257 IF (IERR .GT. 0) THEN 258 id%INFO(1)=-13 259 id%INFO(2)=id%N 260 IF (id%ICNTL(1) .GT. 0 .AND. id%ICNTL(4) .GE.1) THEN 261 WRITE(id%ICNTL(2),99993) 262 END IF 263 GOTO 510 264 ENDIF 265 DO I = 1, id%N 266 UNS_PERM_INV(id%UNS_PERM(I))=I 267 END DO 268 DO I = 1, id%NZ 269 J = id%JCN(I) 270 IF (J.LE.0.OR.J.GT.id%N) CYCLE 271 id%JCN(I)=UNS_PERM_INV(J) 272 END DO 273 DEALLOCATE(UNS_PERM_INV) 274 END IF 275 END IF 276#endif 277 CALL MUMPS_276( id%ICNTL(1), 278 & id%INFO(1), 279 & id%COMM, id%MYID ) 280 IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 281 IF (LANAL) THEN 282 id%KEEP(40)=-1 -456789 283 IF (id%MYID.EQ.MASTER) THEN 284 id%INFOG(7) = -9999 285 id%INFOG(23) = 0 286 id%INFOG(24) = 1 287 IF (associated(id%IS1)) DEALLOCATE(id%IS1) 288 IF ( id%ICNTL(5) .NE. 1 ) THEN 289 IF ( id%KEEP(50) .NE. 1 290 & .AND. ( 291 & (id%ICNTL(6) .NE. 0 .AND. id%ICNTL(7) .NE.1) 292 & .OR. 293 & id%ICNTL(12) .NE. 1) ) THEN 294 id%MAXIS1 = 11 * N 295 ELSE 296 id%MAXIS1 = 10 * N 297 END IF 298 ELSE 299 id%MAXIS1 = 6 * N + 2 * NELT + 2 300 ENDIF 301 ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) 302 IF (IERR.gt.0) THEN 303 id%INFO(1) = -7 304 id%INFO(2) = id%MAXIS1 305 IF ( LP .GT.0 ) 306 & WRITE(LP,*) 'Problem in allocating work array for analysis.' 307 GO TO 100 308 END IF 309 IF ( associated( id%PROCNODE ) ) 310 & DEALLOCATE( id%PROCNODE ) 311 ALLOCATE( id%PROCNODE(id%N), stat=IERR ) 312 IF (IERR.gt.0) THEN 313 id%INFO(1) = -7 314 id%INFO(2) = id%N 315 IF ( LP .GT. 0 ) THEN 316 WRITE(LP,*) 'Problem in allocating work array PROCNODE' 317 END IF 318 GOTO 100 319 END IF 320 id%PROCNODE(1:id%N) = 0 321 IF ( id%ICNTL(5) .EQ. 1 ) THEN 322 IF ( associated( id%ELTPROC ) ) 323 & DEALLOCATE( id%ELTPROC ) 324 ALLOCATE( id%ELTPROC(id%NELT), stat=IERR ) 325 IF (IERR.gt.0) THEN 326 id%INFO(1) = -7 327 id%INFO(2) = id%NELT 328 IF ( LP .GT. 0 ) THEN 329 WRITE(LP,*) 'Problem in allocating work array ELTPROC' 330 END IF 331 GOTO 100 332 END IF 333 END IF 334 IF ( id%ICNTL(5) .NE. 1 ) THEN 335 id%NA_ELT=0 336 IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN 337 & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN 338 IF ( .not. associated( id%IRN ) ) THEN 339 id%INFO(1) = -22 340 id%INFO(2) = 1 341 ELSE IF ( size( id%IRN ) < id%NZ ) THEN 342 id%INFO(1) = -22 343 id%INFO(2) = 1 344 ELSE IF ( .not. associated( id%JCN ) ) THEN 345 id%INFO(1) = -22 346 id%INFO(2) = 2 347 ELSE IF ( size( id%JCN ) < id%NZ ) THEN 348 id%INFO(1) = -22 349 id%INFO(2) = 2 350 END IF 351 END IF 352 IF ( id%INFO( 1 ) .eq. -22 ) THEN 353 IF (LP.GT.0) WRITE(LP,*) 354 & 'Error in analysis: IRN/JCN badly allocated.' 355 END IF 356 ELSE 357 IF ( .not. associated( id%ELTPTR ) ) THEN 358 id%INFO(1) = -22 359 id%INFO(2) = 1 360 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN 361 id%INFO(1) = -22 362 id%INFO(2) = 1 363 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN 364 id%INFO(1) = -22 365 id%INFO(2) = 2 366 ELSE 367 id%LELTVAR = id%ELTPTR( id%NELT+1 ) - 1 368 IF ( size( id%ELTVAR ) < id%LELTVAR ) THEN 369 id%INFO(1) = -22 370 id%INFO(2) = 2 371 ELSE 372 id%NA_ELT = 0 373 IF ( id%KEEP(50) .EQ. 0 ) THEN 374 DO I = 1,NELT 375 J = id%ELTPTR(I+1) - id%ELTPTR(I) 376 J = (J * J) 377 id%NA_ELT = id%NA_ELT + J 378 ENDDO 379 ELSE 380 DO I = 1,NELT 381 J = id%ELTPTR(I+1) - id%ELTPTR(I) 382 J = (J * (J+1))/2 383 id%NA_ELT = id%NA_ELT + J 384 ENDDO 385 ENDIF 386 ENDIF 387 END IF 388 IF ( id%INFO( 1 ) .eq. -22 ) THEN 389 IF (LP.GT.0) WRITE(LP,*) 390 & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' 391 END IF 392 ENDIF 393 100 CONTINUE 394 END IF 395 CALL MUMPS_276( id%ICNTL(1), 396 & id%INFO(1), 397 & id%COMM, id%MYID ) 398 IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 399 id%KEEP(52) = id%ICNTL(8) 400 IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) 401 & id%KEEP(52) = 77 402 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN 403 id%KEEP(52) = 0 404 ENDIF 405 IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN 406 IF (.not.associated(id%A)) id%KEEP(52) = 0 407 ENDIF 408 IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 409 CALL DMUMPS_26( id ) 410 IF (id%MYID .eq. MASTER) THEN 411 IF (id%KEEP(52) .NE. 0) THEN 412 id%INFOG(33)=id%KEEP(52) 413 ELSE 414 id%INFOG(33)=id%ICNTL(8) 415 ENDIF 416 ENDIF 417 IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) 418 IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 419 id%KEEP(40) = 1 -456789 420 END IF 421 IF (LFACTO) THEN 422 id%KEEP(40) = 1 - 456789 423 IF ( id%MYID .EQ. MASTER ) THEN 424 IF (id%KEEP(60).EQ.1) THEN 425 IF ( associated( id%SCHUR_CINTERFACE)) THEN 426 id%SCHUR=>id%SCHUR_CINTERFACE 427 & (1:id%SIZE_SCHUR*id%SIZE_SCHUR) 428 ENDIF 429 IF ( .NOT. associated (id%SCHUR)) THEN 430 IF (LP.GT.0) 431 & write(LP,'(A)') 432 & ' SCHUR not associated' 433 id%INFO(1)=-22 434 id%INFO(2)=9 435 ELSE IF ( size(id%SCHUR) .LT. 436 & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN 437 IF (LP.GT.0) 438 & write(LP,'(A)') 439 & ' SCHUR allocated but too small' 440 id%INFO(1)=-22 441 id%INFO(2)=9 442 END IF 443 END IF 444 IF ( id%KEEP(55) .EQ. 0 ) THEN 445 IF ( id%KEEP(54).eq.0 ) THEN 446 IF ( .not. associated( id%A ) ) THEN 447 id%INFO( 1 ) = -22 448 id%INFO( 2 ) = 4 449 ELSE IF ( size( id%A ) < id%NZ ) THEN 450 id%INFO( 1 ) = -22 451 id%INFO( 2 ) = 4 452 END IF 453 END IF 454 ELSE 455 IF ( .not. associated( id%A_ELT ) ) THEN 456 id%INFO( 1 ) = -22 457 id%INFO( 2 ) = 4 458 ELSE 459 IF ( size( id%A_ELT ) < id%NA_ELT ) THEN 460 id%INFO( 1 ) = -22 461 id%INFO( 2 ) = 4 462 ENDIF 463 END IF 464 ENDIF 465 CALL MUMPS_633(id%KEEP(12),id%ICNTL(14), 466 & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) 467 CALL DMUMPS_635(N,id%KEEP(1),id%ICNTL(1),MPG) 468 IF( id%KEEP(52) .EQ. -2 .AND. id%ICNTL(8) .NE. -2 .AND. 469 & id%ICNTL(8).NE. 77 ) THEN 470 IF ( MPG .GT. 0 ) THEN 471 WRITE(MPG,'(A)') ' ** WARNING : SCALING' 472 WRITE(MPG,'(A)') 473 & ' ** scaling already computed during analysis' 474 WRITE(MPG,'(A)') 475 & ' ** keeping the scaling from the analysis' 476 ENDIF 477 ENDIF 478 IF (id%KEEP(52) .NE. -2) THEN 479 id%KEEP(52)=id%ICNTL(8) 480 ENDIF 481 IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) 482 & id%KEEP(52) = 77 483 IF (id%KEEP(52).EQ.77) THEN 484 IF (id%KEEP(50).EQ.1) THEN 485 id%KEEP(52) = 0 486 ELSE 487 id%KEEP(52) = 7 488 ENDIF 489 ENDIF 490 IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN 491 IF ( MPG .GT. 0 ) THEN 492 WRITE(MPG,'(A)') ' ** WARNING : SCALING' 493 WRITE(MPG,'(A)') 494 & ' ** column permutation applied:' 495 WRITE(MPG,'(A)') 496 & ' ** column scaling has to be permuted' 497 ENDIF 498 ENDIF 499 IF ( id%KEEP( 19 ) .ne. 0 .and. id%KEEP( 52 ).ne. 0 ) THEN 500 IF ( MPG .GT. 0 ) THEN 501 WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' 502 WRITE(MPG,'(A)') ' ** (incompatibility with null space)' 503 END IF 504 id%KEEP(52) = 0 505 END IF 506 IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN 507 id%KEEP(52) = 0 508 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN 509 WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' 510 WRITE(MPG,'(A)') ' ** (incompatibility with Schur)' 511 END IF 512 END IF 513 IF (id%KEEP(54) .NE. 0 .AND. 514 & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. 515 & id%KEEP(52) .NE. 0 ) THEN 516 id%KEEP(52) = 0 517 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN 518 WRITE(MPG,'(A)') 519 & ' ** Warning: This scaling option not available' 520 WRITE(MPG,'(A)') ' ** for distributed matrix entry' 521 END IF 522 END IF 523 IF ( id%KEEP(50) .NE. 0 ) THEN 524 IF ( id%KEEP(52).ne. 1 .and. 525 & id%KEEP(52).ne. -1 .and. 526 & id%KEEP(52).ne. 0 .and. 527 & id%KEEP(52).ne. 7 .and. 528 & id%KEEP(52).ne. 8 .and. 529 & id%KEEP(52).ne. -2 .and. 530 & id%KEEP(52).ne. 77) THEN 531 IF ( MPG .GT. 0 ) THEN 532 WRITE(MPG,'(A)') 533 & ' ** Warning: Scaling option n.a. for symmetric matrix' 534 END IF 535 id%KEEP(52) = 0 536 END IF 537 END IF 538 IF (id%KEEP(55) .NE. 0 .AND. 539 & ( id%KEEP(52) .gt. 0 ) ) THEN 540 id%KEEP(52) = 0 541 IF ( MPG .GT. 0 ) THEN 542 WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' 543 WRITE(MPG,'(A)') 544 & ' ** (only user scaling av. for elt. entry)' 545 END IF 546 END IF 547 IF ( id%KEEP(52) .eq. -1 ) THEN 548 IF ( .not. associated( id%ROWSCA ) ) THEN 549 id%INFO(1) = -22 550 id%INFO(2) = 5 551 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN 552 id%INFO(1) = -22 553 id%INFO(2) = 5 554 ELSE IF ( .not. associated( id%COLSCA ) ) THEN 555 id%INFO(1) = -22 556 id%INFO(2) = 6 557 ELSE IF ( size( id%COLSCA ) < id%N ) THEN 558 id%INFO(1) = -22 559 id%INFO(2) = 6 560 END IF 561 END IF 562 IF (id%KEEP(52).GT.0 .AND. 563 & id%KEEP(52) .LE.8) THEN 564 IF ( associated(id%COLSCA)) 565 & DEALLOCATE( id%COLSCA ) 566 IF ( associated(id%ROWSCA)) 567 & DEALLOCATE( id%ROWSCA ) 568 ALLOCATE( id%COLSCA(N), stat=IERR) 569 IF (IERR .GT.0) id%INFO(1)=-13 570 ALLOCATE( id%ROWSCA(N), stat=IERR) 571 IF (IERR .GT.0) id%INFO(1)=-13 572 END IF 573 IF (.NOT. associated(id%COLSCA)) THEN 574 ALLOCATE( id%COLSCA(1), stat=IERR) 575 END IF 576 IF (IERR .GT.0) id%INFO(1)=-13 577 IF (.NOT. associated(id%ROWSCA)) 578 & ALLOCATE( id%ROWSCA(1), stat=IERR) 579 IF (IERR .GT.0) id%INFO(1)=-13 580 IF ( id%INFO(1) .eq. -13 ) THEN 581 IF ( LP .GT. 0 ) 582 & WRITE(LP,*) 'Problems in allocations before facto' 583 GOTO 200 584 END IF 585 IF (id%KEEP(252) .EQ. 1) THEN 586 CALL DMUMPS_758 587 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) 588 CALL DMUMPS_807(id) 589 CALL DMUMPS_769(id) 590 ENDIF 591 200 CONTINUE 592 END IF 593 CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, 594 & IERR ) 595 IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN 596 IF ( id%root%yes ) THEN 597 IF ( associated( id%SCHUR_CINTERFACE )) THEN 598 id%SCHUR=>id%SCHUR_CINTERFACE 599 & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ 600 & id%root%SCHUR_MLOC) 601 ENDIF 602 IF (id%SCHUR_LLD < id%root%SCHUR_MLOC) THEN 603 IF (LP.GT.0) write(LP,*) 604 & ' SCHUR leading dimension SCHUR_LLD ', 605 & id%SCHUR_LLD, 'too small with respect to', 606 & id%root%SCHUR_MLOC 607 id%INFO(1)=-30 608 id%INFO(2)=id%SCHUR_LLD 609 ELSE IF ( .NOT. associated (id%SCHUR)) THEN 610 IF (LP.GT.0) write(LP,'(A)') 611 & ' SCHUR not associated' 612 id%INFO(1)=-22 613 id%INFO(2)=9 614 ELSE IF (size(id%SCHUR) < 615 & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ 616 & id%root%SCHUR_MLOC) THEN 617 IF (LP.GT.0) THEN 618 write(LP,'(A)') 619 & ' SCHUR allocated but too small' 620 write(LP,*) id%MYID, ' : Size Schur=', 621 & size(id%SCHUR), 622 & ' SCHUR_LLD= ', id%SCHUR_LLD, 623 & ' SCHUR_MLOC=', id%root%SCHUR_NLOC, 624 & ' SCHUR_NLOC=', id%root%SCHUR_NLOC 625 ENDIF 626 id%INFO(1)=-22 627 id%INFO(2)= 9 628 ELSE 629 id%root%SCHUR_LLD=id%SCHUR_LLD 630 IF (id%root%SCHUR_NLOC==0) THEN 631 ALLOCATE(id%root%SCHUR_POINTER(1)) 632 ELSE 633 id%root%SCHUR_POINTER=>id%SCHUR 634 ENDIF 635 ENDIF 636 ENDIF 637 ENDIF 638 CALL MUMPS_276( id%ICNTL(1), 639 & id%INFO(1), 640 & id%COMM, id%MYID ) 641 IF ( id%INFO(1) .LT. 0 ) GO TO 499 642 CALL DMUMPS_142(id) 643 IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) 644 IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN 645 IF (id%root%yes) THEN 646 IF (id%root%SCHUR_NLOC==0) THEN 647 DEALLOCATE(id%root%SCHUR_POINTER) 648 NULLIFY(id%root%SCHUR_POINTER) 649 ELSE 650 NULLIFY(id%root%SCHUR_POINTER) 651 ENDIF 652 ENDIF 653 ENDIF 654 IF ( id%INFO(1) .LT. 0 ) GO TO 499 655 id%KEEP(40) = 2 - 456789 656 END IF 657 IF (LSOLVE) THEN 658 id%KEEP(40) = 2 -456789 659 IF (id%MYID .eq. MASTER) THEN 660 KEEP235SAVE = id%KEEP(235) 661 KEEP242SAVE = id%KEEP(242) 662 KEEP243SAVE = id%KEEP(243) 663 IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 664 ENDIF 665 CALL DMUMPS_301(id) 666 IF (id%MYID .eq. MASTER) THEN 667 id%KEEP(235) = KEEP235SAVE 668 id%KEEP(242) = KEEP242SAVE 669 id%KEEP(243) = KEEP243SAVE 670 ENDIF 671 IF (id%INFO(1).LT.0) GOTO 499 672 id%KEEP(40) = 3 -456789 673 ENDIF 674 IF (MP.GT.0) CALL DMUMPS_349(id, MP) 675 GOTO 500 676 499 PROK = ((id%ICNTL(1).GT.0).AND. 677 & (id%ICNTL(4).GE.1)) 678 IF (PROK) WRITE (id%ICNTL(1),99995) id%INFO(1) 679 IF (PROK) WRITE (id%ICNTL(1),99994) id%INFO(2) 680500 CONTINUE 681#if ! defined(LARGEMATRICES) 682 IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 683 & .AND. NOERRORBEFOREPERM) THEN 684 IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN 685 DO I = 1, id%NZ 686 J=id%JCN(I) 687 IF (J.LE.0.OR.J.GT.id%N) CYCLE 688 id%JCN(I)=id%UNS_PERM(J) 689 END DO 690 END IF 691 END IF 692#endif 693 510 CONTINUE 694 CALL DMUMPS_300(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) 695 CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, 696 & id%COMM, IERR ) 697 IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. 698 & id%INFOG(1).lt.0) THEN 699 WRITE(MPG,'(A,I12)') ' On return from DMUMPS, INFOG(1)=', 700 & id%INFOG(1) 701 WRITE(MPG,'(A,I12)') ' On return from DMUMPS, INFOG(2)=', 702 & id%INFOG(2) 703 END IF 704 CALL MPI_COMM_FREE( id%COMM, IERR ) 705 id%COMM = COMM_SAVE 706 RETURN 70799995 FORMAT (' ** ERROR RETURN ** FROM DMUMPS INFO(1)=', I3) 70899994 FORMAT (' ** INFO(2)=', I10) 70999993 FORMAT (' ** Allocation error: could not permute JCN.') 710 END SUBROUTINE DMUMPS 711 SUBROUTINE DMUMPS_300( INFO, INFOG, COMM, MYID ) 712 IMPLICIT NONE 713 INCLUDE 'mpif.h' 714 INTEGER INFO(40), INFOG(40), COMM, MYID 715 INTEGER TMP1(2),TMP(2) 716 INTEGER ROOT, IERR 717 INTEGER MASTER 718 PARAMETER (MASTER=0) 719 IF ( INFO(1) .ge. 0 .and. INFO(2) .ge. 0 ) THEN 720 INFOG(1) = INFO(1) 721 INFOG(2) = INFO(2) 722 ELSE 723 INFOG(1) = INFO(1) 724 TMP1(1) = INFO(1) 725 TMP1(2) = MYID 726 CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, 727 & MPI_MINLOC,COMM,IERR ) 728 INFOG(2) = INFO(2) 729 ROOT = TMP(2) 730 CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) 731 CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) 732 END IF 733 CALL MPI_BCAST(INFOG(3), 38, MPI_INTEGER, MASTER, COMM, IERR ) 734 RETURN 735 END SUBROUTINE DMUMPS_300 736 SUBROUTINE DMUMPS_349(id, LP) 737 USE DMUMPS_STRUC_DEF 738 TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id 739 INTEGER :: LP 740 INTEGER, POINTER :: JOB 741 INTEGER,DIMENSION(:),POINTER::ICNTL 742 INTEGER MASTER 743 PARAMETER( MASTER = 0 ) 744 IF (LP.LT.0) RETURN 745 JOB=>id%JOB 746 ICNTL=>id%ICNTL 747 IF (id%MYID.EQ.MASTER) THEN 748 SELECT CASE (JOB) 749 CASE(1); 750 WRITE (LP,980) 751 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 752 WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), 753 & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 754 IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. 755 & (ICNTL(12).NE.1) ) THEN 756 WRITE (LP,992) ICNTL(8) 757 ENDIF 758 IF (id%ICNTL(19).NE.0) 759 & WRITE(LP,998) id%SIZE_SCHUR 760 WRITE (LP,993) ICNTL(14) 761 CASE(2); 762 WRITE (LP,980) 763 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 764 WRITE (LP,992) ICNTL(8) 765 WRITE (LP,993) ICNTL(14) 766 CASE(3); 767 WRITE (LP,980) 768 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 769 WRITE (LP,995) 770 & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) 771 CASE(4); 772 WRITE (LP,980) 773 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 774 WRITE (LP,992) ICNTL(8) 775 IF (id%ICNTL(19).NE.0) 776 & WRITE(LP,998) id%SIZE_SCHUR 777 WRITE (LP,993) ICNTL(14) 778 CASE(5); 779 WRITE (LP,980) 780 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 781 WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), 782 & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 783 WRITE (LP,992) ICNTL(8) 784 WRITE (LP,993) ICNTL(14) 785 WRITE (LP,995) 786 & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) 787 CASE(6); 788 WRITE (LP,980) 789 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 790 WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), 791 & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 792 IF (id%ICNTL(19).NE.0) 793 & WRITE(LP,998) id%SIZE_SCHUR 794 WRITE (LP,992) ICNTL(8) 795 WRITE (LP,995) 796 & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) 797 WRITE (LP,993) ICNTL(14) 798 END SELECT 799 ENDIF 800 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 801 990 FORMAT ( 802 & 'ICNTL(1) Output stream for error messages =',I10/ 803 & 'ICNTL(2) Output stream for diagnostic messages =',I10/ 804 & 'ICNTL(3) Output stream for global information =',I10/ 805 & 'ICNTL(4) Level of printing =',I10) 806 991 FORMAT ( 807 & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ 808 & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ 809 & 'ICNTL(7) Ordering =',I10/ 810 & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ 811 & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ 812 & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ 813 & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ 814 & 'ICNTL(22) Out-off-core option (0=Off, >0=ON) =',I10) 815 992 FORMAT ( 816 & 'ICNTL(8) Scaling strategy =',I10) 817 993 FORMAT ( 818 & 'ICNTL(14) Percent of memory increase =',I10) 819 995 FORMAT ( 820 & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ 821 & 'ICNTL(10) Max steps iterative refinement =',I10/ 822 & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10) 823 998 FORMAT ( 824 & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) 825 END SUBROUTINE DMUMPS_349 826 SUBROUTINE DMUMPS_350(id, LP) 827 USE DMUMPS_STRUC_DEF 828 TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id 829 INTEGER ::LP 830 INTEGER, POINTER :: JOB 831 INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP 832 INTEGER MASTER 833 PARAMETER( MASTER = 0 ) 834 IF (LP.LT.0) RETURN 835 JOB=>id%JOB 836 ICNTL=>id%ICNTL 837 KEEP=>id%KEEP 838 IF (id%MYID.EQ.MASTER) THEN 839 SELECT CASE (JOB) 840 CASE(1); 841 WRITE (LP,980) 842 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 843 WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), 844 & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) 845 IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN 846 WRITE (LP,992) KEEP(52) 847 ENDIF 848 WRITE (LP,993) KEEP(12) 849 CASE(2); 850 WRITE (LP,980) 851 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 852 IF (KEEP(23).EQ.0)THEN 853 WRITE (LP,992) KEEP(52) 854 ENDIF 855 WRITE (LP,993) KEEP(12) 856 CASE(3); 857 WRITE (LP,980) 858 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 859 WRITE (LP,995) 860 & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) 861 CASE(4); 862 WRITE (LP,980) 863 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 864 IF (KEEP(23).NE.0)THEN 865 WRITE (LP,992) KEEP(52) 866 ENDIF 867 WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), 868 & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) 869 WRITE (LP,995) 870 & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) 871 WRITE (LP,993) KEEP(12) 872 CASE(5); 873 WRITE (LP,980) 874 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 875 WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), 876 & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) 877 IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) 878 & .OR. (KEEP(23).EQ.7)) THEN 879 WRITE (LP,992) KEEP(52) 880 ENDIF 881 IF (KEEP(23).EQ.0)THEN 882 WRITE (LP,992) KEEP(52) 883 ENDIF 884 WRITE (LP,993) KEEP(12) 885 CASE(6); 886 WRITE (LP,980) 887 WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) 888 WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), 889 & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) 890 IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) 891 & .OR. (KEEP(23).EQ.7)) THEN 892 WRITE (LP,992) KEEP(52) 893 ENDIF 894 IF (KEEP(23).EQ.0)THEN 895 WRITE (LP,992) KEEP(52) 896 ENDIF 897 WRITE (LP,995) 898 & ICNTL(9),ICNTL(10),ICNTL(11),KEEP(248),ICNTL(21) 899 WRITE (LP,993) KEEP(12) 900 END SELECT 901 ENDIF 902 980 FORMAT (/'******INTERNAL VALUE OF PARAMETERS (ICNTL/KEEP)****'/) 903 990 FORMAT ( 904 & 'ICNTL(1) Output stream for error messages =',I10/ 905 & 'ICNTL(2) Output stream for diagnostic messages =',I10/ 906 & 'ICNTL(3) Output stream for global information =',I10/ 907 & 'ICNTL(4) Level of printing =',I10) 908 991 FORMAT ( 909 & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ 910 & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ 911 & 'ICNTL(7) Ordering =',I10/ 912 & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ 913 & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ 914 & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ 915 & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ 916 & 'ICNTL(22) Out-off-core option (0=Off, >0=ON) =',I10) 917 992 FORMAT ( 918 & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 919 993 FORMAT ( 920 & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 921 995 FORMAT ( 922 & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ 923 & 'ICNTL(10) Max steps iterative refinement =',I10/ 924 & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ 925 & 'ICNTL(20) Dense (0) or sparse (1) RHS =',I10/ 926 & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) 927 END SUBROUTINE DMUMPS_350 928 SUBROUTINE DMUMPS_758 929 & (idRHS, idINFO, idN, idNRHS, idLRHS) 930 IMPLICIT NONE 931 DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS 932 INTEGER, intent(in) :: idN, idNRHS, idLRHS 933 INTEGER, intent(inout) :: idINFO(:) 934 IF ( .not. associated( idRHS ) ) THEN 935 idINFO( 1 ) = -22 936 idINFO( 2 ) = 7 937 ELSE IF (idNRHS.EQ.1) THEN 938 IF ( size( idRHS ) < idN ) THEN 939 idINFO( 1 ) = -22 940 idINFO( 2 ) = 7 941 ENDIF 942 ELSE IF (idLRHS < idN) 943 & THEN 944 idINFO( 1 ) = -26 945 idINFO( 2 ) = idLRHS 946 ELSE IF 947 & (size(idRHS)<(idNRHS*idLRHS-idLRHS+idN)) 948 & THEN 949 idINFO( 1 ) = -22 950 idINFO( 2 ) = 7 951 END IF 952 RETURN 953 END SUBROUTINE DMUMPS_758 954 SUBROUTINE DMUMPS_807(id) 955 USE DMUMPS_STRUC_DEF 956 IMPLICIT NONE 957 TYPE (DMUMPS_STRUC) :: id 958 INTEGER MASTER 959 PARAMETER( MASTER = 0 ) 960 IF (id%MYID.EQ.MASTER) THEN 961 id%KEEP(221)=id%ICNTL(26) 962 IF (id%KEEP(221).ne.0 .and. id%KEEP(221) .NE.1 963 & .AND.id%KEEP(221).ne.2) id%KEEP(221)=0 964 ENDIF 965 RETURN 966 END SUBROUTINE DMUMPS_807 967 SUBROUTINE DMUMPS_769(id) 968 USE DMUMPS_STRUC_DEF 969 IMPLICIT NONE 970 TYPE (DMUMPS_STRUC) :: id 971 INTEGER MASTER 972 PARAMETER( MASTER = 0 ) 973 IF (id%MYID .EQ. MASTER) THEN 974 IF ( id%KEEP(221) == 1 .or. id%KEEP(221) == 2 ) THEN 975 IF (id%KEEP(221) == 2 .and. id%JOB == 2) THEN 976 id%INFO(1)=-35 977 id%INFO(2)=id%KEEP(221) 978 GOTO 333 979 ENDIF 980 IF (id%KEEP(221) == 1 .and. id%KEEP(252) == 1 981 & .and. id%JOB == 3) THEN 982 id%INFO(1)=-35 983 id%INFO(2)=id%KEEP(221) 984 ENDIF 985 IF ( id%KEEP(60).eq. 0 .or. id%SIZE_SCHUR.EQ.0 ) THEN 986 id%INFO(1)=-33 987 id%INFO(2)=id%KEEP(221) 988 GOTO 333 989 ENDIF 990 IF ( .NOT. associated( id%REDRHS)) THEN 991 id%INFO(1)=-22 992 id%INFO(2)=15 993 GOTO 333 994 ELSE IF (id%NRHS.EQ.1) THEN 995 IF (size(id%REDRHS) < id%SIZE_SCHUR ) THEN 996 id%INFO(1)=-22 997 id%INFO(2)=15 998 GOTO 333 999 ENDIF 1000 ELSE IF (id%LREDRHS < id%SIZE_SCHUR) THEN 1001 id%INFO(1)=-34 1002 id%INFO(2)=id%LREDRHS 1003 GOTO 333 1004 ELSE IF 1005 & (size(id%REDRHS)< 1006 & id%NRHS*id%LREDRHS-id%LREDRHS+id%SIZE_SCHUR) 1007 & THEN 1008 id%INFO(1)=-22 1009 id%INFO(2)=15 1010 GOTO 333 1011 ENDIF 1012 ENDIF 1013 ENDIF 1014 333 CONTINUE 1015 RETURN 1016 END SUBROUTINE DMUMPS_769 1017 SUBROUTINE DMUMPS_24( MYID, SLAVEF, N, 1018 & PROCNODE, STEP, PTRAIW, PTRARW, ISTEP_TO_INIV2, 1019 & I_AM_CAND, 1020 & KEEP, KEEP8, ICNTL, id ) 1021 USE DMUMPS_STRUC_DEF 1022 IMPLICIT NONE 1023 TYPE (DMUMPS_STRUC) :: id 1024 INTEGER MYID, N, SLAVEF 1025 INTEGER KEEP( 500 ), ICNTL( 40 ) 1026 INTEGER(8) KEEP8(150) 1027 INTEGER PROCNODE( KEEP(28) ), STEP( N ), 1028 & PTRAIW( N ), PTRARW( N ) 1029 INTEGER ISTEP_TO_INIV2(KEEP(71)) 1030 LOGICAL I_AM_CAND(max(1,KEEP(56))) 1031 LOGICAL I_AM_SLAVE 1032 LOGICAL I_AM_CAND_LOC 1033 INTEGER MUMPS_330, MUMPS_275, MUMPS_810 1034 EXTERNAL MUMPS_330, MUMPS_275, MUMPS_810 1035 INTEGER ISTEP, I, IPTRI, IPTRR, NCOL, NROW, allocok 1036 INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT 1037 LOGICAL T4_MASTER_CONCERNED 1038 TYPE_PARALL = KEEP(46) 1039 I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) 1040 KEEP(14) = 0 1041 KEEP(13) = 0 1042 DO I = 1, N 1043 ISTEP=abs(STEP(I)) 1044 ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) 1045 IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) 1046 TYPESPLIT = MUMPS_810 ( PROCNODE(ISTEP), SLAVEF ) 1047 I_AM_CAND_LOC = .FALSE. 1048 T4_MASTER_CONCERNED = .FALSE. 1049 IF (ITYPE.EQ.2) THEN 1050 INIV2 = ISTEP_TO_INIV2(ISTEP) 1051 IF (I_AM_SLAVE) THEN 1052 I_AM_CAND_LOC = I_AM_CAND(INIV2) 1053 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN 1054 IF ( TYPE_PARALL .eq. 0 ) THEN 1055 T4_MASTER_CONCERNED = 1056 & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) 1057 & .EQ.MYID-1 ) 1058 ELSE 1059 T4_MASTER_CONCERNED = 1060 & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1, INIV2)+1,INIV2 ) 1061 & .EQ.MYID ) 1062 ENDIF 1063 ENDIF 1064 ENDIF 1065 ENDIF 1066 IF ( TYPE_PARALL .eq. 0 ) THEN 1067 IRANK = IRANK + 1 1068 END IF 1069 IF ( 1070 & ( (ITYPE .EQ. 1.OR.ITYPE.EQ.2) .AND. 1071 & IRANK .EQ. MYID ) 1072 & .OR. 1073 & ( T4_MASTER_CONCERNED ) 1074 & ) THEN 1075 KEEP( 14 ) = KEEP( 14 ) + 3 + PTRAIW( I ) + PTRARW( I ) 1076 KEEP( 13 ) = KEEP( 13 ) + 1 + PTRAIW( I ) + PTRARW( I ) 1077 ELSE IF ( ITYPE .EQ. 3 ) THEN 1078 ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN 1079 PTRARW( I ) = 0 1080 KEEP(14) = KEEP(14) + 3 + PTRAIW( I ) + PTRARW( I ) 1081 KEEP(13) = KEEP(13) + 1 + PTRAIW( I ) + PTRARW( I ) 1082 END IF 1083 END DO 1084 IF ( associated( id%INTARR ) ) THEN 1085 DEALLOCATE( id%INTARR ) 1086 NULLIFY( id%INTARR ) 1087 END IF 1088 IF ( KEEP(14) > 0 ) THEN 1089 ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) 1090 IF ( allocok .GT. 0 ) THEN 1091 id%INFO(1) = -7 1092 id%INFO(2) = KEEP(14) 1093 RETURN 1094 END IF 1095 ELSE 1096 ALLOCATE( id%INTARR( 1 ), stat = allocok ) 1097 IF ( allocok .GT. 0 ) THEN 1098 id%INFO(1) = -7 1099 id%INFO(2) = 1 1100 RETURN 1101 END IF 1102 END IF 1103 IPTRI = 1 1104 IPTRR = 1 1105 DO I = 1, N 1106 ISTEP = abs(STEP(I)) 1107 ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) 1108 IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) 1109 TYPESPLIT = MUMPS_810 ( PROCNODE(ISTEP), SLAVEF ) 1110 I_AM_CAND_LOC = .FALSE. 1111 T4_MASTER_CONCERNED = .FALSE. 1112 IF (ITYPE.EQ.2) THEN 1113 INIV2 = ISTEP_TO_INIV2(ISTEP) 1114 IF (I_AM_SLAVE) THEN 1115 I_AM_CAND_LOC = I_AM_CAND(INIV2) 1116 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN 1117 IF ( TYPE_PARALL .eq. 0 ) THEN 1118 T4_MASTER_CONCERNED = 1119 & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) 1120 & .EQ.MYID-1 ) 1121 ELSE 1122 T4_MASTER_CONCERNED = 1123 & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) 1124 & .EQ.MYID ) 1125 ENDIF 1126 ENDIF 1127 ENDIF 1128 ENDIF 1129 IF ( TYPE_PARALL .eq. 0 ) THEN 1130 IRANK =IRANK + 1 1131 END IF 1132 IF ( 1133 & ( ITYPE .eq. 2 .and. 1134 & IRANK .eq. MYID ) 1135 & .or. 1136 & ( ITYPE .eq. 1 .and. 1137 & IRANK .eq. MYID ) 1138 & .or. 1139 & ( T4_MASTER_CONCERNED ) 1140 & ) THEN 1141 NCOL = PTRAIW( I ) 1142 NROW = PTRARW( I ) 1143 id%INTARR( IPTRI ) = NCOL 1144 id%INTARR( IPTRI + 1 ) = -NROW 1145 id%INTARR( IPTRI + 2 ) = I 1146 PTRAIW( I ) = IPTRI 1147 PTRARW( I ) = IPTRR 1148 IPTRI = IPTRI + NCOL + NROW + 3 1149 IPTRR = IPTRR + NCOL + NROW + 1 1150 ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN 1151 NCOL = PTRAIW( I ) 1152 NROW = 0 1153 id%INTARR( IPTRI ) = NCOL 1154 id%INTARR( IPTRI + 1 ) = -NROW 1155 id%INTARR( IPTRI + 2 ) = I 1156 PTRAIW( I ) = IPTRI 1157 PTRARW( I ) = IPTRR 1158 IPTRI = IPTRI + NCOL + NROW + 3 1159 IPTRR = IPTRR + NCOL + NROW + 1 1160 ELSE 1161 PTRAIW(I) = 0 1162 PTRARW(I) = 0 1163 END IF 1164 END DO 1165 IF ( IPTRI - 1 .NE. KEEP(14) ) THEN 1166 WRITE(*,*) 'Error 1 in anal_arrowheads', 1167 & ' IPTRI - 1, KEEP(14)=', IPTRI - 1, KEEP(14) 1168 CALL MUMPS_ABORT() 1169 END IF 1170 IF ( IPTRR - 1 .NE. KEEP(13) ) THEN 1171 WRITE(*,*) 'Error 2 in anal_arrowheads' 1172 CALL MUMPS_ABORT() 1173 END IF 1174 RETURN 1175 END SUBROUTINE DMUMPS_24 1176 SUBROUTINE DMUMPS_148(N, NZ, ASPK, 1177 & IRN, ICN, PERM, 1178 & LSCAL,COLSCA,ROWSCA, 1179 & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, 1180 & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, 1181 & INTARR, DBLARR, PTRAIW, PTRARW, FRERE_STEPS, 1182 & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) 1183 IMPLICIT NONE 1184 INCLUDE 'dmumps_root.h' 1185 INTEGER N,NZ, COMM, NBRECORDS 1186 INTEGER KEEP( 500 ) 1187 INTEGER(8) KEEP8(150) 1188 DOUBLE PRECISION ASPK(NZ) 1189 DOUBLE PRECISION COLSCA(*), ROWSCA(*) 1190 INTEGER IRN(NZ), ICN(NZ) 1191 INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) 1192 INTEGER RG2L( N ), FILS( N ) 1193 INTEGER ISTEP_TO_INIV2(KEEP(71)) 1194 LOGICAL I_AM_CAND(max(1,KEEP(56))) 1195 INTEGER LP, SLAVEF, MYID 1196 INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) 1197 LOGICAL LSCAL 1198 TYPE (DMUMPS_ROOT_STRUC) :: root 1199 INTEGER(8) :: LA 1200 INTEGER PTRAIW( N ), PTRARW( N ), FRERE_STEPS( KEEP(28) ) 1201 INTEGER STEP(N) 1202 INTEGER INTARR( max(1,KEEP(14)) ) 1203 DOUBLE PRECISION A( LA ), DBLARR(max(1,KEEP(13))) 1204 INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI 1205 DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BUFR 1206 INTEGER MUMPS_275, MUMPS_330, numroc, 1207 & MUMPS_810 1208 EXTERNAL MUMPS_275, MUMPS_330, numroc, 1209 & MUMPS_810 1210 DOUBLE PRECISION VAL 1211 INTEGER IOLD,JOLD,INEW,JNEW,ISEND,JSEND,DEST,I,K,IARR 1212 INTEGER IPOSROOT, JPOSROOT 1213 INTEGER IROW_GRID, JCOL_GRID 1214 INTEGER INODE, ISTEP 1215 INTEGER NBUFS 1216 INTEGER ARROW_ROOT, TAILLE 1217 INTEGER LOCAL_M, LOCAL_N 1218 INTEGER(8) :: PTR_ROOT 1219 INTEGER TYPENODE_TMP, MASTER_NODE 1220 LOGICAL I_AM_CAND_LOC, I_AM_SLAVE 1221 INTEGER I1, IA, JARR, ILOCROOT, JLOCROOT 1222 INTEGER IS1, ISHIFT, IIW, IS, IAS 1223 INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 1224 LOGICAL T4_MASTER_CONCERNED 1225 DOUBLE PRECISION ZERO 1226 PARAMETER( ZERO = 0.0D0 ) 1227 INTEGER, POINTER, DIMENSION(:,:) :: IW4 1228 ARROW_ROOT = 0 1229 I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) 1230 IF ( KEEP(46) .eq. 0 ) THEN 1231 NBUFS = SLAVEF 1232 ELSE 1233 NBUFS = SLAVEF - 1 1234 ALLOCATE( IW4( N, 2 ), stat = allocok ) 1235 IF ( allocok .GT. 0 ) THEN 1236 WRITE(*,*) 'Error allocating IW4' 1237 CALL MUMPS_ABORT() 1238 END IF 1239 DO I = 1, N 1240 I1 = PTRAIW( I ) 1241 IA = PTRARW( I ) 1242 IF ( IA .GT. 0 ) THEN 1243 DBLARR( IA ) = ZERO 1244 IW4( I, 1 ) = INTARR( I1 ) 1245 IW4( I, 2 ) = -INTARR( I1 + 1 ) 1246 INTARR( I1 + 2 ) = I 1247 END IF 1248 END DO 1249 IF ( KEEP(38) .NE. 0 ) THEN 1250 IF (KEEP(60)==0) THEN 1251 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, 1252 & root%MYROW, 0, root%NPROW ) 1253 LOCAL_M = max( 1, LOCAL_M ) 1254 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, 1255 & root%MYCOL, 0, root%NPCOL ) 1256 PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 1257 IF ( PTR_ROOT .LE. LA ) THEN 1258 A( PTR_ROOT:LA ) = ZERO 1259 END IF 1260 ELSE 1261 DO I = 1, root%SCHUR_NLOC 1262 root%SCHUR_POINTER(int(I-1,8)*int(root%SCHUR_LLD,8)+1_8: 1263 & int(I-1,8)*int(root%SCHUR_LLD,8)+int(root%SCHUR_MLOC,8))= 1264 & ZERO 1265 ENDDO 1266 ENDIF 1267 END IF 1268 END IF 1269 IF (NBUFS.GT.0) THEN 1270 ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) 1271 IF ( allocok .GT. 0 ) THEN 1272 WRITE(*,*) 'Error allocating BUFI' 1273 CALL MUMPS_ABORT() 1274 END IF 1275 ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) 1276 IF ( allocok .GT. 0 ) THEN 1277 WRITE(*,*) 'Error allocating BUFR' 1278 CALL MUMPS_ABORT() 1279 END IF 1280 DO I = 1, NBUFS 1281 BUFI( 1, I ) = 0 1282 ENDDO 1283 ENDIF 1284 INODE = KEEP(38) 1285 I = 1 1286 DO WHILE ( INODE .GT. 0 ) 1287 RG2L( INODE ) = I 1288 INODE = FILS( INODE ) 1289 I = I + 1 1290 END DO 1291 DO 120 K=1,NZ 1292 IOLD = IRN(K) 1293 JOLD = ICN(K) 1294 IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) 1295 & .OR.(JOLD.LT.1) ) THEN 1296 GOTO 120 1297 END IF 1298 IF (LSCAL) THEN 1299 VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) 1300 ELSE 1301 VAL = ASPK(K) 1302 ENDIF 1303 IF (IOLD.EQ.JOLD) THEN 1304 ISEND = IOLD 1305 JSEND = JOLD 1306 ELSE 1307 INEW = PERM(IOLD) 1308 JNEW = PERM(JOLD) 1309 IF (INEW.LT.JNEW) THEN 1310 ISEND = IOLD 1311 IF ( KEEP(50) .NE. 0 ) ISEND = -IOLD 1312 JSEND = JOLD 1313 ELSE 1314 ISEND = -JOLD 1315 JSEND = IOLD 1316 ENDIF 1317 ENDIF 1318 IARR = abs( ISEND ) 1319 ISTEP = abs( STEP(IARR) ) 1320 TYPENODE_TMP = MUMPS_330( PROCNODE_STEPS(ISTEP), 1321 & SLAVEF ) 1322 MASTER_NODE = MUMPS_275( PROCNODE_STEPS(ISTEP), 1323 & SLAVEF ) 1324 TYPESPLIT = MUMPS_810( PROCNODE_STEPS(ISTEP), 1325 & SLAVEF ) 1326 I_AM_CAND_LOC = .FALSE. 1327 T4_MASTER_CONCERNED = .FALSE. 1328 T4MASTER = -9999 1329 IF (TYPENODE_TMP.EQ.2) THEN 1330 INIV2 = ISTEP_TO_INIV2(ISTEP) 1331 IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) 1332 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN 1333 T4_MASTER_CONCERNED = .TRUE. 1334 T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) 1335 IF ( KEEP(46) .eq. 0 ) THEN 1336 T4MASTER=T4MASTER+1 1337 ENDIF 1338 ENDIF 1339 ENDIF 1340 IF ( TYPENODE_TMP .EQ. 1 ) THEN 1341 IF ( KEEP(46) .eq. 0 ) THEN 1342 DEST = MASTER_NODE + 1 1343 ELSE 1344 DEST = MASTER_NODE 1345 END IF 1346 ELSE IF ( TYPENODE_TMP .EQ. 2 ) THEN 1347 IF ( ISEND .LT. 0 ) THEN 1348 DEST = -1 1349 ELSE 1350 IF ( KEEP( 46 ) .eq. 0 ) THEN 1351 DEST = MASTER_NODE + 1 1352 ELSE 1353 DEST = MASTER_NODE 1354 END IF 1355 END IF 1356 ELSE 1357 IF ( ISEND .LT. 0 ) THEN 1358 IPOSROOT = RG2L(JSEND) 1359 JPOSROOT = RG2L(IARR) 1360 ELSE 1361 IPOSROOT = RG2L( IARR ) 1362 JPOSROOT = RG2L( JSEND ) 1363 END IF 1364 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) 1365 JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) 1366 IF ( KEEP( 46 ) .eq. 0 ) THEN 1367 DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 1368 ELSE 1369 DEST = IROW_GRID * root%NPCOL + JCOL_GRID 1370 END IF 1371 END IF 1372 IF ( DEST .eq. 0 .or. 1373 & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. 1374 & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) 1375 & .or. 1376 & ( T4MASTER.EQ.0 ) 1377 & ) THEN 1378 IARR = ISEND 1379 JARR = JSEND 1380 IF ( TYPENODE_TMP .eq. 3 ) THEN 1381 ARROW_ROOT = ARROW_ROOT + 1 1382 IF ( IROW_GRID .EQ. root%MYROW .AND. 1383 & JCOL_GRID .EQ. root%MYCOL ) THEN 1384 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / 1385 & ( root%MBLOCK * root%NPROW ) ) 1386 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 1387 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / 1388 & ( root%NBLOCK * root%NPCOL ) ) 1389 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 1390 IF (KEEP(60)==0) THEN 1391 A( PTR_ROOT 1392 & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) 1393 & + int(ILOCROOT - 1,8) ) 1394 & = A( PTR_ROOT 1395 & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) 1396 & + int(ILOCROOT - 1,8) ) 1397 & + VAL 1398 ELSE 1399 root%SCHUR_POINTER( int(JLOCROOT - 1,8) 1400 & * int(root%SCHUR_LLD,8) 1401 & + int(ILOCROOT,8) ) 1402 & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) 1403 & * int(root%SCHUR_LLD,8) 1404 & + int(ILOCROOT,8)) 1405 & + VAL 1406 ENDIF 1407 ELSE 1408 WRITE(*,*) MYID,':INTERNAL Error: root arrowhead ' 1409 WRITE(*,*) MYID,':is not belonging to me. IARR,JARR=' 1410 & ,IARR,JARR 1411 CALL MUMPS_ABORT() 1412 END IF 1413 ELSE IF ( IARR .GE. 0 ) THEN 1414 IF ( IARR .eq. JARR ) THEN 1415 IA = PTRARW( IARR ) 1416 DBLARR( IA ) = DBLARR( IA ) + VAL 1417 ELSE 1418 IS1 = PTRAIW(IARR) 1419 ISHIFT = INTARR(IS1) + IW4(IARR,2) 1420 IW4(IARR,2) = IW4(IARR,2) - 1 1421 IIW = IS1 + ISHIFT + 2 1422 INTARR(IIW) = JARR 1423 IS = PTRARW(IARR) 1424 IAS = IS + ISHIFT 1425 DBLARR(IAS) = VAL 1426 END IF 1427 ELSE 1428 IARR = -IARR 1429 ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 1430 INTARR(ISHIFT) = JARR 1431 IAS = PTRARW(IARR)+IW4(IARR,1) 1432 IW4(IARR,1) = IW4(IARR,1) - 1 1433 DBLARR(IAS) = VAL 1434 IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 ) 1435 & .AND. IW4(IARR,1) .EQ. 0 .AND. 1436 & STEP( IARR) > 0 ) THEN 1437 IF (MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), 1438 & SLAVEF ) == MYID) THEN 1439 TAILLE = INTARR( PTRAIW(IARR) ) 1440 CALL DMUMPS_310( N, PERM, 1441 & INTARR( PTRAIW(IARR) + 3 ), 1442 & DBLARR( PTRARW(IARR) + 1 ), 1443 & TAILLE, 1, TAILLE ) 1444 END IF 1445 END IF 1446 ENDIF 1447 END IF 1448 IF ( DEST.EQ. -1 ) THEN 1449 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) 1450 DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 1451 IF (KEEP(46).EQ.0) DEST=DEST+1 1452 IF (DEST.NE.0) 1453 & CALL DMUMPS_34( ISEND, JSEND, VAL, 1454 & DEST, BUFI, BUFR, NBRECORDS, NBUFS, 1455 & LP, COMM, KEEP(46)) 1456 ENDDO 1457 DEST = MASTER_NODE 1458 IF (KEEP(46).EQ.0) DEST=DEST+1 1459 IF ( DEST .NE. 0 ) THEN 1460 CALL DMUMPS_34( ISEND, JSEND, VAL, 1461 & DEST, BUFI, BUFR, NBRECORDS, NBUFS, 1462 & LP, COMM, KEEP(46)) 1463 ENDIF 1464 IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN 1465 CALL DMUMPS_34( ISEND, JSEND, VAL, 1466 & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, 1467 & LP, COMM, KEEP(46)) 1468 ENDIF 1469 ELSE IF ( DEST .GT. 0 ) THEN 1470 CALL DMUMPS_34( ISEND, JSEND, VAL, 1471 & DEST, BUFI, BUFR, NBRECORDS, NBUFS, 1472 & LP, COMM, KEEP(46)) 1473 IF ( T4MASTER.GT.0 ) THEN 1474 CALL DMUMPS_34( ISEND, JSEND, VAL, 1475 & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, 1476 & LP, COMM, KEEP(46)) 1477 ENDIF 1478 ELSE IF ( T4MASTER.GT.0 ) THEN 1479 CALL DMUMPS_34( ISEND, JSEND, VAL, 1480 & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, 1481 & LP, COMM, KEEP(46)) 1482 END IF 1483 120 CONTINUE 1484 KEEP(49) = ARROW_ROOT 1485 IF (NBUFS.GT.0) THEN 1486 CALL DMUMPS_18( 1487 & BUFI, BUFR, NBRECORDS, NBUFS, 1488 & LP, COMM, KEEP( 46 ) ) 1489 ENDIF 1490 IF ( KEEP( 46 ) .NE. 0 ) DEALLOCATE( IW4 ) 1491 IF (NBUFS.GT.0) THEN 1492 DEALLOCATE( BUFI ) 1493 DEALLOCATE( BUFR ) 1494 ENDIF 1495 RETURN 1496 END SUBROUTINE DMUMPS_148 1497 SUBROUTINE DMUMPS_34(ISEND, JSEND, VAL, 1498 & DEST, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, 1499 & TYPE_PARALL ) 1500 IMPLICIT NONE 1501 INTEGER ISEND, JSEND, DEST, NBUFS, NBRECORDS, TYPE_PARALL 1502 INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) 1503 DOUBLE PRECISION BUFR( NBRECORDS, NBUFS ) 1504 INTEGER COMM 1505 INTEGER LP 1506 DOUBLE PRECISION VAL 1507 INCLUDE 'mpif.h' 1508 INCLUDE 'mumps_tags.h' 1509 INTEGER IERR 1510 INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ 1511 IF (BUFI(1,DEST)+1.GT.NBRECORDS) THEN 1512 TAILLE_SENDI = BUFI(1,DEST) * 2 + 1 1513 TAILLE_SENDR = BUFI(1,DEST) 1514 CALL MPI_SEND(BUFI(1,DEST),TAILLE_SENDI, 1515 & MPI_INTEGER, 1516 & DEST, ARROWHEAD, COMM, IERR ) 1517 CALL MPI_SEND( BUFR(1,DEST), TAILLE_SENDR, 1518 & MPI_DOUBLE_PRECISION, DEST, 1519 & ARROWHEAD, COMM, IERR ) 1520 BUFI(1,DEST) = 0 1521 ENDIF 1522 IREQ = BUFI(1,DEST) + 1 1523 BUFI(1,DEST) = IREQ 1524 BUFI( IREQ * 2, DEST ) = ISEND 1525 BUFI( IREQ * 2 + 1, DEST ) = JSEND 1526 BUFR( IREQ, DEST ) = VAL 1527 RETURN 1528 END SUBROUTINE DMUMPS_34 1529 SUBROUTINE DMUMPS_18( 1530 & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, 1531 & TYPE_PARALL ) 1532 IMPLICIT NONE 1533 INTEGER NBUFS, NBRECORDS, TYPE_PARALL 1534 INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) 1535 DOUBLE PRECISION BUFR( NBRECORDS, NBUFS ) 1536 INTEGER COMM 1537 INTEGER LP 1538 INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR 1539 INCLUDE 'mpif.h' 1540 INCLUDE 'mumps_tags.h' 1541 DO ISLAVE = 1,NBUFS 1542 TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 1543 TAILLE_SENDR = BUFI(1,ISLAVE) 1544 BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) 1545 CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, 1546 & MPI_INTEGER, 1547 & ISLAVE, ARROWHEAD, COMM, IERR ) 1548 IF ( TAILLE_SENDR .NE. 0 ) THEN 1549 CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, 1550 & MPI_DOUBLE_PRECISION, ISLAVE, 1551 & ARROWHEAD, COMM, IERR ) 1552 END IF 1553 ENDDO 1554 RETURN 1555 END SUBROUTINE DMUMPS_18 1556 RECURSIVE SUBROUTINE DMUMPS_310( N, PERM, 1557 & INTLIST, DBLLIST, TAILLE, LO, HI ) 1558 IMPLICIT NONE 1559 INTEGER N, TAILLE 1560 INTEGER PERM( N ) 1561 INTEGER INTLIST( TAILLE ) 1562 DOUBLE PRECISION DBLLIST( TAILLE ) 1563 INTEGER LO, HI 1564 INTEGER I,J 1565 INTEGER ISWAP, PIVOT 1566 DOUBLE PRECISION dswap 1567 I = LO 1568 J = HI 1569 PIVOT = PERM(INTLIST((I+J)/2)) 1570 10 IF (PERM(INTLIST(I)) < PIVOT) THEN 1571 I=I+1 1572 GOTO 10 1573 ENDIF 1574 20 IF (PERM(INTLIST(J)) > PIVOT) THEN 1575 J=J-1 1576 GOTO 20 1577 ENDIF 1578 IF (I < J) THEN 1579 ISWAP = INTLIST(I) 1580 INTLIST(I) = INTLIST(J) 1581 INTLIST(J)=ISWAP 1582 dswap = DBLLIST(I) 1583 DBLLIST(I) = DBLLIST(J) 1584 DBLLIST(J) = dswap 1585 ENDIF 1586 IF ( I <= J) THEN 1587 I = I+1 1588 J = J-1 1589 ENDIF 1590 IF ( I <= J ) GOTO 10 1591 IF ( LO < J ) CALL DMUMPS_310(N, PERM, 1592 & INTLIST, DBLLIST, TAILLE, LO, J) 1593 IF ( I < HI ) CALL DMUMPS_310(N, PERM, 1594 & INTLIST, DBLLIST, TAILLE, I, HI) 1595 RETURN 1596 END SUBROUTINE DMUMPS_310 1597 SUBROUTINE DMUMPS_145( N, 1598 & DBLARR, LDBLARR, INTARR, LINTARR, PTRAIW, PTRARW, 1599 & KEEP, KEEP8, MYID, COMM, NBRECORDS, 1600 & A, LA, root, 1601 & PROCNODE_STEPS, 1602 & SLAVEF, PERM, FRERE_STEPS, STEP, INFO1, INFO2 1603 & ) 1604 IMPLICIT NONE 1605 INCLUDE 'dmumps_root.h' 1606 INTEGER N, MYID, LDBLARR, LINTARR, 1607 & COMM 1608 INTEGER INTARR(LINTARR) 1609 INTEGER PTRAIW(N), PTRARW(N) 1610 INTEGER KEEP(500) 1611 INTEGER(8) KEEP8(150) 1612 INTEGER(8), intent(IN) :: LA 1613 INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) 1614 INTEGER SLAVEF, NBRECORDS 1615 DOUBLE PRECISION A( LA ) 1616 INTEGER INFO1, INFO2 1617 DOUBLE PRECISION DBLARR(LDBLARR) 1618 TYPE (DMUMPS_ROOT_STRUC) :: root 1619 INTEGER, POINTER, DIMENSION(:) :: BUFI 1620 DOUBLE PRECISION, POINTER, DIMENSION(:) :: BUFR 1621 INTEGER, POINTER, DIMENSION(:,:) :: IW4 1622 LOGICAL FINI 1623 INTEGER IREC, NB_REC, IARR, JARR, IA, I1, I, allocok 1624 INTEGER IS, IS1, ISHIFT, IIW, IAS 1625 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, 1626 & IPOSROOT, JPOSROOT, TAILLE, 1627 & IPROC 1628 INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) 1629 INTEGER(8) :: PTR_ROOT 1630 INTEGER ARROW_ROOT, TYPE_PARALL 1631 INTEGER MUMPS_330, MUMPS_275 1632 EXTERNAL MUMPS_330, MUMPS_275 1633 DOUBLE PRECISION VAL 1634 DOUBLE PRECISION ZERO 1635 PARAMETER( ZERO = 0.0D0 ) 1636 INCLUDE 'mpif.h' 1637 INCLUDE 'mumps_tags.h' 1638 INTEGER MASTER 1639 PARAMETER(MASTER=0) 1640 INTEGER STATUS( MPI_STATUS_SIZE ) 1641 INTEGER IERR 1642 INTEGER numroc 1643 EXTERNAL numroc 1644 TYPE_PARALL = KEEP(46) 1645 ARROW_ROOT=0 1646 ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) 1647 IF ( allocok .GT. 0 ) THEN 1648 INFO1 = -13 1649 INFO2 = NBRECORDS * 2 + 1 1650 WRITE(*,*) MYID,': Could not allocate BUFI: goto 500' 1651 GOTO 500 1652 END IF 1653 ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) 1654 IF ( allocok .GT. 0 ) THEN 1655 INFO1 = -13 1656 INFO2 = NBRECORDS 1657 WRITE(*,*) MYID,': Could not allocate BUFR: goto 500' 1658 GOTO 500 1659 END IF 1660 ALLOCATE( IW4(N,2), stat = allocok ) 1661 IF ( allocok .GT. 0 ) THEN 1662 INFO1 = -13 1663 INFO2 = 2 * N 1664 WRITE(*,*) MYID,': Could not allocate IW4: goto 500' 1665 GOTO 500 1666 END IF 1667 IF ( KEEP(38).NE.0) THEN 1668 IF (KEEP(60)==0) THEN 1669 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, 1670 & root%MYROW, 0, root%NPROW ) 1671 LOCAL_M = max( 1, LOCAL_M ) 1672 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, 1673 & root%MYCOL, 0, root%NPCOL ) 1674 PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 1675 IF ( PTR_ROOT .LE. LA ) THEN 1676 A( PTR_ROOT:LA ) = ZERO 1677 END IF 1678 ELSE 1679 DO I=1, root%SCHUR_NLOC 1680 root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: 1681 & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO 1682 ENDDO 1683 ENDIF 1684 END IF 1685 FINI = .FALSE. 1686 DO I=1,N 1687 I1 = PTRAIW(I) 1688 IA = PTRARW(I) 1689 IF (IA.GT.0) THEN 1690 DBLARR(IA) = ZERO 1691 IW4(I,1) = INTARR(I1) 1692 IW4(I,2) = -INTARR(I1+1) 1693 INTARR(I1+2)=I 1694 ENDIF 1695 ENDDO 1696 DO WHILE (.NOT.FINI) 1697 CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, 1698 & MPI_INTEGER, MASTER, 1699 & ARROWHEAD, 1700 & COMM, STATUS, IERR ) 1701 NB_REC = BUFI(1) 1702 IF (NB_REC.LE.0) THEN 1703 FINI = .TRUE. 1704 NB_REC = -NB_REC 1705 ENDIF 1706 IF (NB_REC.EQ.0) EXIT 1707 CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_DOUBLE_PRECISION, 1708 & MASTER, ARROWHEAD, 1709 & COMM, STATUS, IERR ) 1710 DO IREC=1, NB_REC 1711 IARR = BUFI( IREC * 2 ) 1712 JARR = BUFI( IREC * 2 + 1 ) 1713 VAL = BUFR( IREC ) 1714 IF ( MUMPS_330( PROCNODE_STEPS(abs(STEP(abs(IARR)))), 1715 & SLAVEF ) .eq. 3 ) THEN 1716 ARROW_ROOT = ARROW_ROOT + 1 1717 IF ( IARR .GT. 0 ) THEN 1718 IPOSROOT = root%RG2L_ROW( IARR ) 1719 JPOSROOT = root%RG2L_COL( JARR ) 1720 ELSE 1721 IPOSROOT = root%RG2L_ROW( JARR ) 1722 JPOSROOT = root%RG2L_COL( -IARR ) 1723 END IF 1724 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / 1725 & ( root%MBLOCK * root%NPROW ) ) 1726 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 1727 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / 1728 & ( root%NBLOCK * root%NPCOL ) ) 1729 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 1730 IF (KEEP(60)==0) THEN 1731 A( PTR_ROOT + int(JLOCROOT - 1,8) * int(LOCAL_M,8) 1732 & + int(ILOCROOT - 1,8) ) 1733 & = A( PTR_ROOT + int(JLOCROOT - 1,8) 1734 & * int(LOCAL_M,8) 1735 & + int(ILOCROOT - 1,8)) 1736 & + VAL 1737 ELSE 1738 root%SCHUR_POINTER( int(JLOCROOT-1,8) 1739 & * int(root%SCHUR_LLD,8) 1740 & + int(ILOCROOT,8) ) 1741 & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) 1742 & * int(root%SCHUR_LLD,8) 1743 & + int(ILOCROOT,8)) 1744 & + VAL 1745 ENDIF 1746 ELSE IF (IARR.GE.0) THEN 1747 IF (IARR.EQ.JARR) THEN 1748 IA = PTRARW(IARR) 1749 DBLARR(IA) = DBLARR(IA) + VAL 1750 ELSE 1751 IS1 = PTRAIW(IARR) 1752 ISHIFT = INTARR(IS1) + IW4(IARR,2) 1753 IW4(IARR,2) = IW4(IARR,2) - 1 1754 IIW = IS1 + ISHIFT + 2 1755 INTARR(IIW) = JARR 1756 IS = PTRARW(IARR) 1757 IAS = IS + ISHIFT 1758 DBLARR(IAS) = VAL 1759 ENDIF 1760 ELSE 1761 IARR = -IARR 1762 ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 1763 INTARR(ISHIFT) = JARR 1764 IAS = PTRARW(IARR)+IW4(IARR,1) 1765 IW4(IARR,1) = IW4(IARR,1) - 1 1766 DBLARR(IAS) = VAL 1767 IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) 1768 & .AND. IW4(IARR,1) .EQ. 0 1769 & .AND. STEP(IARR) > 0 ) THEN 1770 IPROC = MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), 1771 & SLAVEF ) 1772 IF ( TYPE_PARALL .eq. 0 ) THEN 1773 IPROC = IPROC + 1 1774 END IF 1775 IF (IPROC .EQ. MYID) THEN 1776 TAILLE = INTARR( PTRAIW(IARR) ) 1777 CALL DMUMPS_310( N, PERM, 1778 & INTARR( PTRAIW(IARR) + 3 ), 1779 & DBLARR( PTRARW(IARR) + 1 ), 1780 & TAILLE, 1, TAILLE ) 1781 END IF 1782 END IF 1783 ENDIF 1784 ENDDO 1785 END DO 1786 DEALLOCATE( BUFI ) 1787 DEALLOCATE( BUFR ) 1788 DEALLOCATE( IW4 ) 1789 500 CONTINUE 1790 KEEP(49) = ARROW_ROOT 1791 RETURN 1792 END SUBROUTINE DMUMPS_145 1793 SUBROUTINE DMUMPS_266( MYID, BUFR, LBUFR, 1794 & LBUFR_BYTES, 1795 & IWPOS, IWPOSCB, 1796 & IPTRLU, LRLU, LRLUS, 1797 & TNBPROCFILS, N, IW, LIW, A, LA, 1798 & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, 1799 & KEEP,KEEP8, ITLOC, RHS_MUMPS, 1800 & IFLAG, IERROR ) 1801 USE DMUMPS_LOAD 1802 IMPLICIT NONE 1803 INTEGER MYID 1804 INTEGER KEEP(500) 1805 INTEGER(8) KEEP8(150) 1806 INTEGER LBUFR, LBUFR_BYTES 1807 INTEGER BUFR( LBUFR ) 1808 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA 1809 INTEGER IWPOS, IWPOSCB, N, LIW 1810 INTEGER IW( LIW ) 1811 DOUBLE PRECISION A( LA ) 1812 INTEGER(8) :: PAMASTER(KEEP(28)) 1813 INTEGER(8) :: PTRAST(KEEP(28)) 1814 INTEGER PTRIST(KEEP(28)), STEP(N), 1815 & PIMASTER(KEEP(28)), 1816 & TNBPROCFILS( KEEP(28) ), ITLOC( N + KEEP(253) ) 1817 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 1818 INTEGER COMP, IFLAG, IERROR 1819 INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES 1820 INTEGER NSLAVES_RECU, NFRONT 1821 INTEGER LREQ 1822 INTEGER(8) :: LREQCB 1823 DOUBLE PRECISION FLOP1 1824 INCLUDE 'mumps_headers.h' 1825 INODE = BUFR( 1 ) 1826 NBPROCFILS = BUFR( 2 ) 1827 NROW = BUFR( 3 ) 1828 NCOL = BUFR( 4 ) 1829 NASS = BUFR( 5 ) 1830 NFRONT = BUFR( 6 ) 1831 NSLAVES_RECU = BUFR( 7 ) 1832 IF ( KEEP(50) .eq. 0 ) THEN 1833 FLOP1 = dble( NASS * NROW ) + 1834 & dble(NROW*NASS)*dble(2*NCOL-NASS-1) 1835 ELSE 1836 FLOP1 = dble( NASS ) * dble( NROW ) 1837 & * dble( 2 * NCOL - NROW - NASS + 1) 1838 END IF 1839 CALL DMUMPS_190(1,.TRUE.,FLOP1, KEEP,KEEP8) 1840 IF ( KEEP(50) .eq. 0 ) THEN 1841 NSLAVES = NSLAVES_RECU + XTRA_SLAVES_UNSYM 1842 ELSE 1843 NSLAVES = NSLAVES_RECU + XTRA_SLAVES_SYM 1844 END IF 1845 LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) 1846 LREQCB = int(NCOL,8) * int(NROW,8) 1847 CALL DMUMPS_22(.FALSE., 0_8, .FALSE.,.TRUE., 1848 & MYID,N, KEEP,KEEP8, IW, LIW, A, LA, 1849 & LRLU, IPTRLU,IWPOS,IWPOSCB, 1850 & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, 1851 & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., 1852 & COMP, LRLUS, IFLAG, IERROR 1853 & ) 1854 IF ( IFLAG .LT. 0 ) RETURN 1855 PTRIST(STEP(INODE)) = IWPOSCB + 1 1856 PTRAST(STEP(INODE)) = IPTRLU + 1_8 1857 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL 1858 IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS 1859 IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW 1860 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 1861 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS 1862 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES 1863 IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : 1864 & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) 1865 &= BUFR( 8 + NSLAVES_RECU : 7 + NSLAVES_RECU + NROW + NCOL ) 1866 IF ( KEEP(50) .eq. 0 ) THEN 1867 IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT 1868 IF (NSLAVES_RECU.GT.0) 1869 & IW( IWPOSCB + 7+XTRA_SLAVES_UNSYM+KEEP(IXSZ): 1870 & IWPOSCB+6+KEEP(IXSZ)+NSLAVES_RECU ) = 1871 & BUFR( 8: 7 + NSLAVES_RECU ) 1872 ELSE 1873 IW( IWPOSCB + 7+KEEP(IXSZ) ) = 0 1874 IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT 1875 IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT 1876 IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): 1877 & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_RECU ) = 1878 & BUFR( 8: 7 + NSLAVES_RECU ) 1879 END IF 1880 TNBPROCFILS(STEP( INODE )) = NBPROCFILS 1881 RETURN 1882 END SUBROUTINE DMUMPS_266 1883 SUBROUTINE DMUMPS_163( id ) 1884 USE DMUMPS_STRUC_DEF 1885 USE DMUMPS_COMM_BUFFER 1886 IMPLICIT NONE 1887 INCLUDE 'mpif.h' 1888 TYPE (DMUMPS_STRUC) id 1889 INTEGER MASTER, IERR,PAR_loc,SYM_loc 1890 PARAMETER( MASTER = 0 ) 1891 INTEGER color 1892 CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) 1893 PAR_loc=id%PAR 1894 SYM_loc=id%SYM 1895 CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) 1896 CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) 1897 IF ( PAR_loc .eq. 0 ) THEN 1898 IF ( id%MYID .eq. MASTER ) THEN 1899 color = MPI_UNDEFINED 1900 ELSE 1901 color = 0 1902 END IF 1903 CALL MPI_COMM_SPLIT( id%COMM, color, 0, 1904 & id%COMM_NODES, IERR ) 1905 id%NSLAVES = id%NPROCS - 1 1906 ELSE 1907 CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) 1908 id%NSLAVES = id%NPROCS 1909 END IF 1910 IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN 1911 CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) 1912 ENDIF 1913 CALL DMUMPS_20( id%NSLAVES, id%LWK_USER, 1914 & id%CNTL(1), id%ICNTL(1), 1915 & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), 1916 & id%RINFO(1), id%RINFOG(1), 1917 & SYM_loc, PAR_loc, id%DKEEP(1) ) 1918 id%WRITE_PROBLEM="NAME_NOT_INITIALIZED" 1919 CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) 1920 id%OOC_TMPDIR="NAME_NOT_INITIALIZED" 1921 id%OOC_PREFIX="NAME_NOT_INITIALIZED" 1922 id%NRHS = 1 1923 id%LRHS = 0 1924 id%LREDRHS = 0 1925 CALL DMUMPS_61( id%KEEP( 34 ), id%KEEP(35) ) 1926 NULLIFY(id%BUFR) 1927 id%MAXIS1 = 0 1928 id%INST_Number = -1 1929 id%N = 0; id%NZ = 0 1930 NULLIFY(id%IRN) 1931 NULLIFY(id%JCN) 1932 NULLIFY(id%A) 1933 id%NZ_loc = 0 1934 NULLIFY(id%IRN_loc) 1935 NULLIFY(id%JCN_loc) 1936 NULLIFY(id%A_loc) 1937 NULLIFY(id%MAPPING) 1938 NULLIFY(id%RHS) 1939 NULLIFY(id%REDRHS) 1940 id%NZ_RHS=0 1941 NULLIFY(id%RHS_SPARSE) 1942 NULLIFY(id%IRHS_SPARSE) 1943 NULLIFY(id%IRHS_PTR) 1944 NULLIFY(id%ISOL_loc) 1945 id%LSOL_loc=0 1946 NULLIFY(id%SOL_loc) 1947 NULLIFY(id%COLSCA) 1948 NULLIFY(id%ROWSCA) 1949 NULLIFY(id%PERM_IN) 1950 NULLIFY(id%IS) 1951 NULLIFY(id%IS1) 1952 NULLIFY(id%STEP) 1953 NULLIFY(id%Step2node) 1954 NULLIFY(id%DAD_STEPS) 1955 NULLIFY(id%NE_STEPS) 1956 NULLIFY(id%ND_STEPS) 1957 NULLIFY(id%FRERE_STEPS) 1958 NULLIFY(id%SYM_PERM) 1959 NULLIFY(id%UNS_PERM) 1960 NULLIFY(id%PIVNUL_LIST) 1961 NULLIFY(id%FILS) 1962 NULLIFY(id%PTRAR) 1963 NULLIFY(id%FRTPTR) 1964 NULLIFY(id%FRTELT) 1965 NULLIFY(id%NA) 1966 id%LNA=0 1967 NULLIFY(id%PROCNODE_STEPS) 1968 NULLIFY(id%S) 1969 NULLIFY(id%PROCNODE) 1970 NULLIFY(id%POIDS) 1971 NULLIFY(id%PTLUST_S) 1972 NULLIFY(id%PTRFAC) 1973 NULLIFY(id%INTARR) 1974 NULLIFY(id%DBLARR) 1975 NULLIFY(id%DEPTH_FIRST) 1976 NULLIFY(id%DEPTH_FIRST_SEQ) 1977 NULLIFY(id%SBTR_ID) 1978 NULLIFY(id%MEM_SUBTREE) 1979 NULLIFY(id%MEM_SUBTREE) 1980 NULLIFY(id%MY_ROOT_SBTR) 1981 NULLIFY(id%MY_FIRST_LEAF) 1982 NULLIFY(id%MY_NB_LEAF) 1983 NULLIFY(id%COST_TRAV) 1984 NULLIFY(id%RHSCOMP) 1985 NULLIFY(id%POSINRHSCOMP) 1986 NULLIFY(id%OOC_INODE_SEQUENCE) 1987 NULLIFY(id%OOC_TOTAL_NB_NODES) 1988 NULLIFY(id%OOC_SIZE_OF_BLOCK) 1989 NULLIFY(id%OOC_FILE_NAME_LENGTH) 1990 NULLIFY(id%OOC_FILE_NAMES) 1991 NULLIFY(id%OOC_VADDR) 1992 NULLIFY(id%OOC_NB_FILES) 1993 NULLIFY(id%CB_SON_SIZE) 1994 NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) 1995 NULLIFY(id%root%RHS_ROOT) 1996 NULLIFY(id%root%RG2L_ROW) 1997 NULLIFY(id%root%RG2L_COL) 1998 NULLIFY(id%root%IPIV) 1999 NULLIFY(id%root%SCHUR_POINTER) 2000 NULLIFY(id%SCHUR_CINTERFACE) 2001 id%NELT=0 2002 NULLIFY(id%ELTPTR) 2003 NULLIFY(id%ELTVAR) 2004 NULLIFY(id%A_ELT) 2005 NULLIFY(id%ELTPROC) 2006 id%SIZE_SCHUR = 0 2007 NULLIFY( id%LISTVAR_SCHUR ) 2008 NULLIFY( id%SCHUR ) 2009 id%NPROW = 0 2010 id%NPCOL = 0 2011 id%MBLOCK = 0 2012 id%NBLOCK = 0 2013 id%SCHUR_MLOC = 0 2014 id%SCHUR_NLOC = 0 2015 id%SCHUR_LLD = 0 2016 NULLIFY(id%ISTEP_TO_INIV2) 2017 NULLIFY(id%I_AM_CAND) 2018 NULLIFY(id%FUTURE_NIV2) 2019 NULLIFY(id%TAB_POS_IN_PERE) 2020 NULLIFY(id%CANDIDATES) 2021 CALL DMUMPS_637(id) 2022 NULLIFY(id%MEM_DIST) 2023 NULLIFY(id%SUP_PROC) 2024 id%Deficiency = 0 2025 id%root%LPIV = -1 2026 id%root%yes = .FALSE. 2027 id%root%gridinit_done = .FALSE. 2028 IF ( id%KEEP( 46 ) .ne. 0 .OR. 2029 & id%MYID .ne. MASTER ) THEN 2030 CALL MPI_COMM_RANK 2031 & (id%COMM_NODES, id%MYID_NODES, IERR ) 2032 ELSE 2033 id%MYID_NODES = -464646 2034 ENDIF 2035 RETURN 2036 END SUBROUTINE DMUMPS_163 2037 SUBROUTINE DMUMPS_252( COMM_LOAD, ASS_IRECV, 2038 & N, INODE, IW, LIW, A, LA, IFLAG, 2039 & IERROR, ND, 2040 & FILS, FRERE, DAD, MAXFRW, root, 2041 & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, 2042 & STEP, PIMASTER, PAMASTER,PTRARW, 2043 & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, 2044 & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, 2045 & ICNTL, KEEP,KEEP8,INTARR,DBLARR, 2046 & 2047 & NSTK_S,NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, 2048 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, 2049 & PERM, 2050 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS 2051 & ) 2052 USE DMUMPS_COMM_BUFFER 2053 USE DMUMPS_LOAD 2054 IMPLICIT NONE 2055 INCLUDE 'dmumps_root.h' 2056 INCLUDE 'mpif.h' 2057 INTEGER STATUS( MPI_STATUS_SIZE ), IERR 2058 TYPE (DMUMPS_ROOT_STRUC) :: root 2059 INTEGER COMM_LOAD, ASS_IRECV 2060 INTEGER IZERO 2061 PARAMETER (IZERO=0) 2062 INTEGER N,LIW,NSTEPS 2063 INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC 2064 INTEGER KEEP(500), ICNTL(40) 2065 INTEGER(8) KEEP8(150) 2066 INTEGER IFLAG,IERROR,INODE,MAXFRW, 2067 & IWPOS, IWPOSCB, COMP 2068 INTEGER JOBASS,ETATASS 2069 LOGICAL SON_LEVEL2 2070 DOUBLE PRECISION A(LA) 2071 DOUBLE PRECISION OPASSW, OPELIW 2072 INTEGER COMM, NBFIN, SLAVEF, MYID 2073 INTEGER LPOOL, LEAF 2074 INTEGER LBUFR, LBUFR_BYTES 2075 INTEGER NBPROCFILS(KEEP(28)) 2076 INTEGER NSTK_S(KEEP(28)),PROCNODE_STEPS(KEEP(28)) 2077 INTEGER IPOOL( LPOOL ) 2078 INTEGER BUFR( LBUFR ) 2079 INTEGER IDUMMY(1) 2080 INTEGER IW(LIW), ITLOC(N+KEEP(253)), 2081 & PTRARW(N), PTRAIW(N), ND(KEEP(28)), PERM(N), 2082 & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), 2083 & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), 2084 & STEP(N), PIMASTER(KEEP(28)) 2085 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 2086 INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), 2087 & PAMASTER(KEEP(28)) 2088 INTEGER ISTEP_TO_INIV2(KEEP(71)), 2089 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 2090 INTEGER INTARR(max(1,KEEP(14))) 2091 DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 2092 INTEGER MUMPS_330 2093 EXTERNAL MUMPS_330 2094 INTEGER LP, HS, HF 2095 INTEGER NBPANELS_L, NBPANELS_U 2096 INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL 2097 INTEGER NFS4FATHER 2098 INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8 2099 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ 2100 INTEGER LREQ_OOC 2101 INTEGER(8) :: SIZFR 2102 INTEGER SIZFI, NCB 2103 INTEGER J1,J2 2104 INTEGER NCOLS, NROWS, LDA_SON 2105 INTEGER(8) :: JJ2, ICT13 2106#if defined(ALLOW_NON_INIT) 2107 INTEGER(8) :: NUMROWS, JJ3, JJ8, APOS_ini 2108#endif 2109 INTEGER NELIM,JJ,JJ1,J3, 2110 & IBROT,IORG 2111 INTEGER JPOS,ICT11 2112 INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4 2113 INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini 2114 INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 2115 INTEGER AINPUT 2116 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV 2117 INTEGER PTRCOL, ISLAVE, PDEST,LEVEL 2118 INTEGER ISON_IN_PLACE 2119 INTEGER ISON_TOP 2120 INTEGER(8) SIZE_ISON_TOP8 2121 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, 2122 & RISK_OF_SAME_POS_THIS_LINE, OMP_PARALLEL_FLAG 2123 LOGICAL LEVEL1, NIV1 2124 INTEGER TROW_SIZE 2125 INTEGER INDX, FIRST_INDEX, SHIFT_INDEX 2126 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 2127 INCLUDE 'mumps_headers.h' 2128 INTEGER NCBSON 2129 LOGICAL SAME_PROC 2130 INTRINSIC real 2131 DOUBLE PRECISION ZERO 2132 PARAMETER( ZERO = 0.0D0 ) 2133 INTEGER NELT, LPTRAR 2134 EXTERNAL MUMPS_167 2135 LOGICAL MUMPS_167 2136 LOGICAL SSARBR 2137 LOGICAL COMPRESSCB 2138 INTEGER(8) :: LCB 2139 DOUBLE PRECISION FLOP1,FLOP1_EFF 2140 EXTERNAL MUMPS_170 2141 LOGICAL MUMPS_170 2142 COMPRESSCB =.FALSE. 2143 NELT = 1 2144 LPTRAR = N 2145 NFS4FATHER = -1 2146 IN = INODE 2147 NBPROCFILS(STEP(IN)) = 0 2148 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 2149 IF (LEVEL.NE.1) THEN 2150 write(6,*) 'Error1 in mpi51f_niv1 ' 2151 CALL MUMPS_ABORT() 2152 ENDIF 2153 NSLAVES = 0 2154 HF = 6 + NSLAVES + KEEP(IXSZ) 2155 IF (JOBASS.EQ.0) THEN 2156 ETATASS= 0 2157 ELSE 2158 ETATASS= 2 2159 IOLDPS = PTLUST_S(STEP(INODE)) 2160 NFRONT = IW(IOLDPS + KEEP(IXSZ)) 2161 NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) 2162 ICT11 = IOLDPS + HF - 1 + NFRONT 2163 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)), 2164 & SLAVEF) 2165 NUMORG = 0 2166 DO WHILE (IN.GT.0) 2167 NUMORG = NUMORG + 1 2168 IN = FILS(IN) 2169 ENDDO 2170 NUMSTK = 0 2171 IFSON = -IN 2172 ISON = IFSON 2173 IF (ISON .NE. 0) THEN 2174 DO WHILE (ISON .GT. 0) 2175 NUMSTK = NUMSTK + 1 2176 ISON = FRERE(STEP(ISON)) 2177 ENDDO 2178 ENDIF 2179 GOTO 123 2180 ENDIF 2181 NUMORG = 0 2182 DO WHILE (IN.GT.0) 2183 NUMORG = NUMORG + 1 2184 IN = FILS(IN) 2185 ENDDO 2186 NPIV_ANA=NUMORG 2187 NSTEPS = NSTEPS + 1 2188 NUMSTK = 0 2189 NASS = 0 2190 IFSON = -IN 2191 ISON = IFSON 2192 IF (ISON .NE. 0) THEN 2193 DO WHILE (ISON .GT. 0) 2194 NUMSTK = NUMSTK + 1 2195 NASS = NASS + IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) 2196 ISON = FRERE(STEP(ISON)) 2197 ENDDO 2198 ENDIF 2199 NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) 2200 NASS1 = NASS + NUMORG 2201 LREQ_OOC = 0 2202 IF (KEEP(201).EQ.1) THEN 2203 CALL DMUMPS_684( KEEP(50), NFRONT, NFRONT, NASS1, 2204 & NBPANELS_L, NBPANELS_U, LREQ_OOC) 2205 ENDIF 2206 LREQ = HF + 2 * NFRONT + LREQ_OOC 2207 IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN 2208 CALL DMUMPS_94(N, KEEP(28), 2209 & IW, LIW, A, LA, 2210 & LRLU, IPTRLU, 2211 & IWPOS, IWPOSCB, PTRIST, PTRAST, 2212 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 2213 & KEEP(IXSZ)) 2214 COMP = COMP+1 2215 IF (LRLU .NE. LRLUS) THEN 2216 WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' 2217 WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS 2218 GOTO 270 2219 ENDIF 2220 IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 2221 ENDIF 2222 IOLDPS = IWPOS 2223 IWPOS = IWPOS + LREQ 2224 ISON_TOP = -9999 2225 ISON_IN_PLACE = -9999 2226 SIZE_ISON_TOP8 = 0_8 2227 IF (KEEP(234).NE.0) THEN 2228 IF ( IWPOSCB .NE. LIW ) THEN 2229 IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN 2230 ISON = IW( IWPOSCB + 1 + XXN ) 2231 IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. 2232 & MUMPS_330(PROCNODE_STEPS(STEP(ISON)),SLAVEF) 2233 & .EQ. 1 ) 2234 & THEN 2235 ISON_TOP = ISON 2236 CALL MUMPS_729(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) 2237 IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN 2238 ISON_IN_PLACE = ISON 2239 ENDIF 2240 END IF 2241 END IF 2242 END IF 2243 END IF 2244 NIV1 = .TRUE. 2245 IF (KEEP(50).EQ.0 .AND. KEEP(234) .EQ. 0) THEN 2246 CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, 2247 & NFRONT_EFF, DAD, 2248 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 2249 & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, 2250 & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, 2251 & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, 2252 & PROCNODE_STEPS, SLAVEF ) 2253 ELSE 2254 CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, 2255 & NFRONT, NFRONT_EFF, PERM, DAD, 2256 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 2257 & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, 2258 & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, 2259 & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, 2260 & ISON_IN_PLACE, 2261 & PROCNODE_STEPS, SLAVEF) 2262 IF (IFLAG.LT.0) GOTO 300 2263 ENDIF 2264 IF (NFRONT_EFF.NE.NFRONT) THEN 2265 IF (NFRONT.GT.NFRONT_EFF) THEN 2266 IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), 2267 & SLAVEF))THEN 2268 NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) 2269 CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), 2270 & NPIV,NPIV, 2271 & KEEP(50),1,FLOP1) 2272 NPIV=NPIV_ANA 2273 CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), 2274 & NPIV,NPIV, 2275 & KEEP(50),1,FLOP1_EFF) 2276 CALL DMUMPS_190(0,.FALSE.,FLOP1-FLOP1_EFF, 2277 & KEEP,KEEP8) 2278 ENDIF 2279 IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) 2280 NFRONT = NFRONT_EFF 2281 LREQ = HF + 2 * NFRONT + LREQ_OOC 2282 ELSE 2283 Write(*,*) ' ERROR 1 during ass_niv1', NFRONT, NFRONT_EFF 2284 GOTO 270 2285 ENDIF 2286 ENDIF 2287 NFRONT8=int(NFRONT,8) 2288 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 2289 CALL DMUMPS_691(KEEP(50), 2290 & NBPANELS_L, NBPANELS_U, NASS1, 2291 & IOLDPS + HF + 2 * NFRONT, IW, LIW) 2292 ENDIF 2293 NCB = NFRONT - NASS1 2294 MAXFRW = max0(MAXFRW, NFRONT) 2295 ICT11 = IOLDPS + HF - 1 + NFRONT 2296 LAELL8 = NFRONT8 * NFRONT8 2297 LAELL_REQ8 = LAELL8 2298 IF ( ISON_IN_PLACE > 0 ) THEN 2299 LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 2300 ENDIF 2301 IF (LRLU .LT. LAELL_REQ8) THEN 2302 IF (LRLUS .LT. LAELL_REQ8) THEN 2303 GOTO 280 2304 ELSE 2305 CALL DMUMPS_94 2306 & (N, KEEP(28), IW, LIW, A, LA, LRLU, IPTRLU, 2307 & IWPOS, IWPOSCB, PTRIST, PTRAST, STEP, PIMASTER, 2308 & PAMASTER,KEEP(216),LRLUS,KEEP(IXSZ)) 2309 COMP = COMP + 1 2310 IF (LRLU .NE. LRLUS) THEN 2311 WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' 2312 WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS 2313 GOTO 280 2314 ENDIF 2315 ENDIF 2316 ENDIF 2317 LRLU = LRLU - LAELL8 2318 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 2319 KEEP8(67) = min(LRLUS, KEEP8(67)) 2320 POSELT = POSFAC 2321 POSFAC = POSFAC + LAELL8 2322 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 2323 CALL DMUMPS_471(SSARBR,.FALSE., 2324 & LA-LRLUS, 2325 & 0_8, 2326 & LAELL8-SIZE_ISON_TOP8, 2327 & KEEP,KEEP8, 2328 & LRLU) 2329#if ! defined(ALLOW_NON_INIT) 2330 LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) 2331 A(POSELT:LAPOS2) = ZERO 2332#else 2333 IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN 2334 LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) 2335 DO JJ8 = POSELT, LAPOS2 2336 A( JJ8 ) = ZERO 2337 ENDDO 2338 ELSE 2339 IF (ETATASS.EQ.1) THEN 2340 APOS_ini = POSELT 2341 DO JJ8 = 0_8, NFRONT8 - 1_8 2342 JJ3 = min(JJ8,int(NASS1-1,8)) 2343 APOS = APOS_ini + JJ8 * NFRONT8 2344 A(APOS:APOS+JJ3) = ZERO 2345 END DO 2346 ELSE 2347 APOS_ini = POSELT 2348 NUMROWS = min(NFRONT8, (IPTRLU-APOS_ini) / NFRONT8 ) 2349 DO JJ8 = 0_8, NUMROWS - 1_8 2350 APOS = APOS_ini + JJ8 * NFRONT8 2351 A(APOS:APOS + JJ8) = ZERO 2352 ENDDO 2353 IF( NUMROWS .LT. NFRONT8 ) THEN 2354 APOS = APOS_ini + NFRONT8*NUMROWS 2355 A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO 2356 ENDIF 2357 ENDIF 2358 END IF 2359#endif 2360 PTRAST(STEP(INODE)) = POSELT 2361 PTRFAC(STEP(INODE)) = POSELT 2362 PTLUST_S(STEP(INODE)) = IOLDPS 2363 IW(IOLDPS+XXI) = LREQ 2364 CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) 2365 IW(IOLDPS+XXS) =-9999 2366 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 2367 IW(IOLDPS + KEEP(IXSZ)) = NFRONT 2368 IW(IOLDPS + KEEP(IXSZ) + 1) = 0 2369 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 2370 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 2371 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) 2372 IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES 2373 123 CONTINUE 2374 IF (NUMSTK.NE.0) THEN 2375 IF (ISON_TOP > 0) THEN 2376 ISON = ISON_TOP 2377 ELSE 2378 ISON = IFSON 2379 ENDIF 2380 DO 220 IELL = 1, NUMSTK 2381 ISTCHK = PIMASTER(STEP(ISON)) 2382 LSTK = IW(ISTCHK + KEEP(IXSZ)) 2383 NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) 2384 NPIVS = IW(ISTCHK + KEEP(IXSZ) + 3) 2385 IF ( NPIVS .LT. 0 ) NPIVS = 0 2386 NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) 2387 HS = 6 + KEEP(IXSZ) + NSLSON 2388 NCOLS = NPIVS + LSTK 2389 SAME_PROC = (ISTCHK.LE.IWPOS) 2390 IF ( SAME_PROC ) THEN 2391 COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) 2392 ELSE 2393 COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) 2394 ENDIF 2395 LEVEL1 = NSLSON.EQ.0 2396 IF (.NOT.SAME_PROC) THEN 2397 NROWS = IW( ISTCHK + KEEP(IXSZ) + 2) 2398 ELSE 2399 NROWS = NCOLS 2400 ENDIF 2401 SIZFI = HS + NROWS + NCOLS 2402 J1 = ISTCHK + HS + NROWS + NPIVS 2403 IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 2404 IF (LEVEL1) THEN 2405 J2 = J1 + LSTK - 1 2406 SIZFR = int(LSTK,8)*int(LSTK,8) 2407 IF (COMPRESSCB) SIZFR = (int(LSTK,8)*int(LSTK+1,8))/2_8 2408 ELSE 2409 IF ( KEEP(50).eq.0 ) THEN 2410 SIZFR = int(NELIM,8) * int(LSTK,8) 2411 ELSE 2412 SIZFR = int(NELIM,8) * int(NELIM,8) 2413 END IF 2414 J2 = J1 + NELIM - 1 2415 ENDIF 2416 IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR) 2417 IACHK = PAMASTER(STEP(ISON)) 2418 IF ( KEEP(50) .eq. 0 ) THEN 2419 POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 2420 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE 2421 & .AND.IACHK + SIZFR - 1_8 .EQ. POSFAC - 1_8 ) THEN 2422 GOTO 205 2423 ENDIF 2424 IF (J2.GE.J1) THEN 2425 RESET_TO_ZERO = (IACHK .LT. POSFAC) 2426 RISK_OF_SAME_POS = IACHK + SIZFR - 1_8 .EQ. POSFAC - 1_8 2427 RISK_OF_SAME_POS_THIS_LINE = .FALSE. 2428 IACHK_ini = IACHK 2429 OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. 2430 & ((J2-J1).GT.300) 2431 DO 170 JJ = J1, J2 2432 APOS = POSEL1 + int(IW(JJ),8) * int(NFRONT,8) 2433 IACHK = IACHK_ini + int(JJ-J1,8)*int(LSTK,8) 2434 IF (RISK_OF_SAME_POS) THEN 2435 IF (JJ.EQ.J2) THEN 2436 RISK_OF_SAME_POS_THIS_LINE = 2437 & (ISON .EQ. ISON_IN_PLACE) 2438 & .AND. ( APOS + int(IW(J1+LSTK-1)-1,8).EQ. 2439 & IACHK+int(LSTK-1,8) ) 2440 ENDIF 2441 ENDIF 2442 IF ((IACHK .GE. POSFAC).AND.(JJ>J1))THEN 2443 RESET_TO_ZERO =.FALSE. 2444 ENDIF 2445 IF (RESET_TO_ZERO) THEN 2446 IF (RISK_OF_SAME_POS_THIS_LINE) THEN 2447 DO JJ1 = 1, LSTK 2448 JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) 2449 IF ( IACHK+int(JJ1-1,8) .NE. JJ2 ) THEN 2450 A(JJ2) = A(IACHK + int(JJ1 - 1,8)) 2451 A(IACHK + int(JJ1 -1,8)) = ZERO 2452 ENDIF 2453 ENDDO 2454 ELSE 2455 DO JJ1 = 1, LSTK 2456 JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 2457 A(JJ2) = A(IACHK + int(JJ1 - 1,8)) 2458 A(IACHK + int(JJ1 -1,8)) = ZERO 2459 ENDDO 2460 ENDIF 2461 ELSE 2462 DO JJ1 = 1, LSTK 2463 JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 2464 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 1,8)) 2465 ENDDO 2466 ENDIF 2467 170 CONTINUE 2468 END IF 2469 ELSE 2470 IF (LEVEL1) THEN 2471 LDA_SON = LSTK 2472 ELSE 2473 LDA_SON = NELIM 2474 ENDIF 2475 IF (COMPRESSCB) THEN 2476 LCB = SIZFR 2477 ELSE 2478 LCB = int(LDA_SON,8)* int(J2-J1+1,8) 2479 ENDIF 2480 CALL DMUMPS_178(A, LA, 2481 & PTRAST(STEP( INODE )), NFRONT, NASS1, 2482 & IACHK, LDA_SON, LCB, 2483 & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, 2484 & COMPRESSCB, (ISON.EQ.ISON_IN_PLACE) 2485 & ) 2486 ENDIF 2487 205 IF (LEVEL1) THEN 2488 IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) 2489 IF ((SAME_PROC).AND.ETATASS.NE.1) THEN 2490 IF (KEEP(50).NE.0) THEN 2491 J2 = J1 + LSTK - 1 2492 DO JJ = J1, J2 2493 IW(JJ) = IW(JJ - NROWS) 2494 ENDDO 2495 ELSE 2496 J2 = J1 + LSTK - 1 2497 J3 = J1 + NELIM 2498 DO JJ = J3, J2 2499 IW(JJ) = IW(JJ - NROWS) 2500 ENDDO 2501 IF (NELIM .NE. 0) THEN 2502 J3 = J3 - 1 2503 DO JJ = J1, J3 2504 JPOS = IW(JJ) + ICT11 2505 IW(JJ) = IW(JPOS) 2506 ENDDO 2507 ENDIF 2508 ENDIF 2509 ENDIF 2510 IF (ETATASS.NE.1) THEN 2511 IF ( SAME_PROC ) THEN 2512 PTRIST(STEP(ISON)) = -99999999 2513 ELSE 2514 PIMASTER(STEP( ISON )) = -99999999 2515 ENDIF 2516 CALL DMUMPS_152(SSARBR, MYID, N, ISTCHK, 2517 & PAMASTER(STEP(ISON)), 2518 & IW, LIW, LRLU, LRLUS, IPTRLU, 2519 & IWPOSCB, LA, KEEP,KEEP8, 2520 & (ISON .EQ. ISON_TOP) 2521 & ) 2522 ENDIF 2523 ELSE 2524 PDEST = ISTCHK + 6 + KEEP(IXSZ) 2525 NCBSON = LSTK - NELIM 2526 PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM 2527 DO ISLAVE = 0, NSLSON-1 2528 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN 2529 CALL MUMPS_49( 2530 & KEEP, KEEP8, ISON, STEP, N, SLAVEF, 2531 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2532 & ISLAVE+1, NCBSON, 2533 & NSLSON, 2534 & TROW_SIZE, FIRST_INDEX ) 2535 SHIFT_INDEX = FIRST_INDEX - 1 2536 INDX = PTRCOL + SHIFT_INDEX 2537 CALL DMUMPS_210( COMM_LOAD, ASS_IRECV, 2538 & BUFR, LBUFR, LBUFR_BYTES, 2539 & INODE, ISON, NSLAVES, IDUMMY, 2540 & NFRONT, NASS1,NFS4FATHER, 2541 & TROW_SIZE, IW( INDX ), 2542 & PROCNODE_STEPS, 2543 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 2544 & LRLUS, N, IW, 2545 & LIW, A, LA, 2546 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, 2547 & PIMASTER, PAMASTER, NSTK_S, COMP, 2548 & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, 2549 & LEAF, NBFIN, ICNTL, KEEP, KEEP8, root, 2550 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2551 & FILS, PTRARW, PTRAIW, 2552 & INTARR, DBLARR, ND, FRERE, 2553 & LPTRAR, NELT, IW, IW, 2554 & 2555 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 2556 IF ( IFLAG .LT. 0 ) GOTO 500 2557 EXIT 2558 ENDIF 2559 ENDDO 2560 IF (PIMASTER(STEP(ISON)).GT.0) THEN 2561 IERR = -1 2562 DO WHILE (IERR.EQ.-1) 2563 PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM 2564 PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) 2565 CALL DMUMPS_71( 2566 & INODE, NFRONT, NASS1, NFS4FATHER, 2567 & ISON, MYID, 2568 & IZERO, IDUMMY, IW(PTRCOL), NCBSON, 2569 & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, 2570 & KEEP, KEEP8, STEP, N, 2571 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 2572 & ) 2573 IF (IERR.EQ.-1) THEN 2574 BLOCKING = .FALSE. 2575 SET_IRECV = .TRUE. 2576 MESSAGE_RECEIVED = .FALSE. 2577 CALL DMUMPS_329( 2578 & COMM_LOAD, ASS_IRECV, 2579 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 2580 & MPI_ANY_SOURCE, MPI_ANY_TAG, 2581 & STATUS, 2582 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 2583 & IWPOS, IWPOSCB, IPTRLU, 2584 & LRLU, LRLUS, N, IW, LIW, A, LA, 2585 & PTRIST, PTLUST_S, PTRFAC, 2586 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 2587 & IFLAG, IERROR, COMM, 2588 & NBPROCFILS, 2589 & IPOOL, LPOOL, LEAF, 2590 & NBFIN, MYID, SLAVEF, 2591 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2592 & FILS, PTRARW, PTRAIW, 2593 & INTARR, DBLARR, ICNTL, KEEP, KEEP8, ND, FRERE, 2594 & LPTRAR, NELT, IW, IW, 2595 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 2596 IF ( IFLAG .LT. 0 ) GOTO 500 2597 ENDIF 2598 ENDDO 2599 IF (IERR .EQ. -2) GOTO 290 2600 IF (IERR .EQ. -3) GOTO 295 2601 ENDIF 2602 ENDIF 2603 ISON = FRERE(STEP(ISON)) 2604 IF (ISON .LE. 0) THEN 2605 ISON = IFSON 2606 ENDIF 2607 220 CONTINUE 2608 END IF 2609 IF (ETATASS.EQ.2) GOTO 500 2610 POSELT = PTRAST(STEP(INODE)) 2611 IBROT = INODE 2612 DO 260 IORG = 1, NUMORG 2613 JK = PTRAIW(IBROT) 2614 AINPUT = PTRARW(IBROT) 2615 JJ = JK + 1 2616 J1 = JJ + 1 2617 J2 = J1 + INTARR(JK) 2618 J3 = J2 + 1 2619 J4 = J2 - INTARR(JJ) 2620 IJROW = INTARR(J1) 2621 ICT12 = POSELT + int(IJROW - NFRONT - 1,8) 2622Cduplicates --> CVD$ DEPCHK 2623 DO 240 JJ = J1, J2 2624 APOS2 = ICT12 + int(INTARR(JJ),8) * NFRONT8 2625 A(APOS2) = A(APOS2) + DBLARR(AINPUT) 2626 AINPUT = AINPUT + 1 2627 240 CONTINUE 2628 IF (J3 .LE. J4) THEN 2629 ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 2630 NBCOL = J4 - J3 + 1 2631Cduplicates--> CVD$ DEPCHK 2632CduplicatesCVD$ NODEPCHK 2633 DO 250 JJ = 1, NBCOL 2634 APOS3 = ICT13 + int(INTARR(J3 + JJ - 1) - 1,8) 2635 A(APOS3) = A(APOS3) + DBLARR(AINPUT + JJ - 1) 2636 250 CONTINUE 2637 ENDIF 2638 IF (KEEP(50).EQ.0) THEN 2639 DO JJ=1, KEEP(253) 2640 APOS = POSELT+ 2641 & int(IJROW-1,8) * NFRONT8 + 2642 & int(NFRONT-KEEP(253)+JJ-1,8) 2643 A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) 2644 ENDDO 2645 ELSE 2646 DO JJ=1, KEEP(253) 2647 APOS = POSELT+ 2648 & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + 2649 & int(IJROW-1,8) 2650 A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) 2651 ENDDO 2652 ENDIF 2653 IBROT = FILS(IBROT) 2654 260 CONTINUE 2655 GOTO 500 2656 270 CONTINUE 2657 IFLAG = -8 2658 IERROR = LREQ 2659 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 2660 LP = ICNTL(1) 2661 WRITE( LP, * ) 2662 &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_252' 2663 ENDIF 2664 GOTO 490 2665 280 CONTINUE 2666 IFLAG = -9 2667 CALL MUMPS_731(LAELL_REQ8 - LRLUS, IERROR) 2668 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 2669 LP = ICNTL(1) 2670 WRITE( LP, * ) 2671 &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_252' 2672 ENDIF 2673 GOTO 490 2674 290 CONTINUE 2675 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 2676 LP = ICNTL(1) 2677 WRITE( LP, * ) 2678 & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_252' 2679 ENDIF 2680 IFLAG = -17 2681 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) 2682 IERROR = LREQ * KEEP( 34 ) 2683 GOTO 490 2684 295 CONTINUE 2685 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 2686 LP = ICNTL(1) 2687 WRITE( LP, * ) 2688 & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_252' 2689 ENDIF 2690 IFLAG = -17 2691 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) 2692 IERROR = LREQ * KEEP( 34 ) 2693 GOTO 490 2694 300 CONTINUE 2695 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 2696 LP = ICNTL(1) 2697 WRITE( LP, * ) 2698 & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING DMUMPS_252' 2699 ENDIF 2700 IFLAG = -13 2701 IERROR = NUMSTK + 1 2702 490 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 2703 500 CONTINUE 2704 RETURN 2705 END SUBROUTINE DMUMPS_252 2706 SUBROUTINE DMUMPS_253(COMM_LOAD, ASS_IRECV, 2707 & N, INODE, IW, LIW, A, LA, IFLAG, 2708 & IERROR, ND, FILS, FRERE, DAD, 2709 & CAND, 2710 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2711 & MAXFRW, root, 2712 & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, 2713 & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, 2714 & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, 2715 & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, 2716 & ICNTL, KEEP, KEEP8,INTARR,DBLARR, 2717 & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, 2718 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, 2719 & PERM , MEM_DISTRIB) 2720 USE DMUMPS_COMM_BUFFER 2721 USE DMUMPS_LOAD 2722 IMPLICIT NONE 2723 INCLUDE 'dmumps_root.h' 2724 INCLUDE 'mpif.h' 2725 INTEGER IERR, STATUS( MPI_STATUS_SIZE ) 2726 TYPE (DMUMPS_ROOT_STRUC) :: root 2727 INTEGER COMM_LOAD, ASS_IRECV 2728 INTEGER N,LIW,NSTEPS, NBFIN 2729 INTEGER(8) :: LA 2730 INTEGER KEEP(500), ICNTL(40) 2731 INTEGER(8) KEEP8(150) 2732 INTEGER IFLAG,IERROR,INODE,MAXFRW, 2733 & LPOOL, LEAF, IWPOS, IWPOSCB, COMP 2734 INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC 2735 DOUBLE PRECISION A(LA) 2736 DOUBLE PRECISION OPASSW, OPELIW 2737 INTEGER COMM, SLAVEF, MYID, LBUFR, LBUFR_BYTES 2738 INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB 2739 INTEGER IPOOL(LPOOL) 2740 INTEGER(8) :: PTRAST(KEEP(28)) 2741 INTEGER(8) :: PTRFAC(KEEP(28)) 2742 INTEGER(8) :: PAMASTER(KEEP(28)) 2743 INTEGER IW(LIW), ITLOC(N+KEEP(253)), 2744 & PTRARW(N), PTRAIW(N), ND(KEEP(28)), 2745 & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), 2746 & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), 2747 & STEP(N), 2748 & PIMASTER(KEEP(28)), 2749 & NSTK_S(KEEP(28)), PERM(N) 2750 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 2751 INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) 2752 INTEGER ISTEP_TO_INIV2(KEEP(71)), 2753 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 2754 INTEGER NBPROCFILS(KEEP(28)), 2755 & PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) 2756 INTEGER INTARR(max(1,KEEP(14))) 2757 DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 2758 INTEGER LP, HS, HF, HF_OLD,NCBSON, NSLAVES_OLD, 2759 & NBSPLIT 2760 INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL 2761 INTEGER NFS4FATHER,I 2762 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ 2763 INTEGER(8) :: LAELL8 2764 INTEGER LREQ_OOC 2765 LOGICAL COMPRESSCB 2766 INTEGER(8) :: LCB 2767 INTEGER NCB 2768 INTEGER J1,J2,J3,MP 2769 INTEGER(8) :: JJ8, LAPOS2, JJ2, JJ3 2770 INTEGER NELIM,JJ,JJ1,NPIVS,NCOLS,NROWS, 2771 & IBROT,IORG 2772 INTEGER LDAFS, LDA_SON 2773 INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4, NUMORG_SPLIT 2774 INTEGER(8) :: ICT13 2775 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 2776 INTEGER AINPUT 2777 INTEGER NSLAVES, NSLSON 2778 INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST 2779 INTEGER PDEST1(1) 2780 INTEGER TYPESPLIT 2781 INTEGER ISON_IN_PLACE 2782 LOGICAL IS_ofType5or6 2783 LOGICAL SAME_PROC, NIV1, SON_LEVEL2 2784 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 2785 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX 2786 INTEGER IZERO 2787 INTEGER IDUMMY(1) 2788 PARAMETER( IZERO = 0 ) 2789 INTEGER MUMPS_275, MUMPS_330, MUMPS_810 2790 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 2791 DOUBLE PRECISION ZERO 2792 DOUBLE PRECISION RZERO 2793 PARAMETER(RZERO = 0.0D0 ) 2794 PARAMETER( ZERO = 0.0D0 ) 2795 INTEGER NELT, LPTRAR, NCBSON_MAX 2796 logical :: force_cand 2797 INTEGER ETATASS 2798 INCLUDE 'mumps_headers.h' 2799 INTEGER (8) :: APOSMAX 2800 DOUBLE PRECISION MAXARR 2801 INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok, 2802 & NCB_SPLIT, SIZE_LIST_SPLIT 2803 INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND 2804 INTEGER NBPANELS_L, NBPANELS_U 2805 MP = ICNTL(2) 2806 IS_ofType5or6 = .FALSE. 2807 COMPRESSCB = .FALSE. 2808 ETATASS = 0 2809 IN = INODE 2810 NBPROCFILS(STEP(IN)) = 0 2811 NSTEPS = NSTEPS + 1 2812 NUMORG = 0 2813 DO WHILE (IN.GT.0) 2814 NUMORG = NUMORG + 1 2815 IN = FILS(IN) 2816 ENDDO 2817 NUMSTK = 0 2818 NASS = 0 2819 IFSON = -IN 2820 ISON = IFSON 2821 NCBSON_MAX = 0 2822 NELT = 1 2823 LPTRAR = 1 2824 DO WHILE (ISON .GT. 0) 2825 NUMSTK = NUMSTK + 1 2826 IF ( KEEP(48)==5 .AND. 2827 & MUMPS_330(PROCNODE_STEPS(STEP(ISON)), 2828 & SLAVEF) .EQ. 1) THEN 2829 NCBSON_MAX = max 2830 & ( 2831 & IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)), NCBSON_MAX 2832 & ) 2833 ENDIF 2834 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) 2835 ISON = FRERE(STEP(ISON)) 2836 ENDDO 2837 NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) 2838 NASS1 = NASS + NUMORG 2839 NCB = NFRONT - NASS1 2840 if((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then 2841 force_cand=.FALSE. 2842 else 2843 force_cand=(mod(KEEP(24),2).eq.0) 2844 end if 2845 IF (force_cand) THEN 2846 INIV2 = ISTEP_TO_INIV2( STEP( INODE )) 2847 SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) 2848 ELSE 2849 INIV2 = 1 2850 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 2851 ENDIF 2852 ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) 2853 IF (allocok > 0 ) THEN 2854 GOTO 265 2855 ENDIF 2856 TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), 2857 & SLAVEF) 2858 IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) 2859 IF ( (TYPESPLIT.EQ.4) 2860 & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) 2861 & ) THEN 2862 IF (TYPESPLIT.EQ.4) THEN 2863 ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) 2864 IF (allocok > 0 ) THEN 2865 GOTO 265 2866 ENDIF 2867 CALL DMUMPS_791 ( 2868 & INODE, STEP, N, SLAVEF, 2869 & PROCNODE_STEPS, KEEP, DAD, FILS, 2870 & CAND(1,INIV2), ICNTL, COPY_CAND, 2871 & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), 2872 & SIZE_TMP_SLAVES_LIST 2873 & ) 2874 NCB_SPLIT = NCB-NUMORG_SPLIT 2875 SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT 2876 CALL DMUMPS_472( NCBSON_MAX, SLAVEF, KEEP,KEEP8, 2877 & ICNTL, COPY_CAND, 2878 & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, 2879 & TAB_POS_IN_PERE(1,INIV2), 2880 & TMP_SLAVES_LIST(NBSPLIT+1), 2881 & SIZE_LIST_SPLIT,INODE ) 2882 DEALLOCATE (COPY_CAND) 2883 CALL DMUMPS_790 ( 2884 & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, 2885 & PROCNODE_STEPS, KEEP, DAD, FILS, 2886 & ICNTL, 2887 & TAB_POS_IN_PERE(1,INIV2), 2888 & NSLAVES 2889 & ) 2890 ELSE 2891 ISTCHK = PIMASTER(STEP(IFSON)) 2892 PDEST = ISTCHK + 6 + KEEP(IXSZ) 2893 NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) 2894 TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) 2895 & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) 2896 CALL DMUMPS_792 ( 2897 & INODE, TYPESPLIT, IFSON, 2898 & IW(PDEST), NSLSON, 2899 & STEP, N, SLAVEF, NBSPLIT, NCB, 2900 & PROCNODE_STEPS, KEEP, DAD, FILS, 2901 & ICNTL, ISTEP_TO_INIV2, INIV2, 2902 & TAB_POS_IN_PERE, NSLAVES, 2903 & TMP_SLAVES_LIST, 2904 & SIZE_TMP_SLAVES_LIST 2905 & ) 2906 ENDIF 2907 ELSE 2908 CALL DMUMPS_472( NCBSON_MAX, SLAVEF, KEEP,KEEP8, 2909 & ICNTL, CAND(1,INIV2), 2910 & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, 2911 & TAB_POS_IN_PERE(1,INIV2), 2912 & TMP_SLAVES_LIST, 2913 & SIZE_TMP_SLAVES_LIST,INODE ) 2914 ENDIF 2915 HF = NSLAVES + 6 + KEEP(IXSZ) 2916 LREQ_OOC = 0 2917 IF (KEEP(201).EQ.1) THEN 2918 CALL DMUMPS_684(KEEP(50), NASS1, NFRONT, NASS1, 2919 & NBPANELS_L, NBPANELS_U, LREQ_OOC) 2920 ENDIF 2921 LREQ = HF + 2 * NFRONT + LREQ_OOC 2922 IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN 2923 CALL DMUMPS_94(N, KEEP(28), 2924 & IW, LIW, A, LA, 2925 & LRLU, IPTRLU, 2926 & IWPOS, IWPOSCB, PTRIST, PTRAST, 2927 & STEP, PIMASTER, PAMASTER, 2928 & KEEP(216),LRLUS,KEEP(IXSZ)) 2929 COMP = COMP+1 2930 IF (LRLU .NE. LRLUS) THEN 2931 WRITE( *, * ) 'PB compress ass..mpi51f_niv2' 2932 WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS 2933 GOTO 270 2934 ENDIF 2935 IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 2936 ENDIF 2937 IOLDPS = IWPOS 2938 IWPOS = IWPOS + LREQ 2939 NIV1 = .FALSE. 2940 IF (KEEP(50).EQ.0 .AND. KEEP(234).EQ.0) THEN 2941 CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, 2942 & NFRONT_EFF, DAD, 2943 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 2944 & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, 2945 & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, 2946 & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, 2947 & PROCNODE_STEPS, SLAVEF ) 2948 ELSE 2949 ISON_IN_PLACE = -9999 2950 CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, 2951 & NFRONT, NFRONT_EFF, PERM, DAD, 2952 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 2953 & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, 2954 & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, 2955 & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, 2956 & ISON_IN_PLACE, 2957 & PROCNODE_STEPS, SLAVEF) 2958 IF (IFLAG.LT.0) GOTO 250 2959 ENDIF 2960 IF ( NFRONT .NE. NFRONT_EFF ) THEN 2961 IF ( 2962 & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6) ) THEN 2963 WRITE(6,*) ' Internal error 1 in fac_ass due to plitting ', 2964 & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF 2965 CALL MUMPS_ABORT() 2966 ENDIF 2967 IF (NFRONT.GT.NFRONT_EFF) THEN 2968 NCB = NFRONT_EFF - NASS1 2969 NSLAVES_OLD = NSLAVES 2970 HF_OLD = HF 2971 IF (TYPESPLIT.EQ.4) THEN 2972 WRITE(6,*) ' Internal error 2 in fac_ass due', 2973 & ' to splitting ', 2974 & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF 2975 CALL MUMPS_ABORT() 2976 ELSE 2977 CALL DMUMPS_472( NCBSON_MAX, 2978 & SLAVEF, KEEP,KEEP8, ICNTL, 2979 & CAND(1,INIV2), 2980 & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, 2981 & TAB_POS_IN_PERE(1,INIV2), 2982 & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE ) 2983 ENDIF 2984 HF = NSLAVES + 6 + KEEP(IXSZ) 2985 IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - 2986 & (NSLAVES_OLD - NSLAVES) 2987 IF (NSLAVES_OLD .NE. NSLAVES) THEN 2988 IF (NSLAVES_OLD > NSLAVES) THEN 2989 DO JJ=0,2*NFRONT_EFF-1 2990 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) 2991 ENDDO 2992 ELSE 2993 IF (IWPOS - 1 > IWPOSCB ) GOTO 270 2994 DO JJ=2*NFRONT_EFF-1, 0, -1 2995 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) 2996 ENDDO 2997 END IF 2998 END IF 2999 NFRONT = NFRONT_EFF 3000 LREQ = HF + 2 * NFRONT + LREQ_OOC 3001 ELSE 3002 Write(*,*) MYID,': ERROR 2 during ass_niv2, INODE=', INODE, 3003 & ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF 3004 GOTO 270 3005 ENDIF 3006 ENDIF 3007 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 3008 CALL DMUMPS_691(KEEP(50), 3009 & NBPANELS_L, NBPANELS_U, NASS1, 3010 & IOLDPS + HF + 2 * NFRONT, IW, LIW) 3011 ENDIF 3012 MAXFRW = max0(MAXFRW, NFRONT) 3013 PTLUST_S(STEP(INODE)) = IOLDPS 3014 IW(IOLDPS + 1+KEEP(IXSZ)) = 0 3015 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 3016 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 3017 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) 3018 IW(IOLDPS+KEEP(IXSZ)) = NFRONT 3019 IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES 3020 IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+KEEP(IXSZ)+NSLAVES)= 3021 & TMP_SLAVES_LIST(1:NSLAVES) 3022#if defined(OLD_LOAD_MECHANISM) 3023#if ! defined (CHECK_COHERENCE) 3024 IF ( KEEP(73) .EQ. 0 ) THEN 3025#endif 3026#endif 3027 CALL DMUMPS_461(MYID, SLAVEF, COMM_LOAD, 3028 & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), 3029 & NASS1, KEEP,KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) 3030#if defined(OLD_LOAD_MECHANISM) 3031#if ! defined (CHECK_COHERENCE) 3032 ENDIF 3033#endif 3034#endif 3035 IF(KEEP(86).EQ.1)THEN 3036 IF(mod(KEEP(24),2).eq.0)THEN 3037 CALL DMUMPS_533(SLAVEF,CAND(SLAVEF+1,INIV2), 3038 & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), 3039 & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, NSLAVES,INODE) 3040 ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN 3041 CALL DMUMPS_533(SLAVEF,SLAVEF-1, 3042 & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), 3043 & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, NSLAVES,INODE) 3044 ENDIF 3045 ENDIF 3046 DEALLOCATE(TMP_SLAVES_LIST) 3047 IF (KEEP(50).EQ.0) THEN 3048 LAELL8 = int(NASS1,8) * int(NFRONT,8) 3049 LDAFS = NFRONT 3050 ELSE 3051 LAELL8 = int(NASS1,8)*int(NASS1,8) 3052 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) 3053 & LAELL8 = LAELL8+int(NASS1,8) 3054 LDAFS = NASS1 3055 ENDIF 3056 IF (LRLU .LT. LAELL8) THEN 3057 IF (LRLUS .LT. LAELL8) THEN 3058 GOTO 280 3059 ELSE 3060 CALL DMUMPS_94(N, KEEP(28), 3061 & IW, LIW, A, LA, 3062 & LRLU, IPTRLU, 3063 & IWPOS, IWPOSCB, PTRIST, PTRAST, 3064 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 3065 & KEEP(IXSZ)) 3066 IF (LRLU .NE. LRLUS) THEN 3067 WRITE( *, * ) 'PB compress ass..mpi51f_niv2' 3068 WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS 3069 GOTO 280 3070 ENDIF 3071 ENDIF 3072 ENDIF 3073 LRLU = LRLU - LAELL8 3074 LRLUS = LRLUS - LAELL8 3075 KEEP8(67) = min(LRLUS, KEEP8(67)) 3076 POSELT = POSFAC 3077 PTRAST(STEP(INODE)) = POSELT 3078 PTRFAC(STEP(INODE)) = POSELT 3079 POSFAC = POSFAC + LAELL8 3080 IW(IOLDPS+XXI) = LREQ 3081 CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) 3082 IW(IOLDPS+XXS) =-9999 3083 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 3084 CALL DMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, 3085 & KEEP,KEEP8,LRLU) 3086 POSEL1 = POSELT - int(LDAFS,8) 3087#if ! defined(ALLOW_NON_INIT) 3088 LAPOS2 = POSELT + LAELL8 - 1_8 3089 A(POSELT:LAPOS2) = ZERO 3090#else 3091 IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN 3092 LAPOS2 = POSELT + LAELL8 - 1_8 3093 A(POSELT:LAPOS2) = ZERO 3094 ELSE 3095 APOS = POSELT 3096 DO JJ8 = 0_8, int(LDAFS-1,8) 3097 A(APOS:APOS+JJ8) = ZERO 3098 APOS = APOS + int(LDAFS,8) 3099 END DO 3100 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN 3101 A(APOS:APOS+int(LDAFS,8)-1_8)=ZERO 3102 ENDIF 3103 END IF 3104#endif 3105 IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN 3106 ISON = IFSON 3107 DO 220 IELL = 1, NUMSTK 3108 ISTCHK = PIMASTER(STEP(ISON)) 3109 NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) 3110 IF (NELIM.EQ.0) GOTO 210 3111 LSTK = IW(ISTCHK+KEEP(IXSZ)) 3112 NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) 3113 IF (NPIVS.LT.0) NPIVS=0 3114 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) 3115 HS = 6 + NSLSON + KEEP(IXSZ) 3116 NCOLS = NPIVS + LSTK 3117 SAME_PROC = (ISTCHK.LE.IWPOS) 3118 IF ( SAME_PROC ) THEN 3119 COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) 3120 ELSE 3121 COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) 3122 ENDIF 3123 IF (.NOT.SAME_PROC) THEN 3124 NROWS = IW(ISTCHK + 2+KEEP(IXSZ)) 3125 ELSE 3126 NROWS = NCOLS 3127 ENDIF 3128 OPASSW = OPASSW + dble(NELIM*LSTK) 3129 J1 = ISTCHK + HS + NROWS + NPIVS 3130 J2 = J1 + NELIM - 1 3131 IACHK = PAMASTER(STEP(ISON)) 3132 IF (KEEP(50).eq.0) THEN 3133 IF (IS_ofType5or6) THEN 3134 APOS = POSELT 3135 DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) 3136 A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + A(IACHK+JJ8-1_8) 3137 ENDDO 3138 ELSE 3139 DO 170 JJ = J1, J2 3140 APOS = POSEL1 + int(IW(JJ),8) * int(LDAFS,8) 3141 DO 160 JJ1 = 1, LSTK 3142 JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 3143 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 1,8)) 3144 160 CONTINUE 3145 IACHK = IACHK + int(LSTK,8) 3146 170 CONTINUE 3147 ENDIF 3148 ELSE 3149 IF (NSLSON.EQ.0) THEN 3150 LDA_SON = LSTK 3151 ELSE 3152 LDA_SON = NELIM 3153 ENDIF 3154 IF (COMPRESSCB) THEN 3155 LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 3156 ELSE 3157 LCB = int(LDA_SON,8)*int(NELIM,8) 3158 ENDIF 3159 CALL DMUMPS_178( A, LA, 3160 & POSELT, LDAFS, NASS1, 3161 & IACHK, LDA_SON, LCB, 3162 & IW( J1 ), NELIM, NELIM, ETATASS, 3163 & COMPRESSCB, 3164 & .FALSE. 3165 & ) 3166 ENDIF 3167 210 ISON = FRERE(STEP(ISON)) 3168 220 CONTINUE 3169 ENDIF 3170 IBROT = INODE 3171 APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) 3172 DO 260 IORG = 1, NUMORG 3173 JK = PTRAIW(IBROT) 3174 AINPUT = PTRARW(IBROT) 3175 JJ = JK + 1 3176 J1 = JJ + 1 3177 J2 = J1 + INTARR(JK) 3178 J3 = J2 + 1 3179 J4 = J2 - INTARR(JJ) 3180 IJROW = INTARR(J1) 3181 ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) 3182 MAXARR = RZERO 3183CduplicatesCVD$ NODEPCHK 3184 DO 240 JJ = J1, J2 3185 IF (KEEP(219).NE.0) THEN 3186 IF (INTARR(JJ).LE.NASS1) THEN 3187 APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) 3188 A(APOS2) = A(APOS2) + DBLARR(AINPUT) 3189 ELSEIF (KEEP(50).EQ.2) THEN 3190 MAXARR = max(MAXARR,abs(DBLARR(AINPUT))) 3191 ENDIF 3192 ELSE 3193 IF (INTARR(JJ).LE.NASS1) THEN 3194 APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) 3195 A(APOS2) = A(APOS2) + DBLARR(AINPUT) 3196 ENDIF 3197 ENDIF 3198 AINPUT = AINPUT + 1 3199 240 CONTINUE 3200 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN 3201 A(APOSMAX+int(IJROW-1,8)) = MAXARR 3202 ENDIF 3203 IF (J3 .GT. J4) GOTO 255 3204 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) 3205 NBCOL = J4 - J3 + 1 3206CduplicatesCVD$ NODEPCHK 3207CduplicatesCVD$ NODEPCHK 3208 DO JJ = 1, NBCOL 3209 JJ3 = ICT13 + int(INTARR(J3 + JJ - 1),8) - 1_8 3210 A(JJ3) = A(JJ3) + DBLARR(AINPUT + JJ - 1) 3211 ENDDO 3212 255 CONTINUE 3213 IF (KEEP(50).EQ.0) THEN 3214 DO JJ = 1, KEEP(253) 3215 APOS = POSELT + 3216 & int(IJROW-1,8) * int(LDAFS,8) + 3217 & int(LDAFS-KEEP(253)+JJ-1,8) 3218 A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) 3219 ENDDO 3220 ENDIF 3221 IBROT = FILS(IBROT) 3222 260 CONTINUE 3223 PTRCOL = IOLDPS + HF + NFRONT 3224 PTRROW = IOLDPS + HF + NASS1 3225 PDEST = IOLDPS + 6 + KEEP(IXSZ) 3226 DO ISLAVE = 1, NSLAVES 3227 CALL MUMPS_49( 3228 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 3229 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 3230 & ISLAVE, NCB, 3231 & NSLAVES, 3232 & NBLIG, FIRST_INDEX ) 3233 SHIFT_INDEX = FIRST_INDEX - 1 3234 IERR = -1 3235 DO WHILE (IERR .EQ.-1) 3236 IF ( KEEP(50) .eq. 0 ) THEN 3237 NBCOL = NFRONT 3238 CALL DMUMPS_68( INODE, 3239 & NBPROCFILS(STEP(INODE)), 3240 & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, 3241 & IZERO, IDUMMY, 3242 & IW(PDEST), NFRONT, COMM, IERR) 3243 ELSE 3244 NBCOL = NASS1+SHIFT_INDEX+NBLIG 3245 CALL DMUMPS_68( INODE, 3246 & NBPROCFILS(STEP(INODE)), 3247 & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, 3248 & NSLAVES-ISLAVE, 3249 & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), 3250 & IW(PDEST), NFRONT, COMM, IERR) 3251 ENDIF 3252 IF (IERR.EQ.-1) THEN 3253 BLOCKING = .FALSE. 3254 SET_IRECV = .TRUE. 3255 MESSAGE_RECEIVED = .FALSE. 3256 CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, 3257 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3258 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3259 & STATUS, BUFR, LBUFR, 3260 & LBUFR_BYTES, 3261 & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, 3262 & LRLU, LRLUS, N, IW, LIW, A, LA, 3263 & PTRIST, PTLUST_S, PTRFAC, 3264 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 3265 & IERROR, COMM, 3266 & NBPROCFILS, 3267 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 3268 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3269 & FILS, PTRARW, PTRAIW, 3270 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 3271 & LPTRAR, NELT, IW, IW, 3272 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3273 IF ( IFLAG .LT. 0 ) GOTO 500 3274 IF (MESSAGE_RECEIVED) THEN 3275 IOLDPS = PTLUST_S(STEP(INODE)) 3276 PTRCOL = IOLDPS + HF + NFRONT 3277 PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX 3278 ENDIF 3279 ENDIF 3280 ENDDO 3281 IF (IERR .EQ. -2) GOTO 300 3282 IF (IERR .EQ. -3) GOTO 305 3283 PTRROW = PTRROW + NBLIG 3284 PDEST = PDEST + 1 3285 ENDDO 3286 IF (NUMSTK.EQ.0) GOTO 500 3287 ISON = IFSON 3288 DO IELL = 1, NUMSTK 3289 ISTCHK = PIMASTER(STEP(ISON)) 3290 NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) 3291 LSTK = IW(ISTCHK+KEEP(IXSZ)) 3292 NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) 3293 IF ( NPIVS .LT. 0 ) NPIVS = 0 3294 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) 3295 HS = 6 + NSLSON + KEEP(IXSZ) 3296 NCOLS = NPIVS + LSTK 3297 SAME_PROC = (ISTCHK.LE.IWPOS) 3298 IF (.NOT.SAME_PROC) THEN 3299 NROWS = IW(ISTCHK + 2+KEEP(IXSZ)) 3300 ELSE 3301 NROWS = NCOLS 3302 ENDIF 3303 PDEST = ISTCHK + 6 + KEEP(IXSZ) 3304 NCBSON = LSTK - NELIM 3305 PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM 3306 IF (KEEP(219).NE.0) THEN 3307 IF(KEEP(50) .EQ. 2) THEN 3308 NFS4FATHER = NCBSON 3309 DO I=0,NCBSON-1 3310 IF(IW(PTRCOL+I) .GT. NASS1) THEN 3311 NFS4FATHER = I 3312 EXIT 3313 ENDIF 3314 ENDDO 3315 NFS4FATHER = NFS4FATHER+NELIM 3316 ELSE 3317 NFS4FATHER = 0 3318 ENDIF 3319 ELSE 3320 NFS4FATHER = 0 3321 ENDIF 3322 IF (NSLSON.EQ.0) THEN 3323 NSLSON = 1 3324 PDEST1(1) = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), 3325 & SLAVEF) 3326 IF (PDEST1(1).EQ.MYID) THEN 3327 CALL DMUMPS_211( COMM_LOAD, ASS_IRECV, 3328 & BUFR, LBUFR, LBUFR_BYTES, 3329 & INODE, ISON, NSLAVES, 3330 & IW( PTLUST_S(STEP(INODE)) + 6 +KEEP(IXSZ)), 3331 & NFRONT, NASS1, NFS4FATHER, NCBSON, 3332 & IW( PTRCOL ), 3333 & PROCNODE_STEPS, 3334 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 3335 & LRLUS, N, IW, 3336 & LIW, A, LA, 3337 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, 3338 & PIMASTER, PAMASTER, NSTK_S, COMP, 3339 & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, 3340 & NBFIN, ICNTL, KEEP,KEEP8, root, 3341 & OPASSW, OPELIW, 3342 & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, 3343 & ND, FRERE, LPTRAR, NELT, IW, IW, 3344 & 3345 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 3346 & ) 3347 IF ( IFLAG .LT. 0 ) GOTO 500 3348 ELSE 3349 IERR = -1 3350 DO WHILE (IERR.EQ.-1) 3351 PTRCOL = PIMASTER(STEP(ISON))+HS+NROWS+NPIVS+NELIM 3352 CALL DMUMPS_71( 3353 & INODE, NFRONT,NASS1,NFS4FATHER, 3354 & ISON, MYID, 3355 & NSLAVES, IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ) ), 3356 & IW(PTRCOL), NCBSON, 3357 & COMM, IERR, PDEST1, NSLSON, SLAVEF, 3358 & KEEP,KEEP8, STEP, N, 3359 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 3360 & ) 3361 IF (IERR.EQ.-1) THEN 3362 BLOCKING = .FALSE. 3363 SET_IRECV = .TRUE. 3364 MESSAGE_RECEIVED = .FALSE. 3365 CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, 3366 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3367 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3368 & STATUS, BUFR, LBUFR, LBUFR_BYTES, 3369 & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, 3370 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3371 & PTLUST_S, PTRFAC, 3372 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 3373 & IERROR, COMM, 3374 & NBPROCFILS, 3375 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 3376 & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3377 & FILS, PTRARW, PTRAIW, 3378 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, LPTRAR, 3379 & NELT, IW, IW, 3380 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3381 IF ( IFLAG .LT. 0 ) GOTO 500 3382 ENDIF 3383 ENDDO 3384 IF (IERR .EQ. -2) GOTO 290 3385 IF (IERR .EQ. -3) GOTO 295 3386 ENDIF 3387 ELSE 3388 DO ISLAVE = 0, NSLSON-1 3389 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN 3390 CALL MUMPS_49( 3391 & KEEP,KEEP8, ISON, STEP, N, SLAVEF, 3392 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 3393 & ISLAVE+1, NCBSON, 3394 & NSLSON, 3395 & TROW_SIZE, FIRST_INDEX ) 3396 SHIFT_INDEX = FIRST_INDEX - 1 3397 INDX = PTRCOL + SHIFT_INDEX 3398 CALL DMUMPS_210( COMM_LOAD, ASS_IRECV, 3399 & BUFR, LBUFR, LBUFR_BYTES, 3400 & INODE, ISON, NSLAVES, 3401 & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)), 3402 & NFRONT, NASS1,NFS4FATHER, 3403 & TROW_SIZE, IW( INDX ), 3404 & PROCNODE_STEPS, 3405 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 3406 & LRLUS, N, IW, 3407 & LIW, A, LA, 3408 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, 3409 & PIMASTER, PAMASTER, NSTK_S, COMP, 3410 & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, 3411 & NBFIN, ICNTL, KEEP,KEEP8, root, 3412 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 3413 & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, 3414 & IW, 3415 & 3416 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 3417 & ) 3418 IF ( IFLAG .LT. 0 ) GOTO 500 3419 EXIT 3420 ENDIF 3421 ENDDO 3422 IF (PIMASTER(STEP(ISON)).GT.0) THEN 3423 IERR = -1 3424 DO WHILE (IERR.EQ.-1) 3425 PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM 3426 PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) 3427 CALL DMUMPS_71( 3428 & INODE, NFRONT,NASS1, NFS4FATHER, 3429 & ISON, MYID, 3430 & NSLAVES, IW(PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)), 3431 & IW(PTRCOL), NCBSON, 3432 & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, 3433 & KEEP,KEEP8, STEP, N, 3434 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 3435 & ) 3436 IF (IERR.EQ.-1) THEN 3437 BLOCKING = .FALSE. 3438 SET_IRECV = .TRUE. 3439 MESSAGE_RECEIVED = .FALSE. 3440 CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, 3441 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3442 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3443 & STATUS, BUFR, LBUFR, 3444 & LBUFR_BYTES, 3445 & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, 3446 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3447 & PTLUST_S, PTRFAC, 3448 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 3449 & IERROR, COMM, 3450 & NBPROCFILS, 3451 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 3452 & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3453 & FILS, PTRARW, PTRAIW, 3454 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 3455 & LPTRAR, NELT, IW, IW, 3456 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3457 IF ( IFLAG .LT. 0 ) GOTO 500 3458 ENDIF 3459 ENDDO 3460 IF (IERR .EQ. -2) GOTO 290 3461 IF (IERR .EQ. -3) GOTO 295 3462 ENDIF 3463 ENDIF 3464 ISON = FRERE(STEP(ISON)) 3465 ENDDO 3466 GOTO 500 3467 250 CONTINUE 3468 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3469 LP = ICNTL(1) 3470 WRITE( LP, * ) 3471 &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING 3472 & DMUMPS_253' 3473 ENDIF 3474 IFLAG = -13 3475 IERROR = NUMSTK + 1 3476 GOTO 490 3477 265 CONTINUE 3478 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3479 LP = ICNTL(1) 3480 WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', 3481 & ' DURING DMUMPS_253' 3482 ENDIF 3483 IFLAG = -13 3484 IERROR = SIZE_TMP_SLAVES_LIST 3485 GOTO 490 3486 270 CONTINUE 3487 IFLAG = -8 3488 IERROR = LREQ 3489 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3490 LP = ICNTL(1) 3491 WRITE( LP, * ) 3492 &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_253' 3493 ENDIF 3494 GOTO 490 3495 280 CONTINUE 3496 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3497 LP = ICNTL(1) 3498 WRITE( LP, * ) 3499 &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_253' 3500 ENDIF 3501 IFLAG = -9 3502 CALL MUMPS_731(LAELL8-LRLUS, IERROR) 3503 GOTO 490 3504 290 CONTINUE 3505 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3506 LP = ICNTL(1) 3507 WRITE( LP, * ) 3508 &' FAILURE, SEND BUFFER TOO SMALL (1) DURING DMUMPS_253' 3509 ENDIF 3510 IFLAG = -17 3511 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) 3512 IERROR = LREQ * KEEP( 34 ) 3513 GOTO 490 3514 295 CONTINUE 3515 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3516 LP = ICNTL(1) 3517 WRITE( LP, * ) 3518 &' FAILURE, RECV BUFFER TOO SMALL (1) DURING DMUMPS_253' 3519 ENDIF 3520 IFLAG = -20 3521 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) 3522 IERROR = LREQ * KEEP( 34 ) 3523 GOTO 490 3524 300 CONTINUE 3525 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3526 LP = ICNTL(1) 3527 WRITE( LP, * ) 3528 &' FAILURE, SEND BUFFER TOO SMALL (2) DURING DMUMPS_253' 3529 ENDIF 3530 IFLAG = -17 3531 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) 3532 IERROR = LREQ * KEEP( 34 ) 3533 GOTO 490 3534 305 CONTINUE 3535 IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN 3536 LP = ICNTL(1) 3537 WRITE( LP, * ) 3538 &' FAILURE, RECV BUFFER TOO SMALL (2) DURING DMUMPS_253' 3539 ENDIF 3540 IFLAG = -17 3541 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) 3542 IERROR = LREQ * KEEP( 34 ) 3543 490 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 3544 500 CONTINUE 3545 RETURN 3546 END SUBROUTINE DMUMPS_253 3547 SUBROUTINE DMUMPS_39(N, INODE, IW, LIW, A, LA, 3548 & ISON, NBROWS, NBCOLS, ROWLIST, 3549 & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, 3550 & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, 3551 & LDA_VALSON ) 3552 USE DMUMPS_LOAD 3553 IMPLICIT NONE 3554 INTEGER KEEP(500) 3555 INTEGER(8) KEEP8(150) 3556 INTEGER(8) :: LA 3557 INTEGER N,LIW,MYID 3558 INTEGER INODE,ISON, IWPOSCB 3559 INTEGER NBROWS, NBCOLS, LDA_VALSON 3560 INTEGER(8) :: PTRAST(KEEP(28)) 3561 INTEGER IW(LIW), STEP(N), PIMASTER(KEEP(28)), 3562 & PTLUST_S(KEEP(28)), ROWLIST(NBROWS) 3563 DOUBLE PRECISION A(LA), VALSON(LDA_VALSON,NBROWS) 3564 DOUBLE PRECISION OPASSW 3565 LOGICAL, INTENT(IN) :: IS_ofType5or6 3566 INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 3567 INTEGER HF,HS, NSLAVES, NFRONT, NASS1, 3568 & IOLDPS, ISTCHK, LSTK, NSLSON,NELIM, 3569 & NPIVS,NCOLS,J1,JJ,JJ1,NROWS, 3570 & LDAFS_PERE, IBEG, DIAG 3571 INCLUDE 'mumps_headers.h' 3572 LOGICAL SAME_PROC 3573 INTRINSIC real 3574 IOLDPS = PTLUST_S(STEP(INODE)) 3575 POSELT = PTRAST(STEP(INODE)) 3576 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 3577 NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) 3578 NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) 3579 IF (KEEP(50).EQ.0) THEN 3580 LDAFS_PERE = NFRONT 3581 ELSE 3582 IF ( NSLAVES .eq. 0 ) THEN 3583 LDAFS_PERE = NFRONT 3584 ELSE 3585 LDAFS_PERE = NASS1 3586 ENDIF 3587 ENDIF 3588 HF = 6 + NSLAVES + KEEP(IXSZ) 3589 POSEL1 = POSELT - int(LDAFS_PERE,8) 3590 ISTCHK = PIMASTER(STEP(ISON)) 3591 LSTK = IW(ISTCHK+KEEP(IXSZ)) 3592 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) 3593 HS = 6 + NSLSON + KEEP(IXSZ) 3594 OPASSW = OPASSW + dble(NBROWS*NBCOLS) 3595 NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) 3596 NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) 3597 IF (NPIVS.LT.0) NPIVS = 0 3598 NCOLS = NPIVS + LSTK 3599 SAME_PROC = (ISTCHK.LT.IWPOSCB) 3600 IF (SAME_PROC) THEN 3601 NROWS = NCOLS 3602 ELSE 3603 NROWS = IW(ISTCHK+2+KEEP(IXSZ)) 3604 ENDIF 3605 J1 = ISTCHK + NROWS + HS + NPIVS 3606 IF (KEEP(50).EQ.0) THEN 3607 IF (IS_ofType5or6) THEN 3608 APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) 3609 DO JJ = 1, NBROWS 3610 DO JJ1 = 1, NBCOLS 3611 JJ2 = APOS + int(JJ1-1,8) 3612 A(JJ2)=A(JJ2)+VALSON(JJ1,JJ) 3613 ENDDO 3614 APOS = APOS + int(LDAFS_PERE,8) 3615 ENDDO 3616 ELSE 3617 DO 170 JJ = 1, NBROWS 3618 APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) 3619 DO 160 JJ1 = 1, NBCOLS 3620 JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) 3621 A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 3622 160 CONTINUE 3623 170 CONTINUE 3624 ENDIF 3625 ELSE 3626 IF (IS_ofType5or6) THEN 3627 APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) 3628 DIAG = ROWLIST(1) 3629 DO JJ = 1, NBROWS 3630 DO JJ1 = 1, DIAG 3631 JJ2 = APOS+int(JJ1-1,8) 3632 A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 3633 ENDDO 3634 DIAG = DIAG+1 3635 APOS = APOS + int(LDAFS_PERE,8) 3636 ENDDO 3637 ELSE 3638 DO JJ = 1, NBROWS 3639 IF (ROWLIST(JJ).LE.NASS1.and..NOT.IS_ofType5or6) THEN 3640 APOS = POSEL1 + int(ROWLIST(JJ) - 1,8) 3641 DO JJ1 = 1, NELIM 3642 JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) 3643 A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 3644 ENDDO 3645 IBEG = NELIM+1 3646 ELSE 3647 IBEG = 1 3648 ENDIF 3649 APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) 3650 DO JJ1 = IBEG, NBCOLS 3651 IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT 3652 JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) 3653 A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 3654 ENDDO 3655 ENDDO 3656 ENDIF 3657 ENDIF 3658 RETURN 3659 END SUBROUTINE DMUMPS_39 3660 SUBROUTINE DMUMPS_539 3661 & (N, INODE, IW, LIW, A, LA, 3662 & NBROWS, NBCOLS, 3663 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, 3664 & RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, 3665 & ICNTL, KEEP,KEEP8, MYID) 3666 IMPLICIT NONE 3667 INTEGER N,LIW 3668 INTEGER(8) :: LA 3669 INTEGER KEEP(500), ICNTL(40) 3670 INTEGER(8) KEEP8(150) 3671 INTEGER INODE, MYID 3672 INTEGER NBROWS, NBCOLS 3673 INTEGER(8) :: PTRAST(KEEP(28)) 3674 INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), 3675 & PTRIST(KEEP(28)), FILS(N), PTRARW(N), PTRAIW(N) 3676 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 3677 INTEGER INTARR(max(1,KEEP(14))) 3678 DOUBLE PRECISION A(LA), 3679 & DBLARR(max(1,KEEP(13))) 3680 DOUBLE PRECISION OPASSW, OPELIW 3681 INTEGER(8) :: POSELT, ICT12, APOS 3682 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, 3683 & K1,K2,K,J,JPOS,NASS,JJ, 3684 & IN,AINPUT,JK,J1,J2,IJROW, ILOC 3685 INTEGER :: K1RHS, K2RHS, JFirstRHS 3686 DOUBLE PRECISION ZERO 3687 PARAMETER( ZERO = 0.0D0 ) 3688 INCLUDE 'mumps_headers.h' 3689 IOLDPS = PTRIST(STEP(INODE)) 3690 POSELT = PTRAST(STEP(INODE)) 3691 NBCOLF = IW(IOLDPS+KEEP(IXSZ)) 3692 NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) 3693 NASS = IW(IOLDPS+1+KEEP(IXSZ)) 3694 NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) 3695 HF = 6 + NSLAVES + KEEP(IXSZ) 3696 IF (NASS.LT.0) THEN 3697 NASS = -NASS 3698 IW(IOLDPS+1+KEEP(IXSZ)) = NASS 3699 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = 3700 & ZERO 3701 K1 = IOLDPS + HF + NBROWF 3702 K2 = K1 + NASS - 1 3703 JPOS = 1 3704 DO K = K1, K2 3705 J = IW(K) 3706 ITLOC(J) = -JPOS 3707 JPOS = JPOS + 1 3708 ENDDO 3709 K1 = IOLDPS + HF 3710 K2 = K1 + NBROWF - 1 3711 JPOS = 1 3712 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN 3713 K1RHS = 0 3714 K2RHS = -1 3715 DO K = K1, K2 3716 J = IW(K) 3717 ITLOC(J) = JPOS 3718 IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN 3719 K1RHS = K 3720 JFirstRHS=J-N 3721 ENDIF 3722 JPOS = JPOS + 1 3723 ENDDO 3724 IF (K1RHS.GT.0) K2RHS=K2 3725 IF ( K2RHS.GE.K1RHS ) THEN 3726 IN = INODE 3727 DO WHILE (IN.GT.0) 3728 IJROW = -ITLOC(IN) 3729 DO K = K1RHS, K2RHS 3730 J = IW(K) 3731 ILOC = ITLOC(J) 3732 APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + 3733 & int(IJROW-1,8) 3734 A(APOS) = A(APOS) + RHS_MUMPS( 3735 & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) 3736 ENDDO 3737 IN = FILS(IN) 3738 ENDDO 3739 ENDIF 3740 ELSE 3741 DO K = K1, K2 3742 J = IW(K) 3743 ITLOC(J) = JPOS 3744 JPOS = JPOS + 1 3745 ENDDO 3746 ENDIF 3747 IN = INODE 3748 DO WHILE (IN.GT.0) 3749 AINPUT = PTRARW(IN) 3750 JK = PTRAIW(IN) 3751 JJ = JK + 1 3752 J1 = JJ + 1 3753 J2 = J1 + INTARR(JK) 3754 IJROW = -ITLOC(INTARR(J1)) 3755 ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) 3756 DO JJ= J1,J2 3757 ILOC = ITLOC(INTARR(JJ)) 3758 IF (ILOC.GT.0) THEN 3759 APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) 3760 A(APOS) = A(APOS) + DBLARR(AINPUT) 3761 ENDIF 3762 AINPUT = AINPUT + 1 3763 ENDDO 3764 IN = FILS(IN) 3765 ENDDO 3766 K1 = IOLDPS + HF 3767 K2 = K1 + NBROWF + NASS - 1 3768 DO K = K1, K2 3769 J = IW(K) 3770 ITLOC(J) = 0 3771 ENDDO 3772 ENDIF 3773 IF (NBROWS.GT.0) THEN 3774 K1 = IOLDPS + HF + NBROWF 3775 K2 = K1 + NBCOLF - 1 3776 JPOS = 1 3777 DO K = K1, K2 3778 J = IW(K) 3779 ITLOC(J) = JPOS 3780 JPOS = JPOS + 1 3781 ENDDO 3782 ENDIF 3783 RETURN 3784 END SUBROUTINE DMUMPS_539 3785 SUBROUTINE DMUMPS_531 3786 & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, 3787 & ITLOC, RHS_MUMPS, KEEP,KEEP8) 3788 IMPLICIT NONE 3789 INTEGER N, LIW 3790 INTEGER KEEP(500) 3791 INTEGER(8) KEEP8(150) 3792 INTEGER INODE 3793 INTEGER NBROWS 3794 INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), 3795 & PTRIST(KEEP(28)) 3796 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 3797 INCLUDE 'mumps_headers.h' 3798 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, 3799 & K1,K2,K,J 3800 IOLDPS = PTRIST(STEP(INODE)) 3801 NBCOLF = IW(IOLDPS+KEEP(IXSZ)) 3802 NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) 3803 NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) 3804 HF = 6 + NSLAVES+KEEP(IXSZ) 3805 IF (NBROWS.GT.0) THEN 3806 K1 = IOLDPS + HF + NBROWF 3807 K2 = K1 + NBCOLF - 1 3808 DO K = K1, K2 3809 J = IW(K) 3810 ITLOC(J) = 0 3811 ENDDO 3812 ENDIF 3813 RETURN 3814 END SUBROUTINE DMUMPS_531 3815 SUBROUTINE DMUMPS_40(N, INODE, IW, LIW, A, LA, 3816 & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, 3817 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, 3818 & RHS_MUMPS, FILS, 3819 & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) 3820 IMPLICIT NONE 3821 INTEGER N,LIW 3822 INTEGER(8) :: LA 3823 INTEGER KEEP(500), ICNTL(40) 3824 INTEGER(8) KEEP8(150) 3825 INTEGER INODE, MYID 3826 LOGICAL, intent(in) :: IS_ofType5or6 3827 INTEGER NBROWS, NBCOLS, LDA_VALSON 3828 INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) 3829 INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), 3830 & PTRIST(KEEP(28)), FILS(N) 3831 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 3832 INTEGER(8) :: PTRAST(KEEP(28)) 3833 DOUBLE PRECISION A(LA), VALSON(LDA_VALSON,NBROWS) 3834 DOUBLE PRECISION OPASSW, OPELIW 3835 INTEGER(8) :: POSEL1, POSELT, APOS, K8 3836 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, 3837 & I,J,NASS,IDIAG 3838 INCLUDE 'mumps_headers.h' 3839 INTRINSIC real 3840 IOLDPS = PTRIST(STEP(INODE)) 3841 POSELT = PTRAST(STEP(INODE)) 3842 NBCOLF = IW(IOLDPS+KEEP(IXSZ)) 3843 NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) 3844 NASS = IW(IOLDPS+1+KEEP(IXSZ)) 3845 IF ( NBROWS .GT. NBROWF ) THEN 3846 WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' 3847 WRITE(*,*) ' ERR: INODE =', INODE 3848 WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF 3849 WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST 3850 CALL MUMPS_ABORT() 3851 END IF 3852 NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) 3853 HF = 6 + NSLAVES+KEEP(IXSZ) 3854 IF (NBROWS.GT.0) THEN 3855 POSEL1 = POSELT - int(NBCOLF,8) 3856 IF (KEEP(50).EQ.0) THEN 3857 IF (IS_ofType5or6) THEN 3858 APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) 3859 DO I=1, NBROWS 3860 DO J = 1, NBCOLS 3861 A(APOS+int(J-1,8)) = A( APOS+int(J-1,8)) + VALSON(J,I) 3862 ENDDO 3863 APOS = APOS + int(NBCOLF,8) 3864 END DO 3865 ELSE 3866 DO I=1,NBROWS 3867 APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) 3868 DO J=1,NBCOLS 3869 K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 3870 A(K8) = A(K8) + VALSON(J,I) 3871 ENDDO 3872 ENDDO 3873 ENDIF 3874 ELSE 3875 IF (IS_ofType5or6) THEN 3876 APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) 3877 & + int((NBROWS-1),8)*int(NBCOLF,8) 3878 IDIAG = 0 3879 DO I=NBROWS,1,-1 3880 A(APOS:APOS+int(NBCOLS-IDIAG-1,8))= 3881 & A(APOS:APOS+int(NBCOLS-IDIAG-1,8)) + 3882 & VALSON(1:NBCOLS-IDIAG,I) 3883 APOS = APOS - int(NBCOLF,8) 3884 IDIAG = IDIAG + 1 3885 ENDDO 3886 ELSE 3887 DO I=1,NBROWS 3888 APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) 3889 DO J=1,NBCOLS 3890 IF (ITLOC(COLLIST(J)) .EQ. 0) THEN 3891 write(6,*) ' .. exit for col =', J 3892 EXIT 3893 ENDIF 3894 K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 3895 A(K8) = A(K8) + VALSON(J,I) 3896 ENDDO 3897 ENDDO 3898 ENDIF 3899 ENDIF 3900 OPASSW = OPASSW + dble(NBROWS*NBCOLS) 3901 ENDIF 3902 RETURN 3903 END SUBROUTINE DMUMPS_40 3904 SUBROUTINE DMUMPS_178( A, LA, 3905 & IAFATH, NFRONT, NASS1, 3906 & IACB, NCOLS, LCB, 3907 & IW, NROWS, NELIM, ETATASS, 3908 & CB_IS_COMPRESSED, IS_INPLACE 3909 & ) 3910 IMPLICIT NONE 3911 INTEGER NFRONT, NASS1 3912 INTEGER(8) :: LA 3913 INTEGER NCOLS, NROWS, NELIM 3914 INTEGER(8) :: LCB 3915 DOUBLE PRECISION A( LA ) 3916 INTEGER(8) :: IAFATH, IACB 3917 INTEGER IW( NCOLS ) 3918 INTEGER ETATASS 3919 LOGICAL CB_IS_COMPRESSED, IS_INPLACE 3920 DOUBLE PRECISION ZERO 3921 PARAMETER( ZERO = 0.0D0 ) 3922 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, 3923 & RISK_OF_SAME_POS_THIS_LINE, OMP_FLAG 3924 INTEGER I, J 3925 INTEGER(8) :: APOS, POSELT 3926 INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT 3927 IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 3928 IF ( IS_INPLACE ) THEN 3929 IPOSCB=1_8 3930 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 3931 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 3932 RISK_OF_SAME_POS_THIS_LINE = .FALSE. 3933 DO I=1, NROWS 3934 POSELT = int(IW(I)-1,8) * int(NFRONT,8) 3935 IF (.NOT. CB_IS_COMPRESSED ) THEN 3936 IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) 3937 IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN 3938 RESET_TO_ZERO = .FALSE. 3939 ENDIF 3940 ENDIF 3941 IF ( RISK_OF_SAME_POS ) THEN 3942 IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN 3943 IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. 3944 & IACB+IPOSCB+int(I-1-1,8)) THEN 3945 RISK_OF_SAME_POS_THIS_LINE = .TRUE. 3946 ENDIF 3947 ENDIF 3948 ENDIF 3949 IF (RESET_TO_ZERO) THEN 3950 IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN 3951 DO J=1, I 3952 APOS = POSELT + int(IW( J ),8) 3953 IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN 3954 A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) 3955 A(IACB+IPOSCB-1_8) = ZERO 3956 ENDIF 3957 IPOSCB = IPOSCB + 1_8 3958 ENDDO 3959 ELSE 3960 DO J=1, I 3961 APOS = POSELT + int(IW( J ),8) 3962 A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) 3963 A(IACB+IPOSCB-1_8) = ZERO 3964 IPOSCB = IPOSCB + 1_8 3965 ENDDO 3966 ENDIF 3967 ELSE 3968 DO J=1, I 3969 APOS = POSELT + int(IW( J ),8) 3970 A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) 3971 IPOSCB = IPOSCB + 1_8 3972 ENDDO 3973 ENDIF 3974 IF (.NOT. CB_IS_COMPRESSED ) THEN 3975 IBEGCBROW = IACB+IPOSCB-1_8 3976 IF ( IBEGCBROW .LE. IENDFRONT ) THEN 3977 A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO 3978 ENDIF 3979 ENDIF 3980 IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN 3981 RESET_TO_ZERO = .FALSE. 3982 ENDIF 3983 ENDDO 3984 RETURN 3985 ENDIF 3986 IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN 3987 IPOSCB = 1_8 3988 DO I = 1, NELIM 3989 POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) 3990 IF (.NOT. CB_IS_COMPRESSED) THEN 3991 IPOSCB = 1_8 + int( I - 1, 8 ) * int(NCOLS,8) 3992 ENDIF 3993 DO J = 1, I 3994 APOS = POSELT + int(IW( J ),8) 3995 A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) 3996 & + A(IACB+IPOSCB-1_8) 3997 IPOSCB = IPOSCB + 1_8 3998 END DO 3999 END DO 4000 ENDIF 4001 IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN 4002 OMP_FLAG = (NROWS-NELIM).GE.300 4003 DO I = NELIM + 1, NROWS 4004 IF (CB_IS_COMPRESSED) THEN 4005 IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 4006 ELSE 4007 IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 4008 ENDIF 4009 POSELT = int(IW( I ),8) 4010 IF (POSELT.LE. int(NASS1,8) .AND. .NOT. IS_INPLACE) THEN 4011 DO J = 1, NELIM 4012 APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) 4013 A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + 4014 & A(IACB+IPOSCB-1_8) 4015 IPOSCB = IPOSCB + 1_8 4016 END DO 4017 ELSE 4018 POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) 4019 DO J = 1, NELIM 4020 APOS = POSELT + int(IW( J ), 8) 4021 A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) 4022 & + A(IACB+IPOSCB-1_8) 4023 IPOSCB = IPOSCB + 1_8 4024 END DO 4025 ENDIF 4026 IF (ETATASS.EQ.1) THEN 4027 POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) 4028 DO J = NELIM + 1, I 4029 IF (IW(J).GT.NASS1) EXIT 4030 APOS = POSELT + int(IW( J ), 8) 4031 A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) 4032 & + A(IACB+IPOSCB-1_8) 4033 IPOSCB = IPOSCB +1_8 4034 END DO 4035 ELSE 4036 POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) 4037 DO J = NELIM + 1, I 4038 APOS = POSELT + int(IW( J ), 8) 4039 A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) 4040 & + A(IACB+IPOSCB-1_8) 4041 IPOSCB = IPOSCB + 1_8 4042 END DO 4043 ENDIF 4044 END DO 4045 ELSE 4046 DO I= NROWS, NELIM+1, -1 4047 IF (CB_IS_COMPRESSED) THEN 4048 IPOSCB = (int(I,8)*int(I+1,8))/2_8 4049 ELSE 4050 IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) 4051 ENDIF 4052 POSELT = int(IW( I ),8) 4053 IF (POSELT.LE.int(NASS1,8)) EXIT 4054 POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) 4055 DO J=I,NELIM+1, -1 4056 IF (IW(J).LE.NASS1) EXIT 4057 APOS = POSELT + int(IW( J ), 8) 4058 A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) 4059 & + A(IACB+IPOSCB-1_8) 4060 IPOSCB = IPOSCB - 1_8 4061 ENDDO 4062 ENDDO 4063 ENDIF 4064 RETURN 4065 END SUBROUTINE DMUMPS_178 4066 SUBROUTINE DMUMPS_530(N, ISON, INODE, IWPOSCB, 4067 & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) 4068 IMPLICIT NONE 4069 INTEGER N, ISON, INODE, IWPOSCB 4070 INTEGER KEEP(500), STEP(N) 4071 INTEGER(8) KEEP8(150) 4072 INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) 4073 INTEGER LIW 4074 INTEGER IW(LIW) 4075 INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM 4076 INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF 4077 INTEGER J1, J2, J3, JJ, JPOS 4078 LOGICAL SAME_PROC 4079 INCLUDE 'mumps_headers.h' 4080 ISTCHK = PIMASTER(STEP(ISON)) 4081 LSTK = IW(ISTCHK+KEEP(IXSZ)) 4082 NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) 4083 HS = 6 + NSLSON + KEEP(IXSZ) 4084 NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) 4085 NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) 4086 NCOLS = NPIVS + LSTK 4087 IF ( NPIVS < 0 ) NPIVS = 0 4088 SAME_PROC = ISTCHK < IWPOSCB 4089 IF (SAME_PROC) THEN 4090 NROWS = NCOLS 4091 ELSE 4092 NROWS = IW(ISTCHK+2+KEEP(IXSZ)) 4093 ENDIF 4094 J1 = ISTCHK + NROWS + HS + NPIVS 4095 IF (KEEP(50).NE.0) THEN 4096 J2 = J1 + LSTK - 1 4097 DO JJ = J1, J2 4098 IW(JJ) = IW(JJ - NROWS) 4099 ENDDO 4100 ELSE 4101 J2 = J1 + LSTK - 1 4102 J3 = J1 + NELIM 4103 DO JJ = J3, J2 4104 IW(JJ) = IW(JJ - NROWS) 4105 ENDDO 4106 IF (NELIM .NE. 0) THEN 4107 IOLDPS = PTLUST_S(STEP(INODE)) 4108 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 4109 NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) 4110 HF = 6 + NSLAVES+KEEP(IXSZ) 4111 ICT11 = IOLDPS + HF - 1 + NFRONT 4112 J3 = J3 - 1 4113 DO 190 JJ = J1, J3 4114 JPOS = IW(JJ) + ICT11 4115 IW(JJ) = IW(JPOS) 4116 190 CONTINUE 4117 ENDIF 4118 ENDIF 4119 RETURN 4120 END SUBROUTINE DMUMPS_530 4121 SUBROUTINE DMUMPS_619( 4122 & N, INODE, IW, LIW, A, LA, 4123 & ISON, NBCOLS, 4124 & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, 4125 & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) 4126 USE DMUMPS_LOAD 4127 IMPLICIT NONE 4128 INTEGER KEEP(500) 4129 INTEGER(8) KEEP8(150) 4130 INTEGER(8) :: LA 4131 INTEGER N,LIW,MYID 4132 INTEGER INODE,ISON,IWPOSCB 4133 INTEGER NBCOLS 4134 INTEGER IW(LIW), STEP(N), 4135 & PIMASTER(KEEP(28)), 4136 & PTLUST_S(KEEP(28)) 4137 INTEGER(8) PTRAST(KEEP(28)) 4138 DOUBLE PRECISION A(LA) 4139 DOUBLE PRECISION VALSON(NBCOLS) 4140 DOUBLE PRECISION OPASSW 4141 INTEGER HF,HS, NSLAVES, NASS1, 4142 & IOLDPS, ISTCHK, 4143 & LSTK, NSLSON,NELIM,NPIVS,NCOLS, J1, 4144 & JJ1,NROWS 4145 INTEGER(8) POSELT, APOS, JJ2 4146 INCLUDE 'mumps_headers.h' 4147 LOGICAL SAME_PROC 4148 INTRINSIC real 4149 IOLDPS = PTLUST_S(STEP(INODE)) 4150 POSELT = PTRAST(STEP(INODE)) 4151 NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) 4152 NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) 4153 HF = 6 + NSLAVES + KEEP(IXSZ) 4154 ISTCHK = PIMASTER(STEP(ISON)) 4155 LSTK = IW(ISTCHK + KEEP(IXSZ)) 4156 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) 4157 HS = 6 + NSLSON + KEEP(IXSZ) 4158 NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) 4159 NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) 4160 IF (NPIVS.LT.0) NPIVS = 0 4161 NCOLS = NPIVS + LSTK 4162 SAME_PROC = (ISTCHK.LT.IWPOSCB) 4163 IF (SAME_PROC) THEN 4164 NROWS = NCOLS 4165 ELSE 4166 NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) 4167 ENDIF 4168 J1 = ISTCHK + NROWS + HS + NPIVS 4169 APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 4170 DO JJ1 = 1, NBCOLS 4171 JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) 4172 IF(abs(A(JJ2)) .LT. VALSON(JJ1)) 4173 & A(JJ2) = VALSON(JJ1) 4174 ENDDO 4175 RETURN 4176 END SUBROUTINE DMUMPS_619 4177 RECURSIVE SUBROUTINE DMUMPS_264( 4178 & COMM_LOAD, ASS_IRECV, 4179 & BUFR, LBUFR, 4180 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, 4181 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 4182 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 4183 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 4184 & MYID, COMM, IFLAG, IERROR, NBFIN, 4185 & 4186 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, 4187 & ITLOC, RHS_MUMPS, FILS, 4188 & PTRARW, PTRAIW, INTARR, DBLARR, 4189 & ICNTL, KEEP,KEEP8, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, 4190 & LPTRAR, NELT, FRTPTR, FRTELT, 4191 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 4192 & ) 4193 USE DMUMPS_OOC 4194 USE DMUMPS_LOAD 4195 IMPLICIT NONE 4196 INCLUDE 'dmumps_root.h' 4197 INCLUDE 'mumps_headers.h' 4198 TYPE (DMUMPS_ROOT_STRUC) :: root 4199 INTEGER ICNTL( 40 ), KEEP( 500 ) 4200 INTEGER(8) KEEP8(150) 4201 INTEGER LBUFR, LBUFR_BYTES 4202 INTEGER COMM_LOAD, ASS_IRECV 4203 INTEGER BUFR( LBUFR ) 4204 INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW 4205 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA 4206 INTEGER(8) :: POSFAC 4207 INTEGER COMP 4208 INTEGER IFLAG, IERROR, NBFIN, MSGSOU 4209 INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), 4210 & NSTK_S(KEEP(28)) 4211 INTEGER(8) :: PAMASTER(KEEP(28)) 4212 INTEGER(8) :: PTRAST(KEEP(28)) 4213 INTEGER(8) :: PTRFAC(KEEP(28)) 4214 INTEGER NBPROCFILS( KEEP(28) ), STEP(N), 4215 & PIMASTER(KEEP(28)) 4216 INTEGER IW( LIW ) 4217 DOUBLE PRECISION A( LA ) 4218 INTEGER COMM, MYID 4219 INTEGER NELT, LPTRAR 4220 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 4221 INTEGER PTLUST_S(KEEP(28)), 4222 & ITLOC(N+KEEP(253)), FILS(N), ND(KEEP(28)) 4223 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 4224 INTEGER PTRAIW( LPTRAR ), PTRARW( LPTRAR ) 4225 INTEGER FRERE_STEPS(KEEP(28)) 4226 INTEGER INTARR( max(1,KEEP(14)) ) 4227 DOUBLE PRECISION OPASSW, OPELIW 4228 DOUBLE PRECISION FLOP1 4229 DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 4230 INTEGER LEAF, LPOOL 4231 INTEGER IPOOL( LPOOL ) 4232 INTEGER ISTEP_TO_INIV2(KEEP(71)), 4233 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 4234 INCLUDE 'mpif.h' 4235 INCLUDE 'mumps_tags.h' 4236 INTEGER STATUS( MPI_STATUS_SIZE ) 4237 INTEGER INODE, POSITION, NPIV, IERR, LP 4238 INTEGER NCOL 4239 INTEGER(8) :: POSBLOCFACTO 4240 INTEGER(8) :: LAELL 4241 INTEGER(8) :: POSELT 4242 INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 4243 INTEGER NSLAV1, HS, ISW 4244 INTEGER (8) :: LPOS, LPOS1, LPOS2, IPOS, KPOS 4245 INTEGER ICT11 4246 INTEGER I, IPIV, FPERE 4247 LOGICAL LASTBL 4248 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 4249 DOUBLE PRECISION ONE,ALPHA 4250 PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) 4251 INTEGER(8) :: LAFAC 4252 INTEGER LIWFAC, STRAT, NextPivDummy 4253 TYPE(IO_BLOCK) :: MonBloc 4254 LOGICAL LAST_CALL 4255 INTEGER MUMPS_275 4256 EXTERNAL MUMPS_275 4257 FPERE = -1 4258 POSITION = 0 4259 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, 4260 & MPI_INTEGER, COMM, IERR ) 4261 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, 4262 & MPI_INTEGER, COMM, IERR ) 4263 LASTBL = (NPIV.LE.0) 4264 IF (LASTBL) THEN 4265 NPIV = -NPIV 4266 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, 4267 & MPI_INTEGER, COMM, IERR ) 4268 ENDIF 4269 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, 4270 & MPI_INTEGER, COMM, IERR ) 4271 LAELL = int(NPIV,8) * int(NCOL,8) 4272 IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN 4273 IF ( LRLUS .LT. LAELL ) THEN 4274 IFLAG = -9 4275 CALL MUMPS_731(LAELL - LRLUS, IERROR) 4276 IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN 4277 LP=ICNTL(1) 4278 WRITE(LP,*) 4279 &" FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_264" 4280 ENDIF 4281 GOTO 700 4282 END IF 4283 CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, 4284 & LRLU, IPTRLU, 4285 & IWPOS, IWPOSCB, PTRIST, PTRAST, 4286 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 4287 & KEEP(IXSZ)) 4288 COMP = COMP+1 4289 IF ( LRLU .NE. LRLUS ) THEN 4290 WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' 4291 & ,LRLU,LRLUS 4292 IFLAG = -9 4293 CALL MUMPS_731( LAELL-LRLUS, IERROR ) 4294 GOTO 700 4295 END IF 4296 IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN 4297 IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN 4298 LP=ICNTL(1) 4299 WRITE(LP,*) 4300 &" FAILURE IN INTEGER ALLOCATION DURING DMUMPS_264" 4301 ENDIF 4302 IFLAG = -8 4303 IERROR = IWPOS + NPIV - 1 - IWPOSCB 4304 GOTO 700 4305 END IF 4306 END IF 4307 LRLU = LRLU - LAELL 4308 LRLUS = LRLUS - LAELL 4309 KEEP8(67) = min(LRLUS, KEEP8(67)) 4310 POSBLOCFACTO = POSFAC 4311 POSFAC = POSFAC + LAELL 4312 CALL DMUMPS_471(.FALSE., .FALSE., 4313 & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) 4314 IPIV = IWPOS 4315 IWPOS = IWPOS + NPIV 4316 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4317 & IW( IPIV ), NPIV, 4318 & MPI_INTEGER, COMM, IERR ) 4319 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4320 & A(POSBLOCFACTO), NPIV*NCOL, 4321 & MPI_DOUBLE_PRECISION, 4322 & COMM, IERR ) 4323 IF (PTRIST(STEP( INODE )) .EQ. 0) THEN 4324 DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) 4325 BLOCKING = .TRUE. 4326 SET_IRECV= .FALSE. 4327 MESSAGE_RECEIVED = .FALSE. 4328 CALL DMUMPS_329( COMM_LOAD, 4329 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 4330 & MSGSOU, MAITRE_DESC_BANDE, 4331 & STATUS, 4332 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 4333 & IWPOS, IWPOSCB, IPTRLU, 4334 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 4335 & PTLUST_S, PTRFAC, 4336 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 4337 & IFLAG, IERROR, COMM, 4338 & NBPROCFILS, 4339 & IPOOL, LPOOL, LEAF, 4340 & NBFIN, MYID, SLAVEF, 4341 & 4342 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 4343 & FILS, PTRARW, PTRAIW, 4344 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 4345 & LPTRAR, NELT, FRTPTR, FRTELT, 4346 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 4347 & ) 4348 IF ( IFLAG .LT. 0 ) GOTO 600 4349 END DO 4350 ENDIF 4351 DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) 4352 BLOCKING = .TRUE. 4353 SET_IRECV = .FALSE. 4354 MESSAGE_RECEIVED = .FALSE. 4355 CALL DMUMPS_329( COMM_LOAD, 4356 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 4357 & MPI_ANY_SOURCE, CONTRIB_TYPE2, 4358 & STATUS, 4359 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 4360 & IWPOS, IWPOSCB, IPTRLU, 4361 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 4362 & PTLUST_S, PTRFAC, 4363 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 4364 & IFLAG, IERROR, COMM, 4365 & NBPROCFILS, 4366 & IPOOL, LPOOL, LEAF, 4367 & NBFIN, MYID, SLAVEF, 4368 & 4369 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 4370 & FILS, PTRARW, PTRAIW, 4371 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 4372 & LPTRAR, NELT, FRTPTR, FRTELT, 4373 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 4374 IF ( IFLAG .LT. 0 ) GOTO 600 4375 END DO 4376 SET_IRECV = .TRUE. 4377 BLOCKING = .FALSE. 4378 MESSAGE_RECEIVED = .TRUE. 4379 CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, 4380 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 4381 & MPI_ANY_SOURCE, MPI_ANY_TAG, 4382 & STATUS, 4383 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 4384 & IWPOS, IWPOSCB, IPTRLU, 4385 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 4386 & PTLUST_S, PTRFAC, 4387 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 4388 & IFLAG, IERROR, COMM, 4389 & NBPROCFILS, 4390 & IPOOL, LPOOL, LEAF, 4391 & NBFIN, MYID, SLAVEF, 4392 & 4393 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 4394 & FILS, PTRARW, PTRAIW, 4395 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 4396 & LPTRAR, NELT, FRTPTR, FRTELT, 4397 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 4398 IOLDPS = PTRIST(STEP(INODE)) 4399 POSELT = PTRAST(STEP(INODE)) 4400 LCONT1 = IW( IOLDPS +KEEP(IXSZ)) 4401 NASS1 = IW( IOLDPS + 1 +KEEP(IXSZ)) 4402 NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) 4403 NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) 4404 NSLAV1 = IW( IOLDPS + 5 +KEEP(IXSZ)) 4405 HS = 6 + NSLAV1 + KEEP(IXSZ) 4406 NCOL1 = LCONT1 + NPIV1 4407 IF (NPIV.GT.0) THEN 4408 ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 4409 DO I = 1, NPIV 4410 IF (IW(IPIV+I-1).EQ.I) CYCLE 4411 ISW = IW(ICT11+I) 4412 IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1)) 4413 IW(ICT11+IW(IPIV+I-1)) = ISW 4414 IPOS = POSELT + int(NPIV1 + I - 1,8) 4415 KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8) 4416 CALL dswap(NROW1, A(IPOS), NCOL1, A(KPOS), NCOL1) 4417 ENDDO 4418 LPOS2 = POSELT + int(NPIV1,8) 4419 CALL dtrsm('L','L','N','N',NPIV, NROW1, ONE, 4420 & A(POSBLOCFACTO), NCOL, A(LPOS2), NCOL1) 4421 LPOS1 = POSBLOCFACTO+int(NPIV,8) 4422 LPOS = LPOS2 + int(NPIV,8) 4423 ENDIF 4424 IF (KEEP(201).eq.1) THEN 4425 MonBloc%INODE = INODE 4426 MonBloc%MASTER = .FALSE. 4427 MonBloc%Typenode = 2 4428 MonBloc%NROW = NROW1 4429 MonBloc%NCOL = NCOL1 4430 MonBloc%NFS = NASS1 4431 MonBloc%LastPiv = NPIV1 + NPIV 4432 NULLIFY(MonBloc%INDICES) 4433 MonBloc%Last = LASTBL 4434 STRAT = STRAT_TRY_WRITE 4435 NextPivDummy = -8888 4436 LIWFAC = IW(IOLDPS+XXI) 4437 CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) 4438 LAST_CALL = .FALSE. 4439 CALL DMUMPS_688( STRAT, TYPEF_L, A(POSELT), 4440 & LAFAC, MonBloc, NextPivDummy, NextPivDummy, 4441 & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) 4442 ENDIF 4443 IF ( NPIV .GT. 0 ) THEN 4444 CALL dgemm('N','N', NCOL-NPIV,NROW1,NPIV, 4445 & ALPHA,A(LPOS1),NCOL, 4446 & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 4447 ENDIF 4448 IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV 4449 IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV 4450 IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) ) 4451 IF ( .not. LASTBL .AND. 4452 & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN 4453 write(*,*) ' ERROR 1 **** IN BLACFACTO ' 4454 CALL MUMPS_ABORT() 4455 ENDIF 4456 LRLU = LRLU + LAELL 4457 LRLUS = LRLUS + LAELL 4458 POSFAC = POSFAC - LAELL 4459 CALL DMUMPS_471(.FALSE.,.FALSE., 4460 & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 4461 IWPOS = IWPOS - NPIV 4462 FLOP1 = dble( NPIV1*NROW1 ) + 4463 & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1) 4464 & - 4465 & dble((NPIV1+NPIV)*NROW1 ) - 4466 & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1) 4467 CALL DMUMPS_190( 1, .FALSE., FLOP1, KEEP,KEEP8 ) 4468 IF (LASTBL) THEN 4469 CALL DMUMPS_759( 4470 & COMM_LOAD, ASS_IRECV, 4471 & N, INODE, FPERE, 4472 & root, 4473 & MYID, COMM, 4474 & 4475 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 4476 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 4477 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, 4478 & PAMASTER, 4479 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 4480 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 4481 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 4482 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 4483 & LPTRAR, NELT, FRTPTR, FRTELT, 4484 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 4485 ENDIF 4486 600 CONTINUE 4487 RETURN 4488 700 CONTINUE 4489 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 4490 RETURN 4491 END SUBROUTINE DMUMPS_264 4492 SUBROUTINE DMUMPS_699( COMM_LOAD, ASS_IRECV, 4493 & MSGLEN, BUFR, LBUFR, 4494 & LBUFR_BYTES, PROCNODE_STEPS, 4495 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, 4496 & N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, PTRAST, 4497 & STEP, PIMASTER, PAMASTER, NBPROCFILS, 4498 & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, 4499 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, 4500 & MYID, COMM, ICNTL, KEEP,KEEP8, IFLAG, IERROR, 4501 & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, 4502 & FRTPTR, FRTELT, 4503 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 4504 USE DMUMPS_LOAD 4505 USE DMUMPS_COMM_BUFFER 4506 IMPLICIT NONE 4507 INCLUDE 'dmumps_root.h' 4508 TYPE (DMUMPS_ROOT_STRUC) :: root 4509 INTEGER ICNTL( 40 ), KEEP( 500 ) 4510 INTEGER(8) KEEP8(150) 4511 INTEGER LBUFR, LBUFR_BYTES 4512 INTEGER COMM_LOAD, ASS_IRECV, MSGLEN 4513 INTEGER BUFR( LBUFR ) 4514 INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC 4515 INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW 4516 INTEGER NBFIN 4517 INTEGER COMP 4518 INTEGER NELT, LPTRAR 4519 INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) 4520 INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) 4521 INTEGER(8) :: PTRFAC(KEEP(28)) 4522 INTEGER STEP(N), PIMASTER(KEEP(28)) 4523 INTEGER PTLUST_S( KEEP(28) ) 4524 INTEGER NBPROCFILS( KEEP(28) ) 4525 INTEGER IW( LIW ) 4526 DOUBLE PRECISION A( LA ) 4527 INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N ) 4528 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 4529 INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) 4530 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 4531 INTEGER INTARR( max(1,KEEP(14)) ) 4532 DOUBLE PRECISION DBLARR( max( 1,KEEP(13)) ) 4533 DOUBLE PRECISION OPASSW, OPELIW 4534 INTEGER COMM, MYID, IFLAG, IERROR 4535 INTEGER LEAF, LPOOL 4536 INTEGER IPOOL( LPOOL ) 4537 INTEGER FRTPTR(N+1), FRTELT( NELT ) 4538 INTEGER ISTEP_TO_INIV2(KEEP(71)), 4539 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 4540 INTEGER NFS4FATHER 4541 INCLUDE 'mumps_headers.h' 4542 INCLUDE 'mpif.h' 4543 INCLUDE 'mumps_tags.h' 4544 INTEGER STATUS( MPI_STATUS_SIZE ) 4545 INTEGER MUMPS_275, MUMPS_810 4546 EXTERNAL MUMPS_275, MUMPS_810 4547 INTEGER IERR 4548 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET 4549 INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL 4550 INTEGER LREQI 4551 INTEGER(8) :: LREQA, POSCONTRIB 4552 INTEGER ROW_LENGTH 4553 INTEGER MASTER 4554 INTEGER ISTCHK 4555 LOGICAL SAME_PROC 4556 LOGICAL SLAVE_NODE 4557 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED, IS_ofType5or6 4558 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC 4559 INTEGER TYPESPLIT 4560 POSITION = 0 4561 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, 4562 & MPI_INTEGER, COMM, IERR ) 4563 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1, 4564 & MPI_INTEGER, COMM, IERR ) 4565 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1, 4566 & MPI_INTEGER, COMM, IERR ) 4567 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1, 4568 & MPI_INTEGER, COMM, IERR ) 4569 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4570 & NBROWS_ALREADY_SENT, 1, 4571 & MPI_INTEGER, COMM, IERR ) 4572 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4573 & NBROWS_PACKET, 1, 4574 & MPI_INTEGER, COMM, IERR ) 4575 MASTER = MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 4576 SLAVE_NODE = MASTER .NE. MYID 4577 TYPESPLIT = MUMPS_810(PROCNODE_STEPS(STEP(INODE)), 4578 & SLAVEF) 4579 IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) 4580 IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN 4581 ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) 4582 LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 4583 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) 4584 DO WHILE ( PTRIST( STEP(INODE) ) .EQ. 0 ) 4585 MASTER = MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 4586 BLOCKING = .TRUE. 4587 SET_IRECV = .FALSE. 4588 MESSAGE_RECEIVED = .FALSE. 4589 CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, 4590 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 4591 & MASTER, MAITRE_DESC_BANDE, 4592 & STATUS, 4593 & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, 4594 & PROCNODE_STEPS, POSFAC, 4595 & IWPOS, IWPOSCB, IPTRLU, 4596 & LRLU, LRLUS, N, IW, LIW, A, LA, 4597 & PTRIST, PTLUST_S, PTRFAC, 4598 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 4599 & IFLAG, IERROR, COMM, 4600 & NBPROCFILS, IPOOL, LPOOL, LEAF, 4601 & NBFIN, MYID, SLAVEF, 4602 & 4603 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 4604 & PTRARW, PTRAIW, 4605 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 4606 & LPTRAR, NELT, FRTPTR, FRTELT, 4607 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 4608 IF (IFLAG.LT.0) RETURN 4609 END DO 4610 ENDIF 4611 IF ( SLAVE_NODE ) THEN 4612 LREQI = LROW + NBROWS_PACKET 4613 ELSE 4614 LREQI = NBROWS_PACKET 4615 END IF 4616 LREQA = int(LROW,8) 4617 IF ( LRLU .LT. LREQA .OR. IWPOS + LREQI 4618 & - 1 .GT. IWPOSCB ) THEN 4619 IF ( LRLUS .LT. LREQA ) THEN 4620 IFLAG = -9 4621 CALL MUMPS_731( LREQA - LRLUS, IERROR ) 4622 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 4623 RETURN 4624 END IF 4625 CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, 4626 & LRLU, IPTRLU, 4627 & IWPOS, IWPOSCB, PTRIST, PTRAST, 4628 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 4629 & KEEP(IXSZ)) 4630 COMP = COMP+1 4631 IF ( LRLU .NE. LRLUS ) THEN 4632 WRITE(*,*) 'PB compress ass..process_contrib' 4633 WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS 4634 IFLAG = -9 4635 CALL MUMPS_731( LREQA - LRLUS, IERROR ) 4636 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 4637 RETURN 4638 END IF 4639 IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN 4640 IFLAG = -8 4641 IERROR = IWPOS + LREQI - 1 - IWPOSCB 4642 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 4643 RETURN 4644 END IF 4645 END IF 4646 LRLU = LRLU - LREQA 4647 LRLUS = LRLUS - LREQA 4648 POSCONTRIB = POSFAC 4649 POSFAC = POSFAC + LREQA 4650 KEEP8(67) = min(LRLUS, KEEP8(67)) 4651 CALL DMUMPS_471(.FALSE.,.FALSE., 4652 & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) 4653 IF ( SLAVE_NODE ) THEN 4654 IROW = IWPOS 4655 INDCOL = IWPOS + NBROWS_PACKET 4656 ELSE 4657 IROW = IWPOS 4658 INDCOL = -1 4659 END IF 4660 IWPOS = IWPOS + LREQI 4661 IF ( SLAVE_NODE ) THEN 4662 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4663 & IW( INDCOL ), LROW, MPI_INTEGER, 4664 & COMM, IERR ) 4665 END IF 4666 DO I = 1, NBROWS_PACKET 4667 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4668 & IW( IROW + I - 1 ), 1, MPI_INTEGER, 4669 & COMM, IERR ) 4670 END DO 4671 IF ( SLAVE_NODE ) THEN 4672 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN 4673 NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-1 4674 ENDIF 4675 IF ( KEEP(55) .eq. 0 ) THEN 4676 CALL DMUMPS_539 4677 & (N, INODE, IW, LIW, A, LA, 4678 & NBROW, LROW, 4679 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, 4680 & ITLOC, RHS_MUMPS, 4681 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, 4682 & KEEP,KEEP8, MYID ) 4683 ELSE 4684 CALL DMUMPS_123( 4685 & NELT, FRTPTR, FRTELT, 4686 & N, INODE, IW, LIW, A, LA, 4687 & NBROW, LROW, 4688 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, 4689 & ITLOC, RHS_MUMPS, 4690 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, 4691 & KEEP,KEEP8, MYID ) 4692 ENDIF 4693 DO I=1,NBROWS_PACKET 4694 IF(KEEP(50).NE.0)THEN 4695 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4696 & ROW_LENGTH, 4697 & 1, 4698 & MPI_INTEGER, 4699 & COMM, IERR ) 4700 ELSE 4701 ROW_LENGTH=LROW 4702 ENDIF 4703 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4704 & A(POSCONTRIB), 4705 & ROW_LENGTH, 4706 & MPI_DOUBLE_PRECISION, 4707 & COMM, IERR ) 4708 CALL DMUMPS_40(N, INODE, IW, LIW, A, LA, 4709 & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), 4710 & A(POSCONTRIB), 4711 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, 4712 & ITLOC, RHS_MUMPS, 4713 & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, 4714 & ROW_LENGTH ) 4715 ENDDO 4716 CALL DMUMPS_531 4717 & (N, INODE, IW, LIW, 4718 & NBROWS_PACKET, STEP, PTRIST, 4719 & ITLOC, RHS_MUMPS,KEEP,KEEP8) 4720 ELSE 4721 DO I=1,NBROWS_PACKET 4722 IF(KEEP(50).NE.0)THEN 4723 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4724 & ROW_LENGTH, 4725 & 1, 4726 & MPI_INTEGER, 4727 & COMM, IERR ) 4728 ELSE 4729 ROW_LENGTH=LROW 4730 ENDIF 4731 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4732 & A(POSCONTRIB), 4733 & ROW_LENGTH, 4734 & MPI_DOUBLE_PRECISION, 4735 & COMM, IERR ) 4736 CALL DMUMPS_39(N, INODE, IW, LIW, A, LA, 4737 & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), 4738 & A(POSCONTRIB), PTLUST_S, PTRAST, 4739 & STEP, PIMASTER, OPASSW, 4740 & IWPOSCB, MYID, KEEP,KEEP8, 4741 & IS_ofType5or6, ROW_LENGTH 4742 &) 4743 ENDDO 4744 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN 4745 IF (KEEP(219).NE.0) THEN 4746 IF(KEEP(50) .EQ. 2) THEN 4747 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4748 & NFS4FATHER, 4749 & 1, 4750 & MPI_INTEGER, 4751 & COMM, IERR ) 4752 IF(NFS4FATHER .GT. 0) THEN 4753 CALL DMUMPS_617(NFS4FATHER,IERR) 4754 IF (IERR .NE. 0) THEN 4755 IERROR = BUF_LMAX_ARRAY 4756 IFLAG = -13 4757 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 4758 RETURN 4759 ENDIF 4760 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4761 & BUF_MAX_ARRAY, 4762 & NFS4FATHER, 4763 & MPI_DOUBLE_PRECISION, 4764 & COMM, IERR ) 4765 CALL DMUMPS_619(N, INODE, IW, LIW, A, LA, 4766 & ISON, NFS4FATHER, 4767 & BUF_MAX_ARRAY, PTLUST_S, PTRAST, 4768 & STEP, PIMASTER, OPASSW, 4769 & IWPOSCB, MYID, KEEP,KEEP8) 4770 ENDIF 4771 ENDIF 4772 ENDIF 4773 ENDIF 4774 IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN 4775 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - 1 4776 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 4777 IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN 4778 ISTCHK = PIMASTER(STEP(ISON)) 4779 SAME_PROC= ISTCHK .LT. IWPOSCB 4780 IF (SAME_PROC) THEN 4781 CALL DMUMPS_530(N, ISON, INODE, IWPOSCB, 4782 & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) 4783 ENDIF 4784 IF (SAME_PROC) THEN 4785 ISTCHK = PTRIST(STEP(ISON)) 4786 PTRIST(STEP( ISON) ) = -99999999 4787 ELSE 4788 PIMASTER(STEP( ISON )) = -99999999 4789 ENDIF 4790 CALL DMUMPS_152(.FALSE., MYID, N, ISTCHK, 4791 & PAMASTER(STEP(ISON)), 4792 & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, 4793 & LA, KEEP,KEEP8, .FALSE. 4794 & ) 4795 ENDIF 4796 IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN 4797 CALL DMUMPS_507( N, IPOOL, LPOOL, 4798 & PROCNODE_STEPS, 4799 & SLAVEF, KEEP(28), KEEP(76), KEEP(80), 4800 & KEEP(47), STEP, INODE+N ) 4801 IF (KEEP(47) .GE. 3) THEN 4802 CALL DMUMPS_500( 4803 & IPOOL, LPOOL, 4804 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 4805 & MYID, STEP, N, ND, FILS ) 4806 ENDIF 4807 ENDIF 4808 ENDIF 4809 END IF 4810 IWPOS = IWPOS - LREQI 4811 LRLU = LRLU + LREQA 4812 LRLUS = LRLUS + LREQA 4813 POSFAC = POSFAC - LREQA 4814 CALL DMUMPS_471(.FALSE.,.FALSE., 4815 & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 4816 RETURN 4817 END SUBROUTINE DMUMPS_699 4818 SUBROUTINE DMUMPS_143( N, INODE, IW, LIW, A, LA, 4819 & IOLDPS, POSELT, IFLAG, UU, NOFFW, 4820 & NPVW, 4821 & KEEP,KEEP8, STEP, 4822 & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, 4823 & AVOID_DELAYED, ETATASS, 4824 & DKEEP,PIVNUL_LIST,LPN_LIST, 4825 & IWPOS ) 4826 USE DMUMPS_OOC 4827 IMPLICIT NONE 4828 INTEGER(8) :: LA, POSELT 4829 INTEGER N, INODE, LIW, IFLAG, NOFFW, NPVW 4830 INTEGER IW( LIW ) 4831 DOUBLE PRECISION A( LA ) 4832 INTEGER MYID, SLAVEF, IOLDPS 4833 INTEGER KEEP( 500 ) 4834 INTEGER(8) KEEP8(150) 4835 INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) 4836 DOUBLE PRECISION UU, SEUIL 4837 LOGICAL AVOID_DELAYED 4838 INTEGER ETATASS, IWPOS 4839 INTEGER LPN_LIST 4840 INTEGER PIVNUL_LIST(LPN_LIST) 4841 DOUBLE PRECISION DKEEP(30) 4842 INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK 4843 INTEGER NASS, NEL1, NPIVB, NPIVE, NBOLKJ, NBTLKJ 4844 DOUBLE PRECISION UUTEMP 4845 INTEGER(8) :: LAFAC 4846 INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, 4847 & UNextPiv2beWritten, IFLAG_OOC, 4848 & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, 4849 & PP_LastPIVRPTRFilled_L, 4850 & PP_LastPIVRPTRFilled_U 4851 TYPE(IO_BLOCK) :: MonBloc 4852 LOGICAL LAST_CALL 4853 INCLUDE 'mumps_headers.h' 4854 EXTERNAL MUMPS_330, DMUMPS_221, DMUMPS_233, 4855 & DMUMPS_229, 4856 & DMUMPS_225, DMUMPS_232, DMUMPS_231, 4857 & DMUMPS_220, 4858 & DMUMPS_228, DMUMPS_236 4859 INTEGER MUMPS_330 4860 LOGICAL STATICMODE 4861 DOUBLE PRECISION SEUIL_LOC 4862 INOPV = 0 4863 SEUIL_LOC = SEUIL 4864 IF(KEEP(97) .EQ. 0) THEN 4865 STATICMODE = .FALSE. 4866 ELSE 4867 STATICMODE = .TRUE. 4868 ENDIF 4869 IF (AVOID_DELAYED) THEN 4870 STATICMODE = .TRUE. 4871 UUTEMP=UU 4872 SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) 4873 ELSE 4874 UUTEMP=UU 4875 ENDIF 4876 IBEG_BLOCK=1 4877 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 4878 NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) 4879 IF (NASS .GT. KEEP(3)) THEN 4880 NBOLKJ = min( KEEP(6), NASS ) 4881 ELSE 4882 NBOLKJ = min( KEEP(5), NASS ) 4883 ENDIF 4884 NBTLKJ = NBOLKJ 4885 IF (KEEP(201).EQ.1) THEN 4886 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) 4887 LIWFAC = IW(IOLDPS+XXI) 4888 TYPEFile = TYPEF_BOTH_LU 4889 LNextPiv2beWritten = 1 4890 UNextPiv2beWritten = 1 4891 PP_FIRST2SWAP_L = LNextPiv2beWritten 4892 PP_FIRST2SWAP_U = UNextPiv2beWritten 4893 MonBloc%LastPanelWritten_L = 0 4894 MonBloc%LastPanelWritten_U = 0 4895 PP_LastPIVRPTRFilled_L = 0 4896 PP_LastPIVRPTRFilled_U = 0 4897 MonBloc%INODE = INODE 4898 MonBloc%MASTER = .TRUE. 4899 MonBloc%Typenode = 1 4900 MonBloc%NROW = NFRONT 4901 MonBloc%NCOL = NFRONT 4902 MonBloc%NFS = NASS 4903 MonBloc%Last = .FALSE. 4904 MonBloc%LastPiv = -88877 4905 NULLIFY(MonBloc%INDICES) 4906 ENDIF 4907 50 CONTINUE 4908 CALL DMUMPS_221(NFRONT,NASS,N,INODE,IW,LIW,A,LA,INOPV,NOFFW, 4909 & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, 4910 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, 4911 & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, 4912 & PP_LastPIVRPTRFilled_L, 4913 & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, 4914 & PP_LastPIVRPTRFilled_U) 4915 IF (IFLAG.LT.0) GOTO 500 4916 IF (INOPV.EQ.1) THEN 4917 IF(STATICMODE) THEN 4918 INOPV = -1 4919 GOTO 50 4920 ENDIF 4921 GOTO 80 4922 ENDIF 4923 IF (INOPV.EQ.2) THEN 4924 CALL DMUMPS_233(IBEG_BLOCK, 4925 & NFRONT,NASS,N,INODE,IW,LIW,A,LA, 4926 & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP(IXSZ)) 4927 GOTO 50 4928 ENDIF 4929 NPVW = NPVW + 1 4930 IF (NASS.LE.1) THEN 4931 CALL DMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA, 4932 & IOLDPS,POSELT,KEEP(IXSZ)) 4933 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 4934 GO TO 500 4935 ENDIF 4936 CALL DMUMPS_225(IBEG_BLOCK,NFRONT, NASS, N,INODE,IW,LIW,A,LA, 4937 & IOLDPS,POSELT,IFINB, 4938 & NBTLKJ,KEEP(4),KEEP(IXSZ)) 4939 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 4940 IF (IFINB.EQ.0) GOTO 50 4941 IF (KEEP(201).EQ.1) THEN 4942 MonBloc%LastPiv= IW(IOLDPS+1+KEEP(IXSZ)) 4943 STRAT = STRAT_TRY_WRITE 4944 TYPEFile = TYPEF_U 4945 LAST_CALL = .FALSE. 4946 CALL DMUMPS_688 4947 & ( STRAT, TYPEFile, 4948 & A(POSELT), LAFAC, MonBloc, 4949 & LNextPiv2beWritten, UNextPiv2beWritten, 4950 & IW(IOLDPS), LIWFAC, 4951 & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 4952 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 4953 ENDIF 4954 IF (IFINB.EQ.(-1)) GOTO 80 4955 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 4956 NEL1 = NASS - NPIV 4957 CALL DMUMPS_232(A,LA, 4958 & NFRONT,NPIV,NASS,POSELT,NBTLKJ) 4959 GO TO 50 4960 80 CONTINUE 4961 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 4962 IF (NPIV.LE.0) GO TO 110 4963 NEL1 = NFRONT - NASS 4964 IF (NEL1.LE.0) GO TO 110 4965 IF (KEEP(201).EQ.1) THEN 4966 STRAT = STRAT_TRY_WRITE 4967 TYPEFile = TYPEF_BOTH_LU 4968 MonBloc%LastPiv= NPIV 4969 CALL DMUMPS_642(A(POSELT), LAFAC, NFRONT, 4970 & NPIV, NASS, IW(IOLDPS), LIWFAC, 4971 & MonBloc, TYPEFile, MYID, KEEP8, 4972 & STRAT, IFLAG_OOC, 4973 & LNextPiv2beWritten, UNextPiv2beWritten) 4974 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 4975 ELSE 4976 CALL DMUMPS_231(A,LA,NFRONT, NPIV,NASS,POSELT) 4977 ENDIF 4978 110 CONTINUE 4979 IF (MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 4980 & .EQ.1) THEN 4981 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 4982 IBEG_BLOCK = NPIV 4983 IF (NASS.EQ.NPIV) GOTO 500 4984 120 CALL DMUMPS_220(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 4985 & INOPV,NOFFW,IOLDPS,POSELT,UU,SEUIL, 4986 & KEEP, DKEEP, 4987 & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, 4988 & PP_LastPIVRPTRFilled_L, 4989 & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, 4990 & PP_LastPIVRPTRFilled_U) 4991 IF (INOPV.NE.1) THEN 4992 NPVW = NPVW + 1 4993 CALL DMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 4994 & IOLDPS,POSELT,IFINB,KEEP(IXSZ)) 4995 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 4996 IF (IFINB.EQ.0) GOTO 120 4997 ENDIF 4998 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 4999 NPIVB = IBEG_BLOCK 5000 NPIVE = NPIV - NPIVB 5001 NEL1 = NFRONT - NASS 5002 IF ((NPIVE.LE.0).OR.(NEL1.EQ.0)) GO TO 500 5003 CALL DMUMPS_236(A,LA,NPIVB, 5004 & NFRONT,NPIV,NASS,POSELT) 5005 ENDIF 5006 500 CONTINUE 5007 IF (KEEP(201).EQ.1) THEN 5008 STRAT = STRAT_WRITE_MAX 5009 MonBloc%Last = .TRUE. 5010 MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) 5011 TYPEFile = TYPEF_BOTH_LU 5012 LAST_CALL = .TRUE. 5013 CALL DMUMPS_688 5014 & ( STRAT, TYPEFile, 5015 & A(POSELT), LAFAC, MonBloc, 5016 & LNextPiv2beWritten, UNextPiv2beWritten, 5017 & IW(IOLDPS), LIWFAC, 5018 & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) 5019 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 5020 CALL DMUMPS_644 (IWPOS, 5021 & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) 5022 ENDIF 5023 RETURN 5024 END SUBROUTINE DMUMPS_143 5025 RECURSIVE SUBROUTINE DMUMPS_322( 5026 & COMM_LOAD, ASS_IRECV, 5027 & MSGSOU, MSGTAG, MSGLEN, 5028 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 5029 & IWPOS, IWPOSCB, IPTRLU, 5030 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5031 & PTLUST_S, PTRFAC, 5032 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5033 & IFLAG, IERROR, COMM, 5034 & NBPROCFILS, 5035 & IPOOL, LPOOL, LEAF, 5036 & NBFIN, MYID, SLAVEF, 5037 & 5038 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5039 & FILS, PTRARW, PTRAIW, 5040 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5041 & LPTRAR, NELT, FRTPTR, FRTELT, 5042 & 5043 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 5044 & ) 5045 USE DMUMPS_LOAD 5046 IMPLICIT NONE 5047 INCLUDE 'dmumps_root.h' 5048 INCLUDE 'mumps_headers.h' 5049 TYPE (DMUMPS_ROOT_STRUC) :: root 5050 INTEGER MSGSOU, MSGTAG, MSGLEN 5051 INTEGER LBUFR, LBUFR_BYTES 5052 INTEGER BUFR( LBUFR ) 5053 INTEGER KEEP(500), ICNTL( 40 ) 5054 INTEGER(8) KEEP8(150) 5055 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA 5056 INTEGER IWPOS, IWPOSCB 5057 INTEGER N, LIW 5058 INTEGER IW( LIW ) 5059 DOUBLE PRECISION A( LA ) 5060 INTEGER(8) :: PTRFAC(KEEP(28)) 5061 INTEGER(8) :: PTRAST(KEEP(28)) 5062 INTEGER(8) :: PAMASTER(KEEP(28)) 5063 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) 5064 INTEGER STEP(N), PIMASTER(KEEP(28)) 5065 INTEGER COMP 5066 INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) 5067 INTEGER NBPROCFILS( KEEP(28) ) 5068 INTEGER IFLAG, IERROR, COMM 5069 INTEGER LPOOL, LEAF 5070 INTEGER IPOOL( LPOOL ) 5071 INTEGER COMM_LOAD, ASS_IRECV 5072 INTEGER MYID, SLAVEF, NBFIN 5073 DOUBLE PRECISION OPASSW, OPELIW 5074 INTEGER NELT, LPTRAR 5075 INTEGER FRTPTR( N+1), FRTELT( NELT ) 5076 INTEGER ITLOC( N+KEEP(253) ), FILS( N ) 5077 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 5078 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 5079 INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) 5080 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5081 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5082 INTEGER INTARR( max(1,KEEP(14)) ) 5083 DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 5084 INTEGER INIV2, ISHIFT, IBEG 5085 INTEGER MUMPS_275 5086 EXTERNAL MUMPS_275 5087 LOGICAL FLAG 5088 INTEGER MP, LP 5089 INTEGER TMP( 2 ) 5090 INTEGER NBRECU, POSITION, INODE, ISON, IROOT 5091 INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, 5092 & LMAP, FPERE, NELIM, 5093 & HDMAPLIG,NFS4FATHER, 5094 & TOT_ROOT_SIZE, TOT_CONT_TO_RECV 5095 DOUBLE PRECISION FLOP1 5096 INCLUDE 'mumps_tags.h' 5097 INCLUDE 'mpif.h' 5098 INTEGER IERR, STATUS( MPI_STATUS_SIZE ) 5099 CHARACTER(LEN=35)::SUBNAME 5100 MP = ICNTL(2) 5101 LP = ICNTL(1) 5102 SUBNAME="??????" 5103 CALL DMUMPS_467(COMM_LOAD, KEEP) 5104 IF ( MSGTAG .EQ. RACINE ) THEN 5105 POSITION = 0 5106 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, 5107 & 1, MPI_INTEGER, COMM, IERR) 5108 NBRECU = BUFR( 1 ) 5109 NBFIN = NBFIN - NBRECU 5110 ELSEIF ( MSGTAG .EQ. NOEUD ) THEN 5111 CALL DMUMPS_269( MYID,KEEP,KEEP8, 5112 & BUFR, LBUFR, LBUFR_BYTES, 5113 & IWPOS, IWPOSCB, IPTRLU, 5114 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTRAST, 5115 & STEP, PIMASTER, PAMASTER, 5116 & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, 5117 & ITLOC, RHS_MUMPS ) 5118 SUBNAME="DMUMPS_269" 5119 IF ( IFLAG .LT. 0 ) GO TO 500 5120 IF ( FLAG ) THEN 5121 CALL DMUMPS_507(N, IPOOL, LPOOL, 5122 & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), 5123 & KEEP(80), KEEP(47), STEP, FPERE ) 5124 IF (KEEP(47) .GE. 3) THEN 5125 CALL DMUMPS_500( 5126 & IPOOL, LPOOL, 5127 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 5128 & MYID, STEP, N, ND, FILS ) 5129 ENDIF 5130 CALL MUMPS_137( FPERE, N, 5131 & PROCNODE_STEPS,SLAVEF, 5132 & ND, FILS, FRERE, STEP, PIMASTER, 5133 & KEEP(28), KEEP(50), KEEP(253), FLOP1, 5134 & IW, LIW, KEEP(IXSZ) ) 5135 IF (FPERE.NE.KEEP(20)) 5136 & CALL DMUMPS_190(1,.FALSE.,FLOP1,KEEP,KEEP8) 5137 ENDIF 5138 ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN 5139 INODE = BUFR( 1 ) 5140 CALL DMUMPS_507(N, IPOOL, LPOOL, 5141 & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), 5142 & KEEP(80), KEEP(47), 5143 & STEP, -INODE ) 5144 IF (KEEP(47) .GE. 3) THEN 5145 CALL DMUMPS_500( 5146 & IPOOL, LPOOL, 5147 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 5148 & MYID, STEP, N, ND, FILS ) 5149 ENDIF 5150 ELSEIF ( MSGTAG .EQ. TERREUR ) THEN 5151 IFLAG = -001 5152 IERROR = MSGSOU 5153 GOTO 100 5154 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN 5155 CALL DMUMPS_266( MYID,BUFR, LBUFR, 5156 & LBUFR_BYTES, IWPOS, 5157 & IWPOSCB, 5158 & IPTRLU, LRLU, LRLUS, NBPROCFILS, 5159 & N, IW, LIW, A, LA, 5160 & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, 5161 & KEEP,KEEP8, ITLOC, RHS_MUMPS, 5162 & IFLAG, IERROR ) 5163 SUBNAME="DMUMPS_266" 5164 IF ( IFLAG .LT. 0 ) GO to 500 5165 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN 5166 CALL DMUMPS_268(MYID,BUFR, LBUFR, LBUFR_BYTES, 5167 & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, 5168 & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, 5169 & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5170 & IFLAG, IERROR, COMM, COMM_LOAD, NBPROCFILS, 5171 & IPOOL, LPOOL, LEAF, 5172 & KEEP,KEEP8, ND, FILS, FRERE, ITLOC, RHS_MUMPS, 5173 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5174 SUBNAME="DMUMPS_268" 5175 IF ( IFLAG .LT. 0 ) GO to 500 5176 ELSEIF ( MSGTAG .EQ. BLOC_FACTO ) THEN 5177 CALL DMUMPS_264( COMM_LOAD, ASS_IRECV, 5178 & BUFR, LBUFR, LBUFR_BYTES, 5179 & PROCNODE_STEPS, MSGSOU, 5180 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 5181 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 5182 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 5183 & MYID, COMM , IFLAG, IERROR, NBFIN, 5184 & 5185 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5186 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, 5187 & ICNTL, KEEP,KEEP8, IPOOL, LPOOL, LEAF, ND, FRERE, 5188 & LPTRAR, NELT, FRTPTR, FRTELT, 5189 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5190 ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN 5191 CALL DMUMPS_263( COMM_LOAD, ASS_IRECV, 5192 & BUFR, LBUFR, 5193 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, 5194 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 5195 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 5196 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 5197 & MYID, COMM, IFLAG, IERROR, NBFIN, 5198 & 5199 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5200 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, 5201 & ICNTL, KEEP,KEEP8, IPOOL, LPOOL, LEAF, ND, FRERE, 5202 & LPTRAR, NELT, FRTPTR, FRTELT, 5203 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5204 ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN 5205 CALL DMUMPS_274( COMM_LOAD, ASS_IRECV, 5206 & BUFR, LBUFR, 5207 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, 5208 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 5209 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 5210 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 5211 & MYID, COMM, IFLAG, IERROR, NBFIN, 5212 & 5213 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5214 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, 5215 & ICNTL, KEEP,KEEP8, IPOOL, LPOOL, LEAF, ND, FRERE, 5216 & LPTRAR, NELT, FRTPTR, FRTELT, 5217 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5218 ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN 5219 CALL DMUMPS_699( COMM_LOAD, ASS_IRECV, 5220 & MSGLEN, BUFR, LBUFR, 5221 & LBUFR_BYTES, PROCNODE_STEPS, 5222 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, 5223 & N, IW, LIW, A, LA, PTRIST, 5224 & PTLUST_S, PTRFAC, PTRAST, 5225 & STEP, PIMASTER, PAMASTER, NBPROCFILS, COMP, root, 5226 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, 5227 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, MYID, COMM, 5228 & ICNTL, KEEP,KEEP8, IFLAG, IERROR, IPOOL, LPOOL, LEAF, 5229 & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, 5230 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5231 IF ( IFLAG .LT. 0 ) GO TO 100 5232 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN 5233 HDMAPLIG = 7 5234 INODE = BUFR( 1 ) 5235 ISON = BUFR( 2 ) 5236 NSLAVES_PERE = BUFR( 3 ) 5237 NFRONT_PERE = BUFR( 4 ) 5238 NASS_PERE = BUFR( 5 ) 5239 LMAP = BUFR( 6 ) 5240 NFS4FATHER = BUFR(7) 5241 IF ( (NSLAVES_PERE.NE.0).AND.(KEEP(48).NE.0) ) THEN 5242 INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) 5243 ISHIFT = NSLAVES_PERE+1 5244 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = 5245 & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) 5246 TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE 5247 ELSE 5248 ISHIFT = 0 5249 ENDIF 5250 IBEG = HDMAPLIG+1+ISHIFT 5251 CALL DMUMPS_210( COMM_LOAD, ASS_IRECV, 5252 & BUFR, LBUFR, LBUFR_BYTES, 5253 & INODE, ISON, NSLAVES_PERE, 5254 & BUFR(IBEG), 5255 & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, 5256 & BUFR(IBEG+NSLAVES_PERE), 5257 & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, 5258 & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, 5259 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, 5260 & NSTK_S, COMP, 5261 & IFLAG, IERROR, MYID, COMM, NBPROCFILS, 5262 & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, root, 5263 & OPASSW, OPELIW, 5264 & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, 5265 & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, 5266 & 5267 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 5268 & ) 5269 IF ( IFLAG .LT. 0 ) GO TO 100 5270 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN 5271 CALL DMUMPS_700( 5272 & BUFR, LBUFR, LBUFR_BYTES, 5273 & root, N, IW, LIW, A, LA, NBPROCFILS, 5274 & LRLU, IPTRLU, IWPOS, IWPOSCB, 5275 & PTRIST, PTLUST_S, PTRFAC, PTRAST, 5276 & STEP, PIMASTER, PAMASTER, 5277 & COMP, LRLUS, IPOOL, LPOOL, LEAF, 5278 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 5279 & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, 5280 & ITLOC, RHS_MUMPS, 5281 & ND, PROCNODE_STEPS, SLAVEF) 5282 SUBNAME="DMUMPS_700" 5283 IF ( IFLAG .LT. 0 ) GO TO 500 5284 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN 5285 IROOT = KEEP( 38 ) 5286 MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(IROOT)), 5287 & SLAVEF ) 5288 IF ( PTLUST_S( STEP(IROOT)) .EQ. 0 ) THEN 5289 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, 5290 & MSGSOU, ROOT_2SLAVE, 5291 & COMM, STATUS, IERR ) 5292 CALL DMUMPS_270( TMP( 1 ), TMP( 2 ), 5293 & root, 5294 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 5295 & IWPOS, IWPOSCB, IPTRLU, 5296 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5297 & PTLUST_S, PTRFAC, 5298 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5299 & IFLAG, IERROR, COMM, COMM_LOAD, 5300 & NBPROCFILS, 5301 & IPOOL, LPOOL, LEAF, 5302 & NBFIN, MYID, SLAVEF, 5303 & 5304 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5305 & FILS, PTRARW, PTRAIW, 5306 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND ) 5307 SUBNAME="DMUMPS_270" 5308 IF ( IFLAG .LT. 0 ) GOTO 500 5309 END IF 5310 CALL DMUMPS_700( 5311 & BUFR, LBUFR, LBUFR_BYTES, 5312 & root, N, IW, LIW, A, LA, NBPROCFILS, 5313 & LRLU, IPTRLU, IWPOS, IWPOSCB, 5314 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, 5315 & COMP, LRLUS, IPOOL, LPOOL, LEAF, 5316 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 5317 & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, 5318 & ITLOC, RHS_MUMPS, 5319 & ND, PROCNODE_STEPS, SLAVEF ) 5320 SUBNAME="DMUMPS_700" 5321 IF ( IFLAG .LT. 0 ) GO TO 500 5322 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN 5323 ISON = BUFR( 1 ) 5324 NELIM = BUFR( 2 ) 5325 CALL DMUMPS_271( COMM_LOAD, ASS_IRECV, 5326 & ISON, NELIM, root, 5327 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 5328 & IWPOS, IWPOSCB, IPTRLU, 5329 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5330 & PTLUST_S, PTRFAC, 5331 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5332 & IFLAG, IERROR, COMM, 5333 & NBPROCFILS, 5334 & IPOOL, LPOOL, LEAF, 5335 & NBFIN, MYID, SLAVEF, 5336 & 5337 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5338 & FILS, PTRARW, PTRAIW, 5339 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5340 & LPTRAR, NELT, FRTPTR, FRTELT, 5341 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5342 IF ( IFLAG .LT. 0 ) GO TO 100 5343 IF (MYID.NE.MUMPS_275(PROCNODE_STEPS(STEP(ISON)), 5344 & SLAVEF)) THEN 5345 IF (KEEP(50).EQ.0) THEN 5346 IF (IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)).EQ. 5347 & S_REC_CONTSTATIC) THEN 5348 IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)) = S_ROOT2SON_CALLED 5349 ELSE 5350 CALL DMUMPS_626( N, ISON, PTRIST, PTRAST, 5351 & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, 5352 & IPTRLU, STEP, MYID, KEEP 5353 & ) 5354 ENDIF 5355 ELSE 5356 IF (IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)).EQ. 5357 & S_REC_CONTSTATIC) THEN 5358 IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)) = S_ROOT2SON_CALLED 5359 ELSE 5360 CALL DMUMPS_626( N, ISON, PTRIST, PTRAST, 5361 & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, 5362 & IPTRLU, STEP, MYID, KEEP 5363 & ) 5364 ENDIF 5365 ENDIF 5366 ENDIF 5367 ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN 5368 TOT_ROOT_SIZE = BUFR( 1 ) 5369 TOT_CONT_TO_RECV = BUFR( 2 ) 5370 CALL DMUMPS_270( TOT_ROOT_SIZE, 5371 & TOT_CONT_TO_RECV, root, 5372 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 5373 & IWPOS, IWPOSCB, IPTRLU, 5374 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5375 & PTLUST_S, PTRFAC, 5376 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5377 & IFLAG, IERROR, COMM, COMM_LOAD, 5378 & NBPROCFILS, 5379 & IPOOL, LPOOL, LEAF, 5380 & NBFIN, MYID, SLAVEF, 5381 & 5382 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5383 & FILS, PTRARW, PTRAIW, 5384 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND ) 5385 IF ( IFLAG .LT. 0 ) GO TO 100 5386 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN 5387 ISON = BUFR( 1 ) 5388 NELIM = BUFR( 2 ) 5389 NSLAVES_PERE = BUFR( 3 ) 5390 CALL DMUMPS_273( root, 5391 & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), 5392 & BUFR(4+2*BUFR(2)), 5393 & 5394 & PROCNODE_STEPS, 5395 & IWPOS, IWPOSCB, IPTRLU, 5396 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5397 & PTLUST_S, PTRFAC, 5398 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, 5399 & ITLOC, RHS_MUMPS, COMP, 5400 & IFLAG, IERROR, 5401 & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, 5402 & COMM, COMM_LOAD, FILS, ND) 5403 SUBNAME="DMUMPS_273" 5404 IF ( IFLAG .LT. 0 ) GO TO 500 5405 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN 5406 WRITE(*,*) "Internal error 3 in DMUMPS_322" 5407 CALL MUMPS_ABORT() 5408 ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN 5409 ELSE 5410 IF ( LP > 0 ) 5411 & WRITE(LP,*) MYID, 5412 &': Internal error, routine DMUMPS_322.',MSGTAG 5413 IFLAG = -100 5414 IERROR= MSGTAG 5415 GOTO 500 5416 ENDIF 5417 100 CONTINUE 5418 RETURN 5419 500 CONTINUE 5420 IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN 5421 LP=ICNTL(1) 5422 IF (IFLAG.EQ.-9) THEN 5423 WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME 5424 ENDIF 5425 IF (IFLAG.EQ.-8) THEN 5426 WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME 5427 ENDIF 5428 IF (IFLAG.EQ.-13) THEN 5429 WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME 5430 ENDIF 5431 ENDIF 5432 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 5433 RETURN 5434 END SUBROUTINE DMUMPS_322 5435 RECURSIVE SUBROUTINE DMUMPS_280( 5436 & COMM_LOAD, ASS_IRECV, 5437 & STATUS, 5438 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 5439 & IWPOS, IWPOSCB, IPTRLU, 5440 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5441 & PTLUST_S, PTRFAC, 5442 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5443 & IFLAG, IERROR, COMM, 5444 & NBPROCFILS, 5445 & IPOOL, LPOOL, LEAF, 5446 & NBFIN, MYID, SLAVEF, 5447 & 5448 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5449 & FILS, PTRARW, PTRAIW, 5450 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5451 & LPTRAR, NELT, FRTPTR, FRTELT , 5452 & 5453 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 5454 & ) 5455 IMPLICIT NONE 5456 INCLUDE 'dmumps_root.h' 5457 INCLUDE 'mpif.h' 5458 INCLUDE 'mumps_tags.h' 5459 TYPE (DMUMPS_ROOT_STRUC) :: root 5460 INTEGER STATUS( MPI_STATUS_SIZE ) 5461 INTEGER KEEP(500), ICNTL(40) 5462 INTEGER(8) KEEP8(150) 5463 INTEGER COMM_LOAD, ASS_IRECV 5464 INTEGER LBUFR, LBUFR_BYTES 5465 INTEGER BUFR( LBUFR ) 5466 INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS 5467 INTEGER IWPOS, IWPOSCB 5468 INTEGER N, LIW 5469 INTEGER IW( LIW ) 5470 DOUBLE PRECISION A( LA ) 5471 INTEGER(8) :: PTRFAC(KEEP(28)) 5472 INTEGER(8) :: PTRAST(KEEP(28)) 5473 INTEGER(8) :: PAMASTER(KEEP(28)) 5474 INTEGER PTRIST( KEEP(28) ), 5475 & PTLUST_S(KEEP(28)) 5476 INTEGER STEP(N), PIMASTER(KEEP(28)) 5477 INTEGER COMP 5478 INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) 5479 INTEGER NBPROCFILS( KEEP(28) ) 5480 INTEGER IFLAG, IERROR, COMM 5481 INTEGER LPOOL, LEAF 5482 INTEGER IPOOL( LPOOL ) 5483 INTEGER MYID, SLAVEF, NBFIN 5484 DOUBLE PRECISION OPASSW, OPELIW 5485 INTEGER NELT, LPTRAR 5486 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 5487 INTEGER ITLOC( N+KEEP(253) ), FILS( N ) 5488 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 5489 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 5490 INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) 5491 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5492 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5493 INTEGER INTARR( max(1,KEEP(14)) ) 5494 DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 5495 INTEGER MSGSOU, MSGTAG, MSGLEN, IERR 5496 MSGSOU = STATUS( MPI_SOURCE ) 5497 MSGTAG = STATUS( MPI_TAG ) 5498 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 5499 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 5500 IFLAG = -20 5501 IERROR = MSGLEN 5502 WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', 5503 & MSGTAG,MSGLEN 5504 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 5505 RETURN 5506 ENDIF 5507 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, 5508 & MSGTAG, 5509 & COMM, STATUS, IERR ) 5510 CALL DMUMPS_322( 5511 & COMM_LOAD, ASS_IRECV, 5512 & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, 5513 & LBUFR_BYTES, 5514 & PROCNODE_STEPS, POSFAC, 5515 & IWPOS, IWPOSCB, IPTRLU, 5516 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5517 & PTLUST_S, PTRFAC, 5518 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 5519 & IERROR, COMM, 5520 & NBPROCFILS, 5521 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 5522 & 5523 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5524 & FILS, PTRARW, PTRAIW, 5525 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5526 & LPTRAR, NELT, FRTPTR, FRTELT, 5527 & 5528 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 5529 & ) 5530 RETURN 5531 END SUBROUTINE DMUMPS_280 5532 RECURSIVE SUBROUTINE DMUMPS_329( 5533 & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, 5534 & MESSAGE_RECEIVED, MSGSOU, MSGTAG, 5535 & STATUS, 5536 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 5537 & IWPOS, IWPOSCB, IPTRLU, 5538 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5539 & PTLUST_S, PTRFAC, 5540 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 5541 & IFLAG, IERROR, COMM, NBPROCFILS, 5542 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 5543 & 5544 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5545 & FILS, PTRARW, PTRAIW, 5546 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5547 & LPTRAR, NELT, FRTPTR, FRTELT, 5548 & 5549 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 5550 & STACK_RIGHT_AUTHORIZED ) 5551 USE DMUMPS_LOAD 5552 IMPLICIT NONE 5553 INCLUDE 'dmumps_root.h' 5554 INCLUDE 'mpif.h' 5555 INCLUDE 'mumps_tags.h' 5556 TYPE (DMUMPS_ROOT_STRUC) :: root 5557 INTEGER STATUS( MPI_STATUS_SIZE ) 5558 LOGICAL, INTENT (IN) :: BLOCKING 5559 LOGICAL, INTENT (IN) :: SET_IRECV 5560 LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED 5561 INTEGER, INTENT (IN) :: MSGSOU, MSGTAG 5562 INTEGER KEEP(500), ICNTL(40) 5563 INTEGER(8) KEEP8(150) 5564 INTEGER LBUFR, LBUFR_BYTES 5565 INTEGER COMM_LOAD, ASS_IRECV 5566 INTEGER BUFR( LBUFR ) 5567 INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS 5568 INTEGER IWPOS, IWPOSCB 5569 INTEGER N, LIW 5570 INTEGER IW( LIW ) 5571 DOUBLE PRECISION A( LA ) 5572 INTEGER(8) :: PTRAST(KEEP(28)) 5573 INTEGER(8) :: PTRFAC(KEEP(28)) 5574 INTEGER(8) :: PAMASTER(KEEP(28)) 5575 INTEGER PTRIST( KEEP(28) ), 5576 & PTLUST_S(KEEP(28)) 5577 INTEGER STEP(N), 5578 & PIMASTER(KEEP(28)) 5579 INTEGER COMP 5580 INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) 5581 INTEGER NBPROCFILS( KEEP(28) ) 5582 INTEGER IFLAG, IERROR, COMM 5583 INTEGER LPOOL, LEAF 5584 INTEGER IPOOL( LPOOL ) 5585 INTEGER MYID, SLAVEF, NBFIN 5586 DOUBLE PRECISION OPASSW, OPELIW 5587 INTEGER NELT, LPTRAR 5588 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 5589 INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 5590 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 5591 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 5592 INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) 5593 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5594 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5595 INTEGER INTARR( max(1,KEEP(14)) ) 5596 DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 5597 LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED 5598 LOGICAL FLAG, RIGHT_MESS, FLAGbis 5599 INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC 5600 INTEGER IERR 5601 INTEGER STATUS_BIS( MPI_STATUS_SIZE ) 5602 INTEGER, SAVE :: RECURS = 0 5603 CALL DMUMPS_467(COMM_LOAD, KEEP) 5604 IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN 5605 RETURN 5606 ENDIF 5607 RECURS = RECURS + 1 5608 LP = ICNTL(1) 5609 IF (ICNTL(4).LT.1) LP=-1 5610 IF ( MESSAGE_RECEIVED ) THEN 5611 MSGSOU_LOC = MPI_ANY_SOURCE 5612 MSGTAG_LOC = MPI_ANY_TAG 5613 GOTO 250 5614 ENDIF 5615 IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN 5616 RIGHT_MESS = .TRUE. 5617 IF (BLOCKING) THEN 5618 CALL MPI_WAIT(ASS_IRECV, 5619 & STATUS, IERR) 5620 FLAG = .TRUE. 5621 IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. 5622 & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN 5623 IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN 5624 RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) 5625 ENDIF 5626 IF ( MSGTAG.NE.MPI_ANY_TAG) THEN 5627 RIGHT_MESS = 5628 & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) 5629 ENDIF 5630 IF (.NOT.RIGHT_MESS) THEN 5631 CALL MPI_PROBE(MSGSOU,MSGTAG, 5632 & COMM, STATUS_BIS, IERR) 5633 ENDIF 5634 ENDIF 5635 ELSE 5636 CALL MPI_TEST(ASS_IRECV, 5637 & FLAG, STATUS, IERR) 5638 ENDIF 5639 IF (IERR.LT.0) THEN 5640 IFLAG = -20 5641 IF (LP.GT.0) 5642 & write(LP,*) ' Error return from MPI_TEST ', 5643 & IFLAG, ' in DMUMPS_329' 5644 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 5645 RETURN 5646 ENDIF 5647 IF ( FLAG ) THEN 5648 MESSAGE_RECEIVED = .TRUE. 5649 MSGSOU_LOC = STATUS( MPI_SOURCE ) 5650 MSGTAG_LOC = STATUS( MPI_TAG ) 5651 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) 5652 IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 5653 CALL DMUMPS_322( COMM_LOAD, ASS_IRECV, 5654 & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, 5655 & LBUFR_BYTES, 5656 & PROCNODE_STEPS, POSFAC, 5657 & IWPOS, IWPOSCB, IPTRLU, 5658 & LRLU, LRLUS, N, IW, LIW, A, LA, 5659 & PTRIST, PTLUST_S, PTRFAC, 5660 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 5661 & IERROR, COMM, 5662 & NBPROCFILS, 5663 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 5664 & 5665 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 5666 & PTRARW, PTRAIW, 5667 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5668 & LPTRAR, NELT, FRTPTR, FRTELT, 5669 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5670 IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 5671 IF ( IFLAG .LT. 0 ) RETURN 5672 IF (.NOT.RIGHT_MESS) THEN 5673 IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN 5674 CALL MUMPS_ABORT() 5675 ENDIF 5676 CALL MPI_IPROBE(MSGSOU,MSGTAG, 5677 & COMM, FLAGbis, STATUS, IERR) 5678 IF (FLAGbis) THEN 5679 MSGSOU_LOC = STATUS( MPI_SOURCE ) 5680 MSGTAG_LOC = STATUS( MPI_TAG ) 5681 CALL DMUMPS_280( COMM_LOAD, ASS_IRECV, 5682 & STATUS, BUFR, LBUFR, 5683 & LBUFR_BYTES, 5684 & PROCNODE_STEPS, POSFAC, 5685 & IWPOS, IWPOSCB, IPTRLU, 5686 & LRLU, LRLUS, N, IW, LIW, A, LA, 5687 & PTRIST, PTLUST_S, PTRFAC, 5688 & PTRAST, STEP, PIMASTER, PAMASTER, 5689 & NSTK_S, COMP, IFLAG, 5690 & IERROR, COMM, 5691 & NBPROCFILS, 5692 & IPOOL, LPOOL, LEAF, 5693 & NBFIN, MYID, SLAVEF, 5694 & 5695 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5696 & FILS, PTRARW, PTRAIW, 5697 & INTARR, DBLARR, ICNTL, 5698 & KEEP,KEEP8, ND, FRERE, 5699 & LPTRAR, NELT, FRTPTR, FRTELT, 5700 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5701 IF ( IFLAG .LT. 0 ) RETURN 5702 ENDIF 5703 ENDIF 5704 ENDIF 5705 ELSE 5706 IF (BLOCKING) THEN 5707 CALL MPI_PROBE(MSGSOU,MSGTAG, 5708 & COMM, STATUS, IERR) 5709 FLAG = .TRUE. 5710 ELSE 5711 CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, 5712 & COMM, FLAG, STATUS, IERR) 5713 ENDIF 5714 IF (FLAG) THEN 5715 MSGSOU_LOC = STATUS( MPI_SOURCE ) 5716 MSGTAG_LOC = STATUS( MPI_TAG ) 5717 MESSAGE_RECEIVED = .TRUE. 5718 CALL DMUMPS_280( COMM_LOAD, ASS_IRECV, 5719 & STATUS, BUFR, LBUFR, 5720 & LBUFR_BYTES, 5721 & PROCNODE_STEPS, POSFAC, 5722 & IWPOS, IWPOSCB, IPTRLU, 5723 & LRLU, LRLUS, N, IW, LIW, A, LA, 5724 & PTRIST, PTLUST_S, PTRFAC, 5725 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 5726 & IERROR, COMM, 5727 & NBPROCFILS, 5728 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 5729 & 5730 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5731 & FILS, PTRARW, PTRAIW, 5732 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5733 & LPTRAR, NELT, FRTPTR, FRTELT, 5734 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5735 IF ( IFLAG .LT. 0 ) RETURN 5736 ENDIF 5737 ENDIF 5738 250 CONTINUE 5739 RECURS = RECURS - 1 5740 IF ( NBFIN .EQ. 0 ) RETURN 5741 IF ( RECURS .GT. 3 ) RETURN 5742 IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. 5743 & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. 5744 & MESSAGE_RECEIVED ) THEN 5745 CALL MPI_IRECV ( BUFR(1), 5746 & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, 5747 & MPI_ANY_TAG, COMM, 5748 & ASS_IRECV, IERR ) 5749 ENDIF 5750 RETURN 5751 END SUBROUTINE DMUMPS_329 5752 SUBROUTINE DMUMPS_255( INFO1, 5753 & ASS_IRECV, 5754 & BUFR, LBUFR, LBUFR_BYTES, 5755 & COMM, 5756 & MYID, SLAVEF) 5757 USE DMUMPS_COMM_BUFFER 5758 IMPLICIT NONE 5759 INCLUDE 'mpif.h' 5760 INCLUDE 'mumps_tags.h' 5761 INTEGER LBUFR, LBUFR_BYTES 5762 INTEGER ASS_IRECV 5763 INTEGER BUFR( LBUFR ) 5764 INTEGER COMM 5765 INTEGER MYID, SLAVEF, INFO1, DEST 5766 INTEGER STATUS( MPI_STATUS_SIZE ) 5767 LOGICAL NO_ACTIVE_IRECV 5768 INTEGER MSGSOU_LOC, MSGTAG_LOC 5769 INTEGER IERR, DUMMY 5770 INTRINSIC mod 5771 IF (SLAVEF .EQ. 1) RETURN 5772 IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN 5773 NO_ACTIVE_IRECV=.TRUE. 5774 ELSE 5775 CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, 5776 & STATUS, IERR) 5777 ENDIF 5778 CALL MPI_BARRIER(COMM,IERR) 5779 DUMMY = 1 5780 DEST = mod(MYID+1, SLAVEF) 5781 CALL DMUMPS_62 5782 & (DUMMY, DEST, TAG_DUMMY, COMM, IERR) 5783 IF (NO_ACTIVE_IRECV) THEN 5784 CALL MPI_RECV( BUFR, LBUFR, 5785 & MPI_INTEGER, MPI_ANY_SOURCE, 5786 & TAG_DUMMY, COMM, STATUS, IERR ) 5787 ELSE 5788 CALL MPI_WAIT(ASS_IRECV, 5789 & STATUS, IERR) 5790 ENDIF 5791 RETURN 5792 END SUBROUTINE DMUMPS_255 5793 SUBROUTINE DMUMPS_180( 5794 & INFO1, BUFR, LBUFR, LBUFR_BYTES, 5795 & COMM_NODES, COMM_LOAD, SLAVEF, MP ) 5796 USE DMUMPS_COMM_BUFFER 5797 IMPLICIT NONE 5798 INCLUDE 'mpif.h' 5799 INCLUDE 'mumps_tags.h' 5800 INTEGER LBUFR, LBUFR_BYTES 5801 INTEGER BUFR( LBUFR ) 5802 INTEGER COMM_NODES, COMM_LOAD, SLAVEF, INFO1, MP 5803 INTEGER STATUS( MPI_STATUS_SIZE ) 5804 LOGICAL FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS 5805 INTEGER MSGSOU_LOC, MSGTAG_LOC, COMM_EFF 5806 INTEGER IERR 5807 INTEGER IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS 5808 IF (SLAVEF.EQ.1) RETURN 5809 BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. 5810 10 CONTINUE 5811 FLAG = .TRUE. 5812 DO WHILE ( FLAG ) 5813 COMM_EFF = COMM_NODES 5814 CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, 5815 & COMM_NODES, FLAG, STATUS, IERR) 5816 IF ( .NOT. FLAG ) THEN 5817 COMM_EFF = COMM_LOAD 5818 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 5819 & COMM_LOAD, FLAG, STATUS, IERR) 5820 END IF 5821 IF (FLAG) THEN 5822 MSGSOU_LOC = STATUS( MPI_SOURCE ) 5823 MSGTAG_LOC = STATUS( MPI_TAG ) 5824 CALL MPI_RECV( BUFR, LBUFR_BYTES, 5825 & MPI_PACKED, MSGSOU_LOC, 5826 & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) 5827 ENDIF 5828 END DO 5829 IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN 5830 RETURN 5831 ENDIF 5832 CALL DMUMPS_469(BUFFERS_EMPTY) 5833 IF ( BUFFERS_EMPTY ) THEN 5834 IBUF_EMPTY = 0 5835 ELSE 5836 IBUF_EMPTY = 1 5837 ENDIF 5838 CALL MPI_ALLREDUCE(IBUF_EMPTY, 5839 & IBUF_EMPTY_ON_ALL_PROCS, 5840 & 1, MPI_INTEGER, MPI_MAX, 5841 & COMM_NODES, IERR) 5842 IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN 5843 BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. 5844 ELSE 5845 BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. 5846 ENDIF 5847 GOTO 10 5848 END SUBROUTINE DMUMPS_180 5849 INTEGER FUNCTION DMUMPS_748 5850 & ( HBUF_SIZE, NNMAX, K227, K50 ) 5851 IMPLICIT NONE 5852 INTEGER, INTENT(IN) :: NNMAX, K227, K50 5853 INTEGER(8), INTENT(IN) :: HBUF_SIZE 5854 INTEGER K227_LOC 5855 INTEGER NBCOL_MAX 5856 INTEGER EFFECTIVE_SIZE 5857 NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) 5858 K227_LOC = abs(K227) 5859 IF (K50.EQ.2) THEN 5860 K227_LOC=max(K227_LOC,2) 5861 EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) 5862 ELSE 5863 EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) 5864 ENDIF 5865 IF (EFFECTIVE_SIZE.LE.0) THEN 5866 write(6,*) 'Internal buffers too small to store ', 5867 & ' ONE col/row of size', NNMAX 5868 CALL MUMPS_ABORT() 5869 ENDIF 5870 DMUMPS_748 = EFFECTIVE_SIZE 5871 RETURN 5872 END FUNCTION DMUMPS_748 5873 SUBROUTINE DMUMPS_698( IPIV, LPIV, ISHIFT, 5874 & THE_PANEL, NBROW, NBCOL, KbeforePanel ) 5875 IMPLICIT NONE 5876 INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel 5877 INTEGER IPIV(LPIV) 5878 DOUBLE PRECISION THE_PANEL(NBROW, NBCOL) 5879 INTEGER I, IPERM 5880 DO I = 1, LPIV 5881 IPERM=IPIV(I) 5882 IF ( I+ISHIFT.NE.IPERM) THEN 5883 CALL dswap(NBCOL, 5884 & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, 5885 & THE_PANEL(IPERM-KbeforePanel,1), NBROW) 5886 ENDIF 5887 END DO 5888 RETURN 5889 END SUBROUTINE DMUMPS_698 5890 SUBROUTINE DMUMPS_667(TYPEF, 5891 & NBPANELS, 5892 & I_PIVPTR, I_PIV, IPOS, IW, LIW) 5893 USE MUMPS_OOC_COMMON 5894 IMPLICIT NONE 5895 INCLUDE 'mumps_headers.h' 5896 INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV 5897 INTEGER, intent(in) :: TYPEF 5898 INTEGER, intent(in) :: LIW, IPOS 5899 INTEGER IW(LIW) 5900 INTEGER I_NBPANELS, I_NASS 5901 I_NASS = IPOS 5902 I_NBPANELS = I_NASS + 1 5903 NBPANELS = IW(I_NBPANELS) 5904 I_PIVPTR = I_NBPANELS + 1 5905 I_PIV = I_PIVPTR + NBPANELS 5906 IF (TYPEF==TYPEF_U) THEN 5907 I_NBPANELS = I_PIV+IW(I_NASS) 5908 NBPANELS = IW(I_NBPANELS) 5909 I_PIVPTR = I_NBPANELS + 1 5910 I_PIV = I_PIVPTR + NBPANELS 5911 ENDIF 5912 RETURN 5913 END SUBROUTINE DMUMPS_667 5914 SUBROUTINE DMUMPS_691(K50,NBPANELS_L,NBPANELS_U, 5915 & NASS, IPOS, IW, LIW ) 5916 IMPLICIT NONE 5917 INTEGER K50 5918 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW 5919 INTEGER IW(LIW) 5920 INTEGER IPOS_U 5921 IF (K50.EQ.1) THEN 5922 WRITE(*,*) "Internal error: DMUMPS_691 called" 5923 ENDIF 5924 IW(IPOS)=NASS 5925 IW(IPOS+1)=NBPANELS_L 5926 IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 5927 IF (K50 == 0) THEN 5928 IPOS_U=IPOS+2+NASS+NBPANELS_L 5929 IW(IPOS_U)=NBPANELS_U 5930 IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 5931 ENDIF 5932 RETURN 5933 END SUBROUTINE DMUMPS_691 5934 SUBROUTINE DMUMPS_644 ( 5935 & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP 5936 & ) 5937 USE DMUMPS_OOC 5938 IMPLICIT NONE 5939 INCLUDE 'mumps_headers.h' 5940 INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, 5941 & KEEP(500) 5942 INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) 5943 TYPE(IO_BLOCK), INTENT(IN):: MonBloc 5944 INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, 5945 & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC 5946 LOGICAL FREESPACE 5947 IF (KEEP(50).EQ.1) RETURN 5948 IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN 5949 XSIZE = KEEP(IXSZ) 5950 IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE 5951 CALL DMUMPS_667(TYPEF_L, NBPANELS_L, 5952 & I_PIVRPTR_L, I_PIVR_L, 5953 & IBEGOOC, IW, LIW) 5954 FREESPACE = 5955 & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) 5956 IF (KEEP(50).EQ.0) THEN 5957 CALL DMUMPS_667(TYPEF_U, NBPANELS_U, 5958 & I_PIVRPTR_U, I_PIVR_U, 5959 & IBEGOOC, IW, LIW) 5960 FREESPACE = FREESPACE .AND. 5961 & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) 5962 ENDIF 5963 IF (FREESPACE) THEN 5964 IW(IBEGOOC) = -7777 5965 IW(IOLDPS+XXI) = IBEGOOC - IOLDPS + 1 5966 IWPOS = IBEGOOC+1 5967 ENDIF 5968 RETURN 5969 END SUBROUTINE DMUMPS_644 5970 SUBROUTINE DMUMPS_684(K50, NBROW_L, NBCOL_U, NASS, 5971 & NBPANELS_L, NBPANELS_U, LREQ) 5972 USE DMUMPS_OOC 5973 IMPLICIT NONE 5974 INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS 5975 INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ 5976 NBPANELS_L=-99999 5977 NBPANELS_U=-99999 5978 IF (K50.EQ.1) THEN 5979 LREQ = 0 5980 RETURN 5981 ENDIF 5982 NBPANELS_L = (NASS / DMUMPS_690(NBROW_L))+1 5983 LREQ = 1 5984 & + 1 5985 & + NASS 5986 & + NBPANELS_L 5987 IF (K50.eq.0) THEN 5988 NBPANELS_U = (NASS / DMUMPS_690(NBCOL_U) ) +1 5989 LREQ = LREQ + 1 5990 & + NASS 5991 & + NBPANELS_U 5992 ENDIF 5993 RETURN 5994 END SUBROUTINE DMUMPS_684 5995 SUBROUTINE DMUMPS_755 5996 & (IW_LOCATION, MUST_BE_PERMUTED) 5997 IMPLICIT NONE 5998 INTEGER, INTENT(IN) :: IW_LOCATION 5999 LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED 6000 IF (IW_LOCATION .EQ. -7777) THEN 6001 MUST_BE_PERMUTED = .FALSE. 6002 ENDIF 6003 RETURN 6004 END SUBROUTINE DMUMPS_755 6005