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 CMUMPS_26(id) 49 USE CMUMPS_LOAD 50 USE MUMPS_STATIC_MAPPING 51 USE CMUMPS_STRUC_DEF 52 USE TOOLS_COMMON 53 USE CMUMPS_PARALLEL_ANALYSIS 54 IMPLICIT NONE 55 INCLUDE 'mpif.h' 56 INCLUDE 'mumps_tags.h' 57 INTEGER IERR, MASTER 58 PARAMETER( MASTER = 0 ) 59 TYPE(CMUMPS_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 REAL 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 REAL, DIMENSION(:), POINTER :: RINFO 90 REAL, 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 REAL, 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( /' CMUMPS ',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 CMUMPS_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 CMUMPS_658(id) 221 IF (KEEP(244) .EQ. 1) THEN 222 IF ( KEEP(54) .eq. 3 ) THEN 223 CALL CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_564(id%KEEP(38), id%PROCNODE(1), 433 & 1+2*id%NSLAVES, id%IS1(FILS),id%N) 434 ENDIF 435 ELSE 436 PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + 437 & real(id%KEEP(2))*real(id%KEEP(2)) 438 SSARBR => id%IS1(IKEEP:IKEEP+id%N-1) 439 CALL CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_26' 727 CALL MUMPS_ABORT() 728 ENDIF 729 IF ( ISTEP .NE. id%KEEP(28) ) THEN 730 write(*,*) 'Internal error 3 in CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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. complex 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.0E0 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_REAL, 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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_26, DYNAMIC ALLOCATION OF', 1685 & A30) 1686 END SUBROUTINE CMUMPS_26 1687 SUBROUTINE CMUMPS_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 REAL 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 CMUMPS_537 1709 SUBROUTINE CMUMPS_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 CMUMPS_564 1721 SUBROUTINE CMUMPS_647(id) 1722 USE CMUMPS_STRUC_DEF 1723 IMPLICIT NONE 1724 TYPE(CMUMPS_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: CMUMPS_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 CMUMPS_647 2129 SUBROUTINE CMUMPS_664(id) 2130 USE CMUMPS_STRUC_DEF 2131 IMPLICIT NONE 2132 INCLUDE 'mpif.h' 2133 INCLUDE 'mumps_tags.h' 2134 TYPE(CMUMPS_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 CMUMPS_664, DYNAMIC ALLOCATION OF', 2246 & A30) 2247 END SUBROUTINE CMUMPS_664 2248 SUBROUTINE CMUMPS_658(id) 2249 USE CMUMPS_STRUC_DEF 2250 IMPLICIT NONE 2251 INCLUDE 'mpif.h' 2252 TYPE(CMUMPS_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 CMUMPS_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 CMUMPS_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 CMUMPS_179(IUNIT, id) 2302 CLOSE(IUNIT) 2303 ENDIF 2304 RETURN 2305 END SUBROUTINE CMUMPS_658 2306 SUBROUTINE CMUMPS_166 2307 & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, 2308 & IS_DISTRIBUTED, IS_ELEMENTAL ) 2309 USE CMUMPS_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(CMUMPS_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='complex' 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), 2341 & real(id%A(I)), aimag(id%A(I)) 2342 ELSE 2343 WRITE(IUNIT,*) id%IRN(I), id%JCN(I), 2344 & real(id%A(I)), aimag(id%A(I)) 2345 ENDIF 2346 ENDDO 2347 ELSE 2348 DO I=1,id%NZ 2349 IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN 2350 WRITE(IUNIT,*) id%JCN(I), id%IRN(I) 2351 ELSE 2352 WRITE(IUNIT,*) id%IRN(I), id%JCN(I) 2353 ENDIF 2354 ENDDO 2355 ENDIF 2356 ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN 2357 IF (associated(id%A_loc)) THEN 2358 ARITH='complex' 2359 ELSE 2360 ARITH='pattern ' 2361 ENDIF 2362 IF (id%KEEP(50) .eq. 0) THEN 2363 SYMM="general" 2364 ELSE 2365 SYMM="symmetric" 2366 END IF 2367 WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', 2368 & trim(ARITH)," ",trim(SYMM) 2369 WRITE(IUNIT,*) id%N, id%N, id%NZ_loc 2370 IF (associated(id%A_loc)) THEN 2371 DO I=1,id%NZ_loc 2372 IF (id%KEEP(50).NE.0 .AND. 2373 & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN 2374 WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I), 2375 & real(id%A_loc(I)), aimag(id%A_loc(I)) 2376 ELSE 2377 WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I), 2378 & real(id%A_loc(I)), aimag(id%A_loc(I)) 2379 ENDIF 2380 ENDDO 2381 ELSE 2382 DO I=1,id%NZ_loc 2383 IF (id%KEEP(50).NE.0 .AND. 2384 & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN 2385 WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I) 2386 ELSE 2387 WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I) 2388 ENDIF 2389 ENDDO 2390 ENDIF 2391 ENDIF 2392 RETURN 2393 END SUBROUTINE CMUMPS_166 2394 SUBROUTINE CMUMPS_179(IUNIT, id) 2395 USE CMUMPS_STRUC_DEF 2396 IMPLICIT NONE 2397 TYPE(CMUMPS_STRUC), intent(in) :: id 2398 INTEGER, intent(in) :: IUNIT 2399 CHARACTER (LEN=8) :: ARITH 2400 INTEGER :: I, J, K, LD_RHS 2401 IF (associated(id%RHS)) THEN 2402 ARITH='complex' 2403 WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ', 2404 & trim(ARITH), 2405 & ' general' 2406 WRITE(IUNIT,*) id%N, id%NRHS 2407 IF ( id%NRHS .EQ. 1 ) THEN 2408 LD_RHS = id%N 2409 ELSE 2410 LD_RHS = id%LRHS 2411 ENDIF 2412 DO J = 1, id%NRHS 2413 DO I = 1, id%N 2414 K=(J-1)*LD_RHS+I 2415 WRITE(IUNIT,*) real(id%RHS(K)), aimag(id%RHS(K)) 2416 ENDDO 2417 ENDDO 2418 ENDIF 2419 RETURN 2420 END SUBROUTINE CMUMPS_179 2421 SUBROUTINE CMUMPS_649( NSLAVES, NB_NIV2, MYID_NODES, 2422 & CANDIDATES, I_AM_CAND ) 2423 IMPLICIT NONE 2424 INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES 2425 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) 2426 LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) 2427 INTEGER I, INIV2, NCAND 2428 DO INIV2=1, NB_NIV2 2429 I_AM_CAND(INIV2)=.FALSE. 2430 NCAND = CANDIDATES(NSLAVES+1,INIV2) 2431 DO I=1, NCAND 2432 IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN 2433 I_AM_CAND(INIV2)=.TRUE. 2434 EXIT 2435 ENDIF 2436 ENDDO 2437 END DO 2438 RETURN 2439 END SUBROUTINE CMUMPS_649 2440 SUBROUTINE CMUMPS_251(N,IW,LIW,A,LA, 2441 & NSTK_STEPS, NBPROCFILS,IFLAG,ND,FILS,STEP, 2442 & FRERE, DAD, CAND, 2443 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2444 & MAXFRT, NTOTPV, NMAXNPIV, PTRIST, PTRAST, 2445 & PIMASTER, PAMASTER, PTRARW,PTRAIW, 2446 & ITLOC, RHS_MUMPS, IERROR,IPOOL, LPOOL, 2447 & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, 2448 & LRLUS, LEAF, NBROOT, NBRTOT, 2449 & UU, ICNTL, PTLUST_S, PTRFAC, NSTEPS, INFO, 2450 & KEEP,KEEP8, 2451 & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, 2452 & MYID_NODES, 2453 & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root, 2454 & PERM, NELT, FRTPTR, FRTELT, LPTRAR, 2455 & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, 2456 & MEM_DISTRIB, NE, 2457 & DKEEP,PIVNUL_LIST,LPN_LIST) 2458 USE CMUMPS_LOAD 2459 USE CMUMPS_OOC 2460 IMPLICIT NONE 2461 INCLUDE 'cmumps_root.h' 2462 TYPE (CMUMPS_ROOT_STRUC) :: root 2463 INTEGER N,IFLAG,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, 2464 & IERROR, NSTEPS, INFO(40) 2465 INTEGER(8) :: LA 2466 COMPLEX, TARGET :: A(LA) 2467 INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES 2468 INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB 2469 INTEGER KEEP(500), ICNTL(40) 2470 INTEGER(8) KEEP8(150) 2471 INTEGER LPOOL 2472 INTEGER PROCNODE_STEPS(KEEP(28)) 2473 INTEGER ITLOC(N+KEEP(253)) 2474 COMPLEX :: RHS_MUMPS(KEEP(255)) 2475 INTEGER IW(LIW), NSTK_STEPS(KEEP(28)), NBPROCFILS(KEEP(28)) 2476 INTEGER PTRARW(LPTRAR), PTRAIW(LPTRAR), ND(KEEP(28)) 2477 INTEGER FILS(N),PTRIST(KEEP(28)) 2478 INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) 2479 INTEGER PIMASTER(KEEP(28)) 2480 INTEGER PTLUST_S(KEEP(28)), PERM(N) 2481 INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) 2482 INTEGER ISTEP_TO_INIV2(KEEP(71)), 2483 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 2484 INTEGER IPOOL(LPOOL) 2485 INTEGER NE(KEEP(28)) 2486 REAL RINFO(40) 2487 INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) 2488 INTEGER(8) :: PTRFAC(KEEP(28)) 2489 INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU 2490 INTEGER IWPOS, LEAF, NBROOT 2491 INTEGER COMM_LOAD, ASS_IRECV 2492 REAL UU, SEUIL, SEUIL_LDLT_NIV2 2493 INTEGER NELT 2494 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 2495 INTEGER LBUFR, LBUFR_BYTES 2496 INTEGER BUFR( LBUFR ) 2497 INTEGER INTARR( max(1,KEEP(14)) ) 2498 COMPLEX DBLARR( max(1,KEEP(13)) ) 2499 LOGICAL IS_ISOLATED_NODE 2500 INTEGER LPN_LIST 2501 INTEGER PIVNUL_LIST(LPN_LIST) 2502 REAL DKEEP(30) 2503 INCLUDE 'mpif.h' 2504 INCLUDE 'mumps_tags.h' 2505 INTEGER STATUS( MPI_STATUS_SIZE ), IERR 2506 DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 2507 INTEGER INODE 2508 INTEGER IWPOSCB 2509 INTEGER FPERE, TYPEF 2510 INTEGER MP, LP, DUMMY(1) 2511 INTEGER NBFIN, NBRTOT, NBROOT_TRAITEES 2512 INTEGER NFRONT, IOLDPS 2513 INTEGER(8) NFRONT8 2514 INTEGER(8) :: POSELT 2515 INTEGER IPOSROOT, IPOSROOTROWINDICES 2516 INTEGER GLOBK109 2517 INTEGER(8) :: LBUFRX 2518 COMPLEX, POINTER, DIMENSION(:) :: BUFRX 2519 LOGICAL :: IS_BUFRX_ALLOCATED 2520 DOUBLE PRECISION FLOP1 2521 INTEGER TYPE 2522 LOGICAL SON_LEVEL2, SET_IRECV, BLOCKING, 2523 & MESSAGE_RECEIVED 2524 LOGICAL AVOID_DELAYED 2525 LOGICAL LAST_CALL 2526 INTEGER MASTER_ROOT 2527 INTEGER LOCAL_M, LOCAL_N 2528 INTEGER LRHS_CNTR_MASTER_ROOT, FWD_LOCAL_N_RHS 2529 LOGICAL ROOT_OWNER 2530 EXTERNAL MUMPS_330, MUMPS_275 2531 INTEGER MUMPS_330, MUMPS_275 2532 LOGICAL MUMPS_167,MUMPS_283 2533 EXTERNAL MUMPS_167,MUMPS_283 2534 LOGICAL CMUMPS_508 2535 EXTERNAL CMUMPS_508, CMUMPS_509 2536 LOGICAL STACK_RIGHT_AUTHORIZED 2537 INTEGER numroc 2538 EXTERNAL numroc 2539 INTEGER MAXFRW, NPVW, NOFFW, NELVAW, COMP, 2540 & JOBASS, ETATASS 2541 INTEGER(8) :: LAFAC 2542 INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, 2543 & IDUMMY 2544 INTEGER(8) :: ITMP8 2545 TYPE(IO_BLOCK) :: MonBloc 2546 INCLUDE 'mumps_headers.h' 2547 DOUBLE PRECISION OPASSW, OPELIW 2548 ASS_IRECV = MPI_REQUEST_NULL 2549 ITLOC(1:N+KEEP(253)) =0 2550 PTRIST (1:KEEP(28))=0 2551 PTLUST_S(1:KEEP(28))=0 2552 PTRAST(1:KEEP(28))=0_8 2553 PTRFAC(1:KEEP(28))=-99999_8 2554 MP = ICNTL(2) 2555 LP = ICNTL(1) 2556 MAXFRW = 0 2557 NPVW = 0 2558 NOFFW = 0 2559 NELVAW = 0 2560 COMP = 0 2561 OPASSW = DZERO 2562 OPELIW = DZERO 2563 IWPOSCB = LIW 2564 STACK_RIGHT_AUTHORIZED = .TRUE. 2565 CALL CMUMPS_22( .FALSE., 0_8, 2566 & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, 2567 & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, 2568 & PTRIST, PTRAST, STEP, PIMASTER, 2569 & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., 2570 & COMP, LRLUS, 2571 & IFLAG, IERROR 2572 & ) 2573 JOBASS = 0 2574 ETATASS = 0 2575 NBFIN = NBRTOT 2576 NBROOT_TRAITEES = 0 2577 NBPROCFILS(1:KEEP(28)) = 0 2578 IF ( KEEP(38).NE.0 ) THEN 2579 IF (root%yes) THEN 2580 CALL CMUMPS_284( 2581 & root, KEEP(38), N, IW, LIW, 2582 & A, LA, 2583 & FILS, MYID_NODES, PTRAIW, PTRARW, 2584 & INTARR, DBLARR, 2585 & LRLU, IPTRLU, 2586 & IWPOS, IWPOSCB, PTRIST, PTRAST, 2587 & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, 2588 & COMP, LRLUS, IFLAG, KEEP,KEEP8, IERROR ) 2589 ENDIF 2590 IF ( IFLAG .LT. 0 ) GOTO 635 2591 END IF 2592 20 CONTINUE 2593 NIV1_FLAG=0 2594 SET_IRECV = .TRUE. 2595 BLOCKING = .FALSE. 2596 MESSAGE_RECEIVED = .FALSE. 2597 CALL CMUMPS_329( 2598 & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, 2599 & MESSAGE_RECEIVED, 2600 & MPI_ANY_SOURCE, MPI_ANY_TAG, 2601 & STATUS, BUFR, LBUFR, 2602 & LBUFR_BYTES, 2603 & PROCNODE_STEPS, POSFAC, 2604 & IWPOS, IWPOSCB, IPTRLU, 2605 & LRLU, LRLUS, N, IW, LIW, A, LA, 2606 & PTRIST, PTLUST_S, PTRFAC, 2607 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, 2608 & COMP, IFLAG, 2609 & IERROR, COMM_NODES, 2610 & NBPROCFILS, 2611 & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, 2612 & 2613 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 2614 & PTRARW, PTRAIW, 2615 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 2616 & LPTRAR, NELT, FRTPTR, FRTELT, 2617 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2618 & STACK_RIGHT_AUTHORIZED ) 2619 CALL CMUMPS_467(COMM_LOAD, KEEP) 2620 IF (MESSAGE_RECEIVED) THEN 2621 IF ( IFLAG .LT. 0 ) GO TO 640 2622 IF ( NBFIN .eq. 0 ) GOTO 640 2623 ELSE 2624 IF ( .NOT. CMUMPS_508( IPOOL, LPOOL) )THEN 2625 CALL CMUMPS_509( N, IPOOL, LPOOL, 2626 & PROCNODE_STEPS, 2627 & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, 2628 & (.NOT. STACK_RIGHT_AUTHORIZED) ) 2629 STACK_RIGHT_AUTHORIZED = .TRUE. 2630 IF (KEEP(47) .GE. 3) THEN 2631 CALL CMUMPS_500( 2632 & IPOOL, LPOOL, 2633 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 2634 & MYID_NODES, STEP, N, ND, FILS ) 2635 ENDIF 2636 IF (KEEP(47).EQ.4) THEN 2637 IF(INODE.GT.0.AND.INODE.LE.N)THEN 2638 IF((NE(STEP(INODE)).EQ.0).AND. 2639 & (FRERE(STEP(INODE)).EQ.0))THEN 2640 IS_ISOLATED_NODE=.TRUE. 2641 ELSE 2642 IS_ISOLATED_NODE=.FALSE. 2643 ENDIF 2644 ENDIF 2645 CALL CMUMPS_501( 2646 & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, 2647 & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) 2648 ENDIF 2649 IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. 2650 & ( KEEP(47) == 4 )).OR. 2651 & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN 2652 CALL CMUMPS_512(INODE,STEP,KEEP(28), 2653 & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, 2654 & MYID_NODES,KEEP,KEEP8,N) 2655 END IF 2656 GOTO 30 2657 ENDIF 2658 ENDIF 2659 GO TO 20 2660 30 CONTINUE 2661 IF ( INODE .LT. 0 ) THEN 2662 INODE = -INODE 2663 FPERE = DAD(STEP(INODE)) 2664 GOTO 130 2665 ELSE IF (INODE.GT.N) THEN 2666 INODE = INODE - N 2667 IF (INODE.EQ.KEEP(38)) THEN 2668 NBROOT_TRAITEES = NBROOT_TRAITEES + 1 2669 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN 2670 NBFIN = NBFIN - NBROOT 2671 IF (SLAVEF.GT.1) THEN 2672 DUMMY(1) = NBROOT 2673 CALL CMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID_NODES, 2674 & COMM_NODES, RACINE, SLAVEF) 2675 END IF 2676 ENDIF 2677 IF (NBFIN.EQ.0) GOTO 640 2678 GOTO 20 2679 ENDIF 2680 TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 2681 IF (TYPE.EQ.1) GOTO 100 2682 FPERE = DAD(STEP(INODE)) 2683 AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) 2684 & .AND. KEEP(60).ne.0 ) 2685 IF ( KEEP(50) .eq. 0 ) THEN 2686 CALL CMUMPS_144( COMM_LOAD, ASS_IRECV, 2687 & N, INODE, FPERE, IW, LIW, A, LA, 2688 & UU, NOFFW, 2689 & NPVW, 2690 & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, 2691 & NBFIN,LEAF, 2692 & IFLAG, IERROR, IPOOL,LPOOL, 2693 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 2694 & LRLUS, COMP, 2695 & PTRIST, PTRAST, PTLUST_S, PTRFAC, 2696 & STEP, PIMASTER, PAMASTER, 2697 & NSTK_STEPS,NBPROCFILS,PROCNODE_STEPS, 2698 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2699 & FILS, PTRARW, PTRAIW, 2700 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 2701 & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, 2702 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, 2703 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST) 2704 IF ( IFLAG .LT. 0 ) GOTO 640 2705 ELSE 2706 CALL CMUMPS_141( COMM_LOAD, ASS_IRECV, 2707 & N, INODE, FPERE, IW, LIW, A, LA, 2708 & UU, NOFFW, 2709 & NPVW, 2710 & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, 2711 & NBFIN,LEAF, 2712 & IFLAG, IERROR, IPOOL,LPOOL, 2713 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 2714 & LRLUS, COMP, 2715 & PTRIST, PTRAST, PTLUST_S, PTRFAC, 2716 & STEP, PIMASTER, PAMASTER, 2717 & NSTK_STEPS,NBPROCFILS,PROCNODE_STEPS, 2718 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2719 & FILS, PTRARW, PTRAIW, 2720 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 2721 & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL_LDLT_NIV2, 2722 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, 2723 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST) 2724 IF ( IFLAG .LT. 0 ) GOTO 640 2725 IF ( IW( PTLUST_S(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN 2726 GOTO 20 2727 END IF 2728 END IF 2729 GOTO 130 2730 ENDIF 2731 IF (INODE.EQ.KEEP(38)) THEN 2732 CALL CMUMPS_176( COMM_LOAD, ASS_IRECV, 2733 & root, FRERE, 2734 & INODE, 2735 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 2736 & IWPOS, IWPOSCB, IPTRLU, 2737 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 2738 & PTLUST_S, PTRFAC, 2739 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, 2740 & IFLAG, IERROR, COMM_NODES, 2741 & NBPROCFILS, 2742 & IPOOL, LPOOL, LEAF, 2743 & NBFIN, MYID_NODES, SLAVEF, 2744 & 2745 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2746 & FILS, PTRARW, PTRAIW, 2747 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, 2748 & LPTRAR, NELT, FRTPTR, FRTELT, 2749 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 2750 IF ( IFLAG .LT. 0 ) GOTO 640 2751 GOTO 20 2752 ENDIF 2753 TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 2754 IF (TYPE.EQ.1) THEN 2755 IF (KEEP(55).NE.0) THEN 2756 CALL CMUMPS_36( COMM_LOAD, ASS_IRECV, 2757 & NELT, FRTPTR, FRTELT, 2758 & N,INODE,IW,LIW,A,LA, 2759 & IFLAG,IERROR,ND, 2760 & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, 2761 & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, 2762 & PTRARW,PTRAIW, 2763 & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, 2764 & COMP, LRLU, IPTRLU, 2765 & IWPOS,IWPOSCB, POSFAC, LRLUS, 2766 & ICNTL, KEEP,KEEP8, INTARR, DBLARR, 2767 & NSTK_STEPS,NBPROCFILS, PROCNODE_STEPS, SLAVEF, 2768 & COMM_NODES, MYID_NODES, 2769 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, 2770 & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 2771 ELSE 2772 JOBASS = 0 2773 CALL CMUMPS_252(COMM_LOAD, ASS_IRECV, 2774 & N,INODE,IW,LIW,A,LA, 2775 & IFLAG,IERROR,ND, 2776 & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, 2777 & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, 2778 & PTRARW,PTRAIW, 2779 & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, 2780 & COMP, LRLU, IPTRLU, 2781 & IWPOS,IWPOSCB, POSFAC, LRLUS, 2782 & ICNTL, KEEP,KEEP8, INTARR, DBLARR, 2783 & NSTK_STEPS,NBPROCFILS, PROCNODE_STEPS, SLAVEF, 2784 & COMM_NODES, MYID_NODES, 2785 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, 2786 & PERM, 2787 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2788 & JOBASS,ETATASS ) 2789 ENDIF 2790 IF ( IFLAG .LT. 0 ) GOTO 640 2791 IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) GOTO 20 2792 ELSE 2793 IF ( KEEP(55) .eq. 0 ) THEN 2794 CALL CMUMPS_253(COMM_LOAD, ASS_IRECV, 2795 & N, INODE, IW, LIW, A, LA, 2796 & IFLAG, IERROR, 2797 & ND, FILS, FRERE, DAD, CAND, 2798 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2799 & MAXFRW, 2800 & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, 2801 & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, 2802 & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, 2803 & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, 2804 & ICNTL, KEEP,KEEP8,INTARR,DBLARR, 2805 & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, 2806 & MYID_NODES, 2807 & BUFR, LBUFR, LBUFR_BYTES, 2808 & NBFIN, LEAF, IPOOL, LPOOL, PERM, 2809 & MEM_DISTRIB(0) 2810 & ) 2811 ELSE 2812 CALL CMUMPS_37( COMM_LOAD, ASS_IRECV, 2813 & NELT, FRTPTR, FRTELT, 2814 & N, INODE, IW, LIW, A, LA, IFLAG, IERROR, 2815 & ND, FILS, FRERE, DAD, CAND, 2816 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2817 & MAXFRW, 2818 & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, 2819 & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, 2820 & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, 2821 & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, 2822 & ICNTL, KEEP,KEEP8,INTARR,DBLARR, 2823 & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, 2824 & MYID_NODES, 2825 & BUFR, LBUFR, LBUFR_BYTES, 2826 & NBFIN, LEAF, IPOOL, LPOOL, PERM, 2827 & MEM_DISTRIB(0)) 2828 END IF 2829 IF (IFLAG.LT.0) GOTO 640 2830 GOTO 20 2831 ENDIF 2832 100 CONTINUE 2833 FPERE = DAD(STEP(INODE)) 2834 IF ( INODE .eq. KEEP(20) ) THEN 2835 POSELT = PTRAST(STEP(INODE)) 2836 IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN 2837 WRITE(*,*) "ERROR 2 in CMUMPS_251", POSELT 2838 CALL MUMPS_ABORT() 2839 ENDIF 2840 CALL CMUMPS_87 2841 & ( IW(PTLUST_S(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) 2842 GOTO 200 2843 END IF 2844 POSELT = PTRAST(STEP(INODE)) 2845 IOLDPS = PTLUST_S(STEP(INODE)) 2846 AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) 2847 & .AND. KEEP(60).ne.0 ) 2848 IF (KEEP(50).EQ.0) THEN 2849 CALL CMUMPS_143( N, INODE, IW, LIW, A, LA, 2850 & IOLDPS, POSELT, 2851 & IFLAG, UU, NOFFW, NPVW, 2852 & KEEP,KEEP8, 2853 & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, 2854 & SEUIL, AVOID_DELAYED, ETATASS, 2855 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) 2856 JOBASS = ETATASS 2857 IF (JOBASS.EQ.1) THEN 2858 CALL CMUMPS_252(COMM_LOAD, ASS_IRECV, 2859 & N,INODE,IW,LIW,A,LA, 2860 & IFLAG,IERROR,ND, 2861 & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, 2862 & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, 2863 & PTRARW,PTRAIW, 2864 & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, 2865 & COMP, LRLU, IPTRLU, 2866 & IWPOS,IWPOSCB, POSFAC, LRLUS, 2867 & ICNTL, KEEP,KEEP8, INTARR, DBLARR, 2868 & NSTK_STEPS,NBPROCFILS, PROCNODE_STEPS, SLAVEF, 2869 & COMM_NODES, MYID_NODES, 2870 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, 2871 & PERM, 2872 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2873 & JOBASS,ETATASS ) 2874 ENDIF 2875 ELSE 2876 IW( IOLDPS+4+KEEP(IXSZ) ) = 1 2877 CALL CMUMPS_140( N, INODE, 2878 & IW, LIW, A, LA, 2879 & IOLDPS, POSELT, 2880 & IFLAG, UU, NOFFW, NPVW, 2881 & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, 2882 & ETATASS, 2883 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) 2884 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) 2885 JOBASS = ETATASS 2886 IF (JOBASS.EQ.1) THEN 2887 CALL CMUMPS_252(COMM_LOAD, ASS_IRECV, 2888 & N,INODE,IW,LIW,A,LA, 2889 & IFLAG,IERROR,ND, 2890 & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, 2891 & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, 2892 & PTRARW,PTRAIW, 2893 & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, 2894 & COMP, LRLU, IPTRLU, 2895 & IWPOS,IWPOSCB, POSFAC, LRLUS, 2896 & ICNTL, KEEP,KEEP8, INTARR, DBLARR, 2897 & NSTK_STEPS,NBPROCFILS, PROCNODE_STEPS, SLAVEF, 2898 & COMM_NODES, MYID_NODES, 2899 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, 2900 & PERM, 2901 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 2902 & JOBASS,ETATASS ) 2903 ENDIF 2904 ENDIF 2905 IF (IFLAG.LT.0) GOTO 635 2906 130 CONTINUE 2907 TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 2908 IF ( FPERE .NE. 0 ) THEN 2909 TYPEF = MUMPS_330(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) 2910 ELSE 2911 TYPEF = -9999 2912 END IF 2913 CALL CMUMPS_254( COMM_LOAD, ASS_IRECV, 2914 & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, 2915 & IFLAG,IERROR,OPELIW,NELVAW,NMAXNPIV, 2916 & PTRIST,PTLUST_S,PTRFAC, 2917 & PTRAST, STEP, PIMASTER, PAMASTER, 2918 & NE, POSFAC,LRLU, 2919 & LRLUS,IPTRLU,ICNTL,KEEP,KEEP8,COMP,IWPOS,IWPOSCB, 2920 & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, 2921 & IPOOL, LPOOL, LEAF, 2922 & NSTK_STEPS, NBPROCFILS, BUFR, LBUFR, LBUFR_BYTES, NBFIN, 2923 & root, OPASSW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 2924 & INTARR, DBLARR, 2925 & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, 2926 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 2927 IF (IFLAG.LT.0) GOTO 640 2928 200 CONTINUE 2929 IF ( INODE .eq. KEEP(38) ) THEN 2930 WRITE(*,*) 'Error .. in CMUMPS_251: ', 2931 & ' INODE == KEEP(38)' 2932 Stop 2933 END IF 2934 IF ( FPERE.EQ.0 ) THEN 2935 NBROOT_TRAITEES = NBROOT_TRAITEES + 1 2936 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN 2937 IF (KEEP(201).EQ.1) THEN 2938 CALL CMUMPS_681(IERR) 2939 ELSE IF ( KEEP(201).EQ.2) THEN 2940 CALL CMUMPS_580(IERR) 2941 ENDIF 2942 NBFIN = NBFIN - NBROOT 2943 IF ( NBFIN .LT. 0 ) THEN 2944 WRITE(*,*) ' ERROR 1 in CMUMPS_251: ', 2945 & ' NBFIN=', NBFIN 2946 CALL MUMPS_ABORT() 2947 END IF 2948 IF ( NBROOT .LT. 0 ) THEN 2949 WRITE(*,*) ' ERROR 1 in CMUMPS_251: ', 2950 & ' NBROOT=', NBROOT 2951 CALL MUMPS_ABORT() 2952 END IF 2953 IF (SLAVEF.GT.1) THEN 2954 DUMMY(1) = NBROOT 2955 CALL CMUMPS_242( DUMMY(1), 1, MPI_INTEGER, 2956 & MYID_NODES, COMM_NODES, RACINE, SLAVEF) 2957 END IF 2958 ENDIF 2959 IF (NBFIN.EQ.0)THEN 2960 GOTO 640 2961 ENDIF 2962 ELSEIF ( FPERE.NE.KEEP(38) .AND. 2963 & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)),SLAVEF).EQ. 2964 & MYID_NODES ) THEN 2965 NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 2966 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN 2967 IF (KEEP(234).NE.0 .AND. 2968 & MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF)) 2969 & THEN 2970 STACK_RIGHT_AUTHORIZED = .FALSE. 2971 ENDIF 2972 CALL CMUMPS_507(N, IPOOL, LPOOL, 2973 & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), 2974 & KEEP(80), KEEP(47), STEP, FPERE ) 2975 IF (KEEP(47) .GE. 3) THEN 2976 CALL CMUMPS_500( 2977 & IPOOL, LPOOL, 2978 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 2979 & MYID_NODES, STEP, N, ND, FILS ) 2980 ENDIF 2981 CALL MUMPS_137( FPERE, N, PROCNODE_STEPS,SLAVEF, 2982 & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), 2983 & KEEP(50), KEEP(253), FLOP1, 2984 & IW, LIW, KEEP(IXSZ) ) 2985 IF (FPERE.NE.KEEP(20)) 2986 & CALL CMUMPS_190(1,.FALSE.,FLOP1,KEEP,KEEP8) 2987 ENDIF 2988 ENDIF 2989 GO TO 20 2990 635 CONTINUE 2991 CALL CMUMPS_44( MYID_NODES, SLAVEF, COMM_NODES ) 2992 640 CONTINUE 2993 CALL CMUMPS_255( INFO(1), 2994 & ASS_IRECV, BUFR, LBUFR, 2995 & LBUFR_BYTES, 2996 & COMM_NODES, 2997 & MYID_NODES, SLAVEF) 2998 CALL CMUMPS_180( INFO(1), 2999 & BUFR, LBUFR, 3000 & LBUFR_BYTES, 3001 & COMM_NODES, COMM_LOAD, SLAVEF, MP) 3002 CALL MPI_BARRIER( COMM_NODES, IERR ) 3003 IF ( INFO(1) .GE. 0 ) THEN 3004 IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN 3005 MASTER_ROOT = MUMPS_275( 3006 & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), 3007 & SLAVEF) 3008 ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) 3009 IF ( KEEP(38) .NE. 0 )THEN 3010 IF (KEEP(60).EQ.0) THEN 3011 IOLDPS = PTLUST_S(STEP(KEEP(38))) 3012 LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) 3013 LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) 3014 ELSE 3015 IOLDPS = -999 3016 LOCAL_M = root%SCHUR_MLOC 3017 LOCAL_N = root%SCHUR_NLOC 3018 ENDIF 3019 ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) 3020 LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), 3021 & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) 3022 IF ( LRLU .GT. LBUFRX ) THEN 3023 BUFRX => A(POSFAC:POSFAC+LRLU-1_8) 3024 LBUFRX=LRLU 3025 IS_BUFRX_ALLOCATED = .FALSE. 3026 ELSE 3027 ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) 3028 IF (IERR.gt.0) THEN 3029 INFO(1) = -9 3030 CALL MUMPS_731(LBUFRX, INFO(2) ) 3031 IF (LP > 0 ) 3032 & write(LP,*) ' Error allocating, real array ', 3033 & 'of size before CMUMPS_146', LBUFRX 3034 CALL MUMPS_ABORT() 3035 ENDIF 3036 IS_BUFRX_ALLOCATED = .FALSE. 3037 ENDIF 3038 CALL CMUMPS_146( MYID_NODES, 3039 & root, N, KEEP(38), 3040 & COMM_NODES, IW, LIW, IWPOS + 1, 3041 & A, LA, PTRAST, PTLUST_S, PTRFAC, STEP, 3042 & INFO(1), KEEP(50), KEEP(19), 3043 & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP ) 3044 IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) 3045 NULLIFY(BUFRX) 3046 IF ( MYID_NODES .eq. 3047 & MUMPS_275(PROCNODE_STEPS(STEP(KEEP(38))), 3048 & SLAVEF) 3049 & ) THEN 3050 IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN 3051 NPVW = NPVW + INFO(2) 3052 ELSE 3053 NPVW = NPVW + root%TOT_ROOT_SIZE 3054 NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) 3055 END IF 3056 END IF 3057 IF (root%yes.AND.KEEP(60).EQ.0) THEN 3058 IF (KEEP(252).EQ.0) THEN 3059 IF (KEEP(201).EQ.1) THEN 3060 CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) 3061 LIWFAC = IW(IOLDPS+XXI) 3062 TYPEFile = TYPEF_L 3063 NextPiv2beWritten = 1 3064 MonBloc%INODE = KEEP(38) 3065 MonBloc%MASTER = .TRUE. 3066 MonBloc%Typenode = 3 3067 MonBloc%NROW = LOCAL_M 3068 MonBloc%NCOL = LOCAL_N 3069 MonBloc%NFS = MonBloc%NCOL 3070 MonBloc%Last = .TRUE. 3071 MonBloc%LastPiv = MonBloc%NCOL 3072 NULLIFY(MonBloc%INDICES) 3073 STRAT = STRAT_WRITE_MAX 3074 MonBloc%Last = .TRUE. 3075 LAST_CALL = .TRUE. 3076 CALL CMUMPS_688 3077 & ( STRAT, TYPEFile, 3078 & A(PTRFAC(STEP(KEEP(38)))), 3079 & LAFAC, MonBloc, 3080 & NextPiv2beWritten, IDUMMY, 3081 & IW(IOLDPS), LIWFAC, 3082 & MYID, KEEP8(31), IERR,LAST_CALL) 3083 ELSE IF (KEEP(201).EQ.2) THEN 3084 KEEP8(31)=KEEP8(31)+ ITMP8 3085 CALL CMUMPS_576(KEEP(38),PTRFAC, 3086 & KEEP,KEEP8,A,LA, ITMP8, IERR) 3087 IF(IERR.LT.0)THEN 3088 WRITE(*,*)MYID, 3089 & ': Internal error in CMUMPS_576' 3090 CALL MUMPS_ABORT() 3091 ENDIF 3092 ENDIF 3093 ENDIF 3094 IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN 3095 LRLUS = LRLUS + ITMP8 3096 IF (KEEP(252).NE.0) THEN 3097 CALL CMUMPS_471(.FALSE.,.FALSE., 3098 & LA-LRLUS 3099 & ,0_8,-ITMP8, 3100 & KEEP,KEEP8,LRLU) 3101 ELSE 3102 CALL CMUMPS_471(.FALSE.,.FALSE., 3103 & LA-LRLUS 3104 & ,ITMP8, 3105 & 0_8, 3106 & KEEP,KEEP8,LRLU) 3107 ENDIF 3108 IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN 3109 POSFAC = POSFAC - ITMP8 3110 LRLU = LRLU + ITMP8 3111 ENDIF 3112 ELSE 3113 CALL CMUMPS_471(.FALSE.,.FALSE., 3114 & LA-LRLUS 3115 & ,ITMP8, 3116 & 0_8, 3117 & KEEP,KEEP8,LRLU) 3118 ENDIF 3119 ENDIF 3120 IF (root%yes. AND. KEEP(252) .NE. 0 .AND. 3121 & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN 3122 IF (MYID_NODES .EQ. MASTER_ROOT) THEN 3123 LRHS_CNTR_MASTER_ROOT = root%TOT_ROOT_SIZE*KEEP(253) 3124 ELSE 3125 LRHS_CNTR_MASTER_ROOT = 1 3126 ENDIF 3127 ALLOCATE(root%RHS_CNTR_MASTER_ROOT( 3128 & LRHS_CNTR_MASTER_ROOT), stat=IERR ) 3129 IF (IERR.gt.0) THEN 3130 INFO(1) = -13 3131 CALL MUMPS_731(LRHS_CNTR_MASTER_ROOT,INFO(2)) 3132 IF (LP > 0 ) 3133 & write(LP,*) ' Error allocating, real array ', 3134 & 'of size before CMUMPS_146', 3135 & LRHS_CNTR_MASTER_ROOT 3136 CALL MUMPS_ABORT() 3137 ENDIF 3138 FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, 3139 & root%MYCOL, 0, root%NPCOL) 3140 FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) 3141 CALL CMUMPS_156( MYID_NODES, 3142 & root%TOT_ROOT_SIZE, KEEP(253), 3143 & root%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, 3144 & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, 3145 & root%RHS_ROOT(1,1), MASTER_ROOT, 3146 & root%NPROW, root%NPCOL, COMM_NODES ) 3147 & 3148 ENDIF 3149 ELSE 3150 IF (KEEP(19).NE.0) THEN 3151 CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, 3152 & MPI_INTEGER, MPI_SUM, 3153 & MASTER_ROOT, 3154 & COMM_NODES, IERR) 3155 ENDIF 3156 IF (ROOT_OWNER) THEN 3157 IPOSROOT = PTLUST_S(STEP(KEEP(20))) 3158 NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) 3159 NFRONT8 = int(NFRONT,8) 3160 IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ 3161 & IW(IPOSROOT+5+KEEP(IXSZ)) 3162 NPVW = NPVW + NFRONT 3163 NMAXNPIV = max(NMAXNPIV,NFRONT) 3164 END IF 3165 IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN 3166 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - 3167 & NFRONT8*NFRONT8 ) THEN 3168 POSFAC = POSFAC - NFRONT8*NFRONT8 3169 LRLUS = LRLUS + NFRONT8*NFRONT8 3170 LRLU = LRLUS + NFRONT8*NFRONT8 3171 CALL CMUMPS_471(.FALSE.,.FALSE., 3172 & LA-LRLUS,0_8,-NFRONT8*NFRONT8,KEEP,KEEP8,LRLU) 3173 ENDIF 3174 ENDIF 3175 END IF 3176 END IF 3177 END IF 3178 IF ( KEEP(38) .NE. 0 ) THEN 3179 IF (MYID_NODES.EQ. 3180 & MUMPS_275(PROCNODE_STEPS(STEP(KEEP(38))),SLAVEF) 3181 & ) THEN 3182 MAXFRW = max ( MAXFRW, root%TOT_ROOT_SIZE) 3183 END IF 3184 END IF 3185 MAXFRT = MAXFRW 3186 NTOTPV = NPVW 3187 INFO(12) = NOFFW 3188 RINFO(2) = real(OPASSW) 3189 RINFO(3) = real(OPELIW) 3190 INFO(13) = NELVAW 3191 INFO(14) = COMP 3192 RETURN 3193 END SUBROUTINE CMUMPS_251 3194 SUBROUTINE CMUMPS_87( HEADER, KEEP253 ) 3195 INTEGER HEADER( 6 ), KEEP253 3196 INTEGER NFRONT, NASS 3197 NFRONT = HEADER(1) 3198 IF ( HEADER(2) .ne. 0 ) THEN 3199 WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) 3200 CALL MUMPS_ABORT() 3201 END IF 3202 NASS = abs( HEADER( 3 ) ) 3203 IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN 3204 WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) 3205 CALL MUMPS_ABORT() 3206 END IF 3207 IF ( NASS+KEEP253 .NE. NFRONT ) THEN 3208 WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root' 3209 CALL MUMPS_ABORT() 3210 END IF 3211 HEADER( 1 ) = KEEP253 3212 HEADER( 2 ) = 0 3213 HEADER( 3 ) = NFRONT 3214 HEADER( 4 ) = NFRONT-KEEP253 3215 RETURN 3216 END SUBROUTINE CMUMPS_87 3217 SUBROUTINE CMUMPS_136( id ) 3218 USE CMUMPS_OOC 3219 USE CMUMPS_STRUC_DEF 3220 USE CMUMPS_COMM_BUFFER 3221 IMPLICIT NONE 3222 include 'mpif.h' 3223 TYPE( CMUMPS_STRUC ) :: id 3224 LOGICAL I_AM_SLAVE 3225 INTEGER IERR, MASTER 3226 PARAMETER ( MASTER = 0 ) 3227 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) 3228 IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN 3229 CALL CMUMPS_587(id,IERR) 3230 IF (IERR < 0) THEN 3231 id%INFO(1) = -90 3232 id%INFO(2) = 0 3233 ENDIF 3234 END IF 3235 CALL MUMPS_276(id%ICNTL(1), id%INFO(1), 3236 & id%COMM, id%MYID) 3237 IF (id%root%gridinit_done) THEN 3238 IF ( id%KEEP(38).NE.0 .and. id%root%yes ) THEN 3239 CALL blacs_gridexit( id%root%CNTXT_BLACS ) 3240 id%root%gridinit_done = .FALSE. 3241 END IF 3242 END IF 3243 IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN 3244 CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) 3245 CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) 3246 END IF 3247 IF (associated(id%MEM_DIST)) THEN 3248 DEALLOCATE(id%MEM_DIST) 3249 NULLIFY(id%MEM_DIST) 3250 ENDIF 3251 IF (associated(id%MAPPING)) THEN 3252 DEALLOCATE(id%MAPPING) 3253 NULLIFY(id%MAPPING) 3254 END IF 3255 NULLIFY(id%SCHUR_CINTERFACE) 3256 IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN 3257 IF (associated(id%COLSCA)) THEN 3258 DEALLOCATE(id%COLSCA) 3259 NULLIFY(id%COLSCA) 3260 ENDIF 3261 IF (associated(id%ROWSCA)) THEN 3262 DEALLOCATE(id%ROWSCA) 3263 NULLIFY(id%ROWSCA) 3264 ENDIF 3265 END IF 3266 IF (associated(id%PTLUST_S)) THEN 3267 DEALLOCATE(id%PTLUST_S) 3268 NULLIFY(id%PTLUST_S) 3269 END IF 3270 IF (associated(id%PTRFAC)) THEN 3271 DEALLOCATE(id%PTRFAC) 3272 NULLIFY(id%PTRFAC) 3273 END IF 3274 IF (associated(id%POIDS)) THEN 3275 DEALLOCATE(id%POIDS) 3276 NULLIFY(id%POIDS) 3277 ENDIF 3278 IF (associated(id%IS)) THEN 3279 DEALLOCATE(id%IS) 3280 NULLIFY(id%IS) 3281 ENDIF 3282 IF (associated(id%IS1)) THEN 3283 DEALLOCATE(id%IS1) 3284 NULLIFY(id%IS1) 3285 ENDIF 3286 IF (associated(id%STEP)) THEN 3287 DEALLOCATE(id%STEP) 3288 NULLIFY(id%STEP) 3289 ENDIF 3290 IF (associated(id%Step2node)) THEN 3291 DEALLOCATE(id%Step2node) 3292 NULLIFY(id%Step2node) 3293 ENDIF 3294 IF (associated(id%NE_STEPS)) THEN 3295 DEALLOCATE(id%NE_STEPS) 3296 NULLIFY(id%NE_STEPS) 3297 ENDIF 3298 IF (associated(id%ND_STEPS)) THEN 3299 DEALLOCATE(id%ND_STEPS) 3300 NULLIFY(id%ND_STEPS) 3301 ENDIF 3302 IF (associated(id%FRERE_STEPS)) THEN 3303 DEALLOCATE(id%FRERE_STEPS) 3304 NULLIFY(id%FRERE_STEPS) 3305 ENDIF 3306 IF (associated(id%DAD_STEPS)) THEN 3307 DEALLOCATE(id%DAD_STEPS) 3308 NULLIFY(id%DAD_STEPS) 3309 ENDIF 3310 IF (associated(id%SYM_PERM)) THEN 3311 DEALLOCATE(id%SYM_PERM) 3312 NULLIFY(id%SYM_PERM) 3313 ENDIF 3314 IF (associated(id%UNS_PERM)) THEN 3315 DEALLOCATE(id%UNS_PERM) 3316 NULLIFY(id%UNS_PERM) 3317 ENDIF 3318 IF (associated(id%PIVNUL_LIST)) THEN 3319 DEALLOCATE(id%PIVNUL_LIST) 3320 NULLIFY(id%PIVNUL_LIST) 3321 ENDIF 3322 IF (associated(id%FILS)) THEN 3323 DEALLOCATE(id%FILS) 3324 NULLIFY(id%FILS) 3325 ENDIF 3326 IF (associated(id%PTRAR)) THEN 3327 DEALLOCATE(id%PTRAR) 3328 NULLIFY(id%PTRAR) 3329 ENDIF 3330 IF (associated(id%FRTPTR)) THEN 3331 DEALLOCATE(id%FRTPTR) 3332 NULLIFY(id%FRTPTR) 3333 ENDIF 3334 IF (associated(id%FRTELT)) THEN 3335 DEALLOCATE(id%FRTELT) 3336 NULLIFY(id%FRTELT) 3337 ENDIF 3338 IF (associated(id%NA)) THEN 3339 DEALLOCATE(id%NA) 3340 NULLIFY(id%NA) 3341 ENDIF 3342 IF (associated(id%PROCNODE_STEPS)) THEN 3343 DEALLOCATE(id%PROCNODE_STEPS) 3344 NULLIFY(id%PROCNODE_STEPS) 3345 ENDIF 3346 IF (associated(id%PROCNODE)) THEN 3347 DEALLOCATE(id%PROCNODE) 3348 NULLIFY(id%PROCNODE) 3349 ENDIF 3350 IF (associated(id%RHSCOMP)) THEN 3351 DEALLOCATE(id%RHSCOMP) 3352 NULLIFY(id%RHSCOMP) 3353 ENDIF 3354 IF (associated(id%POSINRHSCOMP)) THEN 3355 DEALLOCATE(id%POSINRHSCOMP) 3356 NULLIFY(id%POSINRHSCOMP) 3357 ENDIF 3358 IF (id%KEEP(46).eq.1 .and. 3359 & id%KEEP(55).ne.0 .and. 3360 & id%MYID .eq. MASTER .and. 3361 & id%KEEP(52) .eq. 0 ) THEN 3362 NULLIFY(id%DBLARR) 3363 ELSE 3364 IF (associated(id%DBLARR)) THEN 3365 DEALLOCATE(id%DBLARR) 3366 NULLIFY(id%DBLARR) 3367 ENDIF 3368 END IF 3369 IF (associated(id%INTARR)) THEN 3370 DEALLOCATE(id%INTARR) 3371 NULLIFY(id%INTARR) 3372 ENDIF 3373 IF (associated(id%root%RG2L_ROW))THEN 3374 DEALLOCATE(id%root%RG2L_ROW) 3375 NULLIFY(id%root%RG2L_ROW) 3376 ENDIF 3377 IF (associated(id%root%RG2L_COL))THEN 3378 DEALLOCATE(id%root%RG2L_COL) 3379 NULLIFY(id%root%RG2L_COL) 3380 ENDIF 3381 IF (associated(id%root%IPIV)) THEN 3382 DEALLOCATE(id%root%IPIV) 3383 NULLIFY(id%root%IPIV) 3384 ENDIF 3385 IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN 3386 DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) 3387 NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) 3388 ENDIF 3389 IF (associated(id%root%RHS_ROOT))THEN 3390 DEALLOCATE(id%root%RHS_ROOT) 3391 NULLIFY(id%root%RHS_ROOT) 3392 ENDIF 3393 CALL CMUMPS_636(id) 3394 IF (associated(id%ELTPROC)) THEN 3395 DEALLOCATE(id%ELTPROC) 3396 NULLIFY(id%ELTPROC) 3397 ENDIF 3398 IF (associated(id%CANDIDATES)) THEN 3399 DEALLOCATE(id%CANDIDATES) 3400 NULLIFY(id%CANDIDATES) 3401 ENDIF 3402 IF (associated(id%I_AM_CAND)) THEN 3403 DEALLOCATE(id%I_AM_CAND) 3404 NULLIFY(id%I_AM_CAND) 3405 ENDIF 3406 IF (associated(id%ISTEP_TO_INIV2)) THEN 3407 DEALLOCATE(id%ISTEP_TO_INIV2) 3408 NULLIFY(id%ISTEP_TO_INIV2) 3409 ENDIF 3410 IF (I_AM_SLAVE) THEN 3411 IF (associated(id%TAB_POS_IN_PERE)) THEN 3412 DEALLOCATE(id%TAB_POS_IN_PERE) 3413 NULLIFY(id%TAB_POS_IN_PERE) 3414 ENDIF 3415 IF (associated(id%FUTURE_NIV2)) THEN 3416 DEALLOCATE(id%FUTURE_NIV2) 3417 NULLIFY(id%FUTURE_NIV2) 3418 ENDIF 3419 ENDIF 3420 IF(associated(id%DEPTH_FIRST))THEN 3421 DEALLOCATE(id%DEPTH_FIRST) 3422 NULLIFY(id%DEPTH_FIRST) 3423 ENDIF 3424 IF(associated(id%DEPTH_FIRST_SEQ))THEN 3425 DEALLOCATE(id%DEPTH_FIRST_SEQ) 3426 NULLIFY(id%DEPTH_FIRST_SEQ) 3427 ENDIF 3428 IF(associated(id%SBTR_ID))THEN 3429 DEALLOCATE(id%SBTR_ID) 3430 NULLIFY(id%SBTR_ID) 3431 ENDIF 3432 IF (associated(id%MEM_SUBTREE)) THEN 3433 DEALLOCATE(id%MEM_SUBTREE) 3434 NULLIFY(id%MEM_SUBTREE) 3435 ENDIF 3436 IF (associated(id%MY_ROOT_SBTR)) THEN 3437 DEALLOCATE(id%MY_ROOT_SBTR) 3438 NULLIFY(id%MY_ROOT_SBTR) 3439 ENDIF 3440 IF (associated(id%MY_FIRST_LEAF)) THEN 3441 DEALLOCATE(id%MY_FIRST_LEAF) 3442 NULLIFY(id%MY_FIRST_LEAF) 3443 ENDIF 3444 IF (associated(id%MY_NB_LEAF)) THEN 3445 DEALLOCATE(id%MY_NB_LEAF) 3446 NULLIFY(id%MY_NB_LEAF) 3447 ENDIF 3448 IF (associated(id%COST_TRAV)) THEN 3449 DEALLOCATE(id%COST_TRAV) 3450 NULLIFY(id%COST_TRAV) 3451 ENDIF 3452 IF(associated (id%OOC_INODE_SEQUENCE))THEN 3453 DEALLOCATE(id%OOC_INODE_SEQUENCE) 3454 NULLIFY(id%OOC_INODE_SEQUENCE) 3455 ENDIF 3456 IF(associated (id%OOC_TOTAL_NB_NODES))THEN 3457 DEALLOCATE(id%OOC_TOTAL_NB_NODES) 3458 NULLIFY(id%OOC_TOTAL_NB_NODES) 3459 ENDIF 3460 IF(associated (id%OOC_SIZE_OF_BLOCK))THEN 3461 DEALLOCATE(id%OOC_SIZE_OF_BLOCK) 3462 NULLIFY(id%OOC_SIZE_OF_BLOCK) 3463 ENDIF 3464 IF(associated (id%OOC_VADDR))THEN 3465 DEALLOCATE(id%OOC_VADDR) 3466 NULLIFY(id%OOC_VADDR) 3467 ENDIF 3468 IF(associated (id%OOC_NB_FILES))THEN 3469 DEALLOCATE(id%OOC_NB_FILES) 3470 NULLIFY(id%OOC_NB_FILES) 3471 ENDIF 3472 IF (id%KEEP8(24).EQ.0_8) THEN 3473 IF (associated(id%S)) DEALLOCATE(id%S) 3474 ELSE 3475 ENDIF 3476 NULLIFY(id%S) 3477 IF (I_AM_SLAVE) THEN 3478 CALL CMUMPS_57( IERR ) 3479 CALL CMUMPS_59( IERR ) 3480 END IF 3481 IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) 3482 NULLIFY( id%BUFR ) 3483 RETURN 3484 END SUBROUTINE CMUMPS_136 3485 SUBROUTINE CMUMPS_150(MYID,COMM,S,MAXS,MAXS_BYTES) 3486 IMPLICIT NONE 3487 INCLUDE 'mpif.h' 3488 INTEGER IERR, STATUS( MPI_STATUS_SIZE ) 3489 INTEGER COMM, MYID, MAXS, MAXS_BYTES 3490 INTEGER S( MAXS ) 3491 INTEGER MSGTAG, MSGSOU, MSGLEN 3492 LOGICAL FLAG 3493 FLAG = .TRUE. 3494 DO WHILE ( FLAG ) 3495 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 3496 & FLAG, STATUS, IERR ) 3497 IF (FLAG) THEN 3498 MSGTAG=STATUS(MPI_TAG) 3499 MSGSOU=STATUS(MPI_SOURCE) 3500 CALL MPI_GET_COUNT(STATUS,MPI_PACKED,MSGLEN,IERR) 3501 IF (MSGLEN <= MAXS_BYTES) THEN 3502 CALL MPI_RECV(S(1),MAXS_BYTES,MPI_PACKED, 3503 & MSGSOU, MSGTAG, COMM, STATUS, IERR) 3504 ELSE 3505 EXIT 3506 ENDIF 3507 END IF 3508 END DO 3509 CALL MPI_BARRIER( COMM, IERR ) 3510 RETURN 3511 END SUBROUTINE CMUMPS_150 3512 SUBROUTINE CMUMPS_254(COMM_LOAD, ASS_IRECV, 3513 & N, INODE, TYPE, TYPEF, 3514 & LA, IW, LIW, A, 3515 & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, 3516 & PTRIST, PTLUST_S, 3517 & PTRFAC, PTRAST, 3518 & STEP, PIMASTER, PAMASTER, NE, 3519 & POSFAC, LRLU, LRLUS, IPTRLU, ICNTL, KEEP,KEEP8, 3520 & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, 3521 & FPERE, COMM, MYID, 3522 & IPOOL, LPOOL, LEAF, NSTK_S, 3523 & NBPROCFILS, 3524 & BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, 3525 & OPASSW, ITLOC, RHS_MUMPS, 3526 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, 3527 & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, 3528 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 3529 USE CMUMPS_COMM_BUFFER 3530 USE CMUMPS_LOAD 3531 IMPLICIT NONE 3532 INCLUDE 'cmumps_root.h' 3533 TYPE (CMUMPS_ROOT_STRUC) :: root 3534 INTEGER COMM_LOAD, ASS_IRECV 3535 INTEGER COMM, MYID, TYPE, TYPEF 3536 INTEGER N, LIW, INODE,IFLAG,IERROR 3537 INTEGER ICNTL(40), KEEP(500) 3538 INTEGER(8) KEEP8(150) 3539 INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, IPTRLU 3540 INTEGER IWPOSCB, IWPOS, 3541 & FPERE, SLAVEF, NELVAW, NMAXNPIV 3542 INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) 3543 INTEGER(8) :: PTRAST (KEEP(28)) 3544 INTEGER(8) :: PTRFAC (KEEP(28)) 3545 INTEGER(8) :: PAMASTER(KEEP(28)) 3546 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) 3547 INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) 3548 COMPLEX A(LA) 3549 DOUBLE PRECISION OPASSW, OPELIW 3550 COMPLEX DBLARR(max(1,KEEP(13))) 3551 INTEGER INTARR(max(1,KEEP(14))) 3552 INTEGER ITLOC( N + KEEP(253) ), FILS( N ), 3553 & ND( KEEP(28) ), FRERE( KEEP(28) ) 3554 COMPLEX :: RHS_MUMPS(KEEP(255)) 3555 INTEGER ISTEP_TO_INIV2(KEEP(71)), 3556 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 3557 INTEGER NELT, LPTRAR 3558 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 3559 INTEGER PTRAIW( LPTRAR ), PTRARW( LPTRAR ) 3560 INTEGER LPOOL, LEAF, COMP 3561 INTEGER IPOOL( LPOOL ) 3562 INTEGER NSTK_S( KEEP(28) ) 3563 INTEGER NBPROCFILS( KEEP(28) ) 3564 INTEGER LBUFR, LBUFR_BYTES 3565 INTEGER BUFR( LBUFR ) 3566 INTEGER NBFIN 3567 INTEGER NFRONT_ESTIM,NELIM_ESTIM 3568 INTEGER MUMPS_275 3569 EXTERNAL MUMPS_275 3570 INCLUDE 'mpif.h' 3571 INCLUDE 'mumps_tags.h' 3572 INTEGER STATUS( MPI_STATUS_SIZE ) 3573 INTEGER LP 3574 INTEGER NBROWS_ALREADY_SENT 3575 INTEGER(8) :: POSELT, OPSFAC 3576 INTEGER(8) :: IOLD, INEW, FACTOR_POS 3577 INTEGER NSLAVES, NCB, 3578 & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, 3579 & NBROW_STACK, NBCOL_STACK, NELIM 3580 INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, 3581 &NCBROW_NEWLY_MOVED 3582 INTEGER(8) :: LAST_ALLOWED_POS 3583 INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE 3584 INTEGER(8) :: SHIFT_VAL_SON 3585 INTEGER SHIFT_LIST_ROW_SON, 3586 & SHIFT_LIST_COL_SON, 3587 & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES 3588 INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, 3589 & LREQI, LCONT 3590 INTEGER I,LDA, INIV2 3591 INTEGER MSGDEST, MSGTAG, CHK_LOAD 3592 INCLUDE 'mumps_headers.h' 3593 LOGICAL COMPRESSCB, MUST_COMPACT_FACTORS 3594 LOGICAL INPLACE 3595 INTEGER(8) :: SIZE_INPLACE 3596 INTEGER INTSIZ 3597 DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE 3598 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 3599 LOGICAL SSARBR, SSARBR_ROOT, MUMPS_167, 3600 &MUMPS_170 3601 EXTERNAL MUMPS_167, MUMPS_170 3602 LP = ICNTL(1) 3603 IF (ICNTL(4) .LE. 0) LP = -1 3604 INPLACE = .FALSE. 3605 MIN_SPACE_IN_PLACE = 0_8 3606 IOLDPS = PTLUST_S(STEP(INODE)) 3607 INTSIZ = IW(IOLDPS+XXI) 3608 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 3609 NPIV = IW(IOLDPS + 1+KEEP(IXSZ)) 3610 NMAXNPIV = max(NPIV, NMAXNPIV) 3611 NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) 3612 NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) 3613 H_INODE= 6 + NSLAVES + KEEP(IXSZ) 3614 LCONT = NFRONT - NPIV 3615 NBCOL = LCONT 3616 SSARBR = MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 3617 SSARBR_ROOT = MUMPS_170 3618 & (PROCNODE_STEPS(STEP(INODE)),SLAVEF) 3619 LREQCB = 0_8 3620 INPLACE = .FALSE. 3621 COMPRESSCB= ((KEEP(215).EQ.0) 3622 & .AND.(KEEP(50).NE.0) 3623 & .AND.(TYPEF.EQ.1 3624 & .OR.TYPEF.EQ.2 3625 & ) 3626 & .AND.(TYPE.EQ.1)) 3627 MUST_COMPACT_FACTORS = .TRUE. 3628 IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1) THEN 3629 MUST_COMPACT_FACTORS = .FALSE. 3630 ENDIF 3631 IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN 3632 IFLAG = -10 3633 GOTO 600 3634 ENDIF 3635 NBROW = LCONT 3636 IF (TYPE.EQ.2) NBROW = NASS - NPIV 3637 IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN 3638 LDA = NASS 3639 ELSE 3640 LDA = NFRONT 3641 ENDIF 3642 NBROW_SEND = NBROW 3643 NELIM = NASS-NPIV 3644 IF (TYPEF.EQ.2) NBROW_SEND = NELIM 3645 POSELT = PTRAST(STEP(INODE)) 3646 IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN 3647 WRITE(*,*) "Error 1 in G" 3648 CALL MUMPS_ABORT() 3649 END IF 3650 NELVAW = NELVAW + NASS - NPIV 3651 IF (KEEP(50) .eq. 0) THEN 3652 KEEP8(10) = KEEP8(10) + int(NPIV,8) * int(NFRONT,8) 3653 ELSE 3654 KEEP8(10) = KEEP8(10) + ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 3655 ENDIF 3656 KEEP8(10) = KEEP8(10) + int(NBROW,8) * int(NPIV,8) 3657 CALL MUMPS_511( NFRONT, NPIV, NASS, 3658 & KEEP(50), TYPE,FLOP1 ) 3659 IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN 3660 IF (NE(STEP(INODE))==0) THEN 3661 CHK_LOAD=0 3662 ELSE 3663 CHK_LOAD=1 3664 ENDIF 3665 CALL CMUMPS_190(CHK_LOAD, .FALSE., -FLOP1, 3666 & KEEP,KEEP8) 3667 ENDIF 3668 FLOP1_EFFECTIVE = FLOP1 3669 OPELIW = OPELIW + FLOP1 3670 IF ( NPIV .NE. NASS ) THEN 3671 CALL MUMPS_511( NFRONT, NASS, NASS, 3672 & KEEP(50), TYPE,FLOP1 ) 3673 IF (.NOT. SSARBR_ROOT ) THEN 3674 IF (NE(STEP(INODE))==0) THEN 3675 CHK_LOAD=0 3676 ELSE 3677 CHK_LOAD=1 3678 ENDIF 3679 CALL CMUMPS_190(CHK_LOAD, .FALSE., 3680 & FLOP1_EFFECTIVE-FLOP1, 3681 & KEEP,KEEP8) 3682 ENDIF 3683 END IF 3684 IF ( SSARBR_ROOT ) THEN 3685 NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) 3686 NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) 3687 CALL MUMPS_511(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, 3688 & KEEP(50),1,FLOP1) 3689 END IF 3690 FLOP1=-FLOP1 3691 IF (SSARBR_ROOT) THEN 3692 CALL CMUMPS_190(0,.FALSE.,FLOP1,KEEP,KEEP8) 3693 ELSE 3694 CALL CMUMPS_190(2,.FALSE.,FLOP1,KEEP,KEEP8) 3695 ENDIF 3696 IF ( FPERE .EQ. 0 ) THEN 3697 IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 3698 & .AND. KEEP(201).NE.1 ) THEN 3699 MUST_COMPACT_FACTORS = .TRUE. 3700 GOTO 190 3701 ELSE 3702 MUST_COMPACT_FACTORS = .FALSE. 3703 GOTO 190 3704 ENDIF 3705 ENDIF 3706 IF ( FPERE.EQ.KEEP(38) ) THEN 3707 NCB = NFRONT - NASS 3708 SHIFT_LIST_ROW_SON = H_INODE + NASS 3709 SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS 3710 SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) 3711 IF (TYPE.EQ.1) THEN 3712 CALL CMUMPS_80( 3713 & COMM_LOAD, ASS_IRECV, 3714 & N, INODE, FPERE, 3715 & PTLUST_S, PTRAST, 3716 & root, NCB, NCB, SHIFT_LIST_ROW_SON, 3717 & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, 3718 & ROOT_CONT_STATIC, MYID, COMM, 3719 & 3720 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3721 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 3722 & PTRIST, PTLUST_S, PTRFAC, 3723 & PTRAST, STEP, PIMASTER, PAMASTER, 3724 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 3725 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 3726 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 3727 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE, 3728 & LPTRAR, NELT, FRTPTR, FRTELT, 3729 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 3730 IF (IFLAG < 0 ) GOTO 500 3731 ENDIF 3732 MSGDEST= MUMPS_275(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) 3733 IOLDPS = PTLUST_S(STEP(INODE)) 3734 LIST_ROW_SON = IOLDPS + H_INODE + NPIV 3735 LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV 3736 LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) 3737 IF (MSGDEST.EQ.MYID) THEN 3738 CALL CMUMPS_273( root, 3739 & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), 3740 & IW(LIST_COL_SON), IW(LIST_SLAVES), 3741 & 3742 & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, 3743 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3744 & PTLUST_S, PTRFAC, 3745 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, 3746 & ITLOC, RHS_MUMPS, COMP, 3747 & IFLAG, IERROR, 3748 & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, 3749 & COMM, COMM_LOAD, FILS, ND) 3750 IF (IFLAG.LT.0) GOTO 600 3751 ELSE 3752 IERR = -1 3753 DO WHILE (IERR.EQ.-1) 3754 CALL CMUMPS_76( INODE, NELIM, 3755 & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, 3756 & IW(LIST_SLAVES), MSGDEST, COMM, IERR) 3757 IF ( IERR .EQ. -1 ) THEN 3758 BLOCKING =.FALSE. 3759 SET_IRECV =.TRUE. 3760 MESSAGE_RECEIVED = .FALSE. 3761 CALL CMUMPS_329( COMM_LOAD, ASS_IRECV, 3762 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3763 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3764 & STATUS, 3765 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3766 & IWPOS, IWPOSCB, IPTRLU, 3767 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3768 & PTLUST_S, PTRFAC, 3769 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 3770 & IFLAG, IERROR, COMM, 3771 & NBPROCFILS, 3772 & IPOOL, LPOOL, LEAF, 3773 & NBFIN, MYID, SLAVEF, 3774 & 3775 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3776 & FILS, PTRARW, PTRAIW, 3777 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, 3778 & ND, FRERE, LPTRAR, NELT, 3779 & FRTPTR, FRTELT, 3780 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 3781 & .TRUE.) 3782 IF ( IFLAG .LT. 0 ) GOTO 500 3783 IOLDPS = PTLUST_S(STEP(INODE)) 3784 LIST_ROW_SON = IOLDPS + H_INODE + NPIV 3785 LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV 3786 LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) 3787 ENDIF 3788 ENDDO 3789 IF ( IERR .EQ. -2 ) THEN 3790 IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) 3791 IFLAG = - 17 3792 GOTO 600 3793 ELSE IF ( IERR .EQ. -3 ) THEN 3794 IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) 3795 IFLAG = -20 3796 GOTO 600 3797 ENDIF 3798 ENDIF 3799 IF (NELIM.EQ.0) THEN 3800 POSELT = PTRAST(STEP(INODE)) 3801 OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) 3802 GOTO 190 3803 ELSE 3804 GOTO 500 3805 ENDIF 3806 ENDIF 3807 OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) 3808 IF ( MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), 3809 & SLAVEF) .NE. MYID ) THEN 3810 MSGTAG =NOEUD 3811 MSGDEST=MUMPS_275( PROCNODE_STEPS(STEP(FPERE)), SLAVEF ) 3812 IERR = -1 3813 NBROWS_ALREADY_SENT = 0 3814 DO WHILE (IERR.EQ.-1) 3815 IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN 3816 CALL CMUMPS_66( NBROWS_ALREADY_SENT, 3817 & INODE, FPERE, NFRONT, 3818 & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), 3819 & IW( IOLDPS + H_INODE + NPIV + NFRONT ), 3820 & A( OPSFAC ), COMPRESSCB, 3821 & MSGDEST, MSGTAG, COMM, IERR ) 3822 ELSE 3823 IF ( (TYPE.EQ.2).AND.(KEEP(48).NE.0)) THEN 3824 INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) 3825 ELSE 3826 INIV2 = -9999 3827 ENDIF 3828 CALL CMUMPS_70( NBROWS_ALREADY_SENT, 3829 & FPERE, INODE, 3830 & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), 3831 & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), 3832 & A(OPSFAC), LDA, NELIM, TYPE, 3833 & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, 3834 & COMM, IERR, 3835 & 3836 & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) 3837 END IF 3838 IF ( IERR .EQ. -1 ) THEN 3839 BLOCKING = .FALSE. 3840 SET_IRECV = .TRUE. 3841 MESSAGE_RECEIVED = .FALSE. 3842 CALL CMUMPS_329( COMM_LOAD, ASS_IRECV, 3843 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3844 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3845 & STATUS, 3846 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3847 & IWPOS, IWPOSCB, IPTRLU, 3848 & LRLU, LRLUS, N, IW, LIW, A, LA, 3849 & PTRIST, PTLUST_S, PTRFAC, 3850 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 3851 & IFLAG, IERROR, COMM, 3852 & NBPROCFILS, 3853 & IPOOL, LPOOL, LEAF, 3854 & NBFIN, MYID, SLAVEF, 3855 & 3856 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3857 & FILS, PTRARW, PTRAIW, 3858 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 3859 & LPTRAR, NELT, FRTPTR, FRTELT, 3860 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3861 IF ( IFLAG .LT. 0 ) GOTO 500 3862 ENDIF 3863 IOLDPS = PTLUST_S(STEP( INODE )) 3864 OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) 3865 END DO 3866 IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN 3867 IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN 3868 IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + 3869 & LCONT*LCONT * KEEP( 35 ) 3870 ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN 3871 IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) 3872 & * KEEP( 34 ) + 3873 & NBROW_SEND*NBROW_SEND*KEEP( 35 ) 3874 ELSE 3875 IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + 3876 & NBROW_SEND*NBCOL*KEEP( 35 ) 3877 ENDIF 3878 IF (IERR .EQ. -2) THEN 3879 IFLAG = -17 3880 IF ( LP > 0 ) THEN 3881 WRITE(LP, *) MYID, 3882 & ": FAILURE, SEND BUFFER TOO SMALL DURING 3883 & CMUMPS_254", TYPE, TYPEF 3884 ENDIF 3885 ENDIF 3886 IF (IERR .EQ. -3) THEN 3887 IFLAG = -20 3888 IF ( LP > 0 ) THEN 3889 WRITE(LP, *) MYID, 3890 & ": FAILURE, RECV BUFFER TOO SMALL DURING 3891 & CMUMPS_254", TYPE, TYPEF 3892 ENDIF 3893 ENDIF 3894 GOTO 600 3895 ENDIF 3896 ENDIF 3897 IF ( MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), 3898 & SLAVEF) .EQ. MYID ) THEN 3899 LREQI = 2 + KEEP(IXSZ) 3900 NBROW_STACK = NBROW 3901 NBROW_SEND = 0 3902 IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN 3903 NBCOL_STACK = NBROW 3904 ELSE 3905 NBCOL_STACK = NBCOL 3906 ENDIF 3907 ELSE 3908 NBROW_STACK = NBROW-NBROW_SEND 3909 NBCOL_STACK = NBCOL 3910 LREQI = 6 + NBROW_STACK + NBCOL + KEEP(IXSZ) 3911 IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 3912 IF (FPERE.EQ.0) GOTO 190 3913 ENDIF 3914 IF (COMPRESSCB) THEN 3915 LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 3916 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 3917 ELSE 3918 LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) 3919 ENDIF 3920 INPLACE = ( KEEP(234).NE.0 ) 3921 IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. 3922 INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS 3923 INPLACE = INPLACE .AND. 3924 & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) 3925 MIN_SPACE_IN_PLACE = 0_8 3926 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. 3927 & MUST_COMPACT_FACTORS) THEN 3928 MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) 3929 ENDIF 3930 IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN 3931 INPLACE = .FALSE. 3932 ENDIF 3933 CALL CMUMPS_22( INPLACE, MIN_SPACE_IN_PLACE, 3934 & SSARBR, .FALSE., 3935 & MYID,N,KEEP,KEEP8,IW, LIW, A, LA, 3936 & LRLU, IPTRLU,IWPOS,IWPOSCB, 3937 & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, 3938 & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., 3939 & COMP, LRLUS, IFLAG, IERROR ) 3940 IF (IFLAG.LT.0) GOTO 600 3941 PTRIST(STEP(INODE)) = IWPOSCB+1 3942 IF ( MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), 3943 & SLAVEF) .EQ. MYID ) THEN 3944 PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) 3945 PAMASTER(STEP(INODE)) = IPTRLU + 1_8 3946 PTRAST(STEP(INODE)) = -99999999_8 3947 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) 3948 IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK 3949 IF (COMPRESSCB) IW(IWPOSCB+1+XXS) = S_CB1COMP 3950 ELSE 3951 PTRAST(STEP(INODE)) = IPTRLU+1_8 3952 IF (COMPRESSCB) IW(IWPOSCB+1+XXS)=S_CB1COMP 3953 IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL 3954 IW(IWPOSCB+2+KEEP(IXSZ)) = 0 3955 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK 3956 IW(IWPOSCB+4+KEEP(IXSZ)) = 0 3957 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 3958 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 3959 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE 3960 PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) 3961 DO I = 1, NBROW_STACK 3962 IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = 3963 & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) 3964 ENDDO 3965 DO I = 1, NBCOL 3966 IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) 3967 ENDDO 3968 END IF 3969 IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 3970 & .AND. MUST_COMPACT_FACTORS ) THEN 3971 POSELT = PTRFAC(STEP(INODE)) 3972 CALL CMUMPS_324(A(POSELT), LDA, 3973 & NPIV, NBROW, KEEP(50)) 3974 MUST_COMPACT_FACTORS = .FALSE. 3975 ENDIF 3976 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) 3977 & THEN 3978 LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) 3979 & + int(NPIV,8) 3980 ELSE 3981 LAST_ALLOWED_POS = -1_8 3982 ENDIF 3983 NCBROW_ALREADY_MOVED = 0 3984 10 CONTINUE 3985 NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED 3986 IF (IPTRLU .LT. POSFAC ) THEN 3987 CALL CMUMPS_652( A, LA, LDA, 3988 & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, 3989 & NBROW_SEND, LREQCB, KEEP, COMPRESSCB, 3990 & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) 3991 ELSE 3992 CALL CMUMPS_705( A, LA, LDA, 3993 & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, 3994 & NBROW_SEND, LREQCB, KEEP, COMPRESSCB ) 3995 NCBROW_ALREADY_MOVED = NBROW_STACK 3996 ENDIF 3997 IF (LAST_ALLOWED_POS .NE. -1_8) THEN 3998 MUST_COMPACT_FACTORS =.FALSE. 3999 IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN 4000 NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND 4001 ENDIF 4002 NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED 4003 & - NCBROW_PREVIOUSLY_MOVED 4004 FACTOR_POS = POSELT + 4005 & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) 4006 CALL CMUMPS_651( A(FACTOR_POS), LDA, NPIV, 4007 & NCBROW_NEWLY_MOVED ) 4008 INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) 4009 IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) 4010 DO I = 1, NCBROW_PREVIOUSLY_MOVED*NPIV 4011 A(INEW) = A(IOLD) 4012 IOLD = IOLD + 1_8 4013 INEW = INEW + 1_8 4014 ENDDO 4015 KEEP8(8)=KEEP8(8) + int(NCBROW_PREVIOUSLY_MOVED,8) 4016 & * int(NPIV,8) 4017 LAST_ALLOWED_POS = INEW 4018 IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN 4019 GOTO 10 4020 ENDIF 4021 ENDIF 4022 190 CONTINUE 4023 IF (MUST_COMPACT_FACTORS) THEN 4024 POSELT = PTRFAC(STEP(INODE)) 4025 CALL CMUMPS_324(A(POSELT), LDA, 4026 & NPIV, NBROW, KEEP(50)) 4027 MUST_COMPACT_FACTORS = .FALSE. 4028 ENDIF 4029 IOLDPS = PTLUST_S(STEP(INODE)) 4030 IW(IOLDPS+KEEP(IXSZ)) = NBCOL 4031 IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV 4032 IF (TYPE.EQ.2) THEN 4033 IW(IOLDPS + 2+KEEP(IXSZ)) = NASS 4034 ELSE 4035 IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT 4036 ENDIF 4037 IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV 4038 IF (INPLACE) THEN 4039 SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE 4040 ELSE 4041 SIZE_INPLACE = 0_8 4042 ENDIF 4043 CALL CMUMPS_93(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, 4044 & A, LA, POSFAC, LRLU, LRLUS, 4045 & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR) 4046 IF(IERR.LT.0)THEN 4047 IFLAG=IERR 4048 IERROR=0 4049 GOTO 600 4050 ENDIF 4051 500 CONTINUE 4052 RETURN 4053 600 CONTINUE 4054 IF (IFLAG .NE. -1) CALL CMUMPS_44( MYID, SLAVEF, COMM ) 4055 RETURN 4056 END SUBROUTINE CMUMPS_254 4057 SUBROUTINE CMUMPS_142( id) 4058 USE CMUMPS_COMM_BUFFER 4059 USE CMUMPS_LOAD 4060 USE CMUMPS_OOC 4061 USE CMUMPS_STRUC_DEF 4062 IMPLICIT NONE 4063#ifndef SUN_ 4064 INTERFACE 4065 SUBROUTINE CMUMPS_27(id, ANORMINF, LSCAL) 4066 USE CMUMPS_STRUC_DEF 4067 TYPE (CMUMPS_STRUC), TARGET :: id 4068 REAL, INTENT(OUT) :: ANORMINF 4069 LOGICAL :: LSCAL 4070 END SUBROUTINE CMUMPS_27 4071 END INTERFACE 4072#endif 4073 TYPE(CMUMPS_STRUC), TARGET :: id 4074 INCLUDE 'mpif.h' 4075 INCLUDE 'mumps_tags.h' 4076 INTEGER STATUS( MPI_STATUS_SIZE ) 4077 INTEGER IERR, MASTER 4078 PARAMETER( MASTER = 0 ) 4079 INCLUDE 'mumps_headers.h' 4080 INTEGER NSEND, NSEND_TOT, LDPTRAR, NELT 4081 INTEGER NLOCAL, NLOCAL_TOT, KEEP13_SAVE, ITMP 4082 INTEGER(8) K67 4083 INTEGER(8) ITMP8 4084 INTEGER MUMPS_275 4085 EXTERNAL MUMPS_275 4086 INTEGER MP, LP, MPG, allocok 4087 LOGICAL PROK, PROKG, LSCAL 4088 INTEGER CMUMPS_LBUF, CMUMPS_LBUFR_BYTES, CMUMPS_LBUF_INT 4089 INTEGER PTRIST, PTRWB, MAXELT_SIZE, 4090 & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW 4091 INTEGER IRANK, ID_ROOT 4092 INTEGER KKKK, NZ_locMAX 4093 INTEGER(8) MEMORY_MD_ARG 4094 INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 4095 REAL CNTL4 4096 INTEGER MIN_PERLU, MAXIS_ESTIM 4097 INTEGER MAXIS 4098 INTEGER(8) :: MAXS 4099 DOUBLE PRECISION TIME 4100 REAL ZERO 4101 PARAMETER( ZERO = 0.0E0 ) 4102 INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233 4103 INTEGER COLOUR, COMM_FOR_SCALING 4104 INTEGER LIWK, LWK, LWK_REAL 4105 LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED 4106 REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2 4107 REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS 4108 INTEGER N, LPN_LIST,POSBUF 4109 INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 4110 INTEGER I,K 4111 INTEGER, DIMENSION(:), ALLOCATABLE :: IWK 4112 COMPLEX, DIMENSION(:), ALLOCATABLE :: WK 4113 REAL, DIMENSION(:), ALLOCATABLE :: WK_REAL 4114 INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 4115 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP 4116 INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP 4117 INTEGER, DIMENSION(:), ALLOCATABLE :: BURS 4118 INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS 4119 INTEGER BUREGISTRE(12) 4120 INTEGER BUINTSZ, BURESZ, BUJOB 4121 INTEGER BUMAXMN, M, SCMYID, SCNPROCS 4122 REAL SCONEERR, SCINFERR 4123 INTEGER, POINTER :: JOB, NZ 4124 REAL,DIMENSION(:),POINTER::RINFO, RINFOG 4125 REAL,DIMENSION(:),POINTER:: CNTL 4126 INTEGER,DIMENSION(:),POINTER::INFO, INFOG, KEEP 4127 INTEGER, DIMENSION(:), POINTER :: MYIRN_loc, MYJCN_loc 4128 COMPLEX, DIMENSION(:), POINTER :: MYA_loc 4129 INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) 4130 COMPLEX, TARGET :: DUMMYA_loc(1) 4131 INTEGER(8),DIMENSION(:),POINTER::KEEP8 4132 INTEGER,DIMENSION(:),POINTER::ICNTL 4133 EXTERNAL CMUMPS_505 4134 INTEGER CMUMPS_505 4135 INTEGER(8) TOTAL_BYTES 4136 INTEGER(8) :: I8TMP 4137 INTEGER numroc 4138 EXTERNAL numroc 4139 COMPLEX, DIMENSION(:), POINTER :: RHS_MUMPS 4140 LOGICAL :: RHS_MUMPS_ALLOCATED 4141 JOB=>id%JOB 4142 NZ=>id%NZ 4143 RINFO=>id%RINFO 4144 RINFOG=>id%RINFOG 4145 CNTL=>id%CNTL 4146 INFO=>id%INFO 4147 INFOG=>id%INFOG 4148 KEEP=>id%KEEP 4149 KEEP8=>id%KEEP8 4150 ICNTL=>id%ICNTL 4151 IF (id%NZ_loc .NE. 0) THEN 4152 MYIRN_loc=>id%IRN_loc 4153 MYJCN_loc=>id%JCN_loc 4154 MYA_loc=>id%A_loc 4155 ELSE 4156 MYIRN_loc=>DUMMYIRN_loc 4157 MYJCN_loc=>DUMMYJCN_loc 4158 MYA_loc=>DUMMYA_loc 4159 ENDIF 4160 N = id%N 4161 EPS = epsilon ( ZERO ) 4162 NULLIFY(RHS_MUMPS) 4163 RHS_MUMPS_ALLOCATED = .FALSE. 4164 IF (KEEP8(24).GT.0_8) THEN 4165 NULLIFY(id%S) 4166 ENDIF 4167 WK_USER_PROVIDED = (id%LWK_USER.NE.0) 4168 IF (WK_USER_PROVIDED) THEN 4169 IF (id%LWK_USER.GT.0) THEN 4170 KEEP8(24) = int(id%LWK_USER,8) 4171 ELSE 4172 KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 4173 ENDIF 4174 ELSE 4175 KEEP8(24) = 0_8 4176 ENDIF 4177 KEEP13_SAVE = KEEP(13) 4178 id%DKEEP(4)=-1.0E0 4179 id%DKEEP(5)=-1.0E0 4180 MP = ICNTL( 2 ) 4181 MPG = ICNTL( 3 ) 4182 LP = ICNTL( 1 ) 4183 PROK = ( MP .GT. 0 ) 4184 PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) 4185 IF ( PROK ) WRITE( MP, 130 ) 4186 IF ( PROKG ) WRITE( MPG, 130 ) 4187 IF ( PROKG .and. KEEP(53).GT.0 ) THEN 4188 WRITE(MPG,'(/A,I3)') ' Null space option :', KEEP(19) 4189 IF ( KEEP(21) .ne. 0 ) THEN 4190 WRITE( MPG, '(A,I10)') ' Max deficiency : ', KEEP(21) 4191 END IF 4192 IF ( KEEP(22) .ne. 0 ) THEN 4193 WRITE( MPG, '(A,I10)') ' Min deficiency : ', KEEP(22) 4194 END IF 4195 END IF 4196 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. 4197 & ( id%MYID .eq. MASTER .AND. 4198 & KEEP(46) .eq. 1 ) ) 4199 IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN 4200 KEEP(201)=id%ICNTL(22) 4201 IF (KEEP(201) .NE. 0) THEN 4202# if defined(OLD_OOC_NOPANEL) 4203 KEEP(201)=2 4204# else 4205 KEEP(201)=1 4206# endif 4207 ENDIF 4208 ENDIF 4209 CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, 4210 & MASTER, id%COMM, IERR ) 4211 CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, 4212 & MASTER, id%COMM, IERR ) 4213 CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, 4214 & MASTER, id%COMM, IERR ) 4215 CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, 4216 & MASTER, id%COMM, IERR ) 4217 IF (id%MYID.EQ.MASTER) THEN 4218 IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN 4219 KEEP(217)=0 4220 ENDIF 4221 KEEP(214)=KEEP(217) 4222 IF (KEEP(214).EQ.0) THEN 4223 IF (KEEP(201).NE.0) THEN 4224 KEEP(214)=1 4225 ELSE 4226 KEEP(214)=2 4227 ENDIF 4228 ENDIF 4229 ENDIF 4230 CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, 4231 & MASTER, id%COMM, IERR ) 4232 IF (KEEP(201).NE.0) THEN 4233 CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, 4234 & MASTER, id%COMM, IERR ) 4235 CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, 4236 & MASTER, id%COMM, IERR ) 4237 CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, 4238 & MASTER, id%COMM, IERR ) 4239 ENDIF 4240 IF ( KEEP(50) .eq. 1 ) THEN 4241 IF (id%CNTL(1) .ne. ZERO ) THEN 4242 IF ( MPG .GT. 0 ) THEN 4243 WRITE(MPG,'(A)') 4244 &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' 4245 END IF 4246 END IF 4247 id%CNTL(1) = ZERO 4248 END IF 4249 IF (KEEP(219).NE.0) THEN 4250 CALL CMUMPS_617(max(KEEP(108),1),IERR) 4251 IF (IERR .NE. 0) THEN 4252 INFO(1) = -13 4253 INFO(2) = max(KEEP(108),1) 4254 END IF 4255 ENDIF 4256 IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN 4257 IF (id%ICNTL(20).EQ.1) THEN 4258 id%INFO(1)=-43 4259 id%INFO(2)=20 4260 IF (PROKG) WRITE(MPG,'(A)') 4261 & ' ERROR: Sparse RHS is incompatible with forward', 4262 & ' performed during factorization (ICNTL(32)=1)' 4263 ELSE IF (id%ICNTL(30).NE.0) THEN 4264 id%INFO(1)=-43 4265 id%INFO(2)=30 4266 IF (PROKG) WRITE(MPG,'(A)') 4267 & ' ERROR: A-1 functionality incompatible with forward', 4268 & ' performed during factorization (ICNTL(32)=1)' 4269 ELSE IF (id%ICNTL(9) .NE. 1) THEN 4270 id%INFO(1)=-43 4271 id%INFO(2)=9 4272 IF (PROKG) WRITE(MPG,'(A)') 4273 & ' ERROR: sparse RHS incompatible with forward', 4274 & ' performed during factorization (ICNTL(32)=1)' 4275 ENDIF 4276 ENDIF 4277 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 4278 & id%COMM, id%MYID ) 4279 IF (INFO(1).LT.0) GOTO 530 4280 IF ( PROKG ) THEN 4281 WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), 4282 & KEEP8(111), KEEP(126), KEEP(127), KEEP(28) 4283 IF (KEEP(252).GT.0) 4284 & WRITE(MPG,173) KEEP(253) 4285 ENDIF 4286 IF (KEEP(201).LE.0) THEN 4287 KEEP(IXSZ)=XSIZE_IC 4288 ELSE IF (KEEP(201).EQ.2) THEN 4289 KEEP(IXSZ)=XSIZE_OOC_NOPANEL 4290 ELSE IF (KEEP(201).EQ.1) THEN 4291 IF (KEEP(50).EQ.0) THEN 4292 KEEP(IXSZ)=XSIZE_OOC_UNSYM 4293 ELSE 4294 KEEP(IXSZ)=XSIZE_OOC_SYM 4295 ENDIF 4296 ENDIF 4297 IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) 4298 CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, 4299 & MASTER, id%COMM, IERR) 4300 IF (KEEP(258) .NE. 0) THEN 4301 KEEP(259) = 0 4302 KEEP(260) = 1 4303 id%DKEEP(6) = 1.0E0 4304 id%DKEEP(7) = 0.0E0 4305 ENDIF 4306 CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, 4307 & MASTER, id%COMM, IERR) 4308 LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) 4309 IF (LSCAL) THEN 4310 IF ( id%MYID.EQ.MASTER ) THEN 4311 ENDIF 4312 IF (KEEP(52) .EQ. 7) THEN 4313 K231= KEEP(231) 4314 K232= KEEP(232) 4315 K233= KEEP(233) 4316 ELSEIF (KEEP(52) .EQ. 8) THEN 4317 K231= KEEP(239) 4318 K232= KEEP(240) 4319 K233= KEEP(241) 4320 ENDIF 4321 CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, 4322 & id%COMM,IERR) 4323 IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. 4324 & KEEP(54).NE.0 ) THEN 4325 IF ( id%MYID .NE. MASTER ) THEN 4326 IF ( associated(id%COLSCA)) 4327 & DEALLOCATE( id%COLSCA ) 4328 IF ( associated(id%ROWSCA)) 4329 & DEALLOCATE( id%ROWSCA ) 4330 ALLOCATE( id%COLSCA(N), stat=IERR) 4331 IF (IERR .GT.0) THEN 4332 id%INFO(1)=-13 4333 id%INFO(2)=N 4334 ENDIF 4335 ALLOCATE( id%ROWSCA(N), stat=IERR) 4336 IF (IERR .GT.0) THEN 4337 id%INFO(1)=-13 4338 id%INFO(2)=N 4339 ENDIF 4340 ENDIF 4341 M = N 4342 BUMAXMN=M 4343 IF(N > BUMAXMN) BUMAXMN = N 4344 LIWK = 4*BUMAXMN 4345 ALLOCATE (IWK(LIWK),BURP(M),BUCP(N), 4346 & BURS(2* (id%NPROCS)),BUCS(2* (id%NPROCS)), 4347 & stat=allocok) 4348 IF (allocok > 0) THEN 4349 INFO(1)=-13 4350 INFO(2)=LIWK+M+N+4* (id%NPROCS) 4351 ENDIF 4352 CALL MUMPS_276( ICNTL(1), INFO(1), 4353 & id%COMM, id%MYID ) 4354 IF (INFO(1).LT.0) GOTO 530 4355 BUJOB = 1 4356 LWK_REAL = 1 4357 ALLOCATE(WK_REAL(LWK_REAL)) 4358 CALL CMUMPS_693( 4359 & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), 4360 & id%NZ_loc, 4361 & M, N, id%NPROCS, id%MYID, id%COMM, 4362 & BURP, BUCP, 4363 & BURS, BUCS, BUREGISTRE, 4364 & IWK, LIWK, 4365 & BUINTSZ, BURESZ, BUJOB, 4366 & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, 4367 & id%KEEP(50), 4368 & K231, K232, K233, 4369 & id%DKEEP(3), 4370 & SCONEERR, SCINFERR) 4371 IF(LIWK < BUINTSZ) THEN 4372 DEALLOCATE(IWK) 4373 LIWK = BUINTSZ 4374 ALLOCATE(IWK(LIWK), stat=allocok) 4375 IF (allocok > 0) THEN 4376 INFO(1)=-13 4377 INFO(2)=LIWK 4378 ENDIF 4379 ENDIF 4380 LWK_REAL = BURESZ 4381 DEALLOCATE(WK_REAL) 4382 ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) 4383 IF (allocok > 0) THEN 4384 INFO(1)=-13 4385 INFO(2)=LWK_REAL 4386 ENDIF 4387 CALL MUMPS_276( ICNTL(1), INFO(1), 4388 & id%COMM, id%MYID ) 4389 IF (INFO(1).LT.0) GOTO 530 4390 BUJOB = 2 4391 CALL CMUMPS_693( 4392 & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), 4393 & id%NZ_loc, 4394 & M, N, id%NPROCS, id%MYID, id%COMM, 4395 & BURP, BUCP, 4396 & BURS, BUCS, BUREGISTRE, 4397 & IWK, LIWK, 4398 & BUINTSZ, BURESZ, BUJOB, 4399 & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, 4400 & id%KEEP(50), 4401 & K231, K232, K233, 4402 & id%DKEEP(3), 4403 & SCONEERR, SCINFERR) 4404 id%DKEEP(4) = SCONEERR 4405 id%DKEEP(5) = SCINFERR 4406 DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) 4407 ELSE IF ( KEEP(54) .EQ. 0 ) THEN 4408 IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 4409 IF (id%MYID.EQ.MASTER) THEN 4410 COLOUR = 0 4411 ELSE 4412 COLOUR = MPI_UNDEFINED 4413 ENDIF 4414 CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, 4415 & COMM_FOR_SCALING, IERR ) 4416 IF (id%MYID.EQ.MASTER) THEN 4417 M = N 4418 BUMAXMN=N 4419 IF(N > BUMAXMN) BUMAXMN = N 4420 LIWK = 1 4421 ALLOCATE (IWK(LIWK),BURP(1),BUCP(1), 4422 & BURS(1),BUCS(1), 4423 & stat=allocok) 4424 LWK_REAL = M + N 4425 ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) 4426 IF (allocok > 0) THEN 4427 INFO(1)=-13 4428 INFO(2)=1 4429 ENDIF 4430 IF (INFO(1) .LT. 0) GOTO 400 4431 CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) 4432 CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) 4433 BUJOB = 1 4434 CALL CMUMPS_693( 4435 & id%IRN(1), id%JCN(1), id%A(1), 4436 & id%NZ, 4437 & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, 4438 & BURP, BUCP, 4439 & BURS, BUCS, BUREGISTRE, 4440 & IWK, LIWK, 4441 & BUINTSZ, BURESZ, BUJOB, 4442 & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, 4443 & id%KEEP(50), 4444 & K231, K232, K233, 4445 & id%DKEEP(3), 4446 & SCONEERR, SCINFERR) 4447 IF(LWK_REAL < BURESZ) THEN 4448 INFO(1) = -136 4449 GOTO 400 4450 ENDIF 4451 BUJOB = 2 4452 CALL CMUMPS_693(id%IRN(1), 4453 & id%JCN(1), id%A(1), 4454 & id%NZ, 4455 & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, 4456 & BURP, BUCP, 4457 & BURS, BUCS, BUREGISTRE, 4458 & IWK, LIWK, 4459 & BUINTSZ, BURESZ, BUJOB, 4460 & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, 4461 & id%KEEP(50), 4462 & K231, K232, K233, 4463 & id%DKEEP(3), 4464 & SCONEERR, SCINFERR) 4465 id%DKEEP(4) = SCONEERR 4466 id%DKEEP(5) = SCINFERR 4467 DEALLOCATE(WK_REAL) 4468 DEALLOCATE (IWK,BURP,BUCP, 4469 & BURS,BUCS) 4470 ENDIF 4471 CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, 4472 & MASTER, id%COMM, IERR ) 4473 400 CONTINUE 4474 IF (id%MYID.EQ.MASTER) THEN 4475 CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) 4476 ENDIF 4477 CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) 4478 IF (INFO(1).LT.0) GOTO 530 4479 ELSE IF (id%MYID.EQ.MASTER) THEN 4480 IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN 4481 IF ( KEEP(52) .eq. 5 .or. 4482 & KEEP(52) .eq. 6 ) THEN 4483 LWK = NZ 4484 ELSE 4485 LWK = 1 4486 END IF 4487 LWK_REAL = 5 * N 4488 ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) 4489 IF ( IERR .GT. 0 ) THEN 4490 INFO(1) = -13 4491 INFO(2) = LWK_REAL 4492 GOTO 137 4493 END IF 4494 ALLOCATE( WK( LWK ), stat = IERR ) 4495 IF ( IERR .GT. 0 ) THEN 4496 INFO(1) = -13 4497 INFO(2) = LWK 4498 GOTO 137 4499 END IF 4500 CALL CMUMPS_217(N, NZ, KEEP(52), id%A(1), 4501 & id%IRN(1), id%JCN(1), 4502 & id%COLSCA(1), id%ROWSCA(1), 4503 & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), INFO(1) ) 4504 DEALLOCATE( WK_REAL ) 4505 DEALLOCATE( WK ) 4506 ENDIF 4507 ENDIF 4508 ENDIF 4509 IF (id%MYID.EQ.MASTER) THEN 4510 IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8) 4511 & .AND. (K233+K231+K232).GT.0) THEN 4512 IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) 4513 ENDIF 4514 ENDIF 4515 ENDIF 4516 LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) 4517 IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN 4518 DO I = 1, id%N 4519 CALL CMUMPS_761(id%ROWSCA(I), 4520 & id%DKEEP(6), 4521 & KEEP(259)) 4522 ENDDO 4523 IF (KEEP(50) .EQ. 0) THEN 4524 DO I = 1, id%N 4525 CALL CMUMPS_761(id%COLSCA(I), 4526 & id%DKEEP(6), 4527 & KEEP(259)) 4528 ENDDO 4529 ELSE 4530 CALL CMUMPS_765(id%DKEEP(6), KEEP(259)) 4531 ENDIF 4532 CALL CMUMPS_766(id%DKEEP(6), KEEP(259)) 4533 ENDIF 4534 137 CONTINUE 4535 IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN 4536 DEALLOCATE (id%root%RHS_CNTR_MASTER_ROOT) 4537 NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) 4538 ENDIF 4539 IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. 4540 & id%NRHS .NE. id%KEEP(253) ) THEN 4541 id%INFO(1)=-42 4542 id%INFO(2)=id%KEEP(253) 4543 ENDIF 4544 IF (id%KEEP(252) .EQ. 1) THEN 4545 IF ( id%MYID.NE.MASTER ) THEN 4546 id%KEEP(254) = N 4547 id%KEEP(255) = N*id%KEEP(253) 4548 ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) 4549 IF (IERR > 0) THEN 4550 INFO(1)=-13 4551 INFO(2)=id%KEEP(255) 4552 IF (LP > 0) 4553 & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' 4554 NULLIFY(RHS_MUMPS) 4555 ENDIF 4556 RHS_MUMPS_ALLOCATED = .TRUE. 4557 ELSE 4558 id%KEEP(254)=id%LRHS 4559 id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N 4560 RHS_MUMPS=>id%RHS 4561 RHS_MUMPS_ALLOCATED = .FALSE. 4562 IF (LSCAL) THEN 4563 DO K=1, id%KEEP(253) 4564 DO I=1, N 4565 RHS_MUMPS( id%KEEP(254) * (K-1) + I ) 4566 & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) 4567 & * id%ROWSCA(I) 4568 ENDDO 4569 ENDDO 4570 ENDIF 4571 ENDIF 4572 DO I= 1, id%KEEP(253) 4573 CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, 4574 & MPI_COMPLEX, MASTER,id%COMM,IERR) 4575 END DO 4576 ELSE 4577 id%KEEP(255)=1 4578 ALLOCATE(RHS_MUMPS(1)) 4579 RHS_MUMPS_ALLOCATED = .TRUE. 4580 ENDIF 4581 CALL MUMPS_276( ICNTL(1), INFO(1), 4582 & id%COMM, id%MYID ) 4583 IF ( INFO(1).lt.0 ) GOTO 530 4584 KEEP(110)=ICNTL(24) 4585 CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, 4586 & MASTER, id%COMM, IERR) 4587 IF (KEEP(110).NE.1) KEEP(110)=0 4588 IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) 4589 CALL MPI_BCAST(CNTL3, 1, MPI_REAL, 4590 & MASTER, id%COMM, IERR) 4591 IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) 4592 CALL MPI_BCAST(CNTL5, 1, MPI_REAL, 4593 & MASTER, id%COMM, IERR) 4594 IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) 4595 CALL MPI_BCAST(CNTL6, 1, MPI_REAL, 4596 & MASTER, id%COMM, IERR) 4597 IF (id%MYID .EQ. MASTER) CNTL1 = id%CNTL(1) 4598 CALL MPI_BCAST(CNTL1, 1, MPI_REAL, 4599 & MASTER, id%COMM, IERR) 4600 ANORMINF = ZERO 4601 IF (KEEP(19).EQ.0) THEN 4602 SEUIL = ZERO 4603 ELSE 4604 CALL CMUMPS_27( id , ANORMINF, LSCAL ) 4605 IF (CNTL6 .LT. ZERO) THEN 4606 SEUIL = EPS*ANORMINF 4607 ELSE 4608 SEUIL = CNTL6*ANORMINF 4609 ENDIF 4610 IF (PROKG) WRITE(MPG,*) 4611 & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL 4612 ENDIF 4613 SEUIL_LDLT_NIV2 = SEUIL 4614 IF (KEEP(110).EQ.0) THEN 4615 id%DKEEP(1) = -1.0E0 4616 id%DKEEP(2) = ZERO 4617 ELSE 4618 IF (ANORMINF.EQ.ZERO) 4619 & CALL CMUMPS_27( id , ANORMINF, LSCAL ) 4620 IF (CNTL3 .LT. ZERO) THEN 4621 id%DKEEP(1) = abs(CNTL(3)) 4622 ELSE IF (CNTL3 .GT. ZERO) THEN 4623 id%DKEEP(1) = CNTL3*ANORMINF 4624 ELSE 4625 id%DKEEP(1) = 1.0E-5*EPS*ANORMINF 4626 ENDIF 4627 IF (PROKG) WRITE(MPG,*) 4628 & ' ZERO PIVOT DETECTION ON, THRESHOLD =',id%DKEEP(1) 4629 IF (CNTL5.GT.ZERO) THEN 4630 id%DKEEP(2) = CNTL5 * ANORMINF 4631 IF (PROKG) WRITE(MPG,*) 4632 & ' FIXATION FOR NULL PIVOTS =',id%DKEEP(2) 4633 ELSE 4634 IF (PROKG) WRITE(MPG,*) 'INFINITE FIXATION ' 4635 IF (id%KEEP(50).EQ.0) THEN 4636 id%DKEEP(2) = -max(1.0E10*ANORMINF, 4637 & sqrt(huge(ANORMINF))/1.0E8) 4638 ELSE 4639 id%DKEEP(2) = ZERO 4640 ENDIF 4641 ENDIF 4642 ENDIF 4643 IF (KEEP(53).NE.0) THEN 4644 ID_ROOT =MUMPS_275(id%PROCNODE_STEPS(id%STEP(KEEP(20))), 4645 & id%NSLAVES) 4646 IF ( KEEP( 46 ) .NE. 1 ) THEN 4647 ID_ROOT = ID_ROOT + 1 4648 END IF 4649 ENDIF 4650 IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) 4651 IF(KEEP(110) .EQ. 1) THEN 4652 LPN_LIST = N 4653 ELSE 4654 LPN_LIST = 1 4655 ENDIF 4656 IF (KEEP(19).NE.0 .AND. 4657 & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN 4658 LPN_LIST = N 4659 ENDIF 4660 ALLOCATE( id%PIVNUL_LIST(LPN_LIST),stat = IERR ) 4661 IF ( IERR .GT. 0 ) THEN 4662 INFO(1)=-13 4663 INFO(2)=LPN_LIST 4664 END IF 4665 id%PIVNUL_LIST(1:LPN_LIST) = 0 4666 KEEP(109) = 0 4667 CALL MUMPS_276( ICNTL(1), INFO(1), 4668 & id%COMM, id%MYID ) 4669 IF ( INFO(1).lt.0 ) GOTO 530 4670 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN 4671 IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) 4672 CALL MPI_BCAST( CNTL4, 1, MPI_REAL, 4673 & MASTER, id%COMM, IERR ) 4674 IF ( CNTL4 .GE. ZERO ) THEN 4675 KEEP(97) = 1 4676 IF ( CNTL4 .EQ. ZERO ) THEN 4677 IF(ANORMINF .EQ. ZERO) THEN 4678 CALL CMUMPS_27( id , ANORMINF, LSCAL ) 4679 ENDIF 4680 SEUIL = sqrt(EPS) * ANORMINF 4681 ELSE 4682 SEUIL = CNTL4 4683 ENDIF 4684 SEUIL_LDLT_NIV2 = SEUIL 4685 ELSE 4686 SEUIL = ZERO 4687 ENDIF 4688 ENDIF 4689 KEEP(98) = 0 4690 KEEP(103) = 0 4691 KEEP(105) = 0 4692 MAXS = 1_8 4693 IF ( id%MYID.EQ.MASTER ) THEN 4694 ITMP = ICNTL(23) 4695 END IF 4696 CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, 4697 & MASTER, id%COMM, IERR ) 4698 IF (WK_USER_PROVIDED) ITMP = 0 4699 ITMP8 = int(ITMP, 8) 4700 KEEP8(4) = ITMP8 * 1000000_8 4701 PERLU = KEEP(12) 4702 IF (KEEP(201) .EQ. 0) THEN 4703 MAXS_BASE8=KEEP8(12) 4704 ELSE 4705 MAXS_BASE8=KEEP8(14) 4706 ENDIF 4707 IF (WK_USER_PROVIDED) THEN 4708 MAXS = KEEP8(24) 4709 ELSE 4710 IF ( MAXS_BASE8 .GT. 0_8 ) THEN 4711 MAXS_BASE_RELAXED8 = 4712 & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) 4713 IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN 4714 WRITE(*,*) "Internal error: I8 overflow" 4715 CALL MUMPS_ABORT() 4716 ENDIF 4717 MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) 4718 MAXS = MAXS_BASE_RELAXED8 4719 ELSE 4720 MAXS = 1_8 4721 MAXS_BASE_RELAXED8 = 1_8 4722 END IF 4723 ENDIF 4724 CALL MUMPS_276( ICNTL(1), INFO(1), 4725 & id%COMM, id%MYID ) 4726 IF (INFO(1) .LT. 0) THEN 4727 GOTO 530 4728 ENDIF 4729 IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN 4730 IF (KEEP(96).GT.0) THEN 4731 MAXS=int(KEEP(96),8) 4732 ELSE 4733 IF (KEEP8(4) .NE. 0_8) THEN 4734 PERLU_ON = .TRUE. 4735 CALL CMUMPS_214( id%KEEP(1), id%KEEP8(1), 4736 & id%MYID, id%N, id%NELT, id%LNA, id%NZ, id%NA_ELT, 4737 & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), 4738 & PERLU_ON, TOTAL_BYTES) 4739 MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + 4740 & (KEEP8(4)-TOTAL_BYTES)/int(KEEP(35),8) 4741 IF (MAXS_BASE_RELAXED8 > int(huge(MAXS),8)) THEN 4742 WRITE(*,*) "Internal error: I8 overflow" 4743 CALL MUMPS_ABORT() 4744 ELSE IF (MAXS_BASE_RELAXED8 .LE. 0_8) THEN 4745 id%INFO(1)=-9 4746 IF ( -MAXS_BASE_RELAXED8 .GT. 4747 & int(huge(id%INFO(1)),8) ) THEN 4748 WRITE(*,*) "I8: OVERFLOW" 4749 CALL MUMPS_ABORT() 4750 ENDIF 4751 id%INFO(2)=-int(MAXS_BASE_RELAXED8,4) 4752 ELSE 4753 MAXS=MAXS_BASE_RELAXED8 4754 ENDIF 4755 ENDIF 4756 ENDIF 4757 ENDIF 4758 CALL MUMPS_276( ICNTL(1), INFO(1), 4759 & id%COMM, id%MYID ) 4760 IF (INFO(1) .LT. 0) THEN 4761 GOTO 530 4762 ENDIF 4763 CALL CMUMPS_713(PROKG, MPG, MAXS, id%NSLAVES, 4764 & id%COMM, "effective relaxed size of S =") 4765 CALL MUMPS_276( ICNTL(1), INFO(1), 4766 & id%COMM, id%MYID ) 4767 IF (id%INFO(1) .LT. 0) THEN 4768 GOTO 530 4769 ENDIF 4770 IF ( I_AM_SLAVE ) THEN 4771 CALL CMUMPS_188( dble(id%COST_SUBTREES), 4772 & KEEP(64), KEEP(66),MAXS ) 4773 K28=KEEP(28) 4774 MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), 4775 & max(0_8, MAXS-MAXS_BASE8)) 4776 CALL CMUMPS_185( id, MEMORY_MD_ARG, MAXS ) 4777 CALL CMUMPS_587(id, IERR) 4778 IF (IERR < 0) THEN 4779 INFO(1) = -90 4780 INFO(2) = 0 4781 GOTO 112 4782 ENDIF 4783 IF (KEEP(201) .GT. 0) THEN 4784 IF (KEEP(201).EQ.1 4785 & .AND.KEEP(50).EQ.0 4786 & .AND.KEEP(251).NE.2 4787 & ) THEN 4788 OOC_NB_FILE_TYPE=2 4789 ELSE 4790 OOC_NB_FILE_TYPE=1 4791 ENDIF 4792 IF (KEEP(205) .GT. 0) THEN 4793 KEEP(100) = KEEP(205) 4794 ELSE 4795 IF (KEEP(201).EQ.1) THEN 4796 I8TMP = int(OOC_NB_FILE_TYPE,8) * 2_8 * int(KEEP(226),8) 4797 ELSE 4798 I8TMP = 2_8 * KEEP8(119) 4799 ENDIF 4800 I8TMP = I8TMP + int(max(KEEP(12),0),8) * 4801 & (I8TMP/100_8+1_8) 4802 I8TMP = min(I8TMP, 12000000_8) 4803 KEEP(100)=int(I8TMP) 4804 ENDIF 4805 IF (KEEP(201).EQ.1) THEN 4806 IF ( KEEP(99) < 3 ) THEN 4807 KEEP(99) = KEEP(99) + 3 4808 ENDIF 4809 IF (id%MYID_NODES .eq. MASTER) THEN 4810 write(6,*) ' PANEL: INIT and force STRAT_IO= ', 4811 & id%KEEP(99) 4812 ENDIF 4813 ENDIF 4814 IF (KEEP(99) .LT.3) KEEP(100)=0 4815 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. 4816 & (dble(1999999999)))THEN 4817 IF (PROKG) THEN 4818 WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be 4819 & too big for Filesystem' 4820 ENDIF 4821 ENDIF 4822 ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), 4823 & OOC_NB_FILE_TYPE), 4824 & stat=IERR) 4825 IF ( IERR .GT. 0 ) THEN 4826 INFO(1) = -13 4827 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) 4828 NULLIFY(id%OOC_INODE_SEQUENCE) 4829 GOTO 112 4830 ENDIF 4831 ALLOCATE (id%OOC_TOTAL_NB_NODES(OOC_NB_FILE_TYPE), 4832 & stat=IERR) 4833 IF ( IERR .GT. 0 ) THEN 4834 INFO(1) = -13 4835 INFO(2) = OOC_NB_FILE_TYPE 4836 NULLIFY(id%OOC_TOTAL_NB_NODES) 4837 GOTO 112 4838 ENDIF 4839 ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), 4840 & OOC_NB_FILE_TYPE), 4841 & stat=IERR) 4842 IF ( IERR .GT. 0 ) THEN 4843 INFO(1) = -13 4844 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) 4845 NULLIFY(id%OOC_SIZE_OF_BLOCK) 4846 GOTO 112 4847 ENDIF 4848 ALLOCATE (id%OOC_VADDR(KEEP(28),OOC_NB_FILE_TYPE), 4849 & stat=IERR) 4850 IF ( IERR .GT. 0 ) THEN 4851 INFO(1) = -13 4852 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) 4853 NULLIFY(id%OOC_VADDR) 4854 GOTO 112 4855 ENDIF 4856 ENDIF 4857 ENDIF 4858 112 CALL MUMPS_276( ICNTL(1), INFO(1), 4859 & id%COMM, id%MYID ) 4860 IF (INFO(1) < 0) THEN 4861 GOTO 513 4862 ENDIF 4863 IF (I_AM_SLAVE) THEN 4864 IF (KEEP(201) .GT. 0) THEN 4865 IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN 4866 CALL CMUMPS_575(id,MAXS) 4867 ELSE 4868 WRITE(*,*) "Internal error in CMUMPS_142" 4869 CALL MUMPS_ABORT() 4870 ENDIF 4871 IF(INFO(1).LT.0)THEN 4872 GOTO 111 4873 ENDIF 4874 ENDIF 4875#if ! defined(OLD_LOAD_MECHANISM) 4876 CALL CMUMPS_190(0,.FALSE.,dble(id%COST_SUBTREES), 4877 & id%KEEP(1),id%KEEP8(1)) 4878#endif 4879 IF (INFO(1).LT.0) GOTO 111 4880#if defined(stephinfo) 4881 write(*,*) 'proc ',id%MYID,' array of dist : ', 4882 & id%MEM_DIST(0:id%NSLAVES - 1) 4883#endif 4884 END IF 4885 IF ( associated (id%S) ) THEN 4886 DEALLOCATE(id%S) 4887 NULLIFY(id%S) 4888 KEEP8(23)=0_8 4889 ENDIF 4890#if defined (LARGEMATRICES) 4891 IF ( id%MYID .ne. MASTER ) THEN 4892#endif 4893 IF (.NOT.WK_USER_PROVIDED) THEN 4894 ALLOCATE (id%S(MAXS),stat=IERR) 4895 KEEP8(23) = MAXS 4896 IF ( IERR .GT. 0 ) THEN 4897 INFO(1) = -13 4898 CALL MUMPS_735(MAXS, INFO(2)) 4899 NULLIFY(id%S) 4900 KEEP8(23)=0_8 4901 ENDIF 4902 ELSE 4903 id%S => id%WK_USER(1:KEEP8(24)) 4904 ENDIF 4905#if defined (LARGEMATRICES) 4906 END IF 4907#endif 4908 111 CALL MUMPS_276( ICNTL(1), INFO(1), 4909 & id%COMM, id%MYID ) 4910 IF ( INFO(1).LT.0 ) GOTO 500 4911 IF ( KEEP(55) .eq. 0 ) THEN 4912 IF (associated( id%DBLARR)) THEN 4913 DEALLOCATE(id%DBLARR) 4914 NULLIFY(id%DBLARR) 4915 ENDIF 4916 IF ( I_AM_SLAVE .and. KEEP(13) .ne. 0 ) THEN 4917 ALLOCATE( id%DBLARR( KEEP(13) ), stat = IERR ) 4918 ELSE 4919 ALLOCATE( id%DBLARR( 1 ), stat =IERR ) 4920 END IF 4921 IF ( IERR .NE. 0 ) THEN 4922 WRITE(*,*) id%MYID, 4923 & ':Error allocating DBLARR : IERR = ', IERR 4924 INFO(1)=-13 4925 INFO(2)=KEEP(13) 4926 NULLIFY(id%DBLARR) 4927 GOTO 100 4928 END IF 4929 ELSE 4930 IF ( associated( id%INTARR ) ) THEN 4931 DEALLOCATE( id%INTARR ) 4932 NULLIFY( id%INTARR ) 4933 END IF 4934 IF ( I_AM_SLAVE .and. KEEP(14) .ne. 0 ) THEN 4935 ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) 4936 IF ( allocok .GT. 0 ) THEN 4937 id%INFO(1) = -13 4938 id%INFO(2) = KEEP(14) 4939 NULLIFY(id%INTARR) 4940 GOTO 100 4941 END IF 4942 ELSE 4943 ALLOCATE( id%INTARR(1),stat=allocok ) 4944 IF ( allocok .GT. 0 ) THEN 4945 id%INFO(1) = -13 4946 id%INFO(2) = 1 4947 NULLIFY(id%INTARR) 4948 GOTO 100 4949 END IF 4950 END IF 4951 IF (associated( id%DBLARR)) THEN 4952 DEALLOCATE(id%DBLARR) 4953 NULLIFY(id%DBLARR) 4954 ENDIF 4955 IF ( I_AM_SLAVE ) THEN 4956 IF ( id%MYID_NODES .eq. MASTER 4957 & .AND. KEEP(46) .eq. 1 4958 & .AND. KEEP(52) .eq. 0 ) THEN 4959 id%DBLARR => id%A_ELT 4960 ELSE 4961 IF ( KEEP(13) .ne. 0 ) THEN 4962 ALLOCATE( id%DBLARR( KEEP(13) ), stat = allocok ) 4963 IF ( allocok .GT. 0 ) THEN 4964 id%INFO(1) = -13 4965 id%INFO(2) = KEEP(13) 4966 NULLIFY(id%DBLARR) 4967 GOTO 100 4968 END IF 4969 ELSE 4970 ALLOCATE( id%DBLARR(1), stat = allocok ) 4971 IF ( allocok .GT. 0 ) THEN 4972 id%INFO(1) = -13 4973 id%INFO(2) = 1 4974 NULLIFY(id%DBLARR) 4975 GOTO 100 4976 END IF 4977 END IF 4978 END IF 4979 ELSE 4980 ALLOCATE( id%DBLARR(1), stat = allocok ) 4981 IF ( allocok .GT. 0 ) THEN 4982 id%INFO(1) = -13 4983 id%INFO(2) = 1 4984 NULLIFY(id%DBLARR) 4985 GOTO 100 4986 END IF 4987 END IF 4988 END IF 4989 IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN 4990 CALL CMUMPS_165( id%N, 4991 & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) 4992 END IF 4993 100 CONTINUE 4994 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 4995 & id%COMM, id%MYID ) 4996 IF ( INFO(1).LT.0 ) GOTO 500 4997 IF ( KEEP( 55 ) .eq. 0 ) THEN 4998 IF (KEEP(38).NE.0 .AND. I_AM_SLAVE) THEN 4999 LWK = numroc( id%root%ROOT_SIZE, id%root%MBLOCK, 5000 & id%root%MYROW, 0, id%root%NPROW ) 5001 LWK = max( 1, LWK ) 5002 LWK = LWK* 5003 & numroc( id%root%ROOT_SIZE, id%root%NBLOCK, 5004 & id%root%MYCOL, 0, id%root%NPCOL ) 5005 LWK = max( 1, LWK ) 5006 ELSE 5007 LWK = 1 5008 ENDIF 5009 IF (MAXS .LT. int(LWK,8)) THEN 5010 INFO(1) = -9 5011 INFO(2) = LWK 5012 ENDIF 5013 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 5014 & id%COMM, id%MYID ) 5015 IF ( INFO(1).LT.0 ) GOTO 500 5016 IF ( KEEP(54) .eq. 0 ) THEN 5017 IF ( id%MYID .eq. MASTER ) THEN 5018 ALLOCATE(IWK(id%N), stat=allocok) 5019 IF ( allocok .NE. 0 ) THEN 5020 INFO(1)=-13 5021 INFO(2)=id%N 5022 END IF 5023#if defined(LARGEMATRICES) 5024 IF ( associated (id%S) ) THEN 5025 DEALLOCATE(id%S) 5026 NULLIFY(id%S) 5027 KEEP8(23)=0_8 5028 ENDIF 5029 ALLOCATE (WK(LWK),stat=IERR) 5030 IF ( IERR .GT. 0 ) THEN 5031 INFO(1) = -13 5032 INFO(2) = LWK 5033 write(6,*) ' PB1 ALLOC LARGEMAT' 5034 ENDIF 5035#endif 5036 ENDIF 5037 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 5038 & id%COMM, id%MYID ) 5039 IF ( INFO(1).LT.0 ) GOTO 500 5040 IF ( id%MYID .eq. MASTER ) THEN 5041 IF (PROKG ) THEN 5042 CALL MUMPS_291(TIME) 5043 END IF 5044 IF ( .not. associated( id%INTARR ) ) THEN 5045 ALLOCATE( id%INTARR( 1 ) ) 5046 ENDIF 5047#if defined(LARGEMATRICES) 5048 CALL CMUMPS_148(id%N, NZ, id%A(1), 5049 & id%IRN(1), id%JCN(1), id%SYM_PERM(1), 5050 & LSCAL, id%COLSCA(1), id%ROWSCA(1), 5051 & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), 5052 & min(KEEP(39),id%NZ), 5053 & LP, id%COMM, id%root, KEEP,KEEP8, 5054 & id%FILS(1), IWK(1), 5055 & 5056 & id%INTARR(1), id%DBLARR(1), 5057 & id%PTRAR(1), id%PTRAR(id%N+1), 5058 & id%FRERE_STEPS(1), id%STEP(1), WK(1), int(LWK,8), 5059 & id%ISTEP_TO_INIV2, id%I_AM_CAND, 5060 & id%CANDIDATES) 5061 write(6,*) '!!! A,IRN,JCN are freed during facto ' 5062 DEALLOCATE (id%A) 5063 NULLIFY(id%A) 5064 DEALLOCATE (id%IRN) 5065 NULLIFY (id%IRN) 5066 DEALLOCATE (id%JCN) 5067 NULLIFY (id%JCN) 5068 IF (.NOT.WK_USER_PROVIDED) THEN 5069 ALLOCATE (id%S(MAXS),stat=IERR) 5070 KEEP8(23) = MAXS 5071 IF ( IERR .GT. 0 ) THEN 5072 INFO(1) = -13 5073 INFO(2) = MAXS 5074 NULLIFY(id%S) 5075 KEEP8(23)=0_8 5076 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS 5077 CALL MUMPS_ABORT() 5078 ENDIF 5079 ELSE 5080 id%S => id%WK_USER(1:KEEP8(24)) 5081 ENDIF 5082 id%S(MAXS-LWK+1:MAXS) = WK(1:LWK) 5083 DEALLOCATE (WK) 5084#else 5085 CALL CMUMPS_148(id%N, NZ, id%A(1), 5086 & id%IRN(1), id%JCN(1), id%SYM_PERM(1), 5087 & LSCAL, id%COLSCA(1), id%ROWSCA(1), 5088 & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), 5089 & min(KEEP(39),id%NZ), 5090 & LP, id%COMM, id%root, KEEP(1),KEEP8(1), 5091 & id%FILS(1), IWK(1), 5092 & 5093 & id%INTARR(1), id%DBLARR(1), 5094 & id%PTRAR(1), id%PTRAR(id%N+1), 5095 & id%FRERE_STEPS(1), id%STEP(1), id%S(1), MAXS, 5096 & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), 5097 & id%CANDIDATES(1,1) ) 5098#endif 5099 DEALLOCATE(IWK) 5100 IF ( PROKG ) THEN 5101 CALL MUMPS_292(TIME) 5102 WRITE(MPG,160) TIME 5103 CALL MUMPS_291(TIME) 5104 END IF 5105 ELSE 5106 CALL CMUMPS_145( id%N, 5107 & id%DBLARR( 1 ), max(1,KEEP( 13 )), 5108 & id%INTARR( 1 ), max(1,KEEP( 14 )), 5109 & id%PTRAR( 1 ), 5110 & id%PTRAR(id%N+1), 5111 & KEEP( 1 ), KEEP8(1), id%MYID, id%COMM, 5112 & min(id%KEEP(39),id%NZ), 5113 & 5114 & id%S(1), MAXS, 5115 & id%root, 5116 & id%PROCNODE_STEPS(1), id%NSLAVES, 5117 & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), 5118 & id%INFO(1), id%INFO(2) ) 5119 ENDIF 5120 ELSE 5121 IF (PROKG ) THEN 5122 CALL MUMPS_291(TIME) 5123 END IF 5124 IF ( I_AM_SLAVE ) THEN 5125 NZ_locMAX = 0 5126 CALL MPI_ALLREDUCE(id%NZ_loc, NZ_locMAX, 1, MPI_INTEGER, 5127 & MPI_MAX, id%COMM_NODES, IERR) 5128 CALL CMUMPS_282( id%N, 5129 & id%NZ_loc, 5130 & id, 5131 & id%DBLARR(1), KEEP(13), id%INTARR(1), 5132 & KEEP(14), id%PTRAR(1), id%PTRAR(id%N+1), 5133 & KEEP(1), KEEP8(1), id%MYID_NODES, 5134 & id%COMM_NODES, min(id%KEEP(39),NZ_locMAX), 5135 & id%S(1), MAXS, id%root, id%PROCNODE_STEPS(1), 5136 & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), 5137 & id%ICNTL(1), id%INFO(1), NSEND, NLOCAL, 5138 & id%ISTEP_TO_INIV2(1), 5139 & id%CANDIDATES(1,1) ) 5140 IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN 5141 IF ( id%MYID > 0 ) THEN 5142 IF (associated(id%ROWSCA)) THEN 5143 DEALLOCATE(id%ROWSCA) 5144 NULLIFY(id%ROWSCA) 5145 ENDIF 5146 IF (associated(id%COLSCA)) THEN 5147 DEALLOCATE(id%COLSCA) 5148 NULLIFY(id%COLSCA) 5149 ENDIF 5150 ENDIF 5151 ENDIF 5152#if defined(LARGEMATRICES) 5153 IF (associated(id%IRN_loc)) THEN 5154 DEALLOCATE(id%IRN_loc) 5155 NULLIFY(id%IRN_loc) 5156 ENDIF 5157 IF (associated(id%JCN_loc)) THEN 5158 DEALLOCATE(id%JCN_loc) 5159 NULLIFY(id%JCN_loc) 5160 ENDIF 5161 IF (associated(id%A_loc)) THEN 5162 DEALLOCATE(id%A_loc) 5163 NULLIFY(id%A_loc) 5164 ENDIF 5165 write(6,*) ' Warning :', 5166 & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' 5167#endif 5168 IF (PROK) THEN 5169 WRITE(MP,120) NLOCAL, NSEND 5170 END IF 5171 END IF 5172 IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN 5173 NSEND = 0 5174 NLOCAL = 0 5175 END IF 5176 CALL MPI_REDUCE( NSEND, NSEND_TOT, 1, MPI_INTEGER, 5177 & MPI_SUM, MASTER, id%COMM, IERR ) 5178 CALL MPI_REDUCE( NLOCAL, NLOCAL_TOT, 1, MPI_INTEGER, 5179 & MPI_SUM, MASTER, id%COMM, IERR ) 5180 IF ( PROKG ) THEN 5181 WRITE(MPG,125) NLOCAL_TOT, NSEND_TOT 5182 END IF 5183 CALL MUMPS_276( ICNTL(1), INFO(1), 5184 & id%COMM, id%MYID ) 5185 IF ( INFO( 1 ) .LT. 0 ) GOTO 500 5186 IF ( PROKG ) THEN 5187 CALL MUMPS_292(TIME) 5188 WRITE(MPG,160) TIME 5189 CALL MUMPS_291(TIME) 5190 END IF 5191 END IF 5192 ELSE 5193 IF (PROKG ) THEN 5194 CALL MUMPS_291(TIME) 5195 END IF 5196 IF ( id%MYID.eq.MASTER) 5197 &CALL CMUMPS_213( id%ELTPTR(1), 5198 & id%NELT, 5199 & MAXELT_SIZE ) 5200 CALL CMUMPS_126( id%N, id%NELT, id%NA_ELT, 5201 & id%COMM, id%MYID, 5202 & id%NSLAVES, id%PTRAR(1), 5203 & id%PTRAR(id%NELT+2), 5204 & id%INTARR(1), id%DBLARR(1), 5205 & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, 5206 & id%FRTPTR(1), id%FRTELT(1), 5207 & id%S(1), MAXS, id%FILS(1), 5208 & id, id%root ) 5209 CALL MUMPS_276( ICNTL(1), INFO(1), 5210 & id%COMM, id%MYID ) 5211 IF ( INFO( 1 ) .LT. 0 ) GOTO 500 5212 IF ( PROKG ) THEN 5213 CALL MUMPS_292(TIME) 5214 WRITE(MPG,160) TIME 5215 CALL MUMPS_291(TIME) 5216 END IF 5217 END IF 5218 IF ( I_AM_SLAVE ) THEN 5219 CALL CMUMPS_528(id%MYID_NODES) 5220 CMUMPS_LBUFR_BYTES = KEEP( 44 ) * KEEP( 35 ) 5221 CMUMPS_LBUFR_BYTES = max( CMUMPS_LBUFR_BYTES, 5222 & 100000 ) 5223 PERLU = KEEP( 12 ) 5224 IF (KEEP(48).EQ.5) THEN 5225 MIN_PERLU=2 5226 ELSE 5227 MIN_PERLU=0 5228 ENDIF 5229 CMUMPS_LBUFR_BYTES = CMUMPS_LBUFR_BYTES 5230 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* 5231 & real(CMUMPS_LBUFR_BYTES)/100E0) 5232 IF (KEEP(48)==5) THEN 5233 KEEP8(21) = KEEP8(22) + int( real(max(PERLU,MIN_PERLU))* 5234 & real(KEEP8(22))/100E0,8) 5235 ENDIF 5236 CMUMPS_LBUF = int( real(KEEP(213)) / 100.0E0 * 5237 & real(KEEP(43)) * real(KEEP(35)) ) 5238 CMUMPS_LBUF = max( CMUMPS_LBUF, 100000 ) 5239 CMUMPS_LBUF = CMUMPS_LBUF 5240 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* 5241 & real(CMUMPS_LBUF)/100E0) 5242 CMUMPS_LBUF = max(CMUMPS_LBUF, CMUMPS_LBUFR_BYTES+3*KEEP(34)) 5243 IF(id%KEEP(48).EQ.4)THEN 5244 CMUMPS_LBUFR_BYTES=CMUMPS_LBUFR_BYTES*5 5245 CMUMPS_LBUF=CMUMPS_LBUF*5 5246 ENDIF 5247 CMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 5248 & * KEEP(34) 5249 IF ( KEEP( 38 ) .NE. 0 ) THEN 5250 KKKK = MUMPS_275( id%PROCNODE_STEPS(id%STEP(KEEP(38))), 5251 & id%NSLAVES ) 5252 IF ( KKKK .EQ. id%MYID_NODES ) THEN 5253 CMUMPS_LBUF_INT = CMUMPS_LBUF_INT + 5254 & 10 * 5255 & 2 * ( id%NE_STEPS(id%STEP(KEEP(38))) + 1 ) * id%NSLAVES 5256 & * KEEP(34) 5257 END IF 5258 END IF 5259 IF ( MP .GT. 0 ) THEN 5260 WRITE( MP, 9999 ) CMUMPS_LBUFR_BYTES, 5261 & CMUMPS_LBUF, CMUMPS_LBUF_INT 5262 END IF 5263 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, 5264 & ' Size of reception buffer in bytes ...... = ', I10, 5265 & /, 5266 & ' Size of async. emission buffer (bytes).. = ', I10,/, 5267 & ' Small emission buffer (bytes) .......... = ', I10) 5268 CALL CMUMPS_55( CMUMPS_LBUF_INT, IERR ) 5269 IF ( IERR .NE. 0 ) THEN 5270 WRITE(*,*) id%MYID, 5271 & ':Error allocating small Send buffer:IERR=' 5272 & ,IERR 5273 INFO(1)= -13 5274 INFO(2)= (CMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) 5275 GO TO 110 5276 END IF 5277 CALL CMUMPS_53( CMUMPS_LBUF, IERR ) 5278 IF ( IERR .NE. 0 ) THEN 5279 WRITE(*,*) id%MYID,':Error allocating Send buffer:IERR=' 5280 & ,IERR 5281 INFO(1)= -13 5282 INFO(2)= (CMUMPS_LBUF+KEEP(34)-1)/KEEP(34) 5283 GO TO 110 5284 END IF 5285 id%LBUFR_BYTES = CMUMPS_LBUFR_BYTES 5286 id%LBUFR = (CMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) 5287 IF (associated(id%BUFR)) DEALLOCATE(id%BUFR) 5288 ALLOCATE( id%BUFR( id%LBUFR ),stat=IERR ) 5289 IF ( IERR .NE. 0 ) THEN 5290 WRITE(*,*) id%MYID,':Error allocating BUFR:IERR=' 5291 & ,IERR 5292 INFO(1)=-13 5293 INFO(2)=id%LBUFR 5294 NULLIFY(id%BUFR) 5295 GO TO 110 5296 END IF 5297 PERLU = KEEP( 12 ) 5298 IF (KEEP(201).GT.0) THEN 5299 MAXIS_ESTIM = KEEP(225) 5300 ELSE 5301 MAXIS_ESTIM = KEEP(15) 5302 ENDIF 5303 MAXIS = max( 1, 5304 & MAXIS_ESTIM + 2 * max(PERLU,10) * 5305 & ( MAXIS_ESTIM / 100 + 1 ) 5306 & ) 5307 IF (associated(id%IS)) DEALLOCATE( id%IS ) 5308 ALLOCATE( id%IS( MAXIS ), stat = IERR ) 5309 IF ( IERR .NE. 0 ) THEN 5310 WRITE(*,*) id%MYID,':Error allocating IS:IERR=',IERR 5311 INFO(1)=-13 5312 INFO(2)=MAXIS 5313 NULLIFY(id%IS) 5314 GO TO 110 5315 END IF 5316 LIW = MAXIS 5317 IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) 5318 ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) 5319 IF ( IERR .NE. 0 ) THEN 5320 WRITE(*,*) id%MYID,':Error allocatingPTLUST:IERR = ', 5321 & IERR 5322 INFO(1)=-13 5323 INFO(2)=id%KEEP(28) 5324 NULLIFY(id%PTLUST_S) 5325 GOTO 100 5326 END IF 5327 IF (associated( id%PTRFAC )) DEALLOCATE(id%PTRFAC) 5328 ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) 5329 IF ( IERR .NE. 0 ) THEN 5330 WRITE(*,*) id%MYID,':Error allocatingPTRFAC:IERR = ', 5331 & IERR 5332 INFO(1)=-13 5333 INFO(2)=id%KEEP(28) 5334 NULLIFY(id%PTRFAC) 5335 GOTO 100 5336 END IF 5337 PTRIST = 1 5338 PTRWB = PTRIST + id%KEEP(28) 5339 ITLOC = PTRWB + 3 * id%KEEP(28) 5340 IPOOL = ITLOC + id%N + id%KEEP(253) 5341 LPOOL = CMUMPS_505(id%KEEP(1),id%KEEP8(1)) 5342 ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) 5343 IF ( IERR .NE. 0 ) THEN 5344 WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', 5345 & IERR 5346 INFO(1)=-13 5347 INFO(2)=IPOOL + LPOOL - 1 5348 GOTO 110 5349 END IF 5350 ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) 5351 IF ( IERR .NE. 0 ) THEN 5352 WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', 5353 & IERR 5354 INFO(1)=-13 5355 INFO(2)=2 * id%KEEP(28) 5356 GOTO 110 5357 END IF 5358 ENDIF 5359 110 CONTINUE 5360 CALL MUMPS_276( ICNTL(1), INFO(1), 5361 & id%COMM, id%MYID ) 5362 IF ( INFO( 1 ) .LT. 0 ) GOTO 500 5363 IF ( I_AM_SLAVE ) THEN 5364 CALL CMUMPS_60( id%LBUFR_BYTES ) 5365 IF (MP .GT. 0) THEN 5366 WRITE( MP, 170 ) MAXS, MAXIS, KEEP8(12), KEEP(15), KEEP(13), 5367 & KEEP(14), KEEP8(11), KEEP(26), KEEP(27) 5368 ENDIF 5369 END IF 5370 PERLU_ON = .TRUE. 5371 CALL CMUMPS_214( id%KEEP(1), id%KEEP8(1), 5372 & id%MYID, id%N, id%NELT, id%LNA, id%NZ, 5373 & id%NA_ELT, 5374 & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), 5375 & PERLU_ON, TOTAL_BYTES) 5376 id%INFO(16) = TOTAL_MBYTES 5377 IF ( MP .gt. 0 ) THEN 5378 WRITE(MP,'(A,I10) ') 5379 & ' ** Space in MBYTES used during factorization :', 5380 & id%INFO(16) 5381 END IF 5382 CALL MUMPS_243( id%MYID, id%COMM, 5383 & id%INFO(16), id%INFOG(18), IRANK ) 5384 IF ( PROKG ) THEN 5385 WRITE( MPG,'(A,I10) ') 5386 & ' ** Memory relaxation parameter ( ICNTL(14) ) :', 5387 & KEEP(12) 5388 WRITE( MPG,'(A,I10) ') 5389 & ' ** Rank of processor needing largest memory in facto :', 5390 & IRANK 5391 WRITE( MPG,'(A,I10) ') 5392 & ' ** Space in MBYTES used by this processor for facto :', 5393 & id%INFOG(18) 5394 IF ( KEEP(46) .eq. 0 ) THEN 5395 WRITE( MPG,'(A,I10) ') 5396 & ' ** Avg. Space in MBYTES per working proc during facto :', 5397 & ( id%INFOG(19)-id%INFO(16) ) / id%NSLAVES 5398 ELSE 5399 WRITE( MPG,'(A,I10) ') 5400 & ' ** Avg. Space in MBYTES per working proc during facto :', 5401 & id%INFOG(19) / id%NSLAVES 5402 END IF 5403 END IF 5404 KEEP8(31)= 0_8 5405 KEEP8(10) = 0_8 5406 KEEP8(8)=0_8 5407 INFO(9:14)=0 5408 RINFO(2:3)=ZERO 5409 IF ( I_AM_SLAVE ) THEN 5410 IF ( KEEP(55) .eq. 0 ) THEN 5411 LDPTRAR = id%N 5412 ELSE 5413 LDPTRAR = id%NELT + 1 5414 END IF 5415 IF ( id%KEEP(55) .NE. 0 ) THEN 5416 NELT = id%NELT 5417 ELSE 5418 NELT = 1 5419 END IF 5420 CALL CMUMPS_244( id%N, NSTEPS, id%S(1), 5421 & MAXS, id%IS( 1 ), LIW, 5422 & id%SYM_PERM(1), id%NA(1), id%LNA, id%NE_STEPS(1), 5423 & id%ND_STEPS(1), id%FILS(1), id%STEP(1), 5424 & id%FRERE_STEPS(1), id%DAD_STEPS(1), id%CANDIDATES(1,1), 5425 & id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), 5426 & id%PTRAR(1), LDPTRAR, IWK( PTRIST ), 5427 & id%PTLUST_S(1), id%PTRFAC(1), IWK( PTRWB ), 5428 & IWK8, 5429 & IWK( ITLOC ), RHS_MUMPS(1), IWK( IPOOL ), LPOOL, 5430 & CNTL1, ICNTL(1), INFO(1), RINFO(1), KEEP(1),KEEP8(1), 5431 & id%PROCNODE_STEPS(1), 5432 & id%NSLAVES, id%COMM_NODES, 5433 & id%MYID, id%MYID_NODES, 5434 & id%BUFR(1),id%LBUFR,id%LBUFR_BYTES, 5435 & id%INTARR(1), id%DBLARR(1), id%root, 5436 & NELT, id%FRTPTR(1), 5437 & id%FRTELT(1), id%COMM_LOAD, id%ASS_IRECV, SEUIL, 5438 & SEUIL_LDLT_NIV2, id%MEM_DIST(0), 5439 & id%DKEEP(1),id%PIVNUL_LIST(1),LPN_LIST) 5440 IF ( MP . GT. 0 .and. KEEP(38) .ne. 0 ) THEN 5441 WRITE( MP, 175 ) KEEP(49) 5442 END IF 5443 DEALLOCATE( IWK ) 5444 DEALLOCATE( IWK8 ) 5445 ENDIF 5446 IF ( KEEP(55) .eq. 0 ) THEN 5447 IF (associated( id%DBLARR)) THEN 5448 DEALLOCATE(id%DBLARR) 5449 NULLIFY(id%DBLARR) 5450 ENDIF 5451 ELSE 5452 DEALLOCATE( id%INTARR) 5453 NULLIFY( id%INTARR ) 5454 IF ( id%MYID_NODES .eq. MASTER 5455 & .AND. KEEP(46) .eq. 1 5456 & .AND. KEEP(52) .eq. 0 ) THEN 5457 NULLIFY( id%DBLARR ) 5458 ELSE 5459 IF (associated( id%DBLARR)) THEN 5460 DEALLOCATE(id%DBLARR) 5461 NULLIFY(id%DBLARR) 5462 ENDIF 5463 END IF 5464 END IF 5465 IF ( KEEP(19) .NE. 0 ) THEN 5466 IF ( KEEP(46) .NE. 1 ) THEN 5467 IF ( id%MYID .eq. MASTER ) THEN 5468 CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, 5469 & id%COMM, STATUS, IERR ) 5470 ELSE IF ( id%MYID .EQ. 1 ) THEN 5471 CALL MPI_SEND( KEEP(17), 1, MPI_INTEGER, 0, DEFIC_TAG, 5472 & id%COMM, IERR ) 5473 END IF 5474 END IF 5475 END IF 5476 IF (associated(id%BUFR)) THEN 5477 DEALLOCATE(id%BUFR) 5478 NULLIFY(id%BUFR) 5479 END IF 5480 CALL CMUMPS_57( IERR ) 5481 CALL CMUMPS_59( IERR ) 5482 IF (KEEP(219).NE.0) THEN 5483 CALL CMUMPS_620() 5484 ENDIF 5485 CALL MUMPS_276( ICNTL(1), INFO(1), 5486 & id%COMM, id%MYID ) 5487 CALL CMUMPS_770(id) 5488 IF (KEEP(201) .GT. 0) THEN 5489 IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN 5490 IF ( I_AM_SLAVE ) THEN 5491 CALL CMUMPS_591(IERR) 5492 IF(IERR.LT.0)THEN 5493 INFO(1)=IERR 5494 INFO(2)=0 5495 ENDIF 5496 ENDIF 5497 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 5498 & id%COMM, id%MYID ) 5499 END IF 5500 END IF 5501 IF ( PROKG ) THEN 5502 CALL MUMPS_292(TIME) 5503 WRITE(MPG,180) TIME 5504 END IF 5505 PERLU_ON = .TRUE. 5506 CALL CMUMPS_214( id%KEEP(1),id%KEEP8(1), 5507 & id%MYID, N, id%NELT, id%LNA, id%NZ, 5508 & id%NA_ELT, 5509 & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), 5510 & PERLU_ON, TOTAL_BYTES) 5511 KEEP8(7) = TOTAL_BYTES 5512 id%INFO(22) = TOTAL_MBYTES 5513 IF ( MP .gt. 0 ) THEN 5514 WRITE(MP,'(A,I10) ') 5515 & ' ** Effective minimum Space in MBYTES for facto :', 5516 & TOTAL_MBYTES 5517 ENDIF 5518 IF (I_AM_SLAVE) THEN 5519 K67 = KEEP8(67) 5520 ELSE 5521 K67 = 0_8 5522 ENDIF 5523 CALL MUMPS_735(K67,id%INFO(21)) 5524 CALL CMUMPS_713(PROKG, MPG, K67, id%NSLAVES, 5525 & id%COMM, "effective space used in S (KEEP8(67) =") 5526 CALL MUMPS_243( id%MYID, id%COMM, 5527 & TOTAL_MBYTES, id%INFOG(21), IRANK ) 5528 IF ( PROKG ) THEN 5529 WRITE( MPG,'(A,I10) ') 5530 & ' ** EFF Min: Rank of processor needing largest memory :', 5531 & IRANK 5532 WRITE( MPG,'(A,I10) ') 5533 & ' ** EFF Min: Space in MBYTES used by this processor :', 5534 & id%INFOG(21) 5535 IF ( KEEP(46) .eq. 0 ) THEN 5536 WRITE( MPG,'(A,I10) ') 5537 & ' ** EFF Min: Avg. Space in MBYTES per working proc :', 5538 & ( id%INFOG(22)-TOTAL_MBYTES ) / id%NSLAVES 5539 ELSE 5540 WRITE( MPG,'(A,I10) ') 5541 & ' ** EFF Min: Avg. Space in MBYTES per working proc :', 5542 & id%INFOG(22) / id%NSLAVES 5543 END IF 5544 END IF 5545 KEEP(33) = INFO(11) 5546 CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, 5547 & MPI_REAL, 5548 & MPI_SUM, MASTER, id%COMM, IERR) 5549 KEEP(247) = 0 5550 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, 5551 & MPI_MAX, MASTER, id%COMM, IERR) 5552 CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, 5553 & MPI_REAL, 5554 & MPI_SUM, MASTER, id%COMM, IERR) 5555 CALL MUMPS_646( KEEP8(31),KEEP8(6), MPI_SUM, 5556 & MASTER, id%COMM ) 5557 CALL MUMPS_735(KEEP8(6), INFOG(9)) 5558 CALL MPI_REDUCE( INFO(10), INFOG(10), 1, MPI_INTEGER, 5559 & MPI_SUM, MASTER, id%COMM, IERR) 5560 CALL MPI_ALLREDUCE( INFO(11), INFOG(11), 1, MPI_INTEGER, 5561 & MPI_MAX, id%COMM, IERR) 5562 KEEP(133) = INFOG(11) 5563 CALL MPI_REDUCE( INFO(12), INFOG(12), 3, MPI_INTEGER, 5564 & MPI_SUM, MASTER, id%COMM, IERR) 5565 CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, 5566 & MPI_SUM, MASTER, id%COMM, IERR) 5567 KEEP(229) = INFOG(25) 5568 CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, 5569 & MPI_SUM, MASTER, id%COMM, IERR) 5570 KEEP(230) = INFOG(25) 5571 INFO(25) = KEEP(98) 5572 CALL MPI_ALLREDUCE( INFO(25), INFOG(25), 1, MPI_INTEGER, 5573 & MPI_SUM, id%COMM, IERR) 5574 CALL MUMPS_646( KEEP8(8), KEEP8(108), MPI_SUM, 5575 & MASTER, id%COMM ) 5576 CALL MUMPS_735(KEEP8(10), INFO(27)) 5577 CALL MUMPS_646( KEEP8(10),KEEP8(110), MPI_SUM, 5578 & MASTER, id%COMM ) 5579 CALL MUMPS_735(KEEP8(110), INFOG(29)) 5580 IF (KEEP(258).NE.0) THEN 5581 IF (KEEP(260).EQ.-1) THEN 5582 id%DKEEP(6)=-id%DKEEP(6) 5583 id%DKEEP(7)=-id%DKEEP(7) 5584 ENDIF 5585 CALL CMUMPS_764( 5586 & id%COMM, id%DKEEP(6), KEEP(259), 5587 & RINFOG(12), INFOG(34), id%NPROCS) 5588 IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN 5589 IF (id%KEEP(23).NE.0) THEN 5590 CALL CMUMPS_767( 5591 & RINFOG(12), id%N, 5592 & id%STEP(1), 5593 & id%UNS_PERM(1) ) 5594 ENDIF 5595 ENDIF 5596 ENDIF 5597 IF(KEEP(110) .EQ. 1) THEN 5598 INFO(18) = KEEP(109) 5599 CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, 5600 & MPI_SUM, id%COMM, IERR) 5601 ELSE 5602 INFO(18) = 0 5603 KEEP(109) = 0 5604 KEEP(112) = 0 5605 ENDIF 5606 INFOG(28)=KEEP(112)+KEEP(17) 5607 IF (KEEP(17) .NE. 0) THEN 5608 IF (id%MYID .EQ. ID_ROOT) THEN 5609 INFO(18)=INFO(18)+KEEP(17) 5610 ENDIF 5611 IF (ID_ROOT .EQ. MASTER) THEN 5612 IF (id%MYID.EQ.MASTER) THEN 5613 DO I=1, KEEP(17) 5614 id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) 5615 ENDDO 5616 ENDIF 5617 ELSE 5618 IF (id%MYID .EQ. ID_ROOT) THEN 5619 CALL MPI_SEND(id%PIVNUL_LIST(KEEP(109)+1), KEEP(17), 5620 & MPI_INTEGER, MASTER, ZERO_PIV, 5621 & id%COMM, IERR) 5622 ELSE IF (id%MYID .EQ. MASTER) THEN 5623 CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), 5624 & MPI_INTEGER, ID_ROOT, ZERO_PIV, 5625 & id%COMM, STATUS, IERR ) 5626 ENDIF 5627 ENDIF 5628 ENDIF 5629 IF(KEEP(110) .EQ. 1) THEN 5630 ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) 5631 IF ( IERR .GT. 0 ) THEN 5632 INFO(1)=-13 5633 INFO(2)=id%NPROCS 5634 END IF 5635 CALL MUMPS_276( ICNTL(1), INFO(1), 5636 & id%COMM, id%MYID ) 5637 IF (INFO(1).LT.0) GOTO 490 5638 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, 5639 & ITMP2(1), 1, MPI_INTEGER, 5640 & MASTER, id%COMM, IERR) 5641 IF(id%MYID .EQ. MASTER) THEN 5642 POSBUF = ITMP2(1)+1 5643 KEEP(220)=1 5644 DO I = 1,id%NPROCS-1 5645 CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), 5646 & MPI_INTEGER,I, 5647 & ZERO_PIV, id%COMM, STATUS, IERR) 5648 CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, 5649 & id%COMM, IERR) 5650 POSBUF = POSBUF + ITMP2(I+1) 5651 ENDDO 5652 ELSE 5653 CALL MPI_SEND( id%PIVNUL_LIST(1), KEEP(109), MPI_INTEGER, 5654 & MASTER,ZERO_PIV, id%COMM, IERR) 5655 CALL MPI_RECV( KEEP(220), 1, MPI_INTEGER, MASTER, ZERO_PIV, 5656 & id%COMM, STATUS, IERR ) 5657 ENDIF 5658 ENDIF 5659 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) 5660 IF ( PROKG ) THEN 5661 WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP8(6),INFOG(10), 5662 & INFOG(11), KEEP8(110) 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,99979) RINFOG(13) 5697 WRITE(MPG,99977) INFOG(34) 5698 ENDIF 5699 END IF 5700 500 CONTINUE 5701 IF ( I_AM_SLAVE ) THEN 5702 IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN 5703 CALL CMUMPS_592(id,IERR) 5704 IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR 5705 ENDIF 5706 IF (WK_USER_PROVIDED) THEN 5707 NULLIFY(id%S) 5708 ELSE IF (KEEP(201).NE.0) THEN 5709 IF (associated(id%S)) DEALLOCATE(id%S) 5710 NULLIFY(id%S) 5711 KEEP8(23)=0_8 5712 ENDIF 5713 ELSE 5714 IF (WK_USER_PROVIDED) THEN 5715 NULLIFY(id%S) 5716 ELSE 5717 IF (associated(id%S)) DEALLOCATE(id%S) 5718 NULLIFY(id%S) 5719 KEEP8(23)=0_8 5720 END IF 5721 END IF 5722 513 CONTINUE 5723 IF ( I_AM_SLAVE ) THEN 5724 CALL CMUMPS_183( INFO(1), IERR ) 5725 IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR 5726 ENDIF 5727 CALL MUMPS_276( ICNTL(1), INFO(1), 5728 & id%COMM, id%MYID ) 5729 530 CONTINUE 5730 IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) 5731 NULLIFY(RHS_MUMPS) 5732 id%KEEP(13) = KEEP13_SAVE 5733 RETURN 5734 120 FORMAT(/' LOCAL REDISTRIB: DATA LOCAL/SENT =',I12,I12) 5735 125 FORMAT(/' REDISTRIB: TOTAL DATA LOCAL/SENT =',I12,I12) 5736 130 FORMAT(/' ****** FACTORIZATION STEP ********'/) 5737 160 FORMAT(' GLOBAL TIME FOR MATRIX DISTRIBUTION =',F12.4) 5738 165 FORMAT(' Convergence error after scaling for INF-NORM', 5739 & ' (option 7/8) =',D9.2) 5740 166 FORMAT(' Convergence error after scaling for ONE-NORM', 5741 & ' (option 7/8) =',D9.2) 5742 170 FORMAT(/' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ 5743 & ' Size of internal working array S =',I12/ 5744 & ' Size of internal working array IS =',I12/ 5745 & ' MINIMUM (ICNTL(14)=0) size of S =',I12/ 5746 & ' MINIMUM (ICNTL(14)=0) size of IS =',I12/ 5747 & ' REAL SPACE FOR ORIGINAL MATRIX =',I12/ 5748 & ' INTEGER SPACE FOR ORIGINAL MATRIX =',I12/ 5749 & ' REAL SPACE FOR FACTORS =',I12/ 5750 & ' INTEGER SPACE FOR FACTORS =',I12/ 5751 & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12) 5752 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ 5753 & ' NUMBER OF WORKING PROCESSES =',I12/ 5754 & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I12/ 5755 & ' REAL SPACE FOR FACTORS =',I12/ 5756 & ' INTEGER SPACE FOR FACTORS =',I12/ 5757 & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12/ 5758 & ' NUMBER OF NODES IN THE TREE =',I12) 5759 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I12) 5760 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',I12) 5761 180 FORMAT(/' ELAPSED TIME FOR FACTORIZATION =',F12.4) 576299977 FORMAT( ' INFOG(34) DETERMINANT (base 2 exponent) =',I12) 576399978 FORMAT( ' RINFOG(12) DETERMINANT (real part) =',F12.4) 576499979 FORMAT( ' RINFOG(12) DETERMINANT (imaginary part) =',F12.4) 576599980 FORMAT( ' KEEP8(108) Extra copies IP stacking =',I12) 576699981 FORMAT( ' INFOG(14) NUMBER OF MEMORY COMPRESS =',I12) 576799982 FORMAT( ' INFOG(13) NUMBER OF DELAYED PIVOTS =',I12) 576899983 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(16) =',I12) 576999991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I12) 577099992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I12) 577199984 FORMAT(/' GLOBAL STATISTICS '/ 5772 & ' RINFOG(2) OPERATIONS IN NODE ASSEMBLY =',1PD10.3/ 5773 & ' ------(3) OPERATIONS IN NODE ELIMINATION=',1PD10.3/ 5774 & ' INFOG (9) REAL SPACE FOR FACTORS =',I12/ 5775 & ' INFOG(10) INTEGER SPACE FOR FACTORS =',I12/ 5776 & ' INFOG(11) MAXIMUM FRONT SIZE =',I12/ 5777 & ' INFOG(29) NUMBER OF ENTRIES IN FACTORS =',I12) 577899985 FORMAT( ' INFOG(12) NB OF OFF DIAGONAL PIVOTS =',I12) 577999986 FORMAT( ' INFOG(25) NB TINY PIVOTS/STATIC PIVOTING =',I12) 578099988 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 1 nodes =',I12) 578199989 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 2 nodes =',I12) 5782 END SUBROUTINE CMUMPS_142 5783 SUBROUTINE CMUMPS_713(PROKG, MPG, VAL, NSLAVES, 5784 & COMM, MSG) 5785 IMPLICIT NONE 5786 INCLUDE 'mpif.h' 5787 LOGICAL PROKG 5788 INTEGER MPG 5789 INTEGER(8) VAL 5790 INTEGER NSLAVES 5791 INTEGER COMM 5792 CHARACTER*42 MSG 5793 INTEGER(8) MAX_VAL 5794 INTEGER IERR, MASTER 5795 REAL LOC_VAL, AVG_VAL 5796 PARAMETER(MASTER=0) 5797 CALL MUMPS_646( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) 5798 LOC_VAL = real(VAL)/real(NSLAVES) 5799 CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_REAL, 5800 & MPI_SUM, MASTER, COMM, IERR ) 5801 IF (PROKG) THEN 5802 WRITE(MPG,100) " Maximum ", MSG, MAX_VAL 5803 WRITE(MPG,100) " Average ", MSG, int(AVG_VAL,8) 5804 ENDIF 5805 RETURN 5806 100 FORMAT(A9,A42,I12) 5807 END SUBROUTINE CMUMPS_713 5808 SUBROUTINE CMUMPS_770(id) 5809 USE CMUMPS_STRUC_DEF 5810 IMPLICIT NONE 5811 TYPE(CMUMPS_STRUC) :: id 5812 INCLUDE 'mpif.h' 5813 INCLUDE 'mumps_tags.h' 5814 INCLUDE 'mumps_headers.h' 5815 INTEGER STATUS( MPI_STATUS_SIZE ) 5816 INTEGER IERR, MASTER 5817 PARAMETER( MASTER = 0 ) 5818 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 5819 INTEGER :: ROW_LENGTH, I 5820 INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 5821 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS 5822 INTEGER MUMPS_275 5823 EXTERNAL MUMPS_275 5824 IF (id%INFO(1) .LT. 0) RETURN 5825 IF (id%KEEP(60) .EQ. 0) RETURN 5826 ID_SCHUR =MUMPS_275( 5827 & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), 5828 & id%NSLAVES) 5829 IF ( id%KEEP( 46 ) .NE. 1 ) THEN 5830 ID_SCHUR = ID_SCHUR + 1 5831 END IF 5832 IF (id%MYID.EQ.ID_SCHUR) THEN 5833 IF (id%KEEP(60).EQ.1) THEN 5834 LD_SCHUR = 5835 & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) 5836 SIZE_SCHUR = LD_SCHUR - id%KEEP(253) 5837 ELSE 5838 LD_SCHUR = -999999 5839 SIZE_SCHUR = id%root%TOT_ROOT_SIZE 5840 ENDIF 5841 ELSE IF (id%MYID .EQ. MASTER) THEN 5842 SIZE_SCHUR = id%KEEP(116) 5843 LD_SCHUR = -44444 5844 ELSE 5845 RETURN 5846 ENDIF 5847 SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) 5848 IF (id%KEEP(60) .GT. 1) THEN 5849 IF (id%KEEP(221).EQ.1) THEN 5850 DO I = 1, id%KEEP(253) 5851 IF (ID_SCHUR.EQ.MASTER) THEN 5852 CALL ccopy(SIZE_SCHUR, 5853 & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, 5854 & id%REDRHS((I-1)*id%LREDRHS+1), 1) 5855 ELSE 5856 IF (id%MYID.EQ.ID_SCHUR) THEN 5857 CALL MPI_SEND( 5858 & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 5859 & SIZE_SCHUR, 5860 & MPI_COMPLEX, 5861 & MASTER, TAG_SCHUR, 5862 & id%COMM, IERR ) 5863 ELSE 5864 CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), 5865 & SIZE_SCHUR, 5866 & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, 5867 & id%COMM, STATUS, IERR ) 5868 ENDIF 5869 ENDIF 5870 ENDDO 5871 IF (id%MYID.EQ.ID_SCHUR) THEN 5872 DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) 5873 NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) 5874 ENDIF 5875 ENDIF 5876 RETURN 5877 ENDIF 5878 IF (id%KEEP(252).EQ.0) THEN 5879 IF ( ID_SCHUR .EQ. MASTER ) THEN 5880 CALL CMUMPS_756( SURFSCHUR8, 5881 & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), 5882 & id%SCHUR(1) ) 5883 ELSE 5884 BL8=int(huge(BL4)/id%KEEP(35)/10,8) 5885 DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) 5886 SHIFT8 = int(IB-1,8) * BL8 5887 BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) 5888 IF ( id%MYID .eq. ID_SCHUR ) THEN 5889 CALL MPI_SEND( id%S( SHIFT8 + 5890 & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) 5891 & +4+id%KEEP(IXSZ)))), 5892 & BL4, 5893 & MPI_COMPLEX, 5894 & MASTER, TAG_SCHUR, 5895 & id%COMM, IERR ) 5896 ELSE IF ( id%MYID .eq. MASTER ) THEN 5897 CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), 5898 & BL4, 5899 & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, 5900 & id%COMM, STATUS, IERR ) 5901 END IF 5902 ENDDO 5903 END IF 5904 ELSE 5905 ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) 5906 & +4+id%KEEP(IXSZ))) 5907 ISCHUR_DEST= 1_8 5908 DO I=1, SIZE_SCHUR 5909 ROW_LENGTH = SIZE_SCHUR 5910 IF (ID_SCHUR.EQ.MASTER) THEN 5911 CALL ccopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, 5912 & id%SCHUR(ISCHUR_DEST),1) 5913 ELSE 5914 IF (id%MYID.EQ.ID_SCHUR) THEN 5915 CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, 5916 & MPI_COMPLEX, 5917 & MASTER, TAG_SCHUR, 5918 & id%COMM, IERR ) 5919 ELSE 5920 CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), 5921 & ROW_LENGTH, 5922 & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, 5923 & id%COMM, STATUS, IERR ) 5924 ENDIF 5925 ENDIF 5926 ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) 5927 ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) 5928 ENDDO 5929 IF (id%KEEP(221).EQ.1) THEN 5930 ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) 5931 & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * 5932 & int(LD_SCHUR,8) 5933 ISCHUR_UNS = 5934 & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) 5935 & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) 5936 ISCHUR_DEST = 1_8 5937 DO I = 1, id%KEEP(253) 5938 IF (ID_SCHUR .EQ. MASTER) THEN 5939 IF (id%KEEP(50) .EQ. 0) THEN 5940 CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, 5941 & id%REDRHS(ISCHUR_DEST), 1) 5942 ELSE 5943 CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, 5944 & id%REDRHS(ISCHUR_DEST), 1) 5945 ENDIF 5946 ELSE 5947 IF (id%MYID .NE. MASTER) THEN 5948 IF (id%KEEP(50) .EQ. 0) THEN 5949 CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, 5950 & id%S(ISCHUR_SYM), 1) 5951 ENDIF 5952 CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, 5953 & MPI_COMPLEX, MASTER, TAG_SCHUR, 5954 & id%COMM, IERR ) 5955 ELSE 5956 CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), 5957 & SIZE_SCHUR, MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, 5958 & id%COMM, STATUS, IERR ) 5959 ENDIF 5960 ENDIF 5961 IF (id%KEEP(50).EQ.0) THEN 5962 ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) 5963 ELSE 5964 ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) 5965 ENDIF 5966 ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) 5967 ENDDO 5968 ENDIF 5969 ENDIF 5970 RETURN 5971 END SUBROUTINE CMUMPS_770 5972 SUBROUTINE CMUMPS_83 5973 & ( N, MAPPING, NZ, IRN, JCN, PROCNODE, STEP, 5974 & SLAVEF, PERM, FILS, 5975 & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) 5976 USE CMUMPS_STRUC_DEF 5977 IMPLICIT NONE 5978 INTEGER N, NZ, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL 5979 INTEGER KEEP(500) 5980 INTEGER(8) KEEP8(150) 5981 INTEGER IRN( NZ ), JCN( NZ ) 5982 INTEGER MAPPING( NZ ), STEP( N ) 5983 INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) 5984 INTEGER MUMPS_275, MUMPS_330 5985 EXTERNAL MUMPS_275, MUMPS_330 5986 INTEGER K, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE 5987 INTEGER TYPE_NODE, DEST 5988 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID 5989 INODE = KEEP(38) 5990 K = 1 5991 DO WHILE ( INODE .GT. 0 ) 5992 RG2L( INODE ) = K 5993 INODE = FILS( INODE ) 5994 K = K + 1 5995 END DO 5996 DO K = 1, NZ 5997 IOLD = IRN( K ) 5998 JOLD = JCN( K ) 5999 IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. 6000 & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN 6001 MAPPING( K ) = -1 6002 CYCLE 6003 END IF 6004 IF ( IOLD .eq. JOLD ) THEN 6005 ISEND = IOLD 6006 JSEND = JOLD 6007 ELSE 6008 INEW = PERM( IOLD ) 6009 JNEW = PERM( JOLD ) 6010 IF ( INEW .LT. JNEW ) THEN 6011 ISEND = IOLD 6012 IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD 6013 JSEND = JOLD 6014 ELSE 6015 ISEND = -JOLD 6016 JSEND = IOLD 6017 END IF 6018 END IF 6019 IARR = abs( ISEND ) 6020 TYPE_NODE = MUMPS_330( PROCNODE(abs(STEP(IARR))), 6021 & SLAVEF ) 6022 IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN 6023 IF ( KEEP(46) .eq. 0 ) THEN 6024 DEST = MUMPS_275( PROCNODE(abs(STEP(IARR))), 6025 & SLAVEF ) + 1 6026 ELSE 6027 DEST = MUMPS_275( PROCNODE(abs(STEP(IARR))), 6028 & SLAVEF ) 6029 END IF 6030 ELSE 6031 IF ( ISEND .LT. 0 ) THEN 6032 IPOSROOT = RG2L( JSEND ) 6033 JPOSROOT = RG2L( IARR ) 6034 ELSE 6035 IPOSROOT = RG2L( IARR ) 6036 JPOSROOT = RG2L( JSEND ) 6037 END IF 6038 IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) 6039 JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) 6040 IF ( KEEP( 46 ) .eq. 0 ) THEN 6041 DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 6042 ELSE 6043 DEST = IROW_GRID * NPCOL + JCOL_GRID 6044 END IF 6045 END IF 6046 MAPPING( K ) = DEST 6047 END DO 6048 RETURN 6049 END SUBROUTINE CMUMPS_83 6050 SUBROUTINE CMUMPS_282( 6051 & N, NZ_loc, id, 6052 & DBLARR, LDBLARR, INTARR, LINTARR, 6053 & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, 6054 & 6055 & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, 6056 & ICNTL, INFO, NSEND, NLOCAL, 6057 & ISTEP_TO_INIV2, CANDIDATES 6058 & ) 6059 USE CMUMPS_STRUC_DEF 6060 IMPLICIT NONE 6061 INTEGER N, NZ_loc 6062 TYPE (CMUMPS_STRUC) :: id 6063 INTEGER LDBLARR, LINTARR 6064 COMPLEX DBLARR( LDBLARR ) 6065 INTEGER INTARR( LINTARR ) 6066 INTEGER PTRAIW( N ), PTRARW( N ) 6067 INTEGER KEEP(500) 6068 INTEGER(8) KEEP8(150) 6069 INTEGER MYID, COMM, NBRECORDS 6070 INTEGER(8) :: LA 6071 INTEGER SLAVEF 6072 INTEGER ISTEP_TO_INIV2(KEEP(71)) 6073 INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) 6074 COMPLEX A( LA ) 6075 TYPE (CMUMPS_ROOT_STRUC) :: root 6076 INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) 6077 INTEGER INFO( 40 ), ICNTL(40) 6078 INTEGER MUMPS_275, MUMPS_330, numroc, 6079 & MUMPS_810 6080 EXTERNAL MUMPS_275, MUMPS_330, numroc, 6081 & MUMPS_810 6082 INCLUDE 'mumps_tags.h' 6083 INCLUDE 'mpif.h' 6084 INTEGER IERR, STATUS( MPI_STATUS_SIZE ), MSGSOU 6085 COMPLEX ZERO 6086 PARAMETER( ZERO = (0.0E0,0.0E0) ) 6087 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 6088 INTEGER END_MSG_2_RECV 6089 INTEGER I, K, I1, IA 6090 INTEGER TYPE_NODE, DEST 6091 INTEGER IOLD, JOLD, IARR, ISEND, JSEND, INEW, JNEW 6092 INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 6093 LOGICAL T4_MASTER_CONCERNED 6094 COMPLEX VAL 6095 INTEGER(8) :: PTR_ROOT 6096 INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT 6097 INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT 6098 INTEGER MP,LP 6099 INTEGER KPROBE, FREQPROBE 6100 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI 6101 COMPLEX, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR 6102 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI 6103 COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR 6104 INTEGER IACT( SLAVEF ), IREQI( SLAVEF ), IREQR( SLAVEF ) 6105 LOGICAL SEND_ACTIVE( SLAVEF ) 6106 LOGICAL FLAG 6107 INTEGER NSEND, NLOCAL 6108 INTEGER MASTER_NODE, ISTEP 6109 NSEND = 0 6110 NLOCAL = 0 6111 LP = ICNTL(1) 6112 MP = ICNTL(2) 6113 END_MSG_2_RECV = SLAVEF 6114 ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) 6115 IF ( allocok .GT. 0 ) THEN 6116 IF ( LP > 0 ) THEN 6117 WRITE(LP,*) 6118 & '** Error allocating int buffer for matrix distribution' 6119 END IF 6120 INFO(1) = -13 6121 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 6122 END IF 6123 ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) 6124 IF ( allocok .GT. 0 ) THEN 6125 IF ( LP > 0 ) THEN 6126 WRITE(LP,*) 6127 & '** Error allocating real buffer for matrix distribution' 6128 END IF 6129 INFO(1) = -13 6130 INFO(2) = NBRECORDS * SLAVEF * 2 6131 GOTO 20 6132 END IF 6133 ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) 6134 IF ( allocok .GT. 0 ) THEN 6135 IF ( LP > 0 ) THEN 6136 WRITE(LP,*) 6137 & '** Error allocating int recv buffer for matrix distribution' 6138 END IF 6139 INFO(1) = -13 6140 INFO(2) = NBRECORDS * 2 + 1 6141 GOTO 20 6142 END IF 6143 ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) 6144 IF ( allocok .GT. 0 ) THEN 6145 IF ( LP > 0 ) THEN 6146 WRITE(LP,*) 6147 & '** Error allocating int recv buffer for matrix distribution' 6148 END IF 6149 INFO(1) = -13 6150 INFO(2) = NBRECORDS 6151 GOTO 20 6152 END IF 6153 ALLOCATE( IW4( N, 2 ), stat = allocok ) 6154 IF ( allocok .GT. 0 ) THEN 6155 WRITE(LP,*) '** Error allocating IW4 for matrix distribution' 6156 INFO(1) = -13 6157 INFO(2) = N * 2 6158 END IF 6159 20 CONTINUE 6160 CALL MUMPS_276( ICNTL, INFO, COMM, MYID ) 6161 IF ( INFO(1) .LT. 0 ) RETURN 6162 ARROW_ROOT = 0 6163 DO I = 1, N 6164 I1 = PTRAIW( I ) 6165 IA = PTRARW( I ) 6166 IF ( IA .GT. 0 ) THEN 6167 DBLARR( IA ) = ZERO 6168 IW4( I, 1 ) = INTARR( I1 ) 6169 IW4( I, 2 ) = -INTARR( I1 + 1 ) 6170 INTARR( I1 + 2 ) = I 6171 END IF 6172 END DO 6173 IF ( KEEP(38) .NE. 0 ) THEN 6174 IF (KEEP(60)==0) THEN 6175 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, 6176 & root%MYROW, 0, root%NPROW ) 6177 LOCAL_M = max( 1, LOCAL_M ) 6178 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, 6179 & root%MYCOL, 0, root%NPCOL ) 6180 PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 6181 IF ( PTR_ROOT .LE. LA ) THEN 6182 A( PTR_ROOT:LA ) = ZERO 6183 END IF 6184 ELSE 6185 DO I = 1, root%SCHUR_NLOC 6186 root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: 6187 & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC) = ZERO 6188 ENDDO 6189 ENDIF 6190 END IF 6191 DO I = 1, SLAVEF 6192 BUFI( 1, 1, I ) = 0 6193 END DO 6194 DO I = 1, SLAVEF 6195 BUFI( 1, 2, I ) = 0 6196 END DO 6197 DO I = 1, SLAVEF 6198 SEND_ACTIVE( I ) = .FALSE. 6199 IACT( I ) = 1 6200 END DO 6201 KPROBE = 0 6202 FREQPROBE = max(1,NBRECORDS/10) 6203 DO K = 1, NZ_loc 6204 KPROBE = KPROBE + 1 6205 IF ( KPROBE .eq. FREQPROBE ) THEN 6206 KPROBE = 0 6207 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, 6208 & FLAG, STATUS, IERR ) 6209 IF ( FLAG ) THEN 6210 MSGSOU = STATUS( MPI_SOURCE ) 6211 CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, 6212 & MPI_INTEGER, 6213 & MSGSOU, ARR_INT, COMM, STATUS, IERR ) 6214 CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_COMPLEX, 6215 & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) 6216 CALL CMUMPS_102( 6217 & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), 6218 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 6219 & A, LA, 6220 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 6221 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 6222 & INTARR, LINTARR, DBLARR, LDBLARR 6223 & ) 6224 END IF 6225 END IF 6226 IOLD = id%IRN_loc(K) 6227 JOLD = id%JCN_loc(K) 6228 IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) 6229 & .OR.(JOLD.LT.1) ) CYCLE 6230 VAL = id%A_loc(K) 6231 IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 6232 VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) 6233 ENDIF 6234 IF (IOLD.EQ.JOLD) THEN 6235 ISEND = IOLD 6236 JSEND = JOLD 6237 ELSE 6238 INEW = PERM(IOLD) 6239 JNEW = PERM(JOLD) 6240 IF (INEW.LT.JNEW) THEN 6241 ISEND = IOLD 6242 IF ( KEEP(50) .NE. 0 ) ISEND = -IOLD 6243 JSEND = JOLD 6244 ELSE 6245 ISEND = -JOLD 6246 JSEND = IOLD 6247 ENDIF 6248 ENDIF 6249 IARR = abs( ISEND ) 6250 ISTEP = abs(STEP(IARR)) 6251 TYPE_NODE = MUMPS_330( PROCNODE_STEPS(ISTEP), 6252 & SLAVEF ) 6253 MASTER_NODE= MUMPS_275( PROCNODE_STEPS(ISTEP), 6254 & SLAVEF ) 6255 TYPESPLIT = MUMPS_810( PROCNODE_STEPS(ISTEP), 6256 & SLAVEF ) 6257 T4_MASTER_CONCERNED = .FALSE. 6258 T4MASTER = -9999 6259 IF (TYPE_NODE.EQ.2) THEN 6260 INIV2 = ISTEP_TO_INIV2(ISTEP) 6261 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN 6262 T4_MASTER_CONCERNED = .TRUE. 6263 T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) 6264 ENDIF 6265 ENDIF 6266 IF ( TYPE_NODE .eq. 1 ) THEN 6267 DEST = MASTER_NODE 6268 ELSE IF ( TYPE_NODE .eq. 2 ) THEN 6269 IF ( ISEND .LT. 0 ) THEN 6270 DEST = -1 6271 ELSE 6272 DEST = MASTER_NODE 6273 END IF 6274 ELSE 6275 IF ( ISEND < 0 ) THEN 6276 IPOSROOT = root%RG2L_ROW(JSEND) 6277 JPOSROOT = root%RG2L_ROW(IARR ) 6278 ELSE 6279 IPOSROOT = root%RG2L_ROW(IARR ) 6280 JPOSROOT = root%RG2L_ROW(JSEND) 6281 END IF 6282 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) 6283 JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) 6284 DEST = IROW_GRID * root%NPCOL + JCOL_GRID 6285 END IF 6286 if (DEST .eq. -1) then 6287 NLOCAL = NLOCAL + 1 6288 NSEND = NSEND + SLAVEF -1 6289 else 6290 if (DEST .eq.MYID ) then 6291 NLOCAL = NLOCAL + 1 6292 else 6293 NSEND = NSEND + 1 6294 endif 6295 end if 6296 IF ( DEST.EQ.-1) THEN 6297 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) 6298 DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 6299 CALL CMUMPS_101( DEST, ISEND, JSEND, VAL, 6300 & BUFI, BUFR, BUFRECI, BUFRECR, 6301 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6302 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 6303 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6304 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 6305 & root, KEEP,KEEP8 ) 6306 ENDDO 6307 DEST=MASTER_NODE 6308 CALL CMUMPS_101( DEST, ISEND, JSEND, VAL, 6309 & BUFI, BUFR, BUFRECI, BUFRECR, 6310 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6311 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 6312 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6313 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 6314 & root, KEEP,KEEP8 ) 6315 IF (T4_MASTER_CONCERNED) THEN 6316 DEST = T4MASTER 6317 CALL CMUMPS_101( DEST, ISEND, JSEND, VAL, 6318 & BUFI, BUFR, BUFRECI, BUFRECR, 6319 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6320 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 6321 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6322 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 6323 & root, KEEP,KEEP8 ) 6324 ENDIF 6325 ELSE 6326 CALL CMUMPS_101( DEST, ISEND, JSEND, VAL, 6327 & BUFI, BUFR, BUFRECI, BUFRECR, 6328 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6329 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 6330 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6331 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 6332 & root, KEEP,KEEP8 ) 6333 IF (T4_MASTER_CONCERNED) THEN 6334 DEST = T4MASTER 6335 CALL CMUMPS_101( DEST, ISEND, JSEND, VAL, 6336 & BUFI, BUFR, BUFRECI, BUFRECR, 6337 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6338 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 6339 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6340 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 6341 & root, KEEP,KEEP8 ) 6342 ENDIF 6343 ENDIF 6344 END DO 6345 DEST = -2 6346 CALL CMUMPS_101( DEST, ISEND, JSEND, VAL, 6347 & BUFI, BUFR, BUFRECI, BUFRECR, 6348 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6349 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 6350 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6351 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, 6352 & IW4(1,1), root, KEEP,KEEP8 ) 6353 DO WHILE ( END_MSG_2_RECV .NE. 0 ) 6354 CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, 6355 & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) 6356 MSGSOU = STATUS( MPI_SOURCE ) 6357 CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_COMPLEX, 6358 & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) 6359 CALL CMUMPS_102( 6360 & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), 6361 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 6362 & A, LA, 6363 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 6364 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 6365 & INTARR, LINTARR, DBLARR, LDBLARR 6366 & ) 6367 END DO 6368 DO I = 1, SLAVEF 6369 IF ( SEND_ACTIVE( I ) ) THEN 6370 CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) 6371 CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) 6372 END IF 6373 END DO 6374 KEEP(49) = ARROW_ROOT 6375 DEALLOCATE( IW4 ) 6376 DEALLOCATE( BUFI ) 6377 DEALLOCATE( BUFR ) 6378 DEALLOCATE( BUFRECI ) 6379 DEALLOCATE( BUFRECR ) 6380 RETURN 6381 END SUBROUTINE CMUMPS_282 6382 SUBROUTINE CMUMPS_101( DEST, ISEND, JSEND, VAL, 6383 & BUFI, BUFR, BUFRECI, BUFRECR, 6384 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 6385 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, N, 6386 & PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 6387 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, 6388 & KEEP,KEEP8 ) 6389 IMPLICIT NONE 6390 INCLUDE 'cmumps_root.h' 6391 TYPE (CMUMPS_ROOT_STRUC) :: root 6392 INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N 6393 INTEGER KEEP(500) 6394 INTEGER(8) KEEP8(150) 6395 INTEGER ARROW_ROOT, END_MSG_2_RECV, LOCAL_M, LOCAL_N 6396 INTEGER LINTARR, LDBLARR 6397 INTEGER(8) :: LA, PTR_ROOT 6398 INTEGER BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) 6399 INTEGER BUFRECI( NBRECORDS * 2 + 1 ) 6400 INTEGER IREQI(SLAVEF), IREQR(SLAVEF), IACT(SLAVEF) 6401 INTEGER IW4( N, 2 ) 6402 INTEGER PTRAIW( N ), PTRARW( N ), PERM( N ), STEP( N ) 6403 INTEGER PROCNODE_STEPS( KEEP(28) ) 6404 INTEGER INTARR( LINTARR ) 6405 COMPLEX DBLARR( LDBLARR ), A( LA ) 6406 LOGICAL SEND_ACTIVE(SLAVEF) 6407 COMPLEX BUFR( NBRECORDS, 2, SLAVEF ) 6408 COMPLEX BUFRECR( NBRECORDS ) 6409 COMPLEX VAL 6410 INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ 6411 INTEGER TAILLE_SEND_I, TAILLE_SEND_R, MSGSOU 6412 LOGICAL FLAG, SEND_LOCAL 6413 INCLUDE 'mpif.h' 6414 INCLUDE 'mumps_tags.h' 6415 INTEGER IERR, STATUS(MPI_STATUS_SIZE) 6416 IF ( DEST .eq. -2 ) THEN 6417 IBEG = 1 6418 IEND = SLAVEF 6419 ELSE 6420 IBEG = DEST + 1 6421 IEND = DEST + 1 6422 END IF 6423 SEND_LOCAL = .FALSE. 6424 DO ISLAVE = IBEG, IEND 6425 NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) 6426 IF ( DEST .eq. -2 ) THEN 6427 BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC 6428 END IF 6429 IF ( DEST .eq. -2 .or. NBREC + 1 > NBRECORDS ) THEN 6430 DO WHILE ( SEND_ACTIVE( ISLAVE ) ) 6431 CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) 6432 IF ( .NOT. FLAG ) THEN 6433 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, 6434 & FLAG, STATUS, IERR ) 6435 IF ( FLAG ) THEN 6436 MSGSOU = STATUS(MPI_SOURCE) 6437 CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, 6438 & MPI_INTEGER, MSGSOU, ARR_INT, COMM, 6439 & STATUS, IERR ) 6440 CALL MPI_RECV( BUFRECR(1), NBRECORDS, 6441 & MPI_COMPLEX, MSGSOU, 6442 & ARR_REAL, COMM, STATUS, IERR ) 6443 CALL CMUMPS_102( 6444 & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), 6445 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 6446 & A, LA, 6447 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 6448 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 6449 & INTARR, LINTARR, DBLARR, LDBLARR 6450 & ) 6451 END IF 6452 ELSE 6453 CALL MPI_WAIT( IREQI( ISLAVE ), STATUS, IERR ) 6454 SEND_ACTIVE( ISLAVE ) = .FALSE. 6455 END IF 6456 END DO 6457 IF ( ISLAVE - 1 .ne. MYID ) THEN 6458 TAILLE_SEND_I = NBREC * 2 + 1 6459 TAILLE_SEND_R = NBREC 6460 CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), 6461 & TAILLE_SEND_I, 6462 & MPI_INTEGER, ISLAVE - 1, ARR_INT, COMM, 6463 & IREQI( ISLAVE ), IERR ) 6464 CALL MPI_ISEND( BUFR(1, IACT(ISLAVE), ISLAVE ), 6465 & TAILLE_SEND_R, 6466 & MPI_COMPLEX, ISLAVE - 1, ARR_REAL, COMM, 6467 & IREQR( ISLAVE ), IERR ) 6468 SEND_ACTIVE( ISLAVE ) = .TRUE. 6469 ELSE 6470 SEND_LOCAL = .TRUE. 6471 END IF 6472 IACT( ISLAVE ) = 3 - IACT( ISLAVE ) 6473 BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 6474 END IF 6475 IF ( DEST .ne. -2 ) THEN 6476 IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 6477 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ 6478 BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND 6479 BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND 6480 BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL 6481 END IF 6482 END DO 6483 IF ( SEND_LOCAL ) THEN 6484 ISLAVE = MYID + 1 6485 CALL CMUMPS_102( 6486 & BUFI(1,3-IACT(ISLAVE),ISLAVE), 6487 & BUFR(1,3-IACT(ISLAVE),ISLAVE), 6488 & NBRECORDS, N, IW4(1,1), 6489 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 6490 & A, LA, 6491 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 6492 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 6493 & INTARR, LINTARR, DBLARR, LDBLARR 6494 & ) 6495 END IF 6496 RETURN 6497 END SUBROUTINE CMUMPS_101 6498 SUBROUTINE CMUMPS_102 6499 & ( BUFI, BUFR, NBRECORDS, N, IW4, 6500 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, A, LA, 6501 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, 6502 & SLAVEF, ARROW_ROOT, 6503 & PTRAIW, PTRARW, PERM, STEP, 6504 & INTARR, LINTARR, DBLARR, LDBLARR ) 6505 IMPLICIT NONE 6506 INCLUDE 'cmumps_root.h' 6507 TYPE (CMUMPS_ROOT_STRUC) :: root 6508 INTEGER NBRECORDS, N, ARROW_ROOT, MYID, SLAVEF 6509 INTEGER BUFI( NBRECORDS * 2 + 1 ) 6510 COMPLEX BUFR( NBRECORDS ) 6511 INTEGER IW4( N, 2 ) 6512 INTEGER KEEP(500) 6513 INTEGER(8) KEEP8(150) 6514 INTEGER END_MSG_2_RECV 6515 INTEGER PTRAIW( N ), PTRARW( N ), PERM( N ), STEP( N ) 6516 INTEGER PROCNODE_STEPS( KEEP(28) ) 6517 INTEGER LINTARR, LDBLARR 6518 INTEGER INTARR( LINTARR ) 6519 INTEGER LOCAL_M, LOCAL_N 6520 INTEGER(8) :: PTR_ROOT, LA 6521 COMPLEX A( LA ), DBLARR( LDBLARR ) 6522 INTEGER MUMPS_330, MUMPS_275 6523 EXTERNAL MUMPS_330, MUMPS_275 6524 INTEGER IREC, NB_REC, NODE_TYPE, IPROC 6525 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID, 6526 & ILOCROOT, JLOCROOT 6527 INTEGER IA, IS1, ISHIFT, IIW, IS, IAS, IARR, JARR 6528 INTEGER TAILLE 6529 COMPLEX VAL 6530 NB_REC = BUFI( 1 ) 6531 IF ( NB_REC .LE. 0 ) THEN 6532 END_MSG_2_RECV = END_MSG_2_RECV - 1 6533 NB_REC = - NB_REC 6534 END IF 6535 IF ( NB_REC .eq. 0 ) GOTO 100 6536 DO IREC = 1, NB_REC 6537 IARR = BUFI( IREC * 2 ) 6538 JARR = BUFI( IREC * 2 + 1 ) 6539 VAL = BUFR( IREC ) 6540 NODE_TYPE = MUMPS_330( 6541 & PROCNODE_STEPS(abs(STEP(abs( IARR )))), 6542 & SLAVEF ) 6543 IF ( NODE_TYPE .eq. 3 ) THEN 6544 ARROW_ROOT = ARROW_ROOT + 1 6545 IF ( IARR .GT. 0 ) THEN 6546 IPOSROOT = root%RG2L_ROW( IARR ) 6547 JPOSROOT = root%RG2L_COL( JARR ) 6548 ELSE 6549 IPOSROOT = root%RG2L_ROW( JARR ) 6550 JPOSROOT = root%RG2L_COL( -IARR ) 6551 END IF 6552 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) 6553 JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) 6554 IF ( IROW_GRID .NE. root%MYROW .OR. 6555 & JCOL_GRID .NE. root%MYCOL ) THEN 6556 WRITE(*,*) MYID,':INTERNAL Error: recvd root arrowhead ' 6557 WRITE(*,*) MYID,':not belonging to me. IARR,JARR=',IARR,JARR 6558 WRITE(*,*) MYID,':IROW_GRID,JCOL_GRID=',IROW_GRID,JCOL_GRID 6559 WRITE(*,*) MYID,':MYROW, MYCOL=', root%MYROW, root%MYCOL 6560 WRITE(*,*) MYID,':IPOSROOT,JPOSROOT=', IPOSROOT, JPOSROOT 6561 CALL MUMPS_ABORT() 6562 END IF 6563 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / 6564 & ( root%MBLOCK * root%NPROW ) ) 6565 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 6566 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / 6567 & ( root%NBLOCK * root%NPCOL ) ) 6568 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 6569 IF (KEEP(60)==0) THEN 6570 A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) 6571 & + int(ILOCROOT-1,8)) = A( PTR_ROOT 6572 & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) 6573 & + int(ILOCROOT - 1,8) ) 6574 & + VAL 6575 ELSE 6576 root%SCHUR_POINTER( int(JLOCROOT-1,8) 6577 & * int(root%SCHUR_LLD,8) 6578 & + int(ILOCROOT,8) ) 6579 & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) 6580 & * int(root%SCHUR_LLD,8) 6581 & + int(ILOCROOT,8)) 6582 & + VAL 6583 ENDIF 6584 ELSE IF (IARR.GE.0) THEN 6585 IF (IARR.EQ.JARR) THEN 6586 IA = PTRARW(IARR) 6587 DBLARR(IA) = DBLARR(IA) + VAL 6588 ELSE 6589 IS1 = PTRAIW(IARR) 6590 ISHIFT = INTARR(IS1) + IW4(IARR,2) 6591 IW4(IARR,2) = IW4(IARR,2) - 1 6592 IIW = IS1 + ISHIFT + 2 6593 INTARR(IIW) = JARR 6594 IS = PTRARW(IARR) 6595 IAS = IS + ISHIFT 6596 DBLARR(IAS) = VAL 6597 ENDIF 6598 ELSE 6599 IARR = -IARR 6600 ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 6601 INTARR(ISHIFT) = JARR 6602 IAS = PTRARW(IARR)+IW4(IARR,1) 6603 IW4(IARR,1) = IW4(IARR,1) - 1 6604 DBLARR(IAS) = VAL 6605 IPROC = MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), 6606 & SLAVEF ) 6607 IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) 6608 & .AND. 6609 & IW4(IARR,1) .EQ. 0 .AND. 6610 & IPROC .EQ. MYID 6611 & .AND. STEP(IARR) > 0 ) THEN 6612 TAILLE = INTARR( PTRAIW(IARR) ) 6613 CALL CMUMPS_310( N, PERM, 6614 & INTARR( PTRAIW(IARR) + 3 ), 6615 & DBLARR( PTRARW(IARR) + 1 ), 6616 & TAILLE, 1, TAILLE ) 6617 END IF 6618 ENDIF 6619 ENDDO 6620 100 CONTINUE 6621 RETURN 6622 END SUBROUTINE CMUMPS_102 6623 SUBROUTINE CMUMPS_151( NRHS, N, KEEP28, IWCB, LIWW, 6624 & W, LWC, 6625 & POSWCB,IWPOSCB,PTRICB,PTRACB) 6626 IMPLICIT NONE 6627 INTEGER NRHS, N,LIWW,LWC,POSWCB,IWPOSCB, KEEP28 6628 INTEGER IWCB(LIWW),PTRICB(KEEP28),PTRACB(KEEP28) 6629 COMPLEX W(LWC) 6630 INTEGER SIZFI, SIZFR 6631 IF ( IWPOSCB .eq. LIWW ) RETURN 6632 DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) 6633 SIZFR = IWCB( IWPOSCB + 1 ) 6634 SIZFI = 2 6635 SIZFR = SIZFR * NRHS 6636 IWPOSCB = IWPOSCB + SIZFI 6637 POSWCB = POSWCB + SIZFR 6638 IF ( IWPOSCB .eq. LIWW ) RETURN 6639 END DO 6640 RETURN 6641 END SUBROUTINE CMUMPS_151 6642 SUBROUTINE CMUMPS_95(NRHS,N,KEEP28,IWCB,LIWW,W,LWC, 6643 & POSWCB,IWPOSCB,PTRICB,PTRACB) 6644 IMPLICIT NONE 6645 INTEGER NRHS,N,LIWW,LWC,POSWCB,IWPOSCB,KEEP28 6646 INTEGER IWCB(LIWW),PTRICB(KEEP28),PTRACB(KEEP28) 6647 COMPLEX W(LWC) 6648 INTEGER IPTIW,IPTA,SIZFI,SIZFR,LONGI,LONGR 6649 INTEGER I 6650 IPTIW = IWPOSCB 6651 IPTA = POSWCB 6652 LONGI = 0 6653 LONGR = 0 6654 IF ( IPTIW .EQ. LIWW ) RETURN 665510 CONTINUE 6656 IF (IWCB(IPTIW+2).EQ.0) THEN 6657 SIZFR = IWCB(IPTIW+1) 6658 SIZFI = 2 6659 SIZFR = SIZFR * NRHS 6660 IF (LONGI.NE.0) THEN 6661 DO 20 I=0,LONGI-1 6662 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I ) 6663 20 CONTINUE 6664 DO 30 I=0,LONGR-1 6665 W(IPTA + SIZFR - I) = W(IPTA - I ) 6666 30 CONTINUE 6667 ENDIF 6668 DO 40 I=1,KEEP28 6669 IF ((PTRICB(I).LE.(IPTIW+1)).AND. 6670 & (PTRICB(I).GT.IWPOSCB) ) THEN 6671 PTRICB(I) = PTRICB(I) + SIZFI 6672 PTRACB(I) = PTRACB(I) + SIZFR 6673 ENDIF 667440 CONTINUE 6675 IWPOSCB = IWPOSCB + SIZFI 6676 IPTIW = IPTIW + SIZFI 6677 POSWCB = POSWCB + SIZFR 6678 IPTA = IPTA + SIZFR 6679 ELSE 6680 SIZFR = IWCB(IPTIW+1) 6681 SIZFI = 2 6682 SIZFR = SIZFR * NRHS 6683 IPTIW = IPTIW + SIZFI 6684 LONGI = LONGI + SIZFI 6685 IPTA = IPTA + SIZFR 6686 LONGR = LONGR + SIZFR 6687 ENDIF 6688 IF (IPTIW.NE.LIWW) GOTO 10 6689 RETURN 6690 END SUBROUTINE CMUMPS_95 6691 SUBROUTINE CMUMPS_205(MTYPE, IFLAG, N, NZ, 6692 & LHS, WRHS, W, RHS, GIVSOL, SOL, ANORM, XNORM, SCLNRM, 6693 & MPRINT, ICNTL, KEEP,KEEP8) 6694 INTEGER MTYPE,N,NZ,IFLAG,ICNTL(40), KEEP(500) 6695 INTEGER(8) KEEP8(150) 6696 COMPLEX RHS(N),LHS(N) 6697 COMPLEX WRHS(N),SOL(*) 6698 REAL W(N) 6699 REAL RESMAX,RESL2,XNORM, ERMAX,MAXSOL, 6700 & COMAX, SCLNRM, ERL2, ERREL 6701 REAL ANORM,DZERO,EPSI 6702 LOGICAL GIVSOL,PROK 6703 INTEGER MPRINT, MP 6704 INTEGER K 6705 INTRINSIC abs, max, sqrt 6706 MP = ICNTL(2) 6707 PROK = (MPRINT .GT. 0) 6708 DZERO = 0.0E0 6709 EPSI = 0.1E-9 6710 ANORM = DZERO 6711 RESMAX = DZERO 6712 RESL2 = DZERO 6713 DO 40 K = 1, N 6714 RESMAX = max(RESMAX, abs(RHS(K))) 6715 RESL2 = RESL2 + abs(RHS(K)) * abs(RHS(K)) 6716 ANORM = max(ANORM, W(K)) 6717 40 CONTINUE 6718 XNORM = DZERO 6719 DO 50 K = 1, N 6720 XNORM = max(XNORM, abs(LHS(K))) 6721 50 CONTINUE 6722 IF (XNORM .GT. EPSI) THEN 6723 SCLNRM = RESMAX / (ANORM * XNORM) 6724 ELSE 6725 IFLAG = IFLAG + 2 6726 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) 6727 &' max-NORM of computed solut. is zero' 6728 SCLNRM = RESMAX / ANORM 6729 ENDIF 6730 RESL2 = sqrt(RESL2) 6731 ERMAX = DZERO 6732 COMAX = DZERO 6733 ERL2 = DZERO 6734 IF (.NOT.GIVSOL) THEN 6735 IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, 6736 & SCLNRM 6737 ELSE 6738 MAXSOL = DZERO 6739 DO 60 K = 1, N 6740 MAXSOL = max(MAXSOL, abs(SOL(K))) 6741 60 CONTINUE 6742 DO 70 K = 1, N 6743 ERL2 = abs(LHS(K) - SOL(K)) ** 2 + ERL2 6744 ERMAX = max(ERMAX, abs(LHS(K) - SOL(K))) 6745 70 CONTINUE 6746 DO 80 K = 1, N 6747 IF (abs(SOL(K)) .GT. EPSI) THEN 6748 COMAX = max(COMAX, (abs(LHS(K) - SOL(K)) / abs(SOL(K)))) 6749 ENDIF 6750 80 CONTINUE 6751 ERL2 = sqrt(ERL2) 6752 IF (MAXSOL .GT. EPSI) THEN 6753 ERREL = ERMAX / MAXSOL 6754 ELSE 6755 IFLAG = IFLAG + 2 6756 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) 6757 &' MAX-NORM of exact solution is zero' 6758 ERREL = ERMAX 6759 ENDIF 6760 IF (PROK) WRITE( MPRINT, 100 ) ERMAX, ERL2, ERREL, COMAX, RESMAX 6761 & , RESL2, ANORM, XNORM, SCLNRM 6762 ENDIF 6763 90 FORMAT (/' RESIDUAL IS ............ (MAX-NORM) =',1PD9.2/ 6764 & ' .. (2-NORM) =',1PD9.2/ 6765 & ' RINFOG(4):NORM OF input Matrix (MAX-NORM)=',1PD9.2/ 6766 & ' RINFOG(5):NORM OF Computed SOLUT (MAX-NORM)=',1PD9.2/ 6767 & ' RINFOG(6):SCALED RESIDUAL ...... (MAX-NORM)=',1PD9.2) 6768 RETURN 6769 100 FORMAT (/' ERROR IS ............ (MAX-NORM) =',1PD9.2/ 6770 & ' ............ (2-NORM) =',1PD9.2/ 6771 & ' RELATIVE ERROR........... (MAX-NORM) =',1PD9.2/ 6772 & ' Comp. Wise ERROR......... (MAX-NORM) =',1PD9.2/ 6773 & ' AND RESIDUAL IS ......... (MAX-NORM) =',1PD9.2/ 6774 & ' .. (2-NORM) =',1PD9.2/ 6775 & ' NORM OF input MATRIX ... (MAX-NORM) =',1PD9.2/ 6776 & ' NORM of computed SOLUT... (MAX-NORM) =',1PD9.2/ 6777 & ' SCALED RESIDUAL ......... (MAX-NORM) =',1PD9.2) 6778 END SUBROUTINE CMUMPS_205 6779 SUBROUTINE CMUMPS_206(NZ, N, RHS, 6780 & X, Y, D, R_W, C_W, IW, KASE, 6781 & OMEGA, ERX, JOB, COND, MAXIT, NOITER, LP, KEEP,KEEP8, 6782 & ARRET ) 6783 IMPLICIT NONE 6784 INTEGER NZ, N, KASE, KEEP(500), JOB 6785 INTEGER(8) KEEP8(150) 6786 INTEGER IW(N,2) 6787 COMPLEX RHS(N) 6788 COMPLEX X(N), Y(N) 6789 REAL D(N) 6790 REAL R_W(N,2) 6791 COMPLEX C_W(N) 6792 INTEGER LP, MAXIT, NOITER 6793 REAL COND(2),OMEGA(2) 6794 REAL ARRET 6795 REAL CGCE, CTAU 6796 DATA CTAU /1.0E3/, CGCE /0.2E0/ 6797 LOGICAL LCOND1, LCOND2 6798 INTEGER IFLAG, JUMP, I, IMAX 6799 REAL ERX, DXMAX 6800 REAL CONVER, OM1, OM2, DXIMAX 6801 REAL ZERO, ONE,TAU, DD 6802 REAL OLDOMG(2) 6803 INTEGER CMUMPS_IXAMAX 6804 INTRINSIC abs, max 6805 SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX, CONVER, 6806 & OM1, OLDOMG, IFLAG 6807 DATA ZERO /0.0E0/, ONE /1.0E0/ 6808 IF (KASE .EQ. 0) THEN 6809 LCOND1 = .FALSE. 6810 LCOND2 = .FALSE. 6811 COND(1) = ONE 6812 COND(2) = ONE 6813 ERX = ZERO 6814 OM1 = ZERO 6815 IFLAG = 0 6816 NOITER = 0 6817 JUMP = 1 6818 ENDIF 6819 SELECT CASE (JUMP) 6820 CASE (1) 6821 GOTO 30 6822 CASE(2) 6823 GOTO 10 6824 CASE(3) 6825 GOTO 110 6826 CASE(4) 6827 GOTO 150 6828 CASE(5) 6829 GOTO 35 6830 CASE DEFAULT 6831 END SELECT 6832 10 CONTINUE 6833 DO 20 I = 1, N 6834 X(I) = X(I) + Y(I) 6835 20 CONTINUE 6836 IF (NOITER .GT. MAXIT) THEN 6837 IFLAG = IFLAG + 8 6838 GOTO 70 6839 ENDIF 6840 30 CONTINUE 6841 KASE = 14 6842 JUMP = 5 6843 RETURN 6844 35 CONTINUE 6845 IMAX = CMUMPS_IXAMAX(N, X, 1) 6846 DXMAX = abs(X(IMAX)) 6847 OMEGA(1) = ZERO 6848 OMEGA(2) = ZERO 6849 DO 40 I = 1, N 6850 TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * real(N) * CTAU 6851 DD = R_W(I, 1) + abs(RHS(I)) 6852 IF ((DD + TAU) .GT. TAU) THEN 6853 OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) 6854 IW(I, 1) = 1 6855 ELSE 6856 IF (TAU .GT. ZERO) THEN 6857 OMEGA(2) = max(OMEGA(2), 6858 & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) 6859 ENDIF 6860 IW(I, 1) = 2 6861 ENDIF 6862 40 CONTINUE 6863 OM2 = OMEGA(1) + OMEGA(2) 6864 IF (OM2 .LT. ARRET ) GOTO 70 6865 IF (MAXIT .EQ. 0) GOTO 70 6866 IF (NOITER .GT. 1 .AND. OM2 .GT. OM1 * CGCE) THEN 6867 CONVER = OM2 / OM1 6868 IF (OM2 .GT. OM1) THEN 6869 OMEGA(1) = OLDOMG(1) 6870 OMEGA(2) = OLDOMG(2) 6871 DO 50 I = 1, N 6872 X(I) = C_W(I) 6873 50 CONTINUE 6874 ENDIF 6875 GOTO 70 6876 ENDIF 6877 DO 60 I = 1, N 6878 C_W(I) = X(I) 6879 60 CONTINUE 6880 OLDOMG(1) = OMEGA(1) 6881 OLDOMG(2) = OMEGA(2) 6882 OM1 = OM2 6883 NOITER = NOITER + 1 6884 KASE = 2 6885 JUMP = 2 6886 RETURN 6887 70 KASE = 0 6888 IF (JOB .LE. 0) GOTO 170 6889 DO 80 I = 1, N 6890 IF (IW(I, 1) .EQ. 1) THEN 6891 R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) 6892 R_W(I, 2) = ZERO 6893 LCOND1 = .TRUE. 6894 ELSE 6895 R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) 6896 R_W(I, 1) = ZERO 6897 LCOND2 = .TRUE. 6898 ENDIF 6899 80 CONTINUE 6900 DO 90 I = 1, N 6901 C_W(I) = X(I) * D(I) 6902 90 CONTINUE 6903 IMAX = CMUMPS_IXAMAX(N, C_W(1), 1) 6904 DXIMAX = abs(C_W(IMAX)) 6905 IF (.NOT.LCOND1) GOTO 130 6906 100 CALL CMUMPS_218(N, KASE, Y, COND(1), C_W, IW(1, 2)) 6907 IF (KASE .EQ. 0) GOTO 120 6908 IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, D) 6909 IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, R_W) 6910 JUMP = 3 6911 RETURN 6912 110 CONTINUE 6913 IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, R_W) 6914 IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, D) 6915 GOTO 100 6916 120 IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX 6917 ERX = OMEGA(1) * COND(1) 6918 130 IF (.NOT.LCOND2) GOTO 170 6919 KASE = 0 6920 140 CALL CMUMPS_218(N, KASE, Y, COND(2), C_W, IW(1, 2)) 6921 IF (KASE .EQ. 0) GOTO 160 6922 IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, D) 6923 IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, R_W(1, 2)) 6924 JUMP = 4 6925 RETURN 6926 150 CONTINUE 6927 IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, R_W(1, 2)) 6928 IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, D) 6929 GOTO 140 6930 160 IF (DXIMAX .GT. ZERO) THEN 6931 COND(2) = COND(2) / DXIMAX 6932 ENDIF 6933 ERX = ERX + OMEGA(2) * COND(2) 6934 170 KASE = -IFLAG 6935 RETURN 6936 END SUBROUTINE CMUMPS_206 6937 SUBROUTINE CMUMPS_207(A, NZ, N, IRN, ICN, Z, KEEP,KEEP8) 6938 INTEGER NZ, N, I, J, K, KEEP(500) 6939 INTEGER(8) KEEP8(150) 6940 INTEGER IRN(NZ), ICN(NZ) 6941 COMPLEX A(NZ) 6942 REAL Z(N) 6943 REAL ZERO 6944 INTRINSIC abs 6945 DATA ZERO /0.0E0/ 6946 DO 10 I = 1, N 6947 Z(I) = ZERO 6948 10 CONTINUE 6949 IF (KEEP(50) .EQ.0) THEN 6950 DO K = 1, NZ 6951 I = IRN(K) 6952 J = ICN(K) 6953 IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE 6954 IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE 6955 Z(I) = Z(I) + abs(A(K)) 6956 ENDDO 6957 ELSE 6958 DO K = 1, NZ 6959 I = IRN(K) 6960 J = ICN(K) 6961 IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE 6962 IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE 6963 Z(I) = Z(I) + abs(A(K)) 6964 IF (J.NE.I) THEN 6965 Z(J) = Z(J) + abs(A(K)) 6966 ENDIF 6967 ENDDO 6968 ENDIF 6969 RETURN 6970 END SUBROUTINE CMUMPS_207 6971 SUBROUTINE CMUMPS_289(A, NZ, N, IRN, ICN, Z, 6972 & KEEP, KEEP8, COLSCA) 6973 INTEGER, intent(in) :: NZ, N, KEEP(500) 6974 INTEGER(8), intent(in) :: KEEP8(150) 6975 INTEGER, intent(in) :: IRN(NZ), ICN(NZ) 6976 COMPLEX, intent(in) :: A(NZ) 6977 REAL, intent(in) :: COLSCA(N) 6978 REAL, intent(out) :: Z(N) 6979 REAL ZERO 6980 DATA ZERO /0.0E0/ 6981 INTEGER I, J, K 6982 DO 10 I = 1, N 6983 Z(I) = ZERO 6984 10 CONTINUE 6985 IF (KEEP(50) .EQ.0) THEN 6986 DO K = 1, NZ 6987 I = IRN(K) 6988 J = ICN(K) 6989 IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE 6990 IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE 6991 Z(I) = Z(I) + abs(A(K)*COLSCA(J)) 6992 ENDDO 6993 ELSE 6994 DO K = 1, NZ 6995 I = IRN(K) 6996 J = ICN(K) 6997 IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE 6998 IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE 6999 Z(I) = Z(I) + abs(A(K)*COLSCA(J)) 7000 IF (J.NE.I) THEN 7001 Z(J) = Z(J) + abs(A(K)*COLSCA(I)) 7002 ENDIF 7003 ENDDO 7004 ENDIF 7005 RETURN 7006 END SUBROUTINE CMUMPS_289 7007 SUBROUTINE CMUMPS_208(A, NZ, N, IRN, ICN, RHS, X, R, W, 7008 & KEEP,KEEP8) 7009 IMPLICIT NONE 7010 INTEGER, intent(in) :: NZ, N, KEEP(500) 7011 INTEGER(8), intent(in) :: KEEP8(150) 7012 INTEGER, intent(in) :: IRN(NZ), ICN(NZ) 7013 COMPLEX, intent(in) :: A(NZ), RHS(N), X(N) 7014 REAL, intent(out) :: W(N) 7015 COMPLEX, intent(out) :: R(N) 7016 INTEGER I, K, J 7017 REAL ZERO 7018 DATA ZERO /0.0E0/ 7019 COMPLEX D 7020 DO I = 1, N 7021 R(I) = RHS(I) 7022 W(I) = ZERO 7023 ENDDO 7024 DO K = 1, NZ 7025 I = IRN(K) 7026 J = ICN(K) 7027 IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. (J .LT. 1)) 7028 & CYCLE 7029 D = A(K) * X(J) 7030 R(I) = R(I) - D 7031 W(I) = W(I) + abs(D) 7032 IF ((I.NE.J) .AND. (KEEP(50).NE.0) ) THEN 7033 D = A(K) * X(I) 7034 R(J) = R(J) - D 7035 W(J) = W(J) + abs(D) 7036 ENDIF 7037 ENDDO 7038 RETURN 7039 END SUBROUTINE CMUMPS_208 7040 SUBROUTINE CMUMPS_204(N, R, W) 7041 INTEGER, intent(in) :: N 7042 REAL, intent(in) :: W(N) 7043 COMPLEX, intent(inout) :: R(N) 7044 INTEGER I 7045 DO 10 I = 1, N 7046 R(I) = R(I) * W(I) 7047 10 CONTINUE 7048 RETURN 7049 END SUBROUTINE CMUMPS_204 7050 SUBROUTINE CMUMPS_218(N, KASE, X, EST, W, IW) 7051 INTEGER, intent(in) :: N 7052 INTEGER, intent(inout) :: KASE 7053 INTEGER IW(N) 7054 COMPLEX W(N), X(N) 7055 REAL EST 7056 INTRINSIC abs, nint, real, sign 7057 INTEGER CMUMPS_IXAMAX 7058 EXTERNAL CMUMPS_IXAMAX 7059 INTEGER ITMAX 7060 PARAMETER (ITMAX = 5) 7061 INTEGER I, ITER, J, JLAST, JUMP 7062 REAL ALTSGN 7063 REAL TEMP 7064 SAVE ITER, J, JLAST, JUMP 7065 COMPLEX ZERO, ONE 7066 PARAMETER( ZERO = (0.0E0,0.0E0) ) 7067 PARAMETER( ONE = (1.0E0,0.0E0) ) 7068 REAL, PARAMETER :: RZERO = 0.0E0 7069 REAL, PARAMETER :: RONE = 1.0E0 7070 IF (KASE .EQ. 0) THEN 7071 DO 10 I = 1, N 7072 X(I) = ONE / real(N) 7073 10 CONTINUE 7074 KASE = 1 7075 JUMP = 1 7076 RETURN 7077 ENDIF 7078 SELECT CASE (JUMP) 7079 CASE (1) 7080 GOTO 20 7081 CASE(2) 7082 GOTO 40 7083 CASE(3) 7084 GOTO 70 7085 CASE(4) 7086 GOTO 120 7087 CASE(5) 7088 GOTO 160 7089 CASE DEFAULT 7090 END SELECT 7091 20 CONTINUE 7092 IF (N .EQ. 1) THEN 7093 W(1) = X(1) 7094 EST = abs(W(1)) 7095 GOTO 190 7096 ENDIF 7097 DO 30 I = 1, N 7098 X(I) = cmplx( sign(RONE,real(X(I))), kind=kind(X)) 7099 IW(I) = nint(real(X(I))) 7100 30 CONTINUE 7101 KASE = 2 7102 JUMP = 2 7103 RETURN 7104 40 CONTINUE 7105 J = CMUMPS_IXAMAX(N, X, 1) 7106 ITER = 2 7107 50 CONTINUE 7108 DO 60 I = 1, N 7109 X(I) = ZERO 7110 60 CONTINUE 7111 X(J) = ONE 7112 KASE = 1 7113 JUMP = 3 7114 RETURN 7115 70 CONTINUE 7116 DO 80 I = 1, N 7117 W(I) = X(I) 7118 80 CONTINUE 7119 DO 90 I = 1, N 7120 IF (nint(sign(RONE, real(X(I)))) .NE. IW(I)) GOTO 100 7121 90 CONTINUE 7122 GOTO 130 7123 100 CONTINUE 7124 DO 110 I = 1, N 7125 X(I) = cmplx( sign(RONE, real(X(I))), kind=kind(X) ) 7126 IW(I) = nint(real(X(I))) 7127 110 CONTINUE 7128 KASE = 2 7129 JUMP = 4 7130 RETURN 7131 120 CONTINUE 7132 JLAST = J 7133 J = CMUMPS_IXAMAX(N, X, 1) 7134 IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN 7135 ITER = ITER + 1 7136 GOTO 50 7137 ENDIF 7138 130 CONTINUE 7139 EST = RZERO 7140 DO 140 I = 1, N 7141 EST = EST + abs(W(I)) 7142 140 CONTINUE 7143 ALTSGN = RONE 7144 DO 150 I = 1, N 7145 X(I) = cmplx(ALTSGN * (RONE + real(I - 1) / real(N - 1)), 7146 & kind=kind(X)) 7147 ALTSGN = -ALTSGN 7148 150 CONTINUE 7149 KASE = 1 7150 JUMP = 5 7151 RETURN 7152 160 CONTINUE 7153 TEMP = RZERO 7154 DO 170 I = 1, N 7155 TEMP = TEMP + abs(X(I)) 7156 170 CONTINUE 7157 TEMP = 2.0E0 * TEMP / real(3 * N) 7158 IF (TEMP .GT. EST) THEN 7159 DO 180 I = 1, N 7160 W(I) = X(I) 7161 180 CONTINUE 7162 EST = TEMP 7163 ENDIF 7164 190 KASE = 0 7165 RETURN 7166 END SUBROUTINE CMUMPS_218 7167 SUBROUTINE CMUMPS_278( MTYPE, N, NZ, ASPK, IRN, ICN, 7168 & LHS, WRHS, W, RHS, KEEP,KEEP8) 7169 IMPLICIT NONE 7170 INTEGER MTYPE, N, NZ 7171 INTEGER IRN( NZ ), ICN( NZ ) 7172 INTEGER KEEP(500) 7173 INTEGER(8) KEEP8(150) 7174 COMPLEX, intent(in) :: ASPK( NZ ) 7175 COMPLEX, intent(in) :: LHS( N ), WRHS( N ) 7176 COMPLEX, intent(out):: RHS( N ) 7177 REAL, intent(out):: W( N ) 7178 INTEGER K, I, J 7179 REAL DZERO 7180 PARAMETER(DZERO = 0.0E0) 7181 DO 10 K = 1, N 7182 W(K) = DZERO 7183 RHS(K) = WRHS(K) 7184 10 CONTINUE 7185 IF ( KEEP(50) .EQ. 0 ) THEN 7186 IF (MTYPE .EQ. 1) THEN 7187 DO K = 1, NZ 7188 I = IRN(K) 7189 J = ICN(K) 7190 IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) 7191 & ) CYCLE 7192 RHS(I) = RHS(I) - ASPK(K) * LHS(J) 7193 W(I) = W(I) + abs(ASPK(K)) 7194 ENDDO 7195 ELSE 7196 DO K = 1, NZ 7197 I = IRN(K) 7198 J = ICN(K) 7199 IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) 7200 & ) CYCLE 7201 RHS(J) = RHS(J) - ASPK(K) * LHS(I) 7202 W(J) = W(J) + abs(ASPK(K)) 7203 ENDDO 7204 ENDIF 7205 ELSE 7206 DO K = 1, NZ 7207 I = IRN(K) 7208 J = ICN(K) 7209 IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) 7210 & ) CYCLE 7211 RHS(I) = RHS(I) - ASPK(K) * LHS(J) 7212 W(I) = W(I) + abs(ASPK(K)) 7213 IF (J.NE.I) THEN 7214 RHS(J) = RHS(J) - ASPK(K) * LHS(I) 7215 W(J) = W(J) + abs(ASPK(K)) 7216 ENDIF 7217 ENDDO 7218 ENDIF 7219 RETURN 7220 END SUBROUTINE CMUMPS_278 7221 SUBROUTINE CMUMPS_121( MTYPE, N, 7222 & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, 7223 & LHS, WRHS, W, RHS, KEEP,KEEP8) 7224 IMPLICIT NONE 7225 INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT 7226 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) 7227 INTEGER KEEP(500) 7228 INTEGER(8) KEEP8(150) 7229 COMPLEX A_ELT(NA_ELT) 7230 COMPLEX LHS( N ), WRHS( N ), RHS( N ) 7231 REAL W(N) 7232 CALL CMUMPS_257(N, NELT, ELTPTR, ELTVAR, A_ELT, 7233 & LHS, RHS, KEEP(50), MTYPE ) 7234 RHS = WRHS - RHS 7235 CALL CMUMPS_119( MTYPE, N, 7236 & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, 7237 & W, KEEP,KEEP8 ) 7238 RETURN 7239 END SUBROUTINE CMUMPS_121 7240 SUBROUTINE CMUMPS_119( MTYPE, N, 7241 & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, 7242 & W, KEEP,KEEP8 ) 7243 IMPLICIT NONE 7244 INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT 7245 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) 7246 INTEGER KEEP(500) 7247 INTEGER(8) KEEP8(150) 7248 COMPLEX A_ELT(NA_ELT) 7249 REAL TEMP 7250 REAL W(N) 7251 INTEGER K, I, J, IEL, SIZEI, IELPTR 7252 REAL DZERO 7253 PARAMETER(DZERO = 0.0E0) 7254 W = DZERO 7255 K = 1 7256 DO IEL = 1, NELT 7257 SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) 7258 IELPTR = ELTPTR( IEL ) - 1 7259 IF ( KEEP(50).EQ.0 ) THEN 7260 IF (MTYPE.EQ.1) THEN 7261 DO J = 1, SIZEI 7262 DO I = 1, SIZEI 7263 W( ELTVAR( IELPTR + I) ) = 7264 & W( ELTVAR( IELPTR + I) ) 7265 & + abs(A_ELT( K )) 7266 K = K + 1 7267 END DO 7268 END DO 7269 ELSE 7270 DO J = 1, SIZEI 7271 TEMP = W( ELTVAR( IELPTR + J ) ) 7272 DO I = 1, SIZEI 7273 TEMP = TEMP + abs( A_ELT(K)) 7274 K = K + 1 7275 END DO 7276 W(ELTVAR( IELPTR + J )) = 7277 & W(ELTVAR( IELPTR + J )) + TEMP 7278 END DO 7279 ENDIF 7280 ELSE 7281 DO J = 1, SIZEI 7282 W(ELTVAR( IELPTR + J )) = 7283 & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K )) 7284 K = K + 1 7285 DO I = J+1, SIZEI 7286 W(ELTVAR( IELPTR + J )) = 7287 & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K )) 7288 W(ELTVAR( IELPTR + I ) ) = 7289 & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K )) 7290 K = K + 1 7291 END DO 7292 ENDDO 7293 ENDIF 7294 ENDDO 7295 RETURN 7296 END SUBROUTINE CMUMPS_119 7297 SUBROUTINE CMUMPS_135(MTYPE, N, 7298 & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, 7299 & W, KEEP,KEEP8, COLSCA ) 7300 IMPLICIT NONE 7301 INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT 7302 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) 7303 INTEGER KEEP(500) 7304 INTEGER(8) KEEP8(150) 7305 REAL COLSCA(N) 7306 COMPLEX A_ELT(NA_ELT) 7307 REAL W(N) 7308 REAL TEMP, TEMP2 7309 INTEGER K, I, J, IEL, SIZEI, IELPTR 7310 REAL DZERO 7311 PARAMETER(DZERO = 0.0E0) 7312 W = DZERO 7313 K = 1 7314 DO IEL = 1, NELT 7315 SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) 7316 IELPTR = ELTPTR( IEL ) - 1 7317 IF ( KEEP(50).EQ.0 ) THEN 7318 IF (MTYPE.EQ.1) THEN 7319 DO J = 1, SIZEI 7320 TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) 7321 DO I = 1, SIZEI 7322 W( ELTVAR( IELPTR + I) ) = 7323 & W( ELTVAR( IELPTR + I) ) 7324 & + abs(A_ELT( K )) * TEMP2 7325 K = K + 1 7326 END DO 7327 END DO 7328 ELSE 7329 DO J = 1, SIZEI 7330 TEMP = W( ELTVAR( IELPTR + J ) ) 7331 TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) 7332 DO I = 1, SIZEI 7333 TEMP = TEMP + abs(A_ELT( K )) * TEMP2 7334 K = K + 1 7335 END DO 7336 W(ELTVAR( IELPTR + J )) = 7337 & W(ELTVAR( IELPTR + J )) + TEMP 7338 END DO 7339 ENDIF 7340 ELSE 7341 DO J = 1, SIZEI 7342 W(ELTVAR( IELPTR + J )) = 7343 & W(ELTVAR( IELPTR + J )) + 7344 & abs( A_ELT( K )*COLSCA(ELTVAR( IELPTR + J)) ) 7345 K = K + 1 7346 DO I = J+1, SIZEI 7347 W(ELTVAR( IELPTR + J )) = 7348 & W(ELTVAR( IELPTR + J )) + 7349 & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + J))) 7350 W(ELTVAR( IELPTR + I ) ) = 7351 & W(ELTVAR( IELPTR + I )) + 7352 & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + I))) 7353 K = K + 1 7354 END DO 7355 ENDDO 7356 ENDIF 7357 ENDDO 7358 RETURN 7359 END SUBROUTINE CMUMPS_135 7360 SUBROUTINE CMUMPS_122( MTYPE, N, NELT, ELTPTR, 7361 & LELTVAR, ELTVAR, NA_ELT, A_ELT, 7362 & SAVERHS, X, Y, W, K50 ) 7363 IMPLICIT NONE 7364 INTEGER N, NELT, K50, MTYPE, LELTVAR, NA_ELT 7365 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) 7366 COMPLEX A_ELT( NA_ELT ), X( N ), Y( N ), 7367 & SAVERHS(N) 7368 REAL W(N) 7369 INTEGER IEL, I , J, K, SIZEI, IELPTR 7370 REAL ZERO 7371 COMPLEX TEMP 7372 REAL TEMP2 7373 PARAMETER( ZERO = 0.0E0 ) 7374 Y = SAVERHS 7375 W = ZERO 7376 K = 1 7377 DO IEL = 1, NELT 7378 SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) 7379 IELPTR = ELTPTR( IEL ) - 1 7380 IF ( K50 .eq. 0 ) THEN 7381 IF ( MTYPE .eq. 1 ) THEN 7382 DO J = 1, SIZEI 7383 TEMP = X( ELTVAR( IELPTR + J ) ) 7384 DO I = 1, SIZEI 7385 Y( ELTVAR( IELPTR + I ) ) = 7386 & Y( ELTVAR( IELPTR + I ) ) - 7387 & A_ELT( K ) * TEMP 7388 W( ELTVAR( IELPTR + I ) ) = 7389 & W( ELTVAR( IELPTR + I ) ) + 7390 & abs( A_ELT( K ) * TEMP ) 7391 K = K + 1 7392 END DO 7393 END DO 7394 ELSE 7395 DO J = 1, SIZEI 7396 TEMP = Y( ELTVAR( IELPTR + J ) ) 7397 TEMP2 = W( ELTVAR( IELPTR + J ) ) 7398 DO I = 1, SIZEI 7399 TEMP = TEMP - 7400 & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) 7401 TEMP2 = TEMP2 + abs( 7402 & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) 7403 K = K + 1 7404 END DO 7405 Y( ELTVAR( IELPTR + J ) ) = TEMP 7406 W( ELTVAR( IELPTR + J ) ) = TEMP2 7407 END DO 7408 END IF 7409 ELSE 7410 DO J = 1, SIZEI 7411 Y( ELTVAR( IELPTR + J ) ) = 7412 & Y( ELTVAR( IELPTR + J ) ) - 7413 & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) 7414 W( ELTVAR( IELPTR + J ) ) = 7415 & W( ELTVAR( IELPTR + J ) ) + abs( 7416 & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) 7417 K = K + 1 7418 DO I = J+1, SIZEI 7419 Y( ELTVAR( IELPTR + I ) ) = 7420 & Y( ELTVAR( IELPTR + I ) ) - 7421 & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) 7422 Y( ELTVAR( IELPTR + J ) ) = 7423 & Y( ELTVAR( IELPTR + J ) ) - 7424 & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) 7425 W( ELTVAR( IELPTR + I ) ) = 7426 & W( ELTVAR( IELPTR + I ) ) + abs( 7427 & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) 7428 W( ELTVAR( IELPTR + J ) ) = 7429 & W( ELTVAR( IELPTR + J ) ) + abs( 7430 & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) 7431 K = K + 1 7432 END DO 7433 END DO 7434 END IF 7435 END DO 7436 RETURN 7437 END SUBROUTINE CMUMPS_122 7438 SUBROUTINE CMUMPS_643( 7439 & INODE,PTRFAC,KEEP,A,LA,STEP, 7440 & KEEP8,N,MUST_BE_PERMUTED,IERR) 7441 USE CMUMPS_OOC 7442 IMPLICIT NONE 7443 INTEGER INODE,KEEP(500),N 7444 INTEGER(8) KEEP8(150) 7445 INTEGER(8) :: LA 7446 INTEGER(8) :: PTRFAC(KEEP(28)) 7447 INTEGER STEP(N) 7448 INTEGER IERR 7449 COMPLEX A(LA) 7450 INTEGER RETURN_VALUE 7451 LOGICAL MUST_BE_PERMUTED 7452 RETURN_VALUE=CMUMPS_726(INODE,PTRFAC, 7453 & KEEP(28),A,LA,IERR) 7454 IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN 7455 IF(IERR.LT.0)THEN 7456 RETURN 7457 ENDIF 7458 CALL CMUMPS_578(INODE,PTRFAC, 7459 & KEEP,KEEP8,A,IERR) 7460 IF(IERR.LT.0)THEN 7461 RETURN 7462 ENDIF 7463 CALL CMUMPS_577( 7464 & A(PTRFAC(STEP(INODE))), 7465 & INODE,IERR 7466 & ) 7467 IF(IERR.LT.0)THEN 7468 RETURN 7469 ENDIF 7470 ELSE 7471 IF(IERR.LT.0)THEN 7472 RETURN 7473 ENDIF 7474 ENDIF 7475 IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN 7476 MUST_BE_PERMUTED=.TRUE. 7477 CALL CMUMPS_682(INODE) 7478 ELSE 7479 MUST_BE_PERMUTED=.FALSE. 7480 ENDIF 7481 RETURN 7482 END SUBROUTINE CMUMPS_643 7483 SUBROUTINE CMUMPS_257( N, NELT, ELTPTR, ELTVAR, A_ELT, 7484 & X, Y, K50, MTYPE ) 7485 IMPLICIT NONE 7486 INTEGER N, NELT, K50, MTYPE 7487 INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) 7488 COMPLEX A_ELT( * ), X( N ), Y( N ) 7489 INTEGER IEL, I , J, K, SIZEI, IELPTR 7490 COMPLEX TEMP 7491 COMPLEX ZERO 7492 PARAMETER( ZERO = (0.0E0,0.0E0) ) 7493 Y = ZERO 7494 K = 1 7495 DO IEL = 1, NELT 7496 SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) 7497 IELPTR = ELTPTR( IEL ) - 1 7498 IF ( K50 .eq. 0 ) THEN 7499 IF ( MTYPE .eq. 1 ) THEN 7500 DO J = 1, SIZEI 7501 TEMP = X( ELTVAR( IELPTR + J ) ) 7502 DO I = 1, SIZEI 7503 Y( ELTVAR( IELPTR + I ) ) = 7504 & Y( ELTVAR( IELPTR + I ) ) + 7505 & A_ELT( K ) * TEMP 7506 K = K + 1 7507 END DO 7508 END DO 7509 ELSE 7510 DO J = 1, SIZEI 7511 TEMP = Y( ELTVAR( IELPTR + J ) ) 7512 DO I = 1, SIZEI 7513 TEMP = TEMP + 7514 & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) 7515 K = K + 1 7516 END DO 7517 Y( ELTVAR( IELPTR + J ) ) = TEMP 7518 END DO 7519 END IF 7520 ELSE 7521 DO J = 1, SIZEI 7522 Y( ELTVAR( IELPTR + J ) ) = 7523 & Y( ELTVAR( IELPTR + J ) ) + 7524 & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) 7525 K = K + 1 7526 DO I = J+1, SIZEI 7527 Y( ELTVAR( IELPTR + I ) ) = 7528 & Y( ELTVAR( IELPTR + I ) ) + 7529 & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) 7530 Y( ELTVAR( IELPTR + J ) ) = 7531 & Y( ELTVAR( IELPTR + J ) ) + 7532 & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) 7533 K = K + 1 7534 END DO 7535 END DO 7536 END IF 7537 END DO 7538 RETURN 7539 END SUBROUTINE CMUMPS_257 7540 SUBROUTINE CMUMPS_192 7541 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, 7542 & LDLT, MTYPE) 7543 IMPLICIT NONE 7544 INTEGER N, NZ_loc 7545 INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) 7546 COMPLEX A_loc( NZ_loc ), X( N ), Y_loc( N ) 7547 INTEGER LDLT, MTYPE 7548 INTEGER I, J, K 7549 COMPLEX ZERO 7550 PARAMETER( ZERO = (0.0E0,0.0E0) ) 7551 Y_loc = ZERO 7552 IF ( LDLT .eq. 0 ) THEN 7553 IF ( MTYPE .eq. 1 ) THEN 7554 DO K = 1, NZ_loc 7555 I = IRN_loc(K) 7556 J = JCN_loc(K) 7557 IF ((I .LE. 0) .OR. (I .GT. N) .OR. 7558 & (J .LE. 0) .OR. (J .GT. N) 7559 & ) CYCLE 7560 Y_loc(I) = Y_loc(I) + A_loc(K) * X(J) 7561 ENDDO 7562 ELSE 7563 DO K = 1, NZ_loc 7564 I = IRN_loc(K) 7565 J = JCN_loc(K) 7566 IF ((I .LE. 0) .OR. (I .GT. N) 7567 & .OR. (J .LE. 0) .OR. (J .GT. N) 7568 & ) CYCLE 7569 Y_loc(J) = Y_loc(J) + A_loc(K) * X(I) 7570 ENDDO 7571 END IF 7572 ELSE 7573 DO K = 1, NZ_loc 7574 I = IRN_loc(K) 7575 J = JCN_loc(K) 7576 IF ((I .LE. 0) .OR. (I .GT. N) .OR. 7577 & (J .LE. 0) .OR. (J .GT. N) 7578 & ) CYCLE 7579 Y_loc(I) = Y_loc(I) + A_loc(K) * X(J) 7580 IF (J.NE.I) THEN 7581 Y_loc(J) = Y_loc(J) + A_loc(K) * X(I) 7582 ENDIF 7583 ENDDO 7584 END IF 7585 RETURN 7586 END SUBROUTINE CMUMPS_192 7587 SUBROUTINE CMUMPS_256( N, NZ, IRN, ICN, ASPK, X, Y, 7588 & LDLT, MTYPE, MAXTRANS, PERM ) 7589 INTEGER N, NZ, LDLT, MTYPE, MAXTRANS 7590 INTEGER IRN( NZ ), ICN( NZ ) 7591 INTEGER PERM( N ) 7592 COMPLEX ASPK( NZ ), X( N ), Y( N ) 7593 INTEGER K, I, J 7594 COMPLEX PX( N ) 7595 COMPLEX ZERO 7596 PARAMETER( ZERO = (0.0E0,0.0E0) ) 7597 Y = ZERO 7598 IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN 7599 DO I = 1, N 7600 PX(I) = X( PERM( I ) ) 7601 END DO 7602 ELSE 7603 PX = X 7604 END IF 7605 IF ( LDLT .eq. 0 ) THEN 7606 IF (MTYPE .EQ. 1) THEN 7607 DO K = 1, NZ 7608 I = IRN(K) 7609 J = ICN(K) 7610 IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) 7611 & ) CYCLE 7612 Y(I) = Y(I) + ASPK(K) * PX(J) 7613 ENDDO 7614 ELSE 7615 DO K = 1, NZ 7616 I = IRN(K) 7617 J = ICN(K) 7618 IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) 7619 & ) CYCLE 7620 Y(J) = Y(J) + ASPK(K) * PX(I) 7621 ENDDO 7622 ENDIF 7623 ELSE 7624 DO K = 1, NZ 7625 I = IRN(K) 7626 J = ICN(K) 7627 IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) 7628 & ) CYCLE 7629 Y(I) = Y(I) + ASPK(K) * PX(J) 7630 IF (J.NE.I) THEN 7631 Y(J) = Y(J) + ASPK(K) * PX(I) 7632 ENDIF 7633 ENDDO 7634 END IF 7635 IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN 7636 PX = Y 7637 DO I = 1, N 7638 Y( PERM( I ) ) = PX( I ) 7639 END DO 7640 END IF 7641 RETURN 7642 END SUBROUTINE CMUMPS_256 7643 SUBROUTINE CMUMPS_193 7644 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, 7645 & LDLT, MTYPE) 7646 IMPLICIT NONE 7647 INTEGER N, NZ_loc 7648 INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) 7649 COMPLEX A_loc( NZ_loc ), X( N ) 7650 REAL Y_loc( N ) 7651 INTEGER LDLT, MTYPE 7652 INTEGER I, J, K 7653 REAL RZERO 7654 PARAMETER( RZERO = 0.0E0 ) 7655 Y_loc = RZERO 7656 IF ( LDLT .eq. 0 ) THEN 7657 IF ( MTYPE .eq. 1 ) THEN 7658 DO K = 1, NZ_loc 7659 I = IRN_loc(K) 7660 J = JCN_loc(K) 7661 IF ((I .LE. 0) .OR. (I .GT. N) .OR. 7662 & (J .LE. 0) .OR. (J .GT. N) 7663 & ) CYCLE 7664 Y_loc(I) = Y_loc(I) + abs( A_loc(K) * X(J) ) 7665 ENDDO 7666 ELSE 7667 DO K = 1, NZ_loc 7668 I = IRN_loc(K) 7669 J = JCN_loc(K) 7670 IF ((I .LE. 0) .OR. (I .GT. N) 7671 & .OR. (J .LE. 0) .OR. (J .GT. N) 7672 & ) CYCLE 7673 Y_loc(J) = Y_loc(J) + abs( A_loc(K) * X(I) ) 7674 ENDDO 7675 END IF 7676 ELSE 7677 DO K = 1, NZ_loc 7678 I = IRN_loc(K) 7679 J = JCN_loc(K) 7680 IF ((I .LE. 0) .OR. (I .GT. N) .OR. 7681 & (J .LE. 0) .OR. (J .GT. N) 7682 & ) CYCLE 7683 Y_loc(I) = Y_loc(I) + abs( A_loc(K) * X(J) ) 7684 IF (J.NE.I) THEN 7685 Y_loc(J) = Y_loc(J) + abs( A_loc(K) * X(I) ) 7686 ENDIF 7687 ENDDO 7688 END IF 7689 RETURN 7690 END SUBROUTINE CMUMPS_193 7691