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