1C 2C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 3C 4C 5C This version of MUMPS is provided to you free of charge. It is public 6C domain, based on public domain software developed during the Esprit IV 7C European project PARASOL (1996-1999). Since this first public domain 8C version in 1999, research and developments have been supported by the 9C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, 10C INRIA, and University of Bordeaux. 11C 12C The MUMPS team at the moment of releasing this version includes 13C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, 14C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora 15C Ucar and Clement Weisbecker. 16C 17C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil 18C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, 19C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire 20C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who 21C have been contributing to this project. 22C 23C Up-to-date copies of the MUMPS package can be obtained 24C from the Web pages: 25C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS 26C 27C 28C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY 29C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. 30C 31C 32C User documentation of any code that uses this software can 33C include this complete notice. You can acknowledge (using 34C references [1] and [2]) the contribution of this package 35C in any scientific publication dependent upon the use of the 36C package. You shall use reasonable endeavours to notify 37C the authors of the package of this publication. 38C 39C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 40C A fully asynchronous multifrontal solver using distributed dynamic 41C scheduling, SIAM Journal of Matrix Analysis and Applications, 42C Vol 23, No 1, pp 15-41 (2001). 43C 44C [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and 45C S. Pralet, Hybrid scheduling for the parallel solution of linear 46C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 47C 48 SUBROUTINE SMUMPS_246(MYID, N, STEP, FRERE, FILS, 49 & NA, LNA, NE, DAD, ND, PROCNODE, SLAVEF, 50 & NRLADU, NIRADU, NIRNEC, NRLNEC, 51 & NRLNEC_ACTIVE, 52 & NIRADU_OOC, NIRNEC_OOC, 53 & MAXFR, OPSA, 54 & KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, 55 & SBUF_SEND, SBUF_REC, OPS_SUBTREE, NSTEPS, 56 & I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, CANDIDATES, 57 & IFLAG, IERROR 58 & ,MAX_FRONT_SURFACE_LOCAL 59 & ,MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC 60 & ,ENTRIES_IN_FACTORS_LOC_MASTERS 61 & ) 62 IMPLICIT NONE 63 INTEGER MYID, N, LNA, IFLAG, IERROR 64 INTEGER NIRADU, NIRNEC 65 INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE 66 INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 67 INTEGER NIRADU_OOC, NIRNEC_OOC 68 INTEGER MAXFR, NSTEPS 69 INTEGER(8) MAX_FRONT_SURFACE_LOCAL 70 INTEGER STEP(N) 71 INTEGER FRERE(NSTEPS), FILS(N), NA(LNA), NE(NSTEPS), 72 & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) 73 INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N 74 INTEGER(8) KEEP8(150) 75 INTEGER(8) ENTRIES_IN_FACTORS_LOC, 76 & ENTRIES_IN_FACTORS_LOC_MASTERS 77 INTEGER SBUF_SEND, SBUF_REC 78 INTEGER(8) SBUF_RECOLD 79 INTEGER NMB_PAR2 80 INTEGER ISTEP_TO_INIV2( KEEP(71) ) 81 LOGICAL I_AM_CAND(NMB_PAR2) 82 INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) 83 REAL OPSA 84 DOUBLE PRECISION OPSA_LOC 85 INTEGER(8) MAX_SIZE_FACTOR 86 REAL OPS_SUBTREE 87 DOUBLE PRECISION OPS_SBTR_LOC 88 INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, IPOOL, LSTKI 89 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR 90 INTEGER(8) SBUFS_CB, SBUFR_CB 91 INTEGER SBUFR, SBUFS 92 INTEGER BLOCKING_RHS 93 INTEGER ITOP,NELIM,NFR 94 INTEGER(8) ISTKR, LSTK 95 INTEGER ISTKI, STKI, ISTKI_OOC 96 INTEGER K,NSTK, IFATH 97 INTEGER INODE, LEAF, NBROOT, IN 98 INTEGER LEVEL, MAXITEMPCB 99 INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB 100 LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR 101 INTEGER LEVELF, NCB, SIZECBI 102 INTEGER(8) NCB8 103 INTEGER(8) NFR8, NELIM8 104 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE 105 INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC 106 INTEGER EXTRA_PERM_INFO_OOC 107 INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, 108 & NELIMF, NFRF, NCBF, 109 & NBROWMAXF, LKJIB, 110 & LKJIBT, NBR, NBCOLFAC 111 INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS 112 INTEGER ALLOCOK 113 INTEGER PANEL_SIZE 114 LOGICAL COMPRESSCB 115 DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE 116 INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART 117 INCLUDE 'mumps_headers.h' 118 INTEGER WHAT 119 INTEGER(8) IDUMMY8 120 INTRINSIC min, int, real 121 INTEGER SMUMPS_748 122 EXTERNAL SMUMPS_748 123 INTEGER MUMPS_275, MUMPS_330 124 LOGICAL MUMPS_170 125 INTEGER MUMPS_52 126 EXTERNAL MUMPS_503, MUMPS_52 127 EXTERNAL MUMPS_275, MUMPS_330, 128 & MUMPS_170 129 logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON 130 integer :: IFSON, LEVELSON 131 IF (KEEP(50).eq.2) THEN 132 EXTRA_PERM_INFO_OOC = 1 133 ELSE IF (KEEP(50).eq.0) THEN 134 EXTRA_PERM_INFO_OOC = 2 135 ELSE 136 EXTRA_PERM_INFO_OOC = 0 137 ENDIF 138 COMPRESSCB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) 139 MAX_FRONT_SURFACE_LOCAL=0_8 140 MAX_SIZE_FACTOR=0_8 141 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), IPOOL(NSTEPS), 142 & LSTKI(NSTEPS) , stat=ALLOCOK) 143 if (ALLOCOK .GT. 0) THEN 144 IFLAG =-7 145 IERROR = 4*NSTEPS 146 RETURN 147 endif 148 LKJIB = max(KEEP(5),KEEP(6)) 149 TNSTK = NE 150 LEAF = NA(1)+1 151 IPOOL(1:LEAF-1) = NA(3:3+LEAF-2) 152 NBROOT = NA(2) 153#if defined(OLD_OOC_NOPANEL) 154 XSIZE_OOC=XSIZE_OOC_NOPANEL 155#else 156 IF (KEEP(50).EQ.0) THEN 157 XSIZE_OOC=XSIZE_OOC_UNSYM 158 ELSE 159 XSIZE_OOC=XSIZE_OOC_SYM 160 ENDIF 161#endif 162 SIZEHEADER_OOC = XSIZE_OOC+6 163 SIZEHEADER = XSIZE_IC + 6 164 ISTKR = 0_8 165 ISTKI = 0 166 ISTKI_OOC = 0 167 OPSA_LOC = dble(0.0E0) 168 ENTRIES_IN_FACTORS_LOC = 0_8 169 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 170 OPS_SBTR_LOC = dble(0.0E0) 171 NRLADU = 0_8 172 NIRADU = 0 173 NIRADU_OOC = 0 174 NRLADU_CURRENT = 0_8 175 NRLADU_ROOT_3 = 0_8 176 NRLNEC_ACTIVE = 0_8 177 NRLNEC = 0_8 178 NIRNEC = 0 179 NIRNEC_OOC = 0 180 MAXFR = 0 181 ITOP = 0 182 MAXTEMPCB = 0_8 183 MAXITEMPCB = 0 184 SBUFS_CB = 1_8 185 SBUFS = 1 186 SBUFR_CB = 1_8 187 SBUFR = 1 188 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN 189 INODE = KEEP(38) 190 NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) 191 NRLADU = NRLADU_ROOT_3 192 NRLNEC_ACTIVE = NRLADU_CURRENT 193 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) 194 NRLNEC = NRLADU 195 IF (MUMPS_275(PROCNODE(STEP(INODE)),SLAVEF) 196 & .EQ. MYID) THEN 197 NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) 198 NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) 199 ELSE 200 NIRADU = SIZEHEADER 201 NIRADU_OOC = SIZEHEADER_OOC 202 ENDIF 203 NIRNEC = NIRADU 204 NIRNEC_OOC = NIRADU_OOC 205 ENDIF 206 IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN 207 FORCE_CAND=.FALSE. 208 ELSE 209 FORCE_CAND=(mod(KEEP(24),2).eq.0) 210 END IF 211 90 CONTINUE 212 IF (LEAF.NE.1) THEN 213 LEAF = LEAF - 1 214 INODE = IPOOL(LEAF) 215 ELSE 216 WRITE(MYID+6,*) ' ERROR 1 in SMUMPS_246 ' 217 CALL MUMPS_ABORT() 218 ENDIF 219 95 CONTINUE 220 NFR = ND(STEP(INODE))+KEEP(253) 221 NFR8 = int(NFR,8) 222 NSTK = NE(STEP(INODE)) 223 NELIM = 0 224 IN = INODE 225 100 NELIM = NELIM + 1 226 NELIM8=int(NELIM,8) 227 IN = FILS(IN) 228 IF (IN .GT. 0 ) GOTO 100 229 IFSON = -IN 230 IFATH = DAD(STEP(INODE)) 231 MASTER = MUMPS_275(PROCNODE(STEP(INODE)),SLAVEF) 232 & .EQ. MYID 233 LEVEL = MUMPS_330(PROCNODE(STEP(INODE)),SLAVEF) 234 INSSARBR = MUMPS_170(PROCNODE(STEP(INODE)), 235 & SLAVEF) 236 UPDATE=.FALSE. 237 if(.NOT.FORCE_CAND) then 238 UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) 239 else 240 if(MASTER.and.(LEVEL.ne.3)) then 241 UPDATE = .TRUE. 242 else if(LEVEL.eq.2) then 243 if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN 244 UPDATE = .TRUE. 245 end if 246 end if 247 end if 248 NCB = NFR-NELIM 249 NCB8 = int(NCB,8) 250 SIZECBINFR = NCB8*NCB8 251 IF (KEEP(50).EQ.0) THEN 252 SIZECB = SIZECBINFR 253 ELSE 254 IFATH = DAD(STEP(INODE)) 255 IF ( IFATH.NE.KEEP(38) .AND. COMPRESSCB ) THEN 256 SIZECB = (NCB8*(NCB8+1_8))/2_8 257 ELSE 258 SIZECB = SIZECBINFR 259 ENDIF 260 ENDIF 261 SIZECBI = 2* NCB + SIZEHEADER 262 IF (LEVEL.NE.2) THEN 263 NSLAVES_LOC = -99999999 264 SIZECB_SLAVE = -99999997_8 265 NBROWMAX = NCB 266 ELSE 267 IF (KEEP(48) .EQ. 5) THEN 268 WHAT = 5 269 IF (FORCE_CAND) THEN 270 NSLAVES_LOC=CANDIDATES(SLAVEF+1, 271 & ISTEP_TO_INIV2(STEP(INODE))) 272 ELSE 273 NSLAVES_LOC=SLAVEF-1 274 ENDIF 275 NSLAVES_PASSED=NSLAVES_LOC 276 ELSE 277 WHAT = 2 278 NSLAVES_PASSED=SLAVEF 279 NSLAVES_LOC =SLAVEF-1 280 ENDIF 281 CALL MUMPS_503(WHAT, KEEP,KEEP8, 282 & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE 283 & ) 284 ENDIF 285 IF (KEEP(60).GT.1) THEN 286 IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN 287 NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) 288 NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ 289 & 2*(ND(STEP(INODE))+KEEP(253)) 290 ENDIF 291 ENDIF 292 IF (LEVEL.EQ.3) THEN 293 IF ( 294 & KEEP(60).LE.1 295 & ) THEN 296 NRLNEC = max(NRLNEC,NRLADU+ISTKR+ 297 & int(LOCAL_M,8)*int(LOCAL_N,8)) 298 NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) 299 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + 300 & NRLADU_CURRENT+ISTKR) 301 ENDIF 302 IF (MASTER) THEN 303 IF (NFR.GT.MAXFR) MAXFR = NFR 304 ENDIF 305 ENDIF 306 IF(KEEP(86).EQ.1)THEN 307 IF(MASTER.AND.(.NOT.MUMPS_170( 308 & PROCNODE(STEP(INODE)), SLAVEF)) 309 & )THEN 310 IF(LEVEL.EQ.1)THEN 311 MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, 312 & NFR8*NFR8) 313 ELSEIF(LEVEL.EQ.2)THEN 314 IF(KEEP(50).EQ.0)THEN 315 MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, 316 & NFR8*NELIM8) 317 ELSE 318 MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, 319 & NELIM8*NELIM8) 320 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN 321 MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, 322 & NELIM8*(NELIM8+1_8)) 323 ENDIF 324 ENDIF 325 ENDIF 326 ENDIF 327 ENDIF 328 IF (LEVEL.EQ.2) THEN 329 IF (MASTER) THEN 330 IF (KEEP(50).EQ.0) THEN 331 SBUFS = max(SBUFS, NFR*LKJIB+LKJIB+4) 332 ELSE 333 SBUFS = max(SBUFS, NELIM*LKJIB+NELIM+6) 334 ENDIF 335 ELSEIF (UPDATE) THEN 336 if (KEEP(50).EQ.0) THEN 337 SBUFR = max(SBUFR, NFR*LKJIB+LKJIB+4) 338 else 339 SBUFR = max( SBUFR, NELIM*LKJIB+NELIM+6 ) 340 IF (KEEP(50).EQ.1) THEN 341 LKJIBT = LKJIB 342 ELSE 343 LKJIBT = min( NELIM, LKJIB * 2 ) 344 ENDIF 345 SBUFS = max(SBUFS, 346 & LKJIBT*NBROWMAX+6) 347 SBUFR = max( SBUFR, NBROWMAX*LKJIBT+6 ) 348 endif 349 ENDIF 350 ENDIF 351 IF ( UPDATE ) THEN 352 IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN 353 NIRADU = NIRADU + 2*NFR + SIZEHEADER 354 NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC 355 PANEL_SIZE = SMUMPS_748( 356 & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) 357 NIRADU_OOC = NIRADU_OOC + 358 & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) 359 IF (KEEP(50).EQ.0) THEN 360 NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) 361 NRLADU = NRLADU + NRLADU_CURRENT 362 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) 363 ELSE 364 NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) 365 NRLADU = NRLADU + NRLADU_CURRENT 366 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) 367 ENDIF 368 SIZECBI = 2* NCB + 6 + 3 369 ELSEIF (LEVEL.EQ.2) THEN 370 IF (MASTER) THEN 371 NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR 372 NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR 373 IF (KEEP(50).EQ.0) THEN 374 NBCOLFAC=NFR 375 ELSE 376 NBCOLFAC=NELIM 377 ENDIF 378 PANEL_SIZE = SMUMPS_748( 379 & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) 380 NIRADU_OOC = NIRADU_OOC + 381 & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) 382 NRLADU_CURRENT = int(NBCOLFAC,8)*int(NELIM,8) 383 NRLADU = NRLADU + NRLADU_CURRENT 384 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) 385 SIZECB = 0_8 386 SIZECBINFR = 0_8 387 SIZECBI = NCB + 5 + SLAVEF - 1 388 ELSE 389 SIZECB=SIZECB_SLAVE 390 SIZECBINFR = SIZECB 391 NIRADU = NIRADU+4+NELIM+NBROWMAX 392 NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX 393 IF (KEEP(50).EQ.0) THEN 394 NRLADU = NRLADU + int(NELIM,8)*int(NBROWMAX,8) 395 ELSE 396 NRLADU = NRLADU + int(NELIM,8)*int(NCB/NSLAVES_LOC,8) 397 ENDIF 398 NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) 399 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) 400 SIZECBI = 4 + NBROWMAX + NCB 401 IF (KEEP(50).NE.0) THEN 402 SIZECBI=SIZECBI+NSLAVES_LOC+ 403 & XTRA_SLAVES_SYM 404 ELSE 405 SIZECBI=SIZECBI+NSLAVES_LOC+ 406 & XTRA_SLAVES_UNSYM 407 ENDIF 408 ENDIF 409 ENDIF 410 NIRNEC = max0(NIRNEC, 411 & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) 412 NIRNEC_OOC = max0(NIRNEC_OOC, 413 & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + 414 & (XSIZE_OOC-XSIZE_IC) ) 415 CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR 416 IF (NSTK .NE. 0 .AND. INSSARBR .AND. 417 & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN 418 CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) 419 ENDIF 420 IF (KEEP(50).NE.0.AND.UPDATE.AND.LEVEL.EQ.1) THEN 421 CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + 422 & int(NELIM,8)*int(NCB,8) 423 ENDIF 424 IF (MASTER .AND. KEEP(219).NE.0.AND. 425 & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN 426 CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) 427 ENDIF 428 IF (SLAVEF.EQ.1) THEN 429 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) 430 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ 431 & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) 432 ELSE 433 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) 434 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ 435 & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) 436 ENDIF 437 IF (NFR.GT.MAXFR) MAXFR = NFR 438 IF (NSTK.GT.0) THEN 439 DO 70 K=1,NSTK 440 LSTK = LSTKR(ITOP) 441 ISTKR = ISTKR - LSTK 442 IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 443 & .AND.KEEP(55).EQ.0) THEN 444 ELSE 445 CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK 446 ENDIF 447 STKI = LSTKI( ITOP ) 448 ISTKI = ISTKI - STKI 449 ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) 450 ITOP = ITOP - 1 451 IF (ITOP.LT.0) THEN 452 write(*,*) MYID, 453 & ': ERROR 2 in SMUMPS_246. ITOP = ',ITOP 454 CALL MUMPS_ABORT() 455 ENDIF 456 70 CONTINUE 457 ENDIF 458 ELSE IF (LEVEL.NE.3) THEN 459 DO WHILE (IFSON.GT.0) 460 UPDATES=.FALSE. 461 MASTERSON = MUMPS_275(PROCNODE(STEP(IFSON)),SLAVEF) 462 & .EQ.MYID 463 LEVELSON = MUMPS_330(PROCNODE(STEP(IFSON)),SLAVEF) 464 if(.NOT.FORCE_CAND) then 465 UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. 466 & LEVELSON.EQ.2) 467 else 468 if(MASTERSON.and.(LEVELSON.ne.3)) then 469 UPDATES = .TRUE. 470 else if(LEVELSON.eq.2) then 471 if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then 472 UPDATES = .TRUE. 473 end if 474 end if 475 end if 476 IF (UPDATES) THEN 477 LSTK = LSTKR(ITOP) 478 ISTKR = ISTKR - LSTK 479 STKI = LSTKI( ITOP ) 480 ISTKI = ISTKI - STKI 481 ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) 482 ITOP = ITOP - 1 483 IF (ITOP.LT.0) THEN 484 write(*,*) MYID, 485 & ': ERROR 2 in SMUMPS_246. ITOP = ',ITOP 486 CALL MUMPS_ABORT() 487 ENDIF 488 ENDIF 489 IFSON = FRERE(STEP(IFSON)) 490 END DO 491 ENDIF 492 IF ( 493 & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) 494 & .AND. 495 & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) 496 & ) 497 &THEN 498 ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) 499 IF ( KEEP(50).EQ.0 ) THEN 500 ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) 501 ELSE 502 ENTRIES_NODE_UPPER_PART = 503 & (int(NELIM,8)*int(NELIM+1,8))/2_8 504 ENDIF 505 IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN 506 CALL MUMPS_511(NFR, 507 & NELIM, NELIM,0, 508 & 1,OPS_NODE) 509 ELSE 510 CALL MUMPS_511(NFR, 511 & NELIM, NELIM,KEEP(50), 512 & 1,OPS_NODE) 513 ENDIF 514 IF (LEVEL.EQ.2) THEN 515 CALL MUMPS_511(NFR, 516 & NELIM, NELIM,KEEP(50), 517 & 2,OPS_NODE_MASTER) 518 OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER 519 ENDIF 520 ELSE 521 OPS_NODE = 0.0D0 522 ENTRIES_NODE_UPPER_PART = 0_8 523 ENTRIES_NODE_LOWER_PART = 0_8 524 ENDIF 525 IF ( MASTER ) 526 & ENTRIES_IN_FACTORS_LOC_MASTERS = 527 & ENTRIES_IN_FACTORS_LOC_MASTERS + 528 & ENTRIES_NODE_UPPER_PART + 529 & ENTRIES_NODE_LOWER_PART 530 IF (UPDATE.OR.LEVEL.EQ.3) THEN 531 IF ( LEVEL .EQ. 3 ) THEN 532 OPSA_LOC = OPSA_LOC + OPS_NODE / dble( SLAVEF ) 533 ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + 534 & ENTRIES_NODE_UPPER_PART / 535 & int(SLAVEF,8) 536 IF (MASTER) 537 & ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + 538 & mod(ENTRIES_NODE_UPPER_PART, 539 & int(SLAVEF,8)) 540 ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN 541 OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER 542 ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + 543 & ENTRIES_NODE_UPPER_PART + 544 & mod(ENTRIES_NODE_LOWER_PART, 545 & int(NSLAVES_LOC,8)) 546 ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN 547 OPSA_LOC = OPSA_LOC + dble(OPS_NODE) 548 ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + 549 & ENTRIES_NODE_UPPER_PART + 550 & ENTRIES_NODE_LOWER_PART 551 ELSE IF (UPDATE) THEN 552 OPSA_LOC = OPSA_LOC + 553 & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) 554 ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC 555 & + ENTRIES_NODE_LOWER_PART / 556 & int(NSLAVES_LOC,8) 557 ENDIF 558 IF (MUMPS_170(PROCNODE(STEP(INODE)), 559 & SLAVEF) .OR. NE(STEP(INODE))==0) THEN 560 IF (LEVEL == 1) THEN 561 OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE 562 ELSE 563 CALL MUMPS_511(NFR, 564 & NELIM, NELIM,KEEP(50), 565 & 1,OPS_NODE) 566 OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE 567 ENDIF 568 ENDIF 569 ENDIF 570 IF (IFATH .EQ. 0) THEN 571 NBROOT = NBROOT - 1 572 IF (NBROOT.EQ.0) GOTO 115 573 GOTO 90 574 ELSE 575 NFRF = ND(STEP(IFATH))+KEEP(253) 576 IF (DAD(STEP(IFATH)).EQ.0) THEN 577 NELIMF = NFRF 578 ELSE 579 NELIMF = 0 580 IN = IFATH 581 DO WHILE (IN.GT.0) 582 IN = FILS(IN) 583 NELIMF = NELIMF+1 584 ENDDO 585 ENDIF 586 NCBF = NFRF - NELIMF 587 LEVELF = MUMPS_330(PROCNODE(STEP(IFATH)),SLAVEF) 588 MASTERF= MUMPS_275(PROCNODE(STEP(IFATH)),SLAVEF).EQ.MYID 589 UPDATEF= .FALSE. 590 if(.NOT.FORCE_CAND) then 591 UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) 592 else 593 if(MASTERF.and.(LEVELF.ne.3)) then 594 UPDATEF = .TRUE. 595 else if (LEVELF.eq.2) then 596 if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN 597 UPDATEF = .TRUE. 598 end if 599 end if 600 end if 601 CONCERNED = UPDATEF .OR. UPDATE 602 IF (LEVELF .NE. 2) THEN 603 NBROWMAXF = -999999 604 ELSE 605 IF (KEEP(48) .EQ. 5) THEN 606 WHAT = 4 607 IF (FORCE_CAND) THEN 608 NSLAVES_LOC=CANDIDATES(SLAVEF+1, 609 & ISTEP_TO_INIV2(STEP(IFATH))) 610 ELSE 611 NSLAVES_LOC=SLAVEF-1 612 ENDIF 613 ELSE 614 WHAT = 1 615 NSLAVES_LOC=SLAVEF 616 ENDIF 617 CALL MUMPS_503( WHAT, KEEP, KEEP8, 618 & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 619 & ) 620 ENDIF 621 IF(LEVEL.EQ.1.AND.UPDATE.AND. 622 & (UPDATEF.OR.LEVELF.EQ.2) 623 & .AND.LEVELF.NE.3) THEN 624 IF ( INSSARBR .AND. KEEP(234).NE.0) THEN 625 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ 626 & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) 627 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) 628 ELSE 629 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ 630 & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) 631 NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) 632 ENDIF 633 ENDIF 634 IF (UPDATE .AND. LEVEL.EQ.2 .AND. .NOT. MASTER) THEN 635 NRLNEC = 636 & max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+NRLADU_CURRENT) 637 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,2_8*NRLADU_CURRENT+ 638 & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) 639 ENDIF 640 IF (LEVELF.EQ.3) THEN 641 IF (LEVEL.EQ.1) THEN 642 LEV3MAXREC = int(min(NCB,LOCAL_M),8) * 643 & int(min(NCB,LOCAL_N),8) 644 ELSE 645 LEV3MAXREC = min(SIZECB, 646 & int(min(NBROWMAX,LOCAL_M),8) 647 & *int(min(NCB,LOCAL_N),8)) 648 ENDIF 649 MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) 650 MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) 651 SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) 652 NIRNEC = max(NIRNEC,NIRADU+ISTKI+ 653 & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) 654 NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ 655 & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) 656 ENDIF 657 IF (CONCERNED) THEN 658 IF (LEVELF.EQ.2) THEN 659 IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN 660 IF(MASTERF)THEN 661 NBR = min(NBROWMAXF,NBROWMAX) 662 ELSE 663 NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) 664 ENDIF 665 IF (KEEP(50).EQ.0) THEN 666 CBMAXS = int(NBR,8)*int(NCB,8) 667 ELSE 668 CBMAXS = int(NBR,8)*int(NCB,8) - 669 & (int(NBR,8)*int(NBR-1,8))/2_8 670 ENDIF 671 ELSE 672 CBMAXS = 0_8 673 END IF 674 IF (MASTERF) THEN 675 IF (LEVEL.EQ.1) THEN 676 IF (.NOT.UPDATE) THEN 677 NBR = min(NELIMF, NCB) 678 ELSE 679 NBR = 0 680 ENDIF 681 ELSE 682 NBR = min(NELIMF, NBROWMAX) 683 ENDIF 684 IF (KEEP(50).EQ.0) THEN 685 CBMAXR = int(NBR,8)*NCB8 686 ELSE 687 CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- 688 & (int(NBR,8)*int(NBR-1,8))/2_8 689 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) 690 CBMAXR = min(CBMAXR, SIZECB) 691 IF ((LEVEL.EQ.1).AND.(.NOT. COMPRESSCB)) THEN 692 CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) 693 ENDIF 694 ENDIF 695 ELSE IF (UPDATEF) THEN 696 NBR = min(NBROWMAXF,NBROWMAX) 697 CBMAXR = int(NBR,8) * NCB8 698 IF (KEEP(50).NE.0) THEN 699 CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 700 ENDIF 701 ELSE 702 CBMAXR = 0_8 703 ENDIF 704 ELSEIF (LEVELF.EQ.3) THEN 705 CBMAXR = LEV3MAXREC 706 IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN 707 CBMAXS = LEV3MAXREC 708 ELSE 709 CBMAXS = 0_8 710 ENDIF 711 ELSE 712 IF (MASTERF) THEN 713 CBMAXS = 0_8 714 NBR = min(NFRF,NBROWMAX) 715 IF ((LEVEL.EQ.1).AND.UPDATE) THEN 716 NBR = 0 717 ENDIF 718 CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) 719 IF (LEVEL.EQ.2) 720 & CBMAXR = min(CBMAXR, SIZECB_SLAVE) 721 IF ( KEEP(50).NE.0 ) THEN 722 CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) 723 ELSE 724 CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) 725 ENDIF 726 ELSE 727 CBMAXR = 0_8 728 CBMAXS = SIZECB 729 ENDIF 730 ENDIF 731 IF (UPDATE) THEN 732 CBMAXS = min(CBMAXS, SIZECB) 733 IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN 734 SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) 735 ENDIF 736 ENDIF 737 STACKCB = .FALSE. 738 IF (UPDATEF) THEN 739 STACKCB = .TRUE. 740 SIZECBI = 2 * NFR + SIZEHEADER 741 IF (LEVEL.EQ.1) THEN 742 IF (KEEP(50).NE.0.AND.LEVELF.NE.3 743 & .AND.COMPRESSCB) THEN 744 SIZECB = (NCB8*(NCB8+1_8))/2_8 745 ELSE 746 SIZECB = NCB8*NCB8 747 ENDIF 748 IF (MASTER) THEN 749 SIZECBI = 2+ XSIZE_IC 750 ELSE IF (LEVELF.EQ.1) THEN 751 SIZECB = min(CBMAXR,SIZECB) 752 SIZECBI = 2 * NCB + 9 753 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) 754 SIZECBI = 2 * NCB + SIZEHEADER 755 ELSE 756 SIZECBI = 2 * NCB + 9 757 SBUFR_CB = max(SBUFR_CB, 758 & min(SIZECB,CBMAXR) + int(SIZECBI,8)) 759 MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) 760 SIZECBI = 2 * NCB + SIZEHEADER 761 MAXITEMPCB = max(MAXITEMPCB, SIZECBI) 762 SIZECBI = 0 763 SIZECB = 0_8 764 ENDIF 765 ELSE 766 SIZECB = SIZECB_SLAVE 767 MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) 768 MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) 769 IF (.NOT. 770 & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) 771 & ) 772 & SBUFR_CB = max(SBUFR_CB, 773 & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) 774 IF (MASTER) THEN 775 SIZECBI = NCB + 5 + SLAVEF - 1 + XSIZE_IC 776 SIZECB = 0_8 777 ELSE IF (UPDATE) THEN 778 SIZECBI = NFR + 6 + SLAVEF - 1 + XSIZE_IC 779 IF (KEEP(50).EQ.0) THEN 780 SIZECBI = SIZECBI + NBROWMAX + NFR + 781 & SIZEHEADER 782 ELSE 783 SIZECBI = SIZECBI + NBROWMAX + NFR + 784 & SIZEHEADER+ NSLAVES_LOC 785 ENDIF 786 ELSE 787 SIZECB = 0_8 788 SIZECBI = 0 789 ENDIF 790 ENDIF 791 ELSE 792 IF (LEVELF.NE.3) THEN 793 STACKCB = .TRUE. 794 SIZECB = 0_8 795 SIZECBI = 0 796 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN 797 IF (COMPRESSCB) THEN 798 SIZECB = (NCB8*(NCB8+1_8))/2_8 799 ELSE 800 SIZECB = NCB8*NCB8 801 ENDIF 802 SIZECBI = 2 * NCB + SIZEHEADER 803 ELSE IF (LEVEL.EQ.2) THEN 804 IF (MASTER) THEN 805 SIZECBI = NCB + 5 + SLAVEF - 1 + XSIZE_IC 806 ELSE 807 SIZECB = SIZECB_SLAVE 808 SIZECBI = SIZECBI + NBROWMAX + NFR + SIZEHEADER 809 ENDIF 810 ENDIF 811 ENDIF 812 ENDIF 813 IF (STACKCB) THEN 814 IF (FRERE(STEP(INODE)).EQ.0) THEN 815 write(*,*) ' ERROR 3 in SMUMPS_246' 816 CALL MUMPS_ABORT() 817 ENDIF 818 ITOP = ITOP + 1 819 IF ( ITOP .GT. NSTEPS ) THEN 820 WRITE(*,*) 'ERROR 4 in SMUMPS_246 ' 821 ENDIF 822 LSTKI(ITOP) = SIZECBI 823 ISTKI=ISTKI + SIZECBI 824 ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) 825 LSTKR(ITOP) = SIZECB 826 ISTKR = ISTKR + LSTKR(ITOP) 827 NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) 828 NIRNEC = max0(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) 829 NIRNEC_OOC = max0(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ 830 & MAXITEMPCB + 831 & (XSIZE_OOC-XSIZE_IC) ) 832 ENDIF 833 ENDIF 834 TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 835 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN 836 INODE = IFATH 837 GOTO 95 838 ELSE 839 GOTO 90 840 ENDIF 841 ENDIF 842 115 CONTINUE 843 BLOCKING_RHS = KEEP(84) 844 IF (KEEP(84).EQ.0) BLOCKING_RHS=1 845 NRLNEC = max(NRLNEC, 846 & NRLADU+int(4*KEEP(127)*abs(BLOCKING_RHS),8)) 847 IF (BLOCKING_RHS .LT. 0) THEN 848 BLOCKING_RHS = - 2 * BLOCKING_RHS 849 ENDIF 850 NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ 851 & int(4*KEEP(127)*BLOCKING_RHS,8)) 852 SBUF_RECOLD = max(int(SBUFR,8),SBUFR_CB) 853 SBUF_RECOLD = max(SBUF_RECOLD, 854 & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 855 SBUF_REC = max(SBUFR, int(min(100000_8,SBUFR_CB))) 856 SBUF_REC = SBUF_REC + 17 857 SBUF_REC = SBUF_REC + 2 * KEEP(127) + SLAVEF - 1 + 7 858 SBUF_SEND = max(SBUFS, int(min(100000_8,SBUFR_CB))) 859 SBUF_SEND = SBUF_SEND + 17 860 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN 861 SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) 862 SBUF_REC = SBUF_REC+KEEP(108)+1 863 SBUF_SEND = SBUF_SEND+KEEP(108)+1 864 ENDIF 865 IF (SLAVEF.EQ.1) THEN 866 SBUF_RECOLD = 1_8 867 SBUF_REC = 1 868 SBUF_SEND= 1 869 ENDIF 870 DEALLOCATE( LSTKR, TNSTK, IPOOL, 871 & LSTKI ) 872 OPS_SUBTREE = real(OPS_SBTR_LOC) 873 OPSA = real(OPSA_LOC) 874 KEEP(66) = int(OPSA_LOC/1000000.d0) 875 RETURN 876 END SUBROUTINE SMUMPS_246 877 RECURSIVE SUBROUTINE 878 & SMUMPS_271( COMM_LOAD, ASS_IRECV, 879 & INODE, NELIM_ROOT, root, 880 & 881 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 882 & IWPOS, IWPOSCB, IPTRLU, 883 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 884 & PTLUST_S, PTRFAC, 885 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 886 & IFLAG, IERROR, COMM, 887 & NBPROCFILS, 888 & IPOOL, LPOOL, LEAF, 889 & NBFIN, MYID, SLAVEF, 890 & 891 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 892 & FILS, PTRARW, PTRAIW, 893 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 894 & LPTRAR, NELT, FRTPTR, FRTELT, 895 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 896 IMPLICIT NONE 897 INCLUDE 'smumps_root.h' 898 INCLUDE 'mpif.h' 899 TYPE (SMUMPS_ROOT_STRUC) :: root 900 INTEGER KEEP(500), ICNTL( 40 ) 901 INTEGER(8) KEEP8(150) 902 INTEGER COMM_LOAD, ASS_IRECV 903 INTEGER INODE, NELIM_ROOT 904 INTEGER LBUFR, LBUFR_BYTES 905 INTEGER BUFR( LBUFR ) 906 INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS 907 INTEGER IWPOS, IWPOSCB 908 INTEGER N, LIW 909 INTEGER IW( LIW ) 910 REAL A( LA ) 911 INTEGER(8) :: PTRAST(KEEP(28)) 912 INTEGER(8) :: PTRFAC(KEEP(28)) 913 INTEGER(8) :: PAMASTER(KEEP(28)) 914 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) 915 INTEGER STEP(N), PIMASTER(KEEP(28)) 916 INTEGER COMP 917 INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) 918 INTEGER NBPROCFILS(KEEP(28)) 919 INTEGER IFLAG, IERROR, COMM 920 INTEGER LPOOL, LEAF 921 INTEGER IPOOL( LPOOL ) 922 INTEGER NELT, LPTRAR 923 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 924 INTEGER MYID, SLAVEF, NBFIN 925 DOUBLE PRECISION OPASSW, OPELIW 926 INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 927 REAL :: RHS_MUMPS(KEEP(255)) 928 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 929 INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) 930 INTEGER INTARR(max(1,KEEP(14))) 931 REAL DBLARR(max(1,KEEP(13))) 932 INTEGER ISTEP_TO_INIV2(KEEP(71)), 933 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 934 INCLUDE 'mumps_tags.h' 935 INTEGER I, LCONT, NCOL_TO_SEND, LDA 936 INTEGER(8) :: SHIFT_VAL_SON, POSELT 937 INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, 938 & H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, 939 & LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, 940 & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, 941 & SHIFT_LIST_COL_SON, LDAFS, IERR, 942 & STATUS( MPI_STATUS_SIZE ), ISON, PDEST_MASTER_ISON 943 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 944 INTEGER MSGSOU, MSGTAG 945 LOGICAL INVERT 946 INCLUDE 'mumps_headers.h' 947 INTEGER MUMPS_275, MUMPS_330 948 EXTERNAL MUMPS_275, MUMPS_330 949 FPERE = KEEP(38) 950 TYPE_SON = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 951 IF ( MUMPS_275( PROCNODE_STEPS(STEP(INODE)), 952 & SLAVEF ).EQ.MYID) THEN 953 IOLDPS = PTLUST_S(STEP(INODE)) 954 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 955 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 956 NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) 957 NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) 958 H_INODE = 6 + NSLAVES + KEEP(IXSZ) 959 NELIM = NASS - NPIV 960 NBCOL = NFRONT - NPIV 961 LIST_NELIM_ROW = IOLDPS + H_INODE + NPIV 962 LIST_NELIM_COL = LIST_NELIM_ROW + NFRONT 963 IF (NELIM.LE.0) THEN 964 write(6,*) ' ERROR 1 in SMUMPS_271 ', NELIM 965 write(6,*) MYID,':Process root2son: INODE=',INODE, 966 & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) 967 & +5+KEEP(IXSZ)) 968 CALL MUMPS_ABORT() 969 ENDIF 970 NELIM_LOCAL = NELIM_ROOT 971 DO I=1, NELIM 972 root%RG2L_ROW(IW(LIST_NELIM_ROW)) = NELIM_LOCAL 973 root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL 974 NELIM_LOCAL = NELIM_LOCAL + 1 975 LIST_NELIM_ROW = LIST_NELIM_ROW + 1 976 LIST_NELIM_COL = LIST_NELIM_COL + 1 977 ENDDO 978 NBROW = NFRONT - NPIV 979 NROW = NELIM 980 IF ( KEEP( 50 ) .eq. 0 ) THEN 981 NCOL = NFRONT - NPIV 982 ELSE 983 NCOL = NELIM 984 END IF 985 SHIFT_LIST_ROW_SON = H_INODE + NPIV 986 SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV 987 IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN 988 LDAFS = NFRONT 989 ELSE 990 LDAFS = NASS 991 END IF 992 SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) 993 CALL SMUMPS_80( COMM_LOAD, 994 & ASS_IRECV, 995 & N, INODE, FPERE, 996 & PTLUST_S(1), PTRAST(1), 997 & root, NROW, NCOL, SHIFT_LIST_ROW_SON, 998 & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, 999 & ROOT_NON_ELIM_CB, MYID, COMM, 1000 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1001 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 1002 & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), 1003 & STEP, PIMASTER, PAMASTER, 1004 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 1005 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 1006 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1007 & FILS, PTRARW, PTRAIW, 1008 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE, 1009 & LPTRAR, NELT, FRTPTR, FRTELT, 1010 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1011 IF (IFLAG.LT.0 ) RETURN 1012 IF (TYPE_SON.EQ.1) THEN 1013 NROW = NFRONT - NASS 1014 NCOL = NELIM 1015 SHIFT_LIST_ROW_SON = H_INODE + NASS 1016 SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV 1017 SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) 1018 IF ( KEEP( 50 ) .eq. 0 ) THEN 1019 INVERT = .FALSE. 1020 ELSE 1021 INVERT = .TRUE. 1022 END IF 1023 CALL SMUMPS_80( COMM_LOAD, ASS_IRECV, 1024 & N, INODE, FPERE, 1025 & PTLUST_S, PTRAST, 1026 & root, NROW, NCOL, SHIFT_LIST_ROW_SON, 1027 & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, 1028 & ROOT_NON_ELIM_CB, MYID, COMM, 1029 & 1030 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1031 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 1032 & PTRIST, PTLUST_S, PTRFAC, 1033 & PTRAST, STEP, PIMASTER, PAMASTER, 1034 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 1035 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 1036 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1037 & FILS, PTRARW, PTRAIW, 1038 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, INVERT, ND, FRERE, 1039 & LPTRAR, NELT, FRTPTR, FRTELT, 1040 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1041 IF (IFLAG.LT.0 ) RETURN 1042 ENDIF 1043 IOLDPS = PTLUST_S(STEP(INODE)) 1044 POSELT = PTRAST(STEP(INODE)) 1045 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) 1046 PTRFAC(STEP(INODE))=POSELT 1047 IF ( TYPE_SON .eq. 1 ) THEN 1048 NBROW = NFRONT - NPIV 1049 ELSE 1050 NBROW = NELIM 1051 END IF 1052 IF ( TYPE_SON .eq. 1 .OR. KEEP(50).EQ.0) THEN 1053 LDA = NFRONT 1054 ELSE 1055 LDA = NPIV+NBROW 1056 ENDIF 1057 CALL SMUMPS_324(A(POSELT), LDA, 1058 & NPIV, NBROW, KEEP(50)) 1059 IW(IOLDPS + KEEP(IXSZ)) = NBCOL 1060 IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV 1061 IF (TYPE_SON.EQ.2) THEN 1062 IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS 1063 ELSE 1064 IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT 1065 ENDIF 1066 IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV 1067 CALL SMUMPS_93(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, 1068 & A, LA, POSFAC, LRLU, LRLUS, 1069 & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR) 1070 IF(IERR.LT.0)THEN 1071 IFLAG=IERR 1072 IERROR=0 1073 RETURN 1074 ENDIF 1075 ELSE 1076 ISON = INODE 1077 PDEST_MASTER_ISON = 1078 & MUMPS_275(PROCNODE_STEPS(STEP(ISON)), SLAVEF) 1079 DO WHILE ( PTRIST(STEP(ISON)) .EQ. 0) 1080 BLOCKING = .TRUE. 1081 SET_IRECV = .FALSE. 1082 MESSAGE_RECEIVED = .FALSE. 1083 CALL SMUMPS_329( COMM_LOAD, ASS_IRECV, 1084 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 1085 & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, 1086 & STATUS, 1087 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1088 & IWPOS, IWPOSCB, IPTRLU, 1089 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 1090 & PTLUST_S, PTRFAC, 1091 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 1092 & IFLAG, IERROR, COMM, 1093 & NBPROCFILS, 1094 & IPOOL, LPOOL, LEAF, 1095 & NBFIN, MYID, SLAVEF, 1096 & 1097 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1098 & FILS, PTRARW, PTRAIW, 1099 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, LPTRAR, 1100 & NELT, FRTPTR, FRTELT, 1101 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 1102 IF ( IFLAG .LT. 0 ) RETURN 1103 ENDDO 1104 DO WHILE ( 1105 & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. 1106 & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. 1107 & ( KEEP(50) .NE. 0 .AND. 1108 & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) 1109 IF ( KEEP(50).eq.0) THEN 1110 MSGSOU = PDEST_MASTER_ISON 1111 MSGTAG = BLOC_FACTO 1112 ELSE 1113 IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. 1114 & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN 1115 MSGSOU = PDEST_MASTER_ISON 1116 MSGTAG = BLOC_FACTO_SYM 1117 ELSE 1118 MSGSOU = MPI_ANY_SOURCE 1119 MSGTAG = BLOC_FACTO_SYM_SLAVE 1120 END IF 1121 END IF 1122 BLOCKING = .TRUE. 1123 SET_IRECV = .FALSE. 1124 MESSAGE_RECEIVED = .FALSE. 1125 CALL SMUMPS_329( COMM_LOAD, ASS_IRECV, 1126 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 1127 & MSGSOU, MSGTAG, 1128 & STATUS, 1129 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1130 & IWPOS, IWPOSCB, IPTRLU, 1131 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 1132 & PTLUST_S, PTRFAC, 1133 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 1134 & IFLAG, IERROR, COMM, 1135 & NBPROCFILS, 1136 & IPOOL, LPOOL, LEAF, 1137 & NBFIN, MYID, SLAVEF, 1138 & 1139 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1140 & FILS, PTRARW, PTRAIW, 1141 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, LPTRAR, 1142 & NELT, FRTPTR, FRTELT, 1143 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 1144 IF ( IFLAG .LT. 0 ) RETURN 1145 END DO 1146 IOLDPS = PTRIST(STEP(INODE)) 1147 LCONT = IW(IOLDPS+KEEP(IXSZ)) 1148 NROW = IW(IOLDPS+2+KEEP(IXSZ)) 1149 NPIV = IW(IOLDPS+3+KEEP(IXSZ)) 1150 NASS = IW(IOLDPS+4+KEEP(IXSZ)) 1151 NELIM = NASS-NPIV 1152 IF (NELIM.LE.0) THEN 1153 write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', 1154 & INODE,LCONT, NROW, NPIV, NASS, NELIM 1155 write(6,*) MYID,': IOLDPS=',IOLDPS 1156 write(6,*) MYID,': ERROR 2 in SMUMPS_271 ' 1157 CALL MUMPS_ABORT() 1158 ENDIF 1159 NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) 1160 H_INODE = 6 + NSLAVES + KEEP(IXSZ) 1161 LIST_NELIM_COL = IOLDPS + H_INODE + NROW + NPIV 1162 NELIM_LOCAL = NELIM_ROOT 1163 DO I = 1, NELIM 1164 root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL 1165 root%RG2L_ROW(IW(LIST_NELIM_COL)) = NELIM_LOCAL 1166 NELIM_LOCAL = NELIM_LOCAL + 1 1167 LIST_NELIM_COL = LIST_NELIM_COL + 1 1168 ENDDO 1169 SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) 1170 SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV 1171 NCOL_TO_SEND = NELIM 1172 IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. 1173 & IW(IOLDPS+XXS).EQ.S_ALL) THEN 1174 SHIFT_VAL_SON = int(NPIV,8) 1175 LDA = LCONT + NPIV 1176 ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN 1177 SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) 1178 LDA = NELIM 1179 ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN 1180 SHIFT_VAL_SON=0_8 1181 LDA = NELIM 1182 ELSE 1183 write(*,*) MYID,": internal error in SMUMPS_271", 1184 & IW(IOLDPS+XXS), "INODE=",INODE 1185 CALL MUMPS_ABORT() 1186 ENDIF 1187 IF ( KEEP( 50 ) .eq. 0 ) THEN 1188 INVERT = .FALSE. 1189 ELSE 1190 INVERT = .TRUE. 1191 END IF 1192 CALL SMUMPS_80( COMM_LOAD, ASS_IRECV, 1193 & N, INODE, FPERE, 1194 & PTRIST, PTRAST, 1195 & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, 1196 & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, 1197 & ROOT_NON_ELIM_CB, MYID, COMM, 1198 & 1199 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1200 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 1201 & PTRIST, PTLUST_S, PTRFAC, 1202 & PTRAST, STEP, PIMASTER, PAMASTER, 1203 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 1204 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 1205 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1206 & FILS, PTRARW, PTRAIW, 1207 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, INVERT, ND, FRERE, 1208 & LPTRAR, NELT, FRTPTR, FRTELT, 1209 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1210 IF (IFLAG.LT.0 ) RETURN 1211 IF (KEEP(214).EQ.2) THEN 1212 CALL SMUMPS_314( N, INODE, 1213 & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, 1214 & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, 1215 & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, 1216 & IFLAG, IERROR, SLAVEF, MYID, COMM, KEEP,KEEP8, TYPE_SON 1217 & ) 1218 ENDIF 1219 IF (IFLAG.LT.0) THEN 1220 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 1221 ENDIF 1222 ENDIF 1223 RETURN 1224 END SUBROUTINE SMUMPS_271 1225 SUBROUTINE SMUMPS_221(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 1226 & INOPV,NOFFW,IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8, 1227 & DKEEP,PIVNUL_LIST,LPN_LIST, 1228 & 1229 & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, 1230 & PP_LastPIVRPTRFilled_L, 1231 & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, 1232 & PP_LastPIVRPTRFilled_U) 1233 USE MUMPS_OOC_COMMON 1234 IMPLICIT NONE 1235 INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW 1236 INTEGER(8) :: LA 1237 REAL A(LA) 1238 REAL UU, SEUIL 1239 INTEGER IW(LIW) 1240 INTEGER(8) :: POSELT 1241 INTEGER IOLDPS 1242 INTEGER KEEP(500) 1243 INTEGER(8) KEEP8(150) 1244 INTEGER LPN_LIST 1245 INTEGER PIVNUL_LIST(LPN_LIST) 1246 REAL DKEEP(30) 1247 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, 1248 & PP_LastPIVRPTRFilled_L, 1249 & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, 1250 & PP_LastPIVRPTRFilled_U 1251 INCLUDE 'mumps_headers.h' 1252 REAL SWOP 1253 INTEGER XSIZE 1254 INTEGER(8) :: APOS, IDIAG 1255 INTEGER(8) :: J1, J2, J3, JJ 1256 INTEGER(8) :: NFRONT8 1257 REAL AMROW 1258 REAL RMAX 1259 REAL PIVNUL 1260 REAL FIXA, CSEUIL 1261 INTEGER NPIV,NASSW,IPIV 1262 INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 1263 INTEGER ISWPS2,KSW 1264 INTEGER SMUMPS_IXAMAX 1265 INTRINSIC max 1266 REAL, PARAMETER :: RZERO = 0.0E0 1267 REAL, PARAMETER :: ZERO = 0.0E0 1268 INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L 1269 INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U 1270 PIVNUL = DKEEP(1) 1271 FIXA = DKEEP(2) 1272 CSEUIL = SEUIL 1273 XSIZE = KEEP(IXSZ) 1274 NPIV = IW(IOLDPS+1+XSIZE) 1275 NPIVP1 = NPIV + 1 1276 NFRONT8 = int(NFRONT,8) 1277 IF (KEEP(201).EQ.1) THEN 1278 CALL SMUMPS_667(TYPEF_L, NBPANELS_L, 1279 & I_PIVRPTR_L, I_PIVR_L, 1280 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, 1281 & IW, LIW) 1282 CALL SMUMPS_667(TYPEF_U, NBPANELS_U, 1283 & I_PIVRPTR_U, I_PIVR_U, 1284 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, 1285 & IW, LIW) 1286 ENDIF 1287 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 1288 IF(INOPV .EQ. -1) THEN 1289 APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) 1290 IDIAG = APOS 1291 IF(abs(A(APOS)).LT.SEUIL) THEN 1292 IF(real(A(APOS)) .GE. RZERO) THEN 1293 A(APOS) = CSEUIL 1294 ELSE 1295 A(APOS) = -CSEUIL 1296 ENDIF 1297 KEEP(98) = KEEP(98)+1 1298 ELSE IF (KEEP(258) .NE. 0) THEN 1299 CALL SMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) 1300 ENDIF 1301 IF (KEEP(201).EQ.1) THEN 1302 IF (KEEP(251).EQ.0) THEN 1303 CALL SMUMPS_680( IW(I_PIVRPTR_L), 1304 & NBPANELS_L, 1305 & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, 1306 & PP_LastPanelonDisk_L, 1307 & PP_LastPIVRPTRFilled_L) 1308 ENDIF 1309 CALL SMUMPS_680( IW(I_PIVRPTR_U), 1310 & NBPANELS_U, 1311 & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, 1312 & PP_LastPanelonDisk_U, 1313 & PP_LastPIVRPTRFilled_U) 1314 ENDIF 1315 GO TO 420 1316 ENDIF 1317 INOPV = 0 1318 DO 460 IPIV=NPIVP1,NASSW 1319 APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) 1320 JMAX = 1 1321 IF (UU.GT.RZERO) GO TO 340 1322 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 1323 GO TO 380 1324 340 AMROW = RZERO 1325 J1 = APOS 1326 J2 = APOS + int(- NPIV + NASS - 1,8) 1327 J = NASS -NPIV 1328 JMAX = SMUMPS_IXAMAX(J,A(J1),1) 1329 JJ = J1 + int(JMAX - 1,8) 1330 AMROW = abs(A(JJ)) 1331 RMAX = AMROW 1332 J1 = J2 + 1_8 1333 J2 = APOS +int(- NPIV + NFRONT - 1 - KEEP(253),8) 1334 IF (J2.LT.J1) GO TO 370 1335 DO 360 JJ=J1,J2 1336 RMAX = max(abs(A(JJ)),RMAX) 1337 360 CONTINUE 1338 370 IDIAG = APOS + int(IPIV - NPIVP1,8) 1339 IF ( RMAX .LE. PIVNUL ) THEN 1340 KEEP(109) = KEEP(109)+1 1341 ISW = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE+ 1342 & IW(IOLDPS+5+XSIZE)+IPIV-NPIVP1 1343 PIVNUL_LIST(KEEP(109)) = IW(ISW) 1344 IF(real(FIXA).GT.RZERO) THEN 1345 IF(real(A(IDIAG)) .GE. RZERO) THEN 1346 A(IDIAG) = FIXA 1347 ELSE 1348 A(IDIAG) = -FIXA 1349 ENDIF 1350 ELSE 1351 J1 = APOS 1352 J2 = APOS + int(- NPIV + NFRONT - 1 - KEEP(253),8) 1353 DO JJ=J1,J2 1354 A(JJ) = ZERO 1355 ENDDO 1356 A(IDIAG) = -FIXA 1357 ENDIF 1358 JMAX = IPIV - NPIV 1359 GOTO 385 1360 ENDIF 1361 IF (abs(A(IDIAG)).GT. max(UU*RMAX,SEUIL)) THEN 1362 JMAX = IPIV - NPIV 1363 GO TO 380 1364 ENDIF 1365 IF (AMROW.LE. max(UU*RMAX,SEUIL)) GO TO 460 1366 NOFFW = NOFFW + 1 1367 380 CONTINUE 1368 IF (KEEP(258) .NE. 0) THEN 1369 CALL SMUMPS_762( 1370 & A( APOS+int(JMAX-1,8) ), 1371 & DKEEP(6), 1372 & KEEP(259) ) 1373 ENDIF 1374 385 CONTINUE 1375 IF (IPIV.EQ.NPIVP1) GO TO 400 1376 KEEP(260)=-KEEP(260) 1377 J1 = POSELT + int(NPIV,8)*NFRONT8 1378 J2 = J1 + NFRONT8 - 1_8 1379 J3 = POSELT + int(IPIV-1,8)*NFRONT8 1380 DO 390 JJ=J1,J2 1381 SWOP = A(JJ) 1382 A(JJ) = A(J3) 1383 A(J3) = SWOP 1384 J3 = J3 + 1_8 1385 390 CONTINUE 1386 ISWPS1 = IOLDPS + 5 + NPIVP1 + XSIZE 1387 ISWPS2 = IOLDPS + 5 + IPIV + XSIZE 1388 ISW = IW(ISWPS1) 1389 IW(ISWPS1) = IW(ISWPS2) 1390 IW(ISWPS2) = ISW 1391 400 IF (JMAX.EQ.1) GO TO 420 1392 KEEP(260)=-KEEP(260) 1393 J1 = POSELT + int(NPIV,8) 1394 J2 = POSELT + int(NPIV + JMAX - 1,8) 1395 DO 410 KSW=1,NFRONT 1396 SWOP = A(J1) 1397 A(J1) = A(J2) 1398 A(J2) = SWOP 1399 J1 = J1 + NFRONT8 1400 J2 = J2 + NFRONT8 1401 410 CONTINUE 1402 ISWPS1 = IOLDPS + 5 + NFRONT + NPIV + 1 +XSIZE 1403 ISWPS2 = IOLDPS + 5 + NFRONT + NPIV + JMAX +XSIZE 1404 ISW = IW(ISWPS1) 1405 IW(ISWPS1) = IW(ISWPS2) 1406 IW(ISWPS2) = ISW 1407 GO TO 420 1408 460 CONTINUE 1409 IF (NASSW.EQ.NASS) THEN 1410 INOPV = 1 1411 ELSE 1412 INOPV = 2 1413 ENDIF 1414 GO TO 430 1415 630 CONTINUE 1416 IFLAG = -10 1417 WRITE(*,*) 'Detected a null pivot, INODE/NPIV=',INODE,NPIV 1418 GOTO 430 1419 420 CONTINUE 1420 IF (KEEP(201).EQ.1) THEN 1421 IF (KEEP(251).EQ.0) THEN 1422 CALL SMUMPS_680( IW(I_PIVRPTR_L), 1423 & NBPANELS_L, 1424 & IW(I_PIVR_L), NASS, NPIVP1, IPIV, 1425 & PP_LastPanelonDisk_L, 1426 & PP_LastPIVRPTRFilled_L) 1427 ENDIF 1428 CALL SMUMPS_680( IW(I_PIVRPTR_U), 1429 & NBPANELS_U, 1430 & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, 1431 & PP_LastPanelonDisk_U, 1432 & PP_LastPIVRPTRFilled_U) 1433 ENDIF 1434 430 CONTINUE 1435 RETURN 1436 END SUBROUTINE SMUMPS_221 1437 SUBROUTINE SMUMPS_220(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 1438 & INOPV,NOFFW,IOLDPS,POSELT,UU,SEUIL,KEEP, DKEEP, 1439 & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, 1440 & PP_LastPIVRPTRFilled_L, 1441 & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, 1442 & PP_LastPIVRPTRFilled_U) 1443 USE MUMPS_OOC_COMMON 1444 IMPLICIT NONE 1445 INTEGER NFRONT,NASS,N,LIW,INODE,INOPV 1446 INTEGER(8) :: LA 1447 INTEGER KEEP(500) 1448 REAL DKEEP(30) 1449 REAL UU, SEUIL 1450 REAL A(LA) 1451 INTEGER IW(LIW) 1452 REAL AMROW 1453 REAL RMAX 1454 REAL SWOP 1455 INTEGER(8) :: APOS, POSELT 1456 INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG 1457 INTEGER(8) :: NFRONT8 1458 INTEGER IOLDPS 1459 INTEGER NOFFW,NPIV,IPIV 1460 INTEGER J, J3 1461 INTEGER NPIVP1,JMAX,ISW,ISWPS1 1462 INTEGER ISWPS2,KSW,XSIZE 1463 INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L 1464 INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U 1465 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, 1466 & PP_LastPIVRPTRFilled_L, 1467 & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, 1468 & PP_LastPIVRPTRFilled_U 1469 INTEGER SMUMPS_IXAMAX 1470 INCLUDE 'mumps_headers.h' 1471 INTRINSIC max 1472 REAL, PARAMETER :: RZERO = 0.0E0 1473 NFRONT8 = int(NFRONT,8) 1474 INOPV = 0 1475 XSIZE = KEEP(IXSZ) 1476 NPIV = IW(IOLDPS+1+XSIZE) 1477 NPIVP1 = NPIV + 1 1478 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 1479 CALL SMUMPS_667(TYPEF_L, NBPANELS_L, 1480 & I_PIVRPTR_L, I_PIVR_L, 1481 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) 1482 & +KEEP(IXSZ), 1483 & IW, LIW) 1484 CALL SMUMPS_667(TYPEF_U, NBPANELS_U, 1485 & I_PIVRPTR_U, I_PIVR_U, 1486 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, 1487 & IW, LIW) 1488 ENDIF 1489 DO 460 IPIV=NPIVP1,NASS 1490 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) 1491 JMAX = 1 1492 AMROW = RZERO 1493 J1 = APOS 1494 J3 = NASS -NPIV 1495 JMAX = SMUMPS_IXAMAX(J3,A(J1),NFRONT) 1496 JJ = J1 + int(JMAX-1,8)*NFRONT8 1497 AMROW = abs(A(JJ)) 1498 RMAX = AMROW 1499 J1 = APOS + int(NASS-NPIV,8) * NFRONT8 1500 J3 = NFRONT - NASS - KEEP(253) 1501 IF (J3.EQ.0) GOTO 370 1502 DO 360 J=1,J3 1503 RMAX = max(abs(A(J1)),RMAX) 1504 J1 = J1 + NFRONT8 1505 360 CONTINUE 1506 370 IF (RMAX.EQ.RZERO) GO TO 460 1507 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 1508 IF (abs(A(IDIAG)).GE.max(UU*RMAX,SEUIL)) THEN 1509 JMAX = IPIV - NPIV 1510 GO TO 380 1511 ENDIF 1512 IF (AMROW.LT.max(UU*RMAX,SEUIL)) GO TO 460 1513 NOFFW = NOFFW + 1 1514 380 CONTINUE 1515 IF (KEEP(258) .NE. 0) THEN 1516 CALL SMUMPS_762( 1517 & A(APOS + int(JMAX - 1,8) * NFRONT8 ), 1518 & DKEEP(6), 1519 & KEEP(259) ) 1520 ENDIF 1521 IF (IPIV.EQ.NPIVP1) GO TO 400 1522 KEEP(260)=-KEEP(260) 1523 J1 = POSELT + int(NPIV,8) 1524 J3_8 = POSELT + int(IPIV-1,8) 1525 DO 390 J= 1,NFRONT 1526 SWOP = A(J1) 1527 A(J1) = A(J3_8) 1528 A(J3_8) = SWOP 1529 J1 = J1 + NFRONT8 1530 J3_8 = J3_8 + NFRONT8 1531 390 CONTINUE 1532 ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE 1533 ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE 1534 ISW = IW(ISWPS1) 1535 IW(ISWPS1) = IW(ISWPS2) 1536 IW(ISWPS2) = ISW 1537 400 IF (JMAX.EQ.1) GO TO 420 1538 KEEP(260)=-KEEP(260) 1539 J1 = POSELT + int(NPIV,8) * NFRONT8 1540 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 1541 DO 410 KSW=1,NFRONT 1542 SWOP = A(J1) 1543 A(J1) = A(J2) 1544 A(J2) = SWOP 1545 J1 = J1 + 1_8 1546 J2 = J2 + 1_8 1547 410 CONTINUE 1548 ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE 1549 ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE 1550 ISW = IW(ISWPS1) 1551 IW(ISWPS1) = IW(ISWPS2) 1552 IW(ISWPS2) = ISW 1553 GO TO 420 1554 460 CONTINUE 1555 INOPV = 1 1556 GOTO 430 1557 420 CONTINUE 1558 IF (KEEP(201).EQ.1) THEN 1559 IF (KEEP(251).EQ.0) THEN 1560 CALL SMUMPS_680( IW(I_PIVRPTR_L), 1561 & NBPANELS_L, 1562 & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, 1563 & PP_LastPanelonDisk_L, 1564 & PP_LastPIVRPTRFilled_L) 1565 ENDIF 1566 CALL SMUMPS_680( IW(I_PIVRPTR_U), 1567 & NBPANELS_U, 1568 & IW(I_PIVR_U), NASS, NPIVP1, IPIV, 1569 & PP_LastPanelonDisk_U, 1570 & PP_LastPIVRPTRFilled_U) 1571 ENDIF 1572 430 CONTINUE 1573 RETURN 1574 END SUBROUTINE SMUMPS_220 1575 SUBROUTINE SMUMPS_225(IBEG_BLOCK, 1576 & NFRONT,NASS,N,INODE,IW,LIW,A,LA, 1577 & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,XSIZE) 1578 IMPLICIT NONE 1579 INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB,IBEG_BLOCK 1580 INTEGER(8) :: LA 1581 REAL A(LA) 1582 INTEGER IW(LIW) 1583 REAL VALPIV 1584 INTEGER(8) :: APOS, POSELT, UUPOS, LPOS 1585 INTEGER(8) :: NFRONT8 1586 INTEGER IOLDPS 1587 INTEGER LKJIT, XSIZE 1588 REAL ONE, ALPHA 1589 INTEGER NPIV,JROW2 1590 INTEGER NEL2,NPIVP1,KROW,NEL 1591 INCLUDE 'mumps_headers.h' 1592 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 1593 NFRONT8= int(NFRONT,8) 1594 NPIV = IW(IOLDPS+1+XSIZE) 1595 NPIVP1 = NPIV + 1 1596 NEL = NFRONT - NPIVP1 1597 IFINB = 0 1598 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN 1599 IF (NASS.LT.LKJIT) THEN 1600 IW(IOLDPS+3+XSIZE) = NASS 1601 ELSE 1602 IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) 1603 ENDIF 1604 ENDIF 1605 JROW2 = IW(IOLDPS+3+XSIZE) 1606 NEL2 = JROW2 - NPIVP1 1607 IF (NEL2.EQ.0) THEN 1608 IF (JROW2.EQ.NASS) THEN 1609 IFINB = -1 1610 ELSE 1611 IFINB = 1 1612 IW(IOLDPS+3+XSIZE) = min0(JROW2+LKJIB,NASS) 1613 IBEG_BLOCK = NPIVP1+1 1614 ENDIF 1615 ELSE 1616 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) 1617 VALPIV = ONE/A(APOS) 1618 LPOS = APOS + NFRONT8 1619 DO 541 KROW = 1,NEL2 1620 A(LPOS) = A(LPOS)*VALPIV 1621 LPOS = LPOS + NFRONT8 1622 541 CONTINUE 1623 LPOS = APOS + NFRONT8 1624 UUPOS = APOS + 1_8 1625 CALL sger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, 1626 & A(LPOS+1_8),NFRONT) 1627 ENDIF 1628 RETURN 1629 END SUBROUTINE SMUMPS_225 1630 SUBROUTINE SMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA,IOLDPS, 1631 & POSELT,XSIZE) 1632 IMPLICIT NONE 1633 INTEGER NFRONT,N,INODE,LIW,XSIZE 1634 INTEGER(8) :: LA 1635 REAL A(LA) 1636 INTEGER IW(LIW) 1637 REAL ALPHA,VALPIV 1638 INTEGER(8) :: APOS, POSELT, UUPOS 1639 INTEGER(8) :: NFRONT8, LPOS, IRWPOS 1640 INTEGER IOLDPS,NPIV,NEL 1641 INTEGER JROW 1642 INCLUDE 'mumps_headers.h' 1643 REAL, PARAMETER :: ONE = 1.0E0 1644 NFRONT8= int(NFRONT,8) 1645 NPIV = IW(IOLDPS+1+XSIZE) 1646 NEL = NFRONT - NPIV - 1 1647 APOS = POSELT + int(NPIV,8) * NFRONT8 + int(NPIV,8) 1648 IF (NEL.EQ.0) GO TO 650 1649 VALPIV = ONE/A(APOS) 1650 LPOS = APOS + NFRONT8 1651 DO 340 JROW = 1,NEL 1652 A(LPOS) = VALPIV*A(LPOS) 1653 LPOS = LPOS + NFRONT8 1654 340 CONTINUE 1655 LPOS = APOS + NFRONT8 1656 UUPOS = APOS+1_8 1657 DO 440 JROW = 1,NEL 1658 IRWPOS = LPOS + 1_8 1659 ALPHA = -A(LPOS) 1660 CALL saxpy(NEL,ALPHA,A(UUPOS),1,A(IRWPOS),1) 1661 LPOS = LPOS + NFRONT8 1662 440 CONTINUE 1663 650 RETURN 1664 END SUBROUTINE SMUMPS_229 1665 SUBROUTINE SMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 1666 & IOLDPS,POSELT,IFINB,XSIZE) 1667 IMPLICIT NONE 1668 INCLUDE 'mumps_headers.h' 1669 INTEGER NFRONT,NASS,N,LIW,INODE,IFINB 1670 INTEGER(8) :: LA 1671 REAL A(LA) 1672 INTEGER IW(LIW) 1673 REAL ALPHA,VALPIV 1674 INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS 1675 INTEGER(8) :: NFRONT8 1676 INTEGER IOLDPS,NPIV,KROW, XSIZE 1677 INTEGER NEL,ICOL,NEL2 1678 INTEGER NPIVP1 1679 REAL, PARAMETER :: ONE = 1.0E0 1680 NFRONT8=int(NFRONT,8) 1681 NPIV = IW(IOLDPS+1+XSIZE) 1682 NPIVP1 = NPIV + 1 1683 NEL = NFRONT - NPIVP1 1684 NEL2 = NASS - NPIVP1 1685 IFINB = 0 1686 IF (NPIVP1.EQ.NASS) IFINB = 1 1687 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) 1688 VALPIV = ONE/A(APOS) 1689 LPOS = APOS + NFRONT8 1690 DO 541 KROW = 1,NEL 1691 A(LPOS) = A(LPOS)*VALPIV 1692 LPOS = LPOS + NFRONT8 1693 541 CONTINUE 1694 LPOS = APOS + NFRONT8 1695 UUPOS = APOS + 1_8 1696 DO 440 ICOL = 1,NEL 1697 IRWPOS = LPOS + 1_8 1698 ALPHA = -A(LPOS) 1699 CALL saxpy(NEL2,ALPHA,A(UUPOS),1,A(IRWPOS),1) 1700 LPOS = LPOS + NFRONT8 1701 440 CONTINUE 1702 RETURN 1703 END SUBROUTINE SMUMPS_228 1704 SUBROUTINE SMUMPS_231(A,LA,NFRONT, 1705 & NPIV,NASS,POSELT) 1706 IMPLICIT NONE 1707 INTEGER(8) :: LA,POSELT 1708 REAL A(LA) 1709 INTEGER NFRONT, NPIV, NASS 1710 INTEGER(8) :: LPOS, LPOS1, LPOS2 1711 INTEGER NEL1,NEL11 1712 REAL ALPHA, ONE 1713 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 1714 NEL1 = NFRONT - NASS 1715 NEL11 = NFRONT - NPIV 1716 LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) 1717 CALL strsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, 1718 & A(LPOS2),NFRONT) 1719 LPOS = LPOS2 + int(NPIV,8) 1720 LPOS1 = POSELT + int(NPIV,8) 1721 CALL sgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), 1722 & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) 1723 RETURN 1724 END SUBROUTINE SMUMPS_231 1725 SUBROUTINE SMUMPS_642(A,LAFAC,NFRONT, 1726 & NPIV,NASS, IW, LIWFAC, 1727 & MonBloc, TYPEFile, MYID, KEEP8, 1728 & STRAT, IFLAG_OOC, 1729 & LNextPiv2beWritten, UNextPiv2beWritten) 1730 USE SMUMPS_OOC 1731 IMPLICIT NONE 1732 INTEGER NFRONT, NPIV, NASS 1733 INTEGER(8) :: LAFAC 1734 INTEGER LIWFAC, TYPEFile, MYID, IFLAG_OOC, 1735 & LNextPiv2beWritten, UNextPiv2beWritten, STRAT 1736 REAL A(LAFAC) 1737 INTEGER IW(LIWFAC) 1738 INTEGER(8) KEEP8(150) 1739 TYPE(IO_BLOCK) :: MonBloc 1740 INTEGER(8) :: LPOS2,LPOS1,LPOS 1741 INTEGER NEL1,NEL11 1742 REAL ALPHA, ONE 1743 LOGICAL LAST_CALL 1744 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 1745 NEL1 = NFRONT - NASS 1746 NEL11 = NFRONT - NPIV 1747 LPOS2 = 1_8 + int(NASS,8) * int(NFRONT,8) 1748 CALL strsm('L','L','N','N',NPIV,NEL1,ONE,A(1),NFRONT, 1749 & A(LPOS2),NFRONT) 1750 LAST_CALL=.FALSE. 1751 CALL SMUMPS_688 1752 & ( STRAT, TYPEFile, 1753 & A, LAFAC, MonBloc, 1754 & LNextPiv2beWritten, UNextPiv2beWritten, 1755 & IW, LIWFAC, 1756 & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 1757 LPOS = LPOS2 + int(NPIV,8) 1758 LPOS1 = int(1 + NPIV,8) 1759 CALL sgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), 1760 & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) 1761 RETURN 1762 END SUBROUTINE SMUMPS_642 1763 SUBROUTINE SMUMPS_232(A,LA,NFRONT,NPIV,NASS,POSELT,LKJIB) 1764 INTEGER NFRONT, NPIV, NASS, LKJIB 1765 INTEGER (8) :: POSELT, LA 1766 REAL A(LA) 1767 INTEGER(8) :: POSELT_LOCAL, LPOS, LPOS1, LPOS2 1768 INTEGER NEL1, NEL11, NPBEG 1769 REAL ALPHA, ONE 1770 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 1771 POSELT_LOCAL = POSELT 1772 NEL1 = NASS - NPIV 1773 NPBEG = NPIV - LKJIB + 1 1774 NEL11 = NFRONT - NPIV 1775 LPOS2 = POSELT_LOCAL + int(NPIV,8)*int(NFRONT,8) 1776 & + int(NPBEG - 1,8) 1777 POSELT_LOCAL = POSELT_LOCAL + int(NPBEG-1,8)*int(NFRONT,8) 1778 & + int(NPBEG-1,8) 1779 CALL strsm('L','L','N','N',LKJIB,NEL1,ONE,A(POSELT_LOCAL), 1780 & NFRONT,A(LPOS2),NFRONT) 1781 LPOS = LPOS2 + int(LKJIB,8) 1782 LPOS1 = POSELT_LOCAL + int(LKJIB,8) 1783 CALL sgemm('N','N',NEL11,NEL1,LKJIB,ALPHA,A(LPOS1), 1784 & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) 1785 RETURN 1786 END SUBROUTINE SMUMPS_232 1787 SUBROUTINE SMUMPS_233(IBEG_BLOCK, 1788 & NFRONT,NASS,N,INODE,IW,LIW,A,LA, 1789 & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT,XSIZE ) 1790 IMPLICIT NONE 1791 INTEGER NFRONT, NASS,N,LIW 1792 INTEGER(8) :: LA 1793 REAL A(LA) 1794 INTEGER IW(LIW) 1795 INTEGER LKJIB_ORIG,LKJIB, INODE, IBEG_BLOCK 1796 INTEGER(8) :: POSELT, LPOS, LPOS1, LPOS2, POSLOCAL 1797 INTEGER(8) :: IPOS, KPOS 1798 INTEGER(8) :: NFRONT8 1799 INTEGER IOLDPS, NPIV, JROW2, NPBEG 1800 INTEGER NONEL, LKJIW, NEL1, NEL11 1801 INTEGER LBP, HF 1802 INTEGER LBPT,I1,K1,II,ISWOP,LBP1 1803 INTEGER LKJIT, XSIZE 1804 INCLUDE 'mumps_headers.h' 1805 REAL ALPHA, ONE 1806 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 1807 NFRONT8=int(NFRONT,8) 1808 NPIV = IW(IOLDPS+1+XSIZE) 1809 JROW2 = iabs(IW(IOLDPS+3+XSIZE)) 1810 NPBEG = IBEG_BLOCK 1811 HF = 6 + IW(IOLDPS+5+XSIZE) +XSIZE 1812 NONEL = JROW2 - NPIV + 1 1813 IF ((NASS-NPIV).GE.LKJIT) THEN 1814 LKJIB = LKJIB_ORIG + NONEL 1815 IW(IOLDPS+3+XSIZE)= min0(NPIV+LKJIB,NASS) 1816 ELSE 1817 IW(IOLDPS+3+XSIZE) = NASS 1818 ENDIF 1819 IBEG_BLOCK = NPIV + 1 1820 NEL1 = NASS - JROW2 1821 LKJIW = NPIV - NPBEG + 1 1822 NEL11 = NFRONT - NPIV 1823 IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN 1824 LPOS2 = POSELT + int(JROW2,8)*NFRONT8 + 1825 & int(NPBEG - 1,8) 1826 POSLOCAL = POSELT + int(NPBEG-1,8)*NFRONT8 + int(NPBEG - 1,8) 1827 CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, 1828 & A(POSLOCAL),NFRONT, 1829 & A(LPOS2),NFRONT) 1830 LPOS = LPOS2 + int(LKJIW,8) 1831 LPOS1 = POSLOCAL + int(LKJIW,8) 1832 CALL sgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), 1833 & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) 1834 ENDIF 1835 RETURN 1836 END SUBROUTINE SMUMPS_233 1837 SUBROUTINE SMUMPS_236(A,LA,NPIVB,NFRONT, 1838 & NPIV,NASS,POSELT) 1839 IMPLICIT NONE 1840 INTEGER NPIVB,NASS 1841 INTEGER(8) :: LA 1842 REAL A(LA) 1843 INTEGER(8) :: APOS, POSELT 1844 INTEGER NFRONT, NPIV, NASSL 1845 INTEGER(8) :: LPOS, LPOS1, LPOS2 1846 INTEGER NEL1, NEL11, NPIVE 1847 REAL ALPHA, ONE 1848 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 1849 NEL1 = NFRONT - NASS 1850 NEL11 = NFRONT - NPIV 1851 NPIVE = NPIV - NPIVB 1852 NASSL = NASS - NPIVB 1853 APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) 1854 & + int(NPIVB,8) 1855 LPOS2 = APOS + int(NASSL,8) 1856 CALL strsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, 1857 & A(LPOS2),NFRONT) 1858 LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) 1859 LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) 1860 CALL sgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), 1861 & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) 1862 RETURN 1863 END SUBROUTINE SMUMPS_236 1864 SUBROUTINE SMUMPS_217(N, NZ, NSCA, 1865 & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK, WK_REAL, 1866 & LWK_REAL, ICNTL, INFO) 1867 IMPLICIT NONE 1868 INTEGER N, NZ, NSCA 1869 INTEGER IRN(NZ), ICN(NZ) 1870 INTEGER ICNTL(40), INFO(40) 1871 REAL ASPK(NZ) 1872 REAL COLSCA(*), ROWSCA(*) 1873 INTEGER LWK, LWK_REAL 1874 REAL WK(LWK) 1875 REAL WK_REAL(LWK_REAL) 1876 INTEGER MPG,LP 1877 INTEGER IWNOR 1878 INTEGER I, K 1879 LOGICAL PROK 1880 REAL ONE 1881 PARAMETER( ONE = 1.0E0 ) 1882 LP = ICNTL(1) 1883 MPG = ICNTL(2) 1884 MPG = ICNTL(3) 1885 PROK = (MPG.GT.0) 1886 IF (PROK) WRITE(MPG,101) 1887 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) 1888 IF (NSCA.EQ.1) THEN 1889 IF (PROK) 1890 & WRITE (MPG,*) ' DIAGONAL SCALING ' 1891 ELSEIF (NSCA.EQ.2) THEN 1892 IF (PROK) 1893 & WRITE (MPG,*) ' SCALING BASED ON (MC29)' 1894 ELSEIF (NSCA.EQ.3) THEN 1895 IF (PROK) 1896 & WRITE (MPG,*) ' COLUMN SCALING' 1897 ELSEIF (NSCA.EQ.4) THEN 1898 IF (PROK) 1899 & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' 1900 ELSEIF (NSCA.EQ.5) THEN 1901 IF (PROK) 1902 & WRITE (MPG,*) ' MC29 FOLLOWED BY ROW &COL SCALING' 1903 ELSEIF (NSCA.EQ.6) THEN 1904 IF (PROK) 1905 & WRITE (MPG,*) ' MC29 FOLLOWED BY COLUMN SCALING' 1906 ENDIF 1907 DO 10 I=1,N 1908 COLSCA(I) = ONE 1909 ROWSCA(I) = ONE 1910 10 CONTINUE 1911 IF ((NSCA.EQ.5).OR. 1912 & (NSCA.EQ.6)) THEN 1913 IF (NZ.GT.LWK) GOTO 400 1914 DO 15 K=1,NZ 1915 WK(K) = ASPK(K) 1916 15 CONTINUE 1917 ENDIF 1918 IF (5*N.GT.LWK_REAL) GOTO 410 1919 IWNOR = 1 1920 IF (NSCA.EQ.1) THEN 1921 CALL SMUMPS_238(N,NZ,ASPK,IRN,ICN, 1922 & COLSCA,ROWSCA,MPG) 1923 ELSEIF (NSCA.EQ.2) THEN 1924 CALL SMUMPS_239(N,NZ,ASPK,IRN,ICN, 1925 & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) 1926 ELSEIF (NSCA.EQ.3) THEN 1927 CALL SMUMPS_241(N,NZ,ASPK,IRN,ICN,WK_REAL(IWNOR), 1928 & COLSCA, MPG) 1929 ELSEIF (NSCA.EQ.4) THEN 1930 CALL SMUMPS_287(N,NZ,IRN,ICN,ASPK, 1931 & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) 1932 ELSEIF (NSCA.EQ.5) THEN 1933 CALL SMUMPS_239(N,NZ,WK,IRN,ICN, 1934 & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) 1935 CALL SMUMPS_241(N,NZ,WK,IRN,ICN,WK_REAL(IWNOR), 1936 & COLSCA, MPG) 1937 ELSEIF (NSCA.EQ.6) THEN 1938 CALL SMUMPS_239(N,NZ,WK,IRN,ICN, 1939 & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) 1940 CALL SMUMPS_240(NSCA,N,NZ,IRN,ICN,WK, 1941 & WK_REAL(IWNOR+N),ROWSCA,MPG) 1942 CALL SMUMPS_241(N,NZ,WK,IRN,ICN, 1943 & WK_REAL(IWNOR), COLSCA, MPG) 1944 ENDIF 1945 GOTO 500 1946 400 INFO(1) = -5 1947 INFO(2) = NZ-LWK 1948 IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) 1949 & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' 1950 GOTO 500 1951 410 INFO(1) = -5 1952 INFO(2) = 5*N-LWK_REAL 1953 IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) 1954 & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' 1955 GOTO 500 1956 500 CONTINUE 1957 RETURN 1958 END SUBROUTINE SMUMPS_217 1959 SUBROUTINE SMUMPS_287(N,NZ,IRN,ICN,VAL, 1960 & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) 1961 INTEGER N, NZ 1962 REAL VAL(NZ) 1963 REAL RNOR(N),CNOR(N) 1964 REAL COLSCA(N),ROWSCA(N) 1965 REAL CMIN,CMAX,RMIN,ARNOR,ACNOR 1966 INTEGER IRN(NZ), ICN(NZ) 1967 REAL VDIAG 1968 INTEGER MPRINT 1969 INTEGER I,J,K 1970 REAL ZERO, ONE 1971 PARAMETER(ZERO=0.0E0, ONE=1.0E0) 1972 DO 50 J=1,N 1973 CNOR(J) = ZERO 1974 RNOR(J) = ZERO 1975 50 CONTINUE 1976 DO 100 K=1,NZ 1977 I = IRN(K) 1978 J = ICN(K) 1979 IF ((I.LE.0).OR.(I.GT.N).OR. 1980 & (J.LE.0).OR.(J.GT.N)) GOTO 100 1981 VDIAG = abs(VAL(K)) 1982 IF (VDIAG.GT.CNOR(J)) THEN 1983 CNOR(J) = VDIAG 1984 ENDIF 1985 IF (VDIAG.GT.RNOR(I)) THEN 1986 RNOR(I) = VDIAG 1987 ENDIF 1988 100 CONTINUE 1989 IF (MPRINT.GT.0) THEN 1990 CMIN = CNOR(1) 1991 CMAX = CNOR(1) 1992 RMIN = RNOR(1) 1993 DO 111 I=1,N 1994 ARNOR = RNOR(I) 1995 ACNOR = CNOR(I) 1996 IF (ACNOR.GT.CMAX) CMAX=ACNOR 1997 IF (ACNOR.LT.CMIN) CMIN=ACNOR 1998 IF (ARNOR.LT.RMIN) RMIN=ARNOR 1999 111 CONTINUE 2000 WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' 2001 WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX 2002 WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN 2003 WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN 2004 ENDIF 2005 DO 120 J=1,N 2006 IF (CNOR(J).LE.ZERO) THEN 2007 CNOR(J) = ONE 2008 ELSE 2009 CNOR(J) = ONE / CNOR(J) 2010 ENDIF 2011 120 CONTINUE 2012 DO 130 J=1,N 2013 IF (RNOR(J).LE.ZERO) THEN 2014 RNOR(J) = ONE 2015 ELSE 2016 RNOR(J) = ONE / RNOR(J) 2017 ENDIF 2018 130 CONTINUE 2019 DO 110 I=1,N 2020 ROWSCA(I) = ROWSCA(I) * RNOR(I) 2021 COLSCA(I) = COLSCA(I) * CNOR(I) 2022 110 CONTINUE 2023 IF (MPRINT.GT.0) 2024 & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' 2025 RETURN 2026 END SUBROUTINE SMUMPS_287 2027 SUBROUTINE SMUMPS_239(N,NZ,VAL,ROWIND,COLIND, 2028 & RNOR,CNOR,WNOR,MPRINT,MP, 2029 & NSCA) 2030 INTEGER N, NZ 2031 REAL VAL(NZ) 2032 REAL WNOR(5*N) 2033 REAL RNOR(N), CNOR(N) 2034 INTEGER COLIND(NZ),ROWIND(NZ) 2035 INTEGER J,I,K 2036 INTEGER MPRINT,MP,NSCA 2037 INTEGER IFAIL9 2038 REAL ZERO 2039 PARAMETER( ZERO = 0.0E0) 2040 DO 15 I=1,N 2041 RNOR(I) = ZERO 2042 CNOR(I) = ZERO 2043 15 CONTINUE 2044 CALL SMUMPS_216(N,N,NZ,VAL,ROWIND,COLIND, 2045 & RNOR,CNOR,WNOR, MP,IFAIL9) 2046*CVD$ NODEPCHK 2047*CVD$ VECTOR 2048*CVD$ CONCUR 2049 DO 30 I=1,N 2050 CNOR(I) = exp(CNOR(I)) 2051 RNOR(I) = exp(RNOR(I)) 2052 30 CONTINUE 2053 IF ((NSCA.EQ.5).OR.(NSCA.EQ.6)) THEN 2054 DO 100 K=1,NZ 2055 I = ROWIND(K) 2056 J = COLIND(K) 2057 IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 100 2058 VAL(K) = VAL(K) * CNOR(J) * RNOR(I) 2059 100 CONTINUE 2060 ENDIF 2061 IF (MPRINT.GT.0) 2062 & WRITE(MPRINT,*) ' END OF SCALING USING MC29' 2063 RETURN 2064 END SUBROUTINE SMUMPS_239 2065 SUBROUTINE SMUMPS_241(N,NZ,VAL,IRN,ICN, 2066 & CNOR,COLSCA,MPRINT) 2067 INTEGER N,NZ 2068 REAL VAL(NZ) 2069 REAL CNOR(N) 2070 REAL COLSCA(N) 2071 INTEGER IRN(NZ), ICN(NZ) 2072 REAL VDIAG 2073 INTEGER MPRINT 2074 INTEGER I,J,K 2075 REAL ZERO, ONE 2076 PARAMETER (ZERO=0.0E0,ONE=1.0E0) 2077 DO 10 J=1,N 2078 CNOR(J) = ZERO 2079 10 CONTINUE 2080 DO 100 K=1,NZ 2081 I = IRN(K) 2082 J = ICN(K) 2083 IF ((I.LE.0).OR.(I.GT.N).OR. 2084 & (J.LE.0).OR.(J.GT.N)) GOTO 100 2085 VDIAG = abs(VAL(K)) 2086 IF (VDIAG.GT.CNOR(J)) THEN 2087 CNOR(J) = VDIAG 2088 ENDIF 2089 100 CONTINUE 2090 DO 110 J=1,N 2091 IF (CNOR(J).LE.ZERO) THEN 2092 CNOR(J) = ONE 2093 ELSE 2094 CNOR(J) = ONE/CNOR(J) 2095 ENDIF 2096 110 CONTINUE 2097 DO 215 I=1,N 2098 COLSCA(I) = COLSCA(I) * CNOR(I) 2099 215 CONTINUE 2100 IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' 2101 RETURN 2102 END SUBROUTINE SMUMPS_241 2103 SUBROUTINE SMUMPS_238(N,NZ,VAL,IRN,ICN, 2104 & COLSCA,ROWSCA,MPRINT) 2105 INTEGER N, NZ 2106 REAL VAL(NZ) 2107 REAL ROWSCA(N),COLSCA(N) 2108 INTEGER IRN(NZ),ICN(NZ) 2109 REAL VDIAG 2110 INTEGER MPRINT,I,J,K 2111 INTRINSIC sqrt 2112 REAL ZERO, ONE 2113 PARAMETER(ZERO=0.0E0, ONE=1.0E0) 2114 DO 10 I=1,N 2115 ROWSCA(I) = ONE 2116 10 CONTINUE 2117 DO 100 K=1,NZ 2118 I = IRN(K) 2119 IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 2120 J = ICN(K) 2121 IF (I.EQ.J) THEN 2122 VDIAG = abs(VAL(K)) 2123 IF (VDIAG.GT.ZERO) THEN 2124 ROWSCA(J) = ONE/(sqrt(VDIAG)) 2125 ENDIF 2126 ENDIF 2127 100 CONTINUE 2128 DO 110 I=1,N 2129 COLSCA(I) = ROWSCA(I) 2130 110 CONTINUE 2131 IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' 2132 RETURN 2133 END SUBROUTINE SMUMPS_238 2134 SUBROUTINE SMUMPS_240(NSCA,N,NZ,IRN,ICN,VAL, 2135 & RNOR,ROWSCA,MPRINT) 2136 INTEGER N, NZ, NSCA 2137 INTEGER IRN(NZ), ICN(NZ) 2138 REAL VAL(NZ) 2139 REAL RNOR(N) 2140 REAL ROWSCA(N) 2141 REAL VDIAG 2142 INTEGER MPRINT 2143 INTEGER I,J,K 2144 REAL ZERO,ONE 2145 PARAMETER (ZERO=0.0E0, ONE=1.0E0) 2146 DO 50 J=1,N 2147 RNOR(J) = ZERO 2148 50 CONTINUE 2149 DO 100 K=1,NZ 2150 I = IRN(K) 2151 J = ICN(K) 2152 IF ((I.LE.0).OR.(I.GT.N).OR. 2153 & (J.LE.0).OR.(J.GT.N)) GOTO 100 2154 VDIAG = abs(VAL(K)) 2155 IF (VDIAG.GT.RNOR(I)) THEN 2156 RNOR(I) = VDIAG 2157 ENDIF 2158 100 CONTINUE 2159 DO 130 J=1,N 2160 IF (RNOR(J).LE.ZERO) THEN 2161 RNOR(J) = ONE 2162 ELSE 2163 RNOR(J) = ONE/RNOR(J) 2164 ENDIF 2165 130 CONTINUE 2166 DO 110 I=1,N 2167 ROWSCA(I) = ROWSCA(I)* RNOR(I) 2168 110 CONTINUE 2169 IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN 2170 DO 150 K=1,NZ 2171 I = IRN(K) 2172 J = ICN(K) 2173 IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 2174 VAL(K) = VAL(K) * RNOR(I) 2175 150 CONTINUE 2176 ENDIF 2177 IF (MPRINT.GT.0) 2178 & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' 2179 RETURN 2180 END SUBROUTINE SMUMPS_240 2181 SUBROUTINE SMUMPS_216(M,N,NE,A,IRN,ICN,R,C,W,LP,IFAIL) 2182 INTEGER M,N,NE 2183 REAL A(NE) 2184 INTEGER IRN(NE),ICN(NE) 2185 REAL R(M),C(N) 2186 REAL W(M*2+N*3) 2187 INTEGER LP,IFAIL 2188 INTRINSIC log,abs,min 2189 INTEGER MAXIT 2190 PARAMETER (MAXIT=100) 2191 REAL ONE 2192 REAL SMIN,ZERO 2193 PARAMETER (ONE=1.0E0,SMIN=0.1E0,ZERO=0.0E0) 2194 INTEGER I,I1,I2,I3,I4,I5,ITER,J,K 2195 REAL E,E1,EM,Q,Q1,QM,S,S1,SM,U,V 2196 IFAIL = 0 2197 IF (M.LT.1 .OR. N.LT.1) THEN 2198 IFAIL = -1 2199 GO TO 220 2200 ELSE IF (NE.LE.0) THEN 2201 IFAIL = -2 2202 GO TO 220 2203 END IF 2204 I1 = 0 2205 I2 = M 2206 I3 = M + N 2207 I4 = M + N*2 2208 I5 = M + N*3 2209 DO 10 I = 1,M 2210 R(I) = ZERO 2211 W(I1+I) = ZERO 2212 10 CONTINUE 2213 DO 20 J = 1,N 2214 C(J) = ZERO 2215 W(I2+J) = ZERO 2216 W(I3+J) = ZERO 2217 W(I4+J) = ZERO 2218 20 CONTINUE 2219 DO 30 K = 1,NE 2220 U = abs(A(K)) 2221 IF (U.EQ.ZERO) GO TO 30 2222 I = IRN(K) 2223 J = ICN(K) 2224 IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 30 2225 U = log(U) 2226 W(I1+I) = W(I1+I) + ONE 2227 W(I2+J) = W(I2+J) + ONE 2228 R(I) = R(I) + U 2229 W(I3+J) = W(I3+J) + U 2230 30 CONTINUE 2231 DO 40 I = 1,M 2232 IF (W(I1+I).EQ.ZERO) W(I1+I) = ONE 2233 R(I) = R(I)/W(I1+I) 2234 W(I5+I) = R(I) 2235 40 CONTINUE 2236 DO 50 J = 1,N 2237 IF (W(I2+J).EQ.ZERO) W(I2+J) = ONE 2238 W(I3+J) = W(I3+J)/W(I2+J) 2239 50 CONTINUE 2240 SM = SMIN*real(NE) 2241 DO 60 K = 1,NE 2242 IF (abs(A(K)).EQ.ZERO) GO TO 60 2243 I = IRN(K) 2244 J = ICN(K) 2245 IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 60 2246 R(I) = R(I) - W(I3+J)/W(I1+I) 2247 60 CONTINUE 2248 E = ZERO 2249 Q = ONE 2250 S = ZERO 2251 DO 70 I = 1,M 2252 S = S + W(I1+I)*R(I)**2 2253 70 CONTINUE 2254 IF (abs(S).LE.abs(SM)) GO TO 160 2255 DO 150 ITER = 1,MAXIT 2256 DO 80 K = 1,NE 2257 IF (abs(A(K)).EQ.ZERO) GO TO 80 2258 J = ICN(K) 2259 I = IRN(K) 2260 IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 80 2261 C(J) = C(J) + R(I) 2262 80 CONTINUE 2263 S1 = S 2264 S = ZERO 2265 DO 90 J = 1,N 2266 V = -C(J)/Q 2267 C(J) = V/W(I2+J) 2268 S = S + V*C(J) 2269 90 CONTINUE 2270 E1 = E 2271 E = Q*S/S1 2272 Q = ONE - E 2273 IF (abs(S).LE.abs(SM)) E = ZERO 2274 DO 100 I = 1,M 2275 R(I) = R(I)*E*W(I1+I) 2276 100 CONTINUE 2277 IF (abs(S).LE.abs(SM)) GO TO 180 2278 EM = E*E1 2279 DO 110 K = 1,NE 2280 IF (abs(A(K)).EQ.ZERO) GO TO 110 2281 I = IRN(K) 2282 J = ICN(K) 2283 IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 110 2284 R(I) = R(I) + C(J) 2285 110 CONTINUE 2286 S1 = S 2287 S = ZERO 2288 DO 120 I = 1,M 2289 V = -R(I)/Q 2290 R(I) = V/W(I1+I) 2291 S = S + V*R(I) 2292 120 CONTINUE 2293 E1 = E 2294 E = Q*S/S1 2295 Q1 = Q 2296 Q = ONE - E 2297 IF (abs(S).LE.abs(SM)) Q = ONE 2298 QM = Q*Q1 2299 DO 130 J = 1,N 2300 W(I4+J) = (EM*W(I4+J)+C(J))/QM 2301 W(I3+J) = W(I3+J) + W(I4+J) 2302 130 CONTINUE 2303 IF (abs(S).LE.abs(SM)) GO TO 160 2304 DO 140 J = 1,N 2305 C(J) = C(J)*E*W(I2+J) 2306 140 CONTINUE 2307 150 CONTINUE 2308 160 DO 170 I = 1,M 2309 R(I) = R(I)*W(I1+I) 2310 170 CONTINUE 2311 180 DO 190 K = 1,NE 2312 IF (abs(A(K)).EQ.ZERO) GO TO 190 2313 I = IRN(K) 2314 J = ICN(K) 2315 IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 190 2316 R(I) = R(I) + W(I3+J) 2317 190 CONTINUE 2318 DO 200 I = 1,M 2319 R(I) = R(I)/W(I1+I) - W(I5+I) 2320 200 CONTINUE 2321 DO 210 J = 1,N 2322 C(J) = -W(I3+J) 2323 210 CONTINUE 2324 RETURN 2325 220 IF (LP.GT.0) WRITE (LP,'(/A/A,I3)') 2326 & ' **** Error return from SMUMPS_216 ****',' IFAIL =',IFAIL 2327 END SUBROUTINE SMUMPS_216 2328 SUBROUTINE SMUMPS_27( id, ANORMINF, LSCAL ) 2329 USE SMUMPS_STRUC_DEF 2330 IMPLICIT NONE 2331 INCLUDE 'mpif.h' 2332 INTEGER MASTER, IERR 2333 PARAMETER( MASTER = 0 ) 2334 TYPE(SMUMPS_STRUC), TARGET :: id 2335 REAL, INTENT(OUT) :: ANORMINF 2336 LOGICAL :: LSCAL 2337 INTEGER, DIMENSION (:), POINTER :: KEEP,INFO 2338 INTEGER(8), DIMENSION (:), POINTER :: KEEP8 2339 LOGICAL :: I_AM_SLAVE 2340 REAL DUMMY(1) 2341 REAL ZERO 2342 PARAMETER( ZERO = 0.0E0) 2343 REAL, ALLOCATABLE :: SUMR(:), SUMR_LOC(:) 2344 INTEGER :: allocok, MTYPE, I 2345 INFO =>id%INFO 2346 KEEP =>id%KEEP 2347 KEEP8 =>id%KEEP8 2348 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. 2349 & ( id%MYID .eq. MASTER .AND. 2350 & KEEP(46) .eq. 1 ) ) 2351 IF (id%MYID .EQ. MASTER) THEN 2352 ALLOCATE( SUMR( id%N ), stat =allocok ) 2353 IF (allocok .GT.0 ) THEN 2354 id%INFO(1)=-13 2355 id%INFO(2)=id%N 2356 RETURN 2357 ENDIF 2358 ENDIF 2359 IF ( KEEP(54) .eq. 0 ) THEN 2360 IF (id%MYID .EQ. MASTER) THEN 2361 IF (KEEP(55).EQ.0) THEN 2362 IF (.NOT.LSCAL) THEN 2363 CALL SMUMPS_207(id%A(1), 2364 & id%NZ, id%N, 2365 & id%IRN(1), id%JCN(1), 2366 & SUMR, KEEP(1),KEEP8(1) ) 2367 ELSE 2368 CALL SMUMPS_289(id%A(1), 2369 & id%NZ, id%N, 2370 & id%IRN(1), id%JCN(1), 2371 & SUMR, KEEP(1), KEEP8(1), 2372 & id%COLSCA(1)) 2373 ENDIF 2374 ELSE 2375 MTYPE = 1 2376 IF (.NOT.LSCAL) THEN 2377 CALL SMUMPS_119(MTYPE, id%N, 2378 & id%NELT, id%ELTPTR(1), 2379 & id%LELTVAR, id%ELTVAR(1), 2380 & id%NA_ELT, id%A_ELT(1), 2381 & SUMR, KEEP(1),KEEP8(1) ) 2382 ELSE 2383 CALL SMUMPS_135(MTYPE, id%N, 2384 & id%NELT, id%ELTPTR(1), 2385 & id%LELTVAR, id%ELTVAR(1), 2386 & id%NA_ELT, id%A_ELT(1), 2387 & SUMR, KEEP(1),KEEP8(1), id%COLSCA(1)) 2388 ENDIF 2389 ENDIF 2390 ENDIF 2391 ELSE 2392 ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) 2393 IF (allocok .GT.0 ) THEN 2394 id%INFO(1)=-13 2395 id%INFO(2)=id%N 2396 RETURN 2397 ENDIF 2398 IF ( I_AM_SLAVE .and. 2399 & id%NZ_loc .NE. 0 ) THEN 2400 IF (.NOT.LSCAL) THEN 2401 CALL SMUMPS_207(id%A_loc(1), 2402 & id%NZ_loc, id%N, 2403 & id%IRN_loc(1), id%JCN_loc(1), 2404 & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) 2405 ELSE 2406 CALL SMUMPS_289(id%A_loc(1), 2407 & id%NZ_loc, id%N, 2408 & id%IRN_loc(1), id%JCN_loc(1), 2409 & SUMR_LOC, id%KEEP(1),id%KEEP8(1), 2410 & id%COLSCA(1)) 2411 ENDIF 2412 ELSE 2413 SUMR_LOC = ZERO 2414 ENDIF 2415 IF ( id%MYID .eq. MASTER ) THEN 2416 CALL MPI_REDUCE( SUMR_LOC, SUMR, 2417 & id%N, MPI_REAL, 2418 & MPI_SUM,MASTER,id%COMM, IERR) 2419 ELSE 2420 CALL MPI_REDUCE( SUMR_LOC, DUMMY, 2421 & id%N, MPI_REAL, 2422 & MPI_SUM,MASTER,id%COMM, IERR) 2423 END IF 2424 DEALLOCATE (SUMR_LOC) 2425 ENDIF 2426 IF ( id%MYID .eq. MASTER ) THEN 2427 ANORMINF = real(ZERO) 2428 IF (LSCAL) THEN 2429 DO I = 1, id%N 2430 ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), 2431 & ANORMINF) 2432 ENDDO 2433 ELSE 2434 DO I = 1, id%N 2435 ANORMINF = max(abs(SUMR(I)), 2436 & ANORMINF) 2437 ENDDO 2438 ENDIF 2439 ENDIF 2440 CALL MPI_BCAST(ANORMINF, 1, 2441 & MPI_REAL, MASTER, 2442 & id%COMM, IERR ) 2443 IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) 2444 RETURN 2445 END SUBROUTINE SMUMPS_27 2446 SUBROUTINE SMUMPS_693(IRN_loc, JCN_loc, A_loc, NZ_loc, 2447 & M, N, NUMPROCS, MYID, COMM, 2448 & RPARTVEC, CPARTVEC, 2449 & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, 2450 & IWRK, IWRKSZ, 2451 & INTSZ, RESZ, OP, 2452 & ROWSCA, COLSCA, WRKRC, ISZWRKRC, 2453 & SYM, NB1, NB2, NB3, EPS, 2454 & ONENORMERR,INFNORMERR) 2455 IMPLICIT NONE 2456 INCLUDE 'mpif.h' 2457 INTEGER NZ_loc, M, N, IWRKSZ, OP 2458 INTEGER NUMPROCS, MYID, COMM 2459 INTEGER INTSZ, RESZ 2460 INTEGER IRN_loc(NZ_loc) 2461 INTEGER JCN_loc(NZ_loc) 2462 REAL A_loc(NZ_loc) 2463 INTEGER RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) 2464 INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) 2465 INTEGER IWRK(IWRKSZ) 2466 INTEGER REGISTRE(12) 2467 REAL ROWSCA(M) 2468 REAL COLSCA(N) 2469 INTEGER ISZWRKRC 2470 REAL WRKRC(ISZWRKRC) 2471 REAL ONENORMERR,INFNORMERR 2472 INTEGER SYM, NB1, NB2, NB3 2473 REAL EPS 2474 EXTERNAL SMUMPS_694,SMUMPS_687, 2475 & SMUMPS_670 2476 INTEGER I 2477 IF(SYM.EQ.0) THEN 2478 CALL SMUMPS_694(IRN_loc, JCN_loc, A_loc, NZ_loc, 2479 & M, N, NUMPROCS, MYID, COMM, 2480 & RPARTVEC, CPARTVEC, 2481 & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, 2482 & IWRK, IWRKSZ, 2483 & INTSZ, RESZ, OP, 2484 & ROWSCA, COLSCA, WRKRC, ISZWRKRC, 2485 & NB1, NB2, NB3, EPS, 2486 & ONENORMERR, INFNORMERR) 2487 ELSE 2488 CALL SMUMPS_687(IRN_loc, JCN_loc, A_loc, NZ_loc, 2489 & N, NUMPROCS, MYID, COMM, 2490 & RPARTVEC, 2491 & RSNDRCVSZ, REGISTRE, 2492 & IWRK, IWRKSZ, 2493 & INTSZ, RESZ, OP, 2494 & ROWSCA, WRKRC, ISZWRKRC, 2495 & NB1, NB2, NB3, EPS, 2496 & ONENORMERR, INFNORMERR) 2497 DO I=1,N 2498 COLSCA(I) = ROWSCA(I) 2499 ENDDO 2500 ENDIF 2501 RETURN 2502 END SUBROUTINE SMUMPS_693 2503 SUBROUTINE SMUMPS_694(IRN_loc, JCN_loc, A_loc, NZ_loc, 2504 & M, N, NUMPROCS, MYID, COMM, 2505 & RPARTVEC, CPARTVEC, 2506 & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, 2507 & IWRK, IWRKSZ, 2508 & INTSZ, RESZ, OP, 2509 & ROWSCA, COLSCA, WRKRC, ISZWRKRC, 2510 & NB1, NB2, NB3, EPS, 2511 & ONENORMERR, INFNORMERR) 2512 IMPLICIT NONE 2513 INCLUDE 'mpif.h' 2514 INTEGER NZ_loc, M, N, IWRKSZ, OP 2515 INTEGER NUMPROCS, MYID, COMM 2516 INTEGER INTSZ, RESZ 2517 INTEGER IRN_loc(NZ_loc) 2518 INTEGER JCN_loc(NZ_loc) 2519 REAL A_loc(NZ_loc) 2520 INTEGER RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) 2521 INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) 2522 INTEGER IWRK(IWRKSZ) 2523 INTEGER REGISTRE(12) 2524 REAL ROWSCA(M) 2525 REAL COLSCA(N) 2526 INTEGER ISZWRKRC 2527 REAL WRKRC(ISZWRKRC) 2528 REAL ONENORMERR,INFNORMERR 2529 INTEGER IRSNDRCVNUM, ORSNDRCVNUM 2530 INTEGER IRSNDRCVVOL, ORSNDRCVVOL 2531 INTEGER ICSNDRCVNUM, OCSNDRCVNUM 2532 INTEGER ICSNDRCVVOL, OCSNDRCVVOL 2533 INTEGER INUMMYR, INUMMYC 2534 INTEGER IMYRPTR,IMYCPTR 2535 INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA 2536 INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA 2537 INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA 2538 INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA 2539 INTEGER ISTATUS, REQUESTS, TMPWORK 2540 INTEGER ITDRPTR, ITDCPTR, ISRRPTR 2541 INTEGER OSRRPTR, ISRCPTR, OSRCPTR 2542 INTEGER NB1, NB2, NB3 2543 REAL EPS 2544 INTEGER ITER, NZIND, IR, IC 2545 REAL ELM 2546 INTEGER TAG_COMM_COL 2547 PARAMETER(TAG_COMM_COL=100) 2548 INTEGER TAG_COMM_ROW 2549 PARAMETER(TAG_COMM_ROW=101) 2550 INTEGER TAG_ITERS 2551 PARAMETER(TAG_ITERS=102) 2552 EXTERNAL SMUMPS_654, 2553 & SMUMPS_672, 2554 & SMUMPS_674, 2555 & SMUMPS_662, 2556 & SMUMPS_743, 2557 & SMUMPS_745, 2558 & SMUMPS_660, 2559 & SMUMPS_670, 2560 & SMUMPS_671, 2561 & SMUMPS_657, 2562 & SMUMPS_656 2563 INTEGER SMUMPS_743 2564 INTEGER SMUMPS_745 2565 REAL SMUMPS_737 2566 REAL SMUMPS_738 2567 INTRINSIC abs 2568 REAL RONE, RZERO 2569 PARAMETER(RONE=1.0E0,RZERO=0.0E0) 2570 INTEGER RESZR, RESZC 2571 INTEGER INTSZR, INTSZC 2572 INTEGER MAXMN 2573 INTEGER I, IERROR 2574 REAL ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG 2575 REAL INFERRROW, INFERRCOL, INFERRL, INFERRG 2576 INTEGER OORANGEIND 2577 INFERRG = -RONE 2578 ONEERRG = -RONE 2579 OORANGEIND = 0 2580 MAXMN = M 2581 IF(MAXMN < N) MAXMN = N 2582 IF(OP == 1) THEN 2583 IF(NUMPROCS > 1) THEN 2584 CALL SMUMPS_654(MYID, NUMPROCS, COMM, 2585 & IRN_loc, JCN_loc, NZ_loc, 2586 & RPARTVEC, M, N, 2587 & IWRK, IWRKSZ) 2588 CALL SMUMPS_654(MYID, NUMPROCS, COMM, 2589 & JCN_loc, IRN_loc, NZ_loc, 2590 & CPARTVEC, N, M, 2591 & IWRK, IWRKSZ) 2592 CALL SMUMPS_672(MYID, NUMPROCS, M, RPARTVEC, 2593 & NZ_loc, IRN_loc, N, JCN_loc, 2594 & IRSNDRCVNUM,IRSNDRCVVOL, 2595 & ORSNDRCVNUM,ORSNDRCVVOL, 2596 & IWRK,IWRKSZ, 2597 & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) 2598 CALL SMUMPS_672(MYID, NUMPROCS, N, CPARTVEC, 2599 & NZ_loc, JCN_loc, M, IRN_loc, 2600 & ICSNDRCVNUM,ICSNDRCVVOL, 2601 & OCSNDRCVNUM,OCSNDRCVVOL, 2602 & IWRK,IWRKSZ, 2603 & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) 2604 CALL SMUMPS_662(MYID, NUMPROCS, COMM, 2605 & IRN_loc, JCN_loc, NZ_loc, 2606 & RPARTVEC, CPARTVEC, M, N, 2607 & INUMMYR, 2608 & INUMMYC, 2609 & IWRK, IWRKSZ) 2610 INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + 2611 & IRSNDRCVVOL + ORSNDRCVVOL + 2612 & 2*(NUMPROCS+1) + INUMMYR 2613 INTSZC = ICSNDRCVNUM + OCSNDRCVNUM + 2614 & ICSNDRCVVOL + OCSNDRCVVOL + 2615 & 2*(NUMPROCS+1) + INUMMYC 2616 INTSZ = INTSZR + INTSZC + MAXMN + 2617 & (MPI_STATUS_SIZE +1) * NUMPROCS 2618 ELSE 2619 IRSNDRCVNUM = 0 2620 ORSNDRCVNUM = 0 2621 IRSNDRCVVOL = 0 2622 ORSNDRCVVOL = 0 2623 INUMMYR = 0 2624 ICSNDRCVNUM = 0 2625 OCSNDRCVNUM = 0 2626 ICSNDRCVVOL = 0 2627 OCSNDRCVVOL = 0 2628 INUMMYC = 0 2629 INTSZ = 0 2630 ENDIF 2631 RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL 2632 RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL 2633 RESZ = RESZR + RESZC 2634 REGISTRE(1) = IRSNDRCVNUM 2635 REGISTRE(2) = ORSNDRCVNUM 2636 REGISTRE(3) = IRSNDRCVVOL 2637 REGISTRE(4) = ORSNDRCVVOL 2638 REGISTRE(5) = ICSNDRCVNUM 2639 REGISTRE(6) = OCSNDRCVNUM 2640 REGISTRE(7) = ICSNDRCVVOL 2641 REGISTRE(8) = OCSNDRCVVOL 2642 REGISTRE(9) = INUMMYR 2643 REGISTRE(10) = INUMMYC 2644 REGISTRE(11) = INTSZ 2645 REGISTRE(12) = RESZ 2646 ELSE 2647 IRSNDRCVNUM = REGISTRE(1) 2648 ORSNDRCVNUM = REGISTRE(2) 2649 IRSNDRCVVOL = REGISTRE(3) 2650 ORSNDRCVVOL = REGISTRE(4) 2651 ICSNDRCVNUM = REGISTRE(5) 2652 OCSNDRCVNUM = REGISTRE(6) 2653 ICSNDRCVVOL = REGISTRE(7) 2654 OCSNDRCVVOL = REGISTRE(8) 2655 INUMMYR = REGISTRE(9) 2656 INUMMYC = REGISTRE(10) 2657 IF(NUMPROCS > 1) THEN 2658 CALL SMUMPS_660(MYID, NUMPROCS,COMM, 2659 & IRN_loc, JCN_loc, NZ_loc, 2660 & RPARTVEC, CPARTVEC, M, N, 2661 & IWRK(1), INUMMYR, 2662 & IWRK(1+INUMMYR), INUMMYC, 2663 & IWRK(1+INUMMYR+INUMMYC), IWRKSZ-INUMMYR-INUMMYC ) 2664 IMYRPTR = 1 2665 IMYCPTR = IMYRPTR + INUMMYR 2666 IRNGHBPRCS = IMYCPTR+ INUMMYC 2667 IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM 2668 IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 2669 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL 2670 ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM 2671 ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 2672 ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL 2673 ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM 2674 ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 2675 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL 2676 OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM 2677 OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 2678 REQUESTS = OCSNDRCVJA + OCSNDRCVVOL 2679 ISTATUS = REQUESTS + NUMPROCS 2680 TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS 2681 CALL SMUMPS_674(MYID, NUMPROCS, M, RPARTVEC, 2682 & NZ_loc, IRN_loc,N, JCN_loc, 2683 & IRSNDRCVNUM, IRSNDRCVVOL, 2684 & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), 2685 & ORSNDRCVNUM, ORSNDRCVVOL, 2686 & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), 2687 & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), 2688 & IWRK(TMPWORK), 2689 & IWRK(ISTATUS), IWRK(REQUESTS), 2690 & TAG_COMM_ROW, COMM) 2691 CALL SMUMPS_674(MYID, NUMPROCS, N, CPARTVEC, 2692 & NZ_loc, JCN_loc, M, IRN_loc, 2693 & ICSNDRCVNUM, ICSNDRCVVOL, 2694 & IWRK(ICNGHBPRCS), 2695 & IWRK(ICSNDRCVIA), 2696 & IWRK(ICSNDRCVJA), 2697 & OCSNDRCVNUM, OCSNDRCVVOL, 2698 & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), 2699 & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), 2700 & IWRK(TMPWORK), 2701 & IWRK(ISTATUS), IWRK(REQUESTS), 2702 & TAG_COMM_COL, COMM) 2703 CALL SMUMPS_670(ROWSCA, M, RZERO) 2704 CALL SMUMPS_670(COLSCA, N, RZERO) 2705 CALL SMUMPS_671(ROWSCA, M, 2706 & IWRK(IMYRPTR),INUMMYR, RONE) 2707 CALL SMUMPS_671(COLSCA, N, 2708 & IWRK(IMYCPTR),INUMMYC, RONE) 2709 ELSE 2710 CALL SMUMPS_670(ROWSCA, M, RONE) 2711 CALL SMUMPS_670(COLSCA, N, RONE) 2712 ENDIF 2713 ITDRPTR = 1 2714 ITDCPTR = ITDRPTR + M 2715 ISRRPTR = ITDCPTR + N 2716 OSRRPTR = ISRRPTR + IRSNDRCVVOL 2717 ISRCPTR = OSRRPTR + ORSNDRCVVOL 2718 OSRCPTR = ISRCPTR + ICSNDRCVVOL 2719 IF(NUMPROCS == 1)THEN 2720 OSRCPTR = OSRCPTR - 1 2721 ISRCPTR = ISRCPTR - 1 2722 OSRRPTR = OSRRPTR - 1 2723 ISRRPTR = ISRRPTR - 1 2724 ELSE 2725 IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 2726 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 2727 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 2728 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 2729 ENDIF 2730 ITER = 1 2731 DO WHILE (ITER.LE.NB1+NB2+NB3) 2732 IF(NUMPROCS > 1) THEN 2733 CALL SMUMPS_650(WRKRC(ITDRPTR),M, 2734 & IWRK(IMYRPTR),INUMMYR) 2735 CALL SMUMPS_650(WRKRC(ITDCPTR),N, 2736 & IWRK(IMYCPTR),INUMMYC) 2737 ELSE 2738 CALL SMUMPS_670(WRKRC(ITDRPTR),M, RZERO) 2739 CALL SMUMPS_670(WRKRC(ITDCPTR),N, RZERO) 2740 ENDIF 2741 IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN 2742 IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN 2743 DO NZIND=1,NZ_loc 2744 IR = IRN_loc(NZIND) 2745 IC = JCN_loc(NZIND) 2746 IF((IR.GE.1).AND.(IR.LE.M).AND. 2747 & (IC.GE.1).AND.(IC.LE.N)) THEN 2748 ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) 2749 IF(WRKRC(ITDRPTR-1+IR)<ELM) THEN 2750 WRKRC(ITDRPTR-1+IR)= ELM 2751 ENDIF 2752 IF(WRKRC(ITDCPTR-1+IC)<ELM) THEN 2753 WRKRC(ITDCPTR-1+IC)= ELM 2754 ENDIF 2755 ELSE 2756 OORANGEIND = 1 2757 ENDIF 2758 ENDDO 2759 ELSEIF(OORANGEIND.EQ.0) THEN 2760 DO NZIND=1,NZ_loc 2761 IR = IRN_loc(NZIND) 2762 IC = JCN_loc(NZIND) 2763 ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) 2764 IF(WRKRC(ITDRPTR-1+IR)<ELM) THEN 2765 WRKRC(ITDRPTR-1+IR)= ELM 2766 ENDIF 2767 IF(WRKRC(ITDCPTR-1+IC)<ELM) THEN 2768 WRKRC(ITDCPTR-1+IC)= ELM 2769 ENDIF 2770 ENDDO 2771 ENDIF 2772 IF(NUMPROCS > 1) THEN 2773 CALL SMUMPS_657(MYID, NUMPROCS, 2774 & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, 2775 & ICSNDRCVNUM,IWRK(ICNGHBPRCS), 2776 & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), 2777 & WRKRC(ISRCPTR), 2778 & OCSNDRCVNUM,IWRK(OCNGHBPRCS), 2779 & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), 2780 & WRKRC( OSRCPTR), 2781 & IWRK(ISTATUS),IWRK(REQUESTS), 2782 & COMM) 2783 CALL SMUMPS_657(MYID, NUMPROCS, 2784 & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, 2785 & IRSNDRCVNUM,IWRK(IRNGHBPRCS), 2786 & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 2787 & WRKRC(ISRRPTR), 2788 & ORSNDRCVNUM,IWRK(ORNGHBPRCS), 2789 & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), 2790 & WRKRC( OSRRPTR), 2791 & IWRK(ISTATUS),IWRK(REQUESTS), 2792 & COMM) 2793 IF((EPS .GT. RZERO) .OR. 2794 & (ITER.EQ.NB1).OR. 2795 & ((ITER.EQ.NB1+NB2+NB3).AND. 2796 & (NB1+NB3.GT.0))) THEN 2797 INFERRROW = SMUMPS_737(ROWSCA, 2798 & WRKRC(ITDRPTR), M, 2799 & IWRK(IMYRPTR),INUMMYR) 2800 INFERRCOL = SMUMPS_737(COLSCA, 2801 & WRKRC(ITDCPTR), N, 2802 & IWRK(IMYCPTR),INUMMYC) 2803 INFERRL = INFERRCOL 2804 IF(INFERRROW > INFERRL ) THEN 2805 INFERRL = INFERRROW 2806 ENDIF 2807 CALL MPI_ALLREDUCE(INFERRL, INFERRG, 2808 & 1, MPI_REAL, 2809 & MPI_MAX, COMM, IERROR) 2810 IF(INFERRG.LE.EPS) THEN 2811 CALL SMUMPS_665(COLSCA, WRKRC(ITDCPTR), 2812 & N, 2813 & IWRK(IMYCPTR),INUMMYC) 2814 CALL SMUMPS_665(ROWSCA, WRKRC(ITDRPTR), 2815 & M, 2816 & IWRK(IMYRPTR),INUMMYR) 2817 IF(ITER .LE. NB1) THEN 2818 ITER = NB1+1 2819 CYCLE 2820 ELSE 2821 EXIT 2822 ENDIF 2823 ENDIF 2824 ENDIF 2825 ELSE 2826 IF((EPS .GT. RZERO) .OR. 2827 & (ITER.EQ.NB1).OR. 2828 & ((ITER.EQ.NB1+NB2+NB3).AND. 2829 & (NB1+NB3.GT.0))) THEN 2830 INFERRROW = SMUMPS_738(ROWSCA, 2831 & WRKRC(ITDRPTR), M) 2832 INFERRCOL = SMUMPS_738(COLSCA, 2833 & WRKRC(ITDCPTR), N) 2834 INFERRL = INFERRCOL 2835 IF(INFERRROW > INFERRL) THEN 2836 INFERRL = INFERRROW 2837 ENDIF 2838 INFERRG = INFERRL 2839 IF(INFERRG.LE.EPS) THEN 2840 CALL SMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) 2841 CALL SMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) 2842 IF(ITER .LE. NB1) THEN 2843 ITER = NB1+1 2844 CYCLE 2845 ELSE 2846 EXIT 2847 ENDIF 2848 ENDIF 2849 ENDIF 2850 ENDIF 2851 ELSE 2852 IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN 2853 DO NZIND=1,NZ_loc 2854 IR = IRN_loc(NZIND) 2855 IC = JCN_loc(NZIND) 2856 IF((IR.GE.1).AND.(IR.LE.M).AND. 2857 & (IC.GE.1).AND.(IC.LE.N)) THEN 2858 ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) 2859 WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM 2860 WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM 2861 ELSE 2862 OORANGEIND = 1 2863 ENDIF 2864 ENDDO 2865 ELSEIF(OORANGEIND.EQ.0) THEN 2866 DO NZIND=1,NZ_loc 2867 IR = IRN_loc(NZIND) 2868 IC = JCN_loc(NZIND) 2869 ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) 2870 WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM 2871 WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM 2872 ENDDO 2873 ENDIF 2874 IF(NUMPROCS > 1) THEN 2875 CALL SMUMPS_656(MYID, NUMPROCS, 2876 & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, 2877 & ICSNDRCVNUM, IWRK(ICNGHBPRCS), 2878 & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), 2879 & WRKRC(ISRCPTR), 2880 & OCSNDRCVNUM, IWRK(OCNGHBPRCS), 2881 & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), 2882 & WRKRC( OSRCPTR), 2883 & IWRK(ISTATUS), IWRK(REQUESTS), 2884 & COMM) 2885 CALL SMUMPS_656(MYID, NUMPROCS, 2886 & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, 2887 & IRSNDRCVNUM, IWRK(IRNGHBPRCS), 2888 & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 2889 & WRKRC(ISRRPTR), 2890 & ORSNDRCVNUM, IWRK(ORNGHBPRCS), 2891 & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), 2892 & WRKRC( OSRRPTR), 2893 & IWRK(ISTATUS), IWRK(REQUESTS), 2894 & COMM) 2895 IF((EPS .GT. RZERO) .OR. 2896 & ((ITER.EQ.NB1+NB2).AND. 2897 & (NB2.GT.0))) THEN 2898 ONEERRROW = SMUMPS_737(ROWSCA, 2899 & WRKRC(ITDRPTR), M, 2900 & IWRK(IMYRPTR),INUMMYR) 2901 ONEERRCOL = SMUMPS_737(COLSCA, 2902 & WRKRC(ITDCPTR), N, 2903 & IWRK(IMYCPTR),INUMMYC) 2904 ONEERRL = ONEERRCOL 2905 IF(ONEERRROW > ONEERRL ) THEN 2906 ONEERRL = ONEERRROW 2907 ENDIF 2908 CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, 2909 & 1, MPI_REAL, 2910 & MPI_MAX, COMM, IERROR) 2911 IF(ONEERRG.LE.EPS) THEN 2912 CALL SMUMPS_665(COLSCA, WRKRC(ITDCPTR), 2913 & N, 2914 & IWRK(IMYCPTR),INUMMYC) 2915 CALL SMUMPS_665(ROWSCA, WRKRC(ITDRPTR), 2916 & M, 2917 & IWRK(IMYRPTR),INUMMYR) 2918 ITER = NB1+NB2+1 2919 CYCLE 2920 ENDIF 2921 ENDIF 2922 ELSE 2923 IF((EPS .GT. RZERO) .OR. 2924 & ((ITER.EQ.NB1+NB2).AND. 2925 & (NB2.GT.0))) THEN 2926 ONEERRROW = SMUMPS_738(ROWSCA, 2927 & WRKRC(ITDRPTR), M) 2928 ONEERRCOL = SMUMPS_738(COLSCA, 2929 & WRKRC(ITDCPTR), N) 2930 ONEERRL = ONEERRCOL 2931 IF(ONEERRROW > ONEERRL) THEN 2932 ONEERRL = ONEERRROW 2933 ENDIF 2934 ONEERRG = ONEERRL 2935 IF(ONEERRG.LE.EPS) THEN 2936 CALL SMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) 2937 CALL SMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) 2938 ITER = NB1+NB2+1 2939 CYCLE 2940 ENDIF 2941 ENDIF 2942 ENDIF 2943 ENDIF 2944 IF(NUMPROCS > 1) THEN 2945 CALL SMUMPS_665(COLSCA, WRKRC(ITDCPTR), N, 2946 & IWRK(IMYCPTR),INUMMYC) 2947 CALL SMUMPS_665(ROWSCA, WRKRC(ITDRPTR), M, 2948 & IWRK(IMYRPTR),INUMMYR) 2949 ELSE 2950 CALL SMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) 2951 CALL SMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) 2952 ENDIF 2953 ITER = ITER + 1 2954 ENDDO 2955 ONENORMERR = ONEERRG 2956 INFNORMERR = INFERRG 2957 IF(NUMPROCS > 1) THEN 2958 CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_REAL, 2959 & MPI_MAX, 0, 2960 & COMM, IERROR) 2961 IF(MYID.EQ.0) THEN 2962 DO I=1, M 2963 ROWSCA(I) = WRKRC(I) 2964 ENDDO 2965 ENDIF 2966 CALL MPI_REDUCE(COLSCA, WRKRC(1+M), N, MPI_REAL, 2967 & MPI_MAX, 0, 2968 & COMM, IERROR) 2969 If(MYID.EQ.0) THEN 2970 DO I=1, N 2971 COLSCA(I) = WRKRC(I+M) 2972 ENDDO 2973 ENDIF 2974 ENDIF 2975 ENDIF 2976 RETURN 2977 END SUBROUTINE SMUMPS_694 2978 SUBROUTINE SMUMPS_687(IRN_loc, JCN_loc, A_loc, NZ_loc, 2979 & N, NUMPROCS, MYID, COMM, 2980 & PARTVEC, 2981 & RSNDRCVSZ, 2982 & REGISTRE, 2983 & IWRK, IWRKSZ, 2984 & INTSZ, RESZ, OP, 2985 & SCA, WRKRC, ISZWRKRC, 2986 & NB1, NB2, NB3, EPS, 2987 & ONENORMERR, INFNORMERR) 2988 IMPLICIT NONE 2989 INCLUDE 'mpif.h' 2990 INTEGER NZ_loc, N, IWRKSZ, OP 2991 INTEGER NUMPROCS, MYID, COMM 2992 INTEGER INTSZ, RESZ 2993 INTEGER IRN_loc(NZ_loc) 2994 INTEGER JCN_loc(NZ_loc) 2995 REAL A_loc(NZ_loc) 2996 INTEGER PARTVEC(N), RSNDRCVSZ(2*NUMPROCS) 2997 INTEGER IWRK(IWRKSZ) 2998 INTEGER REGISTRE(12) 2999 REAL SCA(N) 3000 INTEGER ISZWRKRC 3001 REAL WRKRC(ISZWRKRC) 3002 INTEGER IRSNDRCVNUM, ORSNDRCVNUM 3003 INTEGER IRSNDRCVVOL, ORSNDRCVVOL 3004 INTEGER INUMMYR 3005 INTEGER IMYRPTR,IMYCPTR 3006 INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA 3007 INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA 3008 INTEGER ISTATUS, REQUESTS, TMPWORK 3009 INTEGER ITDRPTR, ISRRPTR, OSRRPTR 3010 REAL ONENORMERR,INFNORMERR 3011 INTEGER NB1, NB2, NB3 3012 REAL EPS 3013 INTEGER ITER, NZIND, IR, IC 3014 REAL ELM 3015 INTEGER TAG_COMM_ROW 3016 PARAMETER(TAG_COMM_ROW=101) 3017 INTEGER TAG_ITERS 3018 PARAMETER(TAG_ITERS=102) 3019 EXTERNAL SMUMPS_655, 3020 & SMUMPS_673, 3021 & SMUMPS_692, 3022 & SMUMPS_663, 3023 & SMUMPS_742, 3024 & SMUMPS_745, 3025 & SMUMPS_661, 3026 & SMUMPS_657, 3027 & SMUMPS_656, 3028 & SMUMPS_670, 3029 & SMUMPS_671 3030 INTEGER SMUMPS_742 3031 INTEGER SMUMPS_745 3032 REAL SMUMPS_737 3033 REAL SMUMPS_738 3034 INTRINSIC abs 3035 REAL RONE, RZERO 3036 PARAMETER(RONE=1.0E0,RZERO=0.0E0) 3037 INTEGER INTSZR 3038 INTEGER MAXMN 3039 INTEGER I, IERROR 3040 REAL ONEERRL, ONEERRG 3041 REAL INFERRL, INFERRG 3042 INTEGER OORANGEIND 3043 OORANGEIND = 0 3044 INFERRG = -RONE 3045 ONEERRG = -RONE 3046 MAXMN = N 3047 IF(OP == 1) THEN 3048 IF(NUMPROCS > 1) THEN 3049 CALL SMUMPS_655(MYID, NUMPROCS, COMM, 3050 & IRN_loc, JCN_loc, NZ_loc, 3051 & PARTVEC, N, 3052 & IWRK, IWRKSZ) 3053 CALL SMUMPS_673(MYID, NUMPROCS, N, PARTVEC, 3054 & NZ_loc, IRN_loc,JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, 3055 & ORSNDRCVNUM, ORSNDRCVVOL, 3056 & IWRK,IWRKSZ, 3057 & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) 3058 CALL SMUMPS_663(MYID, NUMPROCS, COMM, 3059 & IRN_loc, JCN_loc, NZ_loc, 3060 & PARTVEC, N, 3061 & INUMMYR, 3062 & IWRK, IWRKSZ) 3063 INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + 3064 & IRSNDRCVVOL + ORSNDRCVVOL + 3065 & 2*(NUMPROCS+1) + INUMMYR 3066 INTSZ = INTSZR + N + 3067 & (MPI_STATUS_SIZE +1) * NUMPROCS 3068 ELSE 3069 IRSNDRCVNUM = 0 3070 ORSNDRCVNUM = 0 3071 IRSNDRCVVOL = 0 3072 ORSNDRCVVOL = 0 3073 INUMMYR = 0 3074 INTSZ = 0 3075 ENDIF 3076 RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL 3077 REGISTRE(1) = IRSNDRCVNUM 3078 REGISTRE(2) = ORSNDRCVNUM 3079 REGISTRE(3) = IRSNDRCVVOL 3080 REGISTRE(4) = ORSNDRCVVOL 3081 REGISTRE(9) = INUMMYR 3082 REGISTRE(11) = INTSZ 3083 REGISTRE(12) = RESZ 3084 ELSE 3085 IRSNDRCVNUM = REGISTRE(1) 3086 ORSNDRCVNUM = REGISTRE(2) 3087 IRSNDRCVVOL = REGISTRE(3) 3088 ORSNDRCVVOL = REGISTRE(4) 3089 INUMMYR = REGISTRE(9) 3090 IF(NUMPROCS > 1) THEN 3091 CALL SMUMPS_661(MYID, NUMPROCS,COMM, 3092 & IRN_loc, JCN_loc, NZ_loc, 3093 & PARTVEC, N, 3094 & IWRK(1), INUMMYR, 3095 & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) 3096 IMYRPTR = 1 3097 IMYCPTR = IMYRPTR + INUMMYR 3098 IRNGHBPRCS = IMYCPTR 3099 IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM 3100 IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 3101 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL 3102 ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM 3103 ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 3104 REQUESTS = ORSNDRCVJA + ORSNDRCVVOL 3105 ISTATUS = REQUESTS + NUMPROCS 3106 TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS 3107 CALL SMUMPS_692(MYID, NUMPROCS, N, PARTVEC, 3108 & NZ_loc, IRN_loc, JCN_loc, 3109 & IRSNDRCVNUM, IRSNDRCVVOL, 3110 & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), 3111 & ORSNDRCVNUM, ORSNDRCVVOL, 3112 & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), 3113 & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), 3114 & IWRK(TMPWORK), 3115 & IWRK(ISTATUS), IWRK(REQUESTS), 3116 & TAG_COMM_ROW, COMM) 3117 CALL SMUMPS_670(SCA, N, RZERO) 3118 CALL SMUMPS_671(SCA, N, 3119 & IWRK(IMYRPTR),INUMMYR, RONE) 3120 ELSE 3121 CALL SMUMPS_670(SCA, N, RONE) 3122 ENDIF 3123 ITDRPTR = 1 3124 ISRRPTR = ITDRPTR + N 3125 OSRRPTR = ISRRPTR + IRSNDRCVVOL 3126 IF(NUMPROCS == 1)THEN 3127 OSRRPTR = OSRRPTR - 1 3128 ISRRPTR = ISRRPTR - 1 3129 ELSE 3130 IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 3131 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 3132 ENDIF 3133 ITER = 1 3134 DO WHILE(ITER.LE.NB1+NB2+NB3) 3135 IF(NUMPROCS > 1) THEN 3136 CALL SMUMPS_650(WRKRC(ITDRPTR),N, 3137 & IWRK(IMYRPTR),INUMMYR) 3138 ELSE 3139 CALL SMUMPS_670(WRKRC(ITDRPTR),N, RZERO) 3140 ENDIF 3141 IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN 3142 IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN 3143 DO NZIND=1,NZ_loc 3144 IR = IRN_loc(NZIND) 3145 IC = JCN_loc(NZIND) 3146 IF((IR.GE.1).AND.(IR.LE.N).AND. 3147 & (IC.GE.1).AND.(IC.LE.N)) THEN 3148 ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) 3149 IF(WRKRC(ITDRPTR-1+IR)<ELM) THEN 3150 WRKRC(ITDRPTR-1+IR)= ELM 3151 ENDIF 3152 IF(WRKRC(ITDRPTR-1+IC)<ELM) THEN 3153 WRKRC(ITDRPTR-1+IC)= ELM 3154 ENDIF 3155 ELSE 3156 OORANGEIND = 1 3157 ENDIF 3158 ENDDO 3159 ELSEIF(OORANGEIND.EQ.0) THEN 3160 DO NZIND=1,NZ_loc 3161 IR = IRN_loc(NZIND) 3162 IC = JCN_loc(NZIND) 3163 ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) 3164 IF(WRKRC(ITDRPTR-1+IR)<ELM) THEN 3165 WRKRC(ITDRPTR-1+IR)= ELM 3166 ENDIF 3167 IF(WRKRC(ITDRPTR-1+IC)<ELM) THEN 3168 WRKRC(ITDRPTR-1+IC)= ELM 3169 ENDIF 3170 ENDDO 3171 ENDIF 3172 IF(NUMPROCS > 1) THEN 3173 CALL SMUMPS_657(MYID, NUMPROCS, 3174 & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, 3175 & IRSNDRCVNUM,IWRK(IRNGHBPRCS), 3176 & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 3177 & WRKRC(ISRRPTR), 3178 & ORSNDRCVNUM,IWRK(ORNGHBPRCS), 3179 & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), 3180 & WRKRC( OSRRPTR), 3181 & IWRK(ISTATUS),IWRK(REQUESTS), 3182 & COMM) 3183 IF((EPS .GT. RZERO) .OR. 3184 & (ITER.EQ.NB1).OR. 3185 & ((ITER.EQ.NB1+NB2+NB3).AND. 3186 & (NB1+NB3.GT.0))) THEN 3187 INFERRL = SMUMPS_737(SCA, 3188 & WRKRC(ITDRPTR), N, 3189 & IWRK(IMYRPTR),INUMMYR) 3190 CALL MPI_ALLREDUCE(INFERRL, INFERRG, 3191 & 1, MPI_REAL, 3192 & MPI_MAX, COMM, IERROR) 3193 IF(INFERRG.LE.EPS) THEN 3194 CALL SMUMPS_665(SCA, WRKRC(ITDRPTR), N, 3195 & IWRK(IMYRPTR),INUMMYR) 3196 IF(ITER .LE. NB1) THEN 3197 ITER = NB1+1 3198 CYCLE 3199 ELSE 3200 EXIT 3201 ENDIF 3202 ENDIF 3203 ENDIF 3204 ELSE 3205 IF((EPS .GT. RZERO) .OR. 3206 & (ITER.EQ.NB1).OR. 3207 & ((ITER.EQ.NB1+NB2+NB3).AND. 3208 & (NB1+NB3.GT.0))) THEN 3209 INFERRL = SMUMPS_738(SCA, 3210 & WRKRC(ITDRPTR), N) 3211 INFERRG = INFERRL 3212 IF(INFERRG.LE.EPS) THEN 3213 CALL SMUMPS_666(SCA, WRKRC(ITDRPTR), N) 3214 IF(ITER .LE. NB1) THEN 3215 ITER = NB1+1 3216 CYCLE 3217 ELSE 3218 EXIT 3219 ENDIF 3220 ENDIF 3221 ENDIF 3222 ENDIF 3223 ELSE 3224 IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN 3225 DO NZIND=1,NZ_loc 3226 IR = IRN_loc(NZIND) 3227 IC = JCN_loc(NZIND) 3228 IF((IR.GE.1).AND.(IR.LE.N).AND. 3229 & (IC.GE.1).AND.(IC.LE.N)) THEN 3230 ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) 3231 WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM 3232 IF(IR.NE.IC) THEN 3233 WRKRC(ITDRPTR-1+IC) = 3234 & WRKRC(ITDRPTR-1+IC) + ELM 3235 ENDIF 3236 ELSE 3237 OORANGEIND = 1 3238 ENDIF 3239 ENDDO 3240 ELSEIF(OORANGEIND.EQ.0)THEN 3241 DO NZIND=1,NZ_loc 3242 IR = IRN_loc(NZIND) 3243 IC = JCN_loc(NZIND) 3244 ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) 3245 WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM 3246 IF(IR.NE.IC) THEN 3247 WRKRC(ITDRPTR-1+IC) = WRKRC(ITDRPTR-1+IC) + ELM 3248 ENDIF 3249 ENDDO 3250 ENDIF 3251 IF(NUMPROCS > 1) THEN 3252 CALL SMUMPS_656(MYID, NUMPROCS, 3253 & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, 3254 & IRSNDRCVNUM, IWRK(IRNGHBPRCS), 3255 & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 3256 & WRKRC(ISRRPTR), 3257 & ORSNDRCVNUM, IWRK(ORNGHBPRCS), 3258 & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), 3259 & WRKRC( OSRRPTR), 3260 & IWRK(ISTATUS), IWRK(REQUESTS), 3261 & COMM) 3262 IF((EPS .GT. RZERO) .OR. 3263 & ((ITER.EQ.NB1+NB2).AND. 3264 & (NB2.GT.0))) THEN 3265 ONEERRL = SMUMPS_737(SCA, 3266 & WRKRC(ITDRPTR), N, 3267 & IWRK(IMYRPTR),INUMMYR) 3268 CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, 3269 & 1, MPI_REAL, 3270 & MPI_MAX, COMM, IERROR) 3271 IF(ONEERRG.LE.EPS) THEN 3272 CALL SMUMPS_665(SCA, WRKRC(ITDRPTR), N, 3273 & IWRK(IMYRPTR),INUMMYR) 3274 ITER = NB1+NB2+1 3275 CYCLE 3276 ENDIF 3277 ENDIF 3278 ELSE 3279 IF((EPS .GT. RZERO) .OR. 3280 & ((ITER.EQ.NB1+NB2).AND. 3281 & (NB2.GT.0))) THEN 3282 ONEERRL = SMUMPS_738(SCA, 3283 & WRKRC(ITDRPTR), N) 3284 ONEERRG = ONEERRL 3285 IF(ONEERRG.LE.EPS) THEN 3286 CALL SMUMPS_666(SCA, WRKRC(ITDRPTR), N) 3287 ITER = NB1+NB2+1 3288 CYCLE 3289 ENDIF 3290 ENDIF 3291 ENDIF 3292 ENDIF 3293 IF(NUMPROCS > 1) THEN 3294 CALL SMUMPS_665(SCA, WRKRC(ITDRPTR), N, 3295 & IWRK(IMYRPTR),INUMMYR) 3296 ELSE 3297 CALL SMUMPS_666(SCA, WRKRC(ITDRPTR), N) 3298 ENDIF 3299 ITER = ITER + 1 3300 ENDDO 3301 ONENORMERR = ONEERRG 3302 INFNORMERR = INFERRG 3303 IF(NUMPROCS > 1) THEN 3304 CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_REAL, 3305 & MPI_MAX, 0, 3306 & COMM, IERROR) 3307 IF(MYID.EQ.0) THEN 3308 DO I=1, N 3309 SCA(I) = WRKRC(I) 3310 ENDDO 3311 ENDIF 3312 ENDIF 3313 ENDIF 3314 RETURN 3315 END SUBROUTINE SMUMPS_687 3316 SUBROUTINE SMUMPS_654(MYID, NUMPROCS, COMM, 3317 & IRN_loc, JCN_loc, NZ_loc, 3318 & IPARTVEC, ISZ, OSZ, 3319 & IWRK, IWSZ) 3320 IMPLICIT NONE 3321 EXTERNAL SMUMPS_703 3322 INTEGER MYID, NUMPROCS, COMM 3323 INTEGER NZ_loc, ISZ, IWSZ, OSZ 3324 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 3325 INTEGER IPARTVEC(ISZ) 3326 INTEGER IWRK(IWSZ) 3327 INCLUDE 'mpif.h' 3328 INTEGER I 3329 INTEGER OP, IERROR 3330 INTEGER IR, IC 3331 IF(NUMPROCS.NE.1) THEN 3332 CALL MPI_OP_CREATE(SMUMPS_703, .TRUE., OP, IERROR) 3333 CALL SMUMPS_668(IWRK, 4*ISZ, ISZ) 3334 DO I=1,ISZ 3335 IWRK(2*I-1) = 0 3336 IWRK(2*I) = MYID 3337 ENDDO 3338 DO I=1,NZ_loc 3339 IR = IRN_loc(I) 3340 IC = JCN_loc(I) 3341 IF((IR.GE.1).AND.(IR.LE.ISZ).AND. 3342 & (IC.GE.1).AND.(IC.LE.OSZ)) THEN 3343 IWRK(2*IR-1) = IWRK(2*IR-1) + 1 3344 ENDIF 3345 ENDDO 3346 CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, 3347 & MPI_2INTEGER, OP, COMM, IERROR) 3348 DO I=1,ISZ 3349 IPARTVEC(I) = IWRK(2*I+2*ISZ) 3350 ENDDO 3351 CALL MPI_OP_FREE(OP, IERROR) 3352 ELSE 3353 DO I=1,ISZ 3354 IPARTVEC(I) = 0 3355 ENDDO 3356 ENDIF 3357 RETURN 3358 END SUBROUTINE SMUMPS_654 3359 SUBROUTINE SMUMPS_662(MYID, NUMPROCS, COMM, 3360 & IRN_loc, JCN_loc, NZ_loc, 3361 & ROWPARTVEC, COLPARTVEC, M, N, 3362 & INUMMYR, 3363 & INUMMYC, 3364 & IWRK, IWSZ) 3365 IMPLICIT NONE 3366 INTEGER MYID, NUMPROCS, NZ_loc, M, N 3367 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 3368 INTEGER ROWPARTVEC(M) 3369 INTEGER COLPARTVEC(N) 3370 INTEGER INUMMYR, INUMMYC 3371 INTEGER IWSZ 3372 INTEGER IWRK(IWSZ) 3373 INTEGER COMM 3374 INTEGER I, IR, IC 3375 INUMMYR = 0 3376 INUMMYC = 0 3377 DO I=1,M 3378 IWRK(I) = 0 3379 IF(ROWPARTVEC(I).EQ.MYID) THEN 3380 IWRK(I)=1 3381 INUMMYR = INUMMYR + 1 3382 ENDIF 3383 ENDDO 3384 DO I=1,NZ_loc 3385 IR = IRN_loc(I) 3386 IC = JCN_loc(I) 3387 IF((IR.GE.1).AND.(IR.LE.M).AND. 3388 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 3389 IF(IWRK(IR) .EQ. 0) THEN 3390 IWRK(IR)= 1 3391 INUMMYR = INUMMYR + 1 3392 ENDIF 3393 ENDIF 3394 ENDDO 3395 DO I=1,N 3396 IWRK(I) = 0 3397 IF(COLPARTVEC(I).EQ.MYID) THEN 3398 IWRK(I)= 1 3399 INUMMYC = INUMMYC + 1 3400 ENDIF 3401 ENDDO 3402 DO I=1,NZ_loc 3403 IC = JCN_loc(I) 3404 IR = IRN_loc(I) 3405 IF((IR.GE.1).AND.(IR.LE.M).AND. 3406 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 3407 IF(IWRK(IC) .EQ. 0) THEN 3408 IWRK(IC)= 1 3409 INUMMYC = INUMMYC + 1 3410 ENDIF 3411 ENDIF 3412 ENDDO 3413 RETURN 3414 END SUBROUTINE SMUMPS_662 3415 SUBROUTINE SMUMPS_660(MYID, NUMPROCS,COMM, 3416 & IRN_loc, JCN_loc, NZ_loc, 3417 & ROWPARTVEC, COLPARTVEC, M, N, 3418 & MYROWINDICES, INUMMYR, 3419 & MYCOLINDICES, INUMMYC, 3420 & IWRK, IWSZ ) 3421 IMPLICIT NONE 3422 INTEGER MYID, NUMPROCS, NZ_loc, M, N 3423 INTEGER INUMMYR, INUMMYC, IWSZ 3424 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 3425 INTEGER ROWPARTVEC(M) 3426 INTEGER COLPARTVEC(N) 3427 INTEGER MYROWINDICES(INUMMYR) 3428 INTEGER MYCOLINDICES(INUMMYC) 3429 INTEGER IWRK(IWSZ) 3430 INTEGER COMM 3431 INTEGER I, IR, IC, ITMP, MAXMN 3432 MAXMN = M 3433 IF(N > MAXMN) MAXMN = N 3434 DO I=1,M 3435 IWRK(I) = 0 3436 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 3437 ENDDO 3438 DO I=1,NZ_loc 3439 IR = IRN_loc(I) 3440 IC = JCN_loc(I) 3441 IF((IR.GE.1).AND.(IR.LE.M).AND. 3442 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 3443 IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 3444 ENDIF 3445 ENDDO 3446 ITMP = 1 3447 DO I=1,M 3448 IF(IWRK(I).EQ.1) THEN 3449 MYROWINDICES(ITMP) = I 3450 ITMP = ITMP + 1 3451 ENDIF 3452 ENDDO 3453 DO I=1,N 3454 IWRK(I) = 0 3455 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 3456 ENDDO 3457 DO I=1,NZ_loc 3458 IR = IRN_loc(I) 3459 IC = JCN_loc(I) 3460 IF((IR.GE.1).AND.(IR.LE.M).AND. 3461 & ((IC.GE.1).AND.(IC.LE.N)) ) THEN 3462 IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 3463 ENDIF 3464 ENDDO 3465 ITMP = 1 3466 DO I=1,N 3467 IF(IWRK(I).EQ.1) THEN 3468 MYCOLINDICES(ITMP) = I 3469 ITMP = ITMP + 1 3470 ENDIF 3471 ENDDO 3472 RETURN 3473 END SUBROUTINE SMUMPS_660 3474 INTEGER FUNCTION SMUMPS_744(D, DSZ, INDX, INDXSZ, EPS) 3475 IMPLICIT NONE 3476 INTEGER DSZ, INDXSZ 3477 REAL D(DSZ) 3478 INTEGER INDX(INDXSZ) 3479 REAL EPS 3480 INTEGER I, IID 3481 REAL RONE 3482 PARAMETER(RONE=1.0E0) 3483 SMUMPS_744 = 1 3484 DO I=1, INDXSZ 3485 IID = INDX(I) 3486 IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. 3487 & ((RONE-EPS).LE.D(IID)) )) THEN 3488 SMUMPS_744 = 0 3489 ENDIF 3490 ENDDO 3491 RETURN 3492 END FUNCTION SMUMPS_744 3493 INTEGER FUNCTION SMUMPS_745(D, DSZ, EPS) 3494 IMPLICIT NONE 3495 INTEGER DSZ 3496 REAL D(DSZ) 3497 REAL EPS 3498 INTEGER I 3499 REAL RONE 3500 PARAMETER(RONE=1.0E0) 3501 SMUMPS_745 = 1 3502 DO I=1, DSZ 3503 IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. 3504 & ((RONE-EPS).LE.D(I)) )) THEN 3505 SMUMPS_745 = 0 3506 ENDIF 3507 ENDDO 3508 RETURN 3509 END FUNCTION SMUMPS_745 3510 INTEGER FUNCTION SMUMPS_743(DR, M, INDXR, INDXRSZ, 3511 & DC, N, INDXC, INDXCSZ, EPS, COMM) 3512 IMPLICIT NONE 3513 INCLUDE 'mpif.h' 3514 INTEGER M, N, INDXRSZ, INDXCSZ 3515 REAL DR(M), DC(N) 3516 INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) 3517 REAL EPS 3518 INTEGER COMM 3519 EXTERNAL SMUMPS_744 3520 INTEGER SMUMPS_744 3521 INTEGER GLORES, MYRESR, MYRESC, MYRES 3522 INTEGER IERR 3523 MYRESR = SMUMPS_744(DR, M, INDXR, INDXRSZ, EPS) 3524 MYRESC = SMUMPS_744(DC, N, INDXC, INDXCSZ, EPS) 3525 MYRES = MYRESR + MYRESC 3526 CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, 3527 & MPI_SUM, COMM, IERR) 3528 SMUMPS_743 = GLORES 3529 RETURN 3530 END FUNCTION SMUMPS_743 3531 REAL FUNCTION SMUMPS_737(D, TMPD, DSZ, 3532 & INDX, INDXSZ) 3533 IMPLICIT NONE 3534 INTEGER DSZ, INDXSZ 3535 REAL D(DSZ) 3536 REAL TMPD(DSZ) 3537 INTEGER INDX(INDXSZ) 3538 REAL RONE 3539 PARAMETER(RONE=1.0E0) 3540 INTEGER I, IIND 3541 REAL ERRMAX 3542 INTRINSIC abs 3543 ERRMAX = -RONE 3544 DO I=1,INDXSZ 3545 IIND = INDX(I) 3546 IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN 3547 ERRMAX = abs(RONE-TMPD(IIND)) 3548 ENDIF 3549 ENDDO 3550 SMUMPS_737 = ERRMAX 3551 RETURN 3552 END FUNCTION SMUMPS_737 3553 REAL FUNCTION SMUMPS_738(D, TMPD, DSZ) 3554 IMPLICIT NONE 3555 INTEGER DSZ 3556 REAL D(DSZ) 3557 REAL TMPD(DSZ) 3558 REAL RONE 3559 PARAMETER(RONE=1.0E0) 3560 INTEGER I 3561 REAL ERRMAX1 3562 INTRINSIC abs 3563 ERRMAX1 = -RONE 3564 DO I=1,DSZ 3565 IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN 3566 ERRMAX1 = abs(RONE-TMPD(I)) 3567 ENDIF 3568 ENDDO 3569 SMUMPS_738 = ERRMAX1 3570 RETURN 3571 END FUNCTION SMUMPS_738 3572 SUBROUTINE SMUMPS_665(D, TMPD, DSZ, 3573 & INDX, INDXSZ) 3574 IMPLICIT NONE 3575 INTEGER DSZ, INDXSZ 3576 REAL D(DSZ) 3577 REAL TMPD(DSZ) 3578 INTEGER INDX(INDXSZ) 3579 INTRINSIC sqrt 3580 INTEGER I, IIND 3581 REAL RZERO 3582 PARAMETER(RZERO=0.0E0) 3583 DO I=1,INDXSZ 3584 IIND = INDX(I) 3585 IF (TMPD(IIND).NE.RZERO) D(IIND) = D(IIND)/sqrt(TMPD(IIND)) 3586 ENDDO 3587 RETURN 3588 END SUBROUTINE SMUMPS_665 3589 SUBROUTINE SMUMPS_666(D, TMPD, DSZ) 3590 IMPLICIT NONE 3591 INTEGER DSZ 3592 REAL D(DSZ) 3593 REAL TMPD(DSZ) 3594 INTRINSIC sqrt 3595 INTEGER I 3596 REAL RZERO 3597 PARAMETER(RZERO=0.0E0) 3598 DO I=1,DSZ 3599 IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) 3600 ENDDO 3601 RETURN 3602 END SUBROUTINE SMUMPS_666 3603 SUBROUTINE SMUMPS_671(D, DSZ, INDX, INDXSZ, VAL) 3604 IMPLICIT NONE 3605 INTEGER DSZ, INDXSZ 3606 REAL D(DSZ) 3607 INTEGER INDX(INDXSZ) 3608 REAL VAL 3609 INTEGER I, IIND 3610 DO I=1,INDXSZ 3611 IIND = INDX(I) 3612 D(IIND) = VAL 3613 ENDDO 3614 RETURN 3615 END SUBROUTINE SMUMPS_671 3616 SUBROUTINE SMUMPS_702(D, DSZ, INDX, INDXSZ) 3617 IMPLICIT NONE 3618 INTEGER DSZ, INDXSZ 3619 REAL D(DSZ) 3620 INTEGER INDX(INDXSZ) 3621 INTEGER I, IIND 3622 DO I=1,INDXSZ 3623 IIND = INDX(I) 3624 D(IIND) = 1.0E0/D(IIND) 3625 ENDDO 3626 RETURN 3627 END SUBROUTINE SMUMPS_702 3628 SUBROUTINE SMUMPS_670(D, DSZ, VAL) 3629 IMPLICIT NONE 3630 INTEGER DSZ 3631 REAL D(DSZ) 3632 REAL VAL 3633 INTEGER I 3634 DO I=1,DSZ 3635 D(I) = VAL 3636 ENDDO 3637 RETURN 3638 END SUBROUTINE SMUMPS_670 3639 SUBROUTINE SMUMPS_650(TMPD, TMPSZ, INDX, INDXSZ) 3640 IMPLICIT NONE 3641 INTEGER TMPSZ,INDXSZ 3642 REAL TMPD(TMPSZ) 3643 INTEGER INDX(INDXSZ) 3644 INTEGER I 3645 REAL DZERO 3646 PARAMETER(DZERO=0.0E0) 3647 DO I=1,INDXSZ 3648 TMPD(INDX(I)) = DZERO 3649 ENDDO 3650 RETURN 3651 END SUBROUTINE SMUMPS_650 3652 SUBROUTINE SMUMPS_703(INV, INOUTV, LEN, DTYPE) 3653 IMPLICIT NONE 3654 INTEGER LEN 3655 INTEGER INV(2*LEN) 3656 INTEGER INOUTV(2*LEN) 3657 INTEGER DTYPE 3658 INTEGER I 3659 INTEGER DIN, DINOUT, PIN, PINOUT 3660 DO I=1,2*LEN-1,2 3661 DIN = INV(I) 3662 PIN = INV(I+1) 3663 DINOUT = INOUTV(I) 3664 PINOUT = INOUTV(I+1) 3665 IF (DINOUT < DIN) THEN 3666 INOUTV(I) = DIN 3667 INOUTV(I+1) = PIN 3668 ELSE IF (DINOUT == DIN) THEN 3669 IF ((mod(DINOUT,2).EQ.0).AND.(PIN<PINOUT)) THEN 3670 INOUTV(I+1) = PIN 3671 ELSE IF ((mod(DINOUT,2).EQ.1).AND.(PIN>PINOUT)) THEN 3672 INOUTV(I+1) = PIN 3673 ENDIF 3674 ENDIF 3675 ENDDO 3676 RETURN 3677 END SUBROUTINE SMUMPS_703 3678 SUBROUTINE SMUMPS_668(IW, IWSZ, IVAL) 3679 IMPLICIT NONE 3680 INTEGER IWSZ 3681 INTEGER IW(IWSZ) 3682 INTEGER IVAL 3683 INTEGER I 3684 DO I=1,IWSZ 3685 IW(I)=IVAL 3686 ENDDO 3687 RETURN 3688 END SUBROUTINE SMUMPS_668 3689 SUBROUTINE SMUMPS_704(MYID, NUMPROCS, 3690 & IRN_loc, JCN_loc, NZ_loc, 3691 & ROWPARTVEC, COLPARTVEC, M, N, 3692 & MYROWINDICES, INUMMYR, 3693 & MYCOLINDICES, INUMMYC, 3694 & IWRKROW, IWRKCOL, IWSZR, IWSZC, COMM ) 3695 IMPLICIT NONE 3696 INTEGER MYID, NUMPROCS, NZ_loc, M, N 3697 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 3698 INTEGER ROWPARTVEC(M) 3699 INTEGER COLPARTVEC(N) 3700 INTEGER MYROWINDICES(M) 3701 INTEGER MYCOLINDICES(N) 3702 INTEGER INUMMYR, INUMMYC 3703 INTEGER IWSZR, IWSZC 3704 INTEGER IWRKROW(IWSZR) 3705 INTEGER IWRKCOL(IWSZC) 3706 INTEGER COMM 3707 INTEGER I, IR, IC, ITMP 3708 INUMMYR = 0 3709 INUMMYC = 0 3710 DO I=1,M 3711 IWRKROW(I) = 0 3712 IF(ROWPARTVEC(I).EQ.MYID) THEN 3713 IWRKROW(I)=1 3714 INUMMYR = INUMMYR + 1 3715 ENDIF 3716 ENDDO 3717 DO I=1,NZ_loc 3718 IR = IRN_loc(I) 3719 IC = JCN_loc(I) 3720 IF((IR.GE.1).AND.(IR.LE.M).AND. 3721 & ((IC.GE.1).AND.(IC.LE.N))) THEN 3722 IF(IWRKROW(IR) .EQ. 0) THEN 3723 IWRKROW(IR)= 1 3724 INUMMYR = INUMMYR + 1 3725 ENDIF 3726 ENDIF 3727 ENDDO 3728 ITMP = 1 3729 DO I=1,M 3730 IF(IWRKROW(I).EQ.1) THEN 3731 MYROWINDICES(ITMP) = I 3732 ITMP = ITMP + 1 3733 ENDIF 3734 ENDDO 3735 DO I=1,N 3736 IWRKCOL(I) = 0 3737 IF(COLPARTVEC(I).EQ.MYID) THEN 3738 IWRKCOL(I)= 1 3739 INUMMYC = INUMMYC + 1 3740 ENDIF 3741 ENDDO 3742 DO I=1,NZ_loc 3743 IR = IRN_loc(I) 3744 IC = JCN_loc(I) 3745 IF((IR.GE.1).AND.(IR.LE.M).AND. 3746 & ((IC.GE.1).AND.(IC.LE.N))) THEN 3747 IF(IWRKCOL(IC) .EQ. 0) THEN 3748 IWRKCOL(IC)= 1 3749 INUMMYC = INUMMYC + 1 3750 ENDIF 3751 ENDIF 3752 ENDDO 3753 ITMP = 1 3754 DO I=1,N 3755 IF(IWRKCOL(I).EQ.1) THEN 3756 MYCOLINDICES(ITMP) = I 3757 ITMP = ITMP + 1 3758 ENDIF 3759 ENDDO 3760 RETURN 3761 END SUBROUTINE SMUMPS_704 3762 SUBROUTINE SMUMPS_672(MYID, NUMPROCS, ISZ, IPARTVEC, 3763 & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, 3764 & OSNDRCVNUM,OSNDRCVVOL, 3765 & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) 3766 IMPLICIT NONE 3767 INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ, OSZ 3768 INTEGER ISNDRCVNUM, ISNDRCVVOL 3769 INTEGER OSNDRCVNUM, OSNDRCVVOL 3770 INTEGER COMM 3771 INTEGER INDX(NZ_loc) 3772 INTEGER OINDX(NZ_loc) 3773 INTEGER IPARTVEC(ISZ) 3774 INTEGER IWRK(IWRKSZ) 3775 INTEGER SNDSZ(NUMPROCS) 3776 INTEGER RCVSZ(NUMPROCS) 3777 INCLUDE 'mpif.h' 3778 INTEGER I 3779 INTEGER IIND, IIND2, PIND 3780 INTEGER IERROR 3781 DO I=1,NUMPROCS 3782 SNDSZ(I) = 0 3783 RCVSZ(I) = 0 3784 ENDDO 3785 DO I=1,IWRKSZ 3786 IWRK(I) = 0 3787 ENDDO 3788 DO I=1,NZ_loc 3789 IIND = INDX(I) 3790 IIND2 = OINDX(I) 3791 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. 3792 & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN 3793 PIND = IPARTVEC(IIND) 3794 IF(PIND .NE. MYID) THEN 3795 IF(IWRK(IIND).EQ.0) THEN 3796 IWRK(IIND) = 1 3797 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 3798 ENDIF 3799 ENDIF 3800 ENDIF 3801 ENDDO 3802 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, 3803 & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 3804 ISNDRCVNUM = 0 3805 ISNDRCVVOL = 0 3806 OSNDRCVNUM = 0 3807 OSNDRCVVOL = 0 3808 DO I=1, NUMPROCS 3809 IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 3810 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) 3811 IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 3812 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) 3813 ENDDO 3814 RETURN 3815 END SUBROUTINE SMUMPS_672 3816 SUBROUTINE SMUMPS_674(MYID, NUMPROCS, ISZ, IPARTVEC, 3817 & NZ_loc, INDX, OSZ, OINDX, 3818 & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, 3819 & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, 3820 & SNDSZ, RCVSZ, IWRK, 3821 & ISTATUS, REQUESTS, 3822 & ITAGCOMM, COMM ) 3823 IMPLICIT NONE 3824 INCLUDE 'mpif.h' 3825 INTEGER MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL, OSZ 3826 INTEGER INDX(NZ_loc) 3827 INTEGER OINDX(NZ_loc) 3828 INTEGER IPARTVEC(ISZ) 3829 INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) 3830 INTEGER ISNDRCVIA(NUMPROCS+1) 3831 INTEGER ISNDRCVJA(ISNDVOL) 3832 INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) 3833 INTEGER OSNDRCVIA(NUMPROCS+1) 3834 INTEGER OSNDRCVJA(OSNDVOL) 3835 INTEGER SNDSZ(NUMPROCS) 3836 INTEGER RCVSZ(NUMPROCS) 3837 INTEGER IWRK(ISZ) 3838 INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) 3839 INTEGER REQUESTS(ISNDRCVNUM) 3840 INTEGER ITAGCOMM, COMM 3841 INTEGER I, IIND, IIND2, IPID, OFFS 3842 INTEGER IWHERETO, POFFS, ITMP, IERROR 3843 DO I=1,ISZ 3844 IWRK(I) = 0 3845 ENDDO 3846 OFFS = 1 3847 POFFS = 1 3848 DO I=1,NUMPROCS 3849 OSNDRCVIA(I) = OFFS + SNDSZ(I) 3850 IF(SNDSZ(I) > 0) THEN 3851 ONGHBPRCS(POFFS)=I 3852 POFFS = POFFS + 1 3853 ENDIF 3854 OFFS = OFFS + SNDSZ(I) 3855 ENDDO 3856 OSNDRCVIA(NUMPROCS+1) = OFFS 3857 DO I=1,NZ_loc 3858 IIND=INDX(I) 3859 IIND2 = OINDX(I) 3860 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. 3861 & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN 3862 IPID=IPARTVEC(IIND) 3863 IF(IPID.NE.MYID) THEN 3864 IF(IWRK(IIND).EQ.0) THEN 3865 IWHERETO = OSNDRCVIA(IPID+1)-1 3866 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 3867 OSNDRCVJA(IWHERETO) = IIND 3868 IWRK(IIND) = 1 3869 ENDIF 3870 ENDIF 3871 ENDIF 3872 ENDDO 3873 CALL MPI_BARRIER(COMM,IERROR) 3874 OFFS = 1 3875 POFFS = 1 3876 ISNDRCVIA(1) = 1 3877 DO I=2,NUMPROCS+1 3878 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) 3879 IF(RCVSZ(I-1) > 0) THEN 3880 INGHBPRCS(POFFS)=I-1 3881 POFFS = POFFS + 1 3882 ENDIF 3883 OFFS = OFFS + RCVSZ(I-1) 3884 ENDDO 3885 CALL MPI_BARRIER(COMM,IERROR) 3886 DO I=1, ISNDRCVNUM 3887 IPID = INGHBPRCS(I) 3888 OFFS = ISNDRCVIA(IPID) 3889 ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) 3890 CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, 3891 & ITAGCOMM, COMM, REQUESTS(I),IERROR) 3892 ENDDO 3893 DO I=1,OSNDRCVNUM 3894 IPID = ONGHBPRCS(I) 3895 OFFS = OSNDRCVIA(IPID) 3896 ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) 3897 CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, 3898 & ITAGCOMM, COMM,IERROR) 3899 ENDDO 3900 IF(ISNDRCVNUM > 0) THEN 3901 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 3902 ENDIF 3903 CALL MPI_BARRIER(COMM,IERROR) 3904 RETURN 3905 END SUBROUTINE SMUMPS_674 3906 SUBROUTINE SMUMPS_657(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, 3907 & ISNDRCVNUM, INGHBPRCS, 3908 & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, 3909 & OSNDRCVNUM, ONGHBPRCS, 3910 & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, 3911 & ISTATUS, REQUESTS, 3912 & COMM) 3913 IMPLICIT NONE 3914 INCLUDE 'mpif.h' 3915 INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM 3916 INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL 3917 REAL TMPD(IDSZ) 3918 INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) 3919 INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) 3920 REAL ISNDRCVA(ISNDRCVVOL) 3921 INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) 3922 REAL OSNDRCVA(OSNDRCVVOL) 3923 INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) 3924 INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) 3925 INTEGER COMM, IERROR 3926 INTEGER I, PID, OFFS, SZ, J, JS, JE, IID 3927 DO I=1,ISNDRCVNUM 3928 PID = INGHBPRCS(I) 3929 OFFS = ISNDRCVIA(PID) 3930 SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) 3931 CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, 3932 & MPI_REAL, PID-1, 3933 & ITAGCOMM,COMM,REQUESTS(I), IERROR) 3934 ENDDO 3935 DO I=1,OSNDRCVNUM 3936 PID = ONGHBPRCS(I) 3937 OFFS = OSNDRCVIA(PID) 3938 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 3939 JS = OSNDRCVIA(PID) 3940 JE = OSNDRCVIA(PID+1) - 1 3941 DO J=JS, JE 3942 IID = OSNDRCVJA(J) 3943 OSNDRCVA(J) = TMPD(IID) 3944 ENDDO 3945 CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, 3946 & ITAGCOMM, COMM, IERROR) 3947 ENDDO 3948 IF(ISNDRCVNUM > 0) THEN 3949 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 3950 ENDIF 3951 DO I=1,ISNDRCVNUM 3952 PID = INGHBPRCS(I) 3953 JS = ISNDRCVIA(PID) 3954 JE = ISNDRCVIA(PID+1)-1 3955 DO J=JS,JE 3956 IID = ISNDRCVJA(J) 3957 IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) 3958 ENDDO 3959 ENDDO 3960 DO I=1,OSNDRCVNUM 3961 PID = ONGHBPRCS(I) 3962 OFFS = OSNDRCVIA(PID) 3963 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 3964 CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, 3965 & MPI_REAL, PID-1, 3966 & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) 3967 ENDDO 3968 DO I=1,ISNDRCVNUM 3969 PID = INGHBPRCS(I) 3970 OFFS = ISNDRCVIA(PID) 3971 SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) 3972 JS = ISNDRCVIA(PID) 3973 JE = ISNDRCVIA(PID+1) -1 3974 DO J=JS, JE 3975 IID = ISNDRCVJA(J) 3976 ISNDRCVA(J) = TMPD(IID) 3977 ENDDO 3978 CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, 3979 & ITAGCOMM+1, COMM, IERROR) 3980 ENDDO 3981 IF(OSNDRCVNUM > 0) THEN 3982 CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 3983 ENDIF 3984 DO I=1,OSNDRCVNUM 3985 PID = ONGHBPRCS(I) 3986 JS = OSNDRCVIA(PID) 3987 JE = OSNDRCVIA(PID+1) - 1 3988 DO J=JS,JE 3989 IID = OSNDRCVJA(J) 3990 TMPD(IID)=OSNDRCVA(J) 3991 ENDDO 3992 ENDDO 3993 RETURN 3994 END SUBROUTINE SMUMPS_657 3995 SUBROUTINE SMUMPS_656(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, 3996 & ISNDRCVNUM, INGHBPRCS, 3997 & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, 3998 & OSNDRCVNUM, ONGHBPRCS, 3999 & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, 4000 & ISTATUS, REQUESTS, 4001 & COMM) 4002 IMPLICIT NONE 4003 INCLUDE 'mpif.h' 4004 INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM 4005 INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL 4006 REAL TMPD(IDSZ) 4007 INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) 4008 INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) 4009 REAL ISNDRCVA(ISNDRCVVOL) 4010 INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) 4011 REAL OSNDRCVA(OSNDRCVVOL) 4012 INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) 4013 INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) 4014 INTEGER COMM, IERROR 4015 INTEGER I, PID, OFFS, SZ, J, JS, JE, IID 4016 DO I=1,ISNDRCVNUM 4017 PID = INGHBPRCS(I) 4018 OFFS = ISNDRCVIA(PID) 4019 SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) 4020 CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, 4021 & MPI_REAL, PID-1, 4022 & ITAGCOMM,COMM,REQUESTS(I), IERROR) 4023 ENDDO 4024 DO I=1,OSNDRCVNUM 4025 PID = ONGHBPRCS(I) 4026 OFFS = OSNDRCVIA(PID) 4027 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 4028 JS = OSNDRCVIA(PID) 4029 JE = OSNDRCVIA(PID+1) - 1 4030 DO J=JS, JE 4031 IID = OSNDRCVJA(J) 4032 OSNDRCVA(J) = TMPD(IID) 4033 ENDDO 4034 CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, 4035 & ITAGCOMM, COMM, IERROR) 4036 ENDDO 4037 IF(ISNDRCVNUM > 0) THEN 4038 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 4039 ENDIF 4040 DO I=1,ISNDRCVNUM 4041 PID = INGHBPRCS(I) 4042 JS = ISNDRCVIA(PID) 4043 JE = ISNDRCVIA(PID+1)-1 4044 DO J=JS,JE 4045 IID = ISNDRCVJA(J) 4046 TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) 4047 ENDDO 4048 ENDDO 4049 DO I=1,OSNDRCVNUM 4050 PID = ONGHBPRCS(I) 4051 OFFS = OSNDRCVIA(PID) 4052 SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 4053 CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, 4054 & MPI_REAL, PID-1, 4055 & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) 4056 ENDDO 4057 DO I=1,ISNDRCVNUM 4058 PID = INGHBPRCS(I) 4059 OFFS = ISNDRCVIA(PID) 4060 SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) 4061 JS = ISNDRCVIA(PID) 4062 JE = ISNDRCVIA(PID+1) -1 4063 DO J=JS, JE 4064 IID = ISNDRCVJA(J) 4065 ISNDRCVA(J) = TMPD(IID) 4066 ENDDO 4067 CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, 4068 & ITAGCOMM+1, COMM, IERROR) 4069 ENDDO 4070 IF(OSNDRCVNUM > 0) THEN 4071 CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 4072 ENDIF 4073 DO I=1,OSNDRCVNUM 4074 PID = ONGHBPRCS(I) 4075 JS = OSNDRCVIA(PID) 4076 JE = OSNDRCVIA(PID+1) - 1 4077 DO J=JS,JE 4078 IID = OSNDRCVJA(J) 4079 TMPD(IID)=OSNDRCVA(J) 4080 ENDDO 4081 ENDDO 4082 RETURN 4083 END SUBROUTINE SMUMPS_656 4084 SUBROUTINE SMUMPS_655(MYID, NUMPROCS, COMM, 4085 & IRN_loc, JCN_loc, NZ_loc, 4086 & IPARTVEC, ISZ, 4087 & IWRK, IWSZ) 4088 IMPLICIT NONE 4089 EXTERNAL SMUMPS_703 4090 INTEGER MYID, NUMPROCS, COMM 4091 INTEGER NZ_loc, ISZ, IWSZ 4092 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 4093 INTEGER IPARTVEC(ISZ) 4094 INTEGER IWRK(IWSZ) 4095 INCLUDE 'mpif.h' 4096 INTEGER I 4097 INTEGER OP, IERROR 4098 INTEGER IR, IC 4099 IF(NUMPROCS.NE.1) THEN 4100 CALL MPI_OP_CREATE(SMUMPS_703, .TRUE., OP, IERROR) 4101 CALL SMUMPS_668(IWRK, 4*ISZ, ISZ) 4102 DO I=1,ISZ 4103 IWRK(2*I-1) = 0 4104 IWRK(2*I) = MYID 4105 ENDDO 4106 DO I=1,NZ_loc 4107 IR = IRN_loc(I) 4108 IC = JCN_loc(I) 4109 IF((IR.GE.1).AND.(IR.LE.ISZ).AND. 4110 & (IC.GE.1).AND.(IC.LE.ISZ)) THEN 4111 IWRK(2*IR-1) = IWRK(2*IR-1) + 1 4112 IWRK(2*IC-1) = IWRK(2*IC-1) + 1 4113 ENDIF 4114 ENDDO 4115 CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, 4116 & MPI_2INTEGER, OP, COMM, IERROR) 4117 DO I=1,ISZ 4118 IPARTVEC(I) = IWRK(2*I+2*ISZ) 4119 ENDDO 4120 CALL MPI_OP_FREE(OP, IERROR) 4121 ELSE 4122 DO I=1,ISZ 4123 IPARTVEC(I) = 0 4124 ENDDO 4125 ENDIF 4126 RETURN 4127 END SUBROUTINE SMUMPS_655 4128 SUBROUTINE SMUMPS_673(MYID, NUMPROCS, ISZ, IPARTVEC, 4129 & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, 4130 & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) 4131 IMPLICIT NONE 4132 INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ 4133 INTEGER ISNDRCVNUM, ISNDRCVVOL 4134 INTEGER OSNDRCVNUM, OSNDRCVVOL 4135 INTEGER COMM 4136 INTEGER INDX(NZ_loc), OINDX(NZ_loc) 4137 INTEGER IPARTVEC(ISZ) 4138 INTEGER IWRK(IWRKSZ) 4139 INTEGER SNDSZ(NUMPROCS) 4140 INTEGER RCVSZ(NUMPROCS) 4141 INCLUDE 'mpif.h' 4142 INTEGER I 4143 INTEGER IIND, IIND2, PIND 4144 INTEGER IERROR 4145 DO I=1,NUMPROCS 4146 SNDSZ(I) = 0 4147 RCVSZ(I) = 0 4148 ENDDO 4149 DO I=1,IWRKSZ 4150 IWRK(I) = 0 4151 ENDDO 4152 DO I=1,NZ_loc 4153 IIND = INDX(I) 4154 IIND2 = OINDX(I) 4155 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) 4156 & .AND.(IIND2.LE.ISZ)) THEN 4157 PIND = IPARTVEC(IIND) 4158 IF(PIND .NE. MYID) THEN 4159 IF(IWRK(IIND).EQ.0) THEN 4160 IWRK(IIND) = 1 4161 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 4162 ENDIF 4163 ENDIF 4164 IIND = OINDX(I) 4165 PIND = IPARTVEC(IIND) 4166 IF(PIND .NE. MYID) THEN 4167 IF(IWRK(IIND).EQ.0) THEN 4168 IWRK(IIND) = 1 4169 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 4170 ENDIF 4171 ENDIF 4172 ENDIF 4173 ENDDO 4174 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, 4175 & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 4176 ISNDRCVNUM = 0 4177 ISNDRCVVOL = 0 4178 OSNDRCVNUM = 0 4179 OSNDRCVVOL = 0 4180 DO I=1, NUMPROCS 4181 IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 4182 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) 4183 IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 4184 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) 4185 ENDDO 4186 RETURN 4187 END SUBROUTINE SMUMPS_673 4188 SUBROUTINE SMUMPS_663(MYID, NUMPROCS, COMM, 4189 & IRN_loc, JCN_loc, NZ_loc, 4190 & PARTVEC, N, 4191 & INUMMYR, 4192 & IWRK, IWSZ) 4193 IMPLICIT NONE 4194 INTEGER MYID, NUMPROCS, NZ_loc, N 4195 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 4196 INTEGER PARTVEC(N) 4197 INTEGER INUMMYR 4198 INTEGER IWSZ 4199 INTEGER IWRK(IWSZ) 4200 INTEGER COMM 4201 INTEGER I, IR, IC 4202 INUMMYR = 0 4203 DO I=1,N 4204 IWRK(I) = 0 4205 IF(PARTVEC(I).EQ.MYID) THEN 4206 IWRK(I)=1 4207 INUMMYR = INUMMYR + 1 4208 ENDIF 4209 ENDDO 4210 DO I=1,NZ_loc 4211 IR = IRN_loc(I) 4212 IC = JCN_loc(I) 4213 IF((IR.GE.1).AND.(IR.LE.N).AND. 4214 & ((IC.GE.1).AND.(IC.LE.N))) THEN 4215 IF(IWRK(IR) .EQ. 0) THEN 4216 IWRK(IR)= 1 4217 INUMMYR = INUMMYR + 1 4218 ENDIF 4219 ENDIF 4220 IF((IR.GE.1).AND.(IR.LE.N).AND. 4221 & ((IC.GE.1).AND.(IC.LE.N))) THEN 4222 IF(IWRK(IC).EQ.0) THEN 4223 IWRK(IC)= 1 4224 INUMMYR = INUMMYR + 1 4225 ENDIF 4226 ENDIF 4227 ENDDO 4228 RETURN 4229 END SUBROUTINE SMUMPS_663 4230 INTEGER FUNCTION SMUMPS_742(D, N, INDXR, INDXRSZ, 4231 & EPS, COMM) 4232 IMPLICIT NONE 4233 INCLUDE 'mpif.h' 4234 INTEGER N, INDXRSZ 4235 REAL D(N) 4236 INTEGER INDXR(INDXRSZ) 4237 REAL EPS 4238 INTEGER COMM 4239 EXTERNAL SMUMPS_744 4240 INTEGER SMUMPS_744 4241 INTEGER GLORES, MYRESR, MYRES 4242 INTEGER IERR 4243 MYRESR = SMUMPS_744(D, N, INDXR, INDXRSZ, EPS) 4244 MYRES = 2*MYRESR 4245 CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, 4246 & MPI_SUM, COMM, IERR) 4247 SMUMPS_742 = GLORES 4248 RETURN 4249 END FUNCTION SMUMPS_742 4250 SUBROUTINE SMUMPS_661(MYID, NUMPROCS,COMM, 4251 & IRN_loc, JCN_loc, NZ_loc, 4252 & PARTVEC, N, 4253 & MYROWINDICES, INUMMYR, 4254 & IWRK, IWSZ ) 4255 IMPLICIT NONE 4256 INTEGER MYID, NUMPROCS, NZ_loc, N 4257 INTEGER INUMMYR, IWSZ 4258 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) 4259 INTEGER PARTVEC(N) 4260 INTEGER MYROWINDICES(INUMMYR) 4261 INTEGER IWRK(IWSZ) 4262 INTEGER COMM 4263 INTEGER I, IR, IC, ITMP, MAXMN 4264 MAXMN = N 4265 DO I=1,N 4266 IWRK(I) = 0 4267 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 4268 ENDDO 4269 DO I=1,NZ_loc 4270 IR = IRN_loc(I) 4271 IC = JCN_loc(I) 4272 IF((IR.GE.1).AND.(IR.LE.N).AND. 4273 & ((IC.GE.1).AND.(IC.LE.N))) THEN 4274 IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 4275 ENDIF 4276 IF((IR.GE.1).AND.(IR.LE.N).AND. 4277 & ((IC.GE.1).AND.(IC.LE.N))) THEN 4278 IF(IWRK(IC) .EQ.0) IWRK(IC)=1 4279 ENDIF 4280 ENDDO 4281 ITMP = 1 4282 DO I=1,N 4283 IF(IWRK(I).EQ.1) THEN 4284 MYROWINDICES(ITMP) = I 4285 ITMP = ITMP + 1 4286 ENDIF 4287 ENDDO 4288 RETURN 4289 END SUBROUTINE SMUMPS_661 4290 SUBROUTINE SMUMPS_692(MYID, NUMPROCS, ISZ, IPARTVEC, 4291 & NZ_loc, INDX, OINDX, 4292 & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, 4293 & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, 4294 & SNDSZ, RCVSZ, IWRK, 4295 & ISTATUS, REQUESTS, 4296 & ITAGCOMM, COMM ) 4297 IMPLICIT NONE 4298 INCLUDE 'mpif.h' 4299 INTEGER MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL 4300 INTEGER INDX(NZ_loc), OINDX(NZ_loc) 4301 INTEGER IPARTVEC(ISZ) 4302 INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) 4303 INTEGER ISNDRCVIA(NUMPROCS+1) 4304 INTEGER ISNDRCVJA(ISNDVOL) 4305 INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) 4306 INTEGER OSNDRCVIA(NUMPROCS+1) 4307 INTEGER OSNDRCVJA(OSNDVOL) 4308 INTEGER SNDSZ(NUMPROCS) 4309 INTEGER RCVSZ(NUMPROCS) 4310 INTEGER IWRK(ISZ) 4311 INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) 4312 INTEGER REQUESTS(ISNDRCVNUM) 4313 INTEGER ITAGCOMM, COMM 4314 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR 4315 DO I=1,ISZ 4316 IWRK(I) = 0 4317 ENDDO 4318 OFFS = 1 4319 POFFS = 1 4320 DO I=1,NUMPROCS 4321 OSNDRCVIA(I) = OFFS + SNDSZ(I) 4322 IF(SNDSZ(I) > 0) THEN 4323 ONGHBPRCS(POFFS)=I 4324 POFFS = POFFS + 1 4325 ENDIF 4326 OFFS = OFFS + SNDSZ(I) 4327 ENDDO 4328 OSNDRCVIA(NUMPROCS+1) = OFFS 4329 DO I=1,NZ_loc 4330 IIND=INDX(I) 4331 IIND2 = OINDX(I) 4332 IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) 4333 & .AND.(IIND2.LE.ISZ)) THEN 4334 IPID=IPARTVEC(IIND) 4335 IF(IPID.NE.MYID) THEN 4336 IF(IWRK(IIND).EQ.0) THEN 4337 IWHERETO = OSNDRCVIA(IPID+1)-1 4338 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 4339 OSNDRCVJA(IWHERETO) = IIND 4340 IWRK(IIND) = 1 4341 ENDIF 4342 ENDIF 4343 IIND = OINDX(I) 4344 IPID=IPARTVEC(IIND) 4345 IF(IPID.NE.MYID) THEN 4346 IF(IWRK(IIND).EQ.0) THEN 4347 IWHERETO = OSNDRCVIA(IPID+1)-1 4348 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 4349 OSNDRCVJA(IWHERETO) = IIND 4350 IWRK(IIND) = 1 4351 ENDIF 4352 ENDIF 4353 ENDIF 4354 ENDDO 4355 CALL MPI_BARRIER(COMM,IERROR) 4356 OFFS = 1 4357 POFFS = 1 4358 ISNDRCVIA(1) = 1 4359 DO I=2,NUMPROCS+1 4360 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) 4361 IF(RCVSZ(I-1) > 0) THEN 4362 INGHBPRCS(POFFS)=I-1 4363 POFFS = POFFS + 1 4364 ENDIF 4365 OFFS = OFFS + RCVSZ(I-1) 4366 ENDDO 4367 CALL MPI_BARRIER(COMM,IERROR) 4368 DO I=1, ISNDRCVNUM 4369 IPID = INGHBPRCS(I) 4370 OFFS = ISNDRCVIA(IPID) 4371 ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) 4372 CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, 4373 & ITAGCOMM, COMM, REQUESTS(I),IERROR) 4374 ENDDO 4375 DO I=1,OSNDRCVNUM 4376 IPID = ONGHBPRCS(I) 4377 OFFS = OSNDRCVIA(IPID) 4378 ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) 4379 CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, 4380 & ITAGCOMM, COMM,IERROR) 4381 ENDDO 4382 IF(ISNDRCVNUM > 0) THEN 4383 CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) 4384 ENDIF 4385 CALL MPI_BARRIER(COMM,IERROR) 4386 RETURN 4387 END SUBROUTINE SMUMPS_692 4388 SUBROUTINE SMUMPS_628(IW,LREC,SIZE_FREE,XSIZE) 4389 INTEGER, intent(in) :: LREC, XSIZE 4390 INTEGER, intent(in) :: IW(LREC) 4391 INTEGER(8), intent(out):: SIZE_FREE 4392 INCLUDE 'mumps_headers.h' 4393 IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. 4394 & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN 4395 SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) 4396 ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. 4397 & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN 4398 SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ 4399 & IW(1+XSIZE + 3) - 4400 & ( IW(1+XSIZE + 4) 4401 & - IW(1+XSIZE + 3) ), 8) 4402 ELSE 4403 SIZE_FREE=0_8 4404 ENDIF 4405 RETURN 4406 END SUBROUTINE SMUMPS_628 4407 SUBROUTINE SMUMPS_629 4408 &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) 4409 IMPLICIT NONE 4410 INCLUDE 'mumps_headers.h' 4411 INTEGER(8) :: RCURRENT 4412 INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT 4413 INTEGER IW(LIW) 4414 INTEGER(8) :: RSIZE 4415 ICURRENT=NEXT 4416 CALL MUMPS_729( RSIZE, IW(ICURRENT + XXR) ) 4417 RCURRENT = RCURRENT - RSIZE 4418 NEXT=IW(ICURRENT+XXP) 4419 IW(IXXP)=ICURRENT+ISIZE2SHIFT 4420 IXXP=ICURRENT+XXP 4421 RETURN 4422 END SUBROUTINE SMUMPS_629 4423 SUBROUTINE SMUMPS_630(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) 4424 IMPLICIT NONE 4425 INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT 4426 INTEGER IW(LIW) 4427 INTEGER I 4428 IF (ISIZE2SHIFT.GT.0) THEN 4429 DO I=END2SHIFT,BEG2SHIFT,-1 4430 IW(I+ISIZE2SHIFT)=IW(I) 4431 ENDDO 4432 ELSE IF (ISIZE2SHIFT.LT.0) THEN 4433 DO I=BEG2SHIFT,END2SHIFT 4434 IW(I+ISIZE2SHIFT)=IW(I) 4435 ENDDO 4436 ENDIF 4437 RETURN 4438 END SUBROUTINE SMUMPS_630 4439 SUBROUTINE SMUMPS_631(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) 4440 IMPLICIT NONE 4441 INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT 4442 REAL A(LA) 4443 INTEGER(8) :: I 4444 IF (RSIZE2SHIFT.GT.0_8) THEN 4445 DO I=END2SHIFT,BEG2SHIFT,-1_8 4446 A(I+RSIZE2SHIFT)=A(I) 4447 ENDDO 4448 ELSE IF (RSIZE2SHIFT.LT.0_8) THEN 4449 DO I=BEG2SHIFT,END2SHIFT 4450 A(I+RSIZE2SHIFT)=A(I) 4451 ENDDO 4452 ENDIF 4453 RETURN 4454 END SUBROUTINE SMUMPS_631 4455 SUBROUTINE SMUMPS_94(N,KEEP28,IW,LIW,A,LA, 4456 & LRLU,IPTRLU,IWPOS, 4457 & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, 4458 & KEEP216,LRLUS,XSIZE) 4459 IMPLICIT NONE 4460 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS 4461 INTEGER N,LIW,KEEP28, 4462 & IWPOS,IWPOSCB,KEEP216,XSIZE 4463 INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28) 4464 INTEGER IW(LIW),PTRIST(KEEP28), 4465 & STEP(N), PIMASTER(KEEP28) 4466 REAL A(LA) 4467 INCLUDE 'mumps_headers.h' 4468 INTEGER ICURRENT, NEXT, STATE_NEXT 4469 INTEGER(8) :: RCURRENT 4470 INTEGER ISIZE2SHIFT 4471 INTEGER(8) :: RSIZE2SHIFT 4472 INTEGER IBEGCONTIG 4473 INTEGER(8) :: RBEGCONTIG 4474 INTEGER(8) :: RBEG2SHIFT, REND2SHIFT 4475 INTEGER INODE 4476 INTEGER(8) :: FREE_IN_REC 4477 INTEGER(8) :: RCURRENT_SIZE 4478 INTEGER IXXP 4479 ISIZE2SHIFT=0 4480 RSIZE2SHIFT=0_8 4481 ICURRENT = LIW-XSIZE+1 4482 RCURRENT = LA+1_8 4483 IBEGCONTIG = -999999 4484 RBEGCONTIG = -999999_8 4485 NEXT = IW(ICURRENT+XXP) 4486 IF (NEXT.EQ.TOP_OF_STACK) RETURN 4487 STATE_NEXT = IW(NEXT+XXS) 4488 IXXP = ICURRENT+XXP 4489 10 CONTINUE 4490 IF ( STATE_NEXT .NE. S_FREE .AND. 4491 & (KEEP216.EQ.3.OR. 4492 & (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND. 4493 & STATE_NEXT .NE. S_NOLCBCONTIG .AND. 4494 & STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND. 4495 & STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN 4496 CALL SMUMPS_629(IW,LIW, 4497 & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) 4498 CALL MUMPS_729(RCURRENT_SIZE, IW(ICURRENT+XXR)) 4499 IF (IBEGCONTIG < 0) THEN 4500 IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 4501 ENDIF 4502 IF (RBEGCONTIG < 0_8) THEN 4503 RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 4504 ENDIF 4505 INODE=IW(ICURRENT+XXN) 4506 IF (RSIZE2SHIFT .NE. 0_8) THEN 4507 IF (PTRAST(STEP(INODE)).EQ.RCURRENT) 4508 & PTRAST(STEP(INODE))= 4509 & PTRAST(STEP(INODE))+RSIZE2SHIFT 4510 IF (PAMASTER(STEP(INODE)).EQ.RCURRENT) 4511 & PAMASTER(STEP(INODE))= 4512 & PAMASTER(STEP(INODE))+RSIZE2SHIFT 4513 ENDIF 4514 IF (ISIZE2SHIFT .NE. 0) THEN 4515 IF (PTRIST(STEP(INODE)).EQ.ICURRENT) 4516 & PTRIST(STEP(INODE))= 4517 & PTRIST(STEP(INODE))+ISIZE2SHIFT 4518 IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) 4519 & PIMASTER(STEP(INODE))= 4520 & PIMASTER(STEP(INODE))+ISIZE2SHIFT 4521 ENDIF 4522 IF (NEXT .NE. TOP_OF_STACK) THEN 4523 STATE_NEXT=IW(NEXT+XXS) 4524 GOTO 10 4525 ENDIF 4526 ENDIF 4527 20 CONTINUE 4528 IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN 4529 CALL SMUMPS_630(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) 4530 IF (IXXP .LE.IBEGCONTIG) THEN 4531 IXXP=IXXP+ISIZE2SHIFT 4532 ENDIF 4533 ENDIF 4534 IBEGCONTIG=-9999 4535 25 CONTINUE 4536 IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN 4537 CALL SMUMPS_631(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) 4538 ENDIF 4539 RBEGCONTIG=-99999_8 4540 30 CONTINUE 4541 IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 4542 IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. 4543 & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. 4544 & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. 4545 & STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN 4546 IF ( KEEP216.eq.3) THEN 4547 WRITE(*,*) "Internal error 2 in SMUMPS_94" 4548 ENDIF 4549 IF (RBEGCONTIG > 0_8) GOTO 25 4550 CALL SMUMPS_629 4551 & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) 4552 IF (IBEGCONTIG < 0 ) THEN 4553 IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 4554 ENDIF 4555 CALL SMUMPS_628(IW(ICURRENT), 4556 & LIW-ICURRENT+1, 4557 & FREE_IN_REC, 4558 & XSIZE) 4559 IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN 4560 CALL SMUMPS_627(A,LA,RCURRENT, 4561 & IW(ICURRENT+XSIZE+2), 4562 & IW(ICURRENT+XSIZE), 4563 & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, 4564 & IW(ICURRENT+XXS),RSIZE2SHIFT) 4565 ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN 4566 CALL SMUMPS_627(A,LA,RCURRENT, 4567 & IW(ICURRENT+XSIZE+2), 4568 & IW(ICURRENT+XSIZE), 4569 & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 4570 & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), 4571 & IW(ICURRENT+XXS),RSIZE2SHIFT) 4572 ELSE IF (RSIZE2SHIFT .GT.0_8) THEN 4573 RBEG2SHIFT = RCURRENT + FREE_IN_REC 4574 CALL MUMPS_729(RCURRENT_SIZE, IW(ICURRENT+XXR)) 4575 REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 4576 CALL SMUMPS_631(A, LA, 4577 & RBEG2SHIFT, REND2SHIFT, 4578 & RSIZE2SHIFT) 4579 ENDIF 4580 INODE=IW(ICURRENT+XXN) 4581 IF (ISIZE2SHIFT.NE.0) THEN 4582 PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT 4583 ENDIF 4584 PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ 4585 & FREE_IN_REC 4586 CALL MUMPS_724(IW(ICURRENT+XXR),FREE_IN_REC) 4587 IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR. 4588 & STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN 4589 IW(ICURRENT+XXS)=S_NOLCLEANED 4590 ELSE 4591 IW(ICURRENT+XXS)=S_NOLCLEANED38 4592 ENDIF 4593 RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC 4594 RBEGCONTIG=-9999_8 4595 IF (NEXT.EQ.TOP_OF_STACK) THEN 4596 GOTO 20 4597 ELSE 4598 STATE_NEXT=IW(NEXT+XXS) 4599 ENDIF 4600 GOTO 30 4601 ENDIF 4602 IF (IBEGCONTIG.GT.0) THEN 4603 GOTO 20 4604 ENDIF 4605 40 CONTINUE 4606 IF (STATE_NEXT == S_FREE) THEN 4607 ICURRENT = NEXT 4608 CALL MUMPS_729( RCURRENT_SIZE, IW(ICURRENT + XXR) ) 4609 ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) 4610 RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE 4611 RCURRENT = RCURRENT - RCURRENT_SIZE 4612 NEXT=IW(ICURRENT+XXP) 4613 IF (NEXT.EQ.TOP_OF_STACK) THEN 4614 WRITE(*,*) "Internal error 1 in SMUMPS_94" 4615 CALL MUMPS_ABORT() 4616 ENDIF 4617 STATE_NEXT = IW(NEXT+XXS) 4618 GOTO 40 4619 ENDIF 4620 GOTO 10 4621 100 CONTINUE 4622 IWPOSCB = IWPOSCB + ISIZE2SHIFT 4623 LRLU = LRLU + RSIZE2SHIFT 4624 IPTRLU = IPTRLU + RSIZE2SHIFT 4625 RETURN 4626 END SUBROUTINE SMUMPS_94 4627 SUBROUTINE SMUMPS_632(IREC, IW, LIW, 4628 & ISIZEHOLE, RSIZEHOLE) 4629 IMPLICIT NONE 4630 INTEGER, intent(in) :: IREC, LIW 4631 INTEGER, intent(in) :: IW(LIW) 4632 INTEGER, intent(out):: ISIZEHOLE 4633 INTEGER(8), intent(out) :: RSIZEHOLE 4634 INTEGER IRECLOC 4635 INTEGER(8) :: RECLOC_SIZE 4636 INCLUDE 'mumps_headers.h' 4637 ISIZEHOLE=0 4638 RSIZEHOLE=0_8 4639 IRECLOC = IREC + IW( IREC+XXI ) 4640 10 CONTINUE 4641 CALL MUMPS_729(RECLOC_SIZE, IW(IRECLOC+XXR)) 4642 IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN 4643 ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) 4644 RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE 4645 IRECLOC=IRECLOC+IW(IRECLOC+XXI) 4646 GOTO 10 4647 ENDIF 4648 RETURN 4649 END SUBROUTINE SMUMPS_632 4650 SUBROUTINE SMUMPS_627(A, LA, RCURRENT, 4651 & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) 4652 IMPLICIT NONE 4653 INCLUDE 'mumps_headers.h' 4654 INTEGER LD, NROW, NCB, NELIM, NODESTATE 4655 INTEGER(8) :: ISHIFT 4656 INTEGER(8) :: LA, RCURRENT 4657 REAL A(LA) 4658 INTEGER I,J 4659 INTEGER(8) :: IOLD,INEW 4660 LOGICAL NELIM_ROOT 4661 NELIM_ROOT=.TRUE. 4662 IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN 4663 NELIM_ROOT=.FALSE. 4664 IF (NELIM.NE.0) THEN 4665 WRITE(*,*) "Internal error 1 IN SMUMPS_627" 4666 CALL MUMPS_ABORT() 4667 ENDIF 4668 ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN 4669 WRITE(*,*) "Internal error 2 in SMUMPS_627" 4670 & ,NODESTATE 4671 CALL MUMPS_ABORT() 4672 ENDIF 4673 IF (ISHIFT .LT.0_8) THEN 4674 WRITE(*,*) "Internal error 3 in SMUMPS_627",ISHIFT 4675 CALL MUMPS_ABORT() 4676 ENDIF 4677 IF (NELIM_ROOT) THEN 4678 IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) 4679 ELSE 4680 IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 4681 ENDIF 4682 INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 4683 DO I = NROW, 1, -1 4684 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. 4685 & .NOT. NELIM_ROOT) THEN 4686 IOLD=IOLD-int(LD,8) 4687 INEW=INEW-int(NCB,8) 4688 CYCLE 4689 ENDIF 4690 IF (NELIM_ROOT) THEN 4691 DO J=1,NELIM 4692 A( INEW ) = A( IOLD + int(- J + 1,8)) 4693 INEW = INEW - 1_8 4694 ENDDO 4695 ELSE 4696 DO J=1, NCB 4697 A( INEW ) = A( IOLD + int(- J + 1, 8)) 4698 INEW = INEW - 1_8 4699 ENDDO 4700 ENDIF 4701 IOLD = IOLD - int(LD,8) 4702 ENDDO 4703 IF (NELIM_ROOT) THEN 4704 NODESTATE=S_NOLCBCONTIG38 4705 ELSE 4706 NODESTATE=S_NOLCBCONTIG 4707 ENDIF 4708 RETURN 4709 END SUBROUTINE SMUMPS_627 4710 SUBROUTINE SMUMPS_700(BUFR,LBUFR, 4711 & LBUFR_BYTES, 4712 & root, N, IW, LIW, A, LA, 4713 & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, 4714 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, 4715 & COMP, LRLUS, IPOOL, LPOOL, LEAF, 4716 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 4717 & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, 4718 & ITLOC, RHS_MUMPS, 4719 & ND,PROCNODE_STEPS,SLAVEF ) 4720 USE SMUMPS_LOAD 4721 USE SMUMPS_OOC 4722 IMPLICIT NONE 4723 INCLUDE 'smumps_root.h' 4724 TYPE (SMUMPS_ROOT_STRUC ) :: root 4725 INTEGER KEEP( 500 ) 4726 INTEGER(8) KEEP8(150) 4727 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS 4728 INTEGER(8) :: PAMASTER(KEEP(28)) 4729 INTEGER(8) :: PTRAST(KEEP(28)) 4730 INTEGER(8) :: PTRFAC(KEEP(28)) 4731 INTEGER LBUFR, LBUFR_BYTES, N, LIW, 4732 & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, 4733 & IERROR 4734 INTEGER LPOOL, LEAF 4735 INTEGER IPOOL( LEAF ) 4736 INTEGER PTRIST(KEEP(28)) 4737 INTEGER PTLUST_S(KEEP(28)) 4738 INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) 4739 REAL :: RHS_MUMPS(KEEP(255)) 4740 INTEGER BUFR( LBUFR_BYTES ), NBPROCFILS( KEEP(28) ) 4741 INTEGER IW( LIW ) 4742 INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF 4743 REAL A( LA ) 4744 INTEGER MYID 4745 INTEGER FILS( N ), PTRAIW(N), PTRARW( N ) 4746 INTEGER INTARR(max(1,KEEP(14))) 4747 REAL DBLARR(max(1,KEEP(13))) 4748 INCLUDE 'mpif.h' 4749 INTEGER IERR 4750 INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI 4751 INTEGER(8) :: LREQA, POS_ROOT 4752 INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF 4753 INTEGER NSUPCOL_EFF 4754 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET 4755 INTEGER NSUPROW, NSUPCOL, BBPCBP 4756 INCLUDE 'mumps_headers.h' 4757 POSITION = 0 4758 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4759 & ISON, 1, MPI_INTEGER, COMM, IERR ) 4760 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4761 & NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR ) 4762 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4763 & NSUPROW, 1, MPI_INTEGER, COMM, IERR ) 4764 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4765 & NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR ) 4766 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4767 & NSUPCOL, 1, MPI_INTEGER, COMM, IERR ) 4768 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4769 & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, 4770 & COMM, IERR ) 4771 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4772 & NBROWS_PACKET, 1, MPI_INTEGER, 4773 & COMM, IERR ) 4774 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4775 & BBPCBP, 1, MPI_INTEGER, 4776 & COMM, IERR ) 4777 IF (BBPCBP .EQ. 1) THEN 4778 NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL 4779 NSUPCOL_EFF = 0 4780 ELSE 4781 NSUBSET_COL_EFF = NSUBSET_COL 4782 NSUPCOL_EFF = NSUPCOL 4783 ENDIF 4784 IROOT = KEEP( 38 ) 4785 IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR. 4786 & PTLUST_S( STEP(IROOT)) .NE. 0 ) THEN 4787 IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW 4788 & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. 4789 & NSUBSET_COL_EFF .EQ. 0)THEN 4790 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1 4791 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN 4792 IF (KEEP(201).EQ.1) THEN 4793 CALL SMUMPS_681(IERR) 4794 ELSEIF (KEEP(201).EQ.2) THEN 4795 CALL SMUMPS_580(IERR) 4796 ENDIF 4797 CALL SMUMPS_507( N, IPOOL, LPOOL, 4798 & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), 4799 & KEEP(80), KEEP(47), 4800 & STEP, IROOT + N) 4801 IF (KEEP(47) .GE. 3) THEN 4802 CALL SMUMPS_500( 4803 & IPOOL, LPOOL, 4804 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 4805 & MYID, STEP, N, ND, FILS ) 4806 ENDIF 4807 ENDIF 4808 ENDIF 4809 ELSE 4810 IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. 4811 & NSUBSET_ROW - NSUPROW .OR. 4812 & NSUBSET_ROW - NSUPROW.EQ.0 .OR. 4813 & NSUBSET_COL_EFF .EQ. 0)THEN 4814 NBPROCFILS(STEP( IROOT ) ) = -1 4815 ENDIF 4816 IF (KEEP(60) == 0) THEN 4817 CALL SMUMPS_284( root, IROOT, N, 4818 & IW, LIW, A, LA, 4819 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 4820 & LRLU, IPTRLU, 4821 & IWPOS, IWPOSCB, PTRIST, PTRAST, 4822 & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, 4823 & COMP, LRLUS, IFLAG, KEEP,KEEP8, IERROR ) 4824 IF ( IFLAG .LT. 0 ) RETURN 4825 ELSE 4826 PTRIST(STEP(IROOT)) = -55555 4827 ENDIF 4828 END IF 4829 IF (KEEP(60) .EQ.0) THEN 4830 IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN 4831 IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN 4832 LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) 4833 LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) 4834 POS_ROOT = PAMASTER(STEP( IROOT )) 4835 ELSE 4836 LOCAL_N = IW( PTLUST_S(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) 4837 LOCAL_M = IW( PTLUST_S(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) 4838 POS_ROOT = PTRFAC(IW(PTLUST_S(STEP(IROOT))+4+ 4839 & KEEP(IXSZ))) 4840 END IF 4841 ENDIF 4842 ELSE 4843 LOCAL_M = root%SCHUR_LLD 4844 LOCAL_N = root%SCHUR_NLOC 4845 ENDIF 4846 IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. 4847 & (min(NSUPROW, NSUPCOL) .GT. 0) 4848 & ) THEN 4849 LREQI = NSUPROW+NSUPCOL 4850 LREQA = int(NSUPROW,8) * int(NSUPCOL,8) 4851 IF ( (LREQA.NE.0_8) .AND. 4852 & (PTRIST(STEP(IROOT)).LT.0).AND. 4853 & KEEP(60)==0) THEN 4854 WRITE(*,*) ' Error in SMUMPS_700' 4855 CALL MUMPS_ABORT() 4856 ENDIF 4857 CALL SMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., 4858 & MYID,N,KEEP,KEEP8,IW,LIW,A, LA, 4859 & LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST, 4860 & PTRAST, STEP, PIMASTER, PAMASTER, 4861 & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., 4862 & COMP, LRLUS, IFLAG, IERROR 4863 & ) 4864 IF ( IFLAG .LT. 0 ) RETURN 4865 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4866 & IW( IWPOSCB + 1 ), LREQI, 4867 & MPI_INTEGER, COMM, IERR ) 4868 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4869 & A( IPTRLU + 1_8 ), int(LREQA), 4870 & MPI_REAL, COMM, IERR ) 4871 CALL SMUMPS_38( NSUPROW, NSUPCOL, 4872 & IW( IWPOSCB + 1 ), 4873 & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, 4874 & A( IPTRLU + 1_8 ), 4875 & A( 1 ), 4876 & LOCAL_M, LOCAL_N, 4877 & root%RHS_ROOT(1,1), root%RHS_NLOC, 4878 & 1) 4879 IWPOSCB = IWPOSCB + LREQI 4880 IPTRLU = IPTRLU + LREQA 4881 LRLU = LRLU + LREQA 4882 LRLUS = LRLUS + LREQA 4883 CALL SMUMPS_471(.FALSE.,.FALSE., 4884 & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 4885 ENDIF 4886 LREQI = NBROWS_PACKET + NSUBSET_COL_EFF 4887 LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) 4888 IF ( (LREQA.NE.0_8) .AND. 4889 & (PTRIST(STEP(IROOT)).LT.0).AND. 4890 & KEEP(60)==0) THEN 4891 WRITE(*,*) ' Error in SMUMPS_700' 4892 CALL MUMPS_ABORT() 4893 ENDIF 4894 IF (LREQA.NE.0_8) THEN 4895 CALL SMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., 4896 & MYID,N,KEEP,KEEP8,IW,LIW,A, LA, 4897 & LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST, 4898 & PTRAST, STEP, PIMASTER, PAMASTER, 4899 & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., 4900 & COMP, LRLUS, IFLAG, IERROR 4901 & ) 4902 IF ( IFLAG .LT. 0 ) RETURN 4903 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4904 & IW( IWPOSCB + 1 ), LREQI, 4905 & MPI_INTEGER, COMM, IERR ) 4906 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 4907 & A( IPTRLU + 1_8 ), int(LREQA), 4908 & MPI_REAL, COMM, IERR ) 4909 IF (KEEP(60).EQ.0) THEN 4910 CALL SMUMPS_38( NBROWS_PACKET, NSUBSET_COL_EFF, 4911 & IW( IWPOSCB + 1 ), 4912 & IW( IWPOSCB + NBROWS_PACKET + 1 ), 4913 & NSUPCOL_EFF, 4914 & A( IPTRLU + 1_8 ), 4915 & A( POS_ROOT ), LOCAL_M, LOCAL_N, 4916 & root%RHS_ROOT(1,1), root%RHS_NLOC, 4917 & 0) 4918 ELSE 4919 CALL SMUMPS_38( NBROWS_PACKET, NSUBSET_COL_EFF, 4920 & IW( IWPOSCB + 1 ), 4921 & IW( IWPOSCB + NBROWS_PACKET + 1 ), 4922 & NSUPCOL_EFF, 4923 & A( IPTRLU + 1_8 ), 4924 & root%SCHUR_POINTER(1), 4925 & root%SCHUR_LLD , root%SCHUR_NLOC, 4926 & root%RHS_ROOT(1,1), root%RHS_NLOC, 4927 & 0) 4928 ENDIF 4929 IWPOSCB = IWPOSCB + LREQI 4930 IPTRLU = IPTRLU + LREQA 4931 LRLU = LRLU + LREQA 4932 LRLUS = LRLUS + LREQA 4933 CALL SMUMPS_471(.FALSE.,.FALSE., 4934 & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 4935 ENDIF 4936 RETURN 4937 END SUBROUTINE SMUMPS_700 4938 SUBROUTINE SMUMPS_762(PIV, DETER, NEXP) 4939 IMPLICIT NONE 4940 REAL, intent(in) :: PIV 4941 REAL, intent(inout) :: DETER 4942 INTEGER, intent(inout) :: NEXP 4943 DETER=DETER*fraction(PIV) 4944 NEXP=NEXP+exponent(PIV)+exponent(DETER) 4945 DETER=fraction(DETER) 4946 RETURN 4947 END SUBROUTINE SMUMPS_762 4948 SUBROUTINE SMUMPS_761(PIV, DETER, NEXP) 4949 IMPLICIT NONE 4950 REAL, intent(in) :: PIV 4951 REAL, intent(inout) :: DETER 4952 INTEGER, intent(inout) :: NEXP 4953 DETER=DETER*fraction(PIV) 4954 NEXP=NEXP+exponent(PIV)+exponent(DETER) 4955 DETER=fraction(DETER) 4956 RETURN 4957 END SUBROUTINE SMUMPS_761 4958 SUBROUTINE SMUMPS_763(BLOCK_SIZE,IPIV, 4959 & MYROW, MYCOL, NPROW, NPCOL, 4960 & A, LOCAL_M, LOCAL_N, N, MYID, 4961 & DETER,NEXP,SYM) 4962 IMPLICIT NONE 4963 INTEGER, intent (in) :: SYM 4964 INTEGER, intent (inout) :: NEXP 4965 REAL, intent (inout) :: DETER 4966 INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, 4967 & LOCAL_M, LOCAL_N, N 4968 INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) 4969 REAL, intent(in) :: A(*) 4970 INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, 4971 & ROW_PROC,COL_PROC, K 4972 DI = LOCAL_M + 1 4973 NBLOCK = ( N - 1 ) / BLOCK_SIZE 4974 DO IBLOCK = 0, NBLOCK 4975 ROW_PROC = mod( IBLOCK, NPROW ) 4976 IF ( MYROW.EQ.ROW_PROC ) THEN 4977 COL_PROC = mod( IBLOCK, NPCOL ) 4978 IF ( MYCOL.EQ.COL_PROC ) THEN 4979 ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE 4980 JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE 4981 I = ILOC + JLOC * LOCAL_M + 1 4982 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) 4983 & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M 4984 & + 1 4985 K=1 4986 DO WHILE ( I .LT. IMX ) 4987 CALL SMUMPS_762(A(I),DETER,NEXP) 4988 IF (SYM.NE.1) THEN 4989 IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN 4990 DETER = -DETER 4991 ENDIF 4992 ENDIF 4993 K = K + 1 4994 I = I + DI 4995 END DO 4996 END IF 4997 END IF 4998 END DO 4999 RETURN 5000 END SUBROUTINE SMUMPS_763 5001 SUBROUTINE SMUMPS_764( 5002 & COMM, DETER_IN, NEXP_IN, 5003 & DETER_OUT, NEXP_OUT, NPROCS) 5004 IMPLICIT NONE 5005 INTEGER, intent(in) :: COMM, NPROCS 5006 REAL, intent(in) :: DETER_IN 5007 INTEGER,intent(in) :: NEXP_IN 5008 REAL,intent(out):: DETER_OUT 5009 INTEGER,intent(out):: NEXP_OUT 5010 INTEGER :: IERR_MPI 5011 EXTERNAL SMUMPS_771 5012 INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP 5013 REAL :: INV(2) 5014 REAL :: OUTV(2) 5015 INCLUDE 'mpif.h' 5016 IF (NPROCS .EQ. 1) THEN 5017 DETER_OUT = DETER_IN 5018 NEXP_OUT = NEXP_IN 5019 RETURN 5020 ENDIF 5021 CALL MPI_TYPE_CONTIGUOUS(2, MPI_REAL, 5022 & TWO_SCALARS_TYPE, 5023 & IERR_MPI) 5024 CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) 5025 CALL MPI_OP_CREATE(SMUMPS_771, 5026 & .TRUE., 5027 & DETERREDUCE_OP, 5028 & IERR_MPI) 5029 INV(1)=DETER_IN 5030 INV(2)=real(NEXP_IN) 5031 CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, 5032 & DETERREDUCE_OP, COMM, IERR_MPI) 5033 CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) 5034 CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) 5035 DETER_OUT = OUTV(1) 5036 NEXP_OUT = int(OUTV(2)) 5037 RETURN 5038 END SUBROUTINE SMUMPS_764 5039 SUBROUTINE SMUMPS_771(INV, INOUTV, NEL, DATATYPE) 5040 IMPLICIT NONE 5041 INTEGER, INTENT(IN) :: NEL, DATATYPE 5042 REAL, INTENT(IN) :: INV ( 2 * NEL ) 5043 REAL, INTENT(INOUT) :: INOUTV ( 2 * NEL ) 5044 INTEGER I, TMPEXPIN, TMPEXPINOUT 5045 DO I = 1, NEL 5046 TMPEXPIN = int(INV (I*2)) 5047 TMPEXPINOUT = int(INOUTV(I*2)) 5048 CALL SMUMPS_762(INV(I*2-1), 5049 & INOUTV(I*2-1), 5050 & TMPEXPINOUT) 5051 TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN 5052 INOUTV(I*2) = real(TMPEXPINOUT) 5053 ENDDO 5054 RETURN 5055 END SUBROUTINE SMUMPS_771 5056 SUBROUTINE SMUMPS_765(DETER, NEXP) 5057 IMPLICIT NONE 5058 INTEGER, intent (inout) :: NEXP 5059 REAL, intent (inout) :: DETER 5060 DETER=DETER*DETER 5061 NEXP=NEXP+NEXP 5062 RETURN 5063 END SUBROUTINE SMUMPS_765 5064 SUBROUTINE SMUMPS_766(DETER, NEXP) 5065 IMPLICIT NONE 5066 INTEGER, intent (inout) :: NEXP 5067 REAL, intent (inout) :: DETER 5068 DETER=1.0E0/DETER 5069 NEXP=-NEXP 5070 RETURN 5071 END SUBROUTINE SMUMPS_766 5072 SUBROUTINE SMUMPS_767(DETER, N, VISITED, PERM) 5073 IMPLICIT NONE 5074 REAL, intent(inout) :: DETER 5075 INTEGER, intent(in) :: N 5076 INTEGER, intent(inout) :: VISITED(N) 5077 INTEGER, intent(in) :: PERM(N) 5078 INTEGER I, J, K 5079 K = 0 5080 DO I = 1, N 5081 IF (VISITED(I) .GT. N) THEN 5082 VISITED(I)=VISITED(I)-N-N-1 5083 CYCLE 5084 ENDIF 5085 J = PERM(I) 5086 DO WHILE (J.NE.I) 5087 VISITED(J) = VISITED(J) + N + N + 1 5088 K = K + 1 5089 J = PERM(J) 5090 ENDDO 5091 ENDDO 5092 IF (mod(K,2).EQ.1) THEN 5093 DETER = -DETER 5094 ENDIF 5095 RETURN 5096 END SUBROUTINE SMUMPS_767 5097 SUBROUTINE SMUMPS_224(NFRONT,NASS,IBEGKJI, LPIV, TIPIV, 5098 & N,INODE,IW,LIW,A,LA, 5099 & INOPV,NOFFW,IFLAG,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, 5100 & DKEEP,PIVNUL_LIST,LPN_LIST, 5101 & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, 5102 & PP_LastPIVRPTRFilled_L, 5103 & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, 5104 & PP_LastPIVRPTRFilled_U) 5105 USE MUMPS_OOC_COMMON 5106 IMPLICIT NONE 5107 INTEGER IBEGKJI, LPIV 5108 INTEGER TIPIV(LPIV) 5109 INTEGER(8) :: LA 5110 REAL A(LA) 5111 INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW 5112 REAL UU, SEUIL 5113 INTEGER IW(LIW) 5114 INTEGER IOLDPS 5115 INTEGER(8) :: POSELT 5116 INTEGER KEEP(500) 5117 INTEGER(8) KEEP8(150) 5118 INTEGER LPN_LIST 5119 INTEGER PIVNUL_LIST(LPN_LIST) 5120 REAL DKEEP(30) 5121 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, 5122 & PP_LastPIVRPTRFilled_L, 5123 & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, 5124 & PP_LastPIVRPTRFilled_U 5125 REAL SWOP 5126 INTEGER(8) :: APOS, IDIAG 5127 INTEGER(8) :: J1, J2, JJ, J3_8 5128 INTEGER(8) :: NFRONT8 5129 INTEGER ILOC 5130 REAL ZERO 5131 PARAMETER( ZERO = 0.0E0 ) 5132 REAL RZERO, RMAX, AMROW, ONE 5133 REAL PIVNUL 5134 REAL FIXA, CSEUIL 5135 INTEGER NPIV,NASSW,IPIV 5136 INTEGER NPIVP1,JMAX,J3,ISW,ISWPS1 5137 INTEGER ISWPS2,KSW, HF 5138 INCLUDE 'mumps_headers.h' 5139 INTEGER SMUMPS_IXAMAX 5140 INTRINSIC max 5141 DATA RZERO /0.0E0/ 5142 DATA ONE /1.0E0/ 5143 INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L 5144 INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U 5145 INTEGER XSIZE 5146 PIVNUL = DKEEP(1) 5147 FIXA = DKEEP(2) 5148 CSEUIL = SEUIL 5149 NFRONT8=int(NFRONT,8) 5150 XSIZE = KEEP(IXSZ) 5151 NPIV = IW(IOLDPS+1+XSIZE) 5152 HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE 5153 NPIVP1 = NPIV + 1 5154 IF (KEEP(201).EQ.1) THEN 5155 CALL SMUMPS_667(TYPEF_L, NBPANELS_L, 5156 & I_PIVRPTR_L, I_PIVR_L, 5157 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, 5158 & IW, LIW) 5159 CALL SMUMPS_667(TYPEF_U, NBPANELS_U, 5160 & I_PIVRPTR_U, I_PIVR_U, 5161 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, 5162 & IW, LIW) 5163 ENDIF 5164 ILOC = NPIVP1 - IBEGKJI + 1 5165 TIPIV(ILOC) = ILOC 5166 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 5167 IF(INOPV .EQ. -1) THEN 5168 APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) 5169 IDIAG = APOS 5170 IF(abs(A(APOS)).LT.SEUIL) THEN 5171 IF (real(A(APOS)) .GE. RZERO) THEN 5172 A(APOS) = CSEUIL 5173 ELSE 5174 A(APOS) = -CSEUIL 5175 ENDIF 5176 KEEP(98) = KEEP(98)+1 5177 ELSE IF (KEEP(258) .NE. 0) THEN 5178 CALL SMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) 5179 ENDIF 5180 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 5181 IF (KEEP(251).EQ.0) THEN 5182 CALL SMUMPS_680( IW(I_PIVRPTR_L), 5183 & NBPANELS_L, 5184 & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, 5185 & PP_LastPanelonDisk_L, 5186 & PP_LastPIVRPTRFilled_L) 5187 ENDIF 5188 CALL SMUMPS_680( IW(I_PIVRPTR_U), 5189 & NBPANELS_U, 5190 & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, 5191 & PP_LastPanelonDisk_U, 5192 & PP_LastPIVRPTRFilled_U) 5193 ENDIF 5194 GO TO 420 5195 ENDIF 5196 INOPV = 0 5197 DO 460 IPIV=NPIVP1,NASSW 5198 APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) 5199 JMAX = 1 5200 IF (UU.GT.RZERO) GO TO 340 5201 IF (A(APOS).EQ.ZERO) GO TO 630 5202 GO TO 380 5203 340 AMROW = RZERO 5204 J1 = APOS 5205 J2 = APOS +int(- NPIV + NASS - 1,8) 5206 J3 = NASS -NPIV 5207 JMAX = SMUMPS_IXAMAX(J3,A(J1),1) 5208 JJ = int(JMAX,8) + J1 - 1_8 5209 AMROW = abs(A(JJ)) 5210 RMAX = AMROW 5211 J1 = J2 + 1_8 5212 J2 = APOS +int(- NPIV + NFRONT - KEEP(253)- 1,8) 5213 IF (J2.LT.J1) GO TO 370 5214 DO 360 JJ=J1,J2 5215 RMAX = max(abs(A(JJ)),RMAX) 5216 360 CONTINUE 5217 370 IDIAG = APOS + int(IPIV - NPIVP1,8) 5218 IF (RMAX.LE.PIVNUL) THEN 5219 KEEP(109) = KEEP(109)+1 5220 ISW = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ)+ 5221 & IW(IOLDPS+5+KEEP(IXSZ))+IPIV-NPIVP1 5222 PIVNUL_LIST(KEEP(109)) = IW(ISW) 5223 IF(real(FIXA).GT.RZERO) THEN 5224 IF(real(A(IDIAG)) .GE. RZERO) THEN 5225 A(IDIAG) = FIXA 5226 ELSE 5227 A(IDIAG) = -FIXA 5228 ENDIF 5229 ELSE 5230 J1 = APOS 5231 J2 = APOS +int(- NPIV + NFRONT - KEEP(253) - 1,8) 5232 DO JJ=J1,J2 5233 A(JJ)= ZERO 5234 ENDDO 5235 A(IDIAG) = -FIXA 5236 ENDIF 5237 JMAX = IPIV - NPIV 5238 GOTO 385 5239 ENDIF 5240 IF (abs(A(IDIAG)).GT.max(UU*RMAX,SEUIL)) THEN 5241 JMAX = IPIV - NPIV 5242 GO TO 380 5243 ENDIF 5244 IF (AMROW.LE.max(UU*RMAX,SEUIL)) GO TO 460 5245 NOFFW = NOFFW + 1 5246 380 CONTINUE 5247 IF (KEEP(258).NE.0) THEN 5248 CALL SMUMPS_762( A(APOS+int(JMAX-1,8)), 5249 & DKEEP(6), 5250 & KEEP(259)) 5251 ENDIF 5252 385 CONTINUE 5253 IF (IPIV.EQ.NPIVP1) GO TO 400 5254 KEEP(260)=-KEEP(260) 5255 J1 = POSELT + int(NPIV,8)*NFRONT8 5256 J2 = J1 + NFRONT8 - 1_8 5257 J3_8 = POSELT + int(IPIV-1,8)*NFRONT8 5258 DO 390 JJ=J1,J2 5259 SWOP = A(JJ) 5260 A(JJ) = A(J3_8) 5261 A(J3_8) = SWOP 5262 J3_8 = J3_8 + 1_8 5263 390 CONTINUE 5264 ISWPS1 = IOLDPS + HF - 1 + NPIVP1 5265 ISWPS2 = IOLDPS + HF - 1 + IPIV 5266 ISW = IW(ISWPS1) 5267 IW(ISWPS1) = IW(ISWPS2) 5268 IW(ISWPS2) = ISW 5269 400 IF (JMAX.EQ.1) GO TO 420 5270 KEEP(260)=-KEEP(260) 5271 TIPIV(ILOC) = ILOC + JMAX - 1 5272 J1 = POSELT + int(NPIV,8) 5273 J2 = POSELT + int(NPIV + JMAX - 1,8) 5274 DO 410 KSW=1,NASS 5275 SWOP = A(J1) 5276 A(J1) = A(J2) 5277 A(J2) = SWOP 5278 J1 = J1 + NFRONT8 5279 J2 = J2 + NFRONT8 5280 410 CONTINUE 5281 ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 5282 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX 5283 ISW = IW(ISWPS1) 5284 IW(ISWPS1) = IW(ISWPS2) 5285 IW(ISWPS2) = ISW 5286 GO TO 420 5287 460 CONTINUE 5288 IF (NASSW.EQ.NASS) THEN 5289 INOPV = 1 5290 ELSE 5291 INOPV = 2 5292 ENDIF 5293 GO TO 430 5294 630 CONTINUE 5295 IFLAG = -10 5296 WRITE(*,*) 'NIV2:Detected 0 pivot, INODE,NPIV=',INODE,NPIV 5297 GOTO 430 5298 420 CONTINUE 5299 IF (KEEP(201).EQ.1) THEN 5300 IF (KEEP(251).EQ.0) THEN 5301 CALL SMUMPS_680( IW(I_PIVRPTR_L), 5302 & NBPANELS_L, 5303 & IW(I_PIVR_L), NASS, NPIVP1, IPIV, 5304 & PP_LastPanelonDisk_L, 5305 & PP_LastPIVRPTRFilled_L) 5306 ENDIF 5307 CALL SMUMPS_680( IW(I_PIVRPTR_U), 5308 & NBPANELS_U, 5309 & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, 5310 & PP_LastPanelonDisk_U, 5311 & PP_LastPIVRPTRFilled_U) 5312 ENDIF 5313 430 CONTINUE 5314 RETURN 5315 END SUBROUTINE SMUMPS_224 5316 SUBROUTINE SMUMPS_294( COMM_LOAD, ASS_IRECV, 5317 & N, INODE, FPERE, 5318 & IW, LIW, 5319 & IOLDPS, POSELT, A, LA, LDA_FS, 5320 & IBEGKJI, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC, 5321 & 5322 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 5323 & IFLAG, IERROR, IPOOL,LPOOL, 5324 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 5325 & LRLUS, COMP, 5326 & PTRIST, PTRAST, PTLUST_S, PTRFAC, 5327 & STEP, PIMASTER, PAMASTER, 5328 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 5329 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5330 & FILS, PTRARW, PTRAIW, 5331 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5332 & LPTRAR, NELT, FRTPTR, FRTELT, 5333 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 5334 USE SMUMPS_COMM_BUFFER 5335 USE SMUMPS_LOAD 5336 IMPLICIT NONE 5337 INCLUDE 'smumps_root.h' 5338 INCLUDE 'mpif.h' 5339 TYPE (SMUMPS_ROOT_STRUC) :: root 5340 INTEGER COMM_LOAD, ASS_IRECV 5341 INTEGER N, INODE, FPERE, LIW, IBEGKJI, IEND, LPIV, 5342 & IOLDPS, LDA_FS, NB_BLOC_FAC 5343 INTEGER(8) :: POSELT, LA 5344 INTEGER IW(LIW), TIPIV(LPIV) 5345 LOGICAL LASTBL 5346 REAL A(LA) 5347 INTEGER COMM, MYID, LBUFR, LBUFR_BYTES 5348 INTEGER NELT, LPTRAR 5349 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 5350 INTEGER KEEP(500) 5351 INTEGER(8) KEEP8(150) 5352 INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, 5353 & SLAVEF, ICNTL(40) 5354 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS 5355 INTEGER IWPOS, IWPOSCB, COMP 5356 INTEGER BUFR( LBUFR ), IPOOL(LPOOL), 5357 & ITLOC(N+KEEP(253)), FILS(N), 5358 & PTRARW(LPTRAR), PTRAIW(LPTRAR), 5359 & ND( KEEP(28) ), FRERE( KEEP(28) ) 5360 REAL :: RHS_MUMPS(KEEP(255)) 5361 INTEGER INTARR(max(1,KEEP(14))) 5362 INTEGER(8) :: PTRAST (KEEP(28)) 5363 INTEGER(8) :: PTRFAC (KEEP(28)) 5364 INTEGER(8) :: PAMASTER(KEEP(28)) 5365 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), 5366 & STEP(N), PIMASTER(KEEP(28)), 5367 & NSTK_S(KEEP(28)), 5368 & NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28)) 5369 INTEGER ISTEP_TO_INIV2(KEEP(71)), 5370 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 5371 DOUBLE PRECISION OPASSW, OPELIW 5372 REAL DBLARR(max(1,KEEP(13))) 5373 EXTERNAL SMUMPS_329 5374 INCLUDE 'mumps_headers.h' 5375 INTEGER(8) :: APOS, LREQA 5376 INTEGER NPIV, NCOL, PDEST, NSLAVES 5377 INTEGER IERR, LREQI 5378 INTEGER STATUS( MPI_STATUS_SIZE ) 5379 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 5380 DOUBLE PRECISION FLOP1,FLOP2 5381 NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) 5382 IF (NSLAVES.EQ.0) THEN 5383 WRITE(6,*) ' ERROR 1 in SMUMPS_294 ' 5384 CALL MUMPS_ABORT() 5385 ENDIF 5386 NPIV = IEND - IBEGKJI + 1 5387 NCOL = LDA_FS - IBEGKJI + 1 5388 APOS = POSELT + int(LDA_FS,8)*int(IBEGKJI-1,8) + 5389 & int(IBEGKJI - 1,8) 5390 IF (IBEGKJI > 0) THEN 5391 CALL MUMPS_511( LDA_FS, IBEGKJI-1, LPIV, 5392 & KEEP(50),2,FLOP1) 5393 ELSE 5394 FLOP1=0.0D0 5395 ENDIF 5396 CALL MUMPS_511( LDA_FS, IEND, LPIV, 5397 & KEEP(50),2,FLOP2) 5398 FLOP2 = FLOP1 - FLOP2 5399 CALL SMUMPS_190(1, .FALSE., FLOP2, KEEP,KEEP8) 5400 IF ((NPIV.GT.0) .OR. 5401 & ((NPIV.EQ.0).AND.(LASTBL)) ) THEN 5402 PDEST = IOLDPS + 6 + KEEP(IXSZ) 5403 IERR = -1 5404 IF ( NPIV .NE. 0 ) THEN 5405 NB_BLOC_FAC = NB_BLOC_FAC + 1 5406 END IF 5407 DO WHILE (IERR .EQ.-1) 5408 CALL SMUMPS_65( INODE, LDA_FS, NCOL, 5409 & NPIV, FPERE, LASTBL, TIPIV, A(APOS), 5410 & IW(PDEST), NSLAVES, KEEP(50), NB_BLOC_FAC, 5411 & COMM, IERR ) 5412 IF (IERR.EQ.-1) THEN 5413 BLOCKING = .FALSE. 5414 SET_IRECV = .TRUE. 5415 MESSAGE_RECEIVED = .FALSE. 5416 CALL SMUMPS_329( COMM_LOAD, ASS_IRECV, 5417 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 5418 & MPI_ANY_SOURCE, MPI_ANY_TAG, 5419 & STATUS, BUFR, LBUFR, 5420 & LBUFR_BYTES, 5421 & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, 5422 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5423 & PTLUST_S, PTRFAC, 5424 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 5425 & IERROR, COMM, 5426 & NBPROCFILS, 5427 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 5428 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 5429 & FILS, PTRARW, PTRAIW, 5430 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 5431 & LPTRAR, NELT, FRTPTR, FRTELT, 5432 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 5433 IF (MESSAGE_RECEIVED) POSELT = PTRAST(STEP(INODE)) 5434 IF ( IFLAG .LT. 0 ) GOTO 500 5435 ENDIF 5436 ENDDO 5437 IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN 5438 IF (IERR.EQ.-2) IFLAG = -17 5439 IF (IERR.EQ.-3) IFLAG = -20 5440 LREQA = int(NCOL,8)*int(NPIV,8) 5441 LREQI = NPIV + 6 + 2*NSLAVES 5442 CALL MUMPS_731( 5443 & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), 5444 & IERROR) 5445 GOTO 300 5446 ENDIF 5447 ENDIF 5448 GOTO 500 5449 300 CONTINUE 5450 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 5451 500 RETURN 5452 END SUBROUTINE SMUMPS_294 5453 SUBROUTINE SMUMPS_273( ROOT, 5454 & INODE, NELIM, NSLAVES, ROW_LIST, 5455 & COL_LIST, SLAVE_LIST, 5456 & 5457 & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, 5458 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 5459 & PTLUST_S, PTRFAC, 5460 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, 5461 & ITLOC, RHS_MUMPS, COMP, 5462 & IFLAG, IERROR, 5463 & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, 5464 & COMM,COMM_LOAD,FILS,ND ) 5465 USE SMUMPS_LOAD 5466 IMPLICIT NONE 5467 INCLUDE 'smumps_root.h' 5468 TYPE (SMUMPS_ROOT_STRUC) :: ROOT 5469 INTEGER INODE, NELIM, NSLAVES 5470 INTEGER KEEP( 500 ) 5471 INTEGER(8) KEEP8(150) 5472 INTEGER ROW_LIST(*), COL_LIST(*), 5473 & SLAVE_LIST(*) 5474 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA 5475 INTEGER IWPOS, IWPOSCB 5476 INTEGER N, LIW 5477 INTEGER IW( LIW ) 5478 REAL A( LA ) 5479 INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) 5480 INTEGER(8) :: PTRFAC(KEEP(28)) 5481 INTEGER(8) :: PTRAST(KEEP(28)) 5482 INTEGER(8) :: PAMASTER(KEEP(28)) 5483 INTEGER STEP(N), PIMASTER(KEEP(28)) 5484 INTEGER COMP 5485 INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) 5486 REAL :: RHS_MUMPS(KEEP(255)) 5487 INTEGER PROCNODE_STEPS( KEEP(28) ) 5488 INTEGER IFLAG, IERROR 5489 INTEGER LPOOL, LEAF 5490 INTEGER IPOOL( LPOOL ) 5491 INTEGER MYID, SLAVEF 5492 INTEGER COMM,COMM_LOAD,ND(KEEP(28)),FILS(N) 5493 INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, 5494 & NOINT 5495 INTEGER(8) :: NOREAL 5496 INCLUDE 'mumps_headers.h' 5497 INCLUDE 'mumps_tags.h' 5498 INTEGER MUMPS_330 5499 EXTERNAL MUMPS_330 5500 IROOT = KEEP(38) 5501 NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 5502 KEEP(42) = KEEP(42) + NELIM 5503 TYPE_INODE= MUMPS_330(PROCNODE_STEPS(STEP(INODE)), SLAVEF) 5504 IF (TYPE_INODE.EQ.1) THEN 5505 IF (NELIM.EQ.0) THEN 5506 KEEP(41) = KEEP(41) + 1 5507 ELSE 5508 KEEP(41) = KEEP(41) + 3 5509 ENDIF 5510 ELSE 5511 IF (NELIM.EQ.0) THEN 5512 KEEP(41) = KEEP(41) + NSLAVES 5513 ELSE 5514 KEEP(41) = KEEP(41) + 2*NSLAVES + 1 5515 ENDIF 5516 ENDIF 5517 IF (NELIM.EQ.0) THEN 5518 PIMASTER(STEP(INODE)) = 0 5519 ELSE 5520 NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) 5521 NOREAL= 0_8 5522 CALL SMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., 5523 & MYID,N,KEEP,KEEP8,IW,LIW, A, LA, 5524 & LRLU, IPTRLU,IWPOS,IWPOSCB, 5525 & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, 5526 & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., 5527 & COMP, LRLUS, IFLAG, IERROR 5528 & ) 5529 IF ( IFLAG .LT. 0 ) THEN 5530 WRITE(*,*) ' Failure in int space allocation in CB area ', 5531 & ' during assembly of root : SMUMPS_273', 5532 & ' size required was :', NOINT, 5533 & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES 5534 RETURN 5535 ENDIF 5536 PIMASTER(STEP( INODE )) = IWPOSCB + 1 5537 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 5538 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM 5539 IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM 5540 IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 5541 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 5542 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 5543 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES 5544 IF (NSLAVES.GT.0) THEN 5545 IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = 5546 & SLAVE_LIST(1:NSLAVES) 5547 ENDIF 5548 DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) 5549 IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) 5550 DEB_COL = DEB_ROW + NELIM 5551 IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) 5552 ENDIF 5553 IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN 5554 CALL SMUMPS_507(N, IPOOL, LPOOL, PROCNODE_STEPS, 5555 & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), 5556 & STEP, IROOT ) 5557 IF (KEEP(47) .GE. 3) THEN 5558 CALL SMUMPS_500( 5559 & IPOOL, LPOOL, 5560 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 5561 & MYID, STEP, N, ND, FILS ) 5562 ENDIF 5563 END IF 5564 RETURN 5565 END SUBROUTINE SMUMPS_273 5566 SUBROUTINE SMUMPS_363(N,FRERE, STEP, FILS, 5567 & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, 5568 & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55, 5569 & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M 5570 & ) 5571 IMPLICIT NONE 5572 INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD 5573 INTEGER FRERE(NSTEPS), FILS(N), STEP(N) 5574 INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) 5575 INTEGER K215,K234,K55 5576 INTEGER DAD(LDAD) 5577 LOGICAL USE_DAD 5578 INTEGER INFO(40) 5579 INTEGER SLAVEF,PROCNODE(NSTEPS) 5580 INTEGER :: SBTR_WHICH_M 5581 EXTERNAL MUMPS_275 5582 INTEGER MUMPS_275 5583 REAL PEAK 5584 REAL, DIMENSION(:), ALLOCATABLE :: COST_TRAV 5585 INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH 5586 INTEGER IFATH,IN,NSTK,INODE,I,allocok,LOCAL_PERM 5587 INTEGER(8) NCB 5588 INTEGER(8) NELIM,NFR 5589 INTEGER NFR4,NELIM4 5590 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB 5591 INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK 5592 INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP 5593 INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact 5594 INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 5595 INTEGER, DIMENSION (:), POINTER :: TAB 5596 INTEGER dernier,fin 5597 INTEGER cour,II 5598 INTEGER CB_current,CB_MAX,ROOT_OF_CUR_SBTR 5599 INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 5600 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT 5601 INTEGER(8) MEM_SIZE,FACT_SIZE,SUM,MEM_SEC_PERM,FACT_SIZE_T, 5602 & MEM_SIZE_T,TOTAL_MEM_SIZE,TMP_TOTAL_MEM_SIZE,TMP_SUM, 5603 & SIZECB, SIZECB_LASTSON 5604 INTEGER(8) TMP8 5605 LOGICAL SBTR_M 5606 INTEGER FIRST_LEAF,SIZE_SBTR 5607 EXTERNAL MUMPS_170,MUMPS_167 5608 LOGICAL MUMPS_170,MUMPS_167 5609 DOUBLE PRECISION COST_NODE 5610 INCLUDE 'mumps_headers.h' 5611 TOTAL_MEM_SIZE=0_8 5612 ROOT_OF_CUR_SBTR=0 5613 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. 5614 & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. 5615 & (PERM.EQ.5).OR.(PERM.EQ.6))THEN 5616 LOCAL_PERM=0 5617 ENDIF 5618 SBTR_M=.FALSE. 5619 MEM_SIZE=0_8 5620 FACT_SIZE=0_8 5621 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN 5622 WRITE(*,*) "Internal Error in SMUMPS_363",PERM 5623 CALL MUMPS_ABORT() 5624 END IF 5625 NBLEAF = NA(1) 5626 NBROOT = NA(2) 5627 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN 5628 IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN 5629 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN 5630 ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) 5631 IF (allocok > 0) THEN 5632 IF ( LP .GT. 0 ) 5633 & WRITE(LP,*)'Memory allocation error in 5634 & SMUMPS_363' 5635 INFO(1)=-7 5636 INFO(2)=NSTEPS 5637 RETURN 5638 ENDIF 5639 ENDIF 5640 ENDIF 5641 IF(PERM.NE.7)THEN 5642 ALLOCATE(M(NSTEPS),stat=allocok ) 5643 IF (allocok > 0) THEN 5644 IF ( LP .GT. 0 ) 5645 & WRITE(LP,*)'Memory allocation error 5646 &in SMUMPS_363' 5647 INFO(1)=-7 5648 INFO(2)=NSTEPS 5649 RETURN 5650 ENDIF 5651 ENDIF 5652 ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), 5653 & stat=allocok ) 5654 IF (allocok > 0) THEN 5655 IF ( LP .GT. 0 ) 5656 & WRITE(LP,*)'Memory allocation error in SMUMPS_363' 5657 INFO(1)=-7 5658 INFO(2)=NSTEPS 5659 RETURN 5660 ENDIF 5661 II=0 5662 DO I=1,NSTEPS 5663 TNSTK(I) = NE(I) 5664 IF(NE(I).GE.II) II=NE(I) 5665 ENDDO 5666 SIZE_TAB=max(II,NBROOT) 5667 ALLOCATE(SON(II), TEMP(II), 5668 & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) 5669 IF (allocok > 0) THEN 5670 IF ( LP .GT. 0 ) 5671 & WRITE(LP,*)'Memory allocation error in SMUMPS_363' 5672 INFO(1)=-7 5673 INFO(2)=NSTEPS 5674 RETURN 5675 ENDIF 5676 ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), 5677 & RESULT(SIZE_TAB),stat=allocok) 5678 IF (allocok > 0) THEN 5679 IF ( LP .GT. 0 ) 5680 & WRITE(LP,*)'Memory allocation error in SMUMPS_363' 5681 INFO(1)=-7 5682 INFO(2)=SIZE_TAB 5683 RETURN 5684 ENDIF 5685 IF(PERM.EQ.7) THEN 5686 GOTO 001 5687 ENDIF 5688 IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN 5689 ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) 5690 IF (allocok > 0) THEN 5691 IF ( LP .GT. 0 ) 5692 & WRITE(LP,*)'Memory allocation error 5693 & in SMUMPS_363' 5694 INFO(1)=-7 5695 INFO(2)=NSTEPS 5696 RETURN 5697 ENDIF 5698 COST_TRAV=0.0E0 5699 COST_NODE=0.0d0 5700 ENDIF 5701 IF(NBROOT.EQ.NBLEAF)THEN 5702 IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN 5703 WRITE(*,*)'Internal Error in reordertree:' 5704 WRITE(*,*)' problem with perm parameter in reordertree' 5705 CALL MUMPS_ABORT() 5706 ENDIF 5707 DO I=1,NBROOT 5708 TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) 5709 IPOOL(I)=NA(I+2+NBLEAF) 5710 M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) 5711 ENDDO 5712 CALL SMUMPS_462(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, 5713 & RESULT,T1,T2) 5714 GOTO 789 5715 ENDIF 5716 IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN 5717 ALLOCATE(DEPTH(NSTEPS),stat=allocok) 5718 IF (allocok > 0) THEN 5719 IF ( LP .GT. 0 ) 5720 & WRITE(LP,*)'Memory allocation error in 5721 & SMUMPS_363' 5722 INFO(1)=-7 5723 INFO(2)=NSTEPS 5724 RETURN 5725 ENDIF 5726 DEPTH=0 5727 NBROOT = NA(2) 5728 IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) 5729 fin=NBROOT 5730 LEAF=NA(1) 5731 499 CONTINUE 5732 INODE=IPOOL(fin) 5733 IF(INODE.LT.0)THEN 5734 WRITE(*,*)'Internal Error in reordertree INODE < 0 !' 5735 CALL MUMPS_ABORT() 5736 ENDIF 5737 IN=INODE 5738 4602 IN = FILS(IN) 5739 IF (IN .GT. 0 ) THEN 5740 GOTO 4602 5741 ENDIF 5742 IN=-IN 5743 DO I=1,NE(STEP(INODE)) 5744 SON(I)=IN 5745 IN=FRERE(STEP(IN)) 5746 ENDDO 5747 DO I=1,NE(STEP(INODE)) 5748 IPOOL(fin)=SON(I) 5749 DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 5750 SON(I)=0 5751 fin=fin+1 5752 ENDDO 5753 IF(NE(STEP(INODE)).EQ.0)THEN 5754 LEAF=LEAF-1 5755 ELSE 5756 fin=fin-1 5757 GOTO 499 5758 ENDIF 5759 fin=fin-1 5760 IF(fin.EQ.0) GOTO 489 5761 GOTO 499 5762 489 CONTINUE 5763 ENDIF 5764 DO I=1,NSTEPS 5765 M(I)=0_8 5766 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 5767 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN 5768 M_TOTAL(I)=0_8 5769 ENDIF 5770 ENDIF 5771 ENDDO 5772 DO I=1,NSTEPS 5773 fact(I)=0_8 5774 ENDDO 5775 IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) 5776 LEAF = NBLEAF + 1 5777 91 CONTINUE 5778 IF (LEAF.NE.1) THEN 5779 LEAF = LEAF -1 5780 INODE = IPOOL(LEAF) 5781 ENDIF 5782 96 CONTINUE 5783 NFR = int(ND(STEP(INODE)),8) 5784 NSTK = NE(STEP(INODE)) 5785 NELIM4 = 0 5786 IN = INODE 5787 101 NELIM4 = NELIM4 + 1 5788 IN = FILS(IN) 5789 IF (IN .GT. 0 ) GOTO 101 5790 NELIM=int(NELIM4,8) 5791 IF(NE(STEP(INODE)).EQ.0) THEN 5792 M(STEP(INODE))=NFR*NFR 5793 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 5794 M_TOTAL(STEP(INODE))=NFR*NFR 5795 ENDIF 5796 ENDIF 5797 IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN 5798 IF(MUMPS_170(PROCNODE(STEP(INODE)), 5799 & SLAVEF))THEN 5800 DEPTH(STEP(INODE))=0 5801 ENDIF 5802 ENDIF 5803 IF ( SYM .eq. 0 ) THEN 5804 fact(STEP(INODE))=fact(STEP(INODE))+ 5805 & (2_8*NFR*NELIM)-(NELIM*NELIM) 5806 ELSE 5807 fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM 5808 ENDIF 5809 IF (USE_DAD) THEN 5810 IFATH = DAD( STEP(INODE) ) 5811 ELSE 5812 IN = INODE 5813 113 IN = FRERE(IN) 5814 IF (IN.GT.0) GO TO 113 5815 IFATH = -IN 5816 ENDIF 5817 IF (IFATH.EQ.0) THEN 5818 NBROOT = NBROOT - 1 5819 IF (NBROOT.EQ.0) GOTO 116 5820 GOTO 91 5821 ELSE 5822 fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) 5823 IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN 5824 DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), 5825 & DEPTH(STEP(IFATH))) 5826 ENDIF 5827 ENDIF 5828 TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 5829 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN 5830 INODE = IFATH 5831 IN=INODE 5832 dernier=IN 5833 I=1 5834 5700 IN = FILS(IN) 5835 IF (IN .GT. 0 ) THEN 5836 dernier=IN 5837 I=I+1 5838 GOTO 5700 5839 ENDIF 5840 NCB=int(ND(STEP(INODE))-I,8) 5841 IN=-IN 5842 IF(PERM.NE.7)THEN 5843 DO I=1,NE(STEP(INODE)) 5844 SON(I)=IN 5845 TEMP(I)=IN 5846 IF(IN.GT.0) IN=FRERE(STEP(IN)) 5847 ENDDO 5848 ELSE 5849 DO I=NE(STEP(INODE)),1,-1 5850 SON(I)=IN 5851 TEMP(I)=IN 5852 IF(IN.GT.0) IN=FRERE(STEP(IN)) 5853 ENDDO 5854 ENDIF 5855 NFR = int(ND(STEP(INODE)),8) 5856 DO II=1,NE(STEP(INODE)) 5857 TAB1(II)=0_8 5858 TAB2(II)=0_8 5859 cour=SON(II) 5860 NELIM4=1 5861 151 cour=FILS(cour) 5862 IF(cour.GT.0) THEN 5863 NELIM4=NELIM4+1 5864 GOTO 151 5865 ENDIF 5866 NELIM=int(NELIM4,8) 5867 IF((SYM.EQ.0).OR.(K215.NE.0)) THEN 5868 SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) 5869 & *(int(ND(STEP(SON(II))),8)-NELIM) 5870 ELSE 5871 SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) 5872 & *(int(ND(STEP(SON(II))),8)- 5873 & NELIM+1_8)/2_8 5874 ENDIF 5875 IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN 5876 IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN 5877 TMP8=NFR 5878 TMP8=TMP8*TMP8 5879 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB 5880 TAB2(II)=SIZECB 5881 ELSE 5882 TAB1(II)=M(STEP(SON(II)))- SIZECB 5883 TAB2(II)=SIZECB 5884 ENDIF 5885 ENDIF 5886 IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN 5887 TAB1(II)=M(STEP(SON(II)))-SIZECB 5888 TAB1(II)=TAB1(II)-fact(STEP(SON(II))) 5889 TAB2(II)=SIZECB+fact(STEP(SON(II))) 5890 ENDIF 5891 IF(PERM.EQ.2)THEN 5892 IF (MUMPS_170(PROCNODE(STEP(INODE)), 5893 & SLAVEF))THEN 5894 TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB 5895 & -fact(STEP(SON(II))) 5896 TAB2(II)=SIZECB 5897 ELSE 5898 TAB1(II)=M(STEP(SON(II)))-SIZECB 5899 TAB2(II)=SIZECB 5900 ENDIF 5901 ENDIF 5902 IF(PERM.EQ.3)THEN 5903 IF (MUMPS_170(PROCNODE(STEP(INODE)), 5904 & SLAVEF))THEN 5905 TAB1(II)=M(STEP(SON(II)))-SIZECB 5906 TAB2(II)=SIZECB 5907 ELSE 5908 TAB1(II)=int(DEPTH(STEP(SON(II))),8) 5909 TAB2(II)=M(STEP(SON(II))) 5910 ENDIF 5911 ENDIF 5912 IF(PERM.EQ.4)THEN 5913 IF (MUMPS_170(PROCNODE(STEP(INODE)), 5914 & SLAVEF))THEN 5915 TAB1(II)=M(STEP(SON(II)))- 5916 & SIZECB-fact(STEP(SON(II))) 5917 TAB2(II)=SIZECB 5918 ELSE 5919 TAB1(II)=int(DEPTH(STEP(SON(II))),8) 5920 TAB2(II)=M(STEP(SON(II))) 5921 ENDIF 5922 ENDIF 5923 ENDDO 5924 CALL SMUMPS_462(SON,NE(STEP(INODE)),TAB1,TAB2, 5925 & LOCAL_PERM 5926 & ,RESULT,T1,T2) 5927 IF(PERM.EQ.0) THEN 5928 DO II=1,NE(STEP(INODE)) 5929 cour=TEMP(II) 5930 NELIM4=1 5931 153 cour=FILS(cour) 5932 IF(cour.GT.0) THEN 5933 NELIM4=NELIM4+1 5934 GOTO 153 5935 ENDIF 5936 NELIM=int(NELIM4,8) 5937 IF((SYM.EQ.0).OR.(K215.NE.0))THEN 5938 SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* 5939 & (int(ND(STEP(TEMP(II))),8)-NELIM) 5940 ELSE 5941 SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* 5942 & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 5943 ENDIF 5944 TAB1(II)=SIZECB 5945 ENDDO 5946 CALL SMUMPS_462(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, 5947 & RESULT,T1,T2) 5948 ENDIF 5949 IF(PERM.EQ.1) THEN 5950 DO II=1,NE(STEP(INODE)) 5951 cour=TEMP(II) 5952 NELIM4=1 5953 187 cour=FILS(cour) 5954 IF(cour.GT.0) THEN 5955 NELIM4=NELIM4+1 5956 GOTO 187 5957 ENDIF 5958 NELIM=int(NELIM4,8) 5959 IF((SYM.EQ.0).OR.(K215.NE.0))THEN 5960 SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* 5961 & (int(ND(STEP(TEMP(II))),8)-NELIM) 5962 ELSE 5963 SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* 5964 & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 5965 ENDIF 5966 TAB1(II)=SIZECB+fact(STEP(TEMP(II))) 5967 ENDDO 5968 CALL SMUMPS_462(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, 5969 & RESULT,T1,T2) 5970 ENDIF 5971 CONTINUE 5972 IFATH=INODE 5973 DO II=1,2 5974 SUM=0_8 5975 FACT_SIZE=0_8 5976 FACT_SIZE_T=0_8 5977 MEM_SIZE=0_8 5978 MEM_SIZE_T=0_8 5979 CB_MAX=0 5980 CB_current=0 5981 TMP_SUM=0_8 5982 IF(II.EQ.1) TAB=>SON 5983 IF(II.EQ.2) TAB=>TEMP 5984 DO I=1,NE(STEP(INODE)) 5985 cour=TAB(I) 5986 NELIM4=1 5987 149 cour=FILS(cour) 5988 IF(cour.GT.0) THEN 5989 NELIM4=NELIM4+1 5990 GOTO 149 5991 ENDIF 5992 NELIM=int(NELIM4, 8) 5993 NFR=int(ND(STEP(TAB(I))),8) 5994 IF((SYM.EQ.0).OR.(K215.NE.0))THEN 5995 SIZECB=(NFR-NELIM)*(NFR-NELIM) 5996 ELSE 5997 SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 5998 ENDIF 5999 MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) 6000 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 6001 MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ 6002 & SUM+ 6003 & FACT_SIZE_T)) 6004 FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) 6005 ENDIF 6006 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, 6007 & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) 6008 TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) 6009 SUM=SUM+SIZECB 6010 SIZECB_LASTSON = SIZECB 6011 IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN 6012 FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) 6013 ENDIF 6014 ENDDO 6015 IF((SYM.EQ.0).OR.(K215.NE.0))THEN 6016 SIZECB=NCB*NCB 6017 ELSE 6018 SIZECB=(NCB*(NCB+1_8))/2_8 6019 ENDIF 6020 IF (K234.NE.0 .AND. K55.EQ.0) THEN 6021 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, 6022 & ( ( int(ND(STEP(IFATH)),8) 6023 & * int(ND(STEP(IFATH)),8) ) 6024 & + SUM-SIZECB_LASTSON+TMP_SUM ) 6025 & ) 6026 ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN 6027 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, 6028 & ( ( int(ND(STEP(IFATH)),8) 6029 & * int(ND(STEP(IFATH)),8) ) 6030 & + SUM + TMP_SUM ) 6031 & ) 6032 ELSE 6033 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, 6034 & ( ( int(ND(STEP(IFATH)),8) 6035 & * int(ND(STEP(IFATH)),8)) 6036 & + max(SUM,SIZECB) + TMP_SUM ) 6037 & ) 6038 ENDIF 6039 IF(II.EQ.1)THEN 6040 TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE 6041 ENDIF 6042 IF(II.EQ.1)THEN 6043 IF (K234.NE.0 .AND. K55.EQ.0) THEN 6044 M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) 6045 & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ 6046 & FACT_SIZE)) 6047 ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN 6048 M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) 6049 & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) 6050 ELSE 6051 M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) 6052 & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) 6053 ENDIF 6054 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 6055 M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, 6056 & ((int(ND(STEP(IFATH)),8) 6057 & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ 6058 & FACT_SIZE_T)) 6059 ENDIF 6060 ENDIF 6061 IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. 6062 & (PERM.EQ.5).OR.(PERM.EQ.6).OR. 6063 & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN 6064 MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) 6065 & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) 6066 ENDIF 6067 IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN 6068 MEM_SEC_PERM=huge(MEM_SEC_PERM) 6069 ENDIF 6070 ENDDO 6071 IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN 6072 TAB=>TEMP 6073 ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN 6074 WRITE(*,*)'Probleme dans reorder!!!!' 6075 CALL MUMPS_ABORT() 6076 ELSE 6077 TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE 6078 TAB=>SON 6079 ENDIF 6080 DO I=NE(STEP(INODE)),1,-1 6081 IF(I.EQ.NE(STEP(INODE))) THEN 6082 FILS(dernier)=-TAB(I) 6083 dernier=TAB(I) 6084 GOTO 222 6085 ENDIF 6086 IF(I.EQ.1) THEN 6087 FRERE(STEP(dernier))=TAB(I) 6088 FRERE(STEP(TAB(I)))=-INODE 6089 GOTO 222 6090 ENDIF 6091 IF(I.GT.1) THEN 6092 FRERE(STEP(dernier))=TAB(I) 6093 dernier=TAB(I) 6094 GOTO 222 6095 ENDIF 6096 222 CONTINUE 6097 ENDDO 6098 GOTO 96 6099 ELSE 6100 GOTO 91 6101 ENDIF 6102 116 CONTINUE 6103 NBROOT = NA(2) 6104 IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) 6105 IF (PERM.eq.1) THEN 6106 DO I=1,NBROOT 6107 TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) 6108 TAB1(I)=-TAB1(I) 6109 ENDDO 6110 CALL SMUMPS_462(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, 6111 & RESULT,T1,T2) 6112 IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) 6113 ENDIF 6114 001 CONTINUE 6115 fin=NBROOT 6116 LEAF=NA(1) 6117 FIRST_LEAF=-9999 6118 SIZE_SBTR=0 6119 999 CONTINUE 6120 INODE=IPOOL(fin) 6121 IF(INODE.LT.0)THEN 6122 WRITE(*,*)'Internal Error in reordertree INODE < 0 !' 6123 CALL MUMPS_ABORT() 6124 ENDIF 6125 IN=INODE 6126 5602 IN = FILS(IN) 6127 IF (IN .GT. 0 ) THEN 6128 dernier=IN 6129 GOTO 5602 6130 ENDIF 6131 IN=-IN 6132 IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN 6133 IF(SLAVEF.NE.1)THEN 6134 IF (USE_DAD) THEN 6135 IFATH=DAD(INODE) 6136 ELSE 6137 IN = INODE 6138 395 IN = FRERE(IN) 6139 IF (IN.GT.0) GO TO 395 6140 IFATH = -IN 6141 ENDIF 6142 NFR4 = ND(STEP(INODE)) 6143 NFR = int(NFR4,8) 6144 NELIM4 = 0 6145 IN = INODE 6146 396 NELIM4 = NELIM4 + 1 6147 IN = FILS(IN) 6148 IF (IN .GT. 0 ) GOTO 396 6149 NELIM=int(NELIM4,8) 6150 IF((SYM.EQ.0).OR.(K215.NE.0))THEN 6151 SIZECB=(NFR-NELIM)*(NFR-NELIM) 6152 ELSE 6153 SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 6154 ENDIF 6155 CALL MUMPS_511(NFR4,NELIM4,NELIM4, 6156 & SYM,1,COST_NODE) 6157 IF(IFATH.NE.0)THEN 6158 IF(MUMPS_167(PROCNODE(STEP(INODE)),SLAVEF))THEN 6159 COST_TRAV(STEP(INODE))=COST_TRAV(STEP( 6160 & ROOT_OF_CUR_SBTR)) 6161 ELSE 6162 COST_TRAV(STEP(INODE))=real(COST_NODE)+ 6163 & COST_TRAV(STEP(IFATH))+ 6164 & real(SIZECB*18_8) 6165 ENDIF 6166 ELSE 6167 COST_TRAV(STEP(INODE))=real(COST_NODE) 6168 ENDIF 6169 ENDIF 6170 ENDIF 6171 DO I=1,NE(STEP(INODE)) 6172 TEMP(I)=IN 6173 IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN 6174 IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_170( 6175 & PROCNODE(STEP(INODE)),SLAVEF)))THEN 6176 NFR4 = ND(STEP(INODE)) 6177 NFR = int(NFR4,8) 6178 NELIM4 = 0 6179 II = TEMP(I) 6180 845 NELIM4 = NELIM4 + 1 6181 II = FILS(II) 6182 IF (II .GT. 0 ) GOTO 845 6183 NELIM=int(NELIM4,8) 6184 CALL MUMPS_511(NFR4,NELIM4,NELIM4, 6185 & SYM,1,COST_NODE) 6186 TAB1(I)=int(real(COST_NODE)+ 6187 & COST_TRAV(STEP(INODE)),8) 6188 TAB2(I)=0_8 6189 ELSE 6190 SON(I)=IN 6191 ENDIF 6192 ELSE 6193 SON(I)=IN 6194 ENDIF 6195 IN=FRERE(STEP(IN)) 6196 ENDDO 6197 IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN 6198 IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_170( 6199 & PROCNODE(STEP(INODE)),SLAVEF)))THEN 6200 CALL SMUMPS_462(TEMP,NE(STEP(INODE)),TAB1,TAB2, 6201 & LOCAL_PERM 6202 & ,RESULT,T1,T2) 6203 TAB=>TEMP 6204 DO I=NE(STEP(INODE)),1,-1 6205 IF(I.EQ.NE(STEP(INODE))) THEN 6206 FILS(dernier)=-TAB(I) 6207 dernier=TAB(I) 6208 GOTO 221 6209 ENDIF 6210 IF(I.EQ.1) THEN 6211 FRERE(STEP(dernier))=TAB(I) 6212 FRERE(STEP(TAB(I)))=-INODE 6213 GOTO 221 6214 ENDIF 6215 IF(I.GT.1) THEN 6216 FRERE(STEP(dernier))=TAB(I) 6217 dernier=TAB(I) 6218 GOTO 221 6219 ENDIF 6220 221 CONTINUE 6221 SON(NE(STEP(INODE))-I+1)=TAB(I) 6222 ENDDO 6223 ENDIF 6224 ENDIF 6225 DO I=1,NE(STEP(INODE)) 6226 IPOOL(fin)=SON(I) 6227 SON(I)=0 6228 fin=fin+1 6229 ENDDO 6230 IF(NE(STEP(INODE)).EQ.0)THEN 6231 IF(PERM.NE.7)THEN 6232 NA(LEAF+2)=INODE 6233 ENDIF 6234 LEAF=LEAF-1 6235 ELSE 6236 fin=fin-1 6237 GOTO 999 6238 ENDIF 6239 fin=fin-1 6240 IF(fin.EQ.0) THEN 6241 GOTO 789 6242 ENDIF 6243 GOTO 999 6244 789 CONTINUE 6245 IF(PERM.EQ.7) GOTO 5483 6246 NBROOT=NA(2) 6247 NBLEAF=NA(1) 6248 PEAK=0.0E0 6249 FACT_SIZE=0_8 6250 DO I=1,NBROOT 6251 PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) 6252 FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) 6253 ENDDO 6254 5483 CONTINUE 6255 DEALLOCATE(IPOOL) 6256 DEALLOCATE(fact) 6257 DEALLOCATE(TNSTK) 6258 DEALLOCATE(SON) 6259 DEALLOCATE(TAB2) 6260 DEALLOCATE(TAB1) 6261 DEALLOCATE(T1) 6262 DEALLOCATE(T2) 6263 DEALLOCATE(RESULT) 6264 DEALLOCATE(TEMP) 6265 IF(PERM.NE.7)THEN 6266 DEALLOCATE(M) 6267 ENDIF 6268 IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN 6269 DEALLOCATE(DEPTH) 6270 ENDIF 6271 IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN 6272 DEALLOCATE(COST_TRAV) 6273 ENDIF 6274 IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN 6275 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN 6276 DEALLOCATE(M_TOTAL) 6277 ENDIF 6278 ENDIF 6279 RETURN 6280 END SUBROUTINE SMUMPS_363 6281 SUBROUTINE SMUMPS_364(N,FRERE, STEP, FILS, 6282 & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, 6283 & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55, 6284 & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK 6285 & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, 6286 & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, 6287 & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID 6288 & ) 6289 IMPLICIT NONE 6290 INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD 6291 INTEGER FRERE(NSTEPS), FILS(N), STEP(N) 6292 INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) 6293 INTEGER K47,K81,K76,K215,K234,K55 6294 INTEGER DAD(LDAD) 6295 LOGICAL USE_DAD 6296 INTEGER INFO(40) 6297 INTEGER SLAVEF,PROCNODE(NSTEPS) 6298 DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) 6299 INTEGER :: SBTR_WHICH_M 6300 INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), 6301 & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), 6302 & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) 6303 EXTERNAL MUMPS_283,MUMPS_275 6304 LOGICAL MUMPS_283 6305 INTEGER MUMPS_275 6306 REAL PEAK 6307 INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), 6308 & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) 6309 INTEGER SIZE_COST_TRAV 6310 INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR 6311 REAL COST_TRAV(SIZE_COST_TRAV) 6312 INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH 6313 INTEGER IFATH,IN,INODE,I,allocok,LOCAL_PERM 6314 INTEGER(8) NELIM,NFR 6315 INTEGER NFR4,NELIM4 6316 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB 6317 INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK 6318 INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP 6319 INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact 6320 INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 6321 INTEGER x,dernier,fin,RANK_TRAV 6322 INTEGER II 6323 INTEGER ROOT_OF_CUR_SBTR 6324 INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 6325 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT 6326 INTEGER(8) MEM_SIZE,FACT_SIZE, 6327 & TOTAL_MEM_SIZE, 6328 & SIZECB 6329 LOGICAL SBTR_M 6330 INTEGER INDICE(SLAVEF),ID,FIRST_LEAF,SIZE_SBTR 6331 EXTERNAL MUMPS_170,MUMPS_167 6332 LOGICAL MUMPS_170,MUMPS_167 6333 DOUBLE PRECISION COST_NODE 6334 INTEGER CUR_DEPTH_FIRST_RANK 6335 INCLUDE 'mumps_headers.h' 6336 TOTAL_MEM_SIZE=0_8 6337 ROOT_OF_CUR_SBTR=0 6338 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. 6339 & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. 6340 & (PERM.EQ.5).OR.(PERM.EQ.6))THEN 6341 LOCAL_PERM=0 6342 ENDIF 6343 IF (K47 == 4 .OR. ((K47.GE.2).AND.(K81.GE. 1))) THEN 6344 DO I=1,SLAVEF 6345 INDICE(I)=1 6346 ENDDO 6347 DO I=1,SLAVEF 6348 DO x=1,SIZE_MEM_SBTR 6349 MEM_SUBTREE(x,I)=-1.0D0 6350 ENDDO 6351 ENDDO 6352 ENDIF 6353 SBTR_M=((K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1)))) 6354 MEM_SIZE=0_8 6355 FACT_SIZE=0_8 6356 IF ((PERM.GT.7).AND. 6357 & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN 6358 WRITE(*,*) "Internal Error in SMUMPS_363",PERM 6359 CALL MUMPS_ABORT() 6360 END IF 6361 NBLEAF = NA(1) 6362 NBROOT = NA(2) 6363 CUR_DEPTH_FIRST_RANK=1 6364 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN 6365 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 6366 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN 6367 ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) 6368 IF (allocok > 0) THEN 6369 IF ( LP .GT. 0 ) 6370 & WRITE(LP,*)'Memory allocation error in 6371 & SMUMPS_363' 6372 INFO(1)=-7 6373 INFO(2)=NSTEPS 6374 RETURN 6375 ENDIF 6376 ENDIF 6377 ENDIF 6378 ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), 6379 & TNSTK(NSTEPS), stat=allocok ) 6380 IF (allocok > 0) THEN 6381 IF ( LP .GT. 0 ) 6382 & WRITE(LP,*)'Memory allocation error in SMUMPS_363' 6383 INFO(1)=-7 6384 INFO(2)=NSTEPS 6385 RETURN 6386 ENDIF 6387 II=0 6388 DO I=1,NSTEPS 6389 TNSTK(I) = NE(I) 6390 IF(NE(I).GE.II) II=NE(I) 6391 ENDDO 6392 SIZE_TAB=max(II,NBROOT) 6393 ALLOCATE(SON(II), TEMP(II), 6394 & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) 6395 IF (allocok > 0) THEN 6396 IF ( LP .GT. 0 ) 6397 & WRITE(LP,*)'Memory allocation error in SMUMPS_363' 6398 INFO(1)=-7 6399 INFO(2)=NSTEPS 6400 RETURN 6401 ENDIF 6402 ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), 6403 & RESULT(SIZE_TAB),stat=allocok) 6404 IF (allocok > 0) THEN 6405 IF ( LP .GT. 0 ) 6406 & WRITE(LP,*)'Memory allocation error in SMUMPS_363' 6407 INFO(1)=-7 6408 INFO(2)=SIZE_TAB 6409 RETURN 6410 ENDIF 6411 IF(NBROOT.EQ.NBLEAF)THEN 6412 IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN 6413 WRITE(*,*)'Internal Error in reordertree:' 6414 WRITE(*,*)' problem with perm parameter in reordertree' 6415 CALL MUMPS_ABORT() 6416 ENDIF 6417 DO I=1,NBROOT 6418 TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) 6419 IPOOL(I)=NA(I+2+NBLEAF) 6420 M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) 6421 ENDDO 6422 CALL SMUMPS_462(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, 6423 & RESULT,T1,T2) 6424 GOTO 789 6425 ENDIF 6426 IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN 6427 ALLOCATE(DEPTH(NSTEPS),stat=allocok) 6428 IF (allocok > 0) THEN 6429 IF ( LP .GT. 0 ) 6430 & WRITE(LP,*)'Memory allocation error in 6431 & SMUMPS_363' 6432 INFO(1)=-7 6433 INFO(2)=NSTEPS 6434 RETURN 6435 ENDIF 6436 DEPTH=0 6437 NBROOT = NA(2) 6438 IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) 6439 fin=NBROOT 6440 LEAF=NA(1) 6441 499 CONTINUE 6442 INODE=IPOOL(fin) 6443 IF(INODE.LT.0)THEN 6444 WRITE(*,*)'Internal Error in reordertree INODE < 0 !' 6445 CALL MUMPS_ABORT() 6446 ENDIF 6447 IN=INODE 6448 4602 IN = FILS(IN) 6449 IF (IN .GT. 0 ) THEN 6450 GOTO 4602 6451 ENDIF 6452 IN=-IN 6453 DO I=1,NE(STEP(INODE)) 6454 SON(I)=IN 6455 IN=FRERE(STEP(IN)) 6456 ENDDO 6457 DO I=1,NE(STEP(INODE)) 6458 IPOOL(fin)=SON(I) 6459 DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 6460 SON(I)=0 6461 fin=fin+1 6462 ENDDO 6463 IF(NE(STEP(INODE)).EQ.0)THEN 6464 LEAF=LEAF-1 6465 ELSE 6466 fin=fin-1 6467 GOTO 499 6468 ENDIF 6469 fin=fin-1 6470 IF(fin.EQ.0) GOTO 489 6471 GOTO 499 6472 489 CONTINUE 6473 ENDIF 6474 IF(K76.EQ.4.OR.(K76.EQ.6))THEN 6475 RANK_TRAV=NSTEPS 6476 DEPTH_FIRST_TRAV=0 6477 DEPTH_FIRST_SEQ=0 6478 ENDIF 6479 IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN 6480 COST_TRAV=0.0E0 6481 COST_NODE=0.0d0 6482 ENDIF 6483 DO I=1,NSTEPS 6484 M(I)=0_8 6485 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 6486 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN 6487 M_TOTAL(I)=0_8 6488 ENDIF 6489 ENDIF 6490 ENDDO 6491 DO I=1,NSTEPS 6492 fact(I)=0_8 6493 ENDDO 6494 NBROOT = NA(2) 6495 NBLEAF = NA(1) 6496 IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) 6497 CONTINUE 6498 fin=NBROOT 6499 LEAF=NA(1) 6500 FIRST_LEAF=-9999 6501 SIZE_SBTR=0 6502 999 CONTINUE 6503 INODE=IPOOL(fin) 6504 IF(INODE.LT.0)THEN 6505 WRITE(*,*)'Internal Error in reordertree INODE < 0 !' 6506 CALL MUMPS_ABORT() 6507 ENDIF 6508 IF(SIZE_SBTR.NE.0)THEN 6509 IF(.NOT.MUMPS_167(PROCNODE(STEP(INODE)),SLAVEF))THEN 6510 IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN 6511 IF((SLAVEF.NE.1))THEN 6512 MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF 6513 MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR 6514 FIRST_LEAF=-9999 6515 SIZE_SBTR=0 6516 ENDIF 6517 ENDIF 6518 ENDIF 6519 ENDIF 6520 IF(MUMPS_283(PROCNODE(STEP(INODE)),SLAVEF))THEN 6521 ROOT_OF_CUR_SBTR=INODE 6522 ENDIF 6523 IF (K76.EQ.4)THEN 6524 IF(SLAVEF.NE.1)THEN 6525 WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV 6526 IF(MUMPS_167(PROCNODE(STEP(INODE)),SLAVEF))THEN 6527 DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( 6528 & ROOT_OF_CUR_SBTR)) 6529 ELSE 6530 DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV 6531 ENDIF 6532 RANK_TRAV=RANK_TRAV-1 6533 ENDIF 6534 ENDIF 6535 IF (K76.EQ.5)THEN 6536 IF(SLAVEF.NE.1)THEN 6537 IF (USE_DAD) THEN 6538 IFATH=DAD(INODE) 6539 ELSE 6540 IN = INODE 6541 395 IN = FRERE(IN) 6542 IF (IN.GT.0) GO TO 395 6543 IFATH = -IN 6544 ENDIF 6545 NFR4 = ND(STEP(INODE)) 6546 NFR = int(NFR4,8) 6547 NELIM4 = 0 6548 IN = INODE 6549 396 NELIM4 = NELIM4 + 1 6550 IN = FILS(IN) 6551 IF (IN .GT. 0 ) GOTO 396 6552 NELIM=int(NELIM4,8) 6553 IF((SYM.EQ.0).OR.(K215.NE.0))THEN 6554 SIZECB=(NFR-NELIM)*(NFR-NELIM) 6555 ELSE 6556 SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 6557 ENDIF 6558 CALL MUMPS_511(NFR4,NELIM4,NELIM4, 6559 & SYM,1,COST_NODE) 6560 IF(IFATH.NE.0)THEN 6561 IF(MUMPS_167(PROCNODE(STEP(INODE)),SLAVEF))THEN 6562 COST_TRAV(STEP(INODE))=COST_TRAV(STEP( 6563 & ROOT_OF_CUR_SBTR)) 6564 ELSE 6565 COST_TRAV(STEP(INODE))=real(COST_NODE)+ 6566 & COST_TRAV(STEP(IFATH))+ 6567 & real(SIZECB*18_8) 6568 ENDIF 6569 ELSE 6570 COST_TRAV(STEP(INODE))=real(COST_NODE) 6571 ENDIF 6572 IF(K76.EQ.5)THEN 6573 WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) 6574 ENDIF 6575 ENDIF 6576 ENDIF 6577 IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN 6578 IF((SLAVEF.NE.1).AND. 6579 & MUMPS_283(PROCNODE(STEP(INODE)),SLAVEF))THEN 6580 IF (NE(STEP(INODE)).NE.0) THEN 6581 ID=MUMPS_275(PROCNODE(STEP(INODE)),SLAVEF) 6582 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN 6583 MEM_SUBTREE(INDICE(ID+1),ID+1)= 6584 & dble(M_TOTAL(STEP(INODE))) 6585 ELSE 6586 MEM_SUBTREE(INDICE(ID+1),ID+1)= 6587 & dble(M(STEP(INODE))) 6588 ENDIF 6589 MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE 6590 INDICE(ID+1)=INDICE(ID+1)+1 6591 ENDIF 6592 ENDIF 6593 IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN 6594 ID=MUMPS_275(PROCNODE(STEP(INODE)),SLAVEF) 6595 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN 6596 MEM_SUBTREE(INDICE(ID+1),ID+1)= 6597 & dble(M_TOTAL(STEP(INODE))) 6598 ELSE 6599 MEM_SUBTREE(INDICE(ID+1),ID+1)= 6600 & dble(M(STEP(INODE))) 6601 ENDIF 6602 INDICE(ID+1)=INDICE(ID+1)+1 6603 ENDIF 6604 ENDIF 6605 IN=INODE 6606 5602 IN = FILS(IN) 6607 IF (IN .GT. 0 ) THEN 6608 dernier=IN 6609 GOTO 5602 6610 ENDIF 6611 IN=-IN 6612 DO I=1,NE(STEP(INODE)) 6613 IPOOL(fin)=IN 6614 IF(IN.GT.0) IN=FRERE(STEP(IN)) 6615 fin=fin+1 6616 ENDDO 6617 IF(NE(STEP(INODE)).EQ.0)THEN 6618 IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN 6619 IF(SLAVEF.NE.1)THEN 6620 IF(MUMPS_167(PROCNODE(STEP(INODE)),SLAVEF))THEN 6621 IF(FIRST_LEAF.EQ.-9999)THEN 6622 FIRST_LEAF=INODE 6623 ENDIF 6624 SIZE_SBTR=SIZE_SBTR+1 6625 ENDIF 6626 ENDIF 6627 ENDIF 6628 IF(PERM.NE.7)THEN 6629 NA(LEAF+2)=INODE 6630 ENDIF 6631 LEAF=LEAF-1 6632 ELSE 6633 fin=fin-1 6634 GOTO 999 6635 ENDIF 6636 fin=fin-1 6637 IF(fin.EQ.0) THEN 6638 IF(SIZE_SBTR.NE.0)THEN 6639 IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN 6640 IF((SLAVEF.NE.1))THEN 6641 MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF 6642 MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR 6643 FIRST_LEAF=-9999 6644 SIZE_SBTR=0 6645 ENDIF 6646 ENDIF 6647 ENDIF 6648 GOTO 789 6649 ENDIF 6650 GOTO 999 6651 789 CONTINUE 6652 IF(K76.EQ.6)THEN 6653 OOC_CUR_SBTR=1 6654 DO I=1,NSTEPS 6655 TNSTK(I) = NE(I) 6656 ENDDO 6657 NBROOT=NA(2) 6658 NBLEAF=NA(1) 6659 IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) 6660 LEAF = NBLEAF + 1 6661 9100 CONTINUE 6662 IF (LEAF.NE.1) THEN 6663 LEAF = LEAF -1 6664 INODE = IPOOL(LEAF) 6665 ENDIF 6666 9600 CONTINUE 6667 IF(SLAVEF.NE.1)THEN 6668 ID=MUMPS_275(PROCNODE(STEP(INODE)),SLAVEF) 6669 DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK 6670 DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE 6671 WRITE(*,*)ID,': INODE -> ',INODE,'DF =', 6672 & CUR_DEPTH_FIRST_RANK 6673 CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 6674 IF(MUMPS_170(PROCNODE(STEP(INODE)), 6675 & SLAVEF))THEN 6676 SBTR_ID(STEP(INODE))=OOC_CUR_SBTR 6677 ELSE 6678 SBTR_ID(STEP(INODE))=-9999 6679 ENDIF 6680 IF(MUMPS_283(PROCNODE(STEP(INODE)), 6681 & SLAVEF))THEN 6682 OOC_CUR_SBTR=OOC_CUR_SBTR+1 6683 ENDIF 6684 ENDIF 6685 IF (USE_DAD) THEN 6686 IFATH = DAD( STEP(INODE) ) 6687 ELSE 6688 IN = INODE 6689 1133 IN = FRERE(IN) 6690 IF (IN.GT.0) GO TO 1133 6691 IFATH = -IN 6692 ENDIF 6693 IF (IFATH.EQ.0) THEN 6694 NBROOT = NBROOT - 1 6695 IF (NBROOT.EQ.0) GOTO 1163 6696 GOTO 9100 6697 ENDIF 6698 TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 6699 IF(TNSTK(STEP(IFATH)).EQ.0) THEN 6700 INODE=IFATH 6701 GOTO 9600 6702 ELSE 6703 GOTO 9100 6704 ENDIF 6705 1163 CONTINUE 6706 ENDIF 6707 PEAK=0.0E0 6708 FACT_SIZE=0_8 6709 DO I=1,NBROOT 6710 PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) 6711 FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) 6712 ENDDO 6713 CONTINUE 6714 DEALLOCATE(IPOOL) 6715 DEALLOCATE(M) 6716 DEALLOCATE(fact) 6717 DEALLOCATE(TNSTK) 6718 DEALLOCATE(SON) 6719 DEALLOCATE(TAB2) 6720 DEALLOCATE(TAB1) 6721 DEALLOCATE(T1) 6722 DEALLOCATE(T2) 6723 DEALLOCATE(RESULT) 6724 DEALLOCATE(TEMP) 6725 IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN 6726 DEALLOCATE(DEPTH) 6727 ENDIF 6728 IF (SBTR_M.OR.(PERM.EQ.2)) THEN 6729 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN 6730 DEALLOCATE(M_TOTAL) 6731 ENDIF 6732 ENDIF 6733 RETURN 6734 END SUBROUTINE SMUMPS_364 6735 RECURSIVE SUBROUTINE SMUMPS_462(TAB,DIM,TAB1,TAB2,PERM, 6736 & RESULT,TEMP1,TEMP2) 6737 IMPLICIT NONE 6738 INTEGER DIM 6739 INTEGER(8) TAB1(DIM),TAB2(DIM) 6740 INTEGER(8) TEMP1(DIM),TEMP2(DIM) 6741 INTEGER TAB(DIM), PERM,RESULT(DIM) 6742 INTEGER I,J,I1,I2 6743 IF(DIM.EQ.1) THEN 6744 RESULT(1)=TAB(1) 6745 TEMP1(1)=TAB1(1) 6746 TEMP2(1)=TAB2(1) 6747 RETURN 6748 ENDIF 6749 I=DIM/2 6750 CALL SMUMPS_462(TAB(1),I,TAB1(1),TAB2(1),PERM, 6751 & RESULT(1),TEMP1(1),TEMP2(1)) 6752 CALL SMUMPS_462(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), 6753 & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) 6754 I1=1 6755 I2=I+1 6756 J=1 6757 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) 6758 IF((PERM.EQ.3))THEN 6759 IF(TEMP1(I1).LE.TEMP1(I2))THEN 6760 TAB(J)=RESULT(I1) 6761 TAB1(J)=TEMP1(I1) 6762 J=J+1 6763 I1=I1+1 6764 ELSE 6765 TAB(J)=RESULT(I2) 6766 TAB1(J)=TEMP1(I2) 6767 J=J+1 6768 I2=I2+1 6769 ENDIF 6770 GOTO 3 6771 ENDIF 6772 IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN 6773 IF (TEMP1(I1).GE.TEMP1(I2))THEN 6774 TAB(J)=RESULT(I1) 6775 TAB1(J)=TEMP1(I1) 6776 J=J+1 6777 I1=I1+1 6778 ELSE 6779 TAB(J)=RESULT(I2) 6780 TAB1(J)=TEMP1(I2) 6781 J=J+1 6782 I2=I2+1 6783 ENDIF 6784 GOTO 3 6785 ENDIF 6786 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN 6787 IF(TEMP1(I1).GT.TEMP1(I2))THEN 6788 TAB1(J)=TEMP1(I1) 6789 TAB2(J)=TEMP2(I1) 6790 TAB(J)=RESULT(I1) 6791 J=J+1 6792 I1=I1+1 6793 GOTO 3 6794 ENDIF 6795 IF(TEMP1(I1).LT.TEMP1(I2))THEN 6796 TAB1(J)=TEMP1(I2) 6797 TAB2(J)=TEMP2(I2) 6798 TAB(J)=RESULT(I2) 6799 J=J+1 6800 I2=I2+1 6801 GOTO 3 6802 ENDIF 6803 IF((TEMP1(I1).EQ.TEMP1(I2)))THEN 6804 IF(TEMP2(I1).LE.TEMP2(I2))THEN 6805 TAB1(J)=TEMP1(I1) 6806 TAB2(J)=TEMP2(I1) 6807 TAB(J)=RESULT(I1) 6808 J=J+1 6809 I1=I1+1 6810 ELSE 6811 TAB1(J)=TEMP1(I2) 6812 TAB2(J)=TEMP2(I2) 6813 TAB(J)=RESULT(I2) 6814 J=J+1 6815 I2=I2+1 6816 ENDIF 6817 ENDIF 6818 ENDIF 6819 3 CONTINUE 6820 ENDDO 6821 IF(I1.GT.I)THEN 6822 DO WHILE(I2.LE.DIM) 6823 TAB(J)=RESULT(I2) 6824 TAB1(J)=TEMP1(I2) 6825 TAB2(J)=TEMP2(I2) 6826 J=J+1 6827 I2=I2+1 6828 ENDDO 6829 ELSE 6830 IF(I2.GT.DIM)THEN 6831 DO WHILE(I1.LE.I) 6832 TAB1(J)=TEMP1(I1) 6833 TAB2(J)=TEMP2(I1) 6834 TAB(J)=RESULT(I1) 6835 J=J+1 6836 I1=I1+1 6837 ENDDO 6838 ENDIF 6839 ENDIF 6840 DO I=1,DIM 6841 TEMP1(I)=TAB1(I) 6842 TEMP2(I)=TAB2(I) 6843 RESULT(I)=TAB(I) 6844 ENDDO 6845 RETURN 6846 END SUBROUTINE SMUMPS_462 6847