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 SMUMPS_301( id) 49 USE SMUMPS_STRUC_DEF 50 USE MUMPS_SOL_ES 51 USE SMUMPS_COMM_BUFFER 52 USE SMUMPS_OOC 53 USE TOOLS_COMMON 54 IMPLICIT NONE 55 INTERFACE 56 SUBROUTINE SMUMPS_710( id, NB_INT,NB_CMPLX ) 57 USE SMUMPS_STRUC_DEF 58 TYPE (SMUMPS_STRUC) :: id 59 INTEGER(8) :: NB_INT,NB_CMPLX 60 END SUBROUTINE SMUMPS_710 61 SUBROUTINE SMUMPS_758 62 &(idRHS, idINFO, idN, idNRHS, idLRHS) 63 REAL, DIMENSION(:), POINTER :: idRHS 64 INTEGER, intent(in) :: idN, idNRHS, idLRHS 65 INTEGER, intent(inout) :: idINFO(:) 66 END SUBROUTINE SMUMPS_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 (SMUMPS_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 SMUMPS_LBUF, SMUMPS_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 REAL 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 REAL, 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 REAL ONE 112 REAL ZERO 113 PARAMETER( ONE = 1.0E0 ) 114 PARAMETER( ZERO = 0.0E0 ) 115 REAL RZERO, RONE 116 PARAMETER( RZERO = 0.0E0, RONE = 1.0E0 ) 117 REAL, DIMENSION(:), POINTER :: RHS_MUMPS 118 REAL, DIMENSION(:), POINTER :: WORK_WCB 119 REAL, DIMENSION(:), POINTER :: PTR_RHS_ROOT 120 INTEGER :: LPTR_RHS_ROOT 121 REAL, ALLOCATABLE :: SAVERHS(:), C_RW1(:), 122 & C_RW2(:), 123 & SRW3(:), C_Y(:), 124 & C_W(:) 125 REAL, ALLOCATABLE :: CWORK(:) 126 REAL, ALLOCATABLE :: R_RW1(:), R_Y(:), D(:) 127 REAL, ALLOCATABLE :: R_W(:) 128 REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 129 REAL, 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 REAL, DIMENSION(:), POINTER :: CNTL 136 INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO 137 INTEGER(8), DIMENSION (:), POINTER :: KEEP8 138 INTEGER, DIMENSION (:), POINTER :: IS 139 REAL, DIMENSION(:),POINTER:: RINFOG 140 type scaling_data_t 141 SEQUENCE 142 REAL, dimension(:), pointer :: SCALING 143 REAL, dimension(:), pointer :: SCALING_LOC 144 end type scaling_data_t 145 type (scaling_data_t) :: scaling_data 146 REAL, DIMENSION(:), POINTER :: PT_SCALING 147 REAL, TARGET :: Dummy_SCAL(1) 148 REAL ARRET 149 REAL C_DUMMY(1) 150 REAL R_DUMMY(1) 151 INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) 152 INTEGER, TARGET :: IDUMMY_TARGET(1) 153 REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_590(LA) 813 CALL SMUMPS_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 SMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) 988 & * KEEP(34) 989 CALL SMUMPS_55( SMUMPS_LBUF_INT, IERR ) 990 IF ( IERR .NE. 0 ) THEN 991 INFO(1) = -13 992 INFO(2) = SMUMPS_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 SMUMPS_LBUF = (MSG_MAX_BYTES_SOLVE + 2*KEEP(34) )*id%NSLAVES 1000 SMUMPS_LBUF = min(SMUMPS_LBUF, 100 000 000) 1001 SMUMPS_LBUF = max(SMUMPS_LBUF, 1002 & (MSG_MAX_BYTES_SOLVE+2*KEEP(34)) * min(id%NSLAVES,3)) 1003 SMUMPS_LBUF = SMUMPS_LBUF + KEEP(34) 1004 CALL SMUMPS_53( SMUMPS_LBUF, IERR ) 1005 IF ( IERR .NE. 0 ) THEN 1006 INFO(1) = -13 1007 INFO(2) = SMUMPS_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 SMUMPS_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_REAL,MASTER, 1198 & id%COMM,IERR) 1199 scaling_data%SCALING=>id%COLSCA 1200 ELSE 1201 CALL MPI_BCAST(id%ROWSCA(1),id%N, 1202 & MPI_REAL,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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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_REAL, 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 SMUMPS_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 & abs(id%DKEEP(2)) 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) = id%DKEEP(2) 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_REAL, 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_REAL, 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_REAL, 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_REAL, 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 SMUMPS_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 SMUMPS_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_REAL, 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_REAL, 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_REAL, 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_REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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_REAL, 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 SMUMPS_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_REAL, 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_REAL, 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 SMUMPS_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_REAL, 2453 & MPI_SUM,MASTER,id%COMM, IERR) 2454 ELSE 2455 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2456 & id%N, MPI_REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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_REAL, 2590 & MPI_SUM,MASTER,id%COMM, IERR) 2591 ELSE 2592 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2593 & id%N, MPI_REAL, 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.0E0) THEN 2601 ARRET = sqrt(epsilon(0.0E0)) 2602 END IF 2603 CALL SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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_REAL, MASTER, 2640 & id%COMM, IERR ) 2641 IF ( I_AM_SLAVE .and. 2642 & id%NZ_loc .NE. 0 ) THEN 2643 CALL SMUMPS_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_REAL, 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_REAL, 2657 & MPI_SUM,MASTER,id%COMM, IERR) 2658 END IF 2659 IF ( I_AM_SLAVE .and. id%NZ_loc .NE. 0 ) THEN 2660 CALL SMUMPS_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_REAL, 2669 & MPI_SUM,MASTER,id%COMM, IERR) 2670 ELSE 2671 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2672 & id%N, MPI_REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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_REAL, MASTER, 2831 & id%COMM, IERR ) 2832 IF ( I_AM_SLAVE .and. 2833 & id%NZ_loc .NE. 0 ) THEN 2834 CALL SMUMPS_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_REAL, 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_REAL, 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 SMUMPS_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_REAL, 2862 & MPI_SUM,MASTER,id%COMM, IERR) 2863 ELSE 2864 CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, 2865 & id%N, MPI_REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_57( IERR ) 3082 CALL SMUMPS_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,5E14.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 SMUMPS_301 3179 SUBROUTINE SMUMPS_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 SMUMPS_OOC 3202 USE MUMPS_SOL_ES 3203 IMPLICIT NONE 3204 INCLUDE 'smumps_root.h' 3205#if defined(V_T) 3206 INCLUDE 'VT.inc' 3207#endif 3208 TYPE ( SMUMPS_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 REAL 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 REAL 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 REAL ZERO 3255 PARAMETER( ZERO = 0.0E0 ) 3256 INCLUDE 'mumps_headers.h' 3257 EXTERNAL SMUMPS_248, SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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,5E14.6)) 394099994 FORMAT (' RHS (2 nd column)'/(1X,1P,5E14.6)) 394199992 FORMAT (//' LEAVING SOLVE (MPI41C) WITH') 3942 END SUBROUTINE SMUMPS_245 3943 SUBROUTINE SMUMPS_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 REAL RHS (LRHS, NRHS) 3954 INTEGER KEEP(500) 3955 INTEGER(8) KEEP8(150) 3956 REAL :: 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 REAL, 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_REAL, MASTER, 4002 & GatherSol, COMM, IERR) 4003 & 4004 ELSE 4005 CALL MPI_RECV(RHS(1, J), N, MPI_REAL, 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 SMUMPS_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 SMUMPS_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_REAL, 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 SMUMPS_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 SMUMPS_522 ( ONE_PACK, .TRUE. ) 4098 ELSE 4099 IF (NPIV.GT.0) 4100 & CALL SMUMPS_522 ( ONE_PACK, .FALSE.) 4101 ENDIF 4102 ENDIF 4103 ENDDO 4104 CALL SMUMPS_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_REAL, 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_REAL, 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 SMUMPS_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_REAL, 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_REAL, 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 SMUMPS_523() 4199 END IF 4200 RETURN 4201 END SUBROUTINE SMUMPS_522 4202 SUBROUTINE SMUMPS_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 SMUMPS_523 4213 END SUBROUTINE SMUMPS_521 4214 SUBROUTINE SMUMPS_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 REAL 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 REAL :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) 4239 LOGICAL, intent(in) :: LSCAL 4240 INTEGER, intent(in) :: LSCALING 4241 REAL, 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_REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_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_REAL, 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 SMUMPS_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_REAL, 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 SMUMPS_814() 4392 END IF 4393 RETURN 4394 END SUBROUTINE SMUMPS_813 4395 SUBROUTINE SMUMPS_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 SMUMPS_814 4406 END SUBROUTINE SMUMPS_812 4407 SUBROUTINE SMUMPS_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 REAL, dimension(:), pointer :: SCALING 4424 REAL, 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 SMUMPS_535 4477 SUBROUTINE SMUMPS_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 REAL, dimension(:), pointer :: SCALING 4490 REAL, 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 REAL SOL_LOC( LSOL_LOC, BEG_RHS+NRHS+NB_RHSSKIPPED-1) 4498 REAL 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 REAL ZERO 4507 PARAMETER( ZERO = 0.0E0 ) 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 SMUMPS_532 4554 SUBROUTINE SMUMPS_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 REAL 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 REAL, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS 4576 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE 4577 INTEGER INDX 4578 INTEGER allocok 4579 REAL ZERO 4580 PARAMETER( ZERO = 0.0E0 ) 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_REAL, 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 SMUMPS_640() 4678 ENDIF 4679 ENDDO 4680 ENDIF 4681 ENDIF 4682 ENDDO 4683 IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) 4684 & CALL SMUMPS_640() 4685 ENDIF 4686 DEALLOCATE (BUF_INDX, BUF_RHS) 4687 RETURN 4688 CONTAINS 4689 SUBROUTINE SMUMPS_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_REAL, 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 SMUMPS_640 4705 END SUBROUTINE SMUMPS_638 4706 SUBROUTINE SMUMPS_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 SMUMPS_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 SMUMPS_639 4783 SUBROUTINE SMUMPS_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 SMUMPS_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 REAL A( LA ), RHS( LRHS, NRHS ), WCB( LWCB ) 4808 INTEGER LRHS_ROOT 4809 REAL 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 REAL 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 SMUMPS_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 SMUMPS_574 4861 & ( IPOOL(1), LPOOL, III, LEAF, INODE, 4862 & KEEP(208) ) 4863 GOTO 60 4864 ENDIF 4865 BLOQ = ( ( III .EQ. LEAF ) 4866 & ) 4867 CALL SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_150( MYID,COMM,BUFR, 4907 & LBUFR,LBUFR_BYTES ) 4908 RETURN 4909 END SUBROUTINE SMUMPS_248 4910 RECURSIVE SUBROUTINE SMUMPS_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 SMUMPS_OOC 4923 USE SMUMPS_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 REAL WCB( LWCB ), A( LA ) 4942 INTEGER LRHS 4943 REAL 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 REAL ALPHA, ONE 4955 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 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_REAL, 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_REAL, 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_REAL, COMM, IERR ) 5049 END DO 5050 END IF 5051 IF (KEEP(201).GT.0) THEN 5052 CALL SMUMPS_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 sgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, 5065 & WCB( PTRX ), 1, ONE, 5066 & WCB( PTRY ), 1 ) 5067 ELSE 5068 CALL sgemm( '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 sgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, 5076 & WCB( PTRX ), 1, ONE, 5077 & WCB( PTRY ), 1 ) 5078 ELSE 5079 CALL sgemm( '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 SMUMPS_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 SMUMPS_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 SMUMPS_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 SMUMPS_44( MYID, SLAVEF, COMM ) 5168 270 CONTINUE 5169 RETURN 5170 END SUBROUTINE SMUMPS_323 5171 SUBROUTINE SMUMPS_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 SMUMPS_OOC 5191 USE SMUMPS_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 REAL WCB( LWCB ), A( LA ) 5207 REAL 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 REAL RHSCOMP(LRHSCOMP, NRHS) 5216 LOGICAL BUILD_POSINRHSCOMP 5217 EXTERNAL sgemv, strsv, sgemm, strsm, MUMPS_275 5218 INTEGER MUMPS_275 5219 REAL ALPHA,ONE,ZERO 5220 PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) 5221 INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF 5222 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, 5223 & IERR, IFR_ini, 5224 & IFR, LIELL, JJ, 5225 & NELIM, PLEFT, PCB_COURANT, PPIV_COURANT 5226 INTEGER IPOSINRHSCOMP 5227 INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex 5228 LOGICAL FLAG, OMP_FLAG 5229 INCLUDE 'mumps_headers.h' 5230 INTEGER POSWCB1,POSWCB2 5231 INTEGER(8) :: APOSDEB 5232 INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, 5233 & JFIN, NBJ, NUPDATE_PANEL, 5234 & PPIV_PANEL, PCB_PANEL, NBK, TYPEF 5235 INTEGER LD_WCBPIV 5236 INTEGER LD_WCBCB 5237 INTEGER LDAJ, LDAJ_FIRST_PANEL 5238 INTEGER TMP_NBPANELS, 5239 & I_PIVRPTR, I_PIVR, IPANEL 5240 LOGICAL MUST_BE_PERMUTED 5241 INCLUDE 'mpif.h' 5242 INCLUDE 'mumps_tags.h' 5243 INTEGER DUMMY( 1 ) 5244 IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN 5245 LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) 5246 NPIV = LIELL 5247 NELIM = 0 5248 NSLAVES = 0 5249 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) 5250 ELSE 5251 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 5252 LIELL = IW(IPOS-2)+IW(IPOS+1) 5253 NELIM = IW(IPOS-1) 5254 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) 5255 IPOS = IPOS + 1 5256 NPIV = IW(IPOS) 5257 IPOS = IPOS + 1 5258 IF (KEEP(201).GT.0) THEN 5259 CALL SMUMPS_643( 5260 & INODE,PTRFAC,KEEP,A,LA,STEP, 5261 & KEEP8,N,MUST_BE_PERMUTED,IERR) 5262 IF(IERR.LT.0)THEN 5263 INFO(1)=IERR 5264 INFO(2)=0 5265 GOTO 260 5266 ENDIF 5267 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 5268 CALL SMUMPS_755( 5269 & IW(IPOS+1+2*LIELL+1+NSLAVES), 5270 & MUST_BE_PERMUTED ) 5271 ENDIF 5272 ENDIF 5273 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) 5274 IPOS = IPOS + 1 + NSLAVES 5275 END IF 5276 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 5277 J1 = IPOS + 1 5278 J2 = IPOS + LIELL 5279 J3 = IPOS + NPIV 5280 ELSE 5281 J1 = IPOS + LIELL + 1 5282 J2 = IPOS + 2 * LIELL 5283 J3 = IPOS + LIELL + NPIV 5284 END IF 5285 NCB = LIELL-NPIV 5286 IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN 5287 IFR = 0 5288 DO JJ = J1, J3 5289 J = IW( JJ ) 5290 IFR = IFR + 1 5291 DO K=1,NRHS 5292 RHS_ROOT(IFR+NPIV*(K-1)) = RHS(J,K) 5293 END DO 5294 END DO 5295 IF ( NPIV .LT. LIELL ) THEN 5296 WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' 5297 CALL MUMPS_ABORT() 5298 END IF 5299 MYROOT = MYROOT - 1 5300 IF ( MYROOT .EQ. 0 ) THEN 5301 NBFIN = NBFIN - 1 5302 IF (SLAVEF .GT. 1) THEN 5303 DUMMY (1) = 1 5304 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, 5305 & COMM, RACINE_SOLVE, SLAVEF) 5306 ENDIF 5307 END IF 5308 GO TO 270 5309 END IF 5310 APOS = PTRFAC(STEP(INODE)) 5311 IF (KEEP(201).EQ.1) THEN 5312 IF (MTYPE.EQ.1) THEN 5313 IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN 5314 TempNROW= NPIV+NELIM 5315 TempNCOL= NPIV 5316 LDAJ_FIRST_PANEL=TempNROW 5317 ELSE 5318 TempNROW= LIELL 5319 TempNCOL= NPIV 5320 LDAJ_FIRST_PANEL=TempNROW 5321 ENDIF 5322 TYPEF=TYPEF_L 5323 ELSE 5324 TempNCOL= LIELL 5325 TempNROW= NPIV 5326 LDAJ_FIRST_PANEL=TempNCOL 5327 TYPEF= TYPEF_U 5328 ENDIF 5329 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 5330 PANEL_SIZE = SMUMPS_690( LDAJ_FIRST_PANEL ) 5331 ENDIF 5332 PLEFT = PLEFTWCB 5333 PPIV_COURANT = PLEFTWCB 5334 PLEFTWCB = PLEFTWCB + LIELL * NRHS 5335 IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN 5336 INFO(1) = -11 5337 INFO(2) = PLEFTWCB - POSWCB - 1 5338 GO TO 260 5339 END IF 5340 IF (KEEP(201).EQ.1) THEN 5341 LD_WCBPIV = LIELL 5342 LD_WCBCB = LIELL 5343 PCB_COURANT = PPIV_COURANT + NPIV 5344 DO K=1, NRHS 5345 IFR = PPIV_COURANT + (K-1)*LIELL - 1 5346 DO JJ = J1, J3 5347 J = IW(JJ) 5348 IFR = IFR + 1 5349 WCB(IFR) = RHS(J,K) 5350 ENDDO 5351 IF (NCB.GT.0) THEN 5352 DO JJ = J3+1, J2 5353 J = IW(JJ) 5354 IFR = IFR + 1 5355 WCB(IFR) = RHS(J,K) 5356 RHS (J,K) = ZERO 5357 ENDDO 5358 ENDIF 5359 END DO 5360 ELSE 5361 LD_WCBPIV = NPIV 5362 LD_WCBCB = NCB 5363 PCB_COURANT = PPIV_COURANT + NPIV*NRHS 5364 IFR = PPIV_COURANT - 1 5365 OMP_FLAG = NRHS.GT.4 5366 IFR_ini = IFR 5367 DO 130 JJ = J1, J3 5368 J = IW(JJ) 5369 IFR = IFR_ini + (JJ-J1) + 1 5370 DO K=1, NRHS 5371 WCB(IFR+(K-1)*NPIV) = RHS(J,K) 5372 END DO 5373 130 CONTINUE 5374 IFR = PCB_COURANT - 1 5375 IF (NPIV .LT. LIELL) THEN 5376 IFR_ini = IFR 5377 DO 140 JJ = J3 + 1, J2 5378 J = IW(JJ) 5379 IFR = IFR_ini + (JJ-J3) 5380 DO K=1, NRHS 5381 WCB(IFR+(K-1)*NCB) = RHS(J,K) 5382 RHS(J,K)=ZERO 5383 ENDDO 5384 140 CONTINUE 5385 ENDIF 5386 ENDIF 5387 IF ( NPIV .NE. 0 ) THEN 5388 IF (KEEP(201).EQ.1) THEN 5389 APOSDEB = APOS 5390 J = 1 5391 IPANEL = 0 5392 10 CONTINUE 5393 IPANEL = IPANEL + 1 5394 JFIN = min(J+PANEL_SIZE-1, NPIV) 5395 IF (IW(IPOS+ LIELL + JFIN) < 0) THEN 5396 JFIN=JFIN+1 5397 ENDIF 5398 NBJ = JFIN-J+1 5399 LDAJ = LDAJ_FIRST_PANEL-J+1 5400 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN 5401 CALL SMUMPS_667(TYPEF, TMP_NBPANELS, 5402 & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) 5403 IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN 5404 MUST_BE_PERMUTED=.FALSE. 5405 ELSE 5406 CALL SMUMPS_698( 5407 & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- 5408 & IW(I_PIVRPTR)), 5409 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 5410 & IW(I_PIVRPTR+IPANEL-1)-1, 5411 & 5412 & A(APOSDEB), 5413 & LDAJ, NBJ, J-1 ) 5414 ENDIF 5415 ENDIF 5416 NUPDATE_PANEL = LDAJ - NBJ 5417 PPIV_PANEL = PPIV_COURANT+J-1 5418 PCB_PANEL = PPIV_PANEL+NBJ 5419 APOS1 = APOSDEB+int(NBJ,8) 5420 IF (MTYPE.EQ.1) THEN 5421 IF ( NRHS == 1 ) THEN 5422 CALL strsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, 5423 & WCB(PPIV_PANEL), 1 ) 5424 IF (NUPDATE_PANEL.GT.0) THEN 5425 CALL sgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), 5426 & LDAJ, WCB(PPIV_PANEL), 1, ONE, 5427 & WCB(PCB_PANEL), 1) 5428 ENDIF 5429 ELSE 5430 CALL strsm( 'L','L','N','U', NBJ, NRHS, ONE, 5431 & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), 5432 & LIELL ) 5433 IF (NUPDATE_PANEL.GT.0) THEN 5434 CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, 5435 & ALPHA, 5436 & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, 5437 & WCB(PCB_PANEL), LIELL) 5438 ENDIF 5439 ENDIF 5440 ELSE 5441 IF (NRHS == 1) THEN 5442 CALL strsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, 5443 & WCB(PPIV_PANEL), 1 ) 5444 IF (NUPDATE_PANEL.GT.0) THEN 5445 CALL sgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), 5446 & LDAJ, WCB(PPIV_PANEL), 1, 5447 & ONE, WCB(PCB_PANEL), 1 ) 5448 ENDIF 5449 ELSE 5450 CALL strsm('L','L','N','N',NBJ, NRHS, ONE, 5451 & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), 5452 & LIELL) 5453 IF (NUPDATE_PANEL.GT.0) THEN 5454 CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, 5455 & ALPHA, 5456 & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, 5457 & WCB(PCB_PANEL), LIELL) 5458 ENDIF 5459 ENDIF 5460 ENDIF 5461 APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) 5462 J=JFIN+1 5463 IF ( J .LE. NPIV ) GOTO 10 5464 ELSE 5465 IF (KEEP(50).NE.0) THEN 5466 IF ( NRHS == 1 ) THEN 5467 CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, 5468 & WCB(PPIV_COURANT), 1 ) 5469 ELSE 5470 CALL strsm( 'L','U','T','U', NPIV, NRHS, ONE, 5471 & A(APOS), NPIV, WCB(PPIV_COURANT), 5472 & NPIV ) 5473 ENDIF 5474 ELSE 5475 IF ( MTYPE .eq. 1 ) THEN 5476 IF ( NRHS == 1) THEN 5477 CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, 5478 & WCB(PPIV_COURANT), 1 ) 5479 ELSE 5480 CALL strsm( 'L','U','T','U', NPIV, NRHS, ONE, 5481 & A(APOS), LIELL, WCB(PPIV_COURANT), 5482 & NPIV ) 5483 ENDIF 5484 ELSE 5485 IF (NRHS == 1) THEN 5486 CALL strsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, 5487 & WCB(PPIV_COURANT), 1 ) 5488 ELSE 5489 CALL strsm('L','L','N','N',NPIV, NRHS, ONE, 5490 & A(APOS), LIELL, WCB(PPIV_COURANT), 5491 & NPIV) 5492 ENDIF 5493 END IF 5494 END IF 5495 END IF 5496 END IF 5497 NCB = LIELL - NPIV 5498 IF ( MTYPE .EQ. 1 ) THEN 5499 IF ( KEEP(50) .eq. 0 ) THEN 5500 APOS1 = APOS + int(NPIV,8) * int(LIELL,8) 5501 ELSE 5502 APOS1 = APOS + int(NPIV,8) * int(NPIV,8) 5503 END IF 5504 IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN 5505 NUPDATE = NCB 5506 ELSE 5507 NUPDATE = NELIM 5508 END IF 5509 ELSE 5510 APOS1 = APOS + int(NPIV,8) 5511 NUPDATE = NCB 5512 END IF 5513 IF (KEEP(201).NE.1) THEN 5514 IF ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN 5515 IF ( MTYPE .eq. 1 ) THEN 5516 IF ( NRHS == 1 ) THEN 5517 CALL sgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), 5518 & NPIV, WCB(PPIV_COURANT), 1, ONE, 5519 & WCB(PCB_COURANT), 1) 5520 ELSE 5521 CALL sgemm('T', 'N', NUPDATE, NRHS, NPIV, ALPHA, 5522 & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, 5523 & WCB(PCB_COURANT), NCB) 5524 END IF 5525 ELSE 5526 IF ( NRHS == 1 ) THEN 5527 CALL sgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), 5528 & LIELL, WCB(PPIV_COURANT), 1, 5529 & ONE, WCB(PCB_COURANT), 1 ) 5530 ELSE 5531 CALL sgemm('N', 'N', NUPDATE, NRHS, NPIV, ALPHA, 5532 & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, 5533 & WCB(PCB_COURANT), NCB) 5534 END IF 5535 END IF 5536 END IF 5537 END IF 5538 IF (BUILD_POSINRHSCOMP) THEN 5539 POSINRHSCOMP(STEP(INODE)) = RHSCOMPFREEPOS 5540 RHSCOMPFREEPOS = RHSCOMPFREEPOS + NPIV 5541 ENDIF 5542 IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 5543 IF ( KEEP(50) .eq. 0 ) THEN 5544 DO K=1,NRHS 5545 IFR = PPIV_COURANT + (K-1)*LD_WCBPIV 5546 RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = 5547 & WCB(IFR:IFR+NPIV-1) 5548 ENDDO 5549 ELSE 5550 IFR = PPIV_COURANT - 1 5551 IF (KEEP(201).EQ.1) THEN 5552 LDAJ = TempNROW 5553 ELSE 5554 LDAJ = NPIV 5555 ENDIF 5556 APOS1 = APOS 5557 JJ = J1 5558 IF (KEEP(201).EQ.1) THEN 5559 NBK = 0 5560 ENDIF 5561 DO 5562 IF(JJ .GT. J3) EXIT 5563 IFR = IFR + 1 5564 IF(IW(JJ+LIELL) .GT. 0) THEN 5565 DO K=1, NRHS 5566 RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = 5567 & WCB( IFR+(K-1)*LD_WCBPIV ) * A( APOS1 ) 5568 END DO 5569 IF (KEEP(201).EQ.1) THEN 5570 NBK = NBK+1 5571 IF (NBK.EQ.PANEL_SIZE) THEN 5572 NBK = 0 5573 LDAJ = LDAJ - PANEL_SIZE 5574 ENDIF 5575 ENDIF 5576 APOS1 = APOS1 + int(LDAJ + 1,8) 5577 JJ = JJ+1 5578 ELSE 5579 IF (KEEP(201).EQ.1) THEN 5580 NBK = NBK+1 5581 ENDIF 5582 APOS2 = APOS1+int(LDAJ+1,8) 5583 IF (KEEP(201).EQ.1) THEN 5584 APOSOFF = APOS1+int(LDAJ,8) 5585 ELSE 5586 APOSOFF=APOS1+1_8 5587 ENDIF 5588 DO K=1, NRHS 5589 POSWCB1 = IFR+(K-1)*LD_WCBPIV 5590 POSWCB2 = POSWCB1+1 5591 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = WCB(POSWCB1)*A(APOS1) 5592 & + WCB(POSWCB2)*A(APOSOFF) 5593 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = 5594 & WCB(POSWCB1)*A(APOSOFF) 5595 & + WCB(POSWCB2)*A(APOS2) 5596 END DO 5597 IF (KEEP(201).EQ.1) THEN 5598 NBK = NBK+1 5599 IF (NBK.GE.PANEL_SIZE) THEN 5600 LDAJ = LDAJ - NBK 5601 NBK = 0 5602 ENDIF 5603 ENDIF 5604 APOS1 = APOS2 + int(LDAJ + 1,8) 5605 JJ = JJ+2 5606 IFR = IFR+1 5607 ENDIF 5608 ENDDO 5609 END IF 5610 IF (KEEP(201).GT.0) THEN 5611 CALL SMUMPS_598(INODE,PTRFAC,KEEP(28), 5612 & A,LA,.TRUE.,IERR) 5613 IF(IERR.LT.0)THEN 5614 INFO(1)=IERR 5615 INFO(2)=0 5616 GOTO 260 5617 ENDIF 5618 END IF 5619 FPERE = DAD(STEP(INODE)) 5620 IF ( FPERE .EQ. 0 ) THEN 5621 MYROOT = MYROOT - 1 5622 PLEFTWCB = PLEFTWCB - LIELL *NRHS 5623 IF ( MYROOT .EQ. 0 ) THEN 5624 NBFIN = NBFIN - 1 5625 IF (SLAVEF .GT. 1) THEN 5626 DUMMY (1) = 1 5627 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, 5628 & COMM, RACINE_SOLVE, SLAVEF) 5629 ENDIF 5630 END IF 5631 GO TO 270 5632 ENDIF 5633 IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN 5634 IF (MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), 5635 & SLAVEF) .EQ. MYID) THEN 5636 IF ( NCB .ne. 0 ) THEN 5637 PTRICB(STEP(INODE)) = NCB + 1 5638 DO 190 I = 1, NUPDATE 5639 DO K=1, NRHS 5640 RHS( IW(J3 + I), K ) = RHS( IW(J3 + I), K ) 5641 & + WCB(PCB_COURANT + I-1 +(K-1)*LD_WCBCB) 5642 ENDDO 5643 190 CONTINUE 5644 PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE 5645 IF ( PTRICB(STEP(INODE)) == 1 ) THEN 5646 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 5647 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN 5648 IPOOL( LEAF ) = FPERE 5649 LEAF = LEAF + 1 5650 ENDIF 5651 END IF 5652 ELSE 5653 PTRICB(STEP( INODE )) = -1 5654 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 5655 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN 5656 IPOOL( LEAF ) = FPERE 5657 LEAF = LEAF + 1 5658 ENDIF 5659 ENDIF 5660 ELSE 5661 210 CONTINUE 5662 CALL SMUMPS_78( NRHS, INODE, FPERE, NCB, LD_WCBCB, 5663 & NUPDATE, 5664 & IW( J3 + 1 ), WCB( PCB_COURANT ), 5665 & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), 5666 & ContVec, 5667 & COMM, IERR ) 5668 IF ( IERR .EQ. -1 ) THEN 5669 CALL SMUMPS_303( .FALSE., FLAG, 5670 & BUFR, LBUFR, LBUFR_BYTES, 5671 & MYID, SLAVEF, COMM, 5672 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5673 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 5674 & IWCB, LIWCB, 5675 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 5676 & PTRICB, INFO, KEEP,KEEP8, STEP, 5677 & PROCNODE_STEPS, 5678 & RHS, LRHS 5679 & ) 5680 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 5681 GOTO 210 5682 ELSE IF ( IERR .EQ. -2 ) THEN 5683 INFO( 1 ) = -17 5684 INFO( 2 ) = NUPDATE * KEEP( 35 ) + 5685 & ( NUPDATE + 3 ) * KEEP( 34 ) 5686 GOTO 260 5687 ELSE IF ( IERR .EQ. -3 ) THEN 5688 INFO( 1 ) = -20 5689 INFO( 2 ) = NUPDATE * KEEP( 35 ) + 5690 & ( NUPDATE + 3 ) * KEEP( 34 ) 5691 GOTO 260 5692 END IF 5693 ENDIF 5694 END IF 5695 IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 5696 & .and. NPIV .NE. 0 ) THEN 5697 DO ISLAVE = 1, NSLAVES 5698 PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) 5699 CALL MUMPS_49( 5700 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 5701 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 5702 & ISLAVE, NCB - NELIM, 5703 & NSLAVES, 5704 & Effective_CB_Size, FirstIndex ) 5705 222 CALL SMUMPS_72( NRHS, 5706 & INODE, FPERE, 5707 & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, 5708 & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), 5709 & WCB( PPIV_COURANT ), 5710 & PDEST, COMM, IERR ) 5711 IF ( IERR .EQ. -1 ) THEN 5712 CALL SMUMPS_303( .FALSE., FLAG, 5713 & BUFR, LBUFR, LBUFR_BYTES, 5714 & MYID, SLAVEF, COMM, 5715 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5716 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, 5717 & IWCB, LIWCB, 5718 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 5719 & PTRICB, INFO, KEEP,KEEP8, STEP, 5720 & PROCNODE_STEPS, 5721 & RHS, LRHS 5722 & ) 5723 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 5724 GOTO 222 5725 ELSE IF ( IERR .EQ. -2 ) THEN 5726 INFO( 1 ) = -17 5727 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + 5728 & ( Effective_CB_Size + 4 ) * KEEP( 34 ) 5729 GOTO 260 5730 ELSE IF ( IERR .EQ. -3 ) THEN 5731 INFO( 1 ) = -20 5732 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + 5733 & ( Effective_CB_Size + 4 ) * KEEP( 34 ) 5734 GOTO 260 5735 END IF 5736 END DO 5737 END IF 5738 PLEFTWCB = PLEFTWCB - LIELL*NRHS 5739 270 CONTINUE 5740 RETURN 5741 260 CONTINUE 5742 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 5743 RETURN 5744 END SUBROUTINE SMUMPS_302 5745 RECURSIVE SUBROUTINE SMUMPS_303( BLOQ, FLAG, 5746 & BUFR, LBUFR, LBUFR_BYTES, 5747 & MYID, SLAVEF, COMM, 5748 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5749 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, 5750 & IWCB, LIWCB, 5751 & WCB, LWCB, POSWCB, 5752 & PLEFTWCB, POSIWCB, 5753 & PTRICB, INFO, KEEP,KEEP8, STEP, PROCNODE_STEPS, 5754 & RHS, LRHS 5755 & ) 5756 IMPLICIT NONE 5757 LOGICAL BLOQ 5758 INTEGER LBUFR, LBUFR_BYTES 5759 INTEGER MYID, SLAVEF, COMM 5760 INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN 5761 INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB 5762 INTEGER LIW 5763 INTEGER(8) :: LA 5764 INTEGER INFO( 40 ), KEEP( 500) 5765 INTEGER(8) KEEP8(150) 5766 INTEGER BUFR( LBUFR ), IPOOL(LPOOL) 5767 INTEGER NSTK_S( KEEP(28) ) 5768 INTEGER IWCB( LIWCB ) 5769 INTEGER IW( LIW ) 5770 REAL WCB( LWCB ), A( LA ) 5771 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) 5772 INTEGER(8) :: PTRFAC(KEEP(28)) 5773 INTEGER STEP(N) 5774 INTEGER PROCNODE_STEPS(KEEP(28)) 5775 INTEGER LRHS 5776 REAL RHS(LRHS, NRHS) 5777 LOGICAL FLAG 5778 INCLUDE 'mpif.h' 5779 INCLUDE 'mumps_tags.h' 5780 INTEGER IERR, STATUS( MPI_STATUS_SIZE ) 5781 INTEGER MSGSOU, MSGTAG, MSGLEN 5782 FLAG = .FALSE. 5783 IF ( BLOQ ) THEN 5784 CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 5785 & COMM, STATUS, IERR ) 5786 FLAG = .TRUE. 5787 ELSE 5788 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 5789 & FLAG, STATUS, IERR ) 5790 END IF 5791 IF ( FLAG ) THEN 5792 MSGSOU = STATUS( MPI_SOURCE ) 5793 MSGTAG = STATUS( MPI_TAG ) 5794 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 5795 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 5796 INFO(1) = -20 5797 INFO(2) = MSGLEN 5798 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 5799 ELSE 5800 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, 5801 & MSGSOU, MSGTAG, COMM, STATUS, IERR ) 5802 CALL SMUMPS_323( BUFR, LBUFR, LBUFR_BYTES, 5803 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 5804 & N, NRHS, IPOOL, LPOOL, III, LEAF, 5805 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 5806 & IWCB, LIWCB, 5807 & WCB, LWCB, POSWCB, 5808 & PLEFTWCB, POSIWCB, 5809 & PTRICB, INFO, KEEP,KEEP8, STEP, 5810 & PROCNODE_STEPS, 5811 & RHS, LRHS 5812 & ) 5813 END IF 5814 END IF 5815 RETURN 5816 END SUBROUTINE SMUMPS_303 5817 SUBROUTINE SMUMPS_249(N, A, LA, IW, LIW, W, LWC, 5818 & RHS, LRHS, NRHS, 5819 & RHSCOMP, LRHSCOMP, POSINRHSCOMP, 5820 & PTRICB, PTRACB, IWCB, LIWW, W2, 5821 & NE_STEPS, NA, LNA, STEP, 5822 & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, 5823 & MYLEAF, INFO, 5824 & PROCNODE_STEPS, 5825 & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, 5826 & KEEP,KEEP8, RHS_ROOT, LRHS_ROOT, MTYPE, 5827 & 5828 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS 5829 & , TO_PROCESS, SIZE_TO_PROCESS 5830 & ) 5831 USE SMUMPS_OOC 5832 USE SMUMPS_COMM_BUFFER 5833 IMPLICIT NONE 5834 INTEGER MTYPE 5835 INTEGER(8) :: LA 5836 INTEGER N,LIW,LIWW,LWC,LPOOL,LNA 5837 INTEGER SLAVEF,MYLEAF,COMM,MYID 5838 INTEGER LPANEL_POS 5839 INTEGER KEEP( 500 ) 5840 INTEGER(8) KEEP8(150) 5841 INTEGER PROCNODE_STEPS(KEEP(28)) 5842 INTEGER NA(LNA),NE_STEPS(KEEP(28)) 5843 INTEGER IPOOL(LPOOL) 5844 INTEGER PANEL_POS(LPANEL_POS) 5845 INTEGER INFO(40) 5846 INTEGER PTRIST(KEEP(28)), 5847 & PTRICB(KEEP(28)),PTRACB(KEEP(28)) 5848 INTEGER(8) :: PTRFAC(KEEP(28)) 5849 INTEGER LRHS, NRHS 5850 REAL A(LA), RHS(LRHS,NRHS), W(LWC) 5851 REAL W2(KEEP(133)) 5852 INTEGER IW(LIW),IWCB(LIWW) 5853 INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) 5854 INTEGER LBUFR, LBUFR_BYTES 5855 INTEGER BUFR(LBUFR) 5856 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5857 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5858 INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) 5859 REAL RHSCOMP(LRHSCOMP,NRHS) 5860 INTEGER LRHS_ROOT 5861 REAL RHS_ROOT( LRHS_ROOT ) 5862 INTEGER, intent(in) :: SIZE_TO_PROCESS 5863 LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) 5864 INTEGER MUMPS_275 5865 EXTERNAL MUMPS_275 5866 INCLUDE 'mpif.h' 5867 INCLUDE 'mumps_tags.h' 5868 INTEGER IERR 5869 LOGICAL FLAG 5870 INTEGER POSIWCB,POSWCB,K 5871 INTEGER(8) :: APOS, IST 5872 INTEGER NPIV 5873 INTEGER IPOS,LIELL,NELIM,IFR,JJ,I 5874 INTEGER J1,J2,J,NCB,NBFINF 5875 INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS 5876 INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP 5877 INTEGER III,IIPOOL,MYLEAFE 5878 INTEGER NSLAVES 5879 REAL ALPHA,ONE,ZERO 5880 PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) 5881 LOGICAL BLOQ,DEBUT 5882 INTEGER PROCDEST, DEST 5883 INTEGER POSINDICES, IPOSINRHSCOMP 5884 INTEGER DUMMY(1) 5885 INTEGER PLEFTW, PTWCB 5886 INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex 5887 LOGICAL LTLEVEL2, IN_SUBTREE 5888 INTEGER TYPENODE 5889 INCLUDE 'mumps_headers.h' 5890 LOGICAL BLOCK_SEQUENCE 5891 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR 5892 LOGICAL MUST_BE_PERMUTED 5893 LOGICAL NO_CHILDREN 5894 LOGICAL Exploit_Sparsity, AM1 5895 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) 5896 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS 5897 INTEGER LDAJ, NBJ, LIWFAC, 5898 & NBJLAST, NPIV_LAST, PANEL_SIZE, 5899 & PTWCB_PANEL, NCB_PANEL, TYPEF 5900 INTEGER BEG_PANEL 5901 LOGICAL TWOBYTWO 5902 INTEGER NPANELS, IPANEL 5903 LOGICAL MUMPS_170 5904 INTEGER MUMPS_330 5905 EXTERNAL sgemv, strsv, strsm, sgemm, 5906 & MUMPS_330, 5907 & MUMPS_170 5908 PLEFTW = 1 5909 POSIWCB = LIWW 5910 POSWCB = LWC 5911 NROOT = 0 5912 NBLEAF = NA(1) 5913 NBROOT = NA(2) 5914 DO I = NBROOT, 1, -1 5915 INODE = NA(NBLEAF+I+2) 5916 IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)), 5917 & SLAVEF) .EQ. MYID) THEN 5918 NROOT = NROOT + 1 5919 IPOOL(NROOT) = INODE 5920 ENDIF 5921 END DO 5922 III = 1 5923 IIPOOL = NROOT + 1 5924 BLOCK_SEQUENCE = .FALSE. 5925 Exploit_Sparsity = .FALSE. 5926 AM1 = .FALSE. 5927 IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. 5928 IF (KEEP(237).NE.0) AM1 = .TRUE. 5929 NO_CHILDREN = .FALSE. 5930 IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 5931 IF (MYLEAF .EQ. -1) THEN 5932 MYLEAF = 0 5933 DO I=1, NBLEAF 5934 INODE=NA(I+2) 5935 IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)), 5936 & SLAVEF) .EQ. MYID) THEN 5937 MYLEAF = MYLEAF + 1 5938 ENDIF 5939 ENDDO 5940 ENDIF 5941 MYLEAFE=MYLEAF 5942 NBFINF = SLAVEF 5943 IF (MYLEAFE .EQ. 0) THEN 5944 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, 5945 & SLAVEF) 5946 NBFINF = NBFINF - 1 5947 IF (NBFINF .EQ. 0) THEN 5948 GOTO 340 5949 ENDIF 5950 ENDIF 5951 50 CONTINUE 5952 BLOQ = ( ( III .EQ. IIPOOL ) 5953 & ) 5954 CALL SMUMPS_41( BLOQ, FLAG, BUFR, LBUFR, 5955 & LBUFR_BYTES, MYID, SLAVEF, COMM, 5956 & N, IWCB, LIWW, POSIWCB, 5957 & W, LWC, POSWCB, 5958 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 5959 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 5960 & STEP, FRERE, FILS, PROCNODE_STEPS, 5961 & PLEFTW, KEEP,KEEP8, 5962 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 5963 & RHS, LRHS, NRHS, MTYPE, 5964 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 5965 & , TO_PROCESS, SIZE_TO_PROCESS 5966 & ) 5967 IF ( INFO(1) .LT. 0 ) GOTO 340 5968 IF ( .NOT. FLAG ) THEN 5969 IF (III .NE. IIPOOL) THEN 5970 INODE = IPOOL(IIPOOL-1) 5971 IIPOOL = IIPOOL - 1 5972 GO TO 60 5973 ENDIF 5974 END IF 5975 IF ( NBFINF .eq. 0 ) GOTO 340 5976 GOTO 50 5977 60 CONTINUE 5978 IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN 5979 IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) 5980 NPIV = IW(IPOS+3) 5981 LIELL = IW(IPOS) + NPIV 5982 IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) 5983 IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN 5984 J1 = IPOS + LIELL + 1 5985 J2 = IPOS + LIELL + NPIV 5986 ELSE 5987 J1 = IPOS + 1 5988 J2 = IPOS + NPIV 5989 END IF 5990 IFR = 0 5991 DO JJ = J1, J2 5992 J = IW( JJ ) 5993 IFR = IFR + 1 5994 DO K=1,NRHS 5995 RHS(J,K) = RHS_ROOT(IFR+NPIV*(K-1)) 5996 END DO 5997 END DO 5998 IN = INODE 5999 270 IN = FILS(IN) 6000 IF (IN .GT. 0) GOTO 270 6001 IF (IN .EQ. 0) THEN 6002 MYLEAFE = MYLEAFE - 1 6003 IF (MYLEAFE .EQ. 0) THEN 6004 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6005 & FEUILLE, SLAVEF ) 6006 NBFINF = NBFINF - 1 6007 IF (NBFINF .EQ. 0) GOTO 340 6008 ENDIF 6009 GOTO 50 6010 ENDIF 6011 IF = -IN 6012 LONG = NPIV 6013 NBFILS = NE_STEPS(STEP(INODE)) 6014 IF ( AM1 ) THEN 6015 I = NBFILS 6016 NBFILS = 0 6017 DO WHILE (I.GT.0) 6018 IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 6019 IF = FRERE(STEP(IF)) 6020 I = I -1 6021 ENDDO 6022 IF (NBFILS.EQ.0) THEN 6023 NO_CHILDREN = .TRUE. 6024 ELSE 6025 NO_CHILDREN = .FALSE. 6026 ENDIF 6027 IF = -IN 6028 ENDIF 6029 DEBUT = .TRUE. 6030 DO I = 0, SLAVEF - 1 6031 DEJA_SEND( I ) = .FALSE. 6032 END DO 6033 POOL_FIRST_POS=IIPOOL 6034 DO I = 1, NBFILS 6035 IF ( AM1 ) THEN 6036 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 6037 IF = FRERE(STEP(IF)) 6038 GOTO 1030 6039 ENDIF 6040 NO_CHILDREN = .FALSE. 6041 ENDIF 6042 IF (MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) 6043 & .EQ. MYID) THEN 6044 IPOOL(IIPOOL) = IF 6045 IIPOOL = IIPOOL + 1 6046 ELSE 6047 PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)), 6048 & SLAVEF) 6049 IF (.NOT. DEJA_SEND( PROCDEST )) THEN 6050 600 CALL SMUMPS_78( NRHS, IF, 0, 0, 6051 & LONG, LONG, IW( J1 ), 6052 & RHS_ROOT( 1 ), PROCDEST, 6053 & NOEUD, COMM, IERR ) 6054 IF ( IERR .EQ. -1 ) THEN 6055 CALL SMUMPS_41( 6056 & .FALSE., FLAG, 6057 & BUFR, LBUFR, LBUFR_BYTES, 6058 & MYID, SLAVEF, COMM, 6059 & N, IWCB, LIWW, POSIWCB, 6060 & W, LWC, POSWCB, 6061 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6062 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6063 & STEP, FRERE, FILS, PROCNODE_STEPS, 6064 & PLEFTW, KEEP,KEEP8, 6065 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6066 & RHS, LRHS, NRHS, MTYPE, 6067 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6068 & , TO_PROCESS, SIZE_TO_PROCESS 6069 & ) 6070 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 6071 GOTO 600 6072 ELSE IF ( IERR .EQ. -2 ) THEN 6073 INFO( 1 ) = -17 6074 INFO( 2 ) = LONG * KEEP(35) + 6075 & ( LONG + 2 ) * KEEP(34) 6076 GOTO 330 6077 ELSE IF ( IERR .EQ. -3 ) THEN 6078 INFO( 1 ) = -20 6079 INFO( 2 ) = LONG * KEEP(35) + 6080 & ( LONG + 2 ) * KEEP(34) 6081 GOTO 330 6082 END IF 6083 DEJA_SEND( PROCDEST ) = .TRUE. 6084 END IF 6085 IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() 6086 ENDIF 6087 IF = FRERE(STEP(IF)) 6088 ENDDO 6089 IF (AM1 .AND.NO_CHILDREN) THEN 6090 MYLEAFE = MYLEAFE - 1 6091 IF (MYLEAFE .EQ. 0) THEN 6092 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6093 & FEUILLE, SLAVEF ) 6094 NBFINF = NBFINF - 1 6095 IF (NBFINF .EQ. 0) GOTO 340 6096 GOTO 50 6097 ENDIF 6098 ENDIF 6099 IF (IIPOOL.NE.POOL_FIRST_POS) THEN 6100 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 6101 TMP=IPOOL(POOL_FIRST_POS+I-1) 6102 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 6103 IPOOL(IIPOOL-I)=TMP 6104 ENDDO 6105 ENDIF 6106 GOTO 50 6107 END IF 6108 IN_SUBTREE = MUMPS_170( 6109 & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 6110 TYPENODE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)), 6111 & SLAVEF) 6112 LTLEVEL2= ( 6113 & (TYPENODE .eq.2 ) .AND. 6114 & (MTYPE.NE.1) ) 6115 NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) 6116 IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN 6117 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 6118 LIELL = IW(IPOS-2)+IW(IPOS+1) 6119 NELIM = IW(IPOS-1) 6120 IPOS = IPOS + 1 6121 NPIV = IW(IPOS) 6122 NCB = LIELL - NPIV - NELIM 6123 IPOS = IPOS + 2 6124 NSLAVES = IW( IPOS ) 6125 Offset = 0 6126 IPOS = IPOS + NSLAVES 6127 IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES 6128 IF ( POSIWCB - 2 .LT. 0 .or. 6129 & POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN 6130 CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, 6131 & POSWCB, POSIWCB, PTRICB, PTRACB) 6132 IF ( POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN 6133 INFO( 1 ) = -11 6134 INFO( 2 ) = NCB * NRHS - POSWCB - PLEFTW + 1 6135 GOTO 330 6136 END IF 6137 IF ( POSIWCB - 2 .LT. 0 ) THEN 6138 INFO( 1 ) = -14 6139 INFO( 2 ) = 2 - POSIWCB 6140 GO TO 330 6141 END IF 6142 END IF 6143 POSIWCB = POSIWCB - 2 6144 POSWCB = POSWCB - NCB*NRHS 6145 PTRICB(STEP( INODE )) = POSIWCB + 1 6146 PTRACB(STEP( INODE )) = POSWCB + 1 6147 IWCB( PTRICB(STEP( INODE )) ) = NCB 6148 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 6149 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 6150 POSINDICES = IPOS + LIELL + 1 6151 ELSE 6152 POSINDICES = IPOS + 1 6153 END IF 6154 IF ( NCB.EQ.0 ) THEN 6155 write(6,*) ' Internal Error type 2 node with no CB ' 6156 CALL MUMPS_ABORT() 6157 ENDIF 6158 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 6159 J1 = IPOS + LIELL + NPIV + NELIM +1 6160 J2 = IPOS + 2 * LIELL 6161 ELSE 6162 J1 = IPOS + NPIV + NELIM +1 6163 J2 = IPOS + LIELL 6164 END IF 6165 IFR = PTRACB(STEP( INODE )) - 1 6166 DO JJ = J1, J2 - KEEP(253) 6167 J = IW(JJ) 6168 IFR = IFR + 1 6169 DO K=1, NRHS 6170 W(IFR+(K-1)*NCB) = RHS(J,K) 6171 ENDDO 6172 ENDDO 6173 IF (KEEP(252).NE.0) THEN 6174 DO JJ = J2-KEEP(253)+1, J2 6175 IFR = IFR + 1 6176 DO K=1, NRHS 6177 IF (K.EQ.JJ-J2+KEEP(253)) THEN 6178 W(IFR+(K-1)*NCB) = ALPHA 6179 ELSE 6180 W(IFR+(K-1)*NCB) = ZERO 6181 ENDIF 6182 ENDDO 6183 ENDDO 6184 ENDIF 6185 DO ISLAVE = 1, NSLAVES 6186 CALL MUMPS_49( 6187 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 6188 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 6189 & ISLAVE, NCB, 6190 & NSLAVES, 6191 & EffectiveSize, 6192 & FirstIndex ) 6193 500 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) 6194 CALL SMUMPS_63(NRHS, INODE, 6195 & W(Offset+PTRACB(STEP(INODE))), EffectiveSize, 6196 & NCB, DEST, 6197 & BACKSLV_MASTER2SLAVE, 6198 & COMM, IERR ) 6199 IF ( IERR .EQ. -1 ) THEN 6200 CALL SMUMPS_41( 6201 & .FALSE., FLAG, 6202 & BUFR, LBUFR, LBUFR_BYTES, 6203 & MYID, SLAVEF, COMM, 6204 & N, IWCB, LIWW, POSIWCB, 6205 & W, LWC, POSWCB, 6206 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6207 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6208 & STEP, FRERE, FILS, 6209 & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 6210 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6211 & RHS, LRHS, NRHS, MTYPE, 6212 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6213 & , TO_PROCESS, SIZE_TO_PROCESS 6214 & ) 6215 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 6216 GOTO 500 6217 ELSE IF ( IERR .EQ. -2 ) THEN 6218 INFO( 1 ) = -17 6219 INFO( 2 ) = EffectiveSize * KEEP(35) + 6220 & 2 * KEEP(34) 6221 GOTO 330 6222 ELSE IF ( IERR .EQ. -3 ) THEN 6223 INFO( 1 ) = -20 6224 INFO( 2 ) = EffectiveSize * KEEP(35) + 6225 & 2 * KEEP(34) 6226 GOTO 330 6227 END IF 6228 Offset = Offset + EffectiveSize 6229 END DO 6230 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 6231 CALL SMUMPS_151(NRHS,N, KEEP(28), IWCB, LIWW, W, LWC, 6232 & POSWCB,POSIWCB,PTRICB,PTRACB) 6233 GOTO 50 6234 ENDIF 6235 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 6236 LIELL = IW(IPOS-2)+IW(IPOS+1) 6237 NELIM = IW(IPOS-1) 6238 IPOS = IPOS + 1 6239 NPIV = IW(IPOS) 6240 IPOS = IPOS + 1 6241 IF (KEEP(201).GT.0) THEN 6242 CALL SMUMPS_643( 6243 & INODE,PTRFAC,KEEP,A,LA,STEP, 6244 & KEEP8,N,MUST_BE_PERMUTED,IERR) 6245 IF(IERR.LT.0)THEN 6246 INFO(1)=IERR 6247 INFO(2)=0 6248 GOTO 330 6249 ENDIF 6250 ENDIF 6251 APOS = PTRFAC(IW(IPOS)) 6252 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) 6253 IPOS = IPOS + 1 + NSLAVES 6254 IF (KEEP(201).EQ.1) THEN 6255 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 6256 IF (MTYPE.NE.1) THEN 6257 TYPEF = TYPEF_L 6258 ELSE 6259 TYPEF = TYPEF_U 6260 ENDIF 6261 PANEL_SIZE = SMUMPS_690( LIELL ) 6262 IF (KEEP(50).NE.1) THEN 6263 CALL SMUMPS_755( 6264 & IW(IPOS+1+2*LIELL), 6265 & MUST_BE_PERMUTED ) 6266 ENDIF 6267 ENDIF 6268 LONG = 0 6269 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 6270 J1 = IPOS + 1 6271 J2 = IPOS + NPIV 6272 ELSE 6273 J1 = IPOS + LIELL + 1 6274 J2 = IPOS + NPIV + LIELL 6275 END IF 6276 IF (IN_SUBTREE) THEN 6277 PTWCB = PLEFTW 6278 IF ( POSWCB .LT. LIELL*NRHS ) THEN 6279 CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, 6280 & POSWCB, POSIWCB, PTRICB, PTRACB) 6281 IF ( POSWCB .LT. LIELL*NRHS ) THEN 6282 INFO(1) = -11 6283 INFO(2) = LIELL*NRHS - POSWCB 6284 GOTO 330 6285 END IF 6286 END IF 6287 ELSE 6288 IF ( POSIWCB - 2 .LT. 0 .or. 6289 & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 6290 CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, 6291 & POSWCB, POSIWCB, PTRICB, PTRACB) 6292 IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 6293 INFO( 1 ) = -11 6294 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 6295 GOTO 330 6296 END IF 6297 IF ( POSIWCB - 2 .LT. 0 ) THEN 6298 INFO( 1 ) = -14 6299 INFO( 2 ) = 2 - POSIWCB 6300 GO TO 330 6301 END IF 6302 END IF 6303 POSIWCB = POSIWCB - 2 6304 POSWCB = POSWCB - LIELL*NRHS 6305 PTRICB(STEP( INODE )) = POSIWCB + 1 6306 PTRACB(STEP( INODE )) = POSWCB + 1 6307 IWCB( PTRICB(STEP( INODE )) ) = LIELL 6308 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 6309 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 6310 POSINDICES = IPOS + LIELL + 1 6311 ELSE 6312 POSINDICES = IPOS + 1 6313 END IF 6314 PTWCB = PTRACB(STEP( INODE )) 6315 ENDIF 6316 IF (KEEP(252).EQ.0) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 6317 DO K=1, NRHS 6318 IF (KEEP(252).NE.0) THEN 6319 DO JJ = J1, J2 6320 W(PTWCB+JJ-J1+(K-1)*LIELL) = ZERO 6321 ENDDO 6322 ELSE 6323 DO JJ = J1, J2 6324 W(PTWCB+JJ-J1+(K-1)*LIELL) = RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 6325 ENDDO 6326 ENDIF 6327 END DO 6328 IFR = PTWCB + NPIV - 1 6329 IF ( LIELL .GT. NPIV ) THEN 6330 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 6331 J1 = IPOS + LIELL + NPIV + 1 6332 J2 = IPOS + 2 * LIELL 6333 ELSE 6334 J1 = IPOS + NPIV + 1 6335 J2 = IPOS + LIELL 6336 END IF 6337 DO JJ = J1, J2-KEEP(253) 6338 J = IW(JJ) 6339 IFR = IFR + 1 6340 DO K=1, NRHS 6341 W(IFR+(K-1)*LIELL) = RHS(J,K) 6342 ENDDO 6343 ENDDO 6344 IF (KEEP(252).NE.0) THEN 6345 DO JJ = J2-KEEP(253)+1, J2 6346 IFR = IFR + 1 6347 DO K=1, NRHS 6348 IF (K.EQ.JJ-J2+KEEP(253)) THEN 6349 W(IFR+(K-1)*LIELL) = ALPHA 6350 ELSE 6351 W(IFR+(K-1)*LIELL) = ZERO 6352 ENDIF 6353 ENDDO 6354 ENDDO 6355 ENDIF 6356 NCB = LIELL - NPIV 6357 IF (NPIV .EQ. 0) GOTO 160 6358 ENDIF 6359 IF (KEEP(201).EQ.1) THEN 6360 J = NPIV / PANEL_SIZE 6361 TWOBYTWO = KEEP(50).EQ.2 .AND. 6362 & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. 6363 & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) 6364 IF (TWOBYTWO) THEN 6365 CALL SMUMPS_641(PANEL_SIZE, PANEL_POS, LPANEL_POS, 6366 & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, 6367 & NBENTRIES_ALLPANELS) 6368 ELSE 6369 IF (NPIV.EQ.J*PANEL_SIZE) THEN 6370 NPIV_LAST = NPIV 6371 NBJLAST = PANEL_SIZE 6372 NPANELS = J 6373 ELSE 6374 NPIV_LAST = (J+1)* PANEL_SIZE 6375 NBJLAST = NPIV-J*PANEL_SIZE 6376 NPANELS = J+1 6377 ENDIF 6378 NBENTRIES_ALLPANELS = 6379 & int(LIELL,8) * int(NPIV,8) 6380 & - int( ( J * ( J - 1 ) ) / 2,8 ) 6381 & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) 6382 & - int(J,8) 6383 & * int(mod(NPIV, PANEL_SIZE),8) 6384 & * int(PANEL_SIZE,8) 6385 JJ=NPIV_LAST 6386 ENDIF 6387 APOSDEB = APOS + NBENTRIES_ALLPANELS 6388 DO IPANEL = NPANELS, 1, -1 6389 IF (TWOBYTWO) THEN 6390 NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) 6391 BEG_PANEL = PANEL_POS(IPANEL) 6392 ELSE 6393 IF (JJ.EQ.NPIV_LAST) THEN 6394 NBJ = NBJLAST 6395 ELSE 6396 NBJ = PANEL_SIZE 6397 ENDIF 6398 BEG_PANEL = JJ- PANEL_SIZE+1 6399 ENDIF 6400 LDAJ = LIELL-BEG_PANEL+1 6401 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) 6402 PTWCB_PANEL = PTWCB + BEG_PANEL - 1 6403 NCB_PANEL = LDAJ - NBJ 6404 IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN 6405 CALL SMUMPS_667(TYPEF, TMP_NBPANELS, 6406 & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) 6407 IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN 6408 MUST_BE_PERMUTED=.FALSE. 6409 ELSE 6410 CALL SMUMPS_698( 6411 & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), 6412 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 6413 & IW(I_PIVRPTR+IPANEL-1)-1, 6414 & A(APOSDEB), 6415 & LDAJ, NBJ, BEG_PANEL-1) 6416 ENDIF 6417 ENDIF 6418 IF ( NRHS == 1 ) THEN 6419 IF (NCB_PANEL.NE.0) THEN 6420 CALL sgemv( 'T', NCB_PANEL, NBJ, ALPHA, 6421 & A( APOSDEB + int(NBJ,8) ), LDAJ, 6422 & W( NBJ + PTWCB_PANEL ), 6423 & 1, ONE, 6424 & W(PTWCB_PANEL), 1 ) 6425 ENDIF 6426 IF (MTYPE.NE.1) THEN 6427 CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 6428 & W(PTWCB_PANEL), 1) 6429 ELSE 6430 CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, 6431 & W(PTWCB_PANEL), 1) 6432 ENDIF 6433 ELSE 6434 IF (NCB_PANEL.NE.0) THEN 6435 CALL sgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, 6436 & A(APOSDEB +int(NBJ,8)), LDAJ, 6437 & W(NBJ+PTWCB_PANEL),LIELL, 6438 & ONE, W(PTWCB_PANEL),LIELL) 6439 ENDIF 6440 IF (MTYPE.NE.1) THEN 6441 CALL strsm('L','L','T','U',NBJ, NRHS, ONE, 6442 & A(APOSDEB), 6443 & LDAJ, W(PTWCB_PANEL), LIELL) 6444 ELSE 6445 CALL strsm('L','L','T','N',NBJ, NRHS, ONE, 6446 & A(APOSDEB), 6447 & LDAJ, W(PTWCB_PANEL), LIELL) 6448 ENDIF 6449 ENDIF 6450 IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 6451 ENDDO 6452 ENDIF 6453 IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 6454 IF ( LIELL .GT. NPIV ) THEN 6455 IF ( MTYPE .eq. 1 ) THEN 6456 IST = APOS + int(NPIV,8) 6457 IF (NRHS == 1) THEN 6458 CALL sgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, 6459 & W(NPIV + PTWCB), 1, 6460 & ONE, 6461 & W(PTWCB), 1 ) 6462 ELSE 6463 CALL sgemm('T','N', NPIV, NRHS, NCB, ALPHA, A(IST), LIELL, 6464 & W(NPIV+PTWCB), LIELL, ONE, 6465 & W(PTWCB), LIELL) 6466 ENDIF 6467 ELSE 6468 IF ( KEEP(50) .eq. 0 ) THEN 6469 IST = APOS + int(NPIV,8) * int(LIELL,8) 6470 ELSE 6471 IST = APOS + int(NPIV,8) * int(NPIV,8) 6472 END IF 6473 IF ( NRHS == 1 ) THEN 6474 CALL sgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, 6475 & W( NPIV + PTWCB ), 6476 & 1, ONE, 6477 & W(PTWCB), 1 ) 6478 ELSE 6479 CALL sgemm( 'N', 'N', NPIV, NRHS, NCB, ALPHA, 6480 & A(IST), NPIV, W(NPIV+PTWCB),LIELL, 6481 & ONE, W(PTWCB),LIELL) 6482 END IF 6483 END IF 6484 ENDIF 6485 IF ( MTYPE .eq. 1 ) THEN 6486 IF ( NRHS == 1 ) THEN 6487 CALL strsv('L', 'T', 'N', NPIV, A(APOS), LIELL, 6488 & W(PTWCB), 1) 6489 ELSE 6490 CALL strsm('L','L','T','N', NPIV, NRHS, ONE, A(APOS), 6491 & LIELL, W(PTWCB), LIELL) 6492 ENDIF 6493 ELSE 6494 IF ( KEEP(50) .EQ. 0 ) THEN 6495 IF ( NRHS == 1 ) THEN 6496 CALL strsv('U','N','U', NPIV, A(APOS), LIELL, 6497 & W(PTWCB), 1) 6498 ELSE 6499 CALL strsm('L','U','N','U', NPIV, NRHS, ONE, A(APOS), 6500 & LIELL,W(PTWCB),LIELL) 6501 END IF 6502 ELSE 6503 IF ( NRHS == 1 ) THEN 6504 CALL strsv('U','N','U', NPIV, A(APOS), NPIV, 6505 & W(PTWCB), 1) 6506 ELSE 6507 CALL strsm('L','U','N','U',NPIV, NRHS, ONE, A(APOS), 6508 & NPIV, W(PTWCB), LIELL) 6509 END IF 6510 END IF 6511 END IF 6512 ENDIF 6513 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN 6514 J1 = IPOS + LIELL + 1 6515 ELSE 6516 J1 = IPOS + 1 6517 END IF 6518 DO 150 I = 1, NPIV 6519 JJ = IW(J1 + I - 1) 6520 DO K=1, NRHS 6521 RHS(JJ, K) = W(PTWCB+I-1+(K-1)*LIELL) 6522 ENDDO 6523 150 CONTINUE 6524 160 CONTINUE 6525 IF (KEEP(201).GT.0) THEN 6526 CALL SMUMPS_598(INODE,PTRFAC,KEEP(28), 6527 & A,LA,.TRUE.,IERR) 6528 IF(IERR.LT.0)THEN 6529 INFO(1)=IERR 6530 INFO(2)=0 6531 GOTO 330 6532 ENDIF 6533 ENDIF 6534 IN = INODE 6535 170 IN = FILS(IN) 6536 IF (IN .GT. 0) GOTO 170 6537 IF (IN .EQ. 0) THEN 6538 MYLEAFE = MYLEAFE - 1 6539 IF (MYLEAFE .EQ. 0) THEN 6540 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6541 & FEUILLE, SLAVEF ) 6542 NBFINF = NBFINF - 1 6543 IF (NBFINF .EQ. 0) GOTO 340 6544 ENDIF 6545 GOTO 50 6546 ENDIF 6547 IF = -IN 6548 NBFILS = NE_STEPS(STEP(INODE)) 6549 IF (AM1) THEN 6550 I = NBFILS 6551 NBFILS = 0 6552 DO WHILE (I.GT.0) 6553 IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 6554 IF = FRERE(STEP(IF)) 6555 I = I -1 6556 ENDDO 6557 IF (NBFILS.EQ.0) THEN 6558 NO_CHILDREN = .TRUE. 6559 ELSE 6560 NO_CHILDREN = .FALSE. 6561 ENDIF 6562 IF = -IN 6563 ENDIF 6564 IF (IN_SUBTREE) THEN 6565 DO I = 1, NBFILS 6566 IF ( AM1 ) THEN 6567 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 6568 IF = FRERE(STEP(IF)) 6569 GOTO 1010 6570 ENDIF 6571 NO_CHILDREN = .FALSE. 6572 ENDIF 6573 IPOOL((IIPOOL-I+1)+NBFILS-I) = IF 6574 IIPOOL = IIPOOL + 1 6575 IF = FRERE(STEP(IF)) 6576 ENDDO 6577 IF (AM1 .AND. NO_CHILDREN) THEN 6578 MYLEAFE = MYLEAFE - 1 6579 IF (MYLEAFE .EQ. 0) THEN 6580 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6581 & FEUILLE, SLAVEF ) 6582 NBFINF = NBFINF - 1 6583 IF (NBFINF .EQ. 0) GOTO 340 6584 GOTO 50 6585 ENDIF 6586 ENDIF 6587 ELSE 6588 DEBUT = .TRUE. 6589 DO I = 0, SLAVEF - 1 6590 DEJA_SEND( I ) = .FALSE. 6591 END DO 6592 POOL_FIRST_POS=IIPOOL 6593 DO 190 I = 1, NBFILS 6594 IF ( AM1 ) THEN 65951020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 6596 IF = FRERE(STEP(IF)) 6597 GOTO 1020 6598 ENDIF 6599 NO_CHILDREN = .FALSE. 6600 ENDIF 6601 IF (MUMPS_275(PROCNODE_STEPS(STEP(IF)), 6602 & SLAVEF) .EQ. MYID) THEN 6603 IPOOL(IIPOOL) = IF 6604 IIPOOL = IIPOOL + 1 6605 IF = FRERE(STEP(IF)) 6606 ELSE 6607 PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) 6608 IF (.not. DEJA_SEND( PROCDEST )) THEN 6609 400 CONTINUE 6610 CALL SMUMPS_78( NRHS, IF, 0, 0, LIELL, 6611 & LIELL - KEEP(253), 6612 & IW( POSINDICES ), 6613 & W ( PTRACB(STEP( INODE ))), PROCDEST, 6614 & NOEUD, COMM, IERR ) 6615 IF ( IERR .EQ. -1 ) THEN 6616 CALL SMUMPS_41( 6617 & .FALSE., FLAG, 6618 & BUFR, LBUFR, LBUFR_BYTES, 6619 & MYID, SLAVEF, COMM, 6620 & N, IWCB, LIWW, POSIWCB, 6621 & W, LWC, POSWCB, 6622 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6623 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6624 & STEP, FRERE, FILS, PROCNODE_STEPS, 6625 & PLEFTW, KEEP,KEEP8, 6626 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6627 & RHS, LRHS, NRHS, MTYPE, 6628 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6629 & , TO_PROCESS, SIZE_TO_PROCESS 6630 & ) 6631 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 6632 GOTO 400 6633 ELSE IF ( IERR .EQ. -2 ) THEN 6634 INFO( 1 ) = -17 6635 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 6636 GOTO 330 6637 ELSE IF ( IERR .EQ. -3 ) THEN 6638 INFO( 1 ) = -20 6639 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 6640 GOTO 330 6641 END IF 6642 DEJA_SEND( PROCDEST ) = .TRUE. 6643 END IF 6644 IF = FRERE(STEP(IF)) 6645 ENDIF 6646 190 CONTINUE 6647 IF (AM1 .AND. NO_CHILDREN) THEN 6648 MYLEAFE = MYLEAFE - 1 6649 IF (MYLEAFE .EQ. 0) THEN 6650 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 6651 & FEUILLE, SLAVEF ) 6652 NBFINF = NBFINF - 1 6653 IF (NBFINF .EQ. 0) GOTO 340 6654 GOTO 50 6655 ENDIF 6656 ENDIF 6657 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 6658 TMP=IPOOL(POOL_FIRST_POS+I-1) 6659 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 6660 IPOOL(IIPOOL-I)=TMP 6661 ENDDO 6662 IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 6663 CALL SMUMPS_151(NRHS,N, KEEP(28), IWCB, LIWW, 6664 & W, LWC, 6665 & POSWCB,POSIWCB,PTRICB,PTRACB) 6666 ENDIF 6667 GOTO 50 6668 330 CONTINUE 6669 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, 6670 & SLAVEF) 6671 340 CONTINUE 6672 CALL SMUMPS_150( MYID,COMM,BUFR, 6673 & LBUFR,LBUFR_BYTES ) 6674 RETURN 6675 END SUBROUTINE SMUMPS_249 6676 RECURSIVE SUBROUTINE SMUMPS_41( 6677 & BLOQ, FLAG, 6678 & BUFR, LBUFR, LBUFR_BYTES, 6679 & MYID, SLAVEF, COMM, 6680 & N, IWCB, LIWW, POSIWCB, 6681 & W, LWC, POSWCB, 6682 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6683 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 6684 & STEP, FRERE, FILS, PROCNODE_STEPS, 6685 & PLEFTW, KEEP,KEEP8, 6686 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, RHS, 6687 & LRHS, NRHS, MTYPE, 6688 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6689 & , TO_PROCESS, SIZE_TO_PROCESS 6690 & ) 6691 IMPLICIT NONE 6692 LOGICAL BLOQ, FLAG 6693 INTEGER LBUFR, LBUFR_BYTES 6694 INTEGER BUFR( LBUFR ) 6695 INTEGER MYID, SLAVEF, COMM 6696 INTEGER N, LIWW 6697 INTEGER IWCB( LIWW ) 6698 INTEGER LWC 6699 REAL W( LWC ) 6700 INTEGER POSIWCB, POSWCB 6701 INTEGER IIPOOL, LPOOL 6702 INTEGER IPOOL( LPOOL ) 6703 INTEGER LPANEL_POS 6704 INTEGER PANEL_POS( LPANEL_POS ) 6705 INTEGER NBFINF, INFO(40) 6706 INTEGER PLEFTW, KEEP( 500) 6707 INTEGER(8) KEEP8(150) 6708 INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) 6709 INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 6710 INTEGER LIW 6711 INTEGER(8) :: LA 6712 INTEGER PTRIST(KEEP(28)), IW( LIW ) 6713 INTEGER (8) :: PTRFAC(KEEP(28)) 6714 REAL A( LA ), W2( KEEP(133) ) 6715 INTEGER LRHS, NRHS 6716 REAL RHS(LRHS, NRHS) 6717 INTEGER MYLEAFE, MTYPE 6718 INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) 6719 REAL RHSCOMP(LRHSCOMP,NRHS) 6720 INTEGER SIZE_TO_PROCESS 6721 LOGICAL TO_PROCESS(SIZE_TO_PROCESS) 6722 INCLUDE 'mpif.h' 6723 INCLUDE 'mumps_tags.h' 6724 INTEGER MSGSOU, MSGTAG, MSGLEN 6725 INTEGER STATUS( MPI_STATUS_SIZE ), IERR 6726 FLAG = .FALSE. 6727 IF ( BLOQ ) THEN 6728 CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 6729 & COMM, STATUS, IERR ) 6730 FLAG = .TRUE. 6731 ELSE 6732 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 6733 & FLAG, STATUS, IERR ) 6734 END IF 6735 IF (FLAG) THEN 6736 MSGSOU=STATUS(MPI_SOURCE) 6737 MSGTAG=STATUS(MPI_TAG) 6738 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 6739 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 6740 INFO(1) = -20 6741 INFO(2) = MSGLEN 6742 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 6743 ELSE 6744 CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, 6745 & MSGTAG, COMM, STATUS, IERR) 6746 CALL SMUMPS_42( MSGTAG, MSGSOU, 6747 & BUFR, LBUFR, LBUFR_BYTES, 6748 & MYID, SLAVEF, COMM, 6749 & N, IWCB, LIWW, POSIWCB, 6750 & W, LWC, POSWCB, 6751 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6752 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 6753 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, 6754 & KEEP,KEEP8, 6755 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6756 & RHS, LRHS, NRHS, MTYPE, 6757 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6758 & , TO_PROCESS, SIZE_TO_PROCESS 6759 & ) 6760 END IF 6761 END IF 6762 RETURN 6763 END SUBROUTINE SMUMPS_41 6764 RECURSIVE SUBROUTINE SMUMPS_42( 6765 & MSGTAG, MSGSOU, 6766 & BUFR, LBUFR, LBUFR_BYTES, 6767 & MYID, SLAVEF, COMM, 6768 & N, IWCB, LIWW, POSIWCB, 6769 & W, LWC, POSWCB, 6770 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 6771 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 6772 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 6773 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 6774 & RHS, LRHS, NRHS, MTYPE, 6775 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 6776 & , TO_PROCESS, SIZE_TO_PROCESS 6777 & ) 6778 USE SMUMPS_OOC 6779 USE SMUMPS_COMM_BUFFER 6780 IMPLICIT NONE 6781 INTEGER MSGTAG, MSGSOU 6782 INTEGER LBUFR, LBUFR_BYTES 6783 INTEGER BUFR( LBUFR ) 6784 INTEGER MYID, SLAVEF, COMM 6785 INTEGER N, LIWW 6786 INTEGER IWCB( LIWW ) 6787 INTEGER LWC 6788 REAL W( LWC ) 6789 INTEGER POSIWCB, POSWCB 6790 INTEGER IIPOOL, LPOOL, LPANEL_POS 6791 INTEGER IPOOL( LPOOL ) 6792 INTEGER PANEL_POS( LPANEL_POS ) 6793 INTEGER NBFINF, INFO(40) 6794 INTEGER PLEFTW, KEEP( 500) 6795 INTEGER(8) KEEP8(150) 6796 INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 6797 INTEGER FRERE(KEEP(28)) 6798 INTEGER PROCNODE_STEPS(KEEP(28)) 6799 INTEGER LIW 6800 INTEGER(8) :: LA 6801 INTEGER IW( LIW ), PTRIST( KEEP(28) ) 6802 INTEGER(8) :: PTRFAC(KEEP(28)) 6803 REAL A( LA ), W2( KEEP(133) ) 6804 INTEGER LRHS, NRHS 6805 REAL RHS(LRHS, NRHS) 6806 INTEGER MYLEAFE, MTYPE 6807 INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) 6808 REAL RHSCOMP(LRHSCOMP,NRHS) 6809 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR 6810 LOGICAL MUST_BE_PERMUTED 6811 INTEGER SIZE_TO_PROCESS 6812 LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN 6813 INCLUDE 'mpif.h' 6814 INCLUDE 'mumps_tags.h' 6815 INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) 6816 INTEGER P_UPDATE, P_SOL_MAS, LIELL, K 6817 INTEGER(8) :: APOS, IST 6818 INTEGER NPIV, NROW_L, IPOS, NROW_RECU 6819 INTEGER I, JJ, IN, PROCDEST, J1, J2, IFR, LDA 6820 INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, 6821 & IPOSINRHSCOMP 6822 LOGICAL FLAG 6823 REAL ZERO, ALPHA, ONE 6824 PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) 6825 INCLUDE 'mumps_headers.h' 6826 INTEGER POOL_FIRST_POS, TMP 6827 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) 6828 INTEGER MUMPS_275 6829 EXTERNAL MUMPS_275, strsv, strsm, sgemv, sgemm 6830 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS 6831 INTEGER LDAJ, NBJ, LIWFAC, 6832 & NBJLAST, NPIV_LAST, PANEL_SIZE, 6833 & PTWCB_PANEL, NCB_PANEL, TYPEF 6834 LOGICAL TWOBYTWO 6835 INTEGER BEG_PANEL 6836 INTEGER IPANEL, NPANELS 6837 IF (MSGTAG .EQ. FEUILLE) THEN 6838 NBFINF = NBFINF - 1 6839 ELSE IF (MSGTAG .EQ. NOEUD) THEN 6840 POSITION = 0 6841 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6842 & INODE, 1, MPI_INTEGER, 6843 & COMM, IERR) 6844 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6845 & LONG, 1, MPI_INTEGER, 6846 & COMM, IERR) 6847 IF ( POSIWCB - LONG - 2 .LT. 0 6848 & .OR. POSWCB - PLEFTW + 1 .LT. LONG ) THEN 6849 CALL SMUMPS_95(NRHS, N, KEEP(28), IWCB, 6850 & LIWW, W, LWC, 6851 & POSWCB, POSIWCB, PTRICB, PTRACB) 6852 IF ((POSIWCB - LONG - 2 ) .LT. 0) THEN 6853 INFO(1)=-14 6854 INFO(2)=-POSIWCB + LONG + 2 6855 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 6856 GOTO 260 6857 END IF 6858 IF ( POSWCB - PLEFTW + 1 .LT. LONG ) THEN 6859 INFO(1) = -11 6860 INFO(2) = LONG + PLEFTW - POSWCB - 1 6861 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 6862 GOTO 260 6863 END IF 6864 ENDIF 6865 POSIWCB = POSIWCB - LONG 6866 POSWCB = POSWCB - LONG 6867 IF (LONG .GT. 0) THEN 6868 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6869 & IWCB(POSIWCB + 1), 6870 & LONG, MPI_INTEGER, COMM, IERR) 6871 DO K=1,NRHS 6872 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 6873 & W(POSWCB + 1), LONG, 6874 & MPI_REAL, COMM, IERR) 6875 DO JJ=0, LONG-1 6876 RHS(IWCB(POSIWCB+1+JJ),K) = W(POSWCB+1+JJ) 6877 ENDDO 6878 ENDDO 6879 POSIWCB = POSIWCB + LONG 6880 POSWCB = POSWCB + LONG 6881 ENDIF 6882 POOL_FIRST_POS = IIPOOL 6883 IF ( KEEP(237).GT. 0 ) THEN 6884 IF (.NOT.TO_PROCESS(STEP(INODE))) 6885 & GOTO 1010 6886 ENDIF 6887 IPOOL( IIPOOL ) = INODE 6888 IIPOOL = IIPOOL + 1 6889 1010 CONTINUE 6890 IF = FRERE( STEP(INODE) ) 6891 DO WHILE ( IF .GT. 0 ) 6892 IF ( MUMPS_275(PROCNODE_STEPS(STEP(IF)), 6893 & SLAVEF) .eq. MYID ) THEN 6894 IF ( KEEP(237).GT. 0 ) THEN 6895 IF (.NOT.TO_PROCESS(STEP(IF))) THEN 6896 IF = FRERE(STEP(IF)) 6897 CYCLE 6898 ENDIF 6899 ENDIF 6900 IPOOL( IIPOOL ) = IF 6901 IIPOOL = IIPOOL + 1 6902 END IF 6903 IF = FRERE( STEP( IF ) ) 6904 END DO 6905 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 6906 TMP=IPOOL(POOL_FIRST_POS+I-1) 6907 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 6908 IPOOL(IIPOOL-I)=TMP 6909 ENDDO 6910 ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN 6911 POSITION = 0 6912 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 6913 & INODE, 1, MPI_INTEGER, COMM, IERR ) 6914 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 6915 & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) 6916 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) 6917 NPIV = - IW( IPOS ) 6918 NROW_L = IW( IPOS + 1 ) 6919 IF (KEEP(201).GT.0) THEN 6920 CALL SMUMPS_643( 6921 & INODE,PTRFAC,KEEP,A,LA,STEP, 6922 & KEEP8,N,MUST_BE_PERMUTED,IERR) 6923 IF(IERR.LT.0)THEN 6924 INFO(1)=IERR 6925 INFO(2)=0 6926 GOTO 260 6927 ENDIF 6928 ENDIF 6929 APOS = PTRFAC(IW( IPOS + 3 )) 6930 IF ( NROW_L .NE. NROW_RECU ) THEN 6931 WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU 6932 CALL MUMPS_ABORT() 6933 END IF 6934 LONG = NROW_L + NPIV 6935 IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN 6936 CALL SMUMPS_95(NRHS, N, KEEP(28), IWCB, 6937 & LIWW, W, LWC, 6938 & POSWCB, POSIWCB, PTRICB, PTRACB) 6939 IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN 6940 INFO(1) = -11 6941 INFO(2) = LONG * NRHS- POSWCB 6942 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 6943 GOTO 260 6944 END IF 6945 END IF 6946 P_UPDATE = PLEFTW 6947 P_SOL_MAS = PLEFTW + NPIV * NRHS 6948 PLEFTW = P_SOL_MAS + NROW_L * NRHS 6949 DO K=1, NRHS 6950 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 6951 & W( P_SOL_MAS+(K-1)*NROW_L),NROW_L, 6952 & MPI_REAL, 6953 & COMM, IERR ) 6954 ENDDO 6955 IF (KEEP(201).EQ.1) THEN 6956 IF ( NRHS == 1 ) THEN 6957 CALL sgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, 6958 & W( P_SOL_MAS ), 1, ZERO, 6959 & W( P_UPDATE ), 1 ) 6960 ELSE 6961 CALL sgemm( 'T', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), 6962 & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), 6963 & NPIV ) 6964 ENDIF 6965 ELSE 6966 IF ( NRHS == 1 ) THEN 6967 CALL sgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, 6968 & W( P_SOL_MAS ), 1, ZERO, 6969 & W( P_UPDATE ), 1 ) 6970 ELSE 6971 CALL sgemm( 'N', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), 6972 & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), 6973 & NPIV ) 6974 END IF 6975 ENDIF 6976 IF (KEEP(201).GT.0) THEN 6977 CALL SMUMPS_598(INODE,PTRFAC,KEEP(28), 6978 & A,LA,.TRUE.,IERR) 6979 IF(IERR.LT.0)THEN 6980 INFO(1)=IERR 6981 INFO(2)=0 6982 GOTO 260 6983 ENDIF 6984 ENDIF 6985 PLEFTW = PLEFTW - NROW_L * NRHS 6986 100 CONTINUE 6987 CALL SMUMPS_63( NRHS, INODE, W(P_UPDATE), 6988 & NPIV, NPIV, 6989 & MSGSOU, 6990 & BACKSLV_UPDATERHS, 6991 & COMM, IERR ) 6992 IF ( IERR .EQ. -1 ) THEN 6993 CALL SMUMPS_41( 6994 & .FALSE., FLAG, 6995 & BUFR, LBUFR, LBUFR_BYTES, 6996 & MYID, SLAVEF, COMM, 6997 & N, IWCB, LIWW, POSIWCB, 6998 & W, LWC, POSWCB, 6999 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 7000 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 7001 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 7002 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 7003 & RHS, LRHS, NRHS, MTYPE, 7004 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 7005 & , TO_PROCESS, SIZE_TO_PROCESS 7006 & ) 7007 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 7008 GOTO 100 7009 ELSE IF ( IERR .EQ. -2 ) THEN 7010 INFO( 1 ) = -17 7011 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 7012 GOTO 260 7013 ELSE IF ( IERR .EQ. -3 ) THEN 7014 INFO( 1 ) = -20 7015 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) 7016 GOTO 260 7017 END IF 7018 PLEFTW = PLEFTW - NPIV * NRHS 7019 ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN 7020 POSITION = 0 7021 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 7022 & INODE, 1, MPI_INTEGER, COMM, IERR ) 7023 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 7024 LIELL = IW(IPOS-2)+IW(IPOS+1) 7025 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 7026 & NPIV, 1, MPI_INTEGER, COMM, IERR ) 7027 NELIM = IW(IPOS-1) 7028 IPOS = IPOS + 1 7029 NPIV = IW(IPOS) 7030 IPOS = IPOS + 1 7031 NSLAVES = IW( IPOS + 1 ) 7032 IPOS = IPOS + 1 + NSLAVES 7033 INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 7034 IF ( KEEP(50) .eq. 0 ) THEN 7035 LDA = LIELL 7036 ELSE 7037 LDA = NPIV 7038 ENDIF 7039 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 7040 J1 = IPOS + 1 7041 J2 = IPOS + NPIV 7042 ELSE 7043 J1 = IPOS + LIELL + 1 7044 J2 = IPOS + NPIV + LIELL 7045 END IF 7046 DO K=1, NRHS 7047 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 7048 & W2, NPIV, MPI_REAL, 7049 & COMM, IERR ) 7050 IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 7051 I = 1 7052 IF ( (KEEP(253).NE.0) .AND. 7053 & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) 7054 & ) THEN 7055 DO JJ = J1,J2 7056 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) 7057 I = I+1 7058 ENDDO 7059 ELSE 7060 DO JJ = J1,J2 7061 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = 7062 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) 7063 I = I+1 7064 ENDDO 7065 ENDIF 7066 ENDDO 7067 IW(PTRIST(STEP(INODE))+XXS) = 7068 & IW(PTRIST(STEP(INODE))+XXS) - 1 7069 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN 7070 IF (KEEP(201).GT.0) THEN 7071 CALL SMUMPS_643( 7072 & INODE,PTRFAC,KEEP,A,LA,STEP, 7073 & KEEP8,N,MUST_BE_PERMUTED,IERR) 7074 IF(IERR.LT.0)THEN 7075 INFO(1)=IERR 7076 INFO(2)=0 7077 GOTO 260 7078 ENDIF 7079 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 7080 CALL SMUMPS_755( 7081 & IW(IPOS+1+2*LIELL), 7082 & MUST_BE_PERMUTED ) 7083 ENDIF 7084 ENDIF 7085 APOS = PTRFAC(IW(INODEPOS)) 7086 IF (KEEP(201).EQ.1) THEN 7087 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 7088 TYPEF = TYPEF_L 7089 NROW_L = NPIV+NELIM 7090 PANEL_SIZE = SMUMPS_690(NROW_L) 7091 IF (PANEL_SIZE.LT.0) THEN 7092 WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', 7093 & PANEL_SIZE 7094 CALL MUMPS_ABORT() 7095 ENDIF 7096 ENDIF 7097 IF ( POSIWCB - 2 .LT. 0 .or. 7098 & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 7099 CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, 7100 & LIWW, W, LWC, 7101 & POSWCB, POSIWCB, PTRICB, PTRACB) 7102 IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN 7103 INFO( 1 ) = -11 7104 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 7105 GOTO 260 7106 END IF 7107 IF ( POSIWCB - 2 .LT. 0 ) THEN 7108 INFO( 1 ) = -14 7109 INFO( 2 ) = 2 - POSIWCB 7110 GO TO 260 7111 END IF 7112 END IF 7113 POSIWCB = POSIWCB - 2 7114 POSWCB = POSWCB - LIELL*NRHS 7115 PTRICB(STEP( INODE )) = POSIWCB + 1 7116 PTRACB(STEP( INODE )) = POSWCB + 1 7117 IWCB( PTRICB(STEP( INODE )) ) = LIELL 7118 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 7119 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES 7120 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 7121 POSINDICES = IPOS + LIELL + 1 7122 ELSE 7123 POSINDICES = IPOS + 1 7124 END IF 7125 IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) 7126 IFR = PTRACB(STEP( INODE )) 7127 DO K=1, NRHS 7128 DO JJ = J1, J2 7129 W(IFR+JJ-J1+(K-1)*LIELL) = 7130 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 7131 ENDDO 7132 END DO 7133 IFR = PTRACB(STEP(INODE))-1+NPIV 7134 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 7135 J1 = IPOS + LIELL + NPIV + 1 7136 J2 = IPOS + 2 * LIELL 7137 ELSE 7138 J1 = IPOS + NPIV + 1 7139 J2 = IPOS + LIELL 7140 END IF 7141 DO JJ = J1, J2-KEEP(253) 7142 J = IW(JJ) 7143 IFR = IFR + 1 7144 DO K=1, NRHS 7145 W(IFR+(K-1)*LIELL) = RHS(J,K) 7146 ENDDO 7147 ENDDO 7148 IF ( KEEP(201).EQ.1 .AND. 7149 & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN 7150 J = NPIV / PANEL_SIZE 7151 TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 7152 IF (TWOBYTWO) THEN 7153 CALL SMUMPS_641(PANEL_SIZE, PANEL_POS, 7154 & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, 7155 & NROW_L, NBENTRIES_ALLPANELS) 7156 ELSE 7157 IF (NPIV.EQ.J*PANEL_SIZE) THEN 7158 NPIV_LAST = NPIV 7159 NBJLAST = PANEL_SIZE 7160 NPANELS = J 7161 ELSE 7162 NPIV_LAST = (J+1)* PANEL_SIZE 7163 NBJLAST = NPIV-J*PANEL_SIZE 7164 NPANELS = J+1 7165 ENDIF 7166 NBENTRIES_ALLPANELS = 7167 & int(NROW_L,8) * int(NPIV,8) 7168 & - int( ( J * ( J - 1 ) ) / 2,8 ) 7169 & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) 7170 & - int(J,8) 7171 & * int(mod(NPIV, PANEL_SIZE),8) 7172 & * int(PANEL_SIZE,8) 7173 JJ=NPIV_LAST 7174 ENDIF 7175 APOSDEB = APOS + NBENTRIES_ALLPANELS 7176 DO IPANEL=NPANELS,1,-1 7177 IF (TWOBYTWO) THEN 7178 NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) 7179 BEG_PANEL = PANEL_POS(IPANEL) 7180 ELSE 7181 IF (JJ.EQ.NPIV_LAST) THEN 7182 NBJ = NBJLAST 7183 ELSE 7184 NBJ = PANEL_SIZE 7185 ENDIF 7186 BEG_PANEL = JJ- PANEL_SIZE+1 7187 ENDIF 7188 LDAJ = NROW_L-BEG_PANEL+1 7189 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) 7190 PTWCB_PANEL = PTRACB(STEP(INODE)) + BEG_PANEL - 1 7191 NCB_PANEL = LDAJ - NBJ 7192 IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN 7193 CALL SMUMPS_667(TYPEF, TMP_NBPANELS, 7194 & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) 7195 CALL SMUMPS_698( 7196 & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), 7197 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 7198 & IW(I_PIVRPTR+IPANEL-1)-1, 7199 & A(APOSDEB), 7200 & LDAJ, NBJ, BEG_PANEL-1) 7201 ENDIF 7202 IF ( NRHS == 1 ) THEN 7203 IF (NCB_PANEL.NE.0) THEN 7204 CALL sgemv( 'T', NCB_PANEL, NBJ, ALPHA, 7205 & A( APOSDEB + int(NBJ,8) ), LDAJ, 7206 & W( NBJ + PTWCB_PANEL ), 7207 & 1, ONE, 7208 & W(PTWCB_PANEL), 1 ) 7209 ENDIF 7210 CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 7211 & W(PTWCB_PANEL), 1) 7212 ELSE 7213 IF (NCB_PANEL.NE.0) THEN 7214 CALL sgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, 7215 & A(APOSDEB + int(NBJ,8)), LDAJ, 7216 & W(NBJ+PTWCB_PANEL),LIELL, 7217 & ONE, W(PTWCB_PANEL),LIELL) 7218 ENDIF 7219 CALL strsm('L','L','T','U',NBJ, NRHS, ONE, 7220 & A(APOSDEB), 7221 & LDAJ, W(PTWCB_PANEL), LIELL) 7222 ENDIF 7223 IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 7224 ENDDO 7225 GOTO 1234 7226 ENDIF 7227 IF (NELIM .GT.0) THEN 7228 IF ( KEEP(50) .eq. 0 ) THEN 7229 IST = APOS + int(NPIV,8) * int(LIELL,8) 7230 ELSE 7231 IST = APOS + int(NPIV,8) * int(NPIV,8) 7232 END IF 7233 IF ( NRHS == 1 ) THEN 7234 CALL sgemv( 'N', NPIV, NELIM, ALPHA, 7235 & A( IST ), NPIV, 7236 & W( NPIV + PTRACB(STEP(INODE)) ), 7237 & 1, ONE, 7238 & W(PTRACB(STEP(INODE))), 1 ) 7239 ELSE 7240 CALL sgemm( 'N', 'N', NPIV, NRHS, NELIM, ALPHA, 7241 & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, 7242 & ONE, W(PTRACB(STEP(INODE))),LIELL) 7243 END IF 7244 ENDIF 7245 IF ( NRHS == 1 ) THEN 7246 CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, 7247 & W(PTRACB(STEP(INODE))),1) 7248 ELSE 7249 CALL strsm( 'L','U', 'N', 'U', NPIV, NRHS, ONE, 7250 & A(APOS), LDA, 7251 & W(PTRACB(STEP(INODE))),LIELL) 7252 END IF 7253 1234 CONTINUE 7254 IF (KEEP(201).GT.0) THEN 7255 CALL SMUMPS_598(INODE,PTRFAC,KEEP(28), 7256 & A,LA,.TRUE.,IERR) 7257 IF(IERR.LT.0)THEN 7258 INFO(1)=IERR 7259 INFO(2)=0 7260 GOTO 260 7261 ENDIF 7262 ENDIF 7263 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES 7264 DO I = 1, NPIV 7265 JJ = IW( IPOS + I - 1 ) 7266 DO K=1,NRHS 7267 RHS( JJ, K ) = W( PTRACB(STEP(INODE))+I-1 7268 & + (K-1)*LIELL ) 7269 ENDDO 7270 END DO 7271 IN = INODE 7272 200 IN = FILS(IN) 7273 IF (IN .GT. 0) GOTO 200 7274 IF (IN .EQ. 0) THEN 7275 MYLEAFE = MYLEAFE - 1 7276 IF (MYLEAFE .EQ. 0) THEN 7277 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, 7278 & FEUILLE, SLAVEF ) 7279 NBFINF = NBFINF - 1 7280 ENDIF 7281 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 7282 CALL SMUMPS_151(NRHS, N, KEEP(28), 7283 & IWCB, LIWW, W, LWC, 7284 & POSWCB, POSIWCB, PTRICB, PTRACB) 7285 GOTO 270 7286 ENDIF 7287 DO I = 0, SLAVEF - 1 7288 DEJA_SEND( I ) = .FALSE. 7289 END DO 7290 IN = -IN 7291 IF ( KEEP(237).GT.0 ) THEN 7292 NO_CHILDREN = .TRUE. 7293 ELSE 7294 NO_CHILDREN = .FALSE. 7295 ENDIF 7296 DO WHILE (IN.GT.0) 7297 IF ( KEEP(237).GT.0 ) THEN 7298 IF (.NOT.TO_PROCESS(STEP(IN))) THEN 7299 IN = FRERE(STEP(IN)) 7300 CYCLE 7301 ELSE 7302 NO_CHILDREN = .FALSE. 7303 ENDIF 7304 ENDIF 7305 POOL_FIRST_POS = IIPOOL 7306 IF (MUMPS_275(PROCNODE_STEPS(STEP(IN)), 7307 & SLAVEF) .EQ. MYID) THEN 7308 IPOOL(IIPOOL ) = IN 7309 IIPOOL = IIPOOL + 1 7310 ELSE 7311 PROCDEST = MUMPS_275( PROCNODE_STEPS(STEP(IN)), 7312 & SLAVEF ) 7313 IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 7314 110 CALL SMUMPS_78( NRHS, IN, 0, 0, 7315 & LIELL, LIELL-KEEP(253), 7316 & IW( POSINDICES ) , 7317 & W( PTRACB(STEP(INODE))), 7318 & PROCDEST, NOEUD, COMM, IERR ) 7319 IF ( IERR .EQ. -1 ) THEN 7320 CALL SMUMPS_41( 7321 & .FALSE., FLAG, 7322 & BUFR, LBUFR, LBUFR_BYTES, 7323 & MYID, SLAVEF, COMM, 7324 & N, IWCB, LIWW, POSIWCB, 7325 & W, LWC, POSWCB, 7326 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 7327 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 7328 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, 7329 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 7330 & RHS, LRHS, NRHS, MTYPE, 7331 & RHSCOMP, LRHSCOMP, POSINRHSCOMP 7332 & , TO_PROCESS, SIZE_TO_PROCESS 7333 & ) 7334 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 7335 GOTO 110 7336 ELSE IF ( IERR .eq. -2 ) THEN 7337 INFO(1) = -17 7338 INFO(2) = LIELL * NRHS * KEEP(35) + 7339 & ( LIELL + 2 ) * KEEP(34) 7340 GOTO 260 7341 ELSE IF ( IERR .eq. -3 ) THEN 7342 INFO(1) = -20 7343 INFO(2) = LIELL * NRHS * KEEP(35) + 7344 & ( LIELL + 2 ) * KEEP(34) 7345 GOTO 260 7346 END IF 7347 DEJA_SEND( PROCDEST ) = .TRUE. 7348 END IF 7349 END IF 7350 IN = FRERE( STEP( IN ) ) 7351 END DO 7352 IF (NO_CHILDREN) THEN 7353 MYLEAFE = MYLEAFE - 1 7354 IF (MYLEAFE .EQ. 0) THEN 7355 CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, 7356 & COMM, FEUILLE, SLAVEF ) 7357 NBFINF = NBFINF - 1 7358 ENDIF 7359 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 7360 CALL SMUMPS_151(NRHS, N, KEEP(28), 7361 & IWCB, LIWW, W, LWC, 7362 & POSWCB, POSIWCB, PTRICB, PTRACB) 7363 GOTO 270 7364 ENDIF 7365 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 7366 TMP=IPOOL(POOL_FIRST_POS+I-1) 7367 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 7368 IPOOL(IIPOOL-I)=TMP 7369 ENDDO 7370 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 7371 CALL SMUMPS_151(NRHS, N, KEEP(28), 7372 & IWCB, LIWW, W, LWC, 7373 & POSWCB, POSIWCB, PTRICB, PTRACB) 7374 END IF 7375 ELSE IF (MSGTAG.EQ.TERREUR) THEN 7376 INFO(1) = -001 7377 INFO(2) = MSGSOU 7378 GO TO 270 7379 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. 7380 & (MSGTAG.EQ.TAG_DUMMY) ) THEN 7381 GO TO 270 7382 ELSE 7383 INFO(1) = -100 7384 INFO(2) = MSGTAG 7385 GOTO 260 7386 ENDIF 7387 GO TO 270 7388 260 CONTINUE 7389 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 7390 270 CONTINUE 7391 RETURN 7392 END SUBROUTINE SMUMPS_42 7393 SUBROUTINE SMUMPS_641(PANEL_SIZE, PANEL_POS, 7394 & LEN_PANEL_POS, INDICES, NPIV, 7395 & NPANELS, NFRONT_OR_NASS, 7396 & NBENTRIES_ALLPANELS) 7397 IMPLICIT NONE 7398 INTEGER, intent (in) :: PANEL_SIZE, NPIV 7399 INTEGER, intent (in) :: INDICES(NPIV) 7400 INTEGER, intent (in) :: LEN_PANEL_POS 7401 INTEGER, intent (out) :: NPANELS 7402 INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) 7403 INTEGER, intent (in) :: NFRONT_OR_NASS 7404 INTEGER(8), intent(out):: NBENTRIES_ALLPANELS 7405 INTEGER NPANELS_MAX, I, NBeff 7406 INTEGER(8) :: NBENTRIES_THISPANEL 7407 NBENTRIES_ALLPANELS = 0_8 7408 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE 7409 IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN 7410 WRITE(*,*) "Error 1 in SMUMPS_641", 7411 & LEN_PANEL_POS,NPANELS_MAX 7412 CALL MUMPS_ABORT() 7413 ENDIF 7414 I = 1 7415 NPANELS = 0 7416 IF (I .GT. NPIV) RETURN 7417 10 CONTINUE 7418 NPANELS = NPANELS + 1 7419 PANEL_POS(NPANELS) = I 7420 NBeff = min(PANEL_SIZE, NPIV-I+1) 7421 IF ( INDICES(I+NBeff-1) < 0) THEN 7422 NBeff=NBeff+1 7423 ENDIF 7424 NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) 7425 NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL 7426 I=I+NBeff 7427 IF ( I .LE. NPIV ) GOTO 10 7428 PANEL_POS(NPANELS+1)=NPIV+1 7429 RETURN 7430 END SUBROUTINE SMUMPS_641 7431 SUBROUTINE SMUMPS_286( NRHS, DESCA_PAR, 7432 & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, 7433 & IPIV,LPIV,MASTER_ROOT,MYID,COMM, 7434 & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) 7435 IMPLICIT NONE 7436 INTEGER NRHS, MTYPE 7437 INTEGER DESCA_PAR( 9 ) 7438 INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK 7439 INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT 7440 INTEGER MYID, COMM 7441 INTEGER LPIV, IPIV( LPIV ) 7442 INTEGER INFO(40), LDLT 7443 REAL RHS_SEQ( SIZE_ROOT *NRHS) 7444 REAL A( LOCAL_M, LOCAL_N ) 7445 INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL 7446 INTEGER LOCAL_N_RHS 7447 REAL, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR 7448 EXTERNAL numroc 7449 INTEGER numroc 7450 INTEGER allocok 7451 CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) 7452 LOCAL_N_RHS = numroc(NRHS, NBLOCK, MYCOL, 0, NPCOL) 7453 LOCAL_N_RHS = max(1,LOCAL_N_RHS) 7454 ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) 7455 IF (allocok > 0 ) THEN 7456 WRITE(*,*) ' Problem during solve of the root.' 7457 WRITE(*,*) ' Reduce number of right hand sides.' 7458 CALL MUMPS_ABORT() 7459 ENDIF 7460 CALL SMUMPS_290( MYID, SIZE_ROOT, NRHS, RHS_SEQ, 7461 & LOCAL_M, LOCAL_N_RHS, 7462 & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, 7463 & NPROW, NPCOL, COMM ) 7464 CALL SMUMPS_768 (SIZE_ROOT, NRHS, MTYPE, 7465 & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, 7466 & IPIV, LPIV, RHS_PAR, LDLT, 7467 & MBLOCK, NBLOCK, CNTXT_PAR, 7468 & IERR) 7469 CALL SMUMPS_156( MYID, SIZE_ROOT, NRHS, 7470 & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, 7471 & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, 7472 & NPROW, NPCOL, COMM ) 7473 DEALLOCATE(RHS_PAR) 7474 RETURN 7475 END SUBROUTINE SMUMPS_286 7476 SUBROUTINE SMUMPS_768 (SIZE_ROOT, NRHS, MTYPE, 7477 & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, 7478 & IPIV, LPIV, RHS_PAR, LDLT, 7479 & MBLOCK, NBLOCK, CNTXT_PAR, 7480 & IERR) 7481 IMPLICIT NONE 7482 INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, 7483 & LOCAL_N, LOCAL_N_RHS, 7484 & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE 7485 INTEGER, intent (in) :: DESCA_PAR( 9 ) 7486 INTEGER, intent (in) :: LPIV, IPIV( LPIV ) 7487 REAL, intent (in) :: A( LOCAL_M, LOCAL_N ) 7488 REAL, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) 7489 INTEGER, intent (out) :: IERR 7490 INTEGER :: DESCB_PAR( 9 ) 7491 IERR = 0 7492 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, 7493 & NRHS, MBLOCK, NBLOCK, 0, 0, 7494 & CNTXT_PAR, LOCAL_M, IERR ) 7495 IF (IERR.NE.0) THEN 7496 WRITE(*,*) 'After DESCINIT, IERR = ', IERR 7497 CALL MUMPS_ABORT() 7498 END IF 7499 IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN 7500 IF ( MTYPE .eq. 1 ) THEN 7501 CALL psgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, 7502 & RHS_PAR,1,1,DESCB_PAR,IERR) 7503 ELSE 7504 CALL psgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, 7505 & RHS_PAR, 1, 1, DESCB_PAR,IERR) 7506 END IF 7507 ELSE 7508 CALL pspotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, 7509 & RHS_PAR, 1, 1, DESCB_PAR, IERR ) 7510 END IF 7511 IF ( IERR .LT. 0 ) THEN 7512 WRITE(*,*) ' Problem during solve of the root' 7513 CALL MUMPS_ABORT() 7514 END IF 7515 RETURN 7516 END SUBROUTINE SMUMPS_768 7517