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 ZMUMPS_301( id) 49 USE ZMUMPS_STRUC_DEF 50 USE MUMPS_SOL_ES 51 USE ZMUMPS_COMM_BUFFER 52 USE ZMUMPS_OOC 53 USE TOOLS_COMMON 54 IMPLICIT NONE 55 INTERFACE 56 SUBROUTINE ZMUMPS_710( id, NB_INT,NB_CMPLX ) 57 USE ZMUMPS_STRUC_DEF 58 TYPE (ZMUMPS_STRUC) :: id 59 INTEGER(8) :: NB_INT,NB_CMPLX 60 END SUBROUTINE ZMUMPS_710 61 SUBROUTINE ZMUMPS_758 62 &(idRHS, idINFO, idN, idNRHS, idLRHS) 63 COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS 64 INTEGER, intent(in) :: idN, idNRHS, idLRHS 65 INTEGER, intent(inout) :: idINFO(:) 66 END SUBROUTINE ZMUMPS_758 67 END INTERFACE 68 INCLUDE 'mpif.h' 69 INCLUDE 'mumps_headers.h' 70#if defined(V_T) 71 INCLUDE 'VT.inc' 72#endif 73 INTEGER STATUS( MPI_STATUS_SIZE ) 74 INTEGER MASTER, IERR 75 PARAMETER( MASTER = 0 ) 76 TYPE (ZMUMPS_STRUC), TARGET :: id 77 INTEGER MP,LP, MPG 78 LOGICAL PROK, PROKG 79 INTEGER MTYPE, ICNTL21 80 LOGICAL LSCAL, ERANAL, GIVSOL 81 INTEGER ICNTL10, ICNTL11 82 INTEGER I,K,JPERM, J, II, IZ2 83 INTEGER IZ, NZ_THIS_BLOCK 84 INTEGER LIW 85 INTEGER(8) :: LA, LA_PASSED 86 INTEGER LIW_PASSED 87 INTEGER LWCB_MIN, LWCB, LWCB_SOL_C 88 INTEGER(8) :: TMP_LWCB8 89 INTEGER ZMUMPS_LBUF, ZMUMPS_LBUF_INT 90 INTEGER MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL 91 INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, 92 & IBEG_GLOB_DEF, IEND_GLOB_DEF, 93 & IROOT_DEF_RHS_COL1 94 INTEGER NITREF, NOITER, SOLVET, KASE, JOBIREF 95 COMPLEX(kind=8) RSOL(1) 96 LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS 97 INTEGER :: NRHS_NONEMPTY 98 INTEGER :: STRAT_PERMAM1 99 INTEGER :: K220(0:id%NSLAVES) 100 LOGICAL :: DO_NULL_PIV 101 INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY 102 INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY 103 COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_SPARSE_COPY 104 LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, 105 & RHS_SPARSE_COPY_ALLOCATED 106 INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, 107 & NBCOL_INBLOC, IPOS, NBT 108 INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) 109 INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) 110 INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS 111 COMPLEX(kind=8) ONE 112 COMPLEX(kind=8) ZERO 113 PARAMETER( ONE = (1.0D0,0.0D0) ) 114 PARAMETER( ZERO = (0.0D0,0.0D0) ) 115 DOUBLE PRECISION RZERO, RONE 116 PARAMETER( RZERO = 0.0D0, RONE = 1.0D0 ) 117 COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_MUMPS 118 COMPLEX(kind=8), DIMENSION(:), POINTER :: WORK_WCB 119 COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR_RHS_ROOT 120 INTEGER :: LPTR_RHS_ROOT 121 COMPLEX(kind=8), ALLOCATABLE :: SAVERHS(:), C_RW1(:), 122 & C_RW2(:), 123 & SRW3(:), C_Y(:), 124 & C_W(:) 125 COMPLEX(kind=8), ALLOCATABLE :: CWORK(:) 126 DOUBLE PRECISION, ALLOCATABLE :: R_RW1(:), R_Y(:), D(:) 127 DOUBLE PRECISION, ALLOCATABLE :: R_W(:) 128 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 129 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 130 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV, 131 & POSINRHSCOMP_N 132 INTEGER LIWK_SOLVE, LIWCB 133 INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) 134 INTEGER(8) :: MAXS 135 DOUBLE PRECISION, DIMENSION(:), POINTER :: CNTL 136 INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO 137 INTEGER(8), DIMENSION (:), POINTER :: KEEP8 138 INTEGER, DIMENSION (:), POINTER :: IS 139 DOUBLE PRECISION, DIMENSION(:),POINTER:: RINFOG 140 type scaling_data_t 141 SEQUENCE 142 DOUBLE PRECISION, dimension(:), pointer :: SCALING 143 DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC 144 end type scaling_data_t 145 type (scaling_data_t) :: scaling_data 146 DOUBLE PRECISION, DIMENSION(:), POINTER :: PT_SCALING 147 DOUBLE PRECISION, TARGET :: Dummy_SCAL(1) 148 DOUBLE PRECISION ARRET 149 COMPLEX(kind=8) C_DUMMY(1) 150 DOUBLE PRECISION R_DUMMY(1) 151 INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) 152 INTEGER, TARGET :: IDUMMY_TARGET(1) 153 COMPLEX(kind=8), TARGET :: CDUMMY_TARGET(1) 154 INTEGER JJ, WHAT 155 INTEGER allocok 156 INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, 157 & IBEG, LD_RHS, KDEC, 158 & MASTER_ROOT, MASTER_ROOT_IN_COMM 159 INTEGER IPT_RHS_ROOT, SIZE_ROOT, LD_REDRHS 160 INTEGER IBEG_REDRHS, IBEG_RHSCOMP, LD_RHSCOMP, LENRHSCOMP 161 INTEGER NB_K133, IRANK, TSIZE 162 INTEGER KMAX_246_247 163 LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED 164 INTEGER(8) NB_BYTES 165 INTEGER(8) NB_BYTES_MAX 166 INTEGER(8) NB_BYTES_EXTRA 167 INTEGER(8) NB_INT, NB_CMPLX, K34_8, K35_8, NB_BYTES_ON_ENTRY 168 INTEGER(8) K16_8, ITMP8 169#if defined(V_T) 170 INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, 171 & soln_assem, perm_scal_post 172#endif 173 LOGICAL I_AM_SLAVE, BUILD_POSINRHSCOMP 174 LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE 175 LOGICAL STOP_AT_NEXT_EMPTY_COL 176 INTEGER MTYPE_LOC 177 INTEGER MUMPS_275 178 EXTERNAL MUMPS_275 179#if defined(V_T) 180 CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) 181 CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, 182 & glob_comm_ini,IERR) 183 CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, 184 & perm_scal_ini,IERR) 185 CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) 186 CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) 187 CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, 188 & perm_scal_post,IERR) 189#endif 190 IRHS_PTR_COPY => IDUMMY_TARGET 191 IRHS_PTR_COPY_ALLOCATED = .FALSE. 192 IRHS_SPARSE_COPY => IDUMMY_TARGET 193 IRHS_SPARSE_COPY_ALLOCATED=.FALSE. 194 RHS_SPARSE_COPY => CDUMMY_TARGET 195 RHS_SPARSE_COPY_ALLOCATED=.FALSE. 196 NULLIFY(RHS_MUMPS) 197 NULLIFY(WORK_WCB) 198 IS_INIT_OOC_DONE = .FALSE. 199 WK_USER_PROVIDED = .FALSE. 200 WORK_WCB_ALLOCATED = .FALSE. 201 CNTL =>id%CNTL 202 KEEP =>id%KEEP 203 KEEP8=>id%KEEP8 204 IS =>id%IS 205 ICNTL=>id%ICNTL 206 INFO =>id%INFO 207 RINFOG =>id%RINFOG 208 MP = ICNTL( 2 ) 209 MPG = ICNTL( 3 ) 210 LP = id%ICNTL( 1 ) 211 PROK = (MP.GT.0) 212 PROKG = (MPG.GT.0 .and. id%MYID.eq.MASTER) 213 IF ( PROK ) WRITE(MP,100) 214 IF ( PROKG ) WRITE(MPG,100) 215 NB_BYTES = 0_8 216 NB_BYTES_MAX = 0_8 217 NB_BYTES_EXTRA = 0_8 218 K34_8 = int(KEEP(34), 8) 219 K35_8 = int(KEEP(35), 8) 220 K16_8 = int(KEEP(16), 8) 221 NB_RHSSKIPPED = 0 222 LSCAL = .FALSE. 223 WORK_WCB_ALLOCATED = .FALSE. 224 ICNTL21 = -99998 225 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. 226 & ( id%MYID .eq. MASTER .AND. 227 & KEEP(46) .eq. 1 ) ) 228 CALL ZMUMPS_710 (id, NB_INT,NB_CMPLX ) 229 NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 230 NB_BYTES_ON_ENTRY = NB_BYTES 231 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 232 IF (id%MYID .EQ. MASTER) THEN 233 CALL ZMUMPS_807(id) 234 id%KEEP(111) = id%ICNTL(25) 235 id%KEEP(248) = id%ICNTL(20) 236 ICNTL21 = id%ICNTL(21) 237 IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 238 IF ( id%ICNTL(30) .NE.0 ) THEN 239 id%KEEP(237) = 1 240 ELSE 241 id%KEEP(237) = 0 242 ENDIF 243 IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN 244 id%KEEP(248)=1 245 ENDIF 246 IF (id%KEEP(248) .ne.0.and.id%KEEP(248).ne.1) id%KEEP(248)=0 247 IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN 248 id%KEEP(248) = 0 249 ENDIF 250 IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN 251 id%KEEP(235) = 0 252 ENDIF 253 IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN 254 id%KEEP(235) = 0 255 ENDIF 256 MTYPE = ICNTL( 9 ) 257 IF (id%KEEP(237).NE.0) MTYPE = 1 258 ENDIF 259 CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, 260 & id%COMM,IERR) 261 CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, 262 & IERR ) 263 CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, 264 & IERR ) 265 CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) 266 CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, 267 & IERR ) 268 CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, 269 & IERR ) 270 CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) 271 CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, 272 & IERR ) 273 IF ( id%MYID .EQ. MASTER ) THEN 274 IF (KEEP(201) .EQ. -1) THEN 275 IF (PROKG) WRITE(MPG,'(A)') 276 & ' ERROR: Solve impossible because factors not kept' 277 id%INFO(1)=-44 278 id%INFO(2)=KEEP(251) 279 GOTO 333 280 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 281 & .AND. KEEP(252).EQ.0) THEN 282 IF (PROKG) WRITE(MPG,'(A)') 283 & ' ERROR: Solve impossible because factors not kept' 284 id%INFO(1)=-44 285 id%INFO(2)=KEEP(251) 286 GOTO 333 287 ENDIF 288 IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN 289 IF (PROKG) WRITE(MPG,'(A)') 290 & ' ERROR: id%NRHS not allowed to change when ICNTL(32)=1' 291 id%INFO(1)=-42 292 id%INFO(2)=id%KEEP(253) 293 GOTO 333 294 ENDIF 295 IF (KEEP(252).NE.0 .AND. ICNTL(9).NE.1) THEN 296 INFO(1) = -43 297 INFO(2) = 9 298 IF (PROKG) WRITE(MPG,'(A)') 299 & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', 300 & ' compatible with forward performed during', 301 & ' factorization (ICNTL(32)=1)' 302 GOTO 333 303 ENDIF 304 IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN 305 INFO(1) = -43 306 IF (KEEP(237).NE.0) THEN 307 INFO(2) = 30 308 IF (PROKG) WRITE(MPG,'(A)') 309 & ' ERROR: A-1 functionality incompatible with forward', 310 & ' performed during factorization (ICNTL(32)=1)' 311 ELSE 312 INFO(2) = 20 313 IF (PROKG) WRITE(MPG,'(A)') 314 & ' ERROR: sparse RHS incompatible with forward', 315 & ' performed during factorization (ICNTL(32)=1)' 316 ENDIF 317 GOTO 333 318 ENDIF 319 IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN 320 IF (PROKG) WRITE(MPG,'(A)') 321 & ' ERROR: A-1 functionality is incompatible', 322 & ' with distributed solution.' 323 INFO(1)=-48 324 INFO(2)=21 325 GOTO 333 326 ENDIF 327 IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN 328 IF (PROKG) WRITE(MPG,'(A)') 329 & ' ERROR: A-1 functionality is incompatible', 330 & ' with Schur.' 331 INFO(1)=-48 332 INFO(2)=19 333 GOTO 333 334 ENDIF 335 IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN 336 IF (PROKG) WRITE(MPG,'(A)') 337 & ' ERROR: A-1 functionality is incompatible', 338 & ' with null space.' 339 INFO(1)=-48 340 INFO(2)=25 341 GOTO 333 342 ENDIF 343 IF (id%NRHS .LE. 0) THEN 344 id%INFO(1)=-45 345 id%INFO(2)=id%NRHS 346 GOTO 333 347 ENDIF 348 IF ( (id%KEEP(237).EQ.0) ) THEN 349 IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) 350 & .OR. ICNTL21==0) THEN 351 CALL ZMUMPS_758 352 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) 353 IF (id%INFO(1) .LT. 0) GOTO 333 354 ENDIF 355 ELSE 356 IF (id%NRHS .NE. id%N) THEN 357 id%INFO(1)=-47 358 id%INFO(2)=id%NRHS 359 GOTO 333 360 ENDIF 361 ENDIF 362 IF (id%KEEP(248) == 1) THEN 363 IF ((id%NZ_RHS.LE.0).AND.(KEEP(237).NE.0)) THEN 364 id%INFO(1)=-46 365 id%INFO(2)=id%NZ_RHS 366 GOTO 333 367 ENDIF 368 IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN 369 id%INFO(1)=-46 370 id%INFO(2)=id%NZ_RHS 371 GOTO 333 372 ENDIF 373 IF ( .not. associated(id%RHS_SPARSE) )THEN 374 id%INFO(1)=-22 375 id%INFO(2)=10 376 GOTO 333 377 ENDIF 378 IF ( .not. associated(id%IRHS_SPARSE) )THEN 379 id%INFO(1)=-22 380 id%INFO(2)=11 381 GOTO 333 382 ENDIF 383 IF ( .not. associated(id%IRHS_PTR) )THEN 384 id%INFO(1)=-22 385 id%INFO(2)=12 386 GOTO 333 387 ENDIF 388 IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN 389 id%INFO(1)=-22 390 id%INFO(2)=12 391 GOTO 333 392 END IF 393 IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN 394 id%INFO(1)=-27 395 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) 396 GOTO 333 397 END IF 398 IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN 399 IF (PROKG) THEN 400 write(MPG,*)id%MYID, 401 & " Incompatible values for sparse RHS ", 402 & " id%NZ_RHS,id%N,id%NRHS =", 403 & id%NZ_RHS,id%N,id%NRHS 404 ENDIF 405 id%INFO(1)=-22 406 id%INFO(2)=11 407 GOTO 333 408 END IF 409 IF (id%IRHS_PTR(1).ne.1) THEN 410 id%INFO(1)=-28 411 id%INFO(2)=id%IRHS_PTR(1) 412 GOTO 333 413 END IF 414 IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN 415 id%INFO(1)=-22 416 id%INFO(2)=11 417 GOTO 333 418 END IF 419 IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN 420 id%INFO(1)=-22 421 id%INFO(2)=10 422 GOTO 333 423 END IF 424 ENDIF 425 CALL ZMUMPS_634(ICNTL(1),KEEP(1),MPG,INFO(1)) 426 IF (INFO(1) .LT. 0) GOTO 333 427 IF (KEEP(111).eq.-1.AND.id%NRHS.NE.KEEP(112)+KEEP(17))THEN 428 INFO(1)=-32 429 INFO(2)=id%NRHS 430 GOTO 333 431 ENDIF 432 IF (KEEP(111).gt.0 .AND. id%NRHS .NE. 1) THEN 433 INFO(1)=-32 434 INFO(2)=id%NRHS 435 GOTO 333 436 ENDIF 437 IF (KEEP(111) .NE. 0 .AND. id%KEEP(50) .EQ. 0) THEN 438 IF (PROKG) WRITE(MPG,'(A)') 439 & ' ERROR: null space not available for unsymmetric matrices' 440 INFO(1) = -37 441 INFO(2) = 0 442 GOTO 333 443 ENDIF 444 IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN 445 IF (PROKG) WRITE(MPG,'(A)') 446 & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', 447 & ' incompatible with null space' 448 INFO(1) = -37 449 IF (KEEP(237).NE.0) THEN 450 INFO(2) = 30 451 IF (PROKG) WRITE(MPG,'(A)') 452 & ' ERROR: ICNTL(30) functionality ', 453 & ' incompatible with null space' 454 ELSE 455 IF (PROKG) WRITE(MPG,'(A)') 456 & ' ERROR: ICNTL(20) functionality ', 457 & ' incompatible with null space' 458 INFO(2) = 20 459 ENDIF 460 GOTO 333 461 ENDIF 462 IF (( KEEP(111) .LT. -1 ) .OR. 463 & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. 464 & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) 465 & THEN 466 INFO(1)=-36 467 INFO(2)=KEEP(111) 468 GOTO 333 469 ENDIF 470 END IF 471 IF (ICNTL21==1) THEN 472 IF ( id%MYID .ne. MASTER .OR. 473 & ( id%MYID .eq. MASTER .AND. 474 & id%KEEP(46) .eq. 1 ) ) THEN 475 IF ( id%LSOL_loc < id%KEEP(89) ) THEN 476 id%INFO(1)= -29 477 id%INFO(2)= id%LSOL_loc 478 GOTO 333 479 ENDIF 480 IF (id%KEEP(89) .NE. 0) THEN 481 IF ( .not. associated(id%ISOL_loc) )THEN 482 id%INFO(1)=-22 483 id%INFO(2)=13 484 GOTO 333 485 ENDIF 486 IF ( .not. associated(id%SOL_loc) )THEN 487 id%INFO(1)=-22 488 id%INFO(2)=14 489 GOTO 333 490 ENDIF 491 IF (size(id%ISOL_loc) < id%KEEP(89) ) THEN 492 id%INFO(1)=-22 493 id%INFO(2)=13 494 GOTO 333 495 END IF 496 IF (size(id%SOL_loc) < 497 & (id%NRHS-1)*id%LSOL_loc+id%KEEP(89)) THEN 498 id%INFO(1)=-22 499 id%INFO(2)=14 500 GOTO 333 501 END IF 502 ENDIF 503 ENDIF 504 ENDIF 505 IF (id%MYID .NE. MASTER) THEN 506 IF (id%KEEP(248) == 1) THEN 507 IF ( associated( id%RHS ) ) THEN 508 id%INFO( 1 ) = -22 509 id%INFO( 2 ) = 7 510 GOTO 333 511 END IF 512 IF ( associated( id%RHS_SPARSE ) ) THEN 513 id%INFO( 1 ) = -22 514 id%INFO( 2 ) = 10 515 GOTO 333 516 END IF 517 IF ( associated( id%IRHS_SPARSE ) ) THEN 518 id%INFO( 1 ) = -22 519 id%INFO( 2 ) = 11 520 GOTO 333 521 END IF 522 IF ( associated( id%IRHS_PTR ) ) THEN 523 id%INFO( 1 ) = -22 524 id%INFO( 2 ) = 12 525 GOTO 333 526 END IF 527 END IF 528 ENDIF 529 IF (id%MYID.EQ.MASTER) THEN 530 CALL ZMUMPS_769(id) 531 END IF 532 IF (id%INFO(1) .LT. 0) GOTO 333 533 333 CONTINUE 534 CALL MUMPS_276( id%ICNTL(1), 535 & id%INFO(1), 536 & id%COMM, id%MYID ) 537 IF ( id%INFO(1) .LT. 0 ) GO TO 90 538 IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN 539 CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, 540 & id%COMM,IERR) 541 IF (id%NZ_RHS.EQ.0) THEN 542 IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN 543 LIW_PASSED=max(1,KEEP(32)) 544 IF (KEEP(89) .GT. 0) THEN 545 CALL ZMUMPS_535( MTYPE, id%ISOL_loc(1), 546 & id%PTLUST_S(1), 547 & id%KEEP(1),id%KEEP8(1), 548 & id%IS(1), LIW_PASSED,id%MYID_NODES, 549 & id%N, id%STEP(1), id%PROCNODE_STEPS(1), 550 & id%NSLAVES, scaling_data, LSCAL ) 551 DO J=1, id%NRHS 552 DO I=1, KEEP(89) 553 id%SOL_loc((J-1)*id%LSOL_loc + I) =ZERO 554 ENDDO 555 ENDDO 556 ENDIF 557 ENDIF 558 IF (ICNTL21.NE.1) THEN 559 IF (id%MYID.EQ.MASTER) THEN 560 DO J=1, id%NRHS 561 DO I=1, id%N 562 id%RHS((J-1)*id%LRHS + I) =ZERO 563 ENDDO 564 ENDDO 565 ENDIF 566 ENDIF 567 IF ( PROKG ) THEN 568 WRITE( MPG, 150 ) 569 & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), 570 & ICNTL(20), ICNTL(21), ICNTL(30) 571 IF (KEEP(221).NE.0) THEN 572 WRITE (MPG, 152) KEEP(221) 573 ENDIF 574 IF (KEEP(252).GT.0) THEN 575 WRITE (MPG, 153) KEEP(252) 576 ENDIF 577 ENDIF 578 GOTO 90 579 ENDIF 580 ENDIF 581 IF (id%MYID.EQ.MASTER) THEN 582 IF ((KEEP(111).NE.0)) THEN 583 KEEP(242) = 0 584 ENDIF 585 ENDIF 586 INTERLEAVE_PAR =.FALSE. 587 DO_PERMUTE_RHS =.FALSE. 588 IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN 589 IF (id%KEEP(237).NE.0.AND. 590 & id%KEEP(248).EQ.0) THEN 591 IF (LP.GT.0) THEN 592 WRITE(LP,'(A,I4,I4)') 593 & ' Internal Error in solution driver (A-1) ', 594 & id%KEEP(237), id%KEEP(248) 595 ENDIF 596 CALL MUMPS_ABORT() 597 ENDIF 598 NBT = 0 599 CALL MUMPS_733(id%Step2node, id%KEEP(28), id%INFO, LP, 600 & FORCE=.TRUE., 601 & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) 602 CALL MUMPS_276( ICNTL(1), INFO(1), 603 & id%COMM, id%MYID ) 604 IF ( INFO(1).LT.0 ) RETURN 605 IF (NBT.NE.0) THEN 606 DO I=1, id%N 607 IF (id%STEP(I).LE.0) CYCLE 608 id%Step2node(id%STEP(I)) = I 609 ENDDO 610 ENDIF 611 NB_BYTES = NB_BYTES + int(NBT,8)*K34_8 612 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 613 NB_BYTES_EXTRA = NB_BYTES_EXTRA + int(NBT,8) * K34_8 614 ENDIF 615 IF ( I_AM_SLAVE ) 616 & CALL MUMPS_804(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) 617 DO_NULL_PIV = .TRUE. 618 NBCOL_INBLOC = -9998 619 NZ_THIS_BLOCK= -9998 620 JBEG_RHS = -9998 621 IF (id%MYID.EQ.MASTER) THEN 622 IF( KEEP(111)==0 .AND. KEEP(248)==1 ) THEN 623 NRHS_NONEMPTY = 0 624 DO I=1, id%NRHS 625 IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) 626 & NRHS_NONEMPTY = NRHS_NONEMPTY+1 627 ENDDO 628 IF (NRHS_NONEMPTY.LE.0) THEN 629 IF (LP.GT.0) 630 & WRITE(LP,*) 'Internal error : NRHS_NONEMPTY=', 631 & NRHS_NONEMPTY 632 CALL MUMPS_ABORT() 633 ENDIF 634 ELSE 635 NRHS_NONEMPTY = id%NRHS 636 ENDIF 637 ENDIF 638 BUILD_POSINRHSCOMP = .TRUE. 639 IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN 640 BUILD_POSINRHSCOMP = .FALSE. 641 ENDIF 642 SIZE_ROOT = -33333 643 IF ( KEEP( 38 ) .ne. 0 ) THEN 644 MASTER_ROOT = MUMPS_275( 645 & id%PROCNODE_STEPS(id%STEP( KEEP(38))), 646 & id%NSLAVES ) 647 IF (id%MYID_NODES .eq. MASTER_ROOT) THEN 648 SIZE_ROOT = id%root%TOT_ROOT_SIZE 649 ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN 650 SIZE_ROOT=id%KEEP(116) 651 ENDIF 652 ELSE IF (KEEP( 20 ) .ne. 0 ) THEN 653 MASTER_ROOT = MUMPS_275( 654 & id%PROCNODE_STEPS(id%STEP(KEEP(20))), 655 & id%NSLAVES ) 656 IF (id%MYID_NODES .eq. MASTER_ROOT) THEN 657 SIZE_ROOT = id%IS( 658 & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) 659 ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN 660 SIZE_ROOT=id%KEEP(116) 661 ENDIF 662 ELSE 663 MASTER_ROOT = -44444 664 END IF 665 IF (id%MYID .eq. MASTER) THEN 666 KEEP(84) = ICNTL(27) 667 IF (KEEP(252).NE.0) THEN 668 NBRHS = KEEP(253) 669 ELSE 670 IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN 671 NBRHS = abs(KEEP(84)) 672 ELSE 673 NBRHS = -2*KEEP(84) 674 END IF 675 IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY 676 ENDIF 677 ENDIF 678#if defined(V_T) 679 CALL VTBEGIN(glob_comm_ini,IERR) 680#endif 681 CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, 682 & id%COMM,IERR) 683 CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, 684 & id%COMM,IERR) 685 IF (KEEP(201).GT.0) THEN 686 IF (I_AM_SLAVE) THEN 687 IF (KEEP(201).EQ.1 688 & .AND.KEEP(50).EQ.0 689 & .AND.KEEP(251).NE.2 690 & ) THEN 691 OOC_NB_FILE_TYPE=2 692 ELSE 693 OOC_NB_FILE_TYPE=1 694 ENDIF 695 ENDIF 696 WORKSPACE_MINIMAL_PREFERRED = .FALSE. 697 IF (id%MYID .eq. MASTER) THEN 698 KEEP(107) = max(0,KEEP(107)) 699 IF ((KEEP(107).EQ.0).AND. 700 & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN 701 WORKSPACE_MINIMAL_PREFERRED=.TRUE. 702 ENDIF 703 ENDIF 704 CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, 705 & MASTER, id%COMM, IERR ) 706 CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, 707 & MASTER, id%COMM, IERR ) 708 CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, 709 & MASTER, id%COMM, IERR ) 710 CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, 711 & MPI_LOGICAL, 712 & MASTER, id%COMM, IERR ) 713 ENDIF 714 IF ( I_AM_SLAVE ) THEN 715 NB_K133 = 3 716 IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN 717 IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN 718 IF ( 719 & .NOT. associated(id%root%RHS_CNTR_MASTER_ROOT) 720 & ) THEN 721 NB_K133 = NB_K133 + 1 722 ENDIF 723 END IF 724 ENDIF 725 LWCB_MIN = NB_K133*KEEP(133)*NBRHS 726 WK_USER_PROVIDED = (id%LWK_USER.NE.0) 727 IF (id%LWK_USER.EQ.0) THEN 728 ITMP8 = 0_8 729 ELSE IF (id%LWK_USER.GT.0) THEN 730 ITMP8= int(id%LWK_USER,8) 731 ELSE 732 ITMP8 = -int(id%LWK_USER,8)* 1000000_8 733 ENDIF 734 IF (KEEP(201).EQ.0) THEN 735 IF (ITMP8.NE.KEEP8(24)) THEN 736 INFO(1) = -41 737 INFO(2) = id%LWK_USER 738 GOTO 99 739 ENDIF 740 ELSE 741 KEEP8(24)=ITMP8 742 ENDIF 743 MAXS = 0_8 744 IF (WK_USER_PROVIDED) THEN 745 MAXS = KEEP8(24) 746 IF (MAXS.LT. KEEP8(20)) THEN 747 INFO(1)= -11 748 ITMP8 = KEEP8(20)+1_8-MAXS 749 CALL MUMPS_731(ITMP8, INFO(2)) 750 ENDIF 751 IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) 752 ELSE IF (associated(id%S)) THEN 753 MAXS = KEEP8(23) 754 ELSE 755 IF (KEEP(201).EQ.0) THEN 756 WRITE(*,*) ' Working array S not allocated ', 757 & ' on entry to solve phase (in core) ' 758 CALL MUMPS_ABORT() 759 ELSE 760 IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) 761 & THEN 762 MAXS = KEEP8(20) + 1_8 763 ELSE IF ( KEEP(209) .GE.0 ) THEN 764 MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) 765 ELSE 766 MAXS = id%KEEP8(14) 767 ENDIF 768 ALLOCATE (id%S(MAXS), stat = allocok) 769 KEEP8(23)=MAXS 770 IF ( allocok .GT. 0 ) THEN 771 WRITE(*,*) ' Problem allocation of S at solve' 772 INFO(1) = -13 773 CALL MUMPS_731(MAXS, INFO(2)) 774 NULLIFY(id%S) 775 KEEP8(23)=0_8 776 ENDIF 777 NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 778 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 779 ENDIF 780 ENDIF 781 IF(KEEP(201).EQ.0)THEN 782 LA = KEEP8(31) 783 ELSE 784 LA = MAXS 785 IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN 786 LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) 787 ENDIF 788 ENDIF 789 IF ( MAXS-LA .GT. int(LWCB_MIN,8) ) THEN 790 TMP_LWCB8 = min( MAXS - LA, int(huge(LWCB),8) ) 791 LWCB = int( TMP_LWCB8, kind(LWCB) ) 792 WORK_WCB => id%S(LA+1_8:LA+TMP_LWCB8) 793 WORK_WCB_ALLOCATED=.FALSE. 794 ELSE 795 LWCB = LWCB_MIN 796 ALLOCATE(WORK_WCB(LWCB_MIN), stat = allocok) 797 IF (allocok < 0 ) THEN 798 INFO(1)=-13 799 INFO(2)=LWCB_MIN 800 ENDIF 801 WORK_WCB_ALLOCATED=.TRUE. 802 NB_BYTES = NB_BYTES + int(size(WORK_WCB),8)*K35_8 803 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 804 ENDIF 805 ENDIF 806 99 CONTINUE 807 CALL MUMPS_276( ICNTL(1), INFO(1), 808 & id%COMM,id%MYID) 809 IF (INFO(1) < 0) GOTO 90 810 IF ( I_AM_SLAVE ) THEN 811 IF (KEEP(201).GT.0) THEN 812 CALL ZMUMPS_590(LA) 813 CALL ZMUMPS_586(id) 814 IS_INIT_OOC_DONE = .TRUE. 815 ENDIF 816 ENDIF 817 CALL MUMPS_276( ICNTL(1), INFO(1), 818 & id%COMM,id%MYID) 819 IF (INFO(1) < 0) GOTO 90 820 IF (id%MYID .eq. MASTER) THEN 821 IF ( (KEEP(242).NE.0) .or. (KEEP(243).NE.0) ) THEN 822 IF ( (KEEP(237) .EQ.0) .and. (KEEP(111).EQ.0) ) THEN 823 KEEP(242) = 0 824 KEEP(243) = 0 825 ENDIF 826 ENDIF 827 IF ( PROKG ) THEN 828 WRITE( MPG, 150 ) 829 & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), 830 & ICNTL(20), ICNTL(21), ICNTL(30) 831 IF (KEEP(111).NE.0) THEN 832 WRITE (MPG, 151) KEEP(111) 833 ENDIF 834 IF (KEEP(221).NE.0) THEN 835 WRITE (MPG, 152) KEEP(221) 836 ENDIF 837 IF (KEEP(252).GT.0) THEN 838 WRITE (MPG, 153) KEEP(252) 839 ENDIF 840 ENDIF 841 LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( 842 & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) 843 ERANAL = ((ICNTL(11) .GT. 0) .OR. (ICNTL(10) .GT. 0)) 844 IF ( (KEEP(55).eq.0) .AND. KEEP(54).eq.0 .AND. 845 & .NOT.associated(id%A) ) THEN 846 ICNTL10 = 0 847 ICNTL11 = 0 848 ERANAL = .FALSE. 849 ELSE 850 ICNTL10 = ICNTL(10) 851 ICNTL11 = ICNTL(11) 852 ENDIF 853 IF ((KEEP(111).NE.0).OR.(KEEP(237).NE.0).OR. 854 & (KEEP(252).NE.0) ) THEN 855 IF (ICNTL10 .GT. 0) THEN 856 IF (PROKG) WRITE(MPG,'(A)') 857 & ' WARNING: ICNTL(10) treated as if set to 0 ' 858 ENDIF 859 IF (ICNTL11 .GT. 0) THEN 860 IF (PROKG) WRITE(MPG,'(A)') 861 & ' WARNING: ICNTL(11) treated as if set to 0 ' 862 ENDIF 863 ICNTL10 = 0 864 ICNTL11 = 0 865 ERANAL = .FALSE. 866 END IF 867 IF (KEEP(221).NE.0) THEN 868 IF (ICNTL10 .GT. 0) THEN 869 IF (PROKG) WRITE(MPG,'(A)') 870 & ' WARNING: ICNTL(10) treated as if set to 0 (reduced RHS))' 871 ENDIF 872 IF (ICNTL11 .GT. 0) THEN 873 IF (PROKG) WRITE(MPG,'(A)') 874 & ' WARNING: ICNTL(11) treated as if set to 0 (reduced RHS)' 875 ENDIF 876 ICNTL10 = 0 877 ICNTL11 = 0 878 ERANAL = .FALSE. 879 END IF 880 IF ((ERANAL .AND. NBRHS > 1) .OR. ICNTL(21) > 0) THEN 881 IF (ICNTL11 > 0) THEN 882 IF (PROKG) WRITE(MPG,'(A)') 883 & ' WARNING: ICNTL(11) treated as if set to zero' 884 ICNTL11=0 885 ENDIF 886 IF (ICNTL10 > 0) THEN 887 IF (PROKG) WRITE(MPG,'(A)') 888 & ' WARNING: ICNTL(10) treated as if set to zero' 889 ICNTL10=0 890 ENDIF 891 ERANAL = .FALSE. 892 ENDIF 893 IF (ERANAL) THEN 894 ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) 895 IF ( allocok .GT. 0 ) THEN 896 WRITE(*,*) ' Problem in solve: error allocating SAVERHS' 897 INFO(1) = -13 898 INFO(2) = id%N*NBRHS 899 GOTO 111 900 END IF 901 NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 902 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 903 ENDIF 904 IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN 905 IF (PROKG) WRITE(MPG,'(A)') 906 & ' WARNING: KEEP(237) treated as if set to 0 (null space)' 907 KEEP(237)=0 908 ENDIF 909 IF (KEEP(242).EQ.0) KEEP(243)=0 910 END IF 911 CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, 912 & id%COMM,IERR) 913 CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, 914 & id%COMM,IERR) 915 CALL MPI_BCAST(ICNTL21,1,MPI_INTEGER,MASTER, 916 & id%COMM,IERR) 917 CALL MPI_BCAST(ERANAL,1,MPI_LOGICAL,MASTER, 918 & id%COMM,IERR) 919 CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, 920 & id%COMM,IERR) 921 CALL MPI_BCAST(KEEP(111),1,MPI_INTEGER,MASTER, 922 & id%COMM,IERR) 923 CALL MPI_BCAST(KEEP(242),1,MPI_INTEGER,MASTER, 924 & id%COMM,IERR) 925 CALL MPI_BCAST(KEEP(243),1,MPI_INTEGER,MASTER, 926 & id%COMM,IERR) 927 DO_PERMUTE_RHS = (KEEP(242).NE.0) 928 IF ( KEEP(242).NE.0) THEN 929 IF ((KEEP(237).EQ.0).AND.(KEEP(111).EQ.0)) THEN 930 IF (MP.GT.0) THEN 931 write(MP,*) ' Warning incompatible options ', 932 & ' permute RHS reset to false ' 933 ENDIF 934 DO_PERMUTE_RHS = .FALSE. 935 ENDIF 936 ENDIF 937 IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) 938 & ) THEN 939 IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN 940 INTERLEAVE_PAR= .TRUE. 941 ELSE 942 IF (PROKG) THEN 943 write(MPG,*) ' Warning incompatible options ', 944 & ' interleave RHS reset to false ' 945 ENDIF 946 ENDIF 947 ENDIF 948#if defined(check) 949 IF ( id%MYID_NODES .EQ. MASTER ) THEN 950 WRITE(*,*) " ES A-1 DO_Perm Interleave =" 951 WRITE(*,144) id%KEEP(235), id%KEEP(237), 952 & id%KEEP(242),id%KEEP(243) 953 ENDIF 954#endif 955 MSG_MAX_BYTES_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + 956 & KEEP(133) * NBRHS * KEEP(35) 957 & + 16 * KEEP(34) 958 IF (KEEP(237).EQ.0) THEN 959 KMAX_246_247 = max(KEEP(246),KEEP(247)) 960 MSG_MAX_BYTES_GTHRSOL = ( ( 2 + KMAX_246_247 ) * KEEP(34) + 961 & KMAX_246_247 * NBRHS * KEEP(35) ) 962 ELSE 963 MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) 964 ENDIF 965 id%LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) 966 TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), 967 & 10000000_8)) 968 id%LBUFR_BYTES = max(id%LBUFR_BYTES,TSIZE) 969 id%LBUFR = ( id%LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) 970 IF ( associated (id%BUFR) ) THEN 971 NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 972 DEALLOCATE(id%BUFR) 973 NULLIFY(id%BUFR) 974 ENDIF 975 ALLOCATE (id%BUFR(id%LBUFR),stat=allocok) 976 IF ( allocok .GT. 0 ) THEN 977 IF (LP.GT.0) 978 & WRITE(LP,*) id%MYID, 979 & ' Problem in solve: error allocating BUFR' 980 INFO(1) = -13 981 INFO(2) = id%LBUFR 982 GOTO 111 983 ENDIF 984 NB_BYTES = NB_BYTES + int(size(id%BUFR),8)*K34_8 985 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 986 IF ( I_AM_SLAVE ) THEN 987 ZMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) 988 & * KEEP(34) 989 CALL ZMUMPS_55( ZMUMPS_LBUF_INT, IERR ) 990 IF ( IERR .NE. 0 ) THEN 991 INFO(1) = -13 992 INFO(2) = ZMUMPS_LBUF_INT 993 IF ( LP .GT. 0 ) THEN 994 WRITE(LP,*) id%MYID, 995 & ':Error allocating small Send buffer:IERR=',IERR 996 END IF 997 GOTO 111 998 END IF 999 ZMUMPS_LBUF = (MSG_MAX_BYTES_SOLVE + 2*KEEP(34) )*id%NSLAVES 1000 ZMUMPS_LBUF = min(ZMUMPS_LBUF, 100 000 000) 1001 ZMUMPS_LBUF = max(ZMUMPS_LBUF, 1002 & (MSG_MAX_BYTES_SOLVE+2*KEEP(34)) * min(id%NSLAVES,3)) 1003 ZMUMPS_LBUF = ZMUMPS_LBUF + KEEP(34) 1004 CALL ZMUMPS_53( ZMUMPS_LBUF, IERR ) 1005 IF ( IERR .NE. 0 ) THEN 1006 INFO(1) = -13 1007 INFO(2) = ZMUMPS_LBUF/KEEP(34) + 1 1008 IF ( LP .GT. 0 ) THEN 1009 WRITE(LP,*) id%MYID, 1010 & ':Error allocating Send buffer:IERR=', IERR 1011 END IF 1012 GOTO 111 1013 END IF 1014 ENDIF 1015 IF ( 1016 & ( id%MYID .NE. MASTER ) 1017 & .or. 1018 & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. 1019 & ICNTL21 .NE.0 .AND. 1020 & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 1021 & .OR. KEEP(111).NE.0 ) 1022 & ) 1023 & .or. 1024 & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) 1025 & ) THEN 1026 ALLOCATE(RHS_MUMPS(id%N*NBRHS),stat=IERR) 1027 NB_BYTES = NB_BYTES + int(size(RHS_MUMPS),8)*K35_8 1028 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1029 IF ( IERR .GT. 0 ) THEN 1030 INFO(1)=-13 1031 INFO(2)=id%N*NBRHS 1032 IF (LP > 0) 1033 & WRITE(LP,*) 'ERROR while allocating RHS on a slave' 1034 GOTO 111 1035 END IF 1036 ELSE 1037 RHS_MUMPS=>id%RHS 1038 ENDIF 1039 IF ( I_AM_SLAVE ) THEN 1040 LD_RHSCOMP = max(KEEP(89),1) 1041 IF (id%MYID.EQ.MASTER) THEN 1042 LD_RHSCOMP = max(LD_RHSCOMP, KEEP(247)) 1043 ENDIF 1044 IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN 1045 IF (.NOT.associated(id%RHSCOMP)) THEN 1046 INFO(1) = -35 1047 INFO(2) = 1 1048 GOTO 111 1049 ENDIF 1050 IF (.NOT.associated(id%POSINRHSCOMP)) THEN 1051 INFO(1) = -35 1052 INFO(2) = 2 1053 GOTO 111 1054 ENDIF 1055 LENRHSCOMP = size(id%RHSCOMP) 1056 LD_RHSCOMP = LENRHSCOMP/id%NRHS 1057 ELSE IF (KEEP(221).EQ.1) THEN 1058 IF (associated(id%RHSCOMP)) THEN 1059 NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 1060 DEALLOCATE(id%RHSCOMP) 1061 ENDIF 1062 LENRHSCOMP = LD_RHSCOMP*id%NRHS 1063 ALLOCATE (id%RHSCOMP(LENRHSCOMP)) 1064 NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 1065 IF (associated(id%POSINRHSCOMP)) THEN 1066 NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 1067 DEALLOCATE(id%POSINRHSCOMP) 1068 ENDIF 1069 ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) 1070 NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 1071 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1072 ELSE 1073 LENRHSCOMP = LD_RHSCOMP*NBRHS 1074 IF (associated(id%RHSCOMP)) THEN 1075 NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 1076 DEALLOCATE(id%RHSCOMP) 1077 NULLIFY(id%RHSCOMP) 1078 ENDIF 1079 ALLOCATE (id%RHSCOMP(LENRHSCOMP)) 1080 NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 1081 IF (associated(id%POSINRHSCOMP)) THEN 1082 NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 1083 DEALLOCATE(id%POSINRHSCOMP) 1084 ENDIF 1085 ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) 1086 NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 1087 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1088 ENDIF 1089 LIWK_SOLVE = 4 * KEEP(28) + 1 1090 IF (KEEP(201).EQ.1) THEN 1091 LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 1092 ELSE 1093 LIWK_SOLVE = LIWK_SOLVE + 1 1094 ENDIF 1095 ALLOCATE ( IWK_SOLVE( LIWK_SOLVE), stat = allocok ) 1096 IF (allocok .GT. 0 ) THEN 1097 INFO(1)=-13 1098 INFO(2)=LIWK_SOLVE 1099 GOTO 111 1100 END IF 1101 NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 1102 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1103 LIWCB = 20*NB_K133*2 + KEEP(133) 1104 ALLOCATE ( IWCB( LIWCB), stat = allocok ) 1105 IF (allocok .GT. 0 ) THEN 1106 INFO(1)=-13 1107 INFO(2)=LIWCB 1108 GOTO 111 1109 END IF 1110 NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 1111 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1112 LIW = KEEP(32) 1113 ALLOCATE(SRW3(KEEP(133)), stat = allocok ) 1114 IF ( allocok .GT. 0 ) THEN 1115 INFO(1)=-13 1116 INFO(2)=KEEP(133) 1117 GOTO 111 1118 END IF 1119 NB_BYTES = NB_BYTES + int(size(SRW3),8)*K35_8 1120 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1121 IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) ) THEN 1122 ALLOCATE(POSINRHSCOMP_N(id%N), stat=allocok) 1123 IF ( allocok .GT. 0 ) THEN 1124 IF (LP.GT.0) WRITE(LP,*) 1125 & ' ERROR in ZMUMPS_301: allocating POSINRHSCOMP_N' 1126 INFO(1) = -13 1127 INFO(2) = id%N 1128 GOTO 111 1129 END IF 1130 NB_BYTES = NB_BYTES + int(size(POSINRHSCOMP_N),8)*K34_8 1131 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1132 END IF 1133 ELSE 1134 LIW=0 1135 END IF 1136 IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) 1137 IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. 1138 & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) 1139 & ) 1140 & .OR. ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) 1141 & ) THEN 1142 ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) 1143 if (allocok .GT.0 ) THEN 1144 INFO(1)=-13 1145 INFO(2)=id%N 1146 GOTO 111 1147 endif 1148 NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 1149 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1150 IF (id%MYID.EQ.MASTER) THEN 1151 DO I = 1, id%N 1152 UNS_PERM_INV(id%UNS_PERM(I))=I 1153 ENDDO 1154 ENDIF 1155 ELSE 1156 ALLOCATE(UNS_PERM_INV(1), stat=allocok) 1157 if (allocok .GT.0 ) THEN 1158 INFO(1)=-13 1159 INFO(2)=1 1160 GOTO 111 1161 endif 1162 NB_BYTES = NB_BYTES + 1_8*K34_8 1163 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1164 ENDIF 1165 111 CONTINUE 1166#if defined(V_T) 1167 CALL VTEND(glob_comm_ini,IERR) 1168#endif 1169 CALL MUMPS_276( ICNTL(1), INFO(1), 1170 & id%COMM,id%MYID) 1171 IF (INFO(1) .LT.0 ) GOTO 90 1172 IF ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) THEN 1173 CALL MPI_BCAST(UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, 1174 & id%COMM,IERR) 1175 ENDIF 1176 IF ( ICNTL21==1 ) THEN 1177 IF (LSCAL) THEN 1178 IF (id%MYID.NE.MASTER) THEN 1179 IF (MTYPE == 1) THEN 1180 ALLOCATE(id%COLSCA(id%N),stat=allocok) 1181 ELSE 1182 ALLOCATE(id%ROWSCA(id%N),stat=allocok) 1183 ENDIF 1184 IF (allocok > 0) THEN 1185 IF (LP > 0) THEN 1186 WRITE(LP,*) 'Error allocating temporary scaling array' 1187 ENDIF 1188 INFO(1)=-13 1189 INFO(2)=id%N 1190 GOTO 40 1191 ENDIF 1192 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 1193 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1194 ENDIF 1195 IF (MTYPE == 1) THEN 1196 CALL MPI_BCAST(id%COLSCA(1),id%N, 1197 & MPI_DOUBLE_PRECISION,MASTER, 1198 & id%COMM,IERR) 1199 scaling_data%SCALING=>id%COLSCA 1200 ELSE 1201 CALL MPI_BCAST(id%ROWSCA(1),id%N, 1202 & MPI_DOUBLE_PRECISION,MASTER, 1203 & id%COMM,IERR) 1204 scaling_data%SCALING=>id%ROWSCA 1205 ENDIF 1206 IF (I_AM_SLAVE) THEN 1207 ALLOCATE(scaling_data%SCALING_LOC(id%KEEP(89)), 1208 & stat=allocok) 1209 IF (allocok > 0) THEN 1210 IF (LP > 0) THEN 1211 WRITE(LP,*) 'Error allocating local scaling array' 1212 ENDIF 1213 INFO(1)=-13 1214 INFO(2)=id%KEEP(89) 1215 GOTO 40 1216 ENDIF 1217 NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 1218 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1219 ENDIF 1220 ENDIF 1221 IF ( I_AM_SLAVE ) THEN 1222 LIW_PASSED=max(1,LIW) 1223 IF (KEEP(89) .GT. 0) THEN 1224 CALL ZMUMPS_535( MTYPE, id%ISOL_loc(1), 1225 & id%PTLUST_S(1), 1226 & id%KEEP(1),id%KEEP8(1), 1227 & id%IS(1), LIW_PASSED,id%MYID_NODES, 1228 & id%N, id%STEP(1), id%PROCNODE_STEPS(1), 1229 & id%NSLAVES, scaling_data, LSCAL ) 1230 ENDIF 1231 IF (id%MYID.NE.MASTER .AND. LSCAL) THEN 1232 IF (MTYPE == 1) THEN 1233 DEALLOCATE(id%COLSCA) 1234 NULLIFY(id%COLSCA) 1235 ELSE 1236 DEALLOCATE(id%ROWSCA) 1237 NULLIFY(id%ROWSCA) 1238 ENDIF 1239 NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 1240 ENDIF 1241 ENDIF 1242 IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN 1243 IF (id%MYID.NE.MASTER) THEN 1244 ALLOCATE(id%UNS_PERM(id%N),stat=allocok) 1245 IF (allocok > 0) THEN 1246 INFO(1)=-13 1247 INFO(2)=id%N 1248 GOTO 40 1249 ENDIF 1250 ENDIF 1251 ENDIF 1252 40 CONTINUE 1253 CALL MUMPS_276( ICNTL(1), INFO(1), 1254 & id%COMM,id%MYID) 1255 IF (INFO(1) .LT.0 ) GOTO 90 1256 IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN 1257 CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, 1258 & id%COMM,IERR) 1259 IF (I_AM_SLAVE) THEN 1260 DO I=1, KEEP(89) 1261 id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) 1262 ENDDO 1263 ENDIF 1264 IF (id%MYID.NE.MASTER) THEN 1265 DEALLOCATE(id%UNS_PERM) 1266 NULLIFY(id%UNS_PERM) 1267 ENDIF 1268 ENDIF 1269 ENDIF 1270 IF ( ( KEEP(221) .EQ. 1 ) .OR. 1271 & ( KEEP(221) .EQ. 2 ) 1272 & ) THEN 1273 IF (KEEP(46).EQ.1) THEN 1274 MASTER_ROOT_IN_COMM=MASTER_ROOT 1275 ELSE 1276 MASTER_ROOT_IN_COMM =MASTER_ROOT+1 1277 ENDIF 1278 IF ( id%MYID .EQ. MASTER ) THEN 1279 IF (id%NRHS.EQ.1) THEN 1280 LD_REDRHS = id%KEEP(116) 1281 ELSE 1282 LD_REDRHS = id%LREDRHS 1283 ENDIF 1284 ENDIF 1285 IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN 1286 IF ( id%MYID .EQ. MASTER ) THEN 1287 CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, 1288 & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) 1289 ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN 1290 CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, 1291 & MASTER, 0, id%COMM,STATUS,IERR) 1292 ENDIF 1293 ENDIF 1294 ENDIF 1295 IF ( KEEP(248)==1 ) THEN 1296 JEND_RHS = 0 1297 IF (DO_PERMUTE_RHS) THEN 1298 ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) 1299 IF (allocok > 0) THEN 1300 INFO(1) = -13 1301 INFO(2) = id%NRHS 1302 GOTO 109 1303 ENDIF 1304 NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 1305 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1306 IF (id%MYID.EQ.MASTER) THEN 1307 STRAT_PERMAM1 = KEEP(242) 1308 CALL MUMPS_780 1309 & (STRAT_PERMAM1, id%SYM_PERM(1), 1310 & id%IRHS_PTR(1), id%NRHS+1, 1311 & PERM_RHS, id%NRHS, 1312 & IERR 1313 & ) 1314 ENDIF 1315 ENDIF 1316 ENDIF 1317109 CALL MUMPS_276( ICNTL(1), INFO(1), 1318 & id%COMM,id%MYID) 1319 IF (INFO(1) .LT.0 ) GOTO 90 1320 IF (id%NSLAVES .EQ. 1) THEN 1321 IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN 1322 WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', 1323 & ' PERMUTE RHS during null space computation ', 1324 & ' not available yet ' 1325 CALL MUMPS_ABORT() 1326 ENDIF 1327 ELSE 1328 IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN 1329 WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', 1330 & ' PERMUTE RHS during null space computation ', 1331 & ' not available yet ' 1332 CALL MUMPS_ABORT() 1333 ENDIF 1334 IF (INTERLEAVE_PAR) THEN 1335 IF ( KEEP(111).NE.0 ) THEN 1336 WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', 1337 & ' INTERLEAVE RHS during null space computation ', 1338 & ' not available yet ' 1339 CALL MUMPS_ABORT() 1340 ELSE 1341 IF (id%MYID.EQ.MASTER) THEN 1342 CALL MUMPS_772 1343 & (PERM_RHS, id%NRHS, id%N, id%KEEP(28), 1344 & id%PROCNODE_STEPS(1), id%STEP(1), id%NSLAVES, 1345 & id%Step2node(1), 1346 & IERR) 1347 ENDIF 1348 ENDIF 1349 ENDIF 1350 ENDIF 1351 IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN 1352 CALL MPI_BCAST(PERM_RHS(1), 1353 & id%NRHS, 1354 & MPI_INTEGER, 1355 & MASTER, id%COMM,IERR) 1356 ENDIF 1357 BEG_RHS=1 1358 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) 1359 NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) 1360 IF (IRHS_SPARSE_COPY_ALLOCATED) THEN 1361 NB_BYTES = NB_BYTES - 1362 & int(size(IRHS_SPARSE_COPY),8)*K34_8 1363 DEALLOCATE(IRHS_SPARSE_COPY) 1364 IRHS_SPARSE_COPY_ALLOCATED=.FALSE. 1365 NULLIFY(IRHS_SPARSE_COPY) 1366 ENDIF 1367 IF (IRHS_PTR_COPY_ALLOCATED) THEN 1368 NB_BYTES = NB_BYTES - 1369 & int(size(IRHS_PTR_COPY),8)*K34_8 1370 DEALLOCATE(IRHS_PTR_COPY) 1371 IRHS_PTR_COPY_ALLOCATED=.FALSE. 1372 NULLIFY(IRHS_PTR_COPY) 1373 ENDIF 1374 IF (RHS_SPARSE_COPY_ALLOCATED) THEN 1375 NB_BYTES = NB_BYTES - 1376 & int(size(RHS_SPARSE_COPY),8)*K35_8 1377 DEALLOCATE(RHS_SPARSE_COPY) 1378 RHS_SPARSE_COPY_ALLOCATED=.FALSE. 1379 NULLIFY(RHS_SPARSE_COPY) 1380 ENDIF 1381 IF ( 1382 & ( id%MYID .NE. MASTER ) 1383 & .or. 1384 & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. 1385 & ICNTL21 .NE.0 .AND. 1386 & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 1387 & .OR. KEEP(111).NE.0 ) 1388 & ) 1389 & .or. 1390 & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) 1391 & ) THEN 1392 LD_RHS = id%N 1393 IBEG = 1 1394 ELSE 1395 IF ( associated(id%RHS) ) THEN 1396 LD_RHS = max(id%LRHS, id%N) 1397 ELSE 1398 LD_RHS = id%N 1399 ENDIF 1400 IBEG = (BEG_RHS-1) * LD_RHS + 1 1401 ENDIF 1402 JBEG_RHS = BEG_RHS 1403 IF ( (id%MYID.EQ.MASTER) .AND. 1404 & KEEP(248)==1 ) THEN 1405 JBEG_RHS = JEND_RHS + 1 1406 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 1407 DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. 1408 & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) 1409 IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. 1410 & (KEEP(221).NE.1) ) THEN 1411 DO I=1, id%N 1412 RHS_MUMPS((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) 1413 & = ZERO 1414 ENDDO 1415 ENDIF 1416 JBEG_RHS = JBEG_RHS +1 1417 CYCLE 1418 ENDDO 1419 ELSE 1420 DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. 1421 & id%IRHS_PTR(JBEG_RHS+1) ) 1422 IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. 1423 & (KEEP(221).NE.1)) THEN 1424 DO I=1, id%N 1425 RHS_MUMPS((JBEG_RHS -1)*LD_RHS + I) = ZERO 1426 ENDDO 1427 ENDIF 1428 IF (KEEP(221).EQ.1) THEN 1429 DO I = 1, id%SIZE_SCHUR 1430 id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO 1431 ENDDO 1432 ENDIF 1433 JBEG_RHS = JBEG_RHS +1 1434 ENDDO 1435 ENDIF 1436 NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) 1437 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) 1438 & .AND. (ICNTL21.EQ.0)) 1439 & THEN 1440 IBEG = (JBEG_RHS-1) * LD_RHS + 1 1441 ENDIF 1442 ENDIF 1443 CALL MPI_BCAST( JBEG_RHS,1, MPI_INTEGER, 1444 & MASTER, id%COMM,IERR) 1445 IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN 1446 IBEG_REDRHS= (JBEG_RHS-1)*LD_REDRHS + 1 1447 ELSE 1448 IBEG_REDRHS=-142424 1449 ENDIF 1450 IF ( I_AM_SLAVE ) THEN 1451 IF ( KEEP(221).EQ.0 ) THEN 1452 IBEG_RHSCOMP= 1 1453 ELSE 1454 IBEG_RHSCOMP= (JBEG_RHS-1)*LD_RHSCOMP + 1 1455 ENDIF 1456 ELSE 1457 IBEG_RHSCOMP=-152525 1458 ENDIF 1459#if defined(V_T) 1460 CALL VTBEGIN(perm_scal_ini,IERR) 1461#endif 1462 IF (id%MYID .eq. MASTER) THEN 1463 IF (KEEP(248)==1) THEN 1464 NBCOL = 0 1465 NBCOL_INBLOC = 0 1466 NZ_THIS_BLOCK = 0 1467 STOP_AT_NEXT_EMPTY_COL = .FALSE. 1468 DO I=JBEG_RHS, id%NRHS 1469 NBCOL_INBLOC = NBCOL_INBLOC +1 1470 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 1471 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) 1472 & - id%IRHS_PTR(PERM_RHS(I)) 1473 ELSE 1474 COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) 1475 ENDIF 1476 IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. 1477 & (KEEP(237).EQ.0)) 1478 & STOP_AT_NEXT_EMPTY_COL =.TRUE. 1479 IF (COLSIZE.GT.0) THEN 1480 NBCOL = NBCOL+1 1481 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE 1482 ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN 1483 NBCOL_INBLOC = NBCOL_INBLOC -1 1484 NBRHS_EFF = NBCOL 1485 EXIT 1486 ENDIF 1487 IF (NBCOL.EQ.NBRHS_EFF) EXIT 1488 ENDDO 1489 IF (NBCOL.NE.NBRHS_EFF) THEN 1490 WRITE(6,*) 'INTERNAL ERROR 1 in ZMUMPS_301 ', 1491 & NBCOL, NBRHS_EFF 1492 call MUMPS_ABORT() 1493 ENDIF 1494 ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) 1495 if (allocok .GT.0 ) then 1496 INFO(1)=-13 1497 INFO(2)=NBCOL_INBLOC+1 1498 GOTO 30 1499 endif 1500 IRHS_PTR_COPY_ALLOCATED = .TRUE. 1501 NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 1502 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1503 JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 1504 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 1505 IPOS = 1 1506 J = 0 1507 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 1508 J = J+1 1509 IRHS_PTR_COPY(J) = IPOS 1510 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) 1511 & - id%IRHS_PTR(PERM_RHS(I)) 1512 IPOS = IPOS + COLSIZE 1513 ENDDO 1514 ELSE 1515 IPOS = 1 1516 J = 0 1517 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 1518 J = J+1 1519 IRHS_PTR_COPY(J) = IPOS 1520 COLSIZE = id%IRHS_PTR(I+1) 1521 & - id%IRHS_PTR(I) 1522 IPOS = IPOS + COLSIZE 1523 ENDDO 1524 ENDIF 1525 IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS 1526 IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN 1527 WRITE(*,*) "Error in compressed copy of IRHS_PTR" 1528 IERR = 99 1529 call MUMPS_ABORT() 1530 ENDIF 1531 IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN 1532 ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) 1533 if (allocok .GT.0 ) then 1534 INFO(1)=-13 1535 INFO(2)=NZ_THIS_BLOCK 1536 GOTO 30 1537 endif 1538 IRHS_SPARSE_COPY_ALLOCATED=.TRUE. 1539 NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 1540 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1541 ELSE 1542 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. 1543 & (KEEP(237).NE.0)) THEN 1544 ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), stat=allocok) 1545 IF (allocok .GT.0 ) THEN 1546 IERR = 99 1547 GOTO 30 1548 ENDIF 1549 IRHS_SPARSE_COPY_ALLOCATED=.TRUE. 1550 NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 1551 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1552 IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN 1553 IPOS = 1 1554 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 1555 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) 1556 & - id%IRHS_PTR(PERM_RHS(I)) 1557 IRHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = 1558 & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): 1559 & id%IRHS_PTR(PERM_RHS(I)+1) -1) 1560 IPOS = IPOS + COLSIZE 1561 ENDDO 1562 ELSE 1563 IRHS_SPARSE_COPY = id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): 1564 & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) 1565 ENDIF 1566 ELSE 1567 IRHS_SPARSE_COPY 1568 & => 1569 & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): 1570 & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) 1571 ENDIF 1572 ENDIF 1573 IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. 1574 & (KEEP(237).NE.0)) THEN 1575 ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), stat=allocok) 1576 if (allocok .GT.0 ) THEN 1577 INFO(1)=-13 1578 INFO(2)=NZ_THIS_BLOCK 1579 GOTO 30 1580 endif 1581 RHS_SPARSE_COPY_ALLOCATED = .TRUE. 1582 NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 1583 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1584 ELSE 1585 IF ( KEEP(248)==1 ) THEN 1586 RHS_SPARSE_COPY 1587 & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): 1588 & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) 1589 ELSE 1590 RHS_SPARSE_COPY 1591 & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): 1592 & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) 1593 ENDIF 1594 ENDIF 1595 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. 1596 & (id%KEEP(237).NE.0)) THEN 1597 IF (id%KEEP(237).NE.0) THEN 1598 RHS_SPARSE_COPY = ONE 1599 ELSE IF (.NOT. LSCAL) THEN 1600 IPOS = 1 1601 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 1602 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) 1603 & - id%IRHS_PTR(PERM_RHS(I)) 1604 IF (COLSIZE .EQ. 0) CYCLE 1605 RHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = 1606 & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): 1607 & id%IRHS_PTR(PERM_RHS(I)+1) -1) 1608 IPOS = IPOS + COLSIZE 1609 ENDDO 1610 ENDIF 1611 ENDIF 1612 ENDIF 1613 IF (KEEP(23) .NE. 0) THEN 1614 IF (MTYPE .NE. 1) THEN 1615 IF (KEEP(248)==0) THEN 1616 ALLOCATE( C_RW2( id%N ),stat =allocok ) 1617 IF ( allocok .GT. 0 ) THEN 1618 INFO(1)=-13 1619 INFO(2)=id%N 1620 IF ( LP .GT. 0 ) THEN 1621 WRITE(LP,*) id%MYID, 1622 & ':Error allocating C_RW2 in ZMUMPS_SOLVE_DRIVE' 1623 END IF 1624 GOTO 30 1625 END IF 1626 DO K = 1, NBRHS_EFF 1627 KDEC = IBEG+(K-1)*LD_RHS 1628 DO I = 1, id%N 1629 C_RW2(I)=RHS_MUMPS(I-1+KDEC) 1630 END DO 1631 DO I = 1, id%N 1632 JPERM = id%UNS_PERM(I) 1633 RHS_MUMPS(I-1+KDEC) = C_RW2(JPERM) 1634 END DO 1635 END DO 1636 DEALLOCATE(C_RW2) 1637 ELSE 1638 IPOS = 1 1639 DO I=1, NBCOL_INBLOC 1640 COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) 1641 DO K = 1, COLSIZE 1642 JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) 1643 IRHS_SPARSE_COPY(IPOS+K-1) = JPERM 1644 ENDDO 1645 IPOS = IPOS + COLSIZE 1646 ENDDO 1647 ENDIF 1648 ENDIF 1649 ENDIF 1650 IF (ERANAL) THEN 1651 IF ( KEEP(248) == 0 ) THEN 1652 DO K = 1, NBRHS_EFF 1653 KDEC = IBEG+(K-1)*LD_RHS 1654 DO I = 1, id%N 1655 SAVERHS(I+(K-1)*id%N) = RHS_MUMPS(KDEC+I-1) 1656 END DO 1657 ENDDO 1658 ENDIF 1659 ENDIF 1660 IF (LSCAL) THEN 1661 IF (KEEP(248)==0) THEN 1662 IF (MTYPE .EQ. 1) THEN 1663 DO K =1, NBRHS_EFF 1664 KDEC = (K-1) * LD_RHS + IBEG - 1 1665 DO I = 1, id%N 1666 RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * 1667 & id%ROWSCA(I) 1668 END DO 1669 ENDDO 1670 ELSE 1671 DO K =1, NBRHS_EFF 1672 KDEC = (K-1) * LD_RHS + IBEG - 1 1673 DO I = 1, id%N 1674 RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * 1675 & id%COLSCA(I) 1676 END DO 1677 ENDDO 1678 ENDIF 1679 ELSE 1680 KDEC=id%IRHS_PTR(JBEG_RHS) 1681 IF ((KEEP(248)==1) .AND. 1682 & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. 1683 & (id%KEEP(237).NE.0)) 1684 & ) THEN 1685 IPOS = 1 1686 J = 0 1687 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 1688 J = J+1 1689 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) 1690 IF (COLSIZE .EQ. 0) CYCLE 1691 IF (id%KEEP(237).NE.0) THEN 1692 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 1693 RHS_SPARSE_COPY(IPOS) = id%ROWSCA(PERM_RHS(I)) * 1694 & ONE 1695 ELSE 1696 RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE 1697 ENDIF 1698 ELSE 1699 DO K = 1, COLSIZE 1700 II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) 1701 IF (MTYPE.EQ.1) THEN 1702 RHS_SPARSE_COPY(IPOS+K-1) = 1703 & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1)* 1704 & id%ROWSCA(II) 1705 ELSE 1706 RHS_SPARSE_COPY(IPOS+K-1) = 1707 & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1)* 1708 & id%COLSCA(II) 1709 ENDIF 1710 ENDDO 1711 ENDIF 1712 IPOS = IPOS + COLSIZE 1713 ENDDO 1714 ELSE 1715 IF (MTYPE .eq. 1) THEN 1716 DO IZ=1,NZ_THIS_BLOCK 1717 I=IRHS_SPARSE_COPY(IZ) 1718 RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* 1719 & id%ROWSCA(I) 1720 ENDDO 1721 ELSE 1722 DO IZ=1,NZ_THIS_BLOCK 1723 I=IRHS_SPARSE_COPY(IZ) 1724 RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* 1725 & id%COLSCA(I) 1726 ENDDO 1727 ENDIF 1728 ENDIF 1729 ENDIF 1730 END IF 1731 ENDIF 1732#if defined(V_T) 1733 CALL VTEND(perm_scal_ini,IERR) 1734#endif 1735 30 CONTINUE 1736 CALL MUMPS_276( ICNTL(1), INFO(1), 1737 & id%COMM,id%MYID) 1738 IF (INFO(1) .LT.0 ) GOTO 90 1739 IF ( I_AM_SLAVE ) THEN 1740 IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) .OR. 1741 & (KEEP(252).NE.0) ) THEN 1742 IF (BUILD_POSINRHSCOMP) THEN 1743 IF (KEEP(111).NE.0) THEN 1744 WHAT = 2 1745 MTYPE_LOC = 1 1746 ELSE IF (KEEP(252).NE.0) THEN 1747 WHAT = 0 1748 MTYPE_LOC = 1 1749 ELSE 1750 WHAT = 1 1751 MTYPE_LOC = MTYPE 1752 ENDIF 1753 LIW_PASSED=max(1,LIW) 1754 IF (WHAT.EQ.0) THEN 1755 CALL ZMUMPS_639(id%NSLAVES,id%N, 1756 & id%MYID_NODES, id%PTLUST_S(1), 1757 & id%KEEP(1),id%KEEP8(1), 1758 & id%PROCNODE_STEPS(1), id%IS(1), LIW_PASSED, 1759 & id%STEP(1), 1760 & id%POSINRHSCOMP(1), IDUMMY, 1, MTYPE_LOC, 1761 & WHAT ) 1762 ELSE 1763 CALL ZMUMPS_639(id%NSLAVES,id%N, 1764 & id%MYID_NODES, id%PTLUST_S(1), 1765 & id%KEEP(1),id%KEEP8(1), 1766 & id%PROCNODE_STEPS(1), id%IS(1), LIW_PASSED, 1767 & id%STEP(1), 1768 & id%POSINRHSCOMP(1), POSINRHSCOMP_N(1), 1769 & id%N, MTYPE_LOC, 1770 & WHAT ) 1771 ENDIF 1772 BUILD_POSINRHSCOMP = .FALSE. 1773 ENDIF 1774 ENDIF 1775 ENDIF 1776 IF (KEEP(248)==1) THEN 1777 CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, 1778 & MASTER, id%COMM,IERR) 1779 ELSE 1780 NBCOL_INBLOC = NBRHS_EFF 1781 ENDIF 1782 JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 1783 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN 1784 CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, 1785 & MASTER, id%COMM,IERR) 1786 CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, 1787 & id%COMM,IERR) 1788 ENDIF 1789#if defined(V_T) 1790 CALL VTBEGIN(soln_dist,IERR) 1791#endif 1792 IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0)) THEN 1793 IF (KEEP(248) == 0) THEN 1794 IF ( .NOT.I_AM_SLAVE ) THEN 1795 CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, 1796 & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 1797 & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), 1798 & IDUMMY, 1, 1799 & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, 1800 & id%ICNTL(1),id%INFO(1)) 1801 BUILD_POSINRHSCOMP=.FALSE. 1802 ELSE 1803 LIW_PASSED = max( LIW, 1 ) 1804 CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, 1805 & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 1806 & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), 1807 & id%PROCNODE_STEPS(1), 1808 & IS(1), LIW_PASSED, 1809 & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), 1810 & BUILD_POSINRHSCOMP, 1811 & id%ICNTL(1),id%INFO(1)) 1812 BUILD_POSINRHSCOMP=.FALSE. 1813 ENDIF 1814 IF (INFO(1).LT.0) GOTO 90 1815 ELSE 1816 CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, 1817 & MASTER, id%COMM,IERR) 1818 IF (id%MYID.NE.MASTER) THEN 1819 ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) 1820 if (allocok .GT.0 ) then 1821 INFO(1)=-13 1822 INFO(2)=NZ_THIS_BLOCK 1823 GOTO 45 1824 endif 1825 IRHS_SPARSE_COPY_ALLOCATED=.TRUE. 1826 ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) 1827 if (allocok .GT.0 ) then 1828 INFO(1)=-13 1829 INFO(2)=NZ_THIS_BLOCK 1830 GOTO 45 1831 endif 1832 RHS_SPARSE_COPY_ALLOCATED=.TRUE. 1833 NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) 1834 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1835 ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) 1836 if (allocok .GT.0 ) then 1837 INFO(1)=-13 1838 INFO(2)=NBCOL_INBLOC+1 1839 GOTO 45 1840 endif 1841 IRHS_PTR_COPY_ALLOCATED = .TRUE. 1842 NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 1843 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1844 ENDIF 1845 45 CONTINUE 1846 CALL MUMPS_276( ICNTL(1), INFO(1), 1847 & id%COMM,id%MYID) 1848 IF (INFO(1) .LT.0 ) GOTO 90 1849 CALL MPI_BCAST(IRHS_SPARSE_COPY(1), 1850 & NZ_THIS_BLOCK, 1851 & MPI_INTEGER, 1852 & MASTER, id%COMM,IERR) 1853 CALL MPI_BCAST(RHS_SPARSE_COPY(1), 1854 & NZ_THIS_BLOCK, 1855 & MPI_DOUBLE_COMPLEX, 1856 & MASTER, id%COMM,IERR) 1857 CALL MPI_BCAST(IRHS_PTR_COPY(1), 1858 & NBCOL_INBLOC+1, 1859 & MPI_INTEGER, 1860 & MASTER, id%COMM,IERR) 1861 IF (IERR.GT.0) THEN 1862 WRITE (*,*)'NOT OK FOR ALLOC PTR ON SLAVES' 1863 call MUMPS_ABORT() 1864 ENDIF 1865 IF ( I_AM_SLAVE ) THEN 1866 IF (KEEP(237).NE.0) THEN 1867 K=1 1868 RHS_MUMPS(1:NBRHS_EFF*LD_RHS) = ZERO 1869 IPOS = 1 1870 DO I = 1, NBCOL_INBLOC 1871 COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) 1872 IF (COLSIZE.GT.0) THEN 1873 J = I - 1 + JBEG_RHS 1874 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 1875 J = PERM_RHS(J) 1876 ENDIF 1877 IF (POSINRHSCOMP_N(J).NE.0) THEN 1878 RHS_MUMPS((K-1) * LD_RHS + J) = 1879 & RHS_SPARSE_COPY(IPOS) 1880 ENDIF 1881 K = K + 1 1882 IPOS = IPOS + COLSIZE 1883 ENDIF 1884 ENDDO 1885 IF (K.NE.NBRHS_EFF+1) THEN 1886 WRITE(6,*) 'INTERNAL ERROR 2 in ZMUMPS_301 ', 1887 & K, NBRHS_EFF 1888 call MUMPS_ABORT() 1889 ENDIF 1890 ELSE 1891 IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0)) THEN 1892 DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 1893 DO I = 1, LD_RHSCOMP 1894 id%RHSCOMP((K-1)*LD_RHSCOMP + I) = ZERO 1895 ENDDO 1896 ENDDO 1897 ENDIF 1898 DO K = 1, NBCOL_INBLOC 1899 KDEC = (K-1) * LD_RHS + IBEG - 1 1900 RHS_MUMPS(KDEC+1:KDEC+id%N) = ZERO 1901 DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 1902 I=IRHS_SPARSE_COPY(IZ) 1903 IF (POSINRHSCOMP_N(I).NE.0) THEN 1904 RHS_MUMPS(KDEC+I)= RHS_SPARSE_COPY(IZ) 1905 ENDIF 1906 ENDDO 1907 ENDDO 1908 END IF 1909 ENDIF 1910 ENDIF 1911 ELSE IF (I_AM_SLAVE) THEN 1912 IF (KEEP(111).NE.0) THEN 1913 IF (KEEP(111).GT.0) THEN 1914 IBEG_GLOB_DEF = KEEP(111) 1915 IEND_GLOB_DEF = KEEP(111) 1916 ELSE 1917 IBEG_GLOB_DEF = BEG_RHS 1918 IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 1919 ENDIF 1920 IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN 1921 IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN 1922 id%KEEP(235) = 0 1923 DO_NULL_PIV = .FALSE. 1924 ENDIF 1925 IF (IBEG_GLOB_DEF .LT.id%KEEP(112) 1926 & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) 1927 & .AND. DO_NULL_PIV ) THEN 1928 IEND_GLOB_DEF = id%KEEP(112) 1929 id%KEEP(235) = 1 1930 DO_NULL_PIV = .FALSE. 1931 ENDIF 1932 ENDIF 1933 IF (id%KEEP(235).NE.0) THEN 1934 NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 1935 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) 1936 if (allocok .GT.0 ) then 1937 INFO(1)=-13 1938 INFO(2)=NZ_THIS_BLOCK 1939 GOTO 50 1940 endif 1941 IRHS_PTR_COPY_ALLOCATED = .TRUE. 1942 ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) 1943 if (allocok .GT.0 ) then 1944 INFO(1)=-13 1945 INFO(2)=NZ_THIS_BLOCK 1946 GOTO 50 1947 endif 1948 IRHS_SPARSE_COPY_ALLOCATED=.TRUE. 1949 NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) 1950 & + K34_8 1951 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 1952 IF (id%MYID.eq.MASTER) THEN 1953 II = 1 1954 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF 1955 IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I 1956 IF (INTERLEAVE_PAR .AND.(id%NSLAVES .GT. 1) )THEN 1957 IRHS_SPARSE_COPY(II) = PERM_PIV_LIST(I) 1958 ELSE 1959 IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) 1960 ENDIF 1961 II = II +1 1962 ENDDO 1963 IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 1964 ENDIF 1965 50 CONTINUE 1966 CALL MUMPS_276( ICNTL(1), INFO(1), 1967 & id%COMM,id%MYID) 1968 IF (INFO(1) .LT.0 ) GOTO 90 1969 CALL MPI_BCAST(IRHS_SPARSE_COPY(1), 1970 & NZ_THIS_BLOCK, 1971 & MPI_INTEGER, 1972 & MASTER, id%COMM,IERR) 1973 CALL MPI_BCAST(IRHS_PTR_COPY(1), 1974 & NZ_THIS_BLOCK+1, 1975 & MPI_INTEGER, 1976 & MASTER, id%COMM,IERR) 1977 RHS_MUMPS( IBEG : 1978 & (IBEG + (NBRHS_EFF)*LD_RHS -1) ) = ZERO 1979 ENDIF 1980 DO K=1, NBRHS_EFF 1981 KDEC = (K-1) *LD_RHSCOMP 1982 id%RHSCOMP(KDEC+1:KDEC+LD_RHSCOMP)=ZERO 1983 END DO 1984 IF ((KEEP(235).NE.0).AND. INTERLEAVE_PAR) THEN 1985 DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF 1986 IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN 1987 JJ= POSINRHSCOMP_N(PERM_PIV_LIST(I)) 1988 IF (JJ.GT.LD_RHSCOMP) THEN 1989 WRITE(6,*) ' Internal ERROR JJ, LD_RHSCOMP=', 1990 & JJ, LD_RHSCOMP 1991 ENDIF 1992 IF (JJ.GT.0) THEN 1993 IF (KEEP(50).EQ.0) THEN 1994 id%RHSCOMP(IBEG_RHSCOMP -1+ 1995 & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = 1996 & cmplx(abs(id%DKEEP(2)),kind=kind(id%RHSCOMP)) 1997 ELSE 1998 id%RHSCOMP(IBEG_RHSCOMP -1+ 1999 & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = ONE 2000 ENDIF 2001 ENDIF 2002 ENDIF 2003 ENDDO 2004 ELSE 2005 DO I=max(IBEG_GLOB_DEF,KEEP(220)), 2006 & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) 2007 JJ= POSINRHSCOMP_N(id%PIVNUL_LIST(I-KEEP(220)+1)) 2008 IF (JJ.GT.0) THEN 2009 IF (KEEP(50).EQ.0) THEN 2010 id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP 2011 & + JJ) = cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) 2012 ELSE 2013 id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP 2014 & + JJ) = ONE 2015 ENDIF 2016 ENDIF 2017 ENDDO 2018 ENDIF 2019 IF ( KEEP(17).NE.0 .and. id%MYID_NODES.EQ.MASTER_ROOT) THEN 2020 IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) 2021 IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) 2022 IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 2023 IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) 2024 IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) 2025 ELSE 2026 IBEG_ROOT_DEF = -90999 2027 IEND_ROOT_DEF = -90999 2028 ENDIF 2029 ELSE 2030 ENDIF 2031 ENDIF 2032 IF ( I_AM_SLAVE ) THEN 2033 LWCB_SOL_C = LWCB 2034 IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN 2035 IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN 2036 PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT 2037 LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT) 2038 ELSE 2039 LPTR_RHS_ROOT = NBRHS_EFF * SIZE_ROOT 2040 IPT_RHS_ROOT = LWCB - LPTR_RHS_ROOT + 1 2041 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) 2042 LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT 2043 ENDIF 2044 ELSE 2045 LPTR_RHS_ROOT = 1 2046 IPT_RHS_ROOT = LWCB 2047 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) 2048 LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT 2049 ENDIF 2050 ENDIF 2051 IF (KEEP(221) .EQ. 2 ) THEN 2052 IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. 2053 & ( id%MYID .EQ. MASTER ) ) THEN 2054 II = 0 2055 DO K=1, NBRHS_EFF 2056 KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 2057 DO I = 1, SIZE_ROOT 2058 PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) 2059 ENDDO 2060 II = II+SIZE_ROOT 2061 ENDDO 2062 ELSE 2063 IF ( id%MYID .EQ. MASTER) THEN 2064 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 2065 KDEC = IBEG_REDRHS 2066 CALL MPI_SEND(id%REDRHS(KDEC), 2067 & SIZE_ROOT*NBRHS_EFF, 2068 & MPI_DOUBLE_COMPLEX, 2069 & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) 2070 ELSE 2071 DO K=1, NBRHS_EFF 2072 KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 2073 CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, 2074 & MPI_DOUBLE_COMPLEX, 2075 & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) 2076 ENDDO 2077 ENDIF 2078 ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN 2079 II = 1 2080 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 2081 CALL MPI_RECV(PTR_RHS_ROOT(II), 2082 & SIZE_ROOT*NBRHS_EFF, 2083 & MPI_DOUBLE_COMPLEX, 2084 & MASTER, 0, id%COMM,STATUS,IERR) 2085 ELSE 2086 DO K=1, NBRHS_EFF 2087 CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, 2088 & MPI_DOUBLE_COMPLEX, 2089 & MASTER, 0, id%COMM,STATUS,IERR) 2090 II = II + SIZE_ROOT 2091 ENDDO 2092 ENDIF 2093 ENDIF 2094 ENDIF 2095 ENDIF 2096 IF ( I_AM_SLAVE ) THEN 2097 LIW_PASSED = max( LIW, 1 ) 2098 LA_PASSED = max( LA, 1_8 ) 2099 IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN 2100 PRUNED_SIZE_LOADED = 0_8 2101 CALL ZMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, 2102 & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, 2103 & IWCB, LIWCB, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 2104 & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, 2105 & ICNTL(1), id%STEP(1), id%FRERE_STEPS(1), 2106 & id%DAD_STEPS(1), id%FILS(1), id%PTLUST_S(1), id%PTRFAC(1), 2107 & IWK_SOLVE, LIWK_SOLVE, id%PROCNODE_STEPS(1), 2108 & id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), 2109 & id%COMM_NODES, id%MYID, id%MYID_NODES, 2110 & id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2111 & id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), 2112 & IBEG_ROOT_DEF, IEND_ROOT_DEF, 2113 & IROOT_DEF_RHS_COL1, 2114 & PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, 2115 & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 2116 & id%POSINRHSCOMP(1), BUILD_POSINRHSCOMP 2117 & , 1 , 1 , 1 2118 & , 1 2119 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY 2120 & ) 2121 ELSE 2122 IF ((KEEP(235).NE.0).AND.KEEP(221).NE.2.AND. 2123 & KEEP(111).EQ.0) THEN 2124 DO K=1, NBRHS_EFF 2125 DO I=1, LD_RHSCOMP 2126 id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO 2127 ENDDO 2128 ENDDO 2129 ELSEIF (KEEP(237).NE.0) THEN 2130 DO K=1, NBRHS_EFF 2131 DO I=1, LD_RHSCOMP 2132 id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO 2133 ENDDO 2134 ENDDO 2135 ENDIF 2136 IF (.NOT. allocated(PERM_RHS)) THEN 2137 ALLOCATE(PERM_RHS(1),stat=allocok) 2138 NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 2139 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 2140 ENDIF 2141 CALL ZMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, 2142 & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, 2143 & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, id%NA(1),id%LNA, 2144 & id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), id%STEP(1), 2145 & id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), 2146 & id%PTLUST_S(1), id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, 2147 & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1),KEEP8(1), 2148 & id%COMM_NODES, id%MYID, id%MYID_NODES, 2149 & id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2150 & id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), 2151 & IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1, 2152 & PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, 2153 & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 2154 & id%POSINRHSCOMP(1), BUILD_POSINRHSCOMP, 2155 & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, 2156 & JBEG_RHS , id%Step2node(1), id%KEEP(28), IRHS_SPARSE_COPY(1), 2157 & IRHS_PTR_COPY(1), 2158 & size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV 2159 & ) 2160 ENDIF 2161 END IF 2162 CALL MUMPS_276( ICNTL(1), INFO(1), 2163 & id%COMM,id%MYID) 2164 IF (INFO(1).eq.-2) then 2165 INFO(1)=-11 2166 IF (LP.GT.0) 2167 & write(LP,*) 2168 & ' WARNING : -11 error code obtained in solve' 2169 END IF 2170 IF (INFO(1).eq.-3) then 2171 INFO(1)=-14 2172 IF (LP.GT.0) 2173 & write(LP,*) 2174 & ' WARNING : -14 error code obtained in solve' 2175 END IF 2176 IF (INFO(1).LT.0) GO TO 90 2177 IF ( KEEP(221) .EQ. 1 ) THEN 2178 IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. 2179 & ( id%MYID .EQ. MASTER ) ) THEN 2180 II = 0 2181 DO K=1, NBRHS_EFF 2182 KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 2183 DO I = 1, SIZE_ROOT 2184 id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) 2185 ENDDO 2186 II = II+SIZE_ROOT 2187 ENDDO 2188 ELSE 2189 IF ( id%MYID .EQ. MASTER ) THEN 2190 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 2191 KDEC = IBEG_REDRHS 2192 CALL MPI_RECV(id%REDRHS(KDEC), 2193 & SIZE_ROOT*NBRHS_EFF, 2194 & MPI_DOUBLE_COMPLEX, 2195 & MASTER_ROOT_IN_COMM, 0, id%COMM, 2196 & STATUS,IERR) 2197 ELSE 2198 DO K=1, NBRHS_EFF 2199 KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 2200 CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, 2201 & MPI_DOUBLE_COMPLEX, 2202 & MASTER_ROOT_IN_COMM, 0, id%COMM, 2203 & STATUS,IERR) 2204 ENDDO 2205 ENDIF 2206 ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN 2207 II = 1 2208 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 2209 CALL MPI_SEND(PTR_RHS_ROOT(II), 2210 & SIZE_ROOT*NBRHS_EFF, 2211 & MPI_DOUBLE_COMPLEX, 2212 & MASTER, 0, id%COMM,IERR) 2213 ELSE 2214 DO K=1, NBRHS_EFF 2215 CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, 2216 & MPI_DOUBLE_COMPLEX, 2217 & MASTER, 0, id%COMM,IERR) 2218 II = II + SIZE_ROOT 2219 ENDDO 2220 ENDIF 2221 ENDIF 2222 ENDIF 2223 ENDIF 2224 IF ( KEEP(221) .NE. 1 ) THEN 2225 IF (ICNTL21 == 0) THEN 2226 IF ((.NOT. I_AM_SLAVE).AND.KEEP(237).EQ.0) THEN 2227 ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) 2228 IF (allocok > 0) THEN 2229 ALLOCATE( CWORK(KEEP(247)), stat=allocok) 2230 IF (allocok > 0) THEN 2231 INFO(1)=-13 2232 INFO(2)=KEEP(247) 2233 ENDIF 2234 ENDIF 2235 ENDIF 2236 CALL MUMPS_276( ICNTL(1), INFO(1), 2237 & id%COMM,id%MYID) 2238 IF (INFO(1).LT.0) GO TO 90 2239 IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN 2240 PT_SCALING => Dummy_SCAL 2241 ELSE 2242 IF (MTYPE.EQ.1) THEN 2243 PT_SCALING => id%COLSCA 2244 ELSE 2245 PT_SCALING => id%ROWSCA 2246 ENDIF 2247 ENDIF 2248 LIW_PASSED = max( LIW, 1 ) 2249 IF ( .NOT.I_AM_SLAVE ) THEN 2250 IF (KEEP(237).EQ.0) THEN 2251 CALL ZMUMPS_521(id%NSLAVES,id%N, 2252 & id%MYID, id%COMM, 2253 & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 2254 & JDUMMY, id%KEEP(1), id%KEEP8(1), 2255 & id%PROCNODE_STEPS(1), IDUMMY, 1, 2256 & id%STEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2257 & CWORK(1), size(CWORK), 2258 & LSCAL, PT_SCALING(1), size(PT_SCALING) 2259 & ) 2260 DEALLOCATE( CWORK ) 2261 ELSE 2262 CALL ZMUMPS_812(id%NSLAVES,id%N, 2263 & id%MYID, id%COMM, 2264 & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 2265 & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2266 & LSCAL, PT_SCALING(1), size(PT_SCALING) 2267 & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), 2268 & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), 2269 & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), 2270 & UNS_PERM_INV, size(UNS_PERM_INV), IDUMMY, 1 2271 & ) 2272 ENDIF 2273 ELSE 2274 IF (KEEP(237).EQ.0) THEN 2275 CALL ZMUMPS_521(id%NSLAVES,id%N, 2276 & id%MYID, id%COMM, 2277 & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 2278 & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), 2279 & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, 2280 & id%STEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2281 & id%RHSCOMP(1), LENRHSCOMP, 2282 & LSCAL, PT_SCALING(1), size(PT_SCALING) 2283 & ) 2284 ELSE 2285 CALL ZMUMPS_812(id%NSLAVES,id%N, 2286 & id%MYID, id%COMM, 2287 & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 2288 & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2289 & LSCAL, PT_SCALING(1), size(PT_SCALING) 2290 & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), 2291 & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), 2292 & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), 2293 & UNS_PERM_INV, size(UNS_PERM_INV), POSINRHSCOMP_N, 2294 & id%N 2295 & ) 2296 ENDIF 2297 ENDIF 2298 IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) 2299 & ) THEN 2300 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 2301 DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 2302 COLSIZE = id%IRHS_PTR(PERM_RHS(J)+1) - 2303 & id%IRHS_PTR(PERM_RHS(J)) 2304 IF (COLSIZE.EQ.0) CYCLE 2305 JJ = J-JBEG_RHS+1 2306 DO IZ= id%IRHS_PTR(PERM_RHS(J)), 2307 & id%IRHS_PTR(PERM_RHS(J)+1)-1 2308 I = id%IRHS_SPARSE (IZ) 2309 DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 2310 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT 2311 IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN 2312 WRITE(6,*) " INTERNAL ERROR 1 gather sol_driver" 2313 CALL MUMPS_ABORT() 2314 ENDIF 2315 ENDDO 2316 id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) 2317 ENDDO 2318 ENDDO 2319 ELSE 2320 DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 2321 COLSIZE = id%IRHS_PTR(J+1) - id%IRHS_PTR(J) 2322 IF (COLSIZE.EQ.0) CYCLE 2323 JJ = J-JBEG_RHS+1 2324 DO IZ= id%IRHS_PTR(J), id%IRHS_PTR(J+1) - 1 2325 I = id%IRHS_SPARSE (IZ) 2326 DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 2327 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT 2328 IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN 2329 WRITE(6,*) " INTERNAL ERROR 2 gather sol_driver" 2330 CALL MUMPS_ABORT() 2331 ENDIF 2332 ENDDO 2333 id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) 2334 ENDDO 2335 ENDDO 2336 ENDIF 2337 ENDIF 2338 ELSE 2339 IF ( I_AM_SLAVE ) THEN 2340 LIW_PASSED = max( LIW, 1 ) 2341 IF ( KEEP(89) .GT. 0 ) THEN 2342 CALL ZMUMPS_532(id%NSLAVES, 2343 & id%N, id%MYID_NODES, 2344 & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, 2345 & id%ISOL_loc(1), 2346 & id%SOL_loc(1), JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, 2347 & id%PTLUST_S(1), id%PROCNODE_STEPS(1), 2348 & id%KEEP(1),id%KEEP8(1), 2349 & IS(1), LIW_PASSED, 2350 & id%STEP(1), scaling_data, LSCAL, NB_RHSSKIPPED ) 2351 ENDIF 2352 ENDIF 2353 ENDIF 2354 ENDIF 2355 IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN 2356 DO I = 1, ICNTL10 2357 write(*,*) 'FIXME: to be implemented' 2358 END DO 2359 END IF 2360 IF (ERANAL) THEN 2361 IF ((ICNTL10 .GT. 0) .AND. (ICNTL11 .GT. 0)) THEN 2362 IF (id%MYID .EQ. MASTER) THEN 2363 GIVSOL = .FALSE. 2364 IF (MP .GT. 0) WRITE( MP, 170 ) 2365 ALLOCATE(R_RW1(id%N),stat=allocok) 2366 if (allocok .GT.0 ) THEN 2367 INFO(1)=-13 2368 INFO(2)=id%N 2369 GOTO 776 2370 ENDIF 2371 ALLOCATE(C_RW2(id%N),stat=allocok) 2372 IF (allocok .GT.0) THEN 2373 INFO(1)=-13 2374 INFO(2)=id%N 2375 GOTO 776 2376 ENDIF 2377 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 + int(id%N,8)*K16_8 2378 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 2379 END IF 2380 776 CONTINUE 2381 CALL MUMPS_276( ICNTL(1), INFO(1), 2382 & id%COMM,id%MYID) 2383 IF ( INFO(1) .LT. 0 ) GOTO 90 2384 IF ( KEEP(54) .eq. 0 ) THEN 2385 IF (id%MYID .EQ. MASTER) THEN 2386 IF (KEEP(55).EQ.0) THEN 2387 CALL ZMUMPS_278( ICNTL(9), id%N, id%NZ, id%A(1), 2388 & id%IRN(1), id%JCN(1), 2389 & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, 2390 & KEEP(1),KEEP8(1) ) 2391 ELSE 2392 CALL ZMUMPS_121( ICNTL(9), id%N, 2393 & id%NELT, id%ELTPTR(1), 2394 & id%LELTVAR, id%ELTVAR(1), 2395 & id%NA_ELT, id%A_ELT(1), 2396 & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, 2397 & KEEP(1),KEEP8(1) ) 2398 ENDIF 2399 END IF 2400 ELSE 2401 CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, 2402 & MPI_DOUBLE_COMPLEX, MASTER, 2403 & id%COMM, IERR ) 2404 ALLOCATE( C_LOCWK54( id%N ), stat =allocok ) 2405 if (allocok .GT.0 ) THEN 2406 INFO(1)=-13 2407 INFO(2)=id%N 2408 endif 2409 CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) 2410 IF ( INFO(1) .LT. 0 ) GOTO 90 2411 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 2412 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 2413 IF ( I_AM_SLAVE .and. 2414 & id%NZ_loc .NE. 0 ) THEN 2415 CALL ZMUMPS_192( id%N, id%NZ_loc, 2416 & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), 2417 & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) 2418 ELSE 2419 C_LOCWK54 = ZERO 2420 END IF 2421 IF ( id%MYID .eq. MASTER ) THEN 2422 CALL MPI_REDUCE( C_LOCWK54, C_RW2, 2423 & id%N, MPI_DOUBLE_COMPLEX, 2424 & MPI_SUM,MASTER,id%COMM, IERR) 2425 C_RW2 = SAVERHS - C_RW2 2426 ELSE 2427 CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, 2428 & id%N, MPI_DOUBLE_COMPLEX, 2429 & MPI_SUM,MASTER,id%COMM, IERR) 2430 END IF 2431 NB_BYTES = NB_BYTES - int(size(C_LOCWK54),8)*K35_8 2432 DEALLOCATE( C_LOCWK54 ) 2433 ALLOCATE( R_LOCWK54( id%N ), stat =allocok ) 2434 if (allocok .GT.0 ) THEN 2435 INFO(1)=-13 2436 INFO(2)=id%N 2437 endif 2438 CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) 2439 IF ( INFO(1) .LT. 0 ) GOTO 90 2440 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 2441 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 2442 IF ( I_AM_SLAVE .AND. id%NZ_loc .NE. 0 ) THEN 2443 CALL ZMUMPS_207(id%A_loc(1), 2444 & id%NZ_loc, id%N, 2445 & id%IRN_loc(1), id%JCN_loc(1), 2446 & R_LOCWK54, id%KEEP(1),id%KEEP8(1)) 2447 ELSE 2448 R_LOCWK54 = RZERO 2449 END IF 2450 IF ( id%MYID .eq. MASTER ) THEN 2451 CALL MPI_REDUCE( R_LOCWK54, R_RW1, 2452 & id%N, MPI_DOUBLE_PRECISION, 2453 & MPI_SUM,MASTER,id%COMM, IERR) 2454 ELSE 2455 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2456 & id%N, MPI_DOUBLE_PRECISION, 2457 & MPI_SUM,MASTER,id%COMM, IERR) 2458 END IF 2459 NB_BYTES = NB_BYTES - int(size(R_LOCWK54),8)*K16_8 2460 DEALLOCATE( R_LOCWK54 ) 2461 END IF 2462 IF ( id%MYID .EQ. MASTER ) THEN 2463 CALL ZMUMPS_205(ICNTL(9),INFO(1),id%N,id%NZ, 2464 & RHS_MUMPS(IBEG), SAVERHS,R_RW1,C_RW2,GIVSOL, 2465 & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MP,ICNTL(1), 2466 & KEEP(1),KEEP8(1)) 2467 NB_BYTES = NB_BYTES - int(size(R_RW1),8)*K16_8 2468 & - int(size(C_RW2),8)*K35_8 2469 DEALLOCATE(R_RW1) 2470 DEALLOCATE(C_RW2) 2471 END IF 2472 END IF 2473 IF ( PROK .AND. ICNTL10 .GT. 0 ) WRITE( MP, 270 ) 2474 IF ( PROKG .AND. ICNTL10 .GT. 0 ) WRITE( MPG, 270 ) 2475 ALLOCATE(R_Y(id%N), stat = allocok) 2476 IF ( allocok .GT. 0 ) THEN 2477 INFO(1)=-13 2478 INFO(2)=id%N 2479 GOTO 777 2480 ENDIF 2481 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 2482 ALLOCATE(C_Y(id%N), stat = allocok) 2483 IF ( allocok .GT. 0 ) THEN 2484 INFO(1)=-13 2485 INFO(2)=id%N 2486 GOTO 777 2487 ENDIF 2488 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 2489 IF ( id%MYID .EQ. MASTER ) THEN 2490 ALLOCATE( IW1( 2 * id%N ),stat = allocok ) 2491 IF ( allocok .GT. 0 ) THEN 2492 INFO(1)=-13 2493 INFO(2)=2 * id%N 2494 GOTO 777 2495 ENDIF 2496 NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 2497 ALLOCATE( D(id%N),stat =allocok ) 2498 IF ( allocok .GT. 0 ) THEN 2499 INFO(1)=-13 2500 INFO(2)=id%N 2501 GOTO 777 2502 ENDIF 2503 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 2504 ALLOCATE( C_W(id%N), stat = allocok ) 2505 IF ( allocok .GT. 0 ) THEN 2506 INFO(1)=-13 2507 INFO(2)=id%N 2508 GOTO 777 2509 ENDIF 2510 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 2511 ALLOCATE( R_W(2*id%N), stat = allocok ) 2512 IF ( allocok .GT. 0 ) THEN 2513 INFO(1)=-13 2514 INFO(2)=id%N 2515 GOTO 777 2516 ENDIF 2517 NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 2518 NITREF = ICNTL10 2519 JOBIREF= ICNTL11 2520 IF ( PROKG .AND. ICNTL10 .GT. 0 ) 2521 & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF 2522 DO I = 1, id%N 2523 D( I ) = RONE 2524 END DO 2525 END IF 2526 ALLOCATE(C_LOCWK54(id%N),stat = allocok) 2527 IF ( allocok .GT. 0 ) THEN 2528 INFO(1)=-13 2529 INFO(2)=id%N 2530 GOTO 777 2531 ENDIF 2532 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 2533 ALLOCATE(R_LOCWK54(id%N),stat = allocok) 2534 IF ( allocok .GT. 0 ) THEN 2535 INFO(1)=-13 2536 INFO(2)=id%N 2537 GOTO 777 2538 ENDIF 2539 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 2540 KASE = 0 2541 777 CONTINUE 2542 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 2543 CALL MUMPS_276( ICNTL(1), INFO(1), 2544 & id%COMM,id%MYID) 2545 IF ( INFO(1) .LT. 0 ) GOTO 90 2546 22 CONTINUE 2547 IF ( KEEP(54) .eq. 0 ) THEN 2548 IF ( id%MYID .eq. MASTER ) THEN 2549 IF ( KASE .eq. 0 ) THEN 2550 IF (KEEP(55).NE.0) THEN 2551 CALL ZMUMPS_119(MTYPE, id%N, 2552 & id%NELT, id%ELTPTR(1), 2553 & id%LELTVAR, id%ELTVAR(1), 2554 & id%NA_ELT, id%A_ELT(1), 2555 & R_W(id%N+1), KEEP(1),KEEP8(1) ) 2556 ELSE 2557 IF ( MTYPE .eq. 1 ) THEN 2558 CALL ZMUMPS_207 2559 & ( id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), 2560 & R_W(id%N+1), KEEP(1),KEEP8(1)) 2561 ELSE 2562 CALL ZMUMPS_207 2563 & ( id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), 2564 & R_W(id%N+1), KEEP(1),KEEP8(1)) 2565 END IF 2566 ENDIF 2567 ENDIF 2568 END IF 2569 ELSE 2570 IF ( KASE .eq. 0 ) THEN 2571 IF ( I_AM_SLAVE .and. 2572 & id%NZ_loc .NE. 0 ) THEN 2573 IF ( MTYPE .eq. 1 ) THEN 2574 CALL ZMUMPS_207(id%A_loc(1), 2575 & id%NZ_loc, id%N, 2576 & id%IRN_loc(1), id%JCN_loc(1), 2577 & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) 2578 ELSE 2579 CALL ZMUMPS_207(id%A_loc(1), 2580 & id%NZ_loc, id%N, 2581 & id%JCN_loc(1), id%IRN_loc(1), 2582 & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) 2583 END IF 2584 ELSE 2585 R_LOCWK54 = RZERO 2586 END IF 2587 IF ( id%MYID .eq. MASTER ) THEN 2588 CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), 2589 & id%N, MPI_DOUBLE_PRECISION, 2590 & MPI_SUM,MASTER,id%COMM, IERR) 2591 ELSE 2592 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2593 & id%N, MPI_DOUBLE_PRECISION, 2594 & MPI_SUM,MASTER,id%COMM, IERR) 2595 END IF 2596 END IF 2597 END IF 2598 IF ( id%MYID .eq. MASTER ) THEN 2599 ARRET = CNTL(2) 2600 IF (ARRET .LT. 0.0D0) THEN 2601 ARRET = sqrt(epsilon(0.0D0)) 2602 END IF 2603 CALL ZMUMPS_206(id%NZ,id%N,SAVERHS,RHS_MUMPS(IBEG), 2604 & C_Y, D, R_W, C_W, 2605 & IW1, KASE,RINFOG(7), 2606 & RINFOG(9), JOBIREF, RINFOG(10), NITREF, NOITER, MP, 2607 & KEEP(1),KEEP8(1), ARRET ) 2608 END IF 2609 IF ( KEEP(54) .ne. 0 ) THEN 2610 CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, 2611 & id%COMM, IERR ) 2612 END IF 2613 IF ( KEEP(54) .eq. 0 ) THEN 2614 IF ( id%MYID .eq. MASTER ) THEN 2615 IF ( KASE .eq. 14 ) THEN 2616 IF (KEEP(55).NE.0) THEN 2617 CALL ZMUMPS_122( MTYPE, id%N, 2618 & id%NELT, id%ELTPTR(1), id%LELTVAR, 2619 & id%ELTVAR(1), id%NA_ELT, id%A_ELT(1), 2620 & SAVERHS, RHS_MUMPS(IBEG), 2621 & C_Y, R_W, KEEP(50)) 2622 ELSE 2623 IF ( MTYPE .eq. 1 ) THEN 2624 CALL ZMUMPS_208 2625 & (id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), SAVERHS, 2626 & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) 2627 ELSE 2628 CALL ZMUMPS_208 2629 & (id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), SAVERHS, 2630 & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) 2631 END IF 2632 ENDIF 2633 GOTO 22 2634 END IF 2635 END IF 2636 ELSE 2637 IF ( KASE.eq.14 ) THEN 2638 CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, 2639 & MPI_DOUBLE_COMPLEX, MASTER, 2640 & id%COMM, IERR ) 2641 IF ( I_AM_SLAVE .and. 2642 & id%NZ_loc .NE. 0 ) THEN 2643 CALL ZMUMPS_192( id%N, id%NZ_loc, 2644 & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), 2645 & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) 2646 ELSE 2647 C_LOCWK54 = ZERO 2648 END IF 2649 IF ( id%MYID .eq. MASTER ) THEN 2650 CALL MPI_REDUCE( C_LOCWK54, C_Y, 2651 & id%N, MPI_DOUBLE_COMPLEX, 2652 & MPI_SUM,MASTER,id%COMM, IERR) 2653 C_Y = SAVERHS - C_Y 2654 ELSE 2655 CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, 2656 & id%N, MPI_DOUBLE_COMPLEX, 2657 & MPI_SUM,MASTER,id%COMM, IERR) 2658 END IF 2659 IF ( I_AM_SLAVE .and. id%NZ_loc .NE. 0 ) THEN 2660 CALL ZMUMPS_193( id%N, id%NZ_loc, 2661 & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), 2662 & RHS_MUMPS(IBEG), R_LOCWK54, KEEP(50), MTYPE ) 2663 ELSE 2664 R_LOCWK54 = RZERO 2665 END IF 2666 IF ( id%MYID .eq. MASTER ) THEN 2667 CALL MPI_REDUCE( R_LOCWK54, R_W, 2668 & id%N, MPI_DOUBLE_PRECISION, 2669 & MPI_SUM,MASTER,id%COMM, IERR) 2670 ELSE 2671 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2672 & id%N, MPI_DOUBLE_PRECISION, 2673 & MPI_SUM, MASTER, id%COMM, IERR) 2674 END IF 2675 GOTO 22 2676 END IF 2677 END IF 2678 IF ( id%MYID .eq. MASTER ) THEN 2679 IF ( KASE .GT. 0 ) THEN 2680 IF ( MTYPE .EQ. 1 ) THEN 2681 SOLVET = KASE - 1 2682 ELSE 2683 SOLVET = KASE 2684 END IF 2685 IF ( LSCAL ) THEN 2686 IF ( SOLVET .EQ. 1 ) THEN 2687 DO K = 1, id%N 2688 C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) 2689 END DO 2690 ELSE 2691 DO K = 1, id%N 2692 C_Y( K ) = C_Y( K ) * id%COLSCA( K ) 2693 END DO 2694 END IF 2695 END IF 2696 END IF 2697 END IF 2698 CALL MPI_BCAST( KASE , 1, MPI_INTEGER, MASTER, 2699 & id%COMM, IERR) 2700 CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, 2701 & id%COMM, IERR) 2702 IF ( KASE .GT. 0 ) THEN 2703 BUILD_POSINRHSCOMP=.FALSE. 2704 IF ( .NOT.I_AM_SLAVE ) THEN 2705 CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, 2706 & MTYPE, C_Y(1), id%N, 1, 2707 & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), 2708 & IDUMMY, 1, 2709 & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, 2710 & id%ICNTL(1),id%INFO(1)) 2711 ELSE 2712 LIW_PASSED = max( LIW, 1 ) 2713 CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, 2714 & MTYPE, C_Y(1), id%N, 1, 2715 & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), 2716 & id%PROCNODE_STEPS(1), 2717 & IS(1), LIW_PASSED, 2718 & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), 2719 & BUILD_POSINRHSCOMP, 2720 & id%ICNTL(1),id%INFO(1)) 2721 ENDIF 2722 IF (INFO(1).LT.0) GOTO 89 2723 IF ( I_AM_SLAVE ) THEN 2724 LIW_PASSED = max( LIW, 1 ) 2725 LA_PASSED = max( LA, 1_8 ) 2726 CALL ZMUMPS_245( id%root, id%N, id%S(1), LA_PASSED, 2727 & id%IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, C_Y, 2728 & id%N, NBRHS_EFF, id%NA(1), id%LNA, id%NE_STEPS(1), SRW3, SOLVET, 2729 & ICNTL(1), id%STEP(1), id%FRERE_STEPS(1), id%DAD_STEPS(1), id% 2730 & FILS(1), id%PTLUST_S(1), id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, 2731 & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), 2732 & id%COMM_NODES, id%MYID, id%MYID_NODES, id%BUFR(1), id%LBUFR, 2733 & id%LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), 2734 & IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1, 2735 & PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, 2736 & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 2737 & id%POSINRHSCOMP(1), BUILD_POSINRHSCOMP 2738 & , 1 , 1 , 1 2739 & , 1 2740 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY 2741 & ) 2742 END IF 2743 IF (INFO(1).eq.-2) INFO(1)=-12 2744 IF (INFO(1).eq.-3) INFO(1)=-15 2745 IF ( .NOT. I_AM_SLAVE .AND. INFO(1) .GE. 0) THEN 2746 ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) 2747 IF (allocok > 0) THEN 2748 ALLOCATE( CWORK(KEEP(247)), stat=allocok) 2749 IF (allocok > 0) THEN 2750 INFO(1)=-13 2751 INFO(2)=KEEP(247) 2752 ENDIF 2753 ENDIF 2754 ENDIF 2755 89 CALL MUMPS_276( ICNTL(1), INFO(1), 2756 & id%COMM,id%MYID) 2757 IF (INFO(1).LT.0) GO TO 90 2758 IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN 2759 PT_SCALING => Dummy_SCAL 2760 ELSE 2761 IF (SOLVET.EQ.1) THEN 2762 PT_SCALING => id%COLSCA 2763 ELSE 2764 PT_SCALING => id%ROWSCA 2765 ENDIF 2766 ENDIF 2767 LIW_PASSED = max( LIW, 1 ) 2768 IF ( .NOT. I_AM_SLAVE ) THEN 2769 CALL ZMUMPS_521(id%NSLAVES,id%N, 2770 & id%MYID, id%COMM, 2771 & SOLVET, C_Y, id%N, NBRHS_EFF, 2772 & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), 2773 & IDUMMY, 1, 2774 & id%STEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2775 & CWORK, size(CWORK), 2776 & LSCAL, PT_SCALING(1), size(PT_SCALING)) 2777 DEALLOCATE( CWORK ) 2778 ELSE 2779 CALL ZMUMPS_521(id%NSLAVES,id%N, 2780 & id%MYID, id%COMM, 2781 & SOLVET, C_Y, id%N, NBRHS_EFF, 2782 & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), 2783 & id%PROCNODE_STEPS(1), 2784 & IS(1), LIW_PASSED, 2785 & id%STEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, 2786 & id%RHSCOMP(1), LENRHSCOMP, 2787 & LSCAL, PT_SCALING(1), size(PT_SCALING)) 2788 ENDIF 2789 GO TO 22 2790 ELSEIF ( KASE .LT. 0 ) THEN 2791 INFO( 1 ) = INFO( 1 ) + 8 2792 END IF 2793 IF ( id%MYID .eq. MASTER ) THEN 2794 NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 2795 & - int(size(D ),8)*K16_8 2796 & - int(size(IW1),8)*K34_8 2797 DEALLOCATE(R_W,D) 2798 DEALLOCATE(IW1) 2799 ENDIF 2800 IF ( PROKG ) THEN 2801 IF (NITREF.GT.0) THEN 2802 WRITE( MPG, 81 ) 2803 WRITE( MPG, 141 ) 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS 2804 &=', NOITER 2805 ENDIF 2806 ENDIF 2807 IF ( id%MYID .EQ. MASTER ) THEN 2808 IF ( NITREF .GT. 0 ) THEN 2809 id%INFOG(15) = NOITER 2810 END IF 2811 END IF 2812 IF ( PROK .AND. ICNTL10 .GT.0 ) WRITE( MP, 131 ) 2813 IF (ICNTL11 .GT. 0) THEN 2814 IF ( KEEP(54) .eq. 0 ) THEN 2815 IF (id%MYID .EQ. MASTER) THEN 2816 IF (KEEP(55).EQ.0) THEN 2817 CALL ZMUMPS_278( MTYPE, id%N, id%NZ, id%A(1), 2818 & id%IRN(1), id%JCN(1), 2819 & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) 2820 ELSE 2821 CALL ZMUMPS_121( MTYPE, id%N, 2822 & id%NELT, id%ELTPTR(1), 2823 & id%LELTVAR, id%ELTVAR(1), 2824 & id%NA_ELT, id%A_ELT(1), 2825 & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) 2826 ENDIF 2827 END IF 2828 ELSE 2829 CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, 2830 & MPI_DOUBLE_COMPLEX, MASTER, 2831 & id%COMM, IERR ) 2832 IF ( I_AM_SLAVE .and. 2833 & id%NZ_loc .NE. 0 ) THEN 2834 CALL ZMUMPS_192( id%N, id%NZ_loc, 2835 & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), 2836 & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) 2837 ELSE 2838 C_LOCWK54 = ZERO 2839 END IF 2840 IF ( id%MYID .eq. MASTER ) THEN 2841 CALL MPI_REDUCE( C_LOCWK54, C_W, 2842 & id%N, MPI_DOUBLE_COMPLEX, 2843 & MPI_SUM,MASTER,id%COMM, IERR) 2844 C_W = SAVERHS - C_W 2845 ELSE 2846 CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, 2847 & id%N, MPI_DOUBLE_COMPLEX, 2848 & MPI_SUM,MASTER,id%COMM, IERR) 2849 END IF 2850 IF ( I_AM_SLAVE .and. 2851 & id%NZ_loc .NE. 0 ) THEN 2852 CALL ZMUMPS_207(id%A_loc(1), 2853 & id%NZ_loc, id%N, 2854 & id%IRN_loc(1), id%JCN_loc(1), 2855 & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) 2856 ELSE 2857 R_LOCWK54 = RZERO 2858 END IF 2859 IF ( id%MYID .eq. MASTER ) THEN 2860 CALL MPI_REDUCE( R_LOCWK54, R_Y, 2861 & id%N, MPI_DOUBLE_PRECISION, 2862 & MPI_SUM,MASTER,id%COMM, IERR) 2863 ELSE 2864 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2865 & id%N, MPI_DOUBLE_PRECISION, 2866 & MPI_SUM,MASTER,id%COMM, IERR) 2867 END IF 2868 END IF 2869 IF (id%MYID .EQ. MASTER) THEN 2870 IF ((MPG .GT. 0) .AND. (NITREF .GT. 0)) WRITE( MPG, 65 ) 2871 IF ((MPG .GT. 0) .AND. (NITREF .LE. 0)) WRITE( MPG, 170 ) 2872 GIVSOL = .FALSE. 2873 CALL ZMUMPS_205(MTYPE,INFO(1),id%N,id%NZ,RHS_MUMPS(IBEG), 2874 & SAVERHS,R_Y,C_W,GIVSOL, 2875 & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), 2876 & KEEP(1),KEEP8(1)) 2877 IF ( MPG .GT. 0 ) THEN 2878 WRITE( MPG, 115 ) 2879 &'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', RINFOG(7) 2880 WRITE( MPG, 115 ) 2881 &'------(8):---------------------------- (W2)=', RINFOG(8) 2882 WRITE( MPG, 115 ) 2883 &'------(9):Upper bound ERROR ...............=', RINFOG(9) 2884 WRITE( MPG, 115 ) 2885 &'-----(10):CONDITION NUMBER (1) ............=', RINFOG(10) 2886 WRITE( MPG, 115 ) 2887 &'-----(11):CONDITION NUMBER (2) ............=', RINFOG(11) 2888 END IF 2889 END IF 2890 END IF 2891 IF (id%MYID == MASTER) THEN 2892 NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 2893 DEALLOCATE(C_W) 2894 ENDIF 2895 NB_BYTES = NB_BYTES - 2896 & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 2897 NB_BYTES = NB_BYTES - 2898 & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 2899 DEALLOCATE(R_Y) 2900 DEALLOCATE(C_Y) 2901 DEALLOCATE(R_LOCWK54) 2902 DEALLOCATE(C_LOCWK54) 2903 END IF 2904 IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 2905 & .AND. KEEP(23) .NE. 0 .AND. KEEP(237).EQ.0 ) THEN 2906 IF ((KEEP(221).NE.1 .AND. ICNTL(9) .EQ. 1) 2907 & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN 2908 ALLOCATE( C_RW1( id%N ),stat =allocok ) 2909 IF ( allocok .GT. 0 ) THEN 2910 INFO(1)=-13 2911 INFO(2)=id%N 2912 WRITE(*,*) 'could not allocate ', id%N, 'integers.' 2913 CALL MUMPS_ABORT() 2914 END IF 2915 DO K = 1, NBRHS_EFF 2916 KDEC = (K-1)*LD_RHS+IBEG-1 2917 DO 70 I = 1, id%N 2918 C_RW1(I) = RHS_MUMPS(KDEC+I) 2919 70 CONTINUE 2920 DO 80 I = 1, id%N 2921 JPERM = id%UNS_PERM(I) 2922 RHS_MUMPS( KDEC+JPERM ) = C_RW1( I ) 2923 80 CONTINUE 2924 END DO 2925 DEALLOCATE( C_RW1 ) 2926 END IF 2927 END IF 2928 IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1 2929 & .and. KEEP(237).EQ.0 ) THEN 2930 IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) 2931 & THEN 2932 K = min0(10, id%N) 2933 IF (ICNTL(4) .eq. 4 ) K = id%N 2934 J = min0(10,NBRHS_EFF) 2935 IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF 2936 DO II=1, J 2937 WRITE(ICNTL(3),110) BEG_RHS+II-1 2938 WRITE(ICNTL(3),160) 2939 & (RHS_MUMPS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) 2940 ENDDO 2941 END IF 2942 END IF 2943 IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN 2944 BEG_RHS = BEG_RHS + NBRHS_EFF 2945 ELSE 2946 BEG_RHS = BEG_RHS + NBRHS 2947 ENDIF 2948 ENDDO 2949 IF ( (id%MYID.EQ.MASTER) 2950 & .AND. ( KEEP(248).NE.0 ) 2951 & .AND. ( KEEP(237).EQ.0 ) 2952 & .AND. ( ICNTL21.EQ.0 ) 2953 & .AND. ( KEEP(221) .NE.1 ) 2954 & .AND. ( JEND_RHS .LT. id%NRHS ) 2955 & ) 2956 & THEN 2957 JBEG_NEW = JEND_RHS + 1 2958 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN 2959 DO WHILE ( JBEG_NEW.LE. id%NRHS) 2960 DO I=1, id%N 2961 RHS_MUMPS((PERM_RHS(JBEG_NEW) -1)*LD_RHS+I) 2962 & = ZERO 2963 ENDDO 2964 JBEG_NEW = JBEG_NEW +1 2965 CYCLE 2966 ENDDO 2967 ELSE 2968 DO WHILE ( JBEG_NEW.LE. id%NRHS) 2969 DO I=1, id%N 2970 RHS_MUMPS((JBEG_NEW -1)*LD_RHS + I) = ZERO 2971 ENDDO 2972 JBEG_NEW = JBEG_NEW +1 2973 ENDDO 2974 ENDIF 2975 ENDIF 2976 IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. 2977 & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN 2978 JBEG_NEW = JEND_RHS + 1 2979 DO WHILE ( JBEG_NEW.LE. id%NRHS) 2980 DO I=1, KEEP(89) 2981 id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO 2982 ENDDO 2983 JBEG_NEW = JBEG_NEW +1 2984 ENDDO 2985 ENDIF 2986 IF ((KEEP(221).EQ.1) .AND. 2987 & ( JEND_RHS .LT. id%NRHS ) ) THEN 2988 IF (id%MYID .EQ. MASTER) THEN 2989 JBEG_NEW = JEND_RHS + 1 2990 DO WHILE ( JBEG_NEW.LE. id%NRHS) 2991 DO I=1, id%SIZE_SCHUR 2992 id%REDRHS((JBEG_NEW -1)*LD_REDRHS + I) = ZERO 2993 ENDDO 2994 JBEG_NEW = JBEG_NEW +1 2995 ENDDO 2996 ENDIF 2997 IF (I_AM_SLAVE) THEN 2998 JBEG_NEW = JEND_RHS + 1 2999 DO WHILE ( JBEG_NEW.LE. id%NRHS) 3000 DO I=1,LD_RHSCOMP 3001 id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO 3002 ENDDO 3003 JBEG_NEW = JBEG_NEW +1 3004 ENDDO 3005 ENDIF 3006 ENDIF 3007 id%INFO(26) = int(NB_BYTES_MAX / 1000000_8, 4) 3008 CALL MUMPS_243( id%MYID, id%COMM, 3009 & id%INFO(26), id%INFOG(30), IRANK ) 3010 IF ( PROKG ) THEN 3011 WRITE( MPG,'(A,I10) ') 3012 & ' ** Rank of processor needing largest memory in solve :', 3013 & IRANK 3014 WRITE( MPG,'(A,I10) ') 3015 & ' ** Space in MBYTES used by this processor for solve :', 3016 & id%INFOG(30) 3017 IF ( KEEP(46) .eq. 0 ) THEN 3018 WRITE( MPG,'(A,I10) ') 3019 & ' ** Avg. Space in MBYTES per working proc during solve :', 3020 & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES 3021 ELSE 3022 WRITE( MPG,'(A,I10) ') 3023 & ' ** Avg. Space in MBYTES per working proc during solve :', 3024 & id%INFOG(31) / id%NSLAVES 3025 END IF 3026 END IF 3027 90 CONTINUE 3028 IF (INFO(1) .LT.0 ) THEN 3029 ENDIF 3030 IF (KEEP(201).GT.0)THEN 3031 IF (IS_INIT_OOC_DONE) THEN 3032 CALL ZMUMPS_582(IERR) 3033 IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR 3034 ENDIF 3035 CALL MUMPS_276( ICNTL(1), INFO(1), 3036 & id%COMM,id%MYID) 3037 ENDIF 3038 IF (IRHS_SPARSE_COPY_ALLOCATED) THEN 3039 NB_BYTES = NB_BYTES - 3040 & int(size(IRHS_SPARSE_COPY),8)*K34_8 3041 DEALLOCATE(IRHS_SPARSE_COPY) 3042 IRHS_SPARSE_COPY_ALLOCATED=.FALSE. 3043 NULLIFY(IRHS_SPARSE_COPY) 3044 ENDIF 3045 IF (IRHS_PTR_COPY_ALLOCATED) THEN 3046 NB_BYTES = NB_BYTES - 3047 & int(size(IRHS_PTR_COPY),8)*K34_8 3048 DEALLOCATE(IRHS_PTR_COPY) 3049 IRHS_PTR_COPY_ALLOCATED=.FALSE. 3050 NULLIFY(IRHS_PTR_COPY) 3051 ENDIF 3052 IF (RHS_SPARSE_COPY_ALLOCATED) THEN 3053 NB_BYTES = NB_BYTES - 3054 & int(size(RHS_SPARSE_COPY),8)*K35_8 3055 DEALLOCATE(RHS_SPARSE_COPY) 3056 RHS_SPARSE_COPY_ALLOCATED=.FALSE. 3057 NULLIFY(RHS_SPARSE_COPY) 3058 ENDIF 3059 IF (allocated(PERM_RHS)) THEN 3060 NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 3061 DEALLOCATE(PERM_RHS) 3062 ENDIF 3063 IF (allocated(UNS_PERM_INV)) THEN 3064 NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 3065 DEALLOCATE(UNS_PERM_INV) 3066 ENDIF 3067 IF (associated(id%BUFR)) THEN 3068 NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 3069 DEALLOCATE(id%BUFR) 3070 NULLIFY(id%BUFR) 3071 ENDIF 3072 IF ( I_AM_SLAVE ) THEN 3073 IF (allocated(IWK_SOLVE)) THEN 3074 NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 3075 DEALLOCATE( IWK_SOLVE ) 3076 ENDIF 3077 IF (allocated(IWCB)) THEN 3078 NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 3079 DEALLOCATE( IWCB ) 3080 ENDIF 3081 CALL ZMUMPS_57( IERR ) 3082 CALL ZMUMPS_59( IERR ) 3083 END IF 3084 IF ( id%MYID .eq. MASTER ) THEN 3085 IF (allocated(SAVERHS)) THEN 3086 NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 3087 DEALLOCATE( SAVERHS) 3088 ENDIF 3089 IF ( 3090 & ( 3091 & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 3092 & .OR. KEEP(111).NE.0 ) 3093 & .and. ICNTL21.ne.0 ) 3094 & .or. 3095 & ( KEEP(237).NE.0 ) 3096 & ) 3097 & THEN 3098 IF ( I_AM_SLAVE ) THEN 3099 IF (associated(RHS_MUMPS) ) THEN 3100 NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 3101 DEALLOCATE(RHS_MUMPS) 3102 ENDIF 3103 ENDIF 3104 ENDIF 3105 NULLIFY(RHS_MUMPS) 3106 ELSE 3107 IF (associated(RHS_MUMPS)) THEN 3108 NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 3109 DEALLOCATE(RHS_MUMPS) 3110 NULLIFY(RHS_MUMPS) 3111 END IF 3112 END IF 3113 IF (I_AM_SLAVE) THEN 3114 IF (allocated(SRW3)) THEN 3115 NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 3116 DEALLOCATE(SRW3) 3117 ENDIF 3118 IF (allocated(POSINRHSCOMP_N)) THEN 3119 NB_BYTES = NB_BYTES - int(size(POSINRHSCOMP_N),8)*K34_8 3120 DEALLOCATE(POSINRHSCOMP_N) 3121 ENDIF 3122 IF (LSCAL .AND. ICNTL21==1) THEN 3123 NB_BYTES = NB_BYTES - 3124 & int(size(scaling_data%SCALING_LOC),8)*K16_8 3125 DEALLOCATE(scaling_data%SCALING_LOC) 3126 NULLIFY(scaling_data%SCALING_LOC) 3127 ENDIF 3128 IF (WK_USER_PROVIDED) THEN 3129 NULLIFY(id%S) 3130 ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN 3131 NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 3132 id%KEEP8(23)=0_8 3133 DEALLOCATE(id%S) 3134 NULLIFY(id%S) 3135 ENDIF 3136 IF (KEEP(221).NE.1) THEN 3137 IF (associated(id%RHSCOMP)) THEN 3138 NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 3139 DEALLOCATE(id%RHSCOMP) 3140 NULLIFY(id%RHSCOMP) 3141 ENDIF 3142 IF (associated(id%POSINRHSCOMP)) THEN 3143 NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 3144 DEALLOCATE(id%POSINRHSCOMP) 3145 NULLIFY(id%POSINRHSCOMP) 3146 ENDIF 3147 ENDIF 3148 IF ( WORK_WCB_ALLOCATED ) THEN 3149 NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 3150 DEALLOCATE( WORK_WCB ) 3151 ENDIF 3152 NULLIFY( WORK_WCB ) 3153 ENDIF 3154 RETURN 3155 65 FORMAT (//' ERROR ANALYSIS AFTER ITERATIVE REFINEMENT') 3156 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 3157 110 FORMAT (//' VECTOR SOLUTION FOR COLUMN ',I12) 3158 115 FORMAT(1X, A44,1P,D9.2) 3159 150 FORMAT (/' STATISTICS PRIOR SOLVE PHASE ...........'/ 3160 & ' NUMBER OF RIGHT-HAND-SIDES =',I12/ 3161 & ' BLOCKING FACTOR FOR MULTIPLE RHS =',I12/ 3162 & ' ICNTL (9) =',I12/ 3163 & ' --- (10) =',I12/ 3164 & ' --- (11) =',I12/ 3165 & ' --- (20) =',I12/ 3166 & ' --- (21) =',I12/ 3167 & ' --- (30) =',I12) 3168 151 FORMAT (' --- (25) =',I12) 3169 152 FORMAT (' --- (26) =',I12) 3170 153 FORMAT (' --- (32) =',I12) 3171 160 FORMAT (' RHS'/(1X,1P,5D14.6)) 3172 170 FORMAT (//' ERROR ANALYSIS' ) 3173 240 FORMAT (1X, A42,I4) 3174 270 FORMAT (//' BEGIN ITERATIVE REFINEMENT' ) 3175 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 3176 131 FORMAT (/' END ITERATIVE REFINEMENT ') 3177 141 FORMAT(1X, A42,I4) 3178 END SUBROUTINE ZMUMPS_301 3179 SUBROUTINE ZMUMPS_245(root, N, A, LA, IW, LIW, W, LWC, 3180 & IWCB,LIWW,RHS,LRHS,NRHS,NA,LNA,NE_STEPS, W2, 3181 & MTYPE, ICNTL, 3182 & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1,LIW1, 3183 & PROCNODE_STEPS, SLAVEF, 3184 & INFO, KEEP,KEEP8, COMM_NODES, MYID, 3185 & MYID_NODES, 3186 & BUFR, LBUFR, LBUFR_BYTES, 3187 & 3188 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 3189 & IBEG_ROOT_DEF, IEND_ROOT_DEF, 3190 & IROOT_DEF_RHS_COL1, PTR_RHS_ROOT, LPTR_RHS_ROOT, 3191 & SIZE_ROOT, MASTER_ROOT, 3192 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, BUILD_POSINRHSCOMP 3193 & , NZ_RHS, NBCOL_INBLOC, NRHS_ORIG 3194 & , JBEG_RHS 3195 & , Step2node, LStep2node 3196 & , IRHS_SPARSE 3197 & , IRHS_PTR 3198 & , SIZE_PERM_RHS, PERM_RHS 3199 & , SIZE_UNS_PERM_INV, UNS_PERM_INV 3200 & ) 3201 USE ZMUMPS_OOC 3202 USE MUMPS_SOL_ES 3203 IMPLICIT NONE 3204 INCLUDE 'zmumps_root.h' 3205#if defined(V_T) 3206 INCLUDE 'VT.inc' 3207#endif 3208 TYPE ( ZMUMPS_ROOT_STRUC ) :: root 3209 INTEGER(8) :: LA 3210 INTEGER LWC,N,LIW,MTYPE,LIW1,LIWW,LNA 3211 INTEGER ICNTL(40),INFO(40), KEEP(500) 3212 INTEGER(8) KEEP8(150) 3213 INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) 3214 INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), 3215 & DAD(KEEP(28)) 3216 INTEGER(8) :: PTRFAC(KEEP(28)) 3217 INTEGER LRHS, NRHS, LRHSCOMP 3218 COMPLEX(kind=8) A(LA), W(LWC), RHS(LRHS,NRHS), 3219 & W2(KEEP(133)), 3220 & RHSCOMP(LRHSCOMP,NRHS) 3221 INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES 3222 INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP(KEEP(28)) 3223 INTEGER LBUFR, LBUFR_BYTES 3224 INTEGER BUFR(LBUFR) 3225 INTEGER ISTEP_TO_INIV2(KEEP(71)), 3226 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 3227 INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 3228 INTEGER SIZE_ROOT, MASTER_ROOT 3229 INTEGER LPTR_RHS_ROOT 3230 COMPLEX(kind=8) PTR_RHS_ROOT(LPTR_RHS_ROOT) 3231 LOGICAL BUILD_POSINRHSCOMP 3232 INTEGER MP, LP, LDIAG 3233 INTEGER K,I,II 3234 INTEGER allocok 3235 INTEGER LPOOL,MYLEAF,LPANEL_POS 3236 INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB,PTRACB 3237 INTEGER MTYPE_LOC 3238 INTEGER IERR 3239 INTEGER(8) :: IAPOS 3240 INTEGER IOLDPS, 3241 & LOCAL_M, 3242 & LOCAL_N 3243#if defined(V_T) 3244 INTEGER soln_c_class, forw_soln, back_soln, root_soln 3245#endif 3246 INTEGER IZERO 3247 LOGICAL DOFORWARD, DOROOT, DOBACKWARD 3248 LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED 3249 INTEGER IROOT 3250 LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL 3251 LOGICAL SWITCH_OFF_ES 3252 LOGICAL DUMMY_BOOL 3253 PARAMETER (IZERO = 0 ) 3254 COMPLEX(kind=8) ZERO 3255 PARAMETER( ZERO = (0.0D0,0.0D0) ) 3256 INCLUDE 'mumps_headers.h' 3257 EXTERNAL ZMUMPS_248, ZMUMPS_249 3258 INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG 3259 INTEGER, intent(in) :: SIZE_UNS_PERM_INV 3260 INTEGER, intent(in) :: SIZE_PERM_RHS 3261 INTEGER, intent(in) :: JBEG_RHS 3262 INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) 3263 INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) 3264 INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) 3265 INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) 3266 INTEGER, intent(in) :: LStep2node 3267 INTEGER, intent(in) :: Step2node(LStep2node) 3268 INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS 3269 INTEGER nb_nodes_RHS 3270 INTEGER nb_prun_leaves 3271 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves 3272 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List 3273 INTEGER nb_prun_nodes 3274 INTEGER nb_prun_roots, JAM1 3275 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots 3276 INTEGER, DIMENSION(:), ALLOCATABLE :: prun_NA 3277 INTEGER :: SIZE_TO_PROCESS 3278 LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS 3279 INTEGER ISTEP, INODE_PRINC 3280 LOGICAL AM1, DO_PRUN 3281 LOGICAL Exploit_Sparsity 3282 INTEGER :: OOC_FCT_TYPE_TMP 3283 INTEGER :: MUMPS_808 3284 EXTERNAL :: MUMPS_808 3285 MYLEAF = -1 3286 LP = ICNTL(1) 3287 MP = ICNTL(2) 3288 LDIAG = ICNTL(4) 3289#if defined(V_T) 3290 CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) 3291 CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) 3292 CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) 3293 CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) 3294#endif 3295 NSTK_S = 1 3296 PTRICB = NSTK_S + KEEP(28) 3297 PTRACB = PTRICB + KEEP(28) 3298 IPOOL = PTRACB + KEEP(28) 3299 LPOOL = KEEP(28)+1 3300 IPANEL_POS = IPOOL + LPOOL 3301 IF (KEEP(201).EQ.1) THEN 3302 LPANEL_POS = KEEP(228)+1 3303 ELSE 3304 LPANEL_POS = 1 3305 ENDIF 3306 IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN 3307 WRITE(*,*) MYID, ": Internal Error in ZMUMPS_245", 3308 & IPANEL_POS, LPANEL_POS, LIW1 3309 CALL MUMPS_ABORT() 3310 ENDIF 3311 DOFORWARD = .TRUE. 3312 DOBACKWARD= .TRUE. 3313 SPECIAL_ROOT_REACHED = .TRUE. 3314 SWITCH_OFF_ES = .FALSE. 3315 IF ( KEEP(111).NE.0 .OR. KEEP(252).NE.0 ) THEN 3316 DOFORWARD = .FALSE. 3317 ENDIF 3318 IF (KEEP(221).eq.1) DOBACKWARD = .FALSE. 3319 IF (KEEP(221).eq.2) DOFORWARD = .FALSE. 3320 IF ( KEEP(60).EQ.0 .AND. 3321 & ( 3322 & (KEEP(38).NE.0 .AND. root%yes) 3323 & .OR. 3324 & (KEEP(20).NE.0 .AND. MYID_NODES.EQ.MASTER_ROOT) 3325 & ) 3326 & .AND. KEEP(252).EQ.0 3327 & ) 3328 &THEN 3329 DOROOT = .TRUE. 3330 ELSE 3331 DOROOT = .FALSE. 3332 ENDIF 3333 DOROOT_BWD_PANEL = DOROOT .AND. MTYPE.NE.1 .AND. KEEP(50).EQ.0 3334 & .AND. KEEP(201).EQ.1 3335 DOROOT_FWD_OOC = DOROOT .AND. .NOT.DOROOT_BWD_PANEL 3336 AM1 = (KEEP(237) .NE. 0) 3337 Exploit_Sparsity = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) 3338 DO_PRUN = (Exploit_Sparsity.OR.AM1) 3339 IF ( DO_PRUN ) THEN 3340 IF (.not. allocated(Pruned_SONS)) THEN 3341 ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) 3342 IF(I.GT.0) THEN 3343 INFO(1)=-13 3344 INFO(2)=KEEP(28) 3345 END IF 3346 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3347 IF(INFO(1).LT.0) GOTO 500 3348 END IF 3349 IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) 3350 IF (.not. allocated(TO_PROCESS)) THEN 3351 SIZE_TO_PROCESS = KEEP(28) 3352 ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) 3353 IF(I.GT.0) THEN 3354 INFO(1)=-13 3355 INFO(2)=KEEP(28) 3356 END IF 3357 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3358 IF(INFO(1).LT.0) GOTO 500 3359 END IF 3360 TO_PROCESS(:) = .TRUE. 3361 ENDIF 3362 IF ( DOFORWARD .AND. DO_PRUN ) THEN 3363 nb_prun_nodes = 0 3364 nb_prun_roots = 0 3365 Pruned_SONS(:) = -1 3366 IF ( Exploit_Sparsity ) THEN 3367 nb_nodes_RHS = 0 3368 DO I = 1, NZ_RHS 3369 ISTEP = abs( STEP(IRHS_SPARSE(I)) ) 3370 INODE_PRINC = Step2node( ISTEP ) 3371 IF ( Pruned_SONS(ISTEP) .eq. -1) THEN 3372 nb_nodes_RHS = nb_nodes_RHS +1 3373 Pruned_SONS(ISTEP) = 0 3374 ENDIF 3375 ENDDO 3376 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) 3377 IF(allocok.GT.0) THEN 3378 INFO(1)=-13 3379 INFO(2)=nb_nodes_RHS 3380 END IF 3381 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3382 IF(INFO(1).LT.0) GOTO 500 3383 nb_nodes_RHS = 0 3384 Pruned_SONS = -1 3385 DO I = 1, NZ_RHS 3386 ISTEP = abs( STEP(IRHS_SPARSE(I)) ) 3387 INODE_PRINC = Step2node( ISTEP ) 3388 IF ( Pruned_SONS(ISTEP) .eq. -1) THEN 3389 nb_nodes_RHS = nb_nodes_RHS +1 3390 nodes_RHS(nb_nodes_RHS) = INODE_PRINC 3391 Pruned_SONS(ISTEP) = 0 3392 ENDIF 3393 ENDDO 3394 ELSE IF ( AM1 ) THEN 3395#if defined(NOT_USED) 3396 IF ( KEEP(201).GT.0) THEN 3397 CALL ZMUMPS_789(KEEP(28), 3398 & KEEP(38), KEEP(20) ) 3399 ENDIF 3400#endif 3401 nb_nodes_RHS = 0 3402#if defined(check) 3403 WRITE(*,*) "NBCOL_INBLOC=",NBCOL_INBLOC 3404 WRITE(*,*) "JBEG SIZE=",JBEG_RHS, SIZE(IRHS_PTR) 3405#endif 3406 DO I = 1, NBCOL_INBLOC 3407 IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE 3408 IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN 3409 JAM1 = PERM_RHS(JBEG_RHS+I-1) 3410 ELSE 3411 JAM1 = JBEG_RHS+I-1 3412 ENDIF 3413 ISTEP = abs(STEP(JAM1)) 3414 INODE_PRINC = Step2node(ISTEP) 3415 IF ( Pruned_SONS(ISTEP) .eq. -1) THEN 3416 nb_nodes_RHS = nb_nodes_RHS +1 3417 Pruned_SONS(ISTEP) = 0 3418 ENDIF 3419 ENDDO 3420 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) 3421 IF(allocok.GT.0) THEN 3422 INFO(1)=-13 3423 INFO(2)=nb_nodes_RHS 3424 END IF 3425 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3426 IF(INFO(1).LT.0) GOTO 500 3427 nb_nodes_RHS = 0 3428 Pruned_SONS = -1 3429 DO I = 1, NBCOL_INBLOC 3430 IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE 3431 IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN 3432 JAM1 = PERM_RHS(JBEG_RHS+I-1) 3433 ELSE 3434 JAM1 = JBEG_RHS+I-1 3435 ENDIF 3436 ISTEP = abs(STEP(JAM1)) 3437 INODE_PRINC = Step2node(ISTEP) 3438 IF ( Pruned_SONS(ISTEP) .eq. -1) THEN 3439 nb_nodes_RHS = nb_nodes_RHS +1 3440 nodes_RHS(nb_nodes_RHS) = INODE_PRINC 3441 Pruned_SONS(ISTEP) = 0 3442 ENDIF 3443 ENDDO 3444 ENDIF 3445 CALL MUMPS_797( 3446 & .FALSE., 3447 & DAD, KEEP(28), 3448 & STEP, N, 3449 & nodes_RHS, nb_nodes_RHS, 3450 & Pruned_SONS, TO_PROCESS, 3451 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves ) 3452 ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) 3453 IF(allocok.GT.0) THEN 3454 INFO(1)=-13 3455 INFO(2)=nb_prun_nodes 3456 END IF 3457 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3458 IF(INFO(1).LT.0) GOTO 500 3459 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) 3460 IF(allocok.GT.0) THEN 3461 INFO(1)=-13 3462 INFO(2)=nb_prun_roots 3463 END IF 3464 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3465 IF(INFO(1).LT.0) GOTO 500 3466 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) 3467 IF(allocok.GT.0) THEN 3468 INFO(1)=-13 3469 INFO(2)=nb_prun_leaves 3470 END IF 3471 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3472 IF(INFO(1).LT.0) GOTO 500 3473 CALL MUMPS_797( 3474 & .TRUE., 3475 & DAD, KEEP(28), 3476 & STEP, N, 3477 & nodes_RHS, nb_nodes_RHS, 3478 & Pruned_SONS, TO_PROCESS, 3479 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, 3480 & Pruned_List, Pruned_Roots, Pruned_Leaves ) 3481 IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) 3482 CALL ZMUMPS_809(N, 3483 & KEEP(201), Pruned_List, nb_prun_nodes, 3484 & STEP) 3485 IF ( KEEP(201) .GT. 0) THEN 3486 OOC_FCT_TYPE_TMP=MUMPS_808 3487 & ('F',MTYPE,KEEP(201),KEEP(50)) 3488 ELSE 3489 OOC_FCT_TYPE_TMP = -5959 3490 ENDIF 3491 CALL MUMPS_802( 3492 & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), 3493 & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP 3494 & ) 3495 SPECIAL_ROOT_REACHED = .FALSE. 3496 DO I= 1, nb_prun_roots 3497 IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. 3498 & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN 3499 SPECIAL_ROOT_REACHED = .TRUE. 3500 EXIT 3501 ENDIF 3502 ENDDO 3503 ENDIF 3504 IF (KEEP(201).GT.0) THEN 3505 IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN 3506 CALL ZMUMPS_583(PTRFAC,KEEP(28),MTYPE, 3507 & A,LA,DOFORWARD,IERR) 3508 IF(IERR.LT.0)THEN 3509 INFO(1)=IERR 3510 INFO(2)=0 3511 CALL MUMPS_ABORT() 3512 ENDIF 3513 ENDIF 3514 ENDIF 3515 IF (DOFORWARD) THEN 3516 IF ( KEEP( 50 ) .eq. 0 ) THEN 3517 MTYPE_LOC = MTYPE 3518 ELSE 3519 MTYPE_LOC = 1 3520 ENDIF 3521#if defined(V_T) 3522 CALL VTBEGIN(forw_soln,ierr) 3523#endif 3524 IF (.NOT.DO_PRUN) THEN 3525 CALL ZMUMPS_248(N, A(1), LA, IW(1), LIW, W(1), 3526 & LWC, RHS, LRHS, NRHS, 3527 & IW1(PTRICB), IWCB, LIWW, 3528 & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, 3529 & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, 3530 & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, 3531 & MYLEAF,INFO, 3532 & KEEP,KEEP8, 3533 & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, 3534 & BUFR, LBUFR, LBUFR_BYTES, 3535 & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, 3536 & 3537 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 3538 & ) 3539 ELSE 3540 ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), 3541 & STAT=allocok) 3542 IF(allocok.GT.0) THEN 3543 INFO(1)=-13 3544 INFO(2)=nb_prun_leaves+nb_prun_roots+2 3545 END IF 3546 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3547 IF(I.LT.0) GOTO 500 3548 prun_NA(1) = nb_prun_leaves 3549 prun_NA(2) = nb_prun_roots 3550 DO I = 1, nb_prun_leaves 3551 prun_NA(I+2) = Pruned_Leaves(I) 3552 ENDDO 3553 DO I = 1, nb_prun_roots 3554 prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) 3555 ENDDO 3556 DEALLOCATE(Pruned_List) 3557 DEALLOCATE(Pruned_Leaves) 3558 IF (AM1) THEN 3559 DEALLOCATE(Pruned_Roots) 3560 END IF 3561 IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN 3562 DEALLOCATE(Pruned_Roots) 3563 IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) 3564 SWITCH_OFF_ES = .TRUE. 3565 ENDIF 3566 CALL ZMUMPS_248(N, A(1), LA, IW(1), LIW, W(1), 3567 & LWC, RHS, LRHS, NRHS, 3568 & IW1(PTRICB), IWCB, LIWW, 3569 & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, 3570 & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, 3571 & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, 3572 & MYLEAF,INFO, 3573 & KEEP,KEEP8, 3574 & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, 3575 & BUFR, LBUFR, LBUFR_BYTES, 3576 & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, 3577 & 3578 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 3579 & ) 3580 DEALLOCATE(prun_NA) 3581 ENDIF 3582 BUILD_POSINRHSCOMP = .FALSE. 3583#if defined(V_T) 3584 CALL VTEND(forw_soln,ierr) 3585#endif 3586 ENDIF 3587 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3588 IF ( INFO(1) .LT. 0 ) THEN 3589 IF ( LP .GT. 0 ) THEN 3590 WRITE(LP,*) MYID, 3591 & ': ** ERROR RETURN FROM ZMUMPS_248,INFO(1:2)=', 3592 & INFO(1:2) 3593 END IF 3594 GOTO 500 3595 END IF 3596 CALL MPI_BARRIER( COMM_NODES, IERR ) 3597 IF (DO_PRUN.AND.SWITCH_OFF_ES) THEN 3598 DO_PRUN = .FALSE. 3599 Exploit_Sparsity = .FALSE. 3600 ENDIF 3601 IF ( DOBACKWARD .AND. DO_PRUN ) THEN 3602 nb_prun_leaves = 0 3603 IF ( Exploit_Sparsity .AND. (KEEP(111).EQ.0) ) THEN 3604 nb_nodes_RHS = nb_prun_roots 3605 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) 3606 IF(allocok.GT.0) THEN 3607 WRITE(*,*)'Problem with allocation of nodes_RHS' 3608 INFO(1) = -13 3609 INFO(2) = nb_nodes_RHS 3610 CALL MUMPS_ABORT() 3611 END IF 3612 nodes_RHS(1:nb_prun_roots)=Pruned_Roots(1:nb_prun_roots) 3613 DEALLOCATE(Pruned_Roots) 3614 ELSE 3615 nb_nodes_RHS = 0 3616 Pruned_SONS(:) = -1 3617 DO II = 1, NZ_RHS 3618 I = IRHS_SPARSE(II) 3619 IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) 3620 ISTEP = abs(STEP(I)) 3621 INODE_PRINC = Step2node(ISTEP) 3622 IF ( Pruned_SONS(ISTEP) .eq. -1) THEN 3623 nb_nodes_RHS = nb_nodes_RHS +1 3624 Pruned_SONS(ISTEP) = 0 3625 ENDIF 3626 ENDDO 3627 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) 3628 IF(allocok.GT.0) THEN 3629 WRITE(*,*)'Problem with allocation of nodes_RHS' 3630 INFO(1) = -13 3631 INFO(2) = nb_nodes_RHS 3632 CALL MUMPS_ABORT() 3633 END IF 3634 nb_nodes_RHS = 0 3635 Pruned_SONS(:) = -1 3636 DO II = 1, NZ_RHS 3637 I = IRHS_SPARSE(II) 3638 IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) 3639 ISTEP = abs(STEP(I)) 3640 INODE_PRINC = Step2node(ISTEP) 3641 IF ( Pruned_SONS(ISTEP) .eq. -1) THEN 3642 nb_nodes_RHS = nb_nodes_RHS +1 3643 nodes_RHS(nb_nodes_RHS) = INODE_PRINC 3644 Pruned_SONS(ISTEP) = 0 3645 ENDIF 3646 ENDDO 3647 ENDIF 3648 IF ( Exploit_Sparsity ) THEN 3649 CALL MUMPS_798( 3650 & .FALSE., 3651 & DAD, NE_STEPS, FRERE, KEEP(28), 3652 & FILS, STEP, N, 3653 & nodes_RHS, nb_nodes_RHS, 3654 & TO_PROCESS, 3655 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves 3656 & ) 3657 ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) 3658 IF(allocok.GT.0) THEN 3659 INFO(1)=-13 3660 INFO(2)=nb_prun_nodes 3661 END IF 3662 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3663 IF(INFO(1).LT.0) GOTO 500 3664 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) 3665 IF(allocok.GT.0) THEN 3666 INFO(1)=-13 3667 INFO(2)=nb_prun_roots 3668 END IF 3669 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3670 IF(INFO(1).LT.0) GOTO 500 3671 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) 3672 IF(allocok.GT.0) THEN 3673 INFO(1)=-13 3674 INFO(2)=nb_prun_leaves 3675 END IF 3676 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3677 IF(INFO(1).LT.0) GOTO 500 3678 CALL MUMPS_798( 3679 & .TRUE., 3680 & DAD, NE_STEPS, FRERE, KEEP(28), 3681 & FILS, STEP, N, 3682 & nodes_RHS, nb_nodes_RHS, 3683 & TO_PROCESS, 3684 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, 3685 & Pruned_List, Pruned_Roots, Pruned_Leaves 3686 & ) 3687 CALL ZMUMPS_809(N, 3688 & KEEP(201), Pruned_List, nb_prun_nodes, 3689 & STEP) 3690 IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) 3691 IF (KEEP(201).GT.0) THEN 3692 OOC_FCT_TYPE_TMP=MUMPS_808 3693 & ('B',MTYPE,KEEP(201),KEEP(50)) 3694 ELSE 3695 OOC_FCT_TYPE_TMP = -5959 3696 ENDIF 3697 CALL MUMPS_803( 3698 & MYID_NODES, N, KEEP(28), KEEP(201), 3699 & KEEP8(31), STEP, 3700 & Pruned_List, 3701 & nb_prun_nodes, OOC_FCT_TYPE_TMP) 3702 ENDIF 3703 ENDIF 3704 IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN 3705 I_WORKED_ON_ROOT = .FALSE. 3706 CALL ZMUMPS_584(PTRFAC,KEEP(28),MTYPE, 3707 & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) 3708 IF (IERR .LT. 0) THEN 3709 INFO(1) = -90 3710 INFO(2) = IERR 3711 ENDIF 3712 ENDIF 3713 IF (KEEP(201).EQ.1) THEN 3714 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3715 IF ( INFO(1) .LT. 0 ) GOTO 500 3716 ENDIF 3717 IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 3718 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN 3719 PTR_RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO 3720 ENDIF 3721 IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN 3722 IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN 3723 IF ( root%yes ) THEN 3724 IF (KEEP(201).GT.0) THEN 3725 IF ( (Exploit_Sparsity.AND.(KEEP(111).NE.0)) .and. 3726 & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN 3727 write(6,*) " CPA to be double checked " 3728 GOTO 1010 3729 ENDIF 3730 ENDIF 3731 IOLDPS = PTRIST(STEP(KEEP(38))) 3732 LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) 3733 LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) 3734 IF (KEEP(201).GT.0) THEN 3735 CALL ZMUMPS_643( 3736 & KEEP(38),PTRFAC,KEEP,A,LA, 3737 & STEP,KEEP8,N,DUMMY_BOOL,IERR) 3738 IF(IERR.LT.0)THEN 3739 INFO(1)=IERR 3740 INFO(2)=0 3741 WRITE(*,*) '** ERROR after ZMUMPS_643', 3742 & INFO(1) 3743 call MUMPS_ABORT() 3744 ENDIF 3745 ENDIF 3746 IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) 3747#if defined(V_T) 3748 CALL VTBEGIN(root_soln,ierr) 3749#endif 3750 CALL ZMUMPS_286( NRHS, root%DESCRIPTOR(1), 3751 & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, 3752 & root%MBLOCK, root%NBLOCK, 3753 & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, 3754 & COMM_NODES, 3755 & PTR_RHS_ROOT(1), 3756 & root%TOT_ROOT_SIZE, A( IAPOS ), 3757 & INFO(1), MTYPE, KEEP(50)) 3758 IF(KEEP(201).GT.0)THEN 3759 CALL ZMUMPS_598(KEEP(38), 3760 & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) 3761 IF(IERR.LT.0)THEN 3762 INFO(1)=IERR 3763 INFO(2)=0 3764 WRITE(*,*) 3765 & '** ERROR after ZMUMPS_598 ', 3766 & INFO(1) 3767 call MUMPS_ABORT() 3768 ENDIF 3769 ENDIF 3770 ENDIF 3771 ENDIF 3772 ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN 3773 IF ( MYID_NODES .eq. MASTER_ROOT ) THEN 3774 END IF 3775 END IF 3776#if defined(V_T) 3777 CALL VTEND(root_soln,ierr) 3778#endif 3779 1010 CONTINUE 3780 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3781 IF ( INFO(1) .LT. 0 ) RETURN 3782 IF (DOBACKWARD) THEN 3783 IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) 3784 & THEN 3785 I_WORKED_ON_ROOT = DOROOT 3786 IF (KEEP(111).NE.0) 3787 & I_WORKED_ON_ROOT = .FALSE. 3788 IF (KEEP(38).gt.0 ) THEN 3789 IF ( ( Exploit_Sparsity.AND.(KEEP(111).EQ.0) ) 3790 & .OR. AM1 ) THEN 3791 IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN 3792 OOC_STATE_NODE(STEP(KEEP(38)))=-4 3793 ENDIF 3794 ENDIF 3795 IF (Exploit_Sparsity.AND.(KEEP(111).NE.0)) THEN 3796 IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN 3797 I_WORKED_ON_ROOT = .FALSE. 3798 ENDIF 3799 ENDIF 3800 ENDIF 3801 ENDIF 3802 IF ( AM1 ) THEN 3803 CALL MUMPS_797( 3804 & .FALSE., 3805 & DAD, KEEP(28), 3806 & STEP, N, 3807 & nodes_RHS, nb_nodes_RHS, 3808 & Pruned_SONS, TO_PROCESS, 3809 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves) 3810 ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) 3811 IF(allocok.GT.0) THEN 3812 INFO(1)=-13 3813 INFO(2)=nb_prun_nodes 3814 END IF 3815 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3816 IF(INFO(1).LT.0) GOTO 500 3817 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) 3818 IF(allocok.GT.0) THEN 3819 INFO(1)=-13 3820 INFO(2)=nb_prun_roots 3821 END IF 3822 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3823 IF(INFO(1).LT.0) GOTO 500 3824 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) 3825 IF(allocok.GT.0) THEN 3826 INFO(1)=-13 3827 INFO(2)=nb_prun_leaves 3828 END IF 3829 CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) 3830 IF(INFO(1).LT.0) GOTO 500 3831 CALL MUMPS_797( 3832 & .TRUE., 3833 & DAD, KEEP(28), 3834 & STEP, N, 3835 & nodes_RHS, nb_nodes_RHS, 3836 & Pruned_SONS, TO_PROCESS, 3837 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, 3838 & Pruned_List, Pruned_Roots, Pruned_Leaves ) 3839 CALL ZMUMPS_809(N, 3840 & KEEP(201), Pruned_List, nb_prun_nodes, 3841 & STEP) 3842 IF (KEEP(201).GT.0) THEN 3843 OOC_FCT_TYPE_TMP=MUMPS_808 3844 & ('B',MTYPE,KEEP(201),KEEP(50)) 3845 ELSE 3846 OOC_FCT_TYPE_TMP = -5959 3847 ENDIF 3848 CALL MUMPS_802( 3849 & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), 3850 & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP 3851 & ) 3852 ENDIF 3853 IF ( KEEP(201).GT.0 ) THEN 3854 IROOT = max(KEEP(20),KEEP(38)) 3855 CALL ZMUMPS_584(PTRFAC,KEEP(28),MTYPE, 3856 & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) 3857 ENDIF 3858 IF ( KEEP( 50 ) .eq. 0 ) THEN 3859 MTYPE_LOC = MTYPE 3860 ELSE 3861 MTYPE_LOC = IZERO 3862 ENDIF 3863#if defined(V_T) 3864 CALL VTBEGIN(back_soln,ierr) 3865#endif 3866 IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN 3867 PTR_RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO 3868 ENDIF 3869 IF ( .NOT. DO_PRUN ) THEN 3870 SIZE_TO_PROCESS = 1 3871 IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) 3872 ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) 3873 TO_PROCESS(:) = .TRUE. 3874 CALL ZMUMPS_249( N, A, LA, IW, LIW, W(1), LWC, 3875 & RHS, LRHS, NRHS, 3876 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, 3877 & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, 3878 & W2, NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, 3879 & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, 3880 & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, 3881 & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, 3882 & PTR_RHS_ROOT, LPTR_RHS_ROOT, 3883 & MTYPE_LOC, 3884 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), 3885 & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS) 3886 ELSE 3887 ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), 3888 & STAT=allocok) 3889 IF(allocok.GT.0) THEN 3890 WRITE(*,*)'Problem with allocation of prun_na' 3891 CALL MUMPS_ABORT() 3892 END IF 3893 prun_NA(1) = nb_prun_leaves 3894 prun_NA(2) = nb_prun_roots 3895 DO I = 1, nb_prun_leaves 3896 prun_NA(I+2) = Pruned_Leaves(I) 3897 ENDDO 3898 DO I = 1, nb_prun_roots 3899 prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) 3900 ENDDO 3901 CALL ZMUMPS_249( N, A, LA, IW, LIW, W(1), LWC, 3902 & RHS, LRHS, NRHS, 3903 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, 3904 & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, 3905 & W2, NE_STEPS, prun_NA, LNA, STEP, FRERE,DAD,FILS, 3906 & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, 3907 & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, 3908 & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, 3909 & PTR_RHS_ROOT, LPTR_RHS_ROOT, 3910 & MTYPE_LOC, 3911 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), 3912 & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS) 3913 ENDIF 3914#if defined(V_T) 3915 CALL VTEND(back_soln,ierr) 3916#endif 3917 ENDIF 3918 IF (LDIAG.GT.2 .AND. MP.GT.0) THEN 3919 IF (DOFORWARD) THEN 3920 K = min0(10,N) 3921 IF (LDIAG.EQ.4) K = N 3922 WRITE (MP,99992) 3923 IF (N.GT.0) WRITE (MP,99993) (RHS(I,1),I=1,K) 3924 IF (N.GT.0.and.NRHS>1) 3925 & WRITE (MP,99994) (RHS(I,2),I=1,K) 3926 ENDIF 3927 ENDIF 3928500 CONTINUE 3929 IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) 3930 IF (Exploit_Sparsity.OR.AM1.OR.SWITCH_OFF_ES) THEN 3931 IF ( allocated(nodes_RHS)) DEALLOCATE (nodes_RHS) 3932 IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) 3933 IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) 3934 IF ( allocated(prun_NA)) DEALLOCATE (prun_NA) 3935 IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) 3936 IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) 3937 ENDIF 3938 RETURN 393999993 FORMAT (' RHS (first column)'/(1X,1P,5D14.6)) 394099994 FORMAT (' RHS (2 nd column)'/(1X,1P,5D14.6)) 394199992 FORMAT (//' LEAVING SOLVE (MPI41C) WITH') 3942 END SUBROUTINE ZMUMPS_245 3943 SUBROUTINE ZMUMPS_521(NSLAVES, N, MYID, COMM, 3944 & MTYPE, RHS, LRHS, NRHS, PTRIST, 3945 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, 3946 & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, 3947 & LSCAL, SCALING, LSCALING) 3948 IMPLICIT NONE 3949 INCLUDE 'mpif.h' 3950 INCLUDE 'mumps_tags.h' 3951 INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE 3952 INTEGER NRHS, LRHS, LCWORK 3953 COMPLEX(kind=8) RHS (LRHS, NRHS) 3954 INTEGER KEEP(500) 3955 INTEGER(8) KEEP8(150) 3956 COMPLEX(kind=8) :: CWORK(LCWORK) 3957 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) 3958 INTEGER IW(LIW), STEP(N) 3959 INTEGER SIZE_BUF, SIZE_BUF_BYTES 3960 INTEGER BUFFER(SIZE_BUF) 3961 LOGICAL, intent(in) :: LSCAL 3962 INTEGER, intent(in) :: LSCALING 3963 DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) 3964 INTEGER I, II, J, J1, ISTEP, MASTER, 3965 & MYID_NODES, TYPE_PARAL, N2RECV 3966 INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf 3967 INTEGER STATUS(MPI_STATUS_SIZE), IERR 3968 PARAMETER(MASTER=0) 3969 LOGICAL I_AM_SLAVE 3970 INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 3971 INTEGER POS_BUF, N2SEND 3972 INTEGER SK38, SK20 3973 INTEGER, PARAMETER :: FIN = -1 3974 INTEGER, PARAMETER :: yes = 1 3975 INTEGER, PARAMETER :: no = 0 3976 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) 3977 INTEGER :: ONE_PACK 3978 INCLUDE 'mumps_headers.h' 3979 INTEGER MUMPS_275 3980 EXTERNAL MUMPS_275 3981 TYPE_PARAL = KEEP(46) 3982 I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 3983 IF ( TYPE_PARAL == 1 ) THEN 3984 MYID_NODES = MYID 3985 ELSE 3986 MYID_NODES = MYID-1 3987 ENDIF 3988 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN 3989 IF (LSCAL) THEN 3990 DO J=1, NRHS 3991 DO I=1,N 3992 RHS(I,J) = RHS(I,J)*SCALING(I) 3993 ENDDO 3994 ENDDO 3995 ENDIF 3996 RETURN 3997 ENDIF 3998 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.0) THEN 3999 DO J=1, NRHS 4000 IF ( I_AM_SLAVE ) THEN 4001 CALL MPI_SEND(RHS(1, J), N, MPI_DOUBLE_COMPLEX, MASTER, 4002 & GatherSol, COMM, IERR) 4003 & 4004 ELSE 4005 CALL MPI_RECV(RHS(1, J), N, MPI_DOUBLE_COMPLEX, 4006 & 1, 4007 & GatherSol, COMM, STATUS, IERR ) 4008 IF (LSCAL) THEN 4009 DO I=1,N 4010 RHS(I,J) = RHS(I,J)*SCALING(I) 4011 ENDDO 4012 ENDIF 4013 ENDIF 4014 ENDDO 4015 RETURN 4016 ENDIF 4017 MAXNPIV_estim = max(KEEP(246), KEEP(247)) 4018 MAXSurf = MAXNPIV_estim*NRHS 4019 IF (LCWORK .GE. MAXSurf) THEN 4020 ONE_PACK = yes 4021 ELSE IF (LCWORK .GE. MAXNPIV_estim) THEN 4022 ONE_PACK = no 4023 ELSE 4024 WRITE(*,*) 4025 & "Internal error 2 in ZMUMPS_521:", 4026 & TYPE_PARAL, LCWORK, KEEP(247), NRHS 4027 CALL MUMPS_ABORT() 4028 ENDIF 4029 IF (ONE_PACK .EQ. no .AND. I_AM_SLAVE) THEN 4030 WRITE(*,*) 4031 & "Internal error 1 in ZMUMPS_521:", 4032 & TYPE_PARAL, LCWORK, KEEP(246),KEEP(247), NRHS 4033 CALL MUMPS_ABORT() 4034 ENDIF 4035 IF (TYPE_PARAL .EQ. 0) 4036 &CALL MPI_BCAST(ONE_PACK, 1, MPI_INTEGER, 4037 & MASTER, COMM, IERR) 4038 IF (MYID.EQ.MASTER) THEN 4039 ALLOCATE(IROWlist(KEEP(247))) 4040 ENDIF 4041 IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN 4042 CALL MUMPS_ABORT() 4043 ENDIF 4044 SIZE1=0 4045 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, 4046 & SIZE1, IERR) 4047 SIZE2=0 4048 CALL MPI_PACK_SIZE(MAXSurf,MPI_DOUBLE_COMPLEX, COMM, 4049 & SIZE2, IERR) 4050 RECORD_SIZE_P_1= SIZE1+SIZE2 4051 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN 4052 write(6,*) MYID, 4053 & ' Internal error 3 in ZMUMPS_521 ' 4054 write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', 4055 & RECORD_SIZE_P_1, SIZE_BUF_BYTES 4056 CALL MUMPS_ABORT() 4057 ENDIF 4058 N2SEND =0 4059 N2RECV =N 4060 POS_BUF =0 4061 IF (KEEP(38).NE.0) THEN 4062 SK38=STEP(KEEP(38)) 4063 ELSE 4064 SK38=0 4065 ENDIF 4066 IF (KEEP(20).NE.0) THEN 4067 SK20=STEP(KEEP(20)) 4068 ELSE 4069 SK20=0 4070 ENDIF 4071 IF (I_AM_SLAVE) THEN 4072 POS_BUF = 0 4073 DO ISTEP = 1, KEEP(28) 4074 IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), 4075 & NSLAVES)) THEN 4076 IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN 4077 IPOS = PTRIST(ISTEP)+KEEP(IXSZ) 4078 NPIV = IW(IPOS+3) 4079 LIELL = IW(IPOS) + NPIV 4080 IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) 4081 ELSE 4082 IPOS = PTRIST(ISTEP) + 2+ KEEP(IXSZ) 4083 LIELL = IW(IPOS-2)+IW(IPOS+1) 4084 IPOS= IPOS+1 4085 NPIV = IW(IPOS) 4086 IPOS= IPOS+1 4087 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) 4088 END IF 4089 IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN 4090 J1=IPOS+1+LIELL 4091 ELSE 4092 J1=IPOS+1 4093 END IF 4094 IF (MYID .EQ. MASTER) THEN 4095 N2RECV=N2RECV-NPIV 4096 IF (NPIV.GT.0.AND.LSCAL) 4097 & CALL ZMUMPS_522 ( ONE_PACK, .TRUE. ) 4098 ELSE 4099 IF (NPIV.GT.0) 4100 & CALL ZMUMPS_522 ( ONE_PACK, .FALSE.) 4101 ENDIF 4102 ENDIF 4103 ENDDO 4104 CALL ZMUMPS_523() 4105 ENDIF 4106 IF ( MYID .EQ. MASTER ) THEN 4107 DO WHILE (N2RECV .NE. 0) 4108 CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, 4109 & MPI_ANY_SOURCE, 4110 & GatherSol, COMM, STATUS, IERR ) 4111 POS_BUF = 0 4112 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, 4113 & NPIV, 1, MPI_INTEGER, COMM, IERR) 4114 DO WHILE (NPIV.NE.FIN) 4115 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, 4116 & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) 4117 IF (ONE_PACK.EQ.yes) THEN 4118 CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, 4119 & CWORK, NPIV*NRHS, MPI_DOUBLE_COMPLEX, 4120 & COMM, IERR) 4121 IF (LSCAL) THEN 4122 DO J=1, NRHS 4123 DO I=1,NPIV 4124 RHS(IROWlist(I),J)= 4125 & CWORK(I+(J-1)*NPIV)*SCALING(IROWlist(I)) 4126 ENDDO 4127 END DO 4128 ELSE 4129 DO J=1, NRHS 4130 DO I=1,NPIV 4131 RHS(IROWlist(I),J)= CWORK(I+(J-1)*NPIV) 4132 ENDDO 4133 END DO 4134 ENDIF 4135 ELSE 4136 DO J=1,NRHS 4137 CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, 4138 & CWORK, NPIV, MPI_DOUBLE_COMPLEX, 4139 & COMM, IERR) 4140 IF (LSCAL) THEN 4141 DO I=1,NPIV 4142 RHS(IROWlist(I),J)=CWORK(I)*SCALING(IROWlist(I)) 4143 ENDDO 4144 ELSE 4145 DO I=1,NPIV 4146 RHS(IROWlist(I),J)=CWORK(I) 4147 ENDDO 4148 ENDIF 4149 ENDDO 4150 ENDIF 4151 N2RECV=N2RECV-NPIV 4152 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, 4153 & NPIV, 1, MPI_INTEGER, COMM, IERR) 4154 ENDDO 4155 ENDDO 4156 DEALLOCATE(IROWlist) 4157 ENDIF 4158 RETURN 4159 CONTAINS 4160 SUBROUTINE ZMUMPS_522 ( ONE_PACK, SCALE_ONLY ) 4161 INTEGER, intent(in) :: ONE_PACK 4162 LOGICAL, intent(in) :: SCALE_ONLY 4163 INTEGER III 4164 IF (SCALE_ONLY) THEN 4165 DO II=1,NPIV 4166 I=IW(J1+II-1) 4167 DO J=1, NRHS 4168 RHS(I,J) = RHS(I,J)*SCALING(I) 4169 ENDDO 4170 ENDDO 4171 RETURN 4172 ENDIF 4173 DO II=1,NPIV 4174 I=IW(J1+II-1) 4175 DO J=1, NRHS 4176 CWORK(II+(J-1)*NPIV) = RHS(I,J) 4177 ENDDO 4178 ENDDO 4179 CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, 4180 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) 4181 CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, 4182 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) 4183 IF (ONE_PACK.EQ.yes) THEN 4184 CALL MPI_PACK(CWORK(1), NPIV*NRHS, MPI_DOUBLE_COMPLEX, 4185 & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, 4186 & IERR) 4187 ELSE 4188 III = 1 4189 DO J=1,NRHS 4190 CALL MPI_PACK(CWORK(III), NPIV, MPI_DOUBLE_COMPLEX, 4191 & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, 4192 & IERR) 4193 III =III+NPIV 4194 ENDDO 4195 ENDIF 4196 N2SEND=N2SEND+NPIV 4197 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN 4198 CALL ZMUMPS_523() 4199 END IF 4200 RETURN 4201 END SUBROUTINE ZMUMPS_522 4202 SUBROUTINE ZMUMPS_523() 4203 IF (N2SEND .NE. 0) THEN 4204 CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, 4205 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) 4206 CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, 4207 & GatherSol, COMM, IERR) 4208 ENDIF 4209 POS_BUF=0 4210 N2SEND=0 4211 RETURN 4212 END SUBROUTINE ZMUMPS_523 4213 END SUBROUTINE ZMUMPS_521 4214 SUBROUTINE ZMUMPS_812(NSLAVES, N, MYID, COMM, 4215 & RHS, LRHS, NRHS, KEEP, BUFFER, 4216 & SIZE_BUF, SIZE_BUF_BYTES, 4217 & LSCAL, SCALING, LSCALING, 4218 & IRHS_PTR_COPY, LIRHS_PTR_COPY, 4219 & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, 4220 & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, 4221 & UNS_PERM_INV, LUNS_PERM_INV, 4222 & POSINRHSCOMP_N, LPOS_N ) 4223 IMPLICIT NONE 4224 INCLUDE 'mpif.h' 4225 INCLUDE 'mumps_tags.h' 4226 INTEGER NSLAVES, N, MYID, COMM 4227 INTEGER NRHS, LRHS, LPOS_N 4228 COMPLEX(kind=8) RHS (LRHS, NRHS) 4229 INTEGER KEEP(500) 4230 INTEGER SIZE_BUF, SIZE_BUF_BYTES 4231 INTEGER BUFFER(SIZE_BUF) 4232 INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, 4233 & LRHS_SPARSE_COPY, LUNS_PERM_INV 4234 INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), 4235 & IRHS_PTR_COPY(LIRHS_PTR_COPY), 4236 & UNS_PERM_INV(LUNS_PERM_INV), 4237 & POSINRHSCOMP_N(LPOS_N) 4238 COMPLEX(kind=8) :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) 4239 LOGICAL, intent(in) :: LSCAL 4240 INTEGER, intent(in) :: LSCALING 4241 DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) 4242 INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC 4243 INTEGER I, II, J, MASTER, 4244 & TYPE_PARAL, N2RECV 4245 INTEGER STATUS(MPI_STATUS_SIZE), IERR 4246 PARAMETER(MASTER=0) 4247 LOGICAL I_AM_SLAVE 4248 INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 4249 INTEGER POS_BUF, N2SEND 4250 INTEGER, PARAMETER :: FIN = -1 4251 INCLUDE 'mumps_headers.h' 4252 TYPE_PARAL = KEEP(46) 4253 I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 4254 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 4255 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN 4256 K=1 4257 DO J = 1, NBCOL_INBLOC 4258 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) 4259 IF (COLSIZE.EQ.0) CYCLE 4260 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 4261 I = IRHS_SPARSE_COPY(IZ) 4262 IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) 4263 IF (POSINRHSCOMP_N(I).NE.0) THEN 4264 IF (LSCAL) THEN 4265 RHS_SPARSE_COPY(IZ)=RHS(I,K)*SCALING(I) 4266 ELSE 4267 RHS_SPARSE_COPY(IZ)=RHS(I,K) 4268 ENDIF 4269 ENDIF 4270 ENDDO 4271 K = K + 1 4272 ENDDO 4273 RETURN 4274 ENDIF 4275 IF (I_AM_SLAVE) THEN 4276 K=1 4277 DO J = 1, NBCOL_INBLOC 4278 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) 4279 IF (COLSIZE.EQ.0) CYCLE 4280 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 4281 I = IRHS_SPARSE_COPY(IZ) 4282 IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) 4283 IF (POSINRHSCOMP_N(I).NE.0) THEN 4284 RHS_SPARSE_COPY(IZ)=RHS(I,K) 4285 ENDIF 4286 ENDDO 4287 K = K + 1 4288 ENDDO 4289 ENDIF 4290 SIZE1=0 4291 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, 4292 & SIZE1, IERR) 4293 SIZE2=0 4294 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_COMPLEX, COMM, 4295 & SIZE2, IERR) 4296 RECORD_SIZE_P_1= SIZE1+SIZE2 4297 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN 4298 write(6,*) MYID, 4299 & ' Internal error 3 in ZMUMPS_812 ' 4300 write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', 4301 & RECORD_SIZE_P_1, SIZE_BUF_BYTES 4302 CALL MUMPS_ABORT() 4303 ENDIF 4304 N2SEND =0 4305 N2RECV =size(IRHS_SPARSE_COPY) 4306 POS_BUF =0 4307 IF (I_AM_SLAVE) THEN 4308 DO J = 1, NBCOL_INBLOC 4309 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) 4310 IF (COLSIZE.LE.0) CYCLE 4311 K = 0 4312 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 4313 I = IRHS_SPARSE_COPY(IZ) 4314 II = I 4315 IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) 4316 IF (POSINRHSCOMP_N(II).NE.0) THEN 4317 IF (MYID .EQ. MASTER) THEN 4318 N2RECV=N2RECV-1 4319 IF (LSCAL) 4320 & CALL ZMUMPS_813 ( .TRUE. ) 4321 IRHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = 4322 & I 4323 RHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = 4324 & RHS_SPARSE_COPY(IZ) 4325 K = K+1 4326 ELSE 4327 CALL ZMUMPS_813 ( .FALSE. ) 4328 ENDIF 4329 ENDIF 4330 ENDDO 4331 IF (MYID.EQ.MASTER) 4332 & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K 4333 ENDDO 4334 CALL ZMUMPS_814() 4335 ENDIF 4336 IF ( MYID .EQ. MASTER ) THEN 4337 DO WHILE (N2RECV .NE. 0) 4338 CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, 4339 & MPI_ANY_SOURCE, 4340 & GatherSol, COMM, STATUS, IERR ) 4341 POS_BUF = 0 4342 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, 4343 & J, 1, MPI_INTEGER, COMM, IERR) 4344 DO WHILE (J.NE.FIN) 4345 IZ = IRHS_PTR_COPY(J) 4346 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, 4347 & I, 1, MPI_INTEGER, COMM, IERR) 4348 IRHS_SPARSE_COPY(IZ) = I 4349 CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, 4350 & RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_COMPLEX, 4351 & COMM, IERR) 4352 IF (LSCAL) THEN 4353 IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) 4354 RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) 4355 ENDIF 4356 N2RECV=N2RECV-1 4357 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 4358 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, 4359 & J, 1, MPI_INTEGER, COMM, IERR) 4360 ENDDO 4361 ENDDO 4362 IPREV = 1 4363 DO J=1, size(IRHS_PTR_COPY)-1 4364 I= IRHS_PTR_COPY(J) 4365 IRHS_PTR_COPY(J) = IPREV 4366 IPREV = I 4367 ENDDO 4368 ENDIF 4369 RETURN 4370 CONTAINS 4371 SUBROUTINE ZMUMPS_813 ( SCALE_ONLY ) 4372 LOGICAL, intent(in) :: SCALE_ONLY 4373 INTEGER III 4374 IF (SCALE_ONLY) THEN 4375 III = I 4376 IF (KEEP(23).NE.0) III = UNS_PERM_INV(I) 4377 IF (LSCAL) THEN 4378 RHS_SPARSE_COPY(IZ)=RHS_SPARSE_COPY(IZ)*SCALING(III) 4379 ENDIF 4380 RETURN 4381 ENDIF 4382 CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, 4383 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) 4384 CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, 4385 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) 4386 CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_COMPLEX, 4387 & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, 4388 & IERR) 4389 N2SEND=N2SEND+1 4390 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN 4391 CALL ZMUMPS_814() 4392 END IF 4393 RETURN 4394 END SUBROUTINE ZMUMPS_813 4395 SUBROUTINE ZMUMPS_814() 4396 IF (N2SEND .NE. 0) THEN 4397 CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, 4398 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) 4399 CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, 4400 & GatherSol, COMM, IERR) 4401 ENDIF 4402 POS_BUF=0 4403 N2SEND=0 4404 RETURN 4405 END SUBROUTINE ZMUMPS_814 4406 END SUBROUTINE ZMUMPS_812 4407 SUBROUTINE ZMUMPS_535(MTYPE, ISOL_LOC, 4408 & PTRIST, KEEP,KEEP8, 4409 & IW, LIW_PASSED, MYID_NODES, N, STEP, 4410 & PROCNODE, NSLAVES, scaling_data, LSCAL) 4411 IMPLICIT NONE 4412 INTEGER MTYPE, MYID_NODES, N, NSLAVES 4413 INTEGER KEEP(500) 4414 INTEGER(8) KEEP8(150) 4415 INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) 4416 INTEGER ISOL_LOC(KEEP(89)) 4417 INTEGER LIW_PASSED 4418 INTEGER IW(LIW_PASSED) 4419 INTEGER STEP(N) 4420 LOGICAL LSCAL 4421 type scaling_data_t 4422 SEQUENCE 4423 DOUBLE PRECISION, dimension(:), pointer :: SCALING 4424 DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC 4425 end type scaling_data_t 4426 type (scaling_data_t) :: scaling_data 4427 INTEGER MUMPS_275 4428 EXTERNAL MUMPS_275 4429 INTEGER ISTEP, K 4430 INTEGER J1, IPOS, LIELL, NPIV, JJ 4431 INTEGER SK38,SK20 4432 INCLUDE 'mumps_headers.h' 4433 IF (KEEP(38).NE.0) THEN 4434 SK38=STEP(KEEP(38)) 4435 ELSE 4436 SK38=0 4437 ENDIF 4438 IF (KEEP(20).NE.0) THEN 4439 SK20=STEP(KEEP(20)) 4440 ELSE 4441 SK20=0 4442 ENDIF 4443 K=0 4444 DO ISTEP=1, KEEP(28) 4445 IF ( MYID_NODES == MUMPS_275( PROCNODE(ISTEP), 4446 & NSLAVES)) THEN 4447 IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN 4448 IPOS = PTRIST(ISTEP)+KEEP(IXSZ) 4449 LIELL = IW(IPOS+3) 4450 NPIV = LIELL 4451 IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) 4452 ELSE 4453 IPOS = PTRIST(ISTEP) + 2 + KEEP(IXSZ) 4454 LIELL = IW(IPOS-2)+IW(IPOS+1) 4455 IPOS= IPOS+1 4456 NPIV = IW(IPOS) 4457 IPOS= IPOS+1 4458 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 + KEEP(IXSZ)) 4459 END IF 4460 IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN 4461 J1=IPOS+1+LIELL 4462 ELSE 4463 J1=IPOS+1 4464 END IF 4465 DO JJ=J1,J1+NPIV-1 4466 K=K+1 4467 ISOL_LOC(K)=IW(JJ) 4468 IF (LSCAL) THEN 4469 scaling_data%SCALING_LOC(K)= 4470 & scaling_data%SCALING(IW(JJ)) 4471 ENDIF 4472 ENDDO 4473 ENDIF 4474 ENDDO 4475 RETURN 4476 END SUBROUTINE ZMUMPS_535 4477 SUBROUTINE ZMUMPS_532( 4478 & SLAVEF, N, MYID_NODES, 4479 & MTYPE, RHS, LD_RHS, NRHS, 4480 & ISOL_LOC, SOL_LOC, BEG_RHS, LSOL_LOC, 4481 & PTRIST, 4482 & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, 4483 & scaling_data, LSCAL, NB_RHSSKIPPED) 4484 IMPLICIT NONE 4485 INCLUDE 'mpif.h' 4486 INCLUDE 'mumps_tags.h' 4487 type scaling_data_t 4488 SEQUENCE 4489 DOUBLE PRECISION, dimension(:), pointer :: SCALING 4490 DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC 4491 end type scaling_data_t 4492 TYPE (scaling_data_t) :: scaling_data 4493 LOGICAL LSCAL 4494 INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NRHS, LD_RHS 4495 INTEGER LSOL_LOC, BEG_RHS, NB_RHSSKIPPED 4496 INTEGER ISOL_LOC(LSOL_LOC) 4497 COMPLEX(kind=8) SOL_LOC( LSOL_LOC, BEG_RHS+NRHS+NB_RHSSKIPPED-1) 4498 COMPLEX(kind=8) RHS( LD_RHS , NRHS) 4499 INTEGER KEEP(500) 4500 INTEGER(8) KEEP8(150) 4501 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) 4502 INTEGER IW(LIW), STEP(N) 4503 INTEGER JJ, J1, ISTEP, K, JEMPTY, JEND 4504 INTEGER IPOS, LIELL, NPIV 4505 LOGICAL ROOT 4506 COMPLEX(kind=8) ZERO 4507 PARAMETER( ZERO = (0.0D0,0.0D0) ) 4508 INCLUDE 'mumps_headers.h' 4509 INTEGER MUMPS_275 4510 EXTERNAL MUMPS_275 4511 K=0 4512 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 4513 JEND = BEG_RHS+NB_RHSSKIPPED+NRHS-1 4514 DO ISTEP = 1, KEEP(28) 4515 IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), 4516 & SLAVEF)) THEN 4517 ROOT=.false. 4518 IF (KEEP(38).ne.0) ROOT = STEP(KEEP(38))==ISTEP 4519 IF (KEEP(20).ne.0) ROOT = STEP(KEEP(20))==ISTEP 4520 IF ( ROOT ) THEN 4521 IPOS = PTRIST(ISTEP) + KEEP(IXSZ) 4522 LIELL = IW(IPOS+3) 4523 NPIV = LIELL 4524 IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) 4525 ELSE 4526 IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) 4527 LIELL = IW(IPOS-2)+IW(IPOS+1) 4528 IPOS= IPOS+1 4529 NPIV = IW(IPOS) 4530 IPOS= IPOS+1 4531 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) 4532 END IF 4533 IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN 4534 J1=IPOS+1+LIELL 4535 ELSE 4536 J1=IPOS+1 4537 END IF 4538 DO JJ=J1,J1+NPIV-1 4539 K=K+1 4540 IF (NB_RHSSKIPPED.GT.0) 4541 & SOL_LOC(K, BEG_RHS:JEMPTY) = ZERO 4542 IF (LSCAL) THEN 4543 SOL_LOC(K,JEMPTY+1:JEND) = 4544 & scaling_data%SCALING_LOC(K)*RHS(IW(JJ),1:NRHS) 4545 ELSE 4546 SOL_LOC(K,JEMPTY+1:JEND) = 4547 & RHS(IW(JJ),1:NRHS) 4548 ENDIF 4549 ENDDO 4550 ENDIF 4551 ENDDO 4552 RETURN 4553 END SUBROUTINE ZMUMPS_532 4554 SUBROUTINE ZMUMPS_638 4555 & (NSLAVES, N, MYID, COMM, 4556 & MTYPE, RHS, LRHS, NRHS, PTRIST, 4557 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, 4558 & POSINRHSCOMP, LENPOSINRHSCOMP, 4559 & BUILD_POSINRHSCOMP, ICNTL, INFO) 4560 IMPLICIT NONE 4561 INCLUDE 'mpif.h' 4562 INCLUDE 'mumps_tags.h' 4563 INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE 4564 INTEGER NRHS, LRHS, LENPOSINRHSCOMP 4565 INTEGER ICNTL(40), INFO(40) 4566 COMPLEX(kind=8) RHS (LRHS, NRHS) 4567 INTEGER KEEP(500) 4568 INTEGER(8) KEEP8(150) 4569 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) 4570 INTEGER IW(LIW), STEP(N), POSINRHSCOMP(LENPOSINRHSCOMP) 4571 LOGICAL BUILD_POSINRHSCOMP 4572 INTEGER BUF_MAXSIZE, BUF_MAXREF 4573 PARAMETER (BUF_MAXREF=200000) 4574 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX 4575 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS 4576 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE 4577 INTEGER INDX 4578 INTEGER allocok 4579 COMPLEX(kind=8) ZERO 4580 PARAMETER( ZERO = (0.0D0,0.0D0) ) 4581 INTEGER I, K, JJ, J1, ISTEP, MASTER, 4582 & MYID_NODES, TYPE_PARAL 4583 INTEGER LIELL, IPOS, NPIV 4584 INTEGER STATUS(MPI_STATUS_SIZE), IERR 4585 PARAMETER(MASTER=0) 4586 LOGICAL I_AM_SLAVE 4587 INTEGER SK38, SK20, IPOSINRHSCOMP 4588 INCLUDE 'mumps_headers.h' 4589 INTEGER MUMPS_275 4590 EXTERNAL MUMPS_275 4591 TYPE_PARAL = KEEP(46) 4592 IF (KEEP(38).NE.0) THEN 4593 SK38=STEP(KEEP(38)) 4594 ELSE 4595 SK38=0 4596 ENDIF 4597 IF (KEEP(20).NE.0) THEN 4598 SK20=STEP(KEEP(20)) 4599 ELSE 4600 SK20=0 4601 ENDIF 4602 I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 4603 IF ( TYPE_PARAL == 1 ) THEN 4604 MYID_NODES = MYID 4605 ELSE 4606 MYID_NODES = MYID-1 4607 ENDIF 4608 BUF_EFFSIZE = 0 4609 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) 4610 ALLOCATE (BUF_INDX(BUF_MAXSIZE), 4611 & BUF_RHS(NRHS,BUF_MAXSIZE), 4612 & stat=allocok) 4613 IF (allocok .GT. 0) THEN 4614 INFO(1)=-13 4615 INFO(2)=BUF_MAXSIZE*(NRHS+1) 4616 ENDIF 4617 CALL MUMPS_276(ICNTL, INFO, COMM, MYID ) 4618 IF (INFO(1).LT.0) RETURN 4619 IF (MYID.EQ.MASTER) THEN 4620 ENTRIES_2_PROCESS = N - KEEP(89) 4621 DO WHILE ( ENTRIES_2_PROCESS .NE. 0) 4622 CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, 4623 & MPI_ANY_SOURCE, 4624 & ScatterRhsI, COMM, STATUS, IERR ) 4625 CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, BUF_EFFSIZE, IERR ) 4626 PROC_WHO_ASKS = STATUS(MPI_SOURCE) 4627 DO I = 1, BUF_EFFSIZE 4628 INDX = BUF_INDX( I ) 4629 DO K = 1, NRHS 4630 BUF_RHS( K, I ) = RHS( INDX, K ) 4631 RHS( BUF_INDX(I), K ) = ZERO 4632 ENDDO 4633 ENDDO 4634 CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, 4635 & MPI_DOUBLE_COMPLEX, PROC_WHO_ASKS, 4636 & ScatterRhsR, COMM, IERR) 4637 ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE 4638 ENDDO 4639 BUF_EFFSIZE= 0 4640 ENDIF 4641 IF (I_AM_SLAVE) THEN 4642 IF (BUILD_POSINRHSCOMP) THEN 4643 IPOSINRHSCOMP = 1 4644 POSINRHSCOMP = -9678 4645 ENDIF 4646 IF (MYID.NE.MASTER) RHS = ZERO 4647 DO ISTEP = 1, KEEP(28) 4648 IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), 4649 & NSLAVES)) THEN 4650 IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN 4651 IPOS = PTRIST(ISTEP) 4652 LIELL = IW(IPOS+3+KEEP(IXSZ)) 4653 NPIV = LIELL 4654 IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) 4655 ELSE 4656 IPOS = PTRIST(ISTEP) + 2+ KEEP(IXSZ) 4657 LIELL = IW(IPOS-2)+IW(IPOS+1) 4658 IPOS= IPOS+1 4659 NPIV = IW(IPOS) 4660 IPOS= IPOS+1 4661 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) 4662 END IF 4663 IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN 4664 J1=IPOS+1 4665 ELSE 4666 J1=IPOS+1+LIELL 4667 END IF 4668 IF (BUILD_POSINRHSCOMP) THEN 4669 POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP 4670 IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV 4671 ENDIF 4672 IF (MYID.NE.MASTER) THEN 4673 DO JJ=J1,J1+NPIV-1 4674 BUF_EFFSIZE = BUF_EFFSIZE + 1 4675 BUF_INDX(BUF_EFFSIZE) = IW(JJ) 4676 IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN 4677 CALL ZMUMPS_640() 4678 ENDIF 4679 ENDDO 4680 ENDIF 4681 ENDIF 4682 ENDDO 4683 IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) 4684 & CALL ZMUMPS_640() 4685 ENDIF 4686 DEALLOCATE (BUF_INDX, BUF_RHS) 4687 RETURN 4688 CONTAINS 4689 SUBROUTINE ZMUMPS_640() 4690 CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, 4691 & MASTER, ScatterRhsI, COMM, IERR ) 4692 CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, 4693 & MPI_DOUBLE_COMPLEX, 4694 & MASTER, 4695 & ScatterRhsR, COMM, STATUS, IERR ) 4696 DO I = 1, BUF_EFFSIZE 4697 INDX = BUF_INDX(I) 4698 DO K = 1, NRHS 4699 RHS( INDX, K ) = BUF_RHS( K, I ) 4700 ENDDO 4701 ENDDO 4702 BUF_EFFSIZE = 0 4703 RETURN 4704 END SUBROUTINE ZMUMPS_640 4705 END SUBROUTINE ZMUMPS_638 4706 SUBROUTINE ZMUMPS_639 4707 & (NSLAVES, N, MYID_NODES, 4708 & PTRIST, 4709 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, 4710 & POSINRHSCOMP, POSINRHSCOMP_N, LPIRC_N, MTYPE, 4711 & WHAT ) 4712 IMPLICIT NONE 4713 INCLUDE 'mpif.h' 4714 INCLUDE 'mumps_tags.h' 4715 INTEGER NSLAVES, N, MYID_NODES, LIW 4716 INTEGER KEEP(500) 4717 INTEGER(8) KEEP8(150) 4718 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) 4719 INTEGER IW(LIW), STEP(N), POSINRHSCOMP(KEEP(28)) 4720 INTEGER LPIRC_N, WHAT, MTYPE 4721 INTEGER POSINRHSCOMP_N(LPIRC_N) 4722 INTEGER ISTEP 4723 INTEGER NPIV 4724 INTEGER SK38, SK20, IPOS, LIELL 4725 INTEGER JJ, J1 4726 INTEGER IPOSINRHSCOMP 4727 INCLUDE 'mumps_headers.h' 4728 INTEGER MUMPS_275 4729 EXTERNAL MUMPS_275 4730 IF (WHAT .NE. 0.AND. WHAT.NE.1.AND.WHAT.NE.2) THEN 4731 WRITE(*,*) "Internal error in ZMUMPS_639" 4732 CALL MUMPS_ABORT() 4733 ENDIF 4734 IF (KEEP(38).NE.0) THEN 4735 SK38=STEP(KEEP(38)) 4736 ELSE 4737 SK38=0 4738 ENDIF 4739 IF (KEEP(20).NE.0) THEN 4740 SK20=STEP(KEEP(20)) 4741 ELSE 4742 SK20=0 4743 ENDIF 4744 IPOSINRHSCOMP = 1 4745 POSINRHSCOMP = -9678 4746 IF (WHAT .NE. 0) THEN 4747 POSINRHSCOMP_N = 0 4748 ENDIF 4749 DO ISTEP = 1, KEEP(28) 4750 IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), 4751 & NSLAVES)) THEN 4752 IPOS = PTRIST(ISTEP) 4753 NPIV = IW(IPOS+3+KEEP(IXSZ)) 4754 POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP 4755 IF (WHAT .NE. 0) THEN 4756 IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN 4757 IPOS = PTRIST(ISTEP) 4758 LIELL = IW(IPOS+3+KEEP(IXSZ)) 4759 NPIV = LIELL 4760 IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) 4761 ELSE 4762 IPOS = PTRIST(ISTEP) + 2+ KEEP(IXSZ) 4763 LIELL = IW(IPOS-2)+IW(IPOS+1) 4764 IPOS= IPOS+1 4765 NPIV = IW(IPOS) 4766 IPOS= IPOS+1 4767 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) 4768 ENDIF 4769 IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN 4770 J1=IPOS+1 4771 ELSE 4772 J1=IPOS+1+LIELL 4773 END IF 4774 DO JJ = J1, J1+NPIV-1 4775 POSINRHSCOMP_N(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 4776 END DO 4777 ENDIF 4778 IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV 4779 ENDIF 4780 ENDDO 4781 RETURN 4782 END SUBROUTINE ZMUMPS_639 4783 SUBROUTINE ZMUMPS_248(N, A, LA, IW, LIW, WCB, LWCB, 4784 & RHS, LRHS, NRHS, 4785 & PTRICB, IWCB, LIWCB, 4786 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, BUILD_POSINRHSCOMP, 4787 & NE_STEPS, NA, LNA, STEP, 4788 & FRERE, DAD, FILS, 4789 & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, INFO, 4790 & KEEP,KEEP8, 4791 & PROCNODE_STEPS, 4792 & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, 4793 & RHS_ROOT, LRHS_ROOT, MTYPE, 4794 & 4795 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 4796 & ) 4797 USE ZMUMPS_OOC 4798 IMPLICIT NONE 4799 INTEGER MTYPE 4800 INTEGER(8) :: LA 4801 INTEGER N, LIW, LWCB, LPOOL, LIWCB, LNA 4802 INTEGER SLAVEF, MYLEAF, COMM, MYID 4803 INTEGER INFO( 40 ), KEEP(500) 4804 INTEGER(8) KEEP8(150) 4805 INTEGER PROCNODE_STEPS( KEEP(28) ) 4806 INTEGER LRHS, NRHS 4807 COMPLEX(kind=8) A( LA ), RHS( LRHS, NRHS ), WCB( LWCB ) 4808 INTEGER LRHS_ROOT 4809 COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) 4810 INTEGER LBUFR, LBUFR_BYTES 4811 INTEGER BUFR( LBUFR ) 4812 INTEGER NA( LNA ), NE_STEPS( KEEP(28) ) 4813 INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), 4814 & DAD( KEEP(28) ) 4815 INTEGER NSTK_S(KEEP(28)), IPOOL( LPOOL ) 4816 INTEGER PTRIST(KEEP(28)) 4817 INTEGER(8) :: PTRFAC(KEEP(28)) 4818 INTEGER PTRICB( KEEP(28) ) 4819 INTEGER IW( LIW ), IWCB( LIWCB ) 4820 INTEGER ISTEP_TO_INIV2(KEEP(71)), 4821 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 4822 INTEGER POSINRHSCOMP(KEEP(28)), LRHSCOMP 4823 LOGICAL BUILD_POSINRHSCOMP 4824 COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NRHS ) 4825 INCLUDE 'mpif.h' 4826 INCLUDE 'mumps_tags.h' 4827 INTEGER MSGTAG, MSGSOU, DUMMY(1) 4828 LOGICAL FLAG 4829 INTEGER NBFIN, MYROOT 4830 INTEGER POSIWCB,POSWCB,PLEFTWCB 4831 INTEGER INODE 4832 INTEGER RHSCOMPFREEPOS 4833 INTEGER I 4834 INTEGER III, NBROOT,LEAF 4835 LOGICAL BLOQ 4836 EXTERNAL MUMPS_275 4837 INTEGER MUMPS_275 4838 POSIWCB = LIWCB 4839 POSWCB = LWCB 4840 PLEFTWCB= 1 4841 IF (BUILD_POSINRHSCOMP) RHSCOMPFREEPOS= 1 4842 DO I = 1, KEEP(28) 4843 NSTK_S(I) = NE_STEPS(I) 4844 ENDDO 4845 PTRICB = 0 4846 CALL MUMPS_362(N, LEAF, NBROOT, MYROOT, MYID, 4847 & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, 4848 & PROCNODE_STEPS, IPOOL, LPOOL) 4849 NBFIN = SLAVEF 4850 IF ( MYROOT .EQ. 0 ) THEN 4851 NBFIN = NBFIN - 1 4852 DUMMY(1) = 1 4853 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, 4854 & RACINE_SOLVE, SLAVEF) 4855 END IF 4856 MYLEAF = LEAF - 1 4857 III = 1 4858 50 CONTINUE 4859 IF (SLAVEF .EQ. 1) THEN 4860 CALL ZMUMPS_574 4861 & ( IPOOL(1), LPOOL, III, LEAF, INODE, 4862 & KEEP(208) ) 4863 GOTO 60 4864 ENDIF 4865 BLOQ = ( ( III .EQ. LEAF ) 4866 & ) 4867 CALL ZMUMPS_303( BLOQ, FLAG, 4868 & BUFR, LBUFR, LBUFR_BYTES, 4869 & MYID, SLAVEF, COMM, 4870 & N, NRHS, IPOOL, LPOOL, III, LEAF, 4871 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 4872 & IWCB, LIWCB, 4873 & WCB, LWCB, POSWCB, 4874 & PLEFTWCB, POSIWCB, 4875 & PTRICB, INFO, KEEP,KEEP8, STEP, 4876 & PROCNODE_STEPS, 4877 & RHS, LRHS 4878 & ) 4879 IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 4880 IF (.not. FLAG) THEN 4881 IF (III .NE. LEAF) THEN 4882 CALL ZMUMPS_574 4883 & (IPOOL(1), LPOOL, III, LEAF, INODE, 4884 & KEEP(208) ) 4885 GOTO 60 4886 ENDIF 4887 ENDIF 4888 GOTO 50 4889 60 CONTINUE 4890 CALL ZMUMPS_302( INODE, BUFR, LBUFR, LBUFR_BYTES, 4891 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, N, 4892 & IPOOL, LPOOL, III, LEAF, NBFIN, NSTK_S, 4893 & IWCB, LIWCB, WCB, LWCB, A, LA, 4894 & IW, LIW, RHS, LRHS, NRHS, 4895 & POSWCB, PLEFTWCB, POSIWCB, 4896 & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, 4897 & FILS, STEP, FRERE, DAD, 4898 & MYROOT, INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, 4899 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, 4900 & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, 4901 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 4902 & ) 4903 IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 4904 GOTO 50 4905 260 CONTINUE 4906 CALL ZMUMPS_150( MYID,COMM,BUFR, 4907 & LBUFR,LBUFR_BYTES ) 4908 RETURN 4909 END SUBROUTINE ZMUMPS_248 4910 RECURSIVE SUBROUTINE ZMUMPS_323 4911 & ( BUFR, LBUFR, LBUFR_BYTES, 4912 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 4913 & N, NRHS, IPOOL, LPOOL, III, LEAF, 4914 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, 4915 & PTRFAC, IWCB, LIWCB, 4916 & WCB, LWCB, POSWCB, 4917 & PLEFTWCB, POSIWCB, 4918 & PTRICB, 4919 & INFO, KEEP,KEEP8, STEP, PROCNODE_STEPS, 4920 & RHS, LRHS 4921 & ) 4922 USE ZMUMPS_OOC 4923 USE ZMUMPS_COMM_BUFFER 4924 IMPLICIT NONE 4925 INTEGER LBUFR, LBUFR_BYTES 4926 INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM 4927 INTEGER LIW 4928 INTEGER(8) :: LA 4929 INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN 4930 INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB 4931 INTEGER INFO( 40 ), KEEP( 500) 4932 INTEGER(8) KEEP8(150) 4933 INTEGER BUFR( LBUFR ) 4934 INTEGER IPOOL( LPOOL ), NSTK_S( N ) 4935 INTEGER IWCB( LIWCB ) 4936 INTEGER IW( LIW ) 4937 INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) 4938 INTEGER(8) :: PTRFAC(KEEP(28)) 4939 INTEGER STEP(N) 4940 INTEGER PROCNODE_STEPS(KEEP(28)) 4941 COMPLEX(kind=8) WCB( LWCB ), A( LA ) 4942 INTEGER LRHS 4943 COMPLEX(kind=8) RHS(LRHS, NRHS) 4944 INCLUDE 'mpif.h' 4945 INCLUDE 'mumps_tags.h' 4946 INTEGER IERR, K, JJ 4947 INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV 4948 INTEGER PTRX, PTRY, PDEST, I 4949 INTEGER(8) :: APOS 4950 LOGICAL DUMMY 4951 LOGICAL FLAG 4952 EXTERNAL MUMPS_275 4953 INTEGER MUMPS_275 4954 COMPLEX(kind=8) ALPHA, ONE 4955 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 4956 INCLUDE 'mumps_headers.h' 4957 IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN 4958 NBFIN = NBFIN - 1 4959 IF ( NBFIN .eq. 0 ) GOTO 270 4960 ELSE IF (MSGTAG .EQ. ContVec ) THEN 4961 POSITION = 0 4962 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4963 & FINODE, 1, MPI_INTEGER, COMM, IERR ) 4964 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4965 & FPERE, 1, MPI_INTEGER, COMM, IERR ) 4966 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4967 & NCB, 1, MPI_INTEGER, COMM, IERR ) 4968 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4969 & LONG, 1, MPI_INTEGER, COMM, IERR ) 4970 IF ( NCB .eq. 0 ) THEN 4971 PTRICB(STEP(FINODE)) = -1 4972 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 4973 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN 4974 IPOOL( LEAF ) = FPERE 4975 LEAF = LEAF + 1 4976 IF ( LEAF > LPOOL ) THEN 4977 WRITE(*,*) 'Internal error 41r2 : Pool is too small.' 4978 CALL MUMPS_ABORT() 4979 END IF 4980 END IF 4981 ELSE 4982 IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN 4983 PTRICB(STEP(FINODE)) = NCB + 1 4984 END IF 4985 IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN 4986 INFO( 1 ) = -14 4987 INFO( 2 ) = LONG 4988 GOTO 260 4989 END IF 4990 IF ( POSWCB - PLEFTWCB + 1 .LT. LONG * NRHS) THEN 4991 INFO( 1 ) = -11 4992 INFO( 2 ) = PLEFTWCB - POSWCB - 1 + LONG * NRHS 4993 GOTO 260 4994 END IF 4995 IF (LONG .GT. 0) THEN 4996 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4997 & IWCB( 1 ), 4998 & LONG, MPI_INTEGER, COMM, IERR ) 4999 DO K = 1, NRHS 5000 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5001 & WCB( PLEFTWCB ), 5002 & LONG, MPI_DOUBLE_COMPLEX, COMM, IERR ) 5003 DO I = 1, LONG 5004 RHS(IWCB(I),K) = RHS(IWCB(I),K) +WCB(PLEFTWCB+I-1) 5005 ENDDO 5006 END DO 5007 PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG 5008 ENDIF 5009 IF ( PTRICB(STEP(FINODE)) == 1 ) THEN 5010 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 5011 END IF 5012 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN 5013 IPOOL( LEAF ) = FPERE 5014 LEAF = LEAF + 1 5015 IF ( LEAF > LPOOL ) THEN 5016 WRITE(*,*) 'Internal error 41r2 : Pool is too small.' 5017 CALL MUMPS_ABORT() 5018 END IF 5019 ENDIF 5020 END IF 5021 ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN 5022 POSITION = 0 5023 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5024 & FINODE, 1, MPI_INTEGER, COMM, IERR ) 5025 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5026 & FPERE, 1, MPI_INTEGER, COMM, IERR ) 5027 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5028 & NCV, 1, MPI_INTEGER, COMM, IERR ) 5029 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5030 & NPIV, 1, MPI_INTEGER, COMM, IERR ) 5031 PTRY = PLEFTWCB 5032 PTRX = PLEFTWCB + NCV * NRHS 5033 PLEFTWCB = PLEFTWCB + (NPIV + NCV) * NRHS 5034 IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN 5035 INFO(1) = -11 5036 INFO(2) = -POSWCB + PLEFTWCB -1 5037 GO TO 260 5038 END IF 5039 DO K=1, NRHS 5040 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5041 & WCB( PTRY + (K-1) * NCV ), NCV, 5042 & MPI_DOUBLE_COMPLEX, COMM, IERR ) 5043 ENDDO 5044 IF ( NPIV .GT. 0 ) THEN 5045 DO K=1, NRHS 5046 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 5047 & WCB( PTRX + (K-1)*NPIV ), NPIV, 5048 & MPI_DOUBLE_COMPLEX, COMM, IERR ) 5049 END DO 5050 END IF 5051 IF (KEEP(201).GT.0) THEN 5052 CALL ZMUMPS_643( 5053 & FINODE,PTRFAC,KEEP,A,LA,STEP, 5054 & KEEP8,N,DUMMY,IERR) 5055 IF(IERR.LT.0)THEN 5056 INFO(1)=IERR 5057 INFO(2)=0 5058 GOTO 260 5059 ENDIF 5060 ENDIF 5061 APOS = PTRFAC(STEP(FINODE)) 5062 IF (KEEP(201).EQ.1) THEN 5063 IF ( NRHS == 1 ) THEN 5064 CALL zgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, 5065 & WCB( PTRX ), 1, ONE, 5066 & WCB( PTRY ), 1 ) 5067 ELSE 5068 CALL zgemm( 'N', 'N', NCV, NRHS, NPIV, ALPHA, 5069 & A(APOS), NCV, 5070 & WCB( PTRX), NPIV, ONE, 5071 & WCB( PTRY), NCV ) 5072 ENDIF 5073 ELSE 5074 IF ( NRHS == 1 ) THEN 5075 CALL zgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, 5076 & WCB( PTRX ), 1, ONE, 5077 & WCB( PTRY ), 1 ) 5078 ELSE 5079 CALL zgemm( 'T', 'N', NCV, NRHS, NPIV, ALPHA, 5080 & A(APOS), NPIV, 5081 & WCB( PTRX), NPIV, ONE, 5082 & WCB( PTRY), NCV ) 5083 ENDIF 5084 ENDIF 5085 IF (KEEP(201).GT.0) THEN 5086 CALL ZMUMPS_598(FINODE,PTRFAC, 5087 & KEEP(28),A,LA,.TRUE.,IERR) 5088 IF(IERR.LT.0)THEN 5089 INFO(1)=IERR 5090 INFO(2)=0 5091 GOTO 260 5092 ENDIF 5093 ENDIF 5094 PLEFTWCB = PLEFTWCB - NPIV * NRHS 5095 PDEST = MUMPS_275( PROCNODE_STEPS(STEP(FPERE)), 5096 & SLAVEF ) 5097 IF ( PDEST .EQ. MYID ) THEN 5098 IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN 5099 NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) 5100 PTRICB(STEP(FINODE)) = NCB + 1 5101 END IF 5102 DO I = 1, NCV 5103 JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) 5104 DO K=1, NRHS 5105 RHS(JJ,K)= RHS(JJ,K) + WCB(PTRY+I-1+(K-1)*NCV) 5106 ENDDO 5107 END DO 5108 PTRICB(STEP(FINODE)) = 5109 & PTRICB(STEP(FINODE)) - NCV 5110 IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN 5111 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 5112 END IF 5113 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN 5114 IPOOL( LEAF ) = FPERE 5115 LEAF = LEAF + 1 5116 IF ( LEAF > LPOOL ) THEN 5117 WRITE(*,*) 'INTERNAL Error 41r: Pool is too small.' 5118 CALL MUMPS_ABORT() 5119 END IF 5120 ENDIF 5121 ELSE 5122 210 CONTINUE 5123 CALL ZMUMPS_78( NRHS, FINODE, FPERE, 5124 & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, 5125 & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), 5126 & WCB( PTRY ), PDEST, ContVec, COMM, IERR ) 5127 IF ( IERR .EQ. -1 ) THEN 5128 CALL ZMUMPS_303( .FALSE., FLAG, 5129 & BUFR, LBUFR, LBUFR_BYTES, 5130 & MYID, SLAVEF, COMM, 5131 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5132 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 5133 & IWCB, LIWCB, 5134 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 5135 & PTRICB, INFO, KEEP,KEEP8, STEP, 5136 & PROCNODE_STEPS, 5137 & RHS, LRHS 5138 & ) 5139 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 5140 GOTO 210 5141 ELSE IF ( IERR .EQ. -2 ) THEN 5142 INFO( 1 ) = -17 5143 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + 5144 & NCV * KEEP( 35 ) 5145 GOTO 260 5146 ELSE IF ( IERR .EQ. -3 ) THEN 5147 INFO( 1 ) = -20 5148 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + 5149 & NCV * KEEP( 35 ) 5150 END IF 5151 END IF 5152 PLEFTWCB = PLEFTWCB - NCV * NRHS 5153 ELSEIF ( MSGTAG .EQ. TERREUR ) THEN 5154 INFO(1) = -001 5155 INFO(2) = MSGSOU 5156 GOTO 270 5157 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. 5158 & (MSGTAG.EQ.TAG_DUMMY) ) THEN 5159 GO TO 270 5160 ELSE 5161 INFO(1)=-100 5162 INFO(2)=MSGTAG 5163 GO TO 260 5164 ENDIF 5165 GO TO 270 5166 260 CONTINUE 5167 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 5168 270 CONTINUE 5169 RETURN 5170 END SUBROUTINE ZMUMPS_323 5171 SUBROUTINE ZMUMPS_302( INODE, 5172 & BUFR, LBUFR, LBUFR_BYTES, 5173 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 5174 & N, IPOOL, LPOOL, III, LEAF, 5175 & NBFIN, NSTK_S, 5176 & IWCB, LIWCB, 5177 & WCB, LWCB, A, LA, IW, LIW, 5178 & RHS, LRHS, NRHS, POSWCB, 5179 & PLEFTWCB, POSIWCB, 5180 & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, 5181 & FILS, STEP, FRERE, DAD, 5182 & MYROOT, 5183 & INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, 5184 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, 5185 & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, 5186 & 5187 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 5188 & 5189 & ) 5190 USE ZMUMPS_OOC 5191 USE ZMUMPS_COMM_BUFFER 5192 IMPLICIT NONE 5193 INTEGER MTYPE 5194 INTEGER INODE, LBUFR, LBUFR_BYTES 5195 INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM 5196 INTEGER LIWCB, LWCB, LIW, POSWCB, PLEFTWCB, POSIWCB 5197 INTEGER(8) :: LA 5198 INTEGER N, LPOOL, III, LEAF, NBFIN 5199 INTEGER MYROOT 5200 INTEGER INFO( 40 ), KEEP( 500) 5201 INTEGER(8) KEEP8(150) 5202 INTEGER BUFR( LBUFR ) 5203 INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) 5204 INTEGER IWCB( LIWCB ), IW( LIW ) 5205 INTEGER LRHS, NRHS 5206 COMPLEX(kind=8) WCB( LWCB ), A( LA ) 5207 COMPLEX(kind=8) RHS(LRHS, NRHS ), RHS_ROOT( * ) 5208 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) 5209 INTEGER(8) :: PTRFAC(KEEP(28)) 5210 INTEGER PROCNODE_STEPS(KEEP(28)) 5211 INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) 5212 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5213 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5214 INTEGER POSINRHSCOMP(KEEP(28)), LRHSCOMP, RHSCOMPFREEPOS 5215 COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS) 5216 LOGICAL BUILD_POSINRHSCOMP 5217 EXTERNAL zgemv, ztrsv, zgemm, ztrsm, MUMPS_275 5218 INTEGER MUMPS_275 5219 COMPLEX(kind=8) ALPHA,ONE,ZERO 5220 PARAMETER (ZERO=(0.0D0,0.0D0), 5221 & ONE=(1.0D0,0.0D0), 5222 & ALPHA=(-1.0D0,0.0D0)) 5223 INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF 5224 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, 5225 & IERR, IFR_ini, 5226 & IFR, LIELL, JJ, 5227 & NELIM, PLEFT, PCB_COURANT, PPIV_COURANT 5228 INTEGER IPOSINRHSCOMP 5229 INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex 5230 LOGICAL FLAG, OMP_FLAG 5231 INCLUDE 'mumps_headers.h' 5232 INTEGER POSWCB1,POSWCB2 5233 INTEGER(8) :: APOSDEB 5234 INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, 5235 & JFIN, NBJ, NUPDATE_PANEL, 5236 & PPIV_PANEL, PCB_PANEL, NBK, TYPEF 5237 INTEGER LD_WCBPIV 5238 INTEGER LD_WCBCB 5239 INTEGER LDAJ, LDAJ_FIRST_PANEL 5240 INTEGER TMP_NBPANELS, 5241 & I_PIVRPTR, I_PIVR, IPANEL 5242 LOGICAL MUST_BE_PERMUTED 5243 INCLUDE 'mpif.h' 5244 INCLUDE 'mumps_tags.h' 5245 INTEGER DUMMY( 1 ) 5246 IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN 5247 LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) 5248 NPIV = LIELL 5249 NELIM = 0 5250 NSLAVES = 0 5251 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) 5252 ELSE 5253 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 5254 LIELL = IW(IPOS-2)+IW(IPOS+1) 5255 NELIM = IW(IPOS-1) 5256 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) 5257 IPOS = IPOS + 1 5258 NPIV = IW(IPOS) 5259 IPOS = IPOS + 1 5260 IF (KEEP(201).GT.0) THEN 5261 CALL ZMUMPS_643( 5262 & INODE,PTRFAC,KEEP,A,LA,STEP, 5263 & KEEP8,N,MUST_BE_PERMUTED,IERR) 5264 IF(IERR.LT.0)THEN 5265 INFO(1)=IERR 5266 INFO(2)=0 5267 GOTO 260 5268 ENDIF 5269 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 5270 CALL ZMUMPS_755( 5271 & IW(IPOS+1+2*LIELL+1+NSLAVES), 5272 & MUST_BE_PERMUTED ) 5273 ENDIF 5274 ENDIF 5275 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) 5276 IPOS = IPOS + 1 + NSLAVES 5277 END IF 5278 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 5279 J1 = IPOS + 1 5280 J2 = IPOS + LIELL 5281 J3 = IPOS + NPIV 5282 ELSE 5283 J1 = IPOS + LIELL + 1 5284 J2 = IPOS + 2 * LIELL 5285 J3 = IPOS + LIELL + NPIV 5286 END IF 5287 NCB = LIELL-NPIV 5288 IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN 5289 IFR = 0 5290 DO JJ = J1, J3 5291 J = IW( JJ ) 5292 IFR = IFR + 1 5293 DO K=1,NRHS 5294 RHS_ROOT(IFR+NPIV*(K-1)) = RHS(J,K) 5295 END DO 5296 END DO 5297 IF ( NPIV .LT. LIELL ) THEN 5298 WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' 5299 CALL MUMPS_ABORT() 5300 END IF 5301 MYROOT = MYROOT - 1 5302 IF ( MYROOT .EQ. 0 ) THEN 5303 NBFIN = NBFIN - 1 5304 IF (SLAVEF .GT. 1) THEN 5305 DUMMY (1) = 1 5306 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, 5307 & COMM, RACINE_SOLVE, SLAVEF) 5308 ENDIF 5309 END IF 5310 GO TO 270 5311 END IF 5312 APOS = PTRFAC(STEP(INODE)) 5313 IF (KEEP(201).EQ.1) THEN 5314 IF (MTYPE.EQ.1) THEN 5315 IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN 5316 TempNROW= NPIV+NELIM 5317 TempNCOL= NPIV 5318 LDAJ_FIRST_PANEL=TempNROW 5319 ELSE 5320 TempNROW= LIELL 5321 TempNCOL= NPIV 5322 LDAJ_FIRST_PANEL=TempNROW 5323 ENDIF 5324 TYPEF=TYPEF_L 5325 ELSE 5326 TempNCOL= LIELL 5327 TempNROW= NPIV 5328 LDAJ_FIRST_PANEL=TempNCOL 5329 TYPEF= TYPEF_U 5330 ENDIF 5331 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 5332 PANEL_SIZE = ZMUMPS_690( LDAJ_FIRST_PANEL ) 5333 ENDIF 5334 PLEFT = PLEFTWCB 5335 PPIV_COURANT = PLEFTWCB 5336 PLEFTWCB = PLEFTWCB + LIELL * NRHS 5337 IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN 5338 INFO(1) = -11 5339 INFO(2) = PLEFTWCB - POSWCB - 1 5340 GO TO 260 5341 END IF 5342 IF (KEEP(201).EQ.1) THEN 5343 LD_WCBPIV = LIELL 5344 LD_WCBCB = LIELL 5345 PCB_COURANT = PPIV_COURANT + NPIV 5346 DO K=1, NRHS 5347 IFR = PPIV_COURANT + (K-1)*LIELL - 1 5348 DO JJ = J1, J3 5349 J = IW(JJ) 5350 IFR = IFR + 1 5351 WCB(IFR) = RHS(J,K) 5352 ENDDO 5353 IF (NCB.GT.0) THEN 5354 DO JJ = J3+1, J2 5355 J = IW(JJ) 5356 IFR = IFR + 1 5357 WCB(IFR) = RHS(J,K) 5358 RHS (J,K) = ZERO 5359 ENDDO 5360 ENDIF 5361 END DO 5362 ELSE 5363 LD_WCBPIV = NPIV 5364 LD_WCBCB = NCB 5365 PCB_COURANT = PPIV_COURANT + NPIV*NRHS 5366 IFR = PPIV_COURANT - 1 5367 OMP_FLAG = NRHS.GT.4 5368 IFR_ini = IFR 5369 DO 130 JJ = J1, J3 5370 J = IW(JJ) 5371 IFR = IFR_ini + (JJ-J1) + 1 5372 DO K=1, NRHS 5373 WCB(IFR+(K-1)*NPIV) = RHS(J,K) 5374 END DO 5375 130 CONTINUE 5376 IFR = PCB_COURANT - 1 5377 IF (NPIV .LT. LIELL) THEN 5378 IFR_ini = IFR 5379 DO 140 JJ = J3 + 1, J2 5380 J = IW(JJ) 5381 IFR = IFR_ini + (JJ-J3) 5382 DO K=1, NRHS 5383 WCB(IFR+(K-1)*NCB) = RHS(J,K) 5384 RHS(J,K)=ZERO 5385 ENDDO 5386 140 CONTINUE 5387 ENDIF 5388 ENDIF 5389 IF ( NPIV .NE. 0 ) THEN 5390 IF (KEEP(201).EQ.1) THEN 5391 APOSDEB = APOS 5392 J = 1 5393 IPANEL = 0 5394 10 CONTINUE 5395 IPANEL = IPANEL + 1 5396 JFIN = min(J+PANEL_SIZE-1, NPIV) 5397 IF (IW(IPOS+ LIELL + JFIN) < 0) THEN 5398 JFIN=JFIN+1 5399 ENDIF 5400 NBJ = JFIN-J+1 5401 LDAJ = LDAJ_FIRST_PANEL-J+1 5402 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN 5403 CALL ZMUMPS_667(TYPEF, TMP_NBPANELS, 5404 & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) 5405 IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN 5406 MUST_BE_PERMUTED=.FALSE. 5407 ELSE 5408 CALL ZMUMPS_698( 5409 & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- 5410 & IW(I_PIVRPTR)), 5411 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 5412 & IW(I_PIVRPTR+IPANEL-1)-1, 5413 & 5414 & A(APOSDEB), 5415 & LDAJ, NBJ, J-1 ) 5416 ENDIF 5417 ENDIF 5418 NUPDATE_PANEL = LDAJ - NBJ 5419 PPIV_PANEL = PPIV_COURANT+J-1 5420 PCB_PANEL = PPIV_PANEL+NBJ 5421 APOS1 = APOSDEB+int(NBJ,8) 5422 IF (MTYPE.EQ.1) THEN 5423 IF ( NRHS == 1 ) THEN 5424 CALL ztrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, 5425 & WCB(PPIV_PANEL), 1 ) 5426 IF (NUPDATE_PANEL.GT.0) THEN 5427 CALL zgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), 5428 & LDAJ, WCB(PPIV_PANEL), 1, ONE, 5429 & WCB(PCB_PANEL), 1) 5430 ENDIF 5431 ELSE 5432 CALL ztrsm( 'L','L','N','U', NBJ, NRHS, ONE, 5433 & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), 5434 & LIELL ) 5435 IF (NUPDATE_PANEL.GT.0) THEN 5436 CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, 5437 & ALPHA, 5438 & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, 5439 & WCB(PCB_PANEL), LIELL) 5440 ENDIF 5441 ENDIF 5442 ELSE 5443 IF (NRHS == 1) THEN 5444 CALL ztrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, 5445 & WCB(PPIV_PANEL), 1 ) 5446 IF (NUPDATE_PANEL.GT.0) THEN 5447 CALL zgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), 5448 & LDAJ, WCB(PPIV_PANEL), 1, 5449 & ONE, WCB(PCB_PANEL), 1 ) 5450 ENDIF 5451 ELSE 5452 CALL ztrsm('L','L','N','N',NBJ, NRHS, ONE, 5453 & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), 5454 & LIELL) 5455 IF (NUPDATE_PANEL.GT.0) THEN 5456 CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, 5457 & ALPHA, 5458 & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, 5459 & WCB(PCB_PANEL), LIELL) 5460 ENDIF 5461 ENDIF 5462 ENDIF 5463 APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) 5464 J=JFIN+1 5465 IF ( J .LE. NPIV ) GOTO 10 5466 ELSE 5467 IF (KEEP(50).NE.0) THEN 5468 IF ( NRHS == 1 ) THEN 5469 CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, 5470 & WCB(PPIV_COURANT), 1 ) 5471 ELSE 5472 CALL ztrsm( 'L','U','T','U', NPIV, NRHS, ONE, 5473 & A(APOS), NPIV, WCB(PPIV_COURANT), 5474 & NPIV ) 5475 ENDIF 5476 ELSE 5477 IF ( MTYPE .eq. 1 ) THEN 5478 IF ( NRHS == 1) THEN 5479 CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, 5480 & WCB(PPIV_COURANT), 1 ) 5481 ELSE 5482 CALL ztrsm( 'L','U','T','U', NPIV, NRHS, ONE, 5483 & A(APOS), LIELL, WCB(PPIV_COURANT), 5484 & NPIV ) 5485 ENDIF 5486 ELSE 5487 IF (NRHS == 1) THEN 5488 CALL ztrsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, 5489 & WCB(PPIV_COURANT), 1 ) 5490 ELSE 5491 CALL ztrsm('L','L','N','N',NPIV, NRHS, ONE, 5492 & A(APOS), LIELL, WCB(PPIV_COURANT), 5493 & NPIV) 5494 ENDIF 5495 END IF 5496 END IF 5497 END IF 5498 END IF 5499 NCB = LIELL - NPIV 5500 IF ( MTYPE .EQ. 1 ) THEN 5501 IF ( KEEP(50) .eq. 0 ) THEN 5502 APOS1 = APOS + int(NPIV,8) * int(LIELL,8) 5503 ELSE 5504 APOS1 = APOS + int(NPIV,8) * int(NPIV,8) 5505 END IF 5506 IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN 5507 NUPDATE = NCB 5508 ELSE 5509 NUPDATE = NELIM 5510 END IF 5511 ELSE 5512 APOS1 = APOS + int(NPIV,8) 5513 NUPDATE = NCB 5514 END IF 5515 IF (KEEP(201).NE.1) THEN 5516 IF ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN 5517 IF ( MTYPE .eq. 1 ) THEN 5518 IF ( NRHS == 1 ) THEN 5519 CALL zgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), 5520 & NPIV, WCB(PPIV_COURANT), 1, ONE, 5521 & WCB(PCB_COURANT), 1) 5522 ELSE 5523 CALL zgemm('T', 'N', NUPDATE, NRHS, NPIV, ALPHA, 5524 & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, 5525 & WCB(PCB_COURANT), NCB) 5526 END IF 5527 ELSE 5528 IF ( NRHS == 1 ) THEN 5529 CALL zgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), 5530 & LIELL, WCB(PPIV_COURANT), 1, 5531 & ONE, WCB(PCB_COURANT), 1 ) 5532 ELSE 5533 CALL zgemm('N', 'N', NUPDATE, NRHS, NPIV, ALPHA, 5534 & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, 5535 & WCB(PCB_COURANT), NCB) 5536 END IF 5537 END IF 5538 END IF 5539 END IF 5540 IF (BUILD_POSINRHSCOMP) THEN 5541 POSINRHSCOMP(STEP(INODE)) = RHSCOMPFREEPOS 5542 RHSCOMPFREEPOS = RHSCOMPFREEPOS + NPIV 5543 ENDIF 5544 IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 5545 IF ( KEEP(50) .eq. 0 ) THEN 5546 DO K=1,NRHS 5547 IFR = PPIV_COURANT + (K-1)*LD_WCBPIV 5548 RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = 5549 & WCB(IFR:IFR+NPIV-1) 5550 ENDDO 5551 ELSE 5552 IFR = PPIV_COURANT - 1 5553 IF (KEEP(201).EQ.1) THEN 5554 LDAJ = TempNROW 5555 ELSE 5556 LDAJ = NPIV 5557 ENDIF 5558 APOS1 = APOS 5559 JJ = J1 5560 IF (KEEP(201).EQ.1) THEN 5561 NBK = 0 5562 ENDIF 5563 DO 5564 IF(JJ .GT. J3) EXIT 5565 IFR = IFR + 1 5566 IF(IW(JJ+LIELL) .GT. 0) THEN 5567 DO K=1, NRHS 5568 RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = 5569 & WCB( IFR+(K-1)*LD_WCBPIV ) * A( APOS1 ) 5570 END DO 5571 IF (KEEP(201).EQ.1) THEN 5572 NBK = NBK+1 5573 IF (NBK.EQ.PANEL_SIZE) THEN 5574 NBK = 0 5575 LDAJ = LDAJ - PANEL_SIZE 5576 ENDIF 5577 ENDIF 5578 APOS1 = APOS1 + int(LDAJ + 1,8) 5579 JJ = JJ+1 5580 ELSE 5581 IF (KEEP(201).EQ.1) THEN 5582 NBK = NBK+1 5583 ENDIF 5584 APOS2 = APOS1+int(LDAJ+1,8) 5585 IF (KEEP(201).EQ.1) THEN 5586 APOSOFF = APOS1+int(LDAJ,8) 5587 ELSE 5588 APOSOFF=APOS1+1_8 5589 ENDIF 5590 DO K=1, NRHS 5591 POSWCB1 = IFR+(K-1)*LD_WCBPIV 5592 POSWCB2 = POSWCB1+1 5593 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = WCB(POSWCB1)*A(APOS1) 5594 & + WCB(POSWCB2)*A(APOSOFF) 5595 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = 5596 & WCB(POSWCB1)*A(APOSOFF) 5597 & + WCB(POSWCB2)*A(APOS2) 5598 END DO 5599 IF (KEEP(201).EQ.1) THEN 5600 NBK = NBK+1 5601 IF (NBK.GE.PANEL_SIZE) THEN 5602 LDAJ = LDAJ - NBK 5603 NBK = 0 5604 ENDIF 5605 ENDIF 5606 APOS1 = APOS2 + int(LDAJ + 1,8) 5607 JJ = JJ+2 5608 IFR = IFR+1 5609 ENDIF 5610 ENDDO 5611 END IF 5612 IF (KEEP(201).GT.0) THEN 5613 CALL ZMUMPS_598(INODE,PTRFAC,KEEP(28), 5614 & A,LA,.TRUE.,IERR) 5615 IF(IERR.LT.0)THEN 5616 INFO(1)=IERR 5617 INFO(2)=0 5618 GOTO 260 5619 ENDIF 5620 END IF 5621 FPERE = DAD(STEP(INODE)) 5622 IF ( FPERE .EQ. 0 ) THEN 5623 MYROOT = MYROOT - 1 5624 PLEFTWCB = PLEFTWCB - LIELL *NRHS 5625 IF ( MYROOT .EQ. 0 ) THEN 5626 NBFIN = NBFIN - 1 5627 IF (SLAVEF .GT. 1) THEN 5628 DUMMY (1) = 1 5629 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, 5630 & COMM, RACINE_SOLVE, SLAVEF) 5631 ENDIF 5632 END IF 5633 GO TO 270 5634 ENDIF 5635 IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN 5636 IF (MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), 5637 & SLAVEF) .EQ. MYID) THEN 5638 IF ( NCB .ne. 0 ) THEN 5639 PTRICB(STEP(INODE)) = NCB + 1 5640 DO 190 I = 1, NUPDATE 5641 DO K=1, NRHS 5642 RHS( IW(J3 + I), K ) = RHS( IW(J3 + I), K ) 5643 & + WCB(PCB_COURANT + I-1 +(K-1)*LD_WCBCB) 5644 ENDDO 5645 190 CONTINUE 5646 PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE 5647 IF ( PTRICB(STEP(INODE)) == 1 ) THEN 5648 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 5649 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN 5650 IPOOL( LEAF ) = FPERE 5651 LEAF = LEAF + 1 5652 ENDIF 5653 END IF 5654 ELSE 5655 PTRICB(STEP( INODE )) = -1 5656 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 5657 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN 5658 IPOOL( LEAF ) = FPERE 5659 LEAF = LEAF + 1 5660 ENDIF 5661 ENDIF 5662 ELSE 5663 210 CONTINUE 5664 CALL ZMUMPS_78( NRHS, INODE, FPERE, NCB, LD_WCBCB, 5665 & NUPDATE, 5666 & IW( J3 + 1 ), WCB( PCB_COURANT ), 5667 & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), 5668 & ContVec, 5669 & COMM, IERR ) 5670 IF ( IERR .EQ. -1 ) THEN 5671 CALL ZMUMPS_303( .FALSE., FLAG, 5672 & BUFR, LBUFR, LBUFR_BYTES, 5673 & MYID, SLAVEF, COMM, 5674 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5675 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 5676 & IWCB, LIWCB, 5677 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 5678 & PTRICB, INFO, KEEP,KEEP8, STEP, 5679 & PROCNODE_STEPS, 5680 & RHS, LRHS 5681 & ) 5682 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 5683 GOTO 210 5684 ELSE IF ( IERR .EQ. -2 ) THEN 5685 INFO( 1 ) = -17 5686 INFO( 2 ) = NUPDATE * KEEP( 35 ) + 5687 & ( NUPDATE + 3 ) * KEEP( 34 ) 5688 GOTO 260 5689 ELSE IF ( IERR .EQ. -3 ) THEN 5690 INFO( 1 ) = -20 5691 INFO( 2 ) = NUPDATE * KEEP( 35 ) + 5692 & ( NUPDATE + 3 ) * KEEP( 34 ) 5693 GOTO 260 5694 END IF 5695 ENDIF 5696 END IF 5697 IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 5698 & .and. NPIV .NE. 0 ) THEN 5699 DO ISLAVE = 1, NSLAVES 5700 PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) 5701 CALL MUMPS_49( 5702 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 5703 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 5704 & ISLAVE, NCB - NELIM, 5705 & NSLAVES, 5706 & Effective_CB_Size, FirstIndex ) 5707 222 CALL ZMUMPS_72( NRHS, 5708 & INODE, FPERE, 5709 & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, 5710 & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), 5711 & WCB( PPIV_COURANT ), 5712 & PDEST, COMM, IERR ) 5713 IF ( IERR .EQ. -1 ) THEN 5714 CALL ZMUMPS_303( .FALSE., FLAG, 5715 & BUFR, LBUFR, LBUFR_BYTES, 5716 & MYID, SLAVEF, COMM, 5717 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5718 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, 5719 & IWCB, LIWCB, 5720 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 5721 & PTRICB, INFO, KEEP,KEEP8, STEP, 5722 & PROCNODE_STEPS, 5723 & RHS, LRHS 5724 & ) 5725 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 5726 GOTO 222 5727 ELSE IF ( IERR .EQ. -2 ) THEN 5728 INFO( 1 ) = -17 5729 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + 5730 & ( Effective_CB_Size + 4 ) * KEEP( 34 ) 5731 GOTO 260 5732 ELSE IF ( IERR .EQ. -3 ) THEN 5733 INFO( 1 ) = -20 5734 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + 5735 & ( Effective_CB_Size + 4 ) * KEEP( 34 ) 5736 GOTO 260 5737 END IF 5738 END DO 5739 END IF 5740 PLEFTWCB = PLEFTWCB - LIELL*NRHS 5741 270 CONTINUE 5742 RETURN 5743 260 CONTINUE 5744 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 5745 RETURN 5746 END SUBROUTINE ZMUMPS_302 5747 RECURSIVE SUBROUTINE ZMUMPS_303( BLOQ, FLAG, 5748 & BUFR, LBUFR, LBUFR_BYTES, 5749 & MYID, SLAVEF, COMM, 5750 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5751 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, 5752 & IWCB, LIWCB, 5753 & WCB, LWCB, POSWCB, 5754 & PLEFTWCB, POSIWCB, 5755 & PTRICB, INFO, KEEP,KEEP8, STEP, PROCNODE_STEPS, 5756 & RHS, LRHS 5757 & ) 5758 IMPLICIT NONE 5759 LOGICAL BLOQ 5760 INTEGER LBUFR, LBUFR_BYTES 5761 INTEGER MYID, SLAVEF, COMM 5762 INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN 5763 INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB 5764 INTEGER LIW 5765 INTEGER(8) :: LA 5766 INTEGER INFO( 40 ), KEEP( 500) 5767 INTEGER(8) KEEP8(150) 5768 INTEGER BUFR( LBUFR ), IPOOL(LPOOL) 5769 INTEGER NSTK_S( KEEP(28) ) 5770 INTEGER IWCB( LIWCB ) 5771 INTEGER IW( LIW ) 5772 COMPLEX(kind=8) WCB( LWCB ), A( LA ) 5773 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) 5774 INTEGER(8) :: PTRFAC(KEEP(28)) 5775 INTEGER STEP(N) 5776 INTEGER PROCNODE_STEPS(KEEP(28)) 5777 INTEGER LRHS 5778 COMPLEX(kind=8) RHS(LRHS, NRHS) 5779 LOGICAL FLAG 5780 INCLUDE 'mpif.h' 5781 INCLUDE 'mumps_tags.h' 5782 INTEGER IERR, STATUS( MPI_STATUS_SIZE ) 5783 INTEGER MSGSOU, MSGTAG, MSGLEN 5784 FLAG = .FALSE. 5785 IF ( BLOQ ) THEN 5786 CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 5787 & COMM, STATUS, IERR ) 5788 FLAG = .TRUE. 5789 ELSE 5790 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 5791 & FLAG, STATUS, IERR ) 5792 END IF 5793 IF ( FLAG ) THEN 5794 MSGSOU = STATUS( MPI_SOURCE ) 5795 MSGTAG = STATUS( MPI_TAG ) 5796 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 5797 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 5798 INFO(1) = -20 5799 INFO(2) = MSGLEN 5800 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 5801 ELSE 5802 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, 5803 & MSGSOU, MSGTAG, COMM, STATUS, IERR ) 5804 CALL ZMUMPS_323( BUFR, LBUFR, LBUFR_BYTES, 5805 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 5806 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5807 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 5808 & IWCB, LIWCB, 5809 & WCB, LWCB, POSWCB, 5810 & PLEFTWCB, POSIWCB, 5811 & PTRICB, INFO, KEEP,KEEP8, STEP, 5812 & PROCNODE_STEPS, 5813 & RHS, LRHS 5814 & ) 5815 END IF 5816 END IF 5817 RETURN 5818 END SUBROUTINE ZMUMPS_303 5819 SUBROUTINE ZMUMPS_249(N, A, LA, IW, LIW, W, LWC, 5820 & RHS, LRHS, NRHS, 5821 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, 5822 & PTRICB, PTRACB, IWCB, LIWW, W2, 5823 & NE_STEPS, NA, LNA, STEP, 5824 & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, 5825 & MYLEAF, INFO, 5826 & PROCNODE_STEPS, 5827 & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, 5828 & KEEP,KEEP8, RHS_ROOT, LRHS_ROOT, MTYPE, 5829 & 5830 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS 5831 & , TO_PROCESS, SIZE_TO_PROCESS 5832 & ) 5833 USE ZMUMPS_OOC 5834 USE ZMUMPS_COMM_BUFFER 5835 IMPLICIT NONE 5836 INTEGER MTYPE 5837 INTEGER(8) :: LA 5838 INTEGER N,LIW,LIWW,LWC,LPOOL,LNA 5839 INTEGER SLAVEF,MYLEAF,COMM,MYID 5840 INTEGER LPANEL_POS 5841 INTEGER KEEP( 500 ) 5842 INTEGER(8) KEEP8(150) 5843 INTEGER PROCNODE_STEPS(KEEP(28)) 5844 INTEGER NA(LNA),NE_STEPS(KEEP(28)) 5845 INTEGER IPOOL(LPOOL) 5846 INTEGER PANEL_POS(LPANEL_POS) 5847 INTEGER INFO(40) 5848 INTEGER PTRIST(KEEP(28)), 5849 & PTRICB(KEEP(28)),PTRACB(KEEP(28)) 5850 INTEGER(8) :: PTRFAC(KEEP(28)) 5851 INTEGER LRHS, NRHS 5852 COMPLEX(kind=8) A(LA), RHS(LRHS,NRHS), W(LWC) 5853 COMPLEX(kind=8) W2(KEEP(133)) 5854 INTEGER IW(LIW),IWCB(LIWW) 5855 INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) 5856 INTEGER LBUFR, LBUFR_BYTES 5857 INTEGER BUFR(LBUFR) 5858 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5859 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5860 INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) 5861 COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) 5862 INTEGER LRHS_ROOT 5863 COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) 5864 INTEGER, intent(in) :: SIZE_TO_PROCESS 5865 LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) 5866 INTEGER MUMPS_275 5867 EXTERNAL MUMPS_275 5868 INCLUDE 'mpif.h' 5869 INCLUDE 'mumps_tags.h' 5870 INTEGER IERR 5871 LOGICAL FLAG 5872 INTEGER POSIWCB,POSWCB,K 5873 INTEGER(8) :: APOS, IST 5874 INTEGER NPIV 5875 INTEGER IPOS,LIELL,NELIM,IFR,JJ,I 5876 INTEGER J1,J2,J,NCB,NBFINF 5877 INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS 5878 INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP 5879 INTEGER III,IIPOOL,MYLEAFE 5880 INTEGER NSLAVES 5881 COMPLEX(kind=8) ALPHA,ONE,ZERO 5882 PARAMETER (ZERO=(0.0D0,0.0D0), 5883 & ONE=(1.0D0,0.0D0), 5884 & ALPHA=(-1.0D0,0.0D0)) 5885 LOGICAL BLOQ,DEBUT 5886 INTEGER PROCDEST, DEST 5887 INTEGER POSINDICES, IPOSINRHSCOMP 5888 INTEGER DUMMY(1) 5889 INTEGER PLEFTW, PTWCB 5890 INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex 5891 LOGICAL LTLEVEL2, IN_SUBTREE 5892 INTEGER TYPENODE 5893 INCLUDE 'mumps_headers.h' 5894 LOGICAL BLOCK_SEQUENCE 5895 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR 5896 LOGICAL MUST_BE_PERMUTED 5897 LOGICAL NO_CHILDREN 5898 LOGICAL Exploit_Sparsity, AM1 5899 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) 5900 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS 5901 INTEGER LDAJ, NBJ, LIWFAC, 5902 & NBJLAST, NPIV_LAST, PANEL_SIZE, 5903 & PTWCB_PANEL, NCB_PANEL, TYPEF 5904 INTEGER BEG_PANEL 5905 LOGICAL TWOBYTWO 5906 INTEGER NPANELS, IPANEL 5907 LOGICAL MUMPS_170 5908 INTEGER MUMPS_330 5909 EXTERNAL zgemv, ztrsv, ztrsm, zgemm, 5910 & MUMPS_330, 5911 & MUMPS_170 5912 PLEFTW = 1 5913 POSIWCB = LIWW 5914 POSWCB = LWC 5915 NROOT = 0 5916 NBLEAF = NA(1) 5917 NBROOT = NA(2) 5918 DO I = NBROOT, 1, -1 5919 INODE = NA(NBLEAF+I+2) 5920 IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)), 5921 & SLAVEF) .EQ. MYID) THEN 5922 NROOT = NROOT + 1 5923 IPOOL(NROOT) = INODE 5924 ENDIF 5925 END DO 5926 III = 1 5927 IIPOOL = NROOT + 1 5928 BLOCK_SEQUENCE = .FALSE. 5929 Exploit_Sparsity = .FALSE. 5930 AM1 = .FALSE. 5931 IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. 5932 IF (KEEP(237).NE.0) AM1 = .TRUE. 5933 NO_CHILDREN = .FALSE. 5934 IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 5935 IF (MYLEAF .EQ. -1) THEN 5936 MYLEAF = 0 5937 DO I=1, NBLEAF 5938 INODE=NA(I+2) 5939 IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)), 5940 & SLAVEF) .EQ. MYID) THEN 5941 MYLEAF = MYLEAF + 1 5942 ENDIF 5943 ENDDO 5944 ENDIF 5945 MYLEAFE=MYLEAF 5946 NBFINF = SLAVEF 5947 IF (MYLEAFE .EQ. 0) THEN 5948 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, 5949 & SLAVEF) 5950 NBFINF = NBFINF - 1 5951 IF (NBFINF .EQ. 0) THEN 5952 GOTO 340 5953 ENDIF 5954 ENDIF 5955 50 CONTINUE 5956 BLOQ = ( ( III .EQ. IIPOOL ) 5957 & ) 5958 CALL ZMUMPS_41( BLOQ, FLAG, BUFR, LBUFR, 5959 & LBUFR_BYTES, MYID, SLAVEF, COMM, 5960 & N, IWCB, LIWW, POSIWCB, 5961 & W, LWC, POSWCB, 5962 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 5963 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 5964 & STEP, FRERE, FILS, PROCNODE_STEPS, 5965 & PLEFTW, KEEP,KEEP8, 5966 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 5967 & RHS, LRHS, NRHS, MTYPE, 5968 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 5969 & , TO_PROCESS, SIZE_TO_PROCESS 5970 & ) 5971 IF ( INFO(1) .LT. 0 ) GOTO 340 5972 IF ( .NOT. FLAG ) THEN 5973 IF (III .NE. IIPOOL) THEN 5974 INODE = IPOOL(IIPOOL-1) 5975 IIPOOL = IIPOOL - 1 5976 GO TO 60 5977 ENDIF 5978 END IF 5979 IF ( NBFINF .eq. 0 ) GOTO 340 5980 GOTO 50 5981 60 CONTINUE 5982 IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN 5983 IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) 5984 NPIV = IW(IPOS+3) 5985 LIELL = IW(IPOS) + NPIV 5986 IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) 5987 IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN 5988 J1 = IPOS + LIELL + 1 5989 J2 = IPOS + LIELL + NPIV 5990 ELSE 5991 J1 = IPOS + 1 5992 J2 = IPOS + NPIV 5993 END IF 5994 IFR = 0 5995 DO JJ = J1, J2 5996 J = IW( JJ ) 5997 IFR = IFR + 1 5998 DO K=1,NRHS 5999 RHS(J,K) = RHS_ROOT(IFR+NPIV*(K-1)) 6000 END DO 6001 END DO 6002 IN = INODE 6003 270 IN = FILS(IN) 6004 IF (IN .GT. 0) GOTO 270 6005 IF (IN .EQ. 0) THEN 6006 MYLEAFE = MYLEAFE - 1 6007 IF (MYLEAFE .EQ. 0) THEN 6008 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6009 & FEUILLE, SLAVEF ) 6010 NBFINF = NBFINF - 1 6011 IF (NBFINF .EQ. 0) GOTO 340 6012 ENDIF 6013 GOTO 50 6014 ENDIF 6015 IF = -IN 6016 LONG = NPIV 6017 NBFILS = NE_STEPS(STEP(INODE)) 6018 IF ( AM1 ) THEN 6019 I = NBFILS 6020 NBFILS = 0 6021 DO WHILE (I.GT.0) 6022 IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 6023 IF = FRERE(STEP(IF)) 6024 I = I -1 6025 ENDDO 6026 IF (NBFILS.EQ.0) THEN 6027 NO_CHILDREN = .TRUE. 6028 ELSE 6029 NO_CHILDREN = .FALSE. 6030 ENDIF 6031 IF = -IN 6032 ENDIF 6033 DEBUT = .TRUE. 6034 DO I = 0, SLAVEF - 1 6035 DEJA_SEND( I ) = .FALSE. 6036 END DO 6037 POOL_FIRST_POS=IIPOOL 6038 DO I = 1, NBFILS 6039 IF ( AM1 ) THEN 6040 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 6041 IF = FRERE(STEP(IF)) 6042 GOTO 1030 6043 ENDIF 6044 NO_CHILDREN = .FALSE. 6045 ENDIF 6046 IF (MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) 6047 & .EQ. MYID) THEN 6048 IPOOL(IIPOOL) = IF 6049 IIPOOL = IIPOOL + 1 6050 ELSE 6051 PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)), 6052 & SLAVEF) 6053 IF (.NOT. DEJA_SEND( PROCDEST )) THEN 6054 600 CALL ZMUMPS_78( NRHS, IF, 0, 0, 6055 & LONG, LONG, IW( J1 ), 6056 & RHS_ROOT( 1 ), PROCDEST, 6057 & NOEUD, COMM, IERR ) 6058 IF ( IERR .EQ. -1 ) THEN 6059 CALL ZMUMPS_41( 6060 & .FALSE., FLAG, 6061 & BUFR, LBUFR, LBUFR_BYTES, 6062 & MYID, SLAVEF, COMM, 6063 & N, IWCB, LIWW, POSIWCB, 6064 & W, LWC, POSWCB, 6065 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6066 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6067 & STEP, FRERE, FILS, PROCNODE_STEPS, 6068 & PLEFTW, KEEP,KEEP8, 6069 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6070 & RHS, LRHS, NRHS, MTYPE, 6071 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6072 & , TO_PROCESS, SIZE_TO_PROCESS 6073 & ) 6074 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 6075 GOTO 600 6076 ELSE IF ( IERR .EQ. -2 ) THEN 6077 INFO( 1 ) = -17 6078 INFO( 2 ) = LONG * KEEP(35) + 6079 & ( LONG + 2 ) * KEEP(34) 6080 GOTO 330 6081 ELSE IF ( IERR .EQ. -3 ) THEN 6082 INFO( 1 ) = -20 6083 INFO( 2 ) = LONG * KEEP(35) + 6084 & ( LONG + 2 ) * KEEP(34) 6085 GOTO 330 6086 END IF 6087 DEJA_SEND( PROCDEST ) = .TRUE. 6088 END IF 6089 IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() 6090 ENDIF 6091 IF = FRERE(STEP(IF)) 6092 ENDDO 6093 IF (AM1 .AND.NO_CHILDREN) THEN 6094 MYLEAFE = MYLEAFE - 1 6095 IF (MYLEAFE .EQ. 0) THEN 6096 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6097 & FEUILLE, SLAVEF ) 6098 NBFINF = NBFINF - 1 6099 IF (NBFINF .EQ. 0) GOTO 340 6100 GOTO 50 6101 ENDIF 6102 ENDIF 6103 IF (IIPOOL.NE.POOL_FIRST_POS) THEN 6104 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 6105 TMP=IPOOL(POOL_FIRST_POS+I-1) 6106 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 6107 IPOOL(IIPOOL-I)=TMP 6108 ENDDO 6109 ENDIF 6110 GOTO 50 6111 END IF 6112 IN_SUBTREE = MUMPS_170( 6113 & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 6114 TYPENODE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)), 6115 & SLAVEF) 6116 LTLEVEL2= ( 6117 & (TYPENODE .eq.2 ) .AND. 6118 & (MTYPE.NE.1) ) 6119 NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) 6120 IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN 6121 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 6122 LIELL = IW(IPOS-2)+IW(IPOS+1) 6123 NELIM = IW(IPOS-1) 6124 IPOS = IPOS + 1 6125 NPIV = IW(IPOS) 6126 NCB = LIELL - NPIV - NELIM 6127 IPOS = IPOS + 2 6128 NSLAVES = IW( IPOS ) 6129 Offset = 0 6130 IPOS = IPOS + NSLAVES 6131 IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES 6132 IF ( POSIWCB - 2 .LT. 0 .or. 6133 & POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN 6134 CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, 6135 & POSWCB, POSIWCB, PTRICB, PTRACB) 6136 IF ( POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN 6137 INFO( 1 ) = -11 6138 INFO( 2 ) = NCB * NRHS - POSWCB - PLEFTW + 1 6139 GOTO 330 6140 END IF 6141 IF ( POSIWCB - 2 .LT. 0 ) THEN 6142 INFO( 1 ) = -14 6143 INFO( 2 ) = 2 - POSIWCB 6144 GO TO 330 6145 END IF 6146 END IF 6147 POSIWCB = POSIWCB - 2 6148 POSWCB = POSWCB - NCB*NRHS 6149 PTRICB(STEP( INODE )) = POSIWCB + 1 6150 PTRACB(STEP( INODE )) = POSWCB + 1 6151 IWCB( PTRICB(STEP( INODE )) ) = NCB 6152 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 6153 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 6154 POSINDICES = IPOS + LIELL + 1 6155 ELSE 6156 POSINDICES = IPOS + 1 6157 END IF 6158 IF ( NCB.EQ.0 ) THEN 6159 write(6,*) ' Internal Error type 2 node with no CB ' 6160 CALL MUMPS_ABORT() 6161 ENDIF 6162 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 6163 J1 = IPOS + LIELL + NPIV + NELIM +1 6164 J2 = IPOS + 2 * LIELL 6165 ELSE 6166 J1 = IPOS + NPIV + NELIM +1 6167 J2 = IPOS + LIELL 6168 END IF 6169 IFR = PTRACB(STEP( INODE )) - 1 6170 DO JJ = J1, J2 - KEEP(253) 6171 J = IW(JJ) 6172 IFR = IFR + 1 6173 DO K=1, NRHS 6174 W(IFR+(K-1)*NCB) = RHS(J,K) 6175 ENDDO 6176 ENDDO 6177 IF (KEEP(252).NE.0) THEN 6178 DO JJ = J2-KEEP(253)+1, J2 6179 IFR = IFR + 1 6180 DO K=1, NRHS 6181 IF (K.EQ.JJ-J2+KEEP(253)) THEN 6182 W(IFR+(K-1)*NCB) = ALPHA 6183 ELSE 6184 W(IFR+(K-1)*NCB) = ZERO 6185 ENDIF 6186 ENDDO 6187 ENDDO 6188 ENDIF 6189 DO ISLAVE = 1, NSLAVES 6190 CALL MUMPS_49( 6191 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 6192 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 6193 & ISLAVE, NCB, 6194 & NSLAVES, 6195 & EffectiveSize, 6196 & FirstIndex ) 6197 500 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) 6198 CALL ZMUMPS_63(NRHS, INODE, 6199 & W(Offset+PTRACB(STEP(INODE))), EffectiveSize, 6200 & NCB, DEST, 6201 & BACKSLV_MASTER2SLAVE, 6202 & COMM, IERR ) 6203 IF ( IERR .EQ. -1 ) THEN 6204 CALL ZMUMPS_41( 6205 & .FALSE., FLAG, 6206 & BUFR, LBUFR, LBUFR_BYTES, 6207 & MYID, SLAVEF, COMM, 6208 & N, IWCB, LIWW, POSIWCB, 6209 & W, LWC, POSWCB, 6210 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6211 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6212 & STEP, FRERE, FILS, 6213 & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 6214 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6215 & RHS, LRHS, NRHS, MTYPE, 6216 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6217 & , TO_PROCESS, SIZE_TO_PROCESS 6218 & ) 6219 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 6220 GOTO 500 6221 ELSE IF ( IERR .EQ. -2 ) THEN 6222 INFO( 1 ) = -17 6223 INFO( 2 ) = EffectiveSize * KEEP(35) + 6224 & 2 * KEEP(34) 6225 GOTO 330 6226 ELSE IF ( IERR .EQ. -3 ) THEN 6227 INFO( 1 ) = -20 6228 INFO( 2 ) = EffectiveSize * KEEP(35) + 6229 & 2 * KEEP(34) 6230 GOTO 330 6231 END IF 6232 Offset = Offset + EffectiveSize 6233 END DO 6234 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 6235 CALL ZMUMPS_151(NRHS,N, KEEP(28), IWCB, LIWW, W, LWC, 6236 & POSWCB,POSIWCB,PTRICB,PTRACB) 6237 GOTO 50 6238 ENDIF 6239 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 6240 LIELL = IW(IPOS-2)+IW(IPOS+1) 6241 NELIM = IW(IPOS-1) 6242 IPOS = IPOS + 1 6243 NPIV = IW(IPOS) 6244 IPOS = IPOS + 1 6245 IF (KEEP(201).GT.0) THEN 6246 CALL ZMUMPS_643( 6247 & INODE,PTRFAC,KEEP,A,LA,STEP, 6248 & KEEP8,N,MUST_BE_PERMUTED,IERR) 6249 IF(IERR.LT.0)THEN 6250 INFO(1)=IERR 6251 INFO(2)=0 6252 GOTO 330 6253 ENDIF 6254 ENDIF 6255 APOS = PTRFAC(IW(IPOS)) 6256 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) 6257 IPOS = IPOS + 1 + NSLAVES 6258 IF (KEEP(201).EQ.1) THEN 6259 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 6260 IF (MTYPE.NE.1) THEN 6261 TYPEF = TYPEF_L 6262 ELSE 6263 TYPEF = TYPEF_U 6264 ENDIF 6265 PANEL_SIZE = ZMUMPS_690( LIELL ) 6266 IF (KEEP(50).NE.1) THEN 6267 CALL ZMUMPS_755( 6268 & IW(IPOS+1+2*LIELL), 6269 & MUST_BE_PERMUTED ) 6270 ENDIF 6271 ENDIF 6272 LONG = 0 6273 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 6274 J1 = IPOS + 1 6275 J2 = IPOS + NPIV 6276 ELSE 6277 J1 = IPOS + LIELL + 1 6278 J2 = IPOS + NPIV + LIELL 6279 END IF 6280 IF (IN_SUBTREE) THEN 6281 PTWCB = PLEFTW 6282 IF ( POSWCB .LT. LIELL*NRHS ) THEN 6283 CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, 6284 & POSWCB, POSIWCB, PTRICB, PTRACB) 6285 IF ( POSWCB .LT. LIELL*NRHS ) THEN 6286 INFO(1) = -11 6287 INFO(2) = LIELL*NRHS - POSWCB 6288 GOTO 330 6289 END IF 6290 END IF 6291 ELSE 6292 IF ( POSIWCB - 2 .LT. 0 .or. 6293 & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 6294 CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, 6295 & POSWCB, POSIWCB, PTRICB, PTRACB) 6296 IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 6297 INFO( 1 ) = -11 6298 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 6299 GOTO 330 6300 END IF 6301 IF ( POSIWCB - 2 .LT. 0 ) THEN 6302 INFO( 1 ) = -14 6303 INFO( 2 ) = 2 - POSIWCB 6304 GO TO 330 6305 END IF 6306 END IF 6307 POSIWCB = POSIWCB - 2 6308 POSWCB = POSWCB - LIELL*NRHS 6309 PTRICB(STEP( INODE )) = POSIWCB + 1 6310 PTRACB(STEP( INODE )) = POSWCB + 1 6311 IWCB( PTRICB(STEP( INODE )) ) = LIELL 6312 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 6313 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 6314 POSINDICES = IPOS + LIELL + 1 6315 ELSE 6316 POSINDICES = IPOS + 1 6317 END IF 6318 PTWCB = PTRACB(STEP( INODE )) 6319 ENDIF 6320 IF (KEEP(252).EQ.0) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 6321 DO K=1, NRHS 6322 IF (KEEP(252).NE.0) THEN 6323 DO JJ = J1, J2 6324 W(PTWCB+JJ-J1+(K-1)*LIELL) = ZERO 6325 ENDDO 6326 ELSE 6327 DO JJ = J1, J2 6328 W(PTWCB+JJ-J1+(K-1)*LIELL) = RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 6329 ENDDO 6330 ENDIF 6331 END DO 6332 IFR = PTWCB + NPIV - 1 6333 IF ( LIELL .GT. NPIV ) THEN 6334 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 6335 J1 = IPOS + LIELL + NPIV + 1 6336 J2 = IPOS + 2 * LIELL 6337 ELSE 6338 J1 = IPOS + NPIV + 1 6339 J2 = IPOS + LIELL 6340 END IF 6341 DO JJ = J1, J2-KEEP(253) 6342 J = IW(JJ) 6343 IFR = IFR + 1 6344 DO K=1, NRHS 6345 W(IFR+(K-1)*LIELL) = RHS(J,K) 6346 ENDDO 6347 ENDDO 6348 IF (KEEP(252).NE.0) THEN 6349 DO JJ = J2-KEEP(253)+1, J2 6350 IFR = IFR + 1 6351 DO K=1, NRHS 6352 IF (K.EQ.JJ-J2+KEEP(253)) THEN 6353 W(IFR+(K-1)*LIELL) = ALPHA 6354 ELSE 6355 W(IFR+(K-1)*LIELL) = ZERO 6356 ENDIF 6357 ENDDO 6358 ENDDO 6359 ENDIF 6360 NCB = LIELL - NPIV 6361 IF (NPIV .EQ. 0) GOTO 160 6362 ENDIF 6363 IF (KEEP(201).EQ.1) THEN 6364 J = NPIV / PANEL_SIZE 6365 TWOBYTWO = KEEP(50).EQ.2 .AND. 6366 & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. 6367 & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) 6368 IF (TWOBYTWO) THEN 6369 CALL ZMUMPS_641(PANEL_SIZE, PANEL_POS, LPANEL_POS, 6370 & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, 6371 & NBENTRIES_ALLPANELS) 6372 ELSE 6373 IF (NPIV.EQ.J*PANEL_SIZE) THEN 6374 NPIV_LAST = NPIV 6375 NBJLAST = PANEL_SIZE 6376 NPANELS = J 6377 ELSE 6378 NPIV_LAST = (J+1)* PANEL_SIZE 6379 NBJLAST = NPIV-J*PANEL_SIZE 6380 NPANELS = J+1 6381 ENDIF 6382 NBENTRIES_ALLPANELS = 6383 & int(LIELL,8) * int(NPIV,8) 6384 & - int( ( J * ( J - 1 ) ) / 2,8 ) 6385 & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) 6386 & - int(J,8) 6387 & * int(mod(NPIV, PANEL_SIZE),8) 6388 & * int(PANEL_SIZE,8) 6389 JJ=NPIV_LAST 6390 ENDIF 6391 APOSDEB = APOS + NBENTRIES_ALLPANELS 6392 DO IPANEL = NPANELS, 1, -1 6393 IF (TWOBYTWO) THEN 6394 NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) 6395 BEG_PANEL = PANEL_POS(IPANEL) 6396 ELSE 6397 IF (JJ.EQ.NPIV_LAST) THEN 6398 NBJ = NBJLAST 6399 ELSE 6400 NBJ = PANEL_SIZE 6401 ENDIF 6402 BEG_PANEL = JJ- PANEL_SIZE+1 6403 ENDIF 6404 LDAJ = LIELL-BEG_PANEL+1 6405 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) 6406 PTWCB_PANEL = PTWCB + BEG_PANEL - 1 6407 NCB_PANEL = LDAJ - NBJ 6408 IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN 6409 CALL ZMUMPS_667(TYPEF, TMP_NBPANELS, 6410 & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) 6411 IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN 6412 MUST_BE_PERMUTED=.FALSE. 6413 ELSE 6414 CALL ZMUMPS_698( 6415 & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), 6416 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 6417 & IW(I_PIVRPTR+IPANEL-1)-1, 6418 & A(APOSDEB), 6419 & LDAJ, NBJ, BEG_PANEL-1) 6420 ENDIF 6421 ENDIF 6422 IF ( NRHS == 1 ) THEN 6423 IF (NCB_PANEL.NE.0) THEN 6424 CALL zgemv( 'T', NCB_PANEL, NBJ, ALPHA, 6425 & A( APOSDEB + int(NBJ,8) ), LDAJ, 6426 & W( NBJ + PTWCB_PANEL ), 6427 & 1, ONE, 6428 & W(PTWCB_PANEL), 1 ) 6429 ENDIF 6430 IF (MTYPE.NE.1) THEN 6431 CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 6432 & W(PTWCB_PANEL), 1) 6433 ELSE 6434 CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, 6435 & W(PTWCB_PANEL), 1) 6436 ENDIF 6437 ELSE 6438 IF (NCB_PANEL.NE.0) THEN 6439 CALL zgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, 6440 & A(APOSDEB +int(NBJ,8)), LDAJ, 6441 & W(NBJ+PTWCB_PANEL),LIELL, 6442 & ONE, W(PTWCB_PANEL),LIELL) 6443 ENDIF 6444 IF (MTYPE.NE.1) THEN 6445 CALL ztrsm('L','L','T','U',NBJ, NRHS, ONE, 6446 & A(APOSDEB), 6447 & LDAJ, W(PTWCB_PANEL), LIELL) 6448 ELSE 6449 CALL ztrsm('L','L','T','N',NBJ, NRHS, ONE, 6450 & A(APOSDEB), 6451 & LDAJ, W(PTWCB_PANEL), LIELL) 6452 ENDIF 6453 ENDIF 6454 IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 6455 ENDDO 6456 ENDIF 6457 IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 6458 IF ( LIELL .GT. NPIV ) THEN 6459 IF ( MTYPE .eq. 1 ) THEN 6460 IST = APOS + int(NPIV,8) 6461 IF (NRHS == 1) THEN 6462 CALL zgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, 6463 & W(NPIV + PTWCB), 1, 6464 & ONE, 6465 & W(PTWCB), 1 ) 6466 ELSE 6467 CALL zgemm('T','N', NPIV, NRHS, NCB, ALPHA, A(IST), LIELL, 6468 & W(NPIV+PTWCB), LIELL, ONE, 6469 & W(PTWCB), LIELL) 6470 ENDIF 6471 ELSE 6472 IF ( KEEP(50) .eq. 0 ) THEN 6473 IST = APOS + int(NPIV,8) * int(LIELL,8) 6474 ELSE 6475 IST = APOS + int(NPIV,8) * int(NPIV,8) 6476 END IF 6477 IF ( NRHS == 1 ) THEN 6478 CALL zgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, 6479 & W( NPIV + PTWCB ), 6480 & 1, ONE, 6481 & W(PTWCB), 1 ) 6482 ELSE 6483 CALL zgemm( 'N', 'N', NPIV, NRHS, NCB, ALPHA, 6484 & A(IST), NPIV, W(NPIV+PTWCB),LIELL, 6485 & ONE, W(PTWCB),LIELL) 6486 END IF 6487 END IF 6488 ENDIF 6489 IF ( MTYPE .eq. 1 ) THEN 6490 IF ( NRHS == 1 ) THEN 6491 CALL ztrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, 6492 & W(PTWCB), 1) 6493 ELSE 6494 CALL ztrsm('L','L','T','N', NPIV, NRHS, ONE, A(APOS), 6495 & LIELL, W(PTWCB), LIELL) 6496 ENDIF 6497 ELSE 6498 IF ( KEEP(50) .EQ. 0 ) THEN 6499 IF ( NRHS == 1 ) THEN 6500 CALL ztrsv('U','N','U', NPIV, A(APOS), LIELL, 6501 & W(PTWCB), 1) 6502 ELSE 6503 CALL ztrsm('L','U','N','U', NPIV, NRHS, ONE, A(APOS), 6504 & LIELL,W(PTWCB),LIELL) 6505 END IF 6506 ELSE 6507 IF ( NRHS == 1 ) THEN 6508 CALL ztrsv('U','N','U', NPIV, A(APOS), NPIV, 6509 & W(PTWCB), 1) 6510 ELSE 6511 CALL ztrsm('L','U','N','U',NPIV, NRHS, ONE, A(APOS), 6512 & NPIV, W(PTWCB), LIELL) 6513 END IF 6514 END IF 6515 END IF 6516 ENDIF 6517 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN 6518 J1 = IPOS + LIELL + 1 6519 ELSE 6520 J1 = IPOS + 1 6521 END IF 6522 DO 150 I = 1, NPIV 6523 JJ = IW(J1 + I - 1) 6524 DO K=1, NRHS 6525 RHS(JJ, K) = W(PTWCB+I-1+(K-1)*LIELL) 6526 ENDDO 6527 150 CONTINUE 6528 160 CONTINUE 6529 IF (KEEP(201).GT.0) THEN 6530 CALL ZMUMPS_598(INODE,PTRFAC,KEEP(28), 6531 & A,LA,.TRUE.,IERR) 6532 IF(IERR.LT.0)THEN 6533 INFO(1)=IERR 6534 INFO(2)=0 6535 GOTO 330 6536 ENDIF 6537 ENDIF 6538 IN = INODE 6539 170 IN = FILS(IN) 6540 IF (IN .GT. 0) GOTO 170 6541 IF (IN .EQ. 0) THEN 6542 MYLEAFE = MYLEAFE - 1 6543 IF (MYLEAFE .EQ. 0) THEN 6544 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6545 & FEUILLE, SLAVEF ) 6546 NBFINF = NBFINF - 1 6547 IF (NBFINF .EQ. 0) GOTO 340 6548 ENDIF 6549 GOTO 50 6550 ENDIF 6551 IF = -IN 6552 NBFILS = NE_STEPS(STEP(INODE)) 6553 IF (AM1) THEN 6554 I = NBFILS 6555 NBFILS = 0 6556 DO WHILE (I.GT.0) 6557 IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 6558 IF = FRERE(STEP(IF)) 6559 I = I -1 6560 ENDDO 6561 IF (NBFILS.EQ.0) THEN 6562 NO_CHILDREN = .TRUE. 6563 ELSE 6564 NO_CHILDREN = .FALSE. 6565 ENDIF 6566 IF = -IN 6567 ENDIF 6568 IF (IN_SUBTREE) THEN 6569 DO I = 1, NBFILS 6570 IF ( AM1 ) THEN 6571 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 6572 IF = FRERE(STEP(IF)) 6573 GOTO 1010 6574 ENDIF 6575 NO_CHILDREN = .FALSE. 6576 ENDIF 6577 IPOOL((IIPOOL-I+1)+NBFILS-I) = IF 6578 IIPOOL = IIPOOL + 1 6579 IF = FRERE(STEP(IF)) 6580 ENDDO 6581 IF (AM1 .AND. NO_CHILDREN) THEN 6582 MYLEAFE = MYLEAFE - 1 6583 IF (MYLEAFE .EQ. 0) THEN 6584 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6585 & FEUILLE, SLAVEF ) 6586 NBFINF = NBFINF - 1 6587 IF (NBFINF .EQ. 0) GOTO 340 6588 GOTO 50 6589 ENDIF 6590 ENDIF 6591 ELSE 6592 DEBUT = .TRUE. 6593 DO I = 0, SLAVEF - 1 6594 DEJA_SEND( I ) = .FALSE. 6595 END DO 6596 POOL_FIRST_POS=IIPOOL 6597 DO 190 I = 1, NBFILS 6598 IF ( AM1 ) THEN 65991020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 6600 IF = FRERE(STEP(IF)) 6601 GOTO 1020 6602 ENDIF 6603 NO_CHILDREN = .FALSE. 6604 ENDIF 6605 IF (MUMPS_275(PROCNODE_STEPS(STEP(IF)), 6606 & SLAVEF) .EQ. MYID) THEN 6607 IPOOL(IIPOOL) = IF 6608 IIPOOL = IIPOOL + 1 6609 IF = FRERE(STEP(IF)) 6610 ELSE 6611 PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) 6612 IF (.not. DEJA_SEND( PROCDEST )) THEN 6613 400 CONTINUE 6614 CALL ZMUMPS_78( NRHS, IF, 0, 0, LIELL, 6615 & LIELL - KEEP(253), 6616 & IW( POSINDICES ), 6617 & W ( PTRACB(STEP( INODE ))), PROCDEST, 6618 & NOEUD, COMM, IERR ) 6619 IF ( IERR .EQ. -1 ) THEN 6620 CALL ZMUMPS_41( 6621 & .FALSE., FLAG, 6622 & BUFR, LBUFR, LBUFR_BYTES, 6623 & MYID, SLAVEF, COMM, 6624 & N, IWCB, LIWW, POSIWCB, 6625 & W, LWC, POSWCB, 6626 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6627 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6628 & STEP, FRERE, FILS, PROCNODE_STEPS, 6629 & PLEFTW, KEEP,KEEP8, 6630 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6631 & RHS, LRHS, NRHS, MTYPE, 6632 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6633 & , TO_PROCESS, SIZE_TO_PROCESS 6634 & ) 6635 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 6636 GOTO 400 6637 ELSE IF ( IERR .EQ. -2 ) THEN 6638 INFO( 1 ) = -17 6639 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 6640 GOTO 330 6641 ELSE IF ( IERR .EQ. -3 ) THEN 6642 INFO( 1 ) = -20 6643 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 6644 GOTO 330 6645 END IF 6646 DEJA_SEND( PROCDEST ) = .TRUE. 6647 END IF 6648 IF = FRERE(STEP(IF)) 6649 ENDIF 6650 190 CONTINUE 6651 IF (AM1 .AND. NO_CHILDREN) THEN 6652 MYLEAFE = MYLEAFE - 1 6653 IF (MYLEAFE .EQ. 0) THEN 6654 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6655 & FEUILLE, SLAVEF ) 6656 NBFINF = NBFINF - 1 6657 IF (NBFINF .EQ. 0) GOTO 340 6658 GOTO 50 6659 ENDIF 6660 ENDIF 6661 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 6662 TMP=IPOOL(POOL_FIRST_POS+I-1) 6663 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 6664 IPOOL(IIPOOL-I)=TMP 6665 ENDDO 6666 IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 6667 CALL ZMUMPS_151(NRHS,N, KEEP(28), IWCB, LIWW, 6668 & W, LWC, 6669 & POSWCB,POSIWCB,PTRICB,PTRACB) 6670 ENDIF 6671 GOTO 50 6672 330 CONTINUE 6673 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, 6674 & SLAVEF) 6675 340 CONTINUE 6676 CALL ZMUMPS_150( MYID,COMM,BUFR, 6677 & LBUFR,LBUFR_BYTES ) 6678 RETURN 6679 END SUBROUTINE ZMUMPS_249 6680 RECURSIVE SUBROUTINE ZMUMPS_41( 6681 & BLOQ, FLAG, 6682 & BUFR, LBUFR, LBUFR_BYTES, 6683 & MYID, SLAVEF, COMM, 6684 & N, IWCB, LIWW, POSIWCB, 6685 & W, LWC, POSWCB, 6686 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6687 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6688 & STEP, FRERE, FILS, PROCNODE_STEPS, 6689 & PLEFTW, KEEP,KEEP8, 6690 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, RHS, 6691 & LRHS, NRHS, MTYPE, 6692 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6693 & , TO_PROCESS, SIZE_TO_PROCESS 6694 & ) 6695 IMPLICIT NONE 6696 LOGICAL BLOQ, FLAG 6697 INTEGER LBUFR, LBUFR_BYTES 6698 INTEGER BUFR( LBUFR ) 6699 INTEGER MYID, SLAVEF, COMM 6700 INTEGER N, LIWW 6701 INTEGER IWCB( LIWW ) 6702 INTEGER LWC 6703 COMPLEX(kind=8) W( LWC ) 6704 INTEGER POSIWCB, POSWCB 6705 INTEGER IIPOOL, LPOOL 6706 INTEGER IPOOL( LPOOL ) 6707 INTEGER LPANEL_POS 6708 INTEGER PANEL_POS( LPANEL_POS ) 6709 INTEGER NBFINF, INFO(40) 6710 INTEGER PLEFTW, KEEP( 500) 6711 INTEGER(8) KEEP8(150) 6712 INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) 6713 INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 6714 INTEGER LIW 6715 INTEGER(8) :: LA 6716 INTEGER PTRIST(KEEP(28)), IW( LIW ) 6717 INTEGER (8) :: PTRFAC(KEEP(28)) 6718 COMPLEX(kind=8) A( LA ), W2( KEEP(133) ) 6719 INTEGER LRHS, NRHS 6720 COMPLEX(kind=8) RHS(LRHS, NRHS) 6721 INTEGER MYLEAFE, MTYPE 6722 INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) 6723 COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) 6724 INTEGER SIZE_TO_PROCESS 6725 LOGICAL TO_PROCESS(SIZE_TO_PROCESS) 6726 INCLUDE 'mpif.h' 6727 INCLUDE 'mumps_tags.h' 6728 INTEGER MSGSOU, MSGTAG, MSGLEN 6729 INTEGER STATUS( MPI_STATUS_SIZE ), IERR 6730 FLAG = .FALSE. 6731 IF ( BLOQ ) THEN 6732 CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 6733 & COMM, STATUS, IERR ) 6734 FLAG = .TRUE. 6735 ELSE 6736 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 6737 & FLAG, STATUS, IERR ) 6738 END IF 6739 IF (FLAG) THEN 6740 MSGSOU=STATUS(MPI_SOURCE) 6741 MSGTAG=STATUS(MPI_TAG) 6742 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 6743 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 6744 INFO(1) = -20 6745 INFO(2) = MSGLEN 6746 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 6747 ELSE 6748 CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, 6749 & MSGTAG, COMM, STATUS, IERR) 6750 CALL ZMUMPS_42( MSGTAG, MSGSOU, 6751 & BUFR, LBUFR, LBUFR_BYTES, 6752 & MYID, SLAVEF, COMM, 6753 & N, IWCB, LIWW, POSIWCB, 6754 & W, LWC, POSWCB, 6755 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6756 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 6757 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, 6758 & KEEP,KEEP8, 6759 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6760 & RHS, LRHS, NRHS, MTYPE, 6761 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6762 & , TO_PROCESS, SIZE_TO_PROCESS 6763 & ) 6764 END IF 6765 END IF 6766 RETURN 6767 END SUBROUTINE ZMUMPS_41 6768 RECURSIVE SUBROUTINE ZMUMPS_42( 6769 & MSGTAG, MSGSOU, 6770 & BUFR, LBUFR, LBUFR_BYTES, 6771 & MYID, SLAVEF, COMM, 6772 & N, IWCB, LIWW, POSIWCB, 6773 & W, LWC, POSWCB, 6774 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6775 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 6776 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 6777 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6778 & RHS, LRHS, NRHS, MTYPE, 6779 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6780 & , TO_PROCESS, SIZE_TO_PROCESS 6781 & ) 6782 USE ZMUMPS_OOC 6783 USE ZMUMPS_COMM_BUFFER 6784 IMPLICIT NONE 6785 INTEGER MSGTAG, MSGSOU 6786 INTEGER LBUFR, LBUFR_BYTES 6787 INTEGER BUFR( LBUFR ) 6788 INTEGER MYID, SLAVEF, COMM 6789 INTEGER N, LIWW 6790 INTEGER IWCB( LIWW ) 6791 INTEGER LWC 6792 COMPLEX(kind=8) W( LWC ) 6793 INTEGER POSIWCB, POSWCB 6794 INTEGER IIPOOL, LPOOL, LPANEL_POS 6795 INTEGER IPOOL( LPOOL ) 6796 INTEGER PANEL_POS( LPANEL_POS ) 6797 INTEGER NBFINF, INFO(40) 6798 INTEGER PLEFTW, KEEP( 500) 6799 INTEGER(8) KEEP8(150) 6800 INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 6801 INTEGER FRERE(KEEP(28)) 6802 INTEGER PROCNODE_STEPS(KEEP(28)) 6803 INTEGER LIW 6804 INTEGER(8) :: LA 6805 INTEGER IW( LIW ), PTRIST( KEEP(28) ) 6806 INTEGER(8) :: PTRFAC(KEEP(28)) 6807 COMPLEX(kind=8) A( LA ), W2( KEEP(133) ) 6808 INTEGER LRHS, NRHS 6809 COMPLEX(kind=8) RHS(LRHS, NRHS) 6810 INTEGER MYLEAFE, MTYPE 6811 INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) 6812 COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) 6813 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR 6814 LOGICAL MUST_BE_PERMUTED 6815 INTEGER SIZE_TO_PROCESS 6816 LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN 6817 INCLUDE 'mpif.h' 6818 INCLUDE 'mumps_tags.h' 6819 INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) 6820 INTEGER P_UPDATE, P_SOL_MAS, LIELL, K 6821 INTEGER(8) :: APOS, IST 6822 INTEGER NPIV, NROW_L, IPOS, NROW_RECU 6823 INTEGER I, JJ, IN, PROCDEST, J1, J2, IFR, LDA 6824 INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, 6825 & IPOSINRHSCOMP 6826 LOGICAL FLAG 6827 COMPLEX(kind=8) ZERO, ALPHA, ONE 6828 PARAMETER (ZERO=(0.0D0,0.0D0), 6829 & ONE=(1.0D0,0.0D0), 6830 & ALPHA=(-1.0D0,0.0D0)) 6831 INCLUDE 'mumps_headers.h' 6832 INTEGER POOL_FIRST_POS, TMP 6833 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) 6834 INTEGER MUMPS_275 6835 EXTERNAL MUMPS_275, ztrsv, ztrsm, zgemv, zgemm 6836 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS 6837 INTEGER LDAJ, NBJ, LIWFAC, 6838 & NBJLAST, NPIV_LAST, PANEL_SIZE, 6839 & PTWCB_PANEL, NCB_PANEL, TYPEF 6840 LOGICAL TWOBYTWO 6841 INTEGER BEG_PANEL 6842 INTEGER IPANEL, NPANELS 6843 IF (MSGTAG .EQ. FEUILLE) THEN 6844 NBFINF = NBFINF - 1 6845 ELSE IF (MSGTAG .EQ. NOEUD) THEN 6846 POSITION = 0 6847 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6848 & INODE, 1, MPI_INTEGER, 6849 & COMM, IERR) 6850 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6851 & LONG, 1, MPI_INTEGER, 6852 & COMM, IERR) 6853 IF ( POSIWCB - LONG - 2 .LT. 0 6854 & .OR. POSWCB - PLEFTW + 1 .LT. LONG ) THEN 6855 CALL ZMUMPS_95(NRHS, N, KEEP(28), IWCB, 6856 & LIWW, W, LWC, 6857 & POSWCB, POSIWCB, PTRICB, PTRACB) 6858 IF ((POSIWCB - LONG - 2 ) .LT. 0) THEN 6859 INFO(1)=-14 6860 INFO(2)=-POSIWCB + LONG + 2 6861 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 6862 GOTO 260 6863 END IF 6864 IF ( POSWCB - PLEFTW + 1 .LT. LONG ) THEN 6865 INFO(1) = -11 6866 INFO(2) = LONG + PLEFTW - POSWCB - 1 6867 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 6868 GOTO 260 6869 END IF 6870 ENDIF 6871 POSIWCB = POSIWCB - LONG 6872 POSWCB = POSWCB - LONG 6873 IF (LONG .GT. 0) THEN 6874 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6875 & IWCB(POSIWCB + 1), 6876 & LONG, MPI_INTEGER, COMM, IERR) 6877 DO K=1,NRHS 6878 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6879 & W(POSWCB + 1), LONG, 6880 & MPI_DOUBLE_COMPLEX, COMM, IERR) 6881 DO JJ=0, LONG-1 6882 RHS(IWCB(POSIWCB+1+JJ),K) = W(POSWCB+1+JJ) 6883 ENDDO 6884 ENDDO 6885 POSIWCB = POSIWCB + LONG 6886 POSWCB = POSWCB + LONG 6887 ENDIF 6888 POOL_FIRST_POS = IIPOOL 6889 IF ( KEEP(237).GT. 0 ) THEN 6890 IF (.NOT.TO_PROCESS(STEP(INODE))) 6891 & GOTO 1010 6892 ENDIF 6893 IPOOL( IIPOOL ) = INODE 6894 IIPOOL = IIPOOL + 1 6895 1010 CONTINUE 6896 IF = FRERE( STEP(INODE) ) 6897 DO WHILE ( IF .GT. 0 ) 6898 IF ( MUMPS_275(PROCNODE_STEPS(STEP(IF)), 6899 & SLAVEF) .eq. MYID ) THEN 6900 IF ( KEEP(237).GT. 0 ) THEN 6901 IF (.NOT.TO_PROCESS(STEP(IF))) THEN 6902 IF = FRERE(STEP(IF)) 6903 CYCLE 6904 ENDIF 6905 ENDIF 6906 IPOOL( IIPOOL ) = IF 6907 IIPOOL = IIPOOL + 1 6908 END IF 6909 IF = FRERE( STEP( IF ) ) 6910 END DO 6911 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 6912 TMP=IPOOL(POOL_FIRST_POS+I-1) 6913 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 6914 IPOOL(IIPOOL-I)=TMP 6915 ENDDO 6916 ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN 6917 POSITION = 0 6918 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 6919 & INODE, 1, MPI_INTEGER, COMM, IERR ) 6920 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 6921 & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) 6922 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) 6923 NPIV = - IW( IPOS ) 6924 NROW_L = IW( IPOS + 1 ) 6925 IF (KEEP(201).GT.0) THEN 6926 CALL ZMUMPS_643( 6927 & INODE,PTRFAC,KEEP,A,LA,STEP, 6928 & KEEP8,N,MUST_BE_PERMUTED,IERR) 6929 IF(IERR.LT.0)THEN 6930 INFO(1)=IERR 6931 INFO(2)=0 6932 GOTO 260 6933 ENDIF 6934 ENDIF 6935 APOS = PTRFAC(IW( IPOS + 3 )) 6936 IF ( NROW_L .NE. NROW_RECU ) THEN 6937 WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU 6938 CALL MUMPS_ABORT() 6939 END IF 6940 LONG = NROW_L + NPIV 6941 IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN 6942 CALL ZMUMPS_95(NRHS, N, KEEP(28), IWCB, 6943 & LIWW, W, LWC, 6944 & POSWCB, POSIWCB, PTRICB, PTRACB) 6945 IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN 6946 INFO(1) = -11 6947 INFO(2) = LONG * NRHS- POSWCB 6948 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 6949 GOTO 260 6950 END IF 6951 END IF 6952 P_UPDATE = PLEFTW 6953 P_SOL_MAS = PLEFTW + NPIV * NRHS 6954 PLEFTW = P_SOL_MAS + NROW_L * NRHS 6955 DO K=1, NRHS 6956 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 6957 & W( P_SOL_MAS+(K-1)*NROW_L),NROW_L, 6958 & MPI_DOUBLE_COMPLEX, 6959 & COMM, IERR ) 6960 ENDDO 6961 IF (KEEP(201).EQ.1) THEN 6962 IF ( NRHS == 1 ) THEN 6963 CALL zgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, 6964 & W( P_SOL_MAS ), 1, ZERO, 6965 & W( P_UPDATE ), 1 ) 6966 ELSE 6967 CALL zgemm( 'T', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), 6968 & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), 6969 & NPIV ) 6970 ENDIF 6971 ELSE 6972 IF ( NRHS == 1 ) THEN 6973 CALL zgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, 6974 & W( P_SOL_MAS ), 1, ZERO, 6975 & W( P_UPDATE ), 1 ) 6976 ELSE 6977 CALL zgemm( 'N', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), 6978 & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), 6979 & NPIV ) 6980 END IF 6981 ENDIF 6982 IF (KEEP(201).GT.0) THEN 6983 CALL ZMUMPS_598(INODE,PTRFAC,KEEP(28), 6984 & A,LA,.TRUE.,IERR) 6985 IF(IERR.LT.0)THEN 6986 INFO(1)=IERR 6987 INFO(2)=0 6988 GOTO 260 6989 ENDIF 6990 ENDIF 6991 PLEFTW = PLEFTW - NROW_L * NRHS 6992 100 CONTINUE 6993 CALL ZMUMPS_63( NRHS, INODE, W(P_UPDATE), 6994 & NPIV, NPIV, 6995 & MSGSOU, 6996 & BACKSLV_UPDATERHS, 6997 & COMM, IERR ) 6998 IF ( IERR .EQ. -1 ) THEN 6999 CALL ZMUMPS_41( 7000 & .FALSE., FLAG, 7001 & BUFR, LBUFR, LBUFR_BYTES, 7002 & MYID, SLAVEF, COMM, 7003 & N, IWCB, LIWW, POSIWCB, 7004 & W, LWC, POSWCB, 7005 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 7006 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 7007 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 7008 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 7009 & RHS, LRHS, NRHS, MTYPE, 7010 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 7011 & , TO_PROCESS, SIZE_TO_PROCESS 7012 & ) 7013 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 7014 GOTO 100 7015 ELSE IF ( IERR .EQ. -2 ) THEN 7016 INFO( 1 ) = -17 7017 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 7018 GOTO 260 7019 ELSE IF ( IERR .EQ. -3 ) THEN 7020 INFO( 1 ) = -20 7021 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 7022 GOTO 260 7023 END IF 7024 PLEFTW = PLEFTW - NPIV * NRHS 7025 ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN 7026 POSITION = 0 7027 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 7028 & INODE, 1, MPI_INTEGER, COMM, IERR ) 7029 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 7030 LIELL = IW(IPOS-2)+IW(IPOS+1) 7031 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 7032 & NPIV, 1, MPI_INTEGER, COMM, IERR ) 7033 NELIM = IW(IPOS-1) 7034 IPOS = IPOS + 1 7035 NPIV = IW(IPOS) 7036 IPOS = IPOS + 1 7037 NSLAVES = IW( IPOS + 1 ) 7038 IPOS = IPOS + 1 + NSLAVES 7039 INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 7040 IF ( KEEP(50) .eq. 0 ) THEN 7041 LDA = LIELL 7042 ELSE 7043 LDA = NPIV 7044 ENDIF 7045 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 7046 J1 = IPOS + 1 7047 J2 = IPOS + NPIV 7048 ELSE 7049 J1 = IPOS + LIELL + 1 7050 J2 = IPOS + NPIV + LIELL 7051 END IF 7052 DO K=1, NRHS 7053 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 7054 & W2, NPIV, MPI_DOUBLE_COMPLEX, 7055 & COMM, IERR ) 7056 IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 7057 I = 1 7058 IF ( (KEEP(253).NE.0) .AND. 7059 & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) 7060 & ) THEN 7061 DO JJ = J1,J2 7062 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) 7063 I = I+1 7064 ENDDO 7065 ELSE 7066 DO JJ = J1,J2 7067 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = 7068 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) 7069 I = I+1 7070 ENDDO 7071 ENDIF 7072 ENDDO 7073 IW(PTRIST(STEP(INODE))+XXS) = 7074 & IW(PTRIST(STEP(INODE))+XXS) - 1 7075 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN 7076 IF (KEEP(201).GT.0) THEN 7077 CALL ZMUMPS_643( 7078 & INODE,PTRFAC,KEEP,A,LA,STEP, 7079 & KEEP8,N,MUST_BE_PERMUTED,IERR) 7080 IF(IERR.LT.0)THEN 7081 INFO(1)=IERR 7082 INFO(2)=0 7083 GOTO 260 7084 ENDIF 7085 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 7086 CALL ZMUMPS_755( 7087 & IW(IPOS+1+2*LIELL), 7088 & MUST_BE_PERMUTED ) 7089 ENDIF 7090 ENDIF 7091 APOS = PTRFAC(IW(INODEPOS)) 7092 IF (KEEP(201).EQ.1) THEN 7093 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 7094 TYPEF = TYPEF_L 7095 NROW_L = NPIV+NELIM 7096 PANEL_SIZE = ZMUMPS_690(NROW_L) 7097 IF (PANEL_SIZE.LT.0) THEN 7098 WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', 7099 & PANEL_SIZE 7100 CALL MUMPS_ABORT() 7101 ENDIF 7102 ENDIF 7103 IF ( POSIWCB - 2 .LT. 0 .or. 7104 & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 7105 CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, 7106 & LIWW, W, LWC, 7107 & POSWCB, POSIWCB, PTRICB, PTRACB) 7108 IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 7109 INFO( 1 ) = -11 7110 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 7111 GOTO 260 7112 END IF 7113 IF ( POSIWCB - 2 .LT. 0 ) THEN 7114 INFO( 1 ) = -14 7115 INFO( 2 ) = 2 - POSIWCB 7116 GO TO 260 7117 END IF 7118 END IF 7119 POSIWCB = POSIWCB - 2 7120 POSWCB = POSWCB - LIELL*NRHS 7121 PTRICB(STEP( INODE )) = POSIWCB + 1 7122 PTRACB(STEP( INODE )) = POSWCB + 1 7123 IWCB( PTRICB(STEP( INODE )) ) = LIELL 7124 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 7125 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES 7126 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 7127 POSINDICES = IPOS + LIELL + 1 7128 ELSE 7129 POSINDICES = IPOS + 1 7130 END IF 7131 IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 7132 IFR = PTRACB(STEP( INODE )) 7133 DO K=1, NRHS 7134 DO JJ = J1, J2 7135 W(IFR+JJ-J1+(K-1)*LIELL) = 7136 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 7137 ENDDO 7138 END DO 7139 IFR = PTRACB(STEP(INODE))-1+NPIV 7140 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 7141 J1 = IPOS + LIELL + NPIV + 1 7142 J2 = IPOS + 2 * LIELL 7143 ELSE 7144 J1 = IPOS + NPIV + 1 7145 J2 = IPOS + LIELL 7146 END IF 7147 DO JJ = J1, J2-KEEP(253) 7148 J = IW(JJ) 7149 IFR = IFR + 1 7150 DO K=1, NRHS 7151 W(IFR+(K-1)*LIELL) = RHS(J,K) 7152 ENDDO 7153 ENDDO 7154 IF ( KEEP(201).EQ.1 .AND. 7155 & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN 7156 J = NPIV / PANEL_SIZE 7157 TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 7158 IF (TWOBYTWO) THEN 7159 CALL ZMUMPS_641(PANEL_SIZE, PANEL_POS, 7160 & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, 7161 & NROW_L, NBENTRIES_ALLPANELS) 7162 ELSE 7163 IF (NPIV.EQ.J*PANEL_SIZE) THEN 7164 NPIV_LAST = NPIV 7165 NBJLAST = PANEL_SIZE 7166 NPANELS = J 7167 ELSE 7168 NPIV_LAST = (J+1)* PANEL_SIZE 7169 NBJLAST = NPIV-J*PANEL_SIZE 7170 NPANELS = J+1 7171 ENDIF 7172 NBENTRIES_ALLPANELS = 7173 & int(NROW_L,8) * int(NPIV,8) 7174 & - int( ( J * ( J - 1 ) ) / 2,8 ) 7175 & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) 7176 & - int(J,8) 7177 & * int(mod(NPIV, PANEL_SIZE),8) 7178 & * int(PANEL_SIZE,8) 7179 JJ=NPIV_LAST 7180 ENDIF 7181 APOSDEB = APOS + NBENTRIES_ALLPANELS 7182 DO IPANEL=NPANELS,1,-1 7183 IF (TWOBYTWO) THEN 7184 NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) 7185 BEG_PANEL = PANEL_POS(IPANEL) 7186 ELSE 7187 IF (JJ.EQ.NPIV_LAST) THEN 7188 NBJ = NBJLAST 7189 ELSE 7190 NBJ = PANEL_SIZE 7191 ENDIF 7192 BEG_PANEL = JJ- PANEL_SIZE+1 7193 ENDIF 7194 LDAJ = NROW_L-BEG_PANEL+1 7195 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) 7196 PTWCB_PANEL = PTRACB(STEP(INODE)) + BEG_PANEL - 1 7197 NCB_PANEL = LDAJ - NBJ 7198 IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN 7199 CALL ZMUMPS_667(TYPEF, TMP_NBPANELS, 7200 & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) 7201 CALL ZMUMPS_698( 7202 & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), 7203 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 7204 & IW(I_PIVRPTR+IPANEL-1)-1, 7205 & A(APOSDEB), 7206 & LDAJ, NBJ, BEG_PANEL-1) 7207 ENDIF 7208 IF ( NRHS == 1 ) THEN 7209 IF (NCB_PANEL.NE.0) THEN 7210 CALL zgemv( 'T', NCB_PANEL, NBJ, ALPHA, 7211 & A( APOSDEB + int(NBJ,8) ), LDAJ, 7212 & W( NBJ + PTWCB_PANEL ), 7213 & 1, ONE, 7214 & W(PTWCB_PANEL), 1 ) 7215 ENDIF 7216 CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 7217 & W(PTWCB_PANEL), 1) 7218 ELSE 7219 IF (NCB_PANEL.NE.0) THEN 7220 CALL zgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, 7221 & A(APOSDEB + int(NBJ,8)), LDAJ, 7222 & W(NBJ+PTWCB_PANEL),LIELL, 7223 & ONE, W(PTWCB_PANEL),LIELL) 7224 ENDIF 7225 CALL ztrsm('L','L','T','U',NBJ, NRHS, ONE, 7226 & A(APOSDEB), 7227 & LDAJ, W(PTWCB_PANEL), LIELL) 7228 ENDIF 7229 IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 7230 ENDDO 7231 GOTO 1234 7232 ENDIF 7233 IF (NELIM .GT.0) THEN 7234 IF ( KEEP(50) .eq. 0 ) THEN 7235 IST = APOS + int(NPIV,8) * int(LIELL,8) 7236 ELSE 7237 IST = APOS + int(NPIV,8) * int(NPIV,8) 7238 END IF 7239 IF ( NRHS == 1 ) THEN 7240 CALL zgemv( 'N', NPIV, NELIM, ALPHA, 7241 & A( IST ), NPIV, 7242 & W( NPIV + PTRACB(STEP(INODE)) ), 7243 & 1, ONE, 7244 & W(PTRACB(STEP(INODE))), 1 ) 7245 ELSE 7246 CALL zgemm( 'N', 'N', NPIV, NRHS, NELIM, ALPHA, 7247 & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, 7248 & ONE, W(PTRACB(STEP(INODE))),LIELL) 7249 END IF 7250 ENDIF 7251 IF ( NRHS == 1 ) THEN 7252 CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, 7253 & W(PTRACB(STEP(INODE))),1) 7254 ELSE 7255 CALL ztrsm( 'L','U', 'N', 'U', NPIV, NRHS, ONE, 7256 & A(APOS), LDA, 7257 & W(PTRACB(STEP(INODE))),LIELL) 7258 END IF 7259 1234 CONTINUE 7260 IF (KEEP(201).GT.0) THEN 7261 CALL ZMUMPS_598(INODE,PTRFAC,KEEP(28), 7262 & A,LA,.TRUE.,IERR) 7263 IF(IERR.LT.0)THEN 7264 INFO(1)=IERR 7265 INFO(2)=0 7266 GOTO 260 7267 ENDIF 7268 ENDIF 7269 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES 7270 DO I = 1, NPIV 7271 JJ = IW( IPOS + I - 1 ) 7272 DO K=1,NRHS 7273 RHS( JJ, K ) = W( PTRACB(STEP(INODE))+I-1 7274 & + (K-1)*LIELL ) 7275 ENDDO 7276 END DO 7277 IN = INODE 7278 200 IN = FILS(IN) 7279 IF (IN .GT. 0) GOTO 200 7280 IF (IN .EQ. 0) THEN 7281 MYLEAFE = MYLEAFE - 1 7282 IF (MYLEAFE .EQ. 0) THEN 7283 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 7284 & FEUILLE, SLAVEF ) 7285 NBFINF = NBFINF - 1 7286 ENDIF 7287 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 7288 CALL ZMUMPS_151(NRHS, N, KEEP(28), 7289 & IWCB, LIWW, W, LWC, 7290 & POSWCB, POSIWCB, PTRICB, PTRACB) 7291 GOTO 270 7292 ENDIF 7293 DO I = 0, SLAVEF - 1 7294 DEJA_SEND( I ) = .FALSE. 7295 END DO 7296 IN = -IN 7297 IF ( KEEP(237).GT.0 ) THEN 7298 NO_CHILDREN = .TRUE. 7299 ELSE 7300 NO_CHILDREN = .FALSE. 7301 ENDIF 7302 DO WHILE (IN.GT.0) 7303 IF ( KEEP(237).GT.0 ) THEN 7304 IF (.NOT.TO_PROCESS(STEP(IN))) THEN 7305 IN = FRERE(STEP(IN)) 7306 CYCLE 7307 ELSE 7308 NO_CHILDREN = .FALSE. 7309 ENDIF 7310 ENDIF 7311 POOL_FIRST_POS = IIPOOL 7312 IF (MUMPS_275(PROCNODE_STEPS(STEP(IN)), 7313 & SLAVEF) .EQ. MYID) THEN 7314 IPOOL(IIPOOL ) = IN 7315 IIPOOL = IIPOOL + 1 7316 ELSE 7317 PROCDEST = MUMPS_275( PROCNODE_STEPS(STEP(IN)), 7318 & SLAVEF ) 7319 IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 7320 110 CALL ZMUMPS_78( NRHS, IN, 0, 0, 7321 & LIELL, LIELL-KEEP(253), 7322 & IW( POSINDICES ) , 7323 & W( PTRACB(STEP(INODE))), 7324 & PROCDEST, NOEUD, COMM, IERR ) 7325 IF ( IERR .EQ. -1 ) THEN 7326 CALL ZMUMPS_41( 7327 & .FALSE., FLAG, 7328 & BUFR, LBUFR, LBUFR_BYTES, 7329 & MYID, SLAVEF, COMM, 7330 & N, IWCB, LIWW, POSIWCB, 7331 & W, LWC, POSWCB, 7332 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 7333 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 7334 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 7335 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 7336 & RHS, LRHS, NRHS, MTYPE, 7337 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 7338 & , TO_PROCESS, SIZE_TO_PROCESS 7339 & ) 7340 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 7341 GOTO 110 7342 ELSE IF ( IERR .eq. -2 ) THEN 7343 INFO(1) = -17 7344 INFO(2) = LIELL * NRHS * KEEP(35) + 7345 & ( LIELL + 2 ) * KEEP(34) 7346 GOTO 260 7347 ELSE IF ( IERR .eq. -3 ) THEN 7348 INFO(1) = -20 7349 INFO(2) = LIELL * NRHS * KEEP(35) + 7350 & ( LIELL + 2 ) * KEEP(34) 7351 GOTO 260 7352 END IF 7353 DEJA_SEND( PROCDEST ) = .TRUE. 7354 END IF 7355 END IF 7356 IN = FRERE( STEP( IN ) ) 7357 END DO 7358 IF (NO_CHILDREN) THEN 7359 MYLEAFE = MYLEAFE - 1 7360 IF (MYLEAFE .EQ. 0) THEN 7361 CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, 7362 & COMM, FEUILLE, SLAVEF ) 7363 NBFINF = NBFINF - 1 7364 ENDIF 7365 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 7366 CALL ZMUMPS_151(NRHS, N, KEEP(28), 7367 & IWCB, LIWW, W, LWC, 7368 & POSWCB, POSIWCB, PTRICB, PTRACB) 7369 GOTO 270 7370 ENDIF 7371 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 7372 TMP=IPOOL(POOL_FIRST_POS+I-1) 7373 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 7374 IPOOL(IIPOOL-I)=TMP 7375 ENDDO 7376 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 7377 CALL ZMUMPS_151(NRHS, N, KEEP(28), 7378 & IWCB, LIWW, W, LWC, 7379 & POSWCB, POSIWCB, PTRICB, PTRACB) 7380 END IF 7381 ELSE IF (MSGTAG.EQ.TERREUR) THEN 7382 INFO(1) = -001 7383 INFO(2) = MSGSOU 7384 GO TO 270 7385 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. 7386 & (MSGTAG.EQ.TAG_DUMMY) ) THEN 7387 GO TO 270 7388 ELSE 7389 INFO(1) = -100 7390 INFO(2) = MSGTAG 7391 GOTO 260 7392 ENDIF 7393 GO TO 270 7394 260 CONTINUE 7395 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 7396 270 CONTINUE 7397 RETURN 7398 END SUBROUTINE ZMUMPS_42 7399 SUBROUTINE ZMUMPS_641(PANEL_SIZE, PANEL_POS, 7400 & LEN_PANEL_POS, INDICES, NPIV, 7401 & NPANELS, NFRONT_OR_NASS, 7402 & NBENTRIES_ALLPANELS) 7403 IMPLICIT NONE 7404 INTEGER, intent (in) :: PANEL_SIZE, NPIV 7405 INTEGER, intent (in) :: INDICES(NPIV) 7406 INTEGER, intent (in) :: LEN_PANEL_POS 7407 INTEGER, intent (out) :: NPANELS 7408 INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) 7409 INTEGER, intent (in) :: NFRONT_OR_NASS 7410 INTEGER(8), intent(out):: NBENTRIES_ALLPANELS 7411 INTEGER NPANELS_MAX, I, NBeff 7412 INTEGER(8) :: NBENTRIES_THISPANEL 7413 NBENTRIES_ALLPANELS = 0_8 7414 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE 7415 IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN 7416 WRITE(*,*) "Error 1 in ZMUMPS_641", 7417 & LEN_PANEL_POS,NPANELS_MAX 7418 CALL MUMPS_ABORT() 7419 ENDIF 7420 I = 1 7421 NPANELS = 0 7422 IF (I .GT. NPIV) RETURN 7423 10 CONTINUE 7424 NPANELS = NPANELS + 1 7425 PANEL_POS(NPANELS) = I 7426 NBeff = min(PANEL_SIZE, NPIV-I+1) 7427 IF ( INDICES(I+NBeff-1) < 0) THEN 7428 NBeff=NBeff+1 7429 ENDIF 7430 NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) 7431 NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL 7432 I=I+NBeff 7433 IF ( I .LE. NPIV ) GOTO 10 7434 PANEL_POS(NPANELS+1)=NPIV+1 7435 RETURN 7436 END SUBROUTINE ZMUMPS_641 7437 SUBROUTINE ZMUMPS_286( NRHS, DESCA_PAR, 7438 & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, 7439 & IPIV,LPIV,MASTER_ROOT,MYID,COMM, 7440 & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) 7441 IMPLICIT NONE 7442 INTEGER NRHS, MTYPE 7443 INTEGER DESCA_PAR( 9 ) 7444 INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK 7445 INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT 7446 INTEGER MYID, COMM 7447 INTEGER LPIV, IPIV( LPIV ) 7448 INTEGER INFO(40), LDLT 7449 COMPLEX(kind=8) RHS_SEQ( SIZE_ROOT *NRHS) 7450 COMPLEX(kind=8) A( LOCAL_M, LOCAL_N ) 7451 INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL 7452 INTEGER LOCAL_N_RHS 7453 COMPLEX(kind=8), ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR 7454 EXTERNAL numroc 7455 INTEGER numroc 7456 INTEGER allocok 7457 CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) 7458 LOCAL_N_RHS = numroc(NRHS, NBLOCK, MYCOL, 0, NPCOL) 7459 LOCAL_N_RHS = max(1,LOCAL_N_RHS) 7460 ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) 7461 IF (allocok > 0 ) THEN 7462 WRITE(*,*) ' Problem during solve of the root.' 7463 WRITE(*,*) ' Reduce number of right hand sides.' 7464 CALL MUMPS_ABORT() 7465 ENDIF 7466 CALL ZMUMPS_290( MYID, SIZE_ROOT, NRHS, RHS_SEQ, 7467 & LOCAL_M, LOCAL_N_RHS, 7468 & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, 7469 & NPROW, NPCOL, COMM ) 7470 CALL ZMUMPS_768 (SIZE_ROOT, NRHS, MTYPE, 7471 & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, 7472 & IPIV, LPIV, RHS_PAR, LDLT, 7473 & MBLOCK, NBLOCK, CNTXT_PAR, 7474 & IERR) 7475 CALL ZMUMPS_156( MYID, SIZE_ROOT, NRHS, 7476 & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, 7477 & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, 7478 & NPROW, NPCOL, COMM ) 7479 DEALLOCATE(RHS_PAR) 7480 RETURN 7481 END SUBROUTINE ZMUMPS_286 7482 SUBROUTINE ZMUMPS_768 (SIZE_ROOT, NRHS, MTYPE, 7483 & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, 7484 & IPIV, LPIV, RHS_PAR, LDLT, 7485 & MBLOCK, NBLOCK, CNTXT_PAR, 7486 & IERR) 7487 IMPLICIT NONE 7488 INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, 7489 & LOCAL_N, LOCAL_N_RHS, 7490 & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE 7491 INTEGER, intent (in) :: DESCA_PAR( 9 ) 7492 INTEGER, intent (in) :: LPIV, IPIV( LPIV ) 7493 COMPLEX(kind=8), intent (in) :: A( LOCAL_M, LOCAL_N ) 7494 COMPLEX(kind=8), intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) 7495 INTEGER, intent (out) :: IERR 7496 INTEGER :: DESCB_PAR( 9 ) 7497 IERR = 0 7498 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, 7499 & NRHS, MBLOCK, NBLOCK, 0, 0, 7500 & CNTXT_PAR, LOCAL_M, IERR ) 7501 IF (IERR.NE.0) THEN 7502 WRITE(*,*) 'After DESCINIT, IERR = ', IERR 7503 CALL MUMPS_ABORT() 7504 END IF 7505 IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN 7506 IF ( MTYPE .eq. 1 ) THEN 7507 CALL pzgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, 7508 & RHS_PAR,1,1,DESCB_PAR,IERR) 7509 ELSE 7510 CALL pzgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, 7511 & RHS_PAR, 1, 1, DESCB_PAR,IERR) 7512 END IF 7513 ELSE 7514 CALL pzpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, 7515 & RHS_PAR, 1, 1, DESCB_PAR, IERR ) 7516 END IF 7517 IF ( IERR .LT. 0 ) THEN 7518 WRITE(*,*) ' Problem during solve of the root' 7519 CALL MUMPS_ABORT() 7520 END IF 7521 RETURN 7522 END SUBROUTINE ZMUMPS_768 7523