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 48C $Id$ 49 SUBROUTINE MUMPS_419 (METRIC, JOB, COMPRESS, N, NBBUCK, 50 & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, 51 & LAST, NCMPA, DEGREE, 52 & WF, 53 & NEXT, W, HEAD, AGG4, 54 & SIZE_COMPLEM_LIST, 55 & COMPLEM_LIST) 56 IMPLICIT NONE 57 INTEGER, intent(in) :: METRIC, JOB, N, NBBUCK 58 LOGICAL, intent(in) :: COMPRESS 59 INTEGER IWLEN, PFREE, LEN(N), 60 & ELEN(N), LAST(N), NCMPA, DEGREE(N), NEXT(N), 61 & W(N) 62 INTEGER PE(N), IW(IWLEN), NV(N) 63 LOGICAL, intent(in) :: AGG4 64 INTEGER, intent(in) :: SIZE_COMPLEM_LIST 65 INTEGER, intent(in), optional :: 66 & COMPLEM_LIST(max(1,SIZE_COMPLEM_LIST)) 67 INTEGER HEAD(0:NBBUCK+1), WF(N) 68 INTEGER AMD, AMF1, AMF4MA41 69 PARAMETER (AMD=1, AMF1=2, AMF4MA41=4) 70 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 71 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 72 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 73 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, 74 & LASTD, NELME, N2, PAS 75 INTEGER MAXINT_N 76 INTEGER WF3, WF4 77 INTEGER(8) HASH, HMOD 78 DOUBLE PRECISION RMF, RMF1 79 DOUBLE PRECISION dummy 80 INTEGER idummy 81 LOGICAL SchurON 82 LOGICAL NOTDEFINEDAMD 83 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 84 INTRINSIC max, min, mod, huge 85 INTEGER TOTEL 86 NOTDEFINEDAMD = (METRIC.NE.AMD) 87 IF (N.EQ.1) THEN 88 ELEN(1) = 1 89 LAST(1) = 1 90 PE(1) = 0 91 NV(1) = 1 92 RETURN 93 ENDIF 94 IF (.NOT.present(COMPLEM_LIST)) SchurON=.FALSE. 95 IF ( SIZE_COMPLEM_LIST < 0 .OR. SIZE_COMPLEM_LIST > N ) THEN 96 WRITE(*,*) 'Internal MUMPS_419 ', SIZE_COMPLEM_LIST,N 97 CALL MUMPS_ABORT() 98 ENDIF 99 IF (JOB.EQ.2) THEN 100 SchurON = .FALSE. 101 ENDIF 102 IF (JOB.NE.2) THEN 103 SchurON = (SIZE_COMPLEM_LIST > 0) 104 IF ((JOB.EQ.1) .AND. (.NOT.SchurON) ) THEN 105 WRITE(6,*) ' WARNING MUMPS_419 on Options ', JOB 106 ENDIF 107 ENDIF 108 idummy = huge(idummy) - 1 109 dummy = dble(idummy) 110 N2 = -NBBUCK-1 111 PAS = max((N/8), 1) 112 WFLG = 2 113 MAXINT_N = huge(MAXINT_N) - N 114 NCMPA = 0 115 NEL = 0 116 HMOD = int(max (1, NBBUCK-1),kind=8) 117 DMAX = 0 118 MEM = PFREE - 1 119 MAXMEM = MEM 120 MINDEG = 0 121 LASTD = 0 122 HEAD(0:NBBUCK+1) = 0 123 DEGREE(1:N) = LEN(1:N) 124 LAST = 0 125 W(1:N) = 1 126 TOTEL = N 127 IF (.NOT.COMPRESS) THEN 128 NV = 1 129 ENDIF 130 IF (JOB.EQ.2) THEN 131 DO I = 1,SIZE_COMPLEM_LIST 132 X = COMPLEM_LIST(I) 133 ELEN(X) = -I 134 NV(X) = LEN(X)+1 135 ENDDO 136 NEL = NEL + SIZE_COMPLEM_LIST 137 ELSE 138 ELEN(1:N) = 0 139 DO K=1, SIZE_COMPLEM_LIST 140 I = COMPLEM_LIST(K) 141 DEGREE(I) = N2 142 IF ((LEN(I) .EQ.0).OR.(LEN(I).EQ.-N-1)) THEN 143 PE (I) = 0 144 LEN(I) = 0 145 ENDIF 146 DEG = NBBUCK + 1 147 IF (LASTD.EQ.0) THEN 148 LASTD = I 149 HEAD(DEG) = I 150 NEXT(I) = 0 151 LAST(I) = 0 152 ELSE 153 NEXT(LASTD) = I 154 LAST(I) = LASTD 155 LASTD = I 156 NEXT(I) = 0 157 ENDIF 158 ENDDO 159 ENDIF 160 IF(COMPRESS) THEN 161 TOTEL = 0 162 DO I=1,N 163 IF (ELEN(I).LT.0) CYCLE 164 IF (DEGREE(I).NE.N2) THEN 165 TOTEL = TOTEL + NV(I) 166 DEGREE(I) = ELEN(I) 167 DO J= PE(I)+ELEN(I), PE(I)+LEN(I)-1 168 DEGREE(I) = DEGREE(I) + NV(IW(J)) 169 ENDDO 170 ENDIF 171 ENDDO 172 ENDIF 173 RMF = dble(0) 174 DO I = 1, N 175 IF (ELEN(I).LT.0) CYCLE 176 DEG = DEGREE (I) 177 IF (DEG.EQ.N2) CYCLE 178 IF (DEG .GT. 0) THEN 179 IF (JOB.EQ.2) THEN 180 DEG = DEG - ELEN(I) 181 NVI = NV(I) 182 RMF = dble(0) 183 IF (ELEN(I).GT.0) THEN 184 DO J= PE(I), PE(I)+ELEN(I)-1 185 DEG = DEG + LEN(IW(J)) - NVI 186 IF (NOTDEFINEDAMD) THEN 187 RMF1 = dble( LEN(IW(J))) 188 RMF1 = (RMF1-dble(NVI))*(RMF1-dble(NVI)-1.0D0) 189 RMF = max(RMF, RMF1) 190 ENDIF 191 ENDDO 192 DEG = min(DEG, TOTEL-NEL-NV(I)) 193 ENDIF 194 ENDIF 195 IF ( 196 & ( (JOB.EQ.2).AND.NOTDEFINEDAMD) 197 & .OR. (METRIC.EQ.AMF4MA41) 198 & ) THEN 199 DEG = nint ( 200 & ( (dble(DEG)*dble(DEG-1)) - RMF ) / dble(2) ) 201 DEG = max (DEG,1) 202 ENDIF 203 IF (NOTDEFINEDAMD) THEN 204 WF(I) = DEG 205 IF (DEG.GT.N) THEN 206 DEG = min(((DEG-N)/PAS) + N , NBBUCK) 207 ENDIF 208 ELSE 209 DEGREE(I) = DEG 210 ENDIF 211 INEXT = HEAD (DEG) 212 IF (INEXT .NE. 0) LAST (INEXT) = I 213 NEXT (I) = INEXT 214 HEAD (DEG) = I 215 ELSE 216 NEL = NEL + NV(I) 217 ELEN (I) = -NEL 218 PE (I) = 0 219 W (I) = 0 220 ENDIF 221 ENDDO 222 NLEFT = TOTEL-NEL 223 30 IF ( ((NEL .LT. TOTEL).AND. (JOB.NE.1)) .OR. 224 & ((JOB.EQ.1).AND.(NEL.LT.TOTEL-SIZE_COMPLEM_LIST)) 225 & ) THEN 226 DO 40 DEG = MINDEG, NBBUCK 227 ME = HEAD (DEG) 228 IF (ME .GT. 0) GO TO 50 229 40 CONTINUE 230 50 MINDEG = DEG 231 IF (ME.LE.0) THEN 232 NCMPA = -N 233 CALL MUMPS_ABORT() 234 ENDIF 235 IF (DEG.GT.N) THEN 236 IF (NOTDEFINEDAMD) THEN 237 J = NEXT(ME) 238 K = WF(ME) 239 55 CONTINUE 240 IF (J.GT.0) THEN 241 IF (WF(J).LT.K) THEN 242 ME = J 243 K = WF(ME) 244 ENDIF 245 J= NEXT(J) 246 GOTO 55 247 ENDIF 248 ILAST = LAST(ME) 249 INEXT = NEXT(ME) 250 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 251 IF (ILAST .NE. 0) THEN 252 NEXT (ILAST) = INEXT 253 ELSE 254 HEAD (DEG) = INEXT 255 ENDIF 256 ELSE 257 WRITE(6,*) ' Internal error AMD, DEG>N ' 258 CALL MUMPS_ABORT() 259 ENDIF 260 ELSE 261 INEXT = NEXT (ME) 262 IF (INEXT .NE. 0) LAST (INEXT) = 0 263 HEAD (DEG) = INEXT 264 ENDIF 265 ELENME = ELEN (ME) 266 ELEN (ME) = - (NEL + 1) 267 NVPIV = NV (ME) 268 NEL = NEL + NVPIV 269 NV (ME) = -NVPIV 270 DEGME = 0 271 IF (ELENME .EQ. 0) THEN 272 PME1 = PE (ME) 273 PME2 = PME1 - 1 274 DO 60 P = PME1, PME1 + LEN (ME) - 1 275 I = IW (P) 276 NVI = NV (I) 277 IF (NVI .GT. 0) THEN 278 DEGME = DEGME + NVI 279 NV (I) = -NVI 280 PME2 = PME2 + 1 281 IW (PME2) = I 282 IF (DEGREE(I).NE.N2) THEN 283 ILAST = LAST (I) 284 INEXT = NEXT (I) 285 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 286 IF (ILAST .NE. 0) THEN 287 NEXT (ILAST) = INEXT 288 ELSE 289 IF (NOTDEFINEDAMD) THEN 290 IF (WF(I).GT.N) THEN 291 DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) 292 ELSE 293 DEG = WF(I) 294 ENDIF 295 HEAD (DEG) = INEXT 296 ELSE 297 HEAD (DEGREE (I)) = INEXT 298 ENDIF 299 ENDIF 300 ENDIF 301 ENDIF 302 60 CONTINUE 303 NEWMEM = 0 304 ELSE 305 P = PE (ME) 306 PME1 = PFREE 307 SLENME = LEN (ME) - ELENME 308 DO 120 KNT1 = 1, ELENME + 1 309 IF (KNT1 .GT. ELENME) THEN 310 E = ME 311 PJ = P 312 LN = SLENME 313 ELSE 314 E = IW (P) 315 P = P + 1 316 PJ = PE (E) 317 LN = LEN (E) 318 ENDIF 319 DO 110 KNT2 = 1, LN 320 I = IW (PJ) 321 PJ = PJ + 1 322 NVI = NV (I) 323 IF (NVI .GT. 0) THEN 324 IF (PFREE .GT. IWLEN) THEN 325 PE (ME) = P 326 LEN (ME) = LEN (ME) - KNT1 327 IF (LEN (ME) .EQ. 0) PE (ME) = 0 328 PE (E) = PJ 329 LEN (E) = LN - KNT2 330 IF (LEN (E) .EQ. 0) PE (E) = 0 331 NCMPA = NCMPA + 1 332 DO 70 J = 1, N 333 PN = PE (J) 334 IF (PN .GT. 0) THEN 335 PE (J) = IW (PN) 336 IW (PN) = -J 337 ENDIF 338 70 CONTINUE 339 PDST = 1 340 PSRC = 1 341 PEND = PME1 - 1 342 80 CONTINUE 343 IF (PSRC .LE. PEND) THEN 344 J = -IW (PSRC) 345 PSRC = PSRC + 1 346 IF (J .GT. 0) THEN 347 IW (PDST) = PE (J) 348 PE (J) = PDST 349 PDST = PDST + 1 350 LENJ = LEN (J) 351 DO 90 KNT3 = 0, LENJ - 2 352 IW (PDST + KNT3) = IW (PSRC + KNT3) 353 90 CONTINUE 354 PDST = PDST + LENJ - 1 355 PSRC = PSRC + LENJ - 1 356 ENDIF 357 GO TO 80 358 ENDIF 359 P1 = PDST 360 DO 100 PSRC = PME1, PFREE - 1 361 IW (PDST) = IW (PSRC) 362 PDST = PDST + 1 363 100 CONTINUE 364 PME1 = P1 365 PFREE = PDST 366 PJ = PE (E) 367 P = PE (ME) 368 ENDIF 369 DEGME = DEGME + NVI 370 NV (I) = -NVI 371 IW (PFREE) = I 372 PFREE = PFREE + 1 373 IF (DEGREE(I).NE.N2) THEN 374 ILAST = LAST (I) 375 INEXT = NEXT (I) 376 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 377 IF (ILAST .NE. 0) THEN 378 NEXT (ILAST) = INEXT 379 ELSE 380 IF (NOTDEFINEDAMD) THEN 381 IF (WF(I).GT.N) THEN 382 DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) 383 ELSE 384 DEG = WF(I) 385 ENDIF 386 HEAD (DEG) = INEXT 387 ELSE 388 HEAD(DEGREE(I)) = INEXT 389 ENDIF 390 ENDIF 391 ENDIF 392 ENDIF 393 110 CONTINUE 394 IF (E .NE. ME) THEN 395 PE (E) = -ME 396 W (E) = 0 397 ENDIF 398 120 CONTINUE 399 PME2 = PFREE - 1 400 NEWMEM = PFREE - PME1 401 MEM = MEM + NEWMEM 402 MAXMEM = max(MAXMEM, MEM) 403 ENDIF 404 DEGREE (ME) = DEGME 405 PE (ME) = PME1 406 LEN (ME) = PME2 - PME1 + 1 407 IF (WFLG .GT. MAXINT_N) THEN 408 DO 130 X = 1, N 409 IF (W (X) .NE. 0) W (X) = 1 410 130 CONTINUE 411 WFLG = 2 412 ENDIF 413 DO 150 PME = PME1, PME2 414 I = IW (PME) 415 IF (DEGREE(I).EQ.N2) GOTO 150 416 ELN = ELEN (I) 417 IF (ELN .GT. 0) THEN 418 NVI = -NV (I) 419 WNVI = WFLG - NVI 420 DO 140 P = PE (I), PE (I) + ELN - 1 421 E = IW (P) 422 WE = W (E) 423 IF (WE .GE. WFLG) THEN 424 WE = WE - NVI 425 ELSE IF (WE .NE. 0) THEN 426 WE = DEGREE (E) + WNVI 427 IF (NOTDEFINEDAMD) WF(E) = 0 428 ENDIF 429 W (E) = WE 430 140 CONTINUE 431 ENDIF 432 150 CONTINUE 433 DO 180 PME = PME1, PME2 434 I = IW (PME) 435 IF (DEGREE(I).EQ.N2) GOTO 180 436 P1 = PE (I) 437 P2 = P1 + ELEN (I) - 1 438 PN = P1 439 HASH = 0_8 440 DEG = 0 441 IF (NOTDEFINEDAMD) THEN 442 WF3 = 0 443 WF4 = 0 444 ENDIF 445 NVI = -NV(I) 446 DO 160 P = P1, P2 447 E = IW (P) 448 DEXT = W (E) - WFLG 449 IF (DEXT .GT. 0) THEN 450 IF (NOTDEFINEDAMD) THEN 451 IF ( WF(E) .EQ. 0 ) THEN 452 WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) 453 ENDIF 454 WF4 = WF4 + WF(E) 455 ENDIF 456 DEG = DEG + DEXT 457 IW (PN) = E 458 PN = PN + 1 459 HASH = HASH + int(E, kind=8) 460 ELSE IF (DEXT .EQ. 0) THEN 461 IF (.NOT.AGG4) THEN 462 IW (PN) = E 463 PN = PN + 1 464 HASH = HASH + int(E,kind=8) 465 ELSE 466 PE (E) = -ME 467 W (E) = 0 468 ENDIF 469 ENDIF 470 160 CONTINUE 471 ELEN (I) = PN - P1 + 1 472 P3 = PN 473 DO 170 P = P2 + 1, P1 + LEN (I) - 1 474 J = IW (P) 475 NVJ = NV (J) 476 IF (NVJ .GT. 0) THEN 477 DEG = DEG + NVJ 478 IF (NOTDEFINEDAMD) WF3 = WF3 + NVJ 479 IW (PN) = J 480 PN = PN + 1 481 HASH = HASH + int(J,kind=8) 482 ENDIF 483 170 CONTINUE 484 IF (DEGREE(I).EQ.N2) DEG = N2 485 IF ( (AGG4.AND.(DEG .EQ. 0)).OR. 486 & (ELEN(I).EQ.1 .AND. P3.EQ.PN) ) THEN 487 PE (I) = -ME 488 NVI = -NV (I) 489 DEGME = DEGME - NVI 490 NVPIV = NVPIV + NVI 491 NEL = NEL + NVI 492 NV (I) = 0 493 ELEN (I) = 0 494 ELSE 495 IF ( DEGREE (I).LT.DEG ) THEN 496 IF (NOTDEFINEDAMD) THEN 497 WF4 = 0 498 WF3 = 0 499 ENDIF 500 ELSE 501 DEGREE(I) = DEG 502 ENDIF 503 IF (NOTDEFINEDAMD) THEN 504 WF(I) = WF4 + 2*NVI*WF3 505 ENDIF 506 IW (PN) = IW (P3) 507 IW (P3) = IW (P1) 508 IW (P1) = ME 509 LEN (I) = PN - P1 + 1 510 HASH = mod (HASH, HMOD) + 1_8 511 J = HEAD (HASH) 512 IF (J .LE. 0) THEN 513 NEXT (I) = -J 514 HEAD (HASH) = -I 515 ELSE 516 NEXT (I) = LAST (J) 517 LAST (J) = I 518 ENDIF 519 LAST (I) = int(HASH,kind=kind(LAST)) 520 ENDIF 521 180 CONTINUE 522 DEGREE (ME) = DEGME 523 DMAX = max (DMAX, DEGME) 524 WFLG = WFLG + DMAX 525 IF (WFLG .GT. MAXINT_N) THEN 526 DO 190 X = 1, N 527 IF (W (X) .NE. 0) W (X) = 1 528 190 CONTINUE 529 WFLG = 2 530 ENDIF 531 DO 250 PME = PME1, PME2 532 I = IW (PME) 533 IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN 534 HASH = int(LAST (I),kind=8) 535 J = HEAD (HASH) 536 IF (J .EQ. 0) GO TO 250 537 IF (J .LT. 0) THEN 538 I = -J 539 HEAD (HASH) = 0 540 ELSE 541 I = LAST (J) 542 LAST (J) = 0 543 ENDIF 544 IF (I .EQ. 0) GO TO 250 545 200 CONTINUE 546 IF (NEXT (I) .NE. 0) THEN 547 LN = LEN (I) 548 ELN = ELEN (I) 549 DO 210 P = PE (I) + 1, PE (I) + LN - 1 550 W (IW (P)) = WFLG 551 210 CONTINUE 552 JLAST = I 553 J = NEXT (I) 554 220 CONTINUE 555 IF (J .NE. 0) THEN 556 IF (LEN (J) .NE. LN) GO TO 240 557 IF (ELEN (J) .NE. ELN) GO TO 240 558 DO 230 P = PE (J) + 1, PE (J) + LN - 1 559 IF (W (IW (P)) .NE. WFLG) GO TO 240 560 230 CONTINUE 561 PE (J) = -I 562 IF (NOTDEFINEDAMD) WF(I) = max(WF(I),WF(J)) 563 NV (I) = NV (I) + NV (J) 564 NV (J) = 0 565 ELEN (J) = 0 566 J = NEXT (J) 567 NEXT (JLAST) = J 568 GO TO 220 569 240 CONTINUE 570 JLAST = J 571 J = NEXT (J) 572 GO TO 220 573 ENDIF 574 WFLG = WFLG + 1 575 I = NEXT (I) 576 IF (I .NE. 0) GO TO 200 577 ENDIF 578 ENDIF 579 250 CONTINUE 580 P = PME1 581 NLEFT = TOTEL - NEL 582 DO 260 PME = PME1, PME2 583 I = IW (PME) 584 NVI = -NV (I) 585 IF (NVI .GT. 0) THEN 586 NV (I) = NVI 587 IF (DEGREE(I).NE.N2) THEN 588 DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) 589 IF (NOTDEFINEDAMD) THEN 590 IF(METRIC.EQ.AMF1) THEN 591 DEGREE(I) = DEG 592 RMF = dble(DEG)*dble(DEG-1) 593 & - dble(DEGME-NVI)*dble(DEGME-NVI-1) 594 ELSE 595 IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN 596 DEG = DEGREE(I) 597 RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) 598 & - dble(WF(I)) 599 DEGREE(I) = NLEFT - NVI 600 DEG = DEGREE(I) 601 RMF = dble(DEG)*dble(DEG-1) 602 & - dble(DEGME-NVI)*dble(DEGME-NVI-1) 603 RMF = min(RMF, RMF1) 604 ELSE 605 DEG = DEGREE(I) 606 DEGREE(I) = DEGREE (I) + DEGME - NVI 607 RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) 608 & - dble(WF(I)) 609 ENDIF 610 ENDIF 611 IF (METRIC.EQ.AMF4MA41) THEN 612 RMF = RMF / dble(2*NVI) 613 ELSE 614 RMF = RMF / dble(NVI+1) 615 ENDIF 616 IF (RMF.LT.dummy) THEN 617 WF(I) = int ( anint( RMF )) 618 ELSEIF (RMF / dble(N) .LT. dummy) THEN 619 WF(I) = int ( anint( RMF/dble(N) )) 620 ELSE 621 WF(I) = idummy 622 ENDIF 623 WF(I) = max(1,WF(I)) 624 DEG = WF(I) 625 IF (DEG.GT.N) THEN 626 DEG = min(((DEG-N)/PAS) + N , NBBUCK) 627 ENDIF 628 ELSE 629 DEGREE(I) = DEG 630 ENDIF 631 INEXT = HEAD (DEG) 632 IF (INEXT .NE. 0) LAST (INEXT) = I 633 NEXT (I) = INEXT 634 LAST (I) = 0 635 HEAD (DEG) = I 636 MINDEG = min (MINDEG, DEG) 637 ENDIF 638 IW (P) = I 639 P = P + 1 640 ENDIF 641 260 CONTINUE 642 NV (ME) = NVPIV + DEGME 643 LEN (ME) = P - PME1 644 IF (LEN (ME) .EQ. 0) THEN 645 PE (ME) = 0 646 W (ME) = 0 647 ENDIF 648 IF (NEWMEM .NE. 0) THEN 649 PFREE = P 650 MEM = MEM - NEWMEM + LEN (ME) 651 ENDIF 652 GO TO 30 653 ENDIF 654 IF (NEL.LT.TOTEL) THEN 655 IF (JOB.EQ.1) THEN 656 DO I = 1,SIZE_COMPLEM_LIST 657 X = COMPLEM_LIST(I) 658 ELEN(X) = -(N-SIZE_COMPLEM_LIST+I) 659 NV(X) = 1 660 PE(X) = 0 661 ENDDO 662 NEL = NEL+ SIZE_COMPLEM_LIST 663 ELSE 664 DO DEG = MINDEG, NBBUCK+1 665 ME = HEAD (DEG) 666 IF (ME .GT. 0) GO TO 51 667 ENDDO 668 51 MINDEG = DEG 669 NELME = -(NEL+1) 670 DO X=1,N 671 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 672 PE(X) = -ME 673 ELSEIF (DEGREE(X).EQ.N2) THEN 674 NEL = NEL + NV(X) 675 PE(X) = -ME 676 ELEN(X) = 0 677 NV(X) = 0 678 ENDIF 679 ENDDO 680 ELEN(ME) = NELME 681 NV(ME) = SIZE_COMPLEM_LIST 682 PE(ME) = 0 683 ENDIF 684 IF (NEL.NE.N) THEN 685 write(*,*) ' Error 2 in HALO AMD NEL, N=', NEL,N 686 NCMPA = -N - 1 687 CALL MUMPS_ABORT() 688 ENDIF 689 ENDIF 690 DO 290 I = 1, N 691 IF (ELEN (I) .EQ. 0) THEN 692 J = -PE (I) 693 270 CONTINUE 694 IF (ELEN (J) .GE. 0) THEN 695 J = -PE (J) 696 GO TO 270 697 ENDIF 698 E = J 699 K = -ELEN (E) 700 J = I 701 280 CONTINUE 702 IF (ELEN (J) .GE. 0) THEN 703 JNEXT = -PE (J) 704 PE (J) = -E 705 IF (ELEN (J) .EQ. 0) THEN 706 ELEN (J) = K 707 K = K + 1 708 ENDIF 709 J = JNEXT 710 GO TO 280 711 ENDIF 712 ELEN (E) = -K 713 ENDIF 714 290 CONTINUE 715 IF(COMPRESS) THEN 716 LAST(1:N) = 0 717 DEGREE(1:TOTEL-N)=0 718 DO I = 1, N 719 K = abs (ELEN (I)) 720 IF ( K <= N ) THEN 721 LAST (K) = I 722 ELSE 723 DEGREE(K-N)=I 724 ENDIF 725 ENDDO 726 I = 1 727 DO K = 1, N 728 IF(LAST (K) .NE. 0) THEN 729 LAST(I) = LAST(K) 730 ELEN(LAST(K)) = I 731 I = I + 1 732 ENDIF 733 ENDDO 734 DO K = N+1, TOTEL 735 IF (DEGREE(K-N) .NE. 0) THEN 736 LAST(I)=DEGREE(K-N) 737 ELEN(DEGREE(K-N)) = I 738 I = I + 1 739 ENDIF 740 END DO 741 ELSE 742 DO 300 I = 1, N 743 K = abs (ELEN (I)) 744 LAST (K) = I 745 ELEN (I) = K 746300 CONTINUE 747 ENDIF 748 PFREE = MAXMEM 749 RETURN 750 END SUBROUTINE MUMPS_419 751 SUBROUTINE MUMPS_197(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, 752 & LAST, NCMPA, DEGREE, HEAD, NEXT, W) 753 INTEGER N, IWLEN, PFREE, NCMPA 754 INTEGER NEXT(N), LEN(N), 755 & ELEN(N), LAST(N), DEGREE(N), HEAD(N), 756 & W(N) 757 INTEGER IW(IWLEN), NV(N), PE(N) 758 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 759 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 760 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 761 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X 762 INTEGER MAXINT_N 763 INTEGER(8) HASH, HMOD 764 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 765 INTRINSIC max, min, mod 766 WFLG = 2 767 MAXINT_N=huge(WFLG)-N 768 MINDEG = 1 769 NCMPA = 0 770 NEL = 0 771 HMOD = int(max (1, N-1),kind=8) 772 DMAX = 0 773 MEM = PFREE - 1 774 MAXMEM = MEM 775 DO 10 I = 1, N 776 LAST (I) = 0 777 HEAD (I) = 0 778 NV (I) = 1 779 W (I) = 1 780 ELEN (I) = 0 781 DEGREE (I) = LEN (I) 782 10 CONTINUE 783 DO 20 I = 1, N 784 DEG = DEGREE (I) 785 IF (DEG .GT. 0) THEN 786 INEXT = HEAD (DEG) 787 IF (INEXT .NE. 0) LAST (INEXT) = I 788 NEXT (I) = INEXT 789 HEAD (DEG) = I 790 ELSE 791 NEL = NEL + 1 792 ELEN (I) = -NEL 793 PE (I) = 0 794 W (I) = 0 795 ENDIF 796 20 CONTINUE 797 30 IF (NEL .LT. N) THEN 798 DO 40 DEG = MINDEG, N 799 ME = HEAD (DEG) 800 IF (ME .GT. 0) GO TO 50 801 40 CONTINUE 802 50 MINDEG = DEG 803 INEXT = NEXT (ME) 804 IF (INEXT .NE. 0) LAST (INEXT) = 0 805 HEAD (DEG) = INEXT 806 ELENME = ELEN (ME) 807 ELEN (ME) = - (NEL + 1) 808 NVPIV = NV (ME) 809 NEL = NEL + NVPIV 810 NV (ME) = -NVPIV 811 DEGME = 0 812 IF (ELENME .EQ. 0) THEN 813 PME1 = PE (ME) 814 PME2 = PME1 - 1 815 DO 60 P = PME1, PME1 + LEN (ME) - 1 816 I = IW (P) 817 NVI = NV (I) 818 IF (NVI .GT. 0) THEN 819 DEGME = DEGME + NVI 820 NV (I) = -NVI 821 PME2 = PME2 + 1 822 IW (PME2) = I 823 ILAST = LAST (I) 824 INEXT = NEXT (I) 825 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 826 IF (ILAST .NE. 0) THEN 827 NEXT (ILAST) = INEXT 828 ELSE 829 HEAD (DEGREE (I)) = INEXT 830 ENDIF 831 ENDIF 832 60 CONTINUE 833 NEWMEM = 0 834 ELSE 835 P = PE (ME) 836 PME1 = PFREE 837 SLENME = LEN (ME) - ELENME 838 DO 120 KNT1 = 1, ELENME + 1 839 IF (KNT1 .GT. ELENME) THEN 840 E = ME 841 PJ = P 842 LN = SLENME 843 ELSE 844 E = IW (P) 845 P = P + 1 846 PJ = PE (E) 847 LN = LEN (E) 848 ENDIF 849 DO 110 KNT2 = 1, LN 850 I = IW (PJ) 851 PJ = PJ + 1 852 NVI = NV (I) 853 IF (NVI .GT. 0) THEN 854 IF (PFREE .GT. IWLEN) THEN 855 PE (ME) = P 856 LEN (ME) = LEN (ME) - KNT1 857 IF (LEN (ME) .EQ. 0) PE (ME) = 0 858 PE (E) = PJ 859 LEN (E) = LN - KNT2 860 IF (LEN (E) .EQ. 0) PE (E) = 0 861 NCMPA = NCMPA + 1 862 DO 70 J = 1, N 863 PN = PE (J) 864 IF (PN .GT. 0) THEN 865 PE (J) = IW (PN) 866 IW (PN) = -J 867 ENDIF 868 70 CONTINUE 869 PDST = 1 870 PSRC = 1 871 PEND = PME1 - 1 872 80 CONTINUE 873 IF (PSRC .LE. PEND) THEN 874 J = -IW (PSRC) 875 PSRC = PSRC + 1 876 IF (J .GT. 0) THEN 877 IW (PDST) = PE (J) 878 PE (J) = PDST 879 PDST = PDST + 1 880 LENJ = LEN (J) 881 DO 90 KNT3 = 0, LENJ - 2 882 IW (PDST + KNT3) = IW (PSRC + KNT3) 883 90 CONTINUE 884 PDST = PDST + LENJ - 1 885 PSRC = PSRC + LENJ - 1 886 ENDIF 887 GO TO 80 888 ENDIF 889 P1 = PDST 890 DO 100 PSRC = PME1, PFREE - 1 891 IW (PDST) = IW (PSRC) 892 PDST = PDST + 1 893 100 CONTINUE 894 PME1 = P1 895 PFREE = PDST 896 PJ = PE (E) 897 P = PE (ME) 898 ENDIF 899 DEGME = DEGME + NVI 900 NV (I) = -NVI 901 IW (PFREE) = I 902 PFREE = PFREE + 1 903 ILAST = LAST (I) 904 INEXT = NEXT (I) 905 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 906 IF (ILAST .NE. 0) THEN 907 NEXT (ILAST) = INEXT 908 ELSE 909 HEAD (DEGREE (I)) = INEXT 910 ENDIF 911 ENDIF 912 110 CONTINUE 913 IF (E .NE. ME) THEN 914 PE (E) = -ME 915 W (E) = 0 916 ENDIF 917 120 CONTINUE 918 PME2 = PFREE - 1 919 NEWMEM = PFREE - PME1 920 MEM = MEM + NEWMEM 921 MAXMEM = max (MAXMEM, MEM) 922 ENDIF 923 DEGREE (ME) = DEGME 924 PE (ME) = PME1 925 LEN (ME) = PME2 - PME1 + 1 926 IF (WFLG .GT. MAXINT_N) THEN 927 DO 130 X = 1, N 928 IF (W (X) .NE. 0) W (X) = 1 929 130 CONTINUE 930 WFLG = 2 931 ENDIF 932 DO 150 PME = PME1, PME2 933 I = IW (PME) 934 ELN = ELEN (I) 935 IF (ELN .GT. 0) THEN 936 NVI = -NV (I) 937 WNVI = WFLG - NVI 938 DO 140 P = PE (I), PE (I) + ELN - 1 939 E = IW (P) 940 WE = W (E) 941 IF (WE .GE. WFLG) THEN 942 WE = WE - NVI 943 ELSE IF (WE .NE. 0) THEN 944 WE = DEGREE (E) + WNVI 945 ENDIF 946 W (E) = WE 947 140 CONTINUE 948 ENDIF 949 150 CONTINUE 950 DO 180 PME = PME1, PME2 951 I = IW (PME) 952 P1 = PE (I) 953 P2 = P1 + ELEN (I) - 1 954 PN = P1 955 HASH = 0_8 956 DEG = 0 957 DO 160 P = P1, P2 958 E = IW (P) 959 DEXT = W (E) - WFLG 960 IF (DEXT .GT. 0) THEN 961 DEG = DEG + DEXT 962 IW (PN) = E 963 PN = PN + 1 964 HASH = HASH + int(E,kind=8) 965 ELSE IF (DEXT .EQ. 0) THEN 966#if defined (NOAGG1) 967 IW (PN) = E 968 PN = PN + 1 969 HASH = HASH + int(E,kind=8) 970#else 971 PE (E) = -ME 972 W (E) = 0 973#endif 974 ENDIF 975 160 CONTINUE 976 ELEN (I) = PN - P1 + 1 977 P3 = PN 978 DO 170 P = P2 + 1, P1 + LEN (I) - 1 979 J = IW (P) 980 NVJ = NV (J) 981 IF (NVJ .GT. 0) THEN 982 DEG = DEG + NVJ 983 IW (PN) = J 984 PN = PN + 1 985 HASH = HASH + int(J,kind=8) 986 ENDIF 987 170 CONTINUE 988#if defined (NOAGG1) 989 IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN 990#else 991 IF (DEG .EQ. 0) THEN 992#endif 993 PE (I) = -ME 994 NVI = -NV (I) 995 DEGME = DEGME - NVI 996 NVPIV = NVPIV + NVI 997 NEL = NEL + NVI 998 NV (I) = 0 999 ELEN (I) = 0 1000 ELSE 1001 DEGREE (I) = min (DEGREE (I), DEG) 1002 IW (PN) = IW (P3) 1003 IW (P3) = IW (P1) 1004 IW (P1) = ME 1005 LEN (I) = PN - P1 + 1 1006 HASH = mod (HASH, HMOD) + 1_8 1007 J = HEAD (HASH) 1008 IF (J .LE. 0) THEN 1009 NEXT (I) = -J 1010 HEAD (HASH) = -I 1011 ELSE 1012 NEXT (I) = LAST (J) 1013 LAST (J) = I 1014 ENDIF 1015 LAST (I) = int(HASH,kind=kind(LAST)) 1016 ENDIF 1017 180 CONTINUE 1018 DEGREE (ME) = DEGME 1019 DMAX = max (DMAX, DEGME) 1020 WFLG = WFLG + DMAX 1021 IF (WFLG .GT. MAXINT_N) THEN 1022 DO 190 X = 1, N 1023 IF (W (X) .NE. 0) W (X) = 1 1024 190 CONTINUE 1025 WFLG = 2 1026 ENDIF 1027 DO 250 PME = PME1, PME2 1028 I = IW (PME) 1029 IF (NV (I) .LT. 0) THEN 1030 HASH = int(LAST (I),kind=8) 1031 J = HEAD (HASH) 1032 IF (J .EQ. 0) GO TO 250 1033 IF (J .LT. 0) THEN 1034 I = -J 1035 HEAD (HASH) = 0 1036 ELSE 1037 I = LAST (J) 1038 LAST (J) = 0 1039 ENDIF 1040 IF (I .EQ. 0) GO TO 250 1041 200 CONTINUE 1042 IF (NEXT (I) .NE. 0) THEN 1043 LN = LEN (I) 1044 ELN = ELEN (I) 1045 DO 210 P = PE (I) + 1, PE (I) + LN - 1 1046 W (IW (P)) = WFLG 1047 210 CONTINUE 1048 JLAST = I 1049 J = NEXT (I) 1050 220 CONTINUE 1051 IF (J .NE. 0) THEN 1052 IF (LEN (J) .NE. LN) GO TO 240 1053 IF (ELEN (J) .NE. ELN) GO TO 240 1054 DO 230 P = PE (J) + 1, PE (J) + LN - 1 1055 IF (W (IW (P)) .NE. WFLG) GO TO 240 1056 230 CONTINUE 1057 PE (J) = -I 1058 NV (I) = NV (I) + NV (J) 1059 NV (J) = 0 1060 ELEN (J) = 0 1061 J = NEXT (J) 1062 NEXT (JLAST) = J 1063 GO TO 220 1064 240 CONTINUE 1065 JLAST = J 1066 J = NEXT (J) 1067 GO TO 220 1068 ENDIF 1069 WFLG = WFLG + 1 1070 I = NEXT (I) 1071 IF (I .NE. 0) GO TO 200 1072 ENDIF 1073 ENDIF 1074 250 CONTINUE 1075 P = PME1 1076 NLEFT = N - NEL 1077 DO 260 PME = PME1, PME2 1078 I = IW (PME) 1079 NVI = -NV (I) 1080 IF (NVI .GT. 0) THEN 1081 NV (I) = NVI 1082 DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) 1083 INEXT = HEAD (DEG) 1084 IF (INEXT .NE. 0) LAST (INEXT) = I 1085 NEXT (I) = INEXT 1086 LAST (I) = 0 1087 HEAD (DEG) = I 1088 MINDEG = min (MINDEG, DEG) 1089 DEGREE (I) = DEG 1090 IW (P) = I 1091 P = P + 1 1092 ENDIF 1093 260 CONTINUE 1094 NV (ME) = NVPIV + DEGME 1095 LEN (ME) = P - PME1 1096 IF (LEN (ME) .EQ. 0) THEN 1097 PE (ME) = 0 1098 W (ME) = 0 1099 ENDIF 1100 IF (NEWMEM .NE. 0) THEN 1101 PFREE = P 1102 MEM = MEM - NEWMEM + LEN (ME) 1103 ENDIF 1104 GO TO 30 1105 ENDIF 1106 DO 290 I = 1, N 1107 IF (ELEN (I) .EQ. 0) THEN 1108 J = -PE (I) 1109 270 CONTINUE 1110 IF (ELEN (J) .GE. 0) THEN 1111 J = -PE (J) 1112 GO TO 270 1113 ENDIF 1114 E = J 1115 K = -ELEN (E) 1116 J = I 1117 280 CONTINUE 1118 IF (ELEN (J) .GE. 0) THEN 1119 JNEXT = -PE (J) 1120 PE (J) = -E 1121 IF (ELEN (J) .EQ. 0) THEN 1122 ELEN (J) = K 1123 K = K + 1 1124 ENDIF 1125 J = JNEXT 1126 GO TO 280 1127 ENDIF 1128 ELEN (E) = -K 1129 ENDIF 1130 290 CONTINUE 1131 DO 300 I = 1, N 1132 K = abs (ELEN (I)) 1133 LAST (K) = I 1134 ELEN (I) = K 1135 300 CONTINUE 1136 PFREE = MAXMEM 1137 RETURN 1138 END SUBROUTINE MUMPS_197 1139 SUBROUTINE MUMPS_23(N,IWLEN, PE, PFREE, LEN, IW, NV, ELEN, 1140 & LAST, NCMPA, DEGREE, HEAD, NEXT, W) 1141 INTEGER N, IWLEN, PFREE, NCMPA 1142 INTEGER PE(N), LEN(N), 1143 & ELEN(N), LAST(N), DEGREE(N), HEAD(N), 1144 & W(N) 1145 INTEGER IW(IWLEN), NV(N), NEXT(N) 1146 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 1147 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 1148 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 1149 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, 1150 & NPRINC 1151 INTEGER MAXINT_N 1152 INTEGER(8) HASH, HMOD 1153 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 1154 INTRINSIC max, min, mod 1155 WFLG = 2 1156 MAXINT_N=huge(WFLG)-N 1157 MINDEG = 1 1158 NCMPA = 0 1159 NEL = 0 1160 HMOD = int(max (1, N-1),kind=8) 1161 DMAX = 0 1162 MEM = PFREE - 1 1163 MAXMEM = MEM 1164 NPRINC = 0 1165 DO I = 1, N 1166 LAST (I) = 0 1167 HEAD (I) = 0 1168 NV (I) = 1 1169 W (I) = 1 1170 ELEN (I) = 0 1171 ENDDO 1172 DO I=1, N 1173 IF (LEN (I).GE.0) THEN 1174 DEGREE (I) = LEN (I) 1175 NPRINC = NPRINC + 1 1176 ELSE 1177 J = -LEN (I) 1178 DEGREE (I) = - 1 1179 IF ( PE(I) .NE. 0 ) THEN 1180 LEN (I) = LEN(J) 1181 ELSE 1182 LEN (I) = 0 1183 ENDIF 1184 PE (I) = -J 1185 NV (J) = NV (J) + NV (I) 1186 NV (I) = 0 1187 ELEN (I) = 0 1188 ENDIF 1189 ENDDO 1190 DO 20 I = 1, N 1191 DEG = DEGREE (I) 1192 IF (DEG .GT. 0) THEN 1193 INEXT = HEAD (DEG) 1194 IF (INEXT .NE. 0) LAST (INEXT) = I 1195 NEXT (I) = INEXT 1196 HEAD (DEG) = I 1197 ELSE IF ( DEG.EQ. 0) THEN 1198 ELEN (I) = - (NEL + 1) 1199 NEL = NEL + NV(I) 1200 PE (I) = 0 1201 W (I) = 0 1202 ENDIF 1203 20 CONTINUE 1204 30 IF (NEL .LT. N) THEN 1205 DO 40 DEG = MINDEG, N 1206 ME = HEAD (DEG) 1207 IF (ME .GT. 0) GO TO 50 1208 40 CONTINUE 1209 50 MINDEG = DEG 1210 INEXT = NEXT (ME) 1211 IF (INEXT .NE. 0) LAST (INEXT) = 0 1212 HEAD (DEG) = INEXT 1213 ELENME = ELEN (ME) 1214 ELEN (ME) = - (NEL + 1) 1215 NVPIV = NV (ME) 1216 NEL = NEL + NVPIV 1217 NV (ME) = -NVPIV 1218 DEGME = 0 1219 IF (ELENME .EQ. 0) THEN 1220 PME1 = PE (ME) 1221 PME2 = PME1 - 1 1222 DO 60 P = PME1, PME1 + LEN (ME) - 1 1223 I = IW (P) 1224 NVI = NV (I) 1225 IF (NVI .GT. 0) THEN 1226 DEGME = DEGME + NVI 1227 NV (I) = -NVI 1228 PME2 = PME2 + 1 1229 IW (PME2) = I 1230 ILAST = LAST (I) 1231 INEXT = NEXT (I) 1232 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 1233 IF (ILAST .NE. 0) THEN 1234 NEXT (ILAST) = INEXT 1235 ELSE 1236 HEAD (DEGREE (I)) = INEXT 1237 ENDIF 1238 ENDIF 1239 60 CONTINUE 1240 NEWMEM = 0 1241 ELSE 1242 P = PE (ME) 1243 PME1 = PFREE 1244 SLENME = LEN (ME) - ELENME 1245 DO 120 KNT1 = 1, ELENME + 1 1246 IF (KNT1 .GT. ELENME) THEN 1247 E = ME 1248 PJ = P 1249 LN = SLENME 1250 ELSE 1251 E = IW (P) 1252 P = P + 1 1253 PJ = PE (E) 1254 LN = LEN (E) 1255 ENDIF 1256 DO 110 KNT2 = 1, LN 1257 I = IW (PJ) 1258 PJ = PJ + 1 1259 NVI = NV (I) 1260 IF (NVI .GT. 0) THEN 1261 IF (PFREE .GT. IWLEN) THEN 1262 PE (ME) = P 1263 LEN (ME) = LEN (ME) - KNT1 1264 IF (LEN (ME) .EQ. 0) PE (ME) = 0 1265 PE (E) = PJ 1266 LEN (E) = LN - KNT2 1267 IF (LEN (E) .EQ. 0) PE (E) = 0 1268 NCMPA = NCMPA + 1 1269 DO 70 J = 1, N 1270 PN = PE (J) 1271 IF (PN .GT. 0) THEN 1272 PE (J) = IW (PN) 1273 IW (PN) = -J 1274 ENDIF 1275 70 CONTINUE 1276 PDST = 1 1277 PSRC = 1 1278 PEND = PME1 - 1 1279 80 CONTINUE 1280 IF (PSRC .LE. PEND) THEN 1281 J = -IW (PSRC) 1282 PSRC = PSRC + 1 1283 IF (J .GT. 0) THEN 1284 IW (PDST) = PE (J) 1285 PE (J) = PDST 1286 PDST = PDST + 1 1287 LENJ = LEN (J) 1288 DO 90 KNT3 = 0, LENJ - 2 1289 IW (PDST + KNT3) = IW (PSRC + KNT3) 1290 90 CONTINUE 1291 PDST = PDST + LENJ - 1 1292 PSRC = PSRC + LENJ - 1 1293 ENDIF 1294 GO TO 80 1295 ENDIF 1296 P1 = PDST 1297 DO 100 PSRC = PME1, PFREE - 1 1298 IW (PDST) = IW (PSRC) 1299 PDST = PDST + 1 1300 100 CONTINUE 1301 PME1 = P1 1302 PFREE = PDST 1303 PJ = PE (E) 1304 P = PE (ME) 1305 ENDIF 1306 DEGME = DEGME + NVI 1307 NV (I) = -NVI 1308 IW (PFREE) = I 1309 PFREE = PFREE + 1 1310 ILAST = LAST (I) 1311 INEXT = NEXT (I) 1312 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 1313 IF (ILAST .NE. 0) THEN 1314 NEXT (ILAST) = INEXT 1315 ELSE 1316 HEAD (DEGREE (I)) = INEXT 1317 ENDIF 1318 ENDIF 1319 110 CONTINUE 1320 IF (E .NE. ME) THEN 1321 PE (E) = -ME 1322 W (E) = 0 1323 ENDIF 1324 120 CONTINUE 1325 PME2 = PFREE - 1 1326 NEWMEM = PFREE - PME1 1327 MEM = MEM + NEWMEM 1328 MAXMEM = max (MAXMEM, MEM) 1329 ENDIF 1330 DEGREE (ME) = DEGME 1331 PE (ME) = PME1 1332 LEN (ME) = PME2 - PME1 + 1 1333 IF (WFLG .GT. MAXINT_N) THEN 1334 DO 130 X = 1, N 1335 IF (W (X) .NE. 0) W (X) = 1 1336 130 CONTINUE 1337 WFLG = 2 1338 ENDIF 1339 DO 150 PME = PME1, PME2 1340 I = IW (PME) 1341 ELN = ELEN (I) 1342 IF (ELN .GT. 0) THEN 1343 NVI = -NV (I) 1344 WNVI = WFLG - NVI 1345 DO 140 P = PE (I), PE (I) + ELN - 1 1346 E = IW (P) 1347 WE = W (E) 1348 IF (WE .GE. WFLG) THEN 1349 WE = WE - NVI 1350 ELSE IF (WE .NE. 0) THEN 1351 WE = DEGREE (E) + WNVI 1352 ENDIF 1353 W (E) = WE 1354 140 CONTINUE 1355 ENDIF 1356 150 CONTINUE 1357 DO 180 PME = PME1, PME2 1358 I = IW (PME) 1359 P1 = PE (I) 1360 P2 = P1 + ELEN (I) - 1 1361 PN = P1 1362 HASH = 0_8 1363 DEG = 0 1364 DO 160 P = P1, P2 1365 E = IW (P) 1366 DEXT = W (E) - WFLG 1367 IF (DEXT .GT. 0) THEN 1368 DEG = DEG + DEXT 1369 IW (PN) = E 1370 PN = PN + 1 1371 HASH = HASH + int(E,kind=8) 1372 ELSE IF (DEXT .EQ. 0) THEN 1373#if defined (NOAGG2) 1374 IW (PN) = E 1375 PN = PN + 1 1376 HASH = HASH + int(E,kind=8) 1377#else 1378 PE (E) = -ME 1379 W (E) = 0 1380#endif 1381 ENDIF 1382 160 CONTINUE 1383 ELEN (I) = PN - P1 + 1 1384 P3 = PN 1385 DO 170 P = P2 + 1, P1 + LEN (I) - 1 1386 J = IW (P) 1387 NVJ = NV (J) 1388 IF (NVJ .GT. 0) THEN 1389 DEG = DEG + NVJ 1390 IW (PN) = J 1391 PN = PN + 1 1392 HASH = HASH + int(J,kind=8) 1393 ENDIF 1394 170 CONTINUE 1395#if defined (NOAGG2) 1396 IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN 1397#else 1398 IF (DEG .EQ. 0) THEN 1399#endif 1400 PE (I) = -ME 1401 NVI = -NV (I) 1402 DEGME = DEGME - NVI 1403 NVPIV = NVPIV + NVI 1404 NEL = NEL + NVI 1405 NV (I) = 0 1406 ELEN (I) = 0 1407 ELSE 1408 DEGREE (I) = min (DEGREE (I), DEG) 1409 IW (PN) = IW (P3) 1410 IW (P3) = IW (P1) 1411 IW (P1) = ME 1412 LEN (I) = PN - P1 + 1 1413 HASH = mod (HASH, HMOD) + 1_8 1414 J = HEAD (HASH) 1415 IF (J .LE. 0) THEN 1416 NEXT (I) = -J 1417 HEAD (HASH) = -I 1418 ELSE 1419 NEXT (I) = LAST (J) 1420 LAST (J) = I 1421 ENDIF 1422 LAST (I) = int(HASH,kind=kind(LAST)) 1423 ENDIF 1424 180 CONTINUE 1425 DEGREE (ME) = DEGME 1426 DMAX = max (DMAX, DEGME) 1427 WFLG = WFLG + DMAX 1428 IF (WFLG .GT. MAXINT_N) THEN 1429 DO 190 X = 1, N 1430 IF (W (X) .NE. 0) W (X) = 1 1431 190 CONTINUE 1432 WFLG = 2 1433 ENDIF 1434 DO 250 PME = PME1, PME2 1435 I = IW (PME) 1436 IF (NV (I) .LT. 0) THEN 1437 HASH = int(LAST (I),kind=8) 1438 J = HEAD (HASH) 1439 IF (J .EQ. 0) GO TO 250 1440 IF (J .LT. 0) THEN 1441 I = -J 1442 HEAD (HASH) = 0 1443 ELSE 1444 I = LAST (J) 1445 LAST (J) = 0 1446 ENDIF 1447 IF (I .EQ. 0) GO TO 250 1448 200 CONTINUE 1449 IF (NEXT (I) .NE. 0) THEN 1450 LN = LEN (I) 1451 ELN = ELEN (I) 1452 DO 210 P = PE (I) + 1, PE (I) + LN - 1 1453 W (IW (P)) = WFLG 1454 210 CONTINUE 1455 JLAST = I 1456 J = NEXT (I) 1457 220 CONTINUE 1458 IF (J .NE. 0) THEN 1459 IF (LEN (J) .NE. LN) GO TO 240 1460 IF (ELEN (J) .NE. ELN) GO TO 240 1461 DO 230 P = PE (J) + 1, PE (J) + LN - 1 1462 IF (W (IW (P)) .NE. WFLG) GO TO 240 1463 230 CONTINUE 1464 PE (J) = -I 1465 NV (I) = NV (I) + NV (J) 1466 NV (J) = 0 1467 ELEN (J) = 0 1468 J = NEXT (J) 1469 NEXT (JLAST) = J 1470 GO TO 220 1471 240 CONTINUE 1472 JLAST = J 1473 J = NEXT (J) 1474 GO TO 220 1475 ENDIF 1476 WFLG = WFLG + 1 1477 I = NEXT (I) 1478 IF (I .NE. 0) GO TO 200 1479 ENDIF 1480 ENDIF 1481 250 CONTINUE 1482 P = PME1 1483 NLEFT = N - NEL 1484 DO 260 PME = PME1, PME2 1485 I = IW (PME) 1486 NVI = -NV (I) 1487 IF (NVI .GT. 0) THEN 1488 NV (I) = NVI 1489 DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) 1490 INEXT = HEAD (DEG) 1491 IF (INEXT .NE. 0) LAST (INEXT) = I 1492 NEXT (I) = INEXT 1493 LAST (I) = 0 1494 HEAD (DEG) = I 1495 MINDEG = min (MINDEG, DEG) 1496 DEGREE (I) = DEG 1497 IW (P) = I 1498 P = P + 1 1499 ENDIF 1500 260 CONTINUE 1501 NV (ME) = NVPIV + DEGME 1502 LEN (ME) = P - PME1 1503 IF (LEN (ME) .EQ. 0) THEN 1504 PE (ME) = 0 1505 W (ME) = 0 1506 ENDIF 1507 IF (NEWMEM .NE. 0) THEN 1508 PFREE = P 1509 MEM = MEM - NEWMEM + LEN (ME) 1510 ENDIF 1511 GO TO 30 1512 ENDIF 1513 DO 290 I = 1, N 1514 IF (ELEN (I) .EQ. 0) THEN 1515 J = -PE (I) 1516 270 CONTINUE 1517 IF (ELEN (J) .GE. 0) THEN 1518 J = -PE (J) 1519 GO TO 270 1520 ENDIF 1521 E = J 1522 K = -ELEN (E) 1523 J = I 1524 280 CONTINUE 1525 IF (ELEN (J) .GE. 0) THEN 1526 JNEXT = -PE (J) 1527 PE (J) = -E 1528 IF (ELEN (J) .EQ. 0) THEN 1529 ELEN (J) = K 1530 K = K + 1 1531 ENDIF 1532 J = JNEXT 1533 GO TO 280 1534 ENDIF 1535 ELEN (E) = -K 1536 ENDIF 1537 290 CONTINUE 1538 DO 300 I = 1, N 1539 K = abs (ELEN (I)) 1540 LAST (K) = I 1541 ELEN (I) = K 1542 300 CONTINUE 1543 PFREE = MAXMEM 1544 RETURN 1545 END SUBROUTINE MUMPS_23 1546 SUBROUTINE MUMPS_162(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, 1547 & LAST, NCMPA, DEGREE, HEAD, NEXT, W, 1548 & LISTVAR_SCHUR, SIZE_SCHUR) 1549 INTEGER SIZE_SCHUR 1550 INTEGER LISTVAR_SCHUR(SIZE_SCHUR) 1551 INTEGER N, IWLEN, PFREE, NCMPA 1552 INTEGER LEN(N), 1553 & ELEN(N), LAST(N), DEGREE(N), HEAD(N), 1554 & W(N), NEXT(N) 1555 INTEGER IW(IWLEN), NV(N), PE(N) 1556 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 1557 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 1558 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 1559 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, 1560 & NBFLAG, NREAL, LASTD, NELME 1561 INTEGER MAXINT_N 1562 INTEGER(8) HASH, HMOD 1563 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 1564 INTRINSIC max, min, mod 1565 WFLG = 2 1566 MAXINT_N=huge(WFLG)-N 1567 MINDEG = 1 1568 NCMPA = 0 1569 NEL = 0 1570 HMOD = int(max (1, N-1),kind=8) 1571 DMAX = 0 1572 MEM = PFREE - 1 1573 MAXMEM = MEM 1574 NBFLAG = 0 1575 LASTD = 0 1576 DO 10 I = 1, N 1577 LAST (I) = 0 1578 HEAD (I) = 0 1579 NV (I) = 1 1580 W (I) = 1 1581 ELEN (I) = 0 1582 DEGREE(I) = LEN(I) 1583 10 CONTINUE 1584 NBFLAG = SIZE_SCHUR 1585 DO K=1,SIZE_SCHUR 1586 I = LISTVAR_SCHUR(K) 1587 DEGREE(I) = N+1 1588 IF ((LEN(I) .EQ.0).OR.(LEN(I).EQ.-N-1)) THEN 1589 PE (I) = 0 1590 LEN(I) = 0 1591 ENDIF 1592 DEG = N 1593 IF (LASTD.EQ.0) THEN 1594 LASTD = I 1595 HEAD(DEG) = I 1596 NEXT(I) = 0 1597 LAST(I) = 0 1598 ELSE 1599 NEXT(LASTD) = I 1600 LAST(I) = LASTD 1601 LASTD = I 1602 NEXT(I) = 0 1603 ENDIF 1604 ENDDO 1605 NREAL = N - NBFLAG 1606 DO 20 I = 1, N 1607 DEG = DEGREE (I) 1608 IF (DEG.EQ.N+1) GOTO 20 1609 IF (DEG .GT. 0) THEN 1610 INEXT = HEAD (DEG) 1611 IF (INEXT .NE. 0) LAST (INEXT) = I 1612 NEXT (I) = INEXT 1613 HEAD (DEG) = I 1614 ELSE 1615 NEL = NEL + 1 1616 ELEN (I) = -NEL 1617 PE (I) = 0 1618 W (I) = 0 1619 ENDIF 1620 20 CONTINUE 1621 NLEFT = N-NEL 1622 30 IF (NEL .LT. NREAL) THEN 1623 DO 40 DEG = MINDEG, N 1624 ME = HEAD (DEG) 1625 IF (ME .GT. 0) GO TO 50 1626 40 CONTINUE 1627 50 MINDEG = DEG 1628 IF (ME.LE.0) THEN 1629 write (*,*) ' Error 1 in HALO_AMD ' 1630 NCMPA = -N 1631 GOTO 500 1632 ENDIF 1633 INEXT = NEXT (ME) 1634 IF (INEXT .NE. 0) LAST (INEXT) = 0 1635 HEAD (DEG) = INEXT 1636 ELENME = ELEN (ME) 1637 ELEN (ME) = - (NEL + 1) 1638 NVPIV = NV (ME) 1639 NEL = NEL + NVPIV 1640 NV (ME) = -NVPIV 1641 DEGME = 0 1642 IF (ELENME .EQ. 0) THEN 1643 PME1 = PE (ME) 1644 PME2 = PME1 - 1 1645 DO 60 P = PME1, PME1 + LEN (ME) - 1 1646 I = IW (P) 1647 NVI = NV (I) 1648 IF (NVI .GT. 0) THEN 1649 DEGME = DEGME + NVI 1650 NV (I) = -NVI 1651 PME2 = PME2 + 1 1652 IW (PME2) = I 1653 IF (DEGREE(I).LE.N) THEN 1654 ILAST = LAST (I) 1655 INEXT = NEXT (I) 1656 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 1657 IF (ILAST .NE. 0) THEN 1658 NEXT (ILAST) = INEXT 1659 ELSE 1660 HEAD (DEGREE (I)) = INEXT 1661 ENDIF 1662 ENDIF 1663 ENDIF 1664 60 CONTINUE 1665 NEWMEM = 0 1666 ELSE 1667 P = PE (ME) 1668 PME1 = PFREE 1669 SLENME = LEN (ME) - ELENME 1670 DO 120 KNT1 = 1, ELENME + 1 1671 IF (KNT1 .GT. ELENME) THEN 1672 E = ME 1673 PJ = P 1674 LN = SLENME 1675 ELSE 1676 E = IW (P) 1677 P = P + 1 1678 PJ = PE (E) 1679 LN = LEN (E) 1680 ENDIF 1681 DO 110 KNT2 = 1, LN 1682 I = IW (PJ) 1683 PJ = PJ + 1 1684 NVI = NV (I) 1685 IF (NVI .GT. 0) THEN 1686 IF (PFREE .GT. IWLEN) THEN 1687 PE (ME) = P 1688 LEN (ME) = LEN (ME) - KNT1 1689 IF (LEN (ME) .EQ. 0) PE (ME) = 0 1690 PE (E) = PJ 1691 LEN (E) = LN - KNT2 1692 IF (LEN (E) .EQ. 0) PE (E) = 0 1693 NCMPA = NCMPA + 1 1694 DO 70 J = 1, N 1695 PN = PE (J) 1696 IF (PN .GT. 0) THEN 1697 PE (J) = IW (PN) 1698 IW (PN) = -J 1699 ENDIF 1700 70 CONTINUE 1701 PDST = 1 1702 PSRC = 1 1703 PEND = PME1 - 1 1704 80 CONTINUE 1705 IF (PSRC .LE. PEND) THEN 1706 J = -IW (PSRC) 1707 PSRC = PSRC + 1 1708 IF (J .GT. 0) THEN 1709 IW (PDST) = PE (J) 1710 PE (J) = PDST 1711 PDST = PDST + 1 1712 LENJ = LEN (J) 1713 DO 90 KNT3 = 0, LENJ - 2 1714 IW (PDST + KNT3) = IW (PSRC + KNT3) 1715 90 CONTINUE 1716 PDST = PDST + LENJ - 1 1717 PSRC = PSRC + LENJ - 1 1718 ENDIF 1719 GO TO 80 1720 ENDIF 1721 P1 = PDST 1722 DO 100 PSRC = PME1, PFREE - 1 1723 IW (PDST) = IW (PSRC) 1724 PDST = PDST + 1 1725 100 CONTINUE 1726 PME1 = P1 1727 PFREE = PDST 1728 PJ = PE (E) 1729 P = PE (ME) 1730 ENDIF 1731 DEGME = DEGME + NVI 1732 NV (I) = -NVI 1733 IW (PFREE) = I 1734 PFREE = PFREE + 1 1735 IF (DEGREE(I).LE.N) THEN 1736 ILAST = LAST (I) 1737 INEXT = NEXT (I) 1738 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 1739 IF (ILAST .NE. 0) THEN 1740 NEXT (ILAST) = INEXT 1741 ELSE 1742 HEAD (DEGREE (I)) = INEXT 1743 ENDIF 1744 ENDIF 1745 ENDIF 1746 110 CONTINUE 1747 IF (E .NE. ME) THEN 1748 PE (E) = -ME 1749 W (E) = 0 1750 ENDIF 1751 120 CONTINUE 1752 PME2 = PFREE - 1 1753 NEWMEM = PFREE - PME1 1754 MEM = MEM + NEWMEM 1755 MAXMEM = max (MAXMEM, MEM) 1756 ENDIF 1757 DEGREE (ME) = DEGME 1758 PE (ME) = PME1 1759 LEN (ME) = PME2 - PME1 + 1 1760 IF (WFLG .GT. MAXINT_N) THEN 1761 DO 130 X = 1, N 1762 IF (W (X) .NE. 0) W (X) = 1 1763 130 CONTINUE 1764 WFLG = 2 1765 ENDIF 1766 DO 150 PME = PME1, PME2 1767 I = IW (PME) 1768 ELN = ELEN (I) 1769 IF (ELN .GT. 0) THEN 1770 NVI = -NV (I) 1771 WNVI = WFLG - NVI 1772 DO 140 P = PE (I), PE (I) + ELN - 1 1773 E = IW (P) 1774 WE = W (E) 1775 IF (WE .GE. WFLG) THEN 1776 WE = WE - NVI 1777 ELSE IF (WE .NE. 0) THEN 1778 WE = DEGREE (E) + WNVI 1779 ENDIF 1780 W (E) = WE 1781 140 CONTINUE 1782 ENDIF 1783 150 CONTINUE 1784 DO 180 PME = PME1, PME2 1785 I = IW (PME) 1786 P1 = PE (I) 1787 P2 = P1 + ELEN (I) - 1 1788 PN = P1 1789 HASH = 0_8 1790 DEG = 0 1791 DO 160 P = P1, P2 1792 E = IW (P) 1793 DEXT = W (E) - WFLG 1794 IF (DEXT .GT. 0) THEN 1795 DEG = DEG + DEXT 1796 IW (PN) = E 1797 PN = PN + 1 1798 HASH = HASH + int(E,kind=8) 1799 ELSE IF (DEXT .EQ. 0) THEN 1800#if defined (NOAGG3) 1801 IW (PN) = E 1802 PN = PN + 1 1803 HASH = HASH + E 1804#else 1805 PE (E) = -ME 1806 W (E) = 0 1807#endif 1808 ENDIF 1809 160 CONTINUE 1810 ELEN (I) = PN - P1 + 1 1811 P3 = PN 1812 DO 170 P = P2 + 1, P1 + LEN (I) - 1 1813 J = IW (P) 1814 NVJ = NV (J) 1815 IF (NVJ .GT. 0) THEN 1816 DEG = DEG + NVJ 1817 IW (PN) = J 1818 PN = PN + 1 1819 HASH = HASH + int(J,kind=8) 1820 ENDIF 1821 170 CONTINUE 1822 IF (DEGREE(I).EQ.N+1) DEG = N+1 1823#if defined (NOAGG3) 1824 IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN 1825#else 1826 IF (DEG .EQ. 0) THEN 1827#endif 1828 PE (I) = -ME 1829 NVI = -NV (I) 1830 DEGME = DEGME - NVI 1831 NVPIV = NVPIV + NVI 1832 NEL = NEL + NVI 1833 NV (I) = 0 1834 ELEN (I) = 0 1835 ELSE 1836 IF (DEGREE(I).NE.N+1) THEN 1837 DEG = min (DEG, NLEFT) 1838 DEGREE (I) = min (DEGREE (I), DEG) 1839 ENDIF 1840 IW (PN) = IW (P3) 1841 IW (P3) = IW (P1) 1842 IW (P1) = ME 1843 LEN (I) = PN - P1 + 1 1844 IF (DEG.LE.N) THEN 1845 HASH = mod (HASH, HMOD) + 1_8 1846 J = HEAD (HASH) 1847 IF (J .LE. 0) THEN 1848 NEXT (I) = -J 1849 HEAD (HASH) = -I 1850 ELSE 1851 NEXT (I) = LAST (J) 1852 LAST (J) = I 1853 ENDIF 1854 LAST (I) = int(HASH, kind=kind(LAST)) 1855 ENDIF 1856 ENDIF 1857 180 CONTINUE 1858 DEGREE (ME) = DEGME 1859 DMAX = max (DMAX, DEGME) 1860 WFLG = WFLG + DMAX 1861 IF (WFLG .GT. MAXINT_N) THEN 1862 DO 190 X = 1, N 1863 IF (W (X) .NE. 0) W (X) = 1 1864 190 CONTINUE 1865 WFLG = 2 1866 ENDIF 1867 DO 250 PME = PME1, PME2 1868 I = IW (PME) 1869 IF ( (NV (I) .LT. 0) .AND. (DEGREE(I) .LE. N) ) THEN 1870 HASH = int(LAST (I),kind=8) 1871 J = HEAD (HASH) 1872 IF (J .EQ. 0) GO TO 250 1873 IF (J .LT. 0) THEN 1874 I = -J 1875 HEAD (HASH) = 0 1876 ELSE 1877 I = LAST (J) 1878 LAST (J) = 0 1879 ENDIF 1880 IF (I .EQ. 0) GO TO 250 1881 200 CONTINUE 1882 IF (NEXT (I) .NE. 0) THEN 1883 LN = LEN (I) 1884 ELN = ELEN (I) 1885 DO 210 P = PE (I) + 1, PE (I) + LN - 1 1886 W (IW (P)) = WFLG 1887 210 CONTINUE 1888 JLAST = I 1889 J = NEXT (I) 1890 220 CONTINUE 1891 IF (J .NE. 0) THEN 1892 IF (LEN (J) .NE. LN) GO TO 240 1893 IF (ELEN (J) .NE. ELN) GO TO 240 1894 DO 230 P = PE (J) + 1, PE (J) + LN - 1 1895 IF (W (IW (P)) .NE. WFLG) GO TO 240 1896 230 CONTINUE 1897 PE (J) = -I 1898 NV (I) = NV (I) + NV (J) 1899 NV (J) = 0 1900 ELEN (J) = 0 1901 J = NEXT (J) 1902 NEXT (JLAST) = J 1903 GO TO 220 1904 240 CONTINUE 1905 JLAST = J 1906 J = NEXT (J) 1907 GO TO 220 1908 ENDIF 1909 WFLG = WFLG + 1 1910 I = NEXT (I) 1911 IF (I .NE. 0) GO TO 200 1912 ENDIF 1913 ENDIF 1914 250 CONTINUE 1915 P = PME1 1916 NLEFT = N - NEL 1917 DO 260 PME = PME1, PME2 1918 I = IW (PME) 1919 NVI = -NV (I) 1920 IF (NVI .GT. 0) THEN 1921 NV (I) = NVI 1922 IF (DEGREE(I).LE.N) THEN 1923 DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) 1924 INEXT = HEAD (DEG) 1925 IF (INEXT .NE. 0) LAST (INEXT) = I 1926 NEXT (I) = INEXT 1927 LAST (I) = 0 1928 HEAD (DEG) = I 1929 MINDEG = min (MINDEG, DEG) 1930 DEGREE (I) = DEG 1931 ENDIF 1932 IW (P) = I 1933 P = P + 1 1934 ENDIF 1935 260 CONTINUE 1936 NV (ME) = NVPIV + DEGME 1937 LEN (ME) = P - PME1 1938 IF (LEN (ME) .EQ. 0) THEN 1939 PE (ME) = 0 1940 W (ME) = 0 1941 ENDIF 1942 IF (NEWMEM .NE. 0) THEN 1943 PFREE = P 1944 MEM = MEM - NEWMEM + LEN (ME) 1945 ENDIF 1946 GO TO 30 1947 ENDIF 1948 IF (NEL.LT.N) THEN 1949 DO DEG = MINDEG, N 1950 ME = HEAD (DEG) 1951 IF (ME .GT. 0) GO TO 51 1952 ENDDO 1953 51 MINDEG = DEG 1954 IF (ME.NE.LISTVAR_SCHUR(1)) THEN 1955 write(6,*) ' error 1 in MUMPS_162 ' 1956 write(6,*) ' wrong principal var for Schur !!' 1957 NCMPA = -N - 2 1958 CALL MUMPS_ABORT() 1959 ENDIF 1960 NELME = -(NEL+1) 1961 DO X=1,N 1962 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 1963 PE(X) = -ME 1964 ELSEIF (DEGREE(X).EQ.N+1) THEN 1965 NEL = NEL + NV(X) 1966 PE(X) = -ME 1967 ELEN(X) = 0 1968 NV(X) = 0 1969 ENDIF 1970 ENDDO 1971 ELEN(ME) = NELME 1972 NV(ME) = N-NREAL 1973 PE(ME) = 0 1974 IF (NEL.NE.N) THEN 1975 write(*,*) ' Error 2 in MUMPS_162 NEL, N=', NEL,N 1976 NCMPA = -N - 1 1977 CALL MUMPS_ABORT() 1978 ENDIF 1979 ENDIF 1980 DO 290 I = 1, N 1981 IF (ELEN (I) .EQ. 0) THEN 1982 J = -PE (I) 1983 270 CONTINUE 1984 IF (ELEN (J) .GE. 0) THEN 1985 J = -PE (J) 1986 GO TO 270 1987 ENDIF 1988 E = J 1989 K = -ELEN (E) 1990 J = I 1991 280 CONTINUE 1992 IF (ELEN (J) .GE. 0) THEN 1993 JNEXT = -PE (J) 1994 PE (J) = -E 1995 IF (ELEN (J) .EQ. 0) THEN 1996 ELEN (J) = K 1997 K = K + 1 1998 ENDIF 1999 J = JNEXT 2000 GO TO 280 2001 ENDIF 2002 ELEN (E) = -K 2003 ENDIF 2004 290 CONTINUE 2005 DO 300 I = 1, N 2006 K = abs (ELEN (I)) 2007 LAST (K) = I 2008 ELEN (I) = K 2009 300 CONTINUE 2010 500 PFREE = MAXMEM 2011 RETURN 2012 END SUBROUTINE MUMPS_162 2013 SUBROUTINE MUMPS_337(N, NBBUCK, 2014 & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, 2015 & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD) 2016 IMPLICIT NONE 2017 INTEGER N, IWLEN, PFREE, LEN(N), 2018 & ELEN(N), LAST(N), NCMPA, DEGREE(N), NEXT(N), 2019 & W(N) 2020 INTEGER PE(N), IW(IWLEN), NV(N) 2021 INTEGER NBBUCK 2022 INTEGER HEAD(0:NBBUCK+1), WF(N) 2023 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 2024 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 2025 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 2026 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, 2027 & NBFLAG, NREAL, LASTD, NELME, WF3, WF4, N2, PAS 2028 INTEGER MAXINT_N 2029 INTEGER(8) HASH, HMOD 2030 DOUBLE PRECISION RMF, RMF1 2031 DOUBLE PRECISION dummy 2032 INTEGER idummy 2033 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 2034 INTRINSIC max, min, mod, huge 2035 INTEGER TOTEL 2036 LOGICAL COMPRESS 2037 idummy = huge(idummy) - 1 2038 dummy = dble(idummy) 2039 N2 = -NBBUCK-1 2040 PAS = max((N/8), 1) 2041 WFLG = 2 2042 MAXINT_N=huge(WFLG)-N 2043 NCMPA = 0 2044 NEL = 0 2045 HMOD = int(max (1, NBBUCK-1),kind=8) 2046 DMAX = 0 2047 MEM = PFREE - 1 2048 MAXMEM = MEM 2049 MINDEG = 0 2050 NBFLAG = 0 2051 LASTD = 0 2052 HEAD(0:NBBUCK+1) = 0 2053 DO 10 I = 1, N 2054 LAST(I) = 0 2055 W(I) = 1 2056 ELEN (I) = 0 2057 10 CONTINUE 2058 IF(NV(1) .LT. 0) THEN 2059 COMPRESS = .FALSE. 2060 ELSE 2061 COMPRESS = .TRUE. 2062 ENDIF 2063 IF(COMPRESS) THEN 2064 TOTEL = 0 2065 DO I=1,N 2066 IF (LEN(I).LT.0) THEN 2067 DEGREE (I) = N2 2068 NBFLAG = NBFLAG +1 2069 IF (LEN(I).EQ.-N-1) THEN 2070 LEN (I) = 0 2071 PE (I) = 0 2072 ELSE 2073 LEN (I) = - LEN(I) 2074 ENDIF 2075 ELSE 2076 TOTEL = TOTEL + NV(I) 2077 DEGREE(I) = 0 2078 DO J= PE(I) , PE(I)+LEN(I)-1 2079 DEGREE(I) = DEGREE(I) + NV(IW(J)) 2080 ENDDO 2081 ENDIF 2082 ENDDO 2083 ELSE 2084 DO I=1,N 2085 NV(I) = 1 2086 IF (LEN(I).LT.0) THEN 2087 DEGREE (I) = N2 2088 NBFLAG = NBFLAG +1 2089 IF (LEN(I).EQ.-N-1) THEN 2090 LEN (I) = 0 2091 PE (I) = 0 2092 ELSE 2093 LEN (I) = - LEN(I) 2094 ENDIF 2095 ELSE 2096 DEGREE (I) = LEN (I) 2097 ENDIF 2098 ENDDO 2099 TOTEL = N - NBFLAG 2100 ENDIF 2101 NREAL = N - NBFLAG 2102 DO 20 I = 1, N 2103 DEG = DEGREE (I) 2104 IF (DEG.EQ.N2) THEN 2105 DEG = NBBUCK + 1 2106 IF (LASTD.EQ.0) THEN 2107 LASTD = I 2108 HEAD(DEG) = I 2109 NEXT(I) = 0 2110 LAST(I) = 0 2111 ELSE 2112 NEXT(LASTD) = I 2113 LAST(I) = LASTD 2114 LASTD = I 2115 NEXT(I) = 0 2116 ENDIF 2117 GOTO 20 2118 ENDIF 2119 IF (DEG .GT. 0) THEN 2120 WF(I) = DEG 2121 IF (DEG.GT.N) THEN 2122 DEG = min(((DEG-N)/PAS) + N , NBBUCK) 2123 ENDIF 2124 INEXT = HEAD (DEG) 2125 IF (INEXT .NE. 0) LAST (INEXT) = I 2126 NEXT (I) = INEXT 2127 HEAD (DEG) = I 2128 ELSE 2129 NEL = NEL + NV(I) 2130 ELEN (I) = -NEL 2131 PE (I) = 0 2132 W (I) = 0 2133 ENDIF 2134 20 CONTINUE 2135 NLEFT = TOTEL-NEL 2136 30 IF (NEL .LT. TOTEL) THEN 2137 DO 40 DEG = MINDEG, NBBUCK 2138 ME = HEAD (DEG) 2139 IF (ME .GT. 0) GO TO 50 2140 40 CONTINUE 2141 50 MINDEG = DEG 2142 IF (ME.LE.0) THEN 2143 NCMPA = -N 2144 CALL MUMPS_ABORT() 2145 ENDIF 2146 IF (DEG.GT.N) THEN 2147 J = NEXT(ME) 2148 K = WF(ME) 2149 55 CONTINUE 2150 IF (J.GT.0) THEN 2151 IF (WF(J).LT.K) THEN 2152 ME = J 2153 K = WF(ME) 2154 ENDIF 2155 J= NEXT(J) 2156 GOTO 55 2157 ENDIF 2158 ILAST = LAST(ME) 2159 INEXT = NEXT(ME) 2160 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 2161 IF (ILAST .NE. 0) THEN 2162 NEXT (ILAST) = INEXT 2163 ELSE 2164 HEAD (DEG) = INEXT 2165 ENDIF 2166 ELSE 2167 INEXT = NEXT (ME) 2168 IF (INEXT .NE. 0) LAST (INEXT) = 0 2169 HEAD (DEG) = INEXT 2170 ENDIF 2171 ELENME = ELEN (ME) 2172 ELEN (ME) = - (NEL + 1) 2173 NVPIV = NV (ME) 2174 NEL = NEL + NVPIV 2175 NV (ME) = -NVPIV 2176 DEGME = 0 2177 IF (ELENME .EQ. 0) THEN 2178 PME1 = PE (ME) 2179 PME2 = PME1 - 1 2180 DO 60 P = PME1, PME1 + LEN (ME) - 1 2181 I = IW (P) 2182 NVI = NV (I) 2183 IF (NVI .GT. 0) THEN 2184 DEGME = DEGME + NVI 2185 NV (I) = -NVI 2186 PME2 = PME2 + 1 2187 IW (PME2) = I 2188 IF (DEGREE(I).NE.N2) THEN 2189 ILAST = LAST (I) 2190 INEXT = NEXT (I) 2191 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 2192 IF (ILAST .NE. 0) THEN 2193 NEXT (ILAST) = INEXT 2194 ELSE 2195 IF (WF(I).GT.N) THEN 2196 DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) 2197 ELSE 2198 DEG = WF(I) 2199 ENDIF 2200 HEAD (DEG) = INEXT 2201 ENDIF 2202 ENDIF 2203 ENDIF 2204 60 CONTINUE 2205 NEWMEM = 0 2206 ELSE 2207 P = PE (ME) 2208 PME1 = PFREE 2209 SLENME = LEN (ME) - ELENME 2210 DO 120 KNT1 = 1, ELENME + 1 2211 IF (KNT1 .GT. ELENME) THEN 2212 E = ME 2213 PJ = P 2214 LN = SLENME 2215 ELSE 2216 E = IW (P) 2217 P = P + 1 2218 PJ = PE (E) 2219 LN = LEN (E) 2220 ENDIF 2221 DO 110 KNT2 = 1, LN 2222 I = IW (PJ) 2223 PJ = PJ + 1 2224 NVI = NV (I) 2225 IF (NVI .GT. 0) THEN 2226 IF (PFREE .GT. IWLEN) THEN 2227 PE (ME) = P 2228 LEN (ME) = LEN (ME) - KNT1 2229 IF (LEN (ME) .EQ. 0) PE (ME) = 0 2230 PE (E) = PJ 2231 LEN (E) = LN - KNT2 2232 IF (LEN (E) .EQ. 0) PE (E) = 0 2233 NCMPA = NCMPA + 1 2234 DO 70 J = 1, N 2235 PN = PE (J) 2236 IF (PN .GT. 0) THEN 2237 PE (J) = IW (PN) 2238 IW (PN) = -J 2239 ENDIF 2240 70 CONTINUE 2241 PDST = 1 2242 PSRC = 1 2243 PEND = PME1 - 1 2244 80 CONTINUE 2245 IF (PSRC .LE. PEND) THEN 2246 J = -IW (PSRC) 2247 PSRC = PSRC + 1 2248 IF (J .GT. 0) THEN 2249 IW (PDST) = PE (J) 2250 PE (J) = PDST 2251 PDST = PDST + 1 2252 LENJ = LEN (J) 2253 DO 90 KNT3 = 0, LENJ - 2 2254 IW (PDST + KNT3) = IW (PSRC + KNT3) 2255 90 CONTINUE 2256 PDST = PDST + LENJ - 1 2257 PSRC = PSRC + LENJ - 1 2258 ENDIF 2259 GO TO 80 2260 ENDIF 2261 P1 = PDST 2262 DO 100 PSRC = PME1, PFREE - 1 2263 IW (PDST) = IW (PSRC) 2264 PDST = PDST + 1 2265 100 CONTINUE 2266 PME1 = P1 2267 PFREE = PDST 2268 PJ = PE (E) 2269 P = PE (ME) 2270 ENDIF 2271 DEGME = DEGME + NVI 2272 NV (I) = -NVI 2273 IW (PFREE) = I 2274 PFREE = PFREE + 1 2275 IF (DEGREE(I).NE.N2) THEN 2276 ILAST = LAST (I) 2277 INEXT = NEXT (I) 2278 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 2279 IF (ILAST .NE. 0) THEN 2280 NEXT (ILAST) = INEXT 2281 ELSE 2282 IF (WF(I).GT.N) THEN 2283 DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) 2284 ELSE 2285 DEG = WF(I) 2286 ENDIF 2287 HEAD (DEG) = INEXT 2288 ENDIF 2289 ENDIF 2290 ENDIF 2291 110 CONTINUE 2292 IF (E .NE. ME) THEN 2293 PE (E) = -ME 2294 W (E) = 0 2295 ENDIF 2296 120 CONTINUE 2297 PME2 = PFREE - 1 2298 NEWMEM = PFREE - PME1 2299 MEM = MEM + NEWMEM 2300 MAXMEM = max (MAXMEM, MEM) 2301 ENDIF 2302 DEGREE (ME) = DEGME 2303 PE (ME) = PME1 2304 LEN (ME) = PME2 - PME1 + 1 2305 IF (WFLG .GT. MAXINT_N) THEN 2306 DO 130 X = 1, N 2307 IF (W (X) .NE. 0) W (X) = 1 2308 130 CONTINUE 2309 WFLG = 2 2310 ENDIF 2311 DO 150 PME = PME1, PME2 2312 I = IW (PME) 2313 ELN = ELEN (I) 2314 IF (ELN .GT. 0) THEN 2315 NVI = -NV (I) 2316 WNVI = WFLG - NVI 2317 DO 140 P = PE (I), PE (I) + ELN - 1 2318 E = IW (P) 2319 WE = W (E) 2320 IF (WE .GE. WFLG) THEN 2321 WE = WE - NVI 2322 ELSE IF (WE .NE. 0) THEN 2323 WE = DEGREE (E) + WNVI 2324 WF(E) = 0 2325 ENDIF 2326 W (E) = WE 2327 140 CONTINUE 2328 ENDIF 2329 150 CONTINUE 2330 DO 180 PME = PME1, PME2 2331 I = IW (PME) 2332 P1 = PE (I) 2333 P2 = P1 + ELEN (I) - 1 2334 PN = P1 2335 HASH = 0_8 2336 DEG = 0 2337 WF3 = 0 2338 WF4 = 0 2339 NVI = -NV(I) 2340 DO 160 P = P1, P2 2341 E = IW (P) 2342 DEXT = W (E) - WFLG 2343 IF (DEXT .GT. 0) THEN 2344 IF ( WF(E) .EQ. 0 ) THEN 2345 WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) 2346 ENDIF 2347 WF4 = WF4 + WF(E) 2348 DEG = DEG + DEXT 2349 IW (PN) = E 2350 PN = PN + 1 2351 HASH = HASH + int(E, kind=8) 2352 ELSE IF (DEXT .EQ. 0) THEN 2353#if defined (NOAGG4) 2354 IW (PN) = E 2355 PN = PN + 1 2356 HASH = HASH + int(E,kind=8) 2357#else 2358 PE (E) = -ME 2359 W (E) = 0 2360#endif 2361 ENDIF 2362 160 CONTINUE 2363 ELEN (I) = PN - P1 + 1 2364 P3 = PN 2365 DO 170 P = P2 + 1, P1 + LEN (I) - 1 2366 J = IW (P) 2367 NVJ = NV (J) 2368 IF (NVJ .GT. 0) THEN 2369 DEG = DEG + NVJ 2370 WF3 = WF3 + NVJ 2371 IW (PN) = J 2372 PN = PN + 1 2373 HASH = HASH + int(J,kind=8) 2374 ENDIF 2375 170 CONTINUE 2376 IF (DEGREE(I).EQ.N2) DEG = N2 2377#if defined (NOAGG4) 2378 IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN 2379#else 2380 IF (DEG .EQ. 0) THEN 2381#endif 2382 PE (I) = -ME 2383 NVI = -NV (I) 2384 DEGME = DEGME - NVI 2385 NVPIV = NVPIV + NVI 2386 NEL = NEL + NVI 2387 NV (I) = 0 2388 ELEN (I) = 0 2389 ELSE 2390 IF (DEGREE(I).NE.N2) THEN 2391 IF ( DEGREE (I).LT.DEG ) THEN 2392 WF4 = 0 2393 WF3 = 0 2394 ELSE 2395 DEGREE(I) = DEG 2396 ENDIF 2397 ENDIF 2398 WF(I) = WF4 + 2*NVI*WF3 2399 IW (PN) = IW (P3) 2400 IW (P3) = IW (P1) 2401 IW (P1) = ME 2402 LEN (I) = PN - P1 + 1 2403 IF (DEG.NE.N2) THEN 2404 HASH = mod (HASH, HMOD) + 1_8 2405 J = HEAD (HASH) 2406 IF (J .LE. 0) THEN 2407 NEXT (I) = -J 2408 HEAD (HASH) = -I 2409 ELSE 2410 NEXT (I) = LAST (J) 2411 LAST (J) = I 2412 ENDIF 2413 LAST (I) = int(HASH,kind=kind(LAST)) 2414 ENDIF 2415 ENDIF 2416 180 CONTINUE 2417 DEGREE (ME) = DEGME 2418 DMAX = max (DMAX, DEGME) 2419 WFLG = WFLG + DMAX 2420 IF (WFLG .GT. MAXINT_N) THEN 2421 DO 190 X = 1, N 2422 IF (W (X) .NE. 0) W (X) = 1 2423 190 CONTINUE 2424 WFLG = 2 2425 ENDIF 2426 DO 250 PME = PME1, PME2 2427 I = IW (PME) 2428 IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN 2429 HASH = int(LAST (I),kind=8) 2430 J = HEAD (HASH) 2431 IF (J .EQ. 0) GO TO 250 2432 IF (J .LT. 0) THEN 2433 I = -J 2434 HEAD (HASH) = 0 2435 ELSE 2436 I = LAST (J) 2437 LAST (J) = 0 2438 ENDIF 2439 IF (I .EQ. 0) GO TO 250 2440 200 CONTINUE 2441 IF (NEXT (I) .NE. 0) THEN 2442 LN = LEN (I) 2443 ELN = ELEN (I) 2444 DO 210 P = PE (I) + 1, PE (I) + LN - 1 2445 W (IW (P)) = WFLG 2446 210 CONTINUE 2447 JLAST = I 2448 J = NEXT (I) 2449 220 CONTINUE 2450 IF (J .NE. 0) THEN 2451 IF (LEN (J) .NE. LN) GO TO 240 2452 IF (ELEN (J) .NE. ELN) GO TO 240 2453 DO 230 P = PE (J) + 1, PE (J) + LN - 1 2454 IF (W (IW (P)) .NE. WFLG) GO TO 240 2455 230 CONTINUE 2456 PE (J) = -I 2457 WF(I) = max(WF(I),WF(J)) 2458 NV (I) = NV (I) + NV (J) 2459 NV (J) = 0 2460 ELEN (J) = 0 2461 J = NEXT (J) 2462 NEXT (JLAST) = J 2463 GO TO 220 2464 240 CONTINUE 2465 JLAST = J 2466 J = NEXT (J) 2467 GO TO 220 2468 ENDIF 2469 WFLG = WFLG + 1 2470 I = NEXT (I) 2471 IF (I .NE. 0) GO TO 200 2472 ENDIF 2473 ENDIF 2474 250 CONTINUE 2475 P = PME1 2476 NLEFT = TOTEL - NEL 2477 DO 260 PME = PME1, PME2 2478 I = IW (PME) 2479 NVI = -NV (I) 2480 IF (NVI .GT. 0) THEN 2481 NV (I) = NVI 2482 IF (DEGREE(I).NE.N2) THEN 2483 DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) 2484 IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN 2485 DEG = DEGREE(I) 2486 RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) 2487 & - dble(WF(I)) 2488 DEGREE(I) = NLEFT - NVI 2489 DEG = DEGREE(I) 2490 RMF = dble(DEG)*dble(DEG-1) 2491 & - dble(DEGME-NVI)*dble(DEGME-NVI-1) 2492 RMF = min(RMF, RMF1) 2493 ELSE 2494 DEG = DEGREE(I) 2495 DEGREE(I) = DEGREE (I) + DEGME - NVI 2496 RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) 2497 & - dble(WF(I)) 2498 ENDIF 2499 RMF = RMF / dble(NVI+1) 2500 IF (RMF.LT.dummy) THEN 2501 WF(I) = int ( anint( RMF )) 2502 ELSEIF (RMF / dble(N) .LT. dummy) THEN 2503 WF(I) = int ( anint( RMF/dble(N) )) 2504 ELSE 2505 WF(I) = idummy 2506 ENDIF 2507 WF(I) = max(1,WF(I)) 2508 DEG = WF(I) 2509 IF (DEG.GT.N) THEN 2510 DEG = min(((DEG-N)/PAS) + N , NBBUCK) 2511 ENDIF 2512 INEXT = HEAD (DEG) 2513 IF (INEXT .NE. 0) LAST (INEXT) = I 2514 NEXT (I) = INEXT 2515 LAST (I) = 0 2516 HEAD (DEG) = I 2517 MINDEG = min (MINDEG, DEG) 2518 ENDIF 2519 IW (P) = I 2520 P = P + 1 2521 ENDIF 2522 260 CONTINUE 2523 NV (ME) = NVPIV + DEGME 2524 LEN (ME) = P - PME1 2525 IF (LEN (ME) .EQ. 0) THEN 2526 PE (ME) = 0 2527 W (ME) = 0 2528 ENDIF 2529 IF (NEWMEM .NE. 0) THEN 2530 PFREE = P 2531 MEM = MEM - NEWMEM + LEN (ME) 2532 ENDIF 2533 GO TO 30 2534 ENDIF 2535 IF (NEL.LT.N) THEN 2536 DO DEG = MINDEG, NBBUCK+1 2537 ME = HEAD (DEG) 2538 IF (ME .GT. 0) GO TO 51 2539 ENDDO 2540 51 MINDEG = DEG 2541 NELME = -(NEL+1) 2542 DO X=1,N 2543 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 2544 PE(X) = -ME 2545 ELSEIF (DEGREE(X).EQ.N2) THEN 2546 NEL = NEL + NV(X) 2547 PE(X) = -ME 2548 ELEN(X) = 0 2549 NV(X) = 0 2550 ENDIF 2551 ENDDO 2552 ELEN(ME) = NELME 2553 NV(ME) = N-NREAL 2554 PE(ME) = 0 2555 IF (NEL.NE.N) THEN 2556 NCMPA = -N - 1 2557 GOTO 500 2558 ENDIF 2559 ENDIF 2560 DO 290 I = 1, N 2561 IF (ELEN (I) .EQ. 0) THEN 2562 J = -PE (I) 2563 270 CONTINUE 2564 IF (ELEN (J) .GE. 0) THEN 2565 J = -PE (J) 2566 GO TO 270 2567 ENDIF 2568 E = J 2569 K = -ELEN (E) 2570 J = I 2571 280 CONTINUE 2572 IF (ELEN (J) .GE. 0) THEN 2573 JNEXT = -PE (J) 2574 PE (J) = -E 2575 IF (ELEN (J) .EQ. 0) THEN 2576 ELEN (J) = K 2577 K = K + 1 2578 ENDIF 2579 J = JNEXT 2580 GO TO 280 2581 ENDIF 2582 ELEN (E) = -K 2583 ENDIF 2584 290 CONTINUE 2585 IF(COMPRESS) THEN 2586 LAST(1:N) = 0 2587 DEGREE(1:TOTEL-N)=0 2588 DO I = 1, N 2589 K = abs (ELEN (I)) 2590 IF ( K <= N ) THEN 2591 LAST (K) = I 2592 ELSE 2593 DEGREE(K-N)=I 2594 ENDIF 2595 ENDDO 2596 I = 1 2597 DO K = 1, N 2598 IF(LAST (K) .NE. 0) THEN 2599 LAST(I) = LAST(K) 2600 ELEN(LAST(K)) = I 2601 I = I + 1 2602 ENDIF 2603 ENDDO 2604 DO K = N+1, TOTEL 2605 IF (DEGREE(K-N) .NE. 0) THEN 2606 LAST(I)=DEGREE(K-N) 2607 ELEN(DEGREE(K-N)) = I 2608 I = I + 1 2609 ENDIF 2610 END DO 2611 ELSE 2612 DO 300 I = 1, N 2613 K = abs (ELEN (I)) 2614 LAST (K) = I 2615 ELEN (I) = K 2616300 CONTINUE 2617 ENDIF 2618 500 PFREE = MAXMEM 2619 RETURN 2620 END SUBROUTINE MUMPS_337 2621 SUBROUTINE MUMPS_421 2622 & (TOTEL, IVersion, THRESH, NDENSE, 2623 & N, IWLEN, PE, PFREE, LEN, IW, NV, 2624 & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W) 2625 INTEGER TOTEL 2626 INTEGER N, IWLEN, PE(N), PFREE, LEN(N), IW(IWLEN), NV(N), 2627 & ELEN(N), NCMPA, DEGREE(N), 2628 & LAST(TOTEL), HEAD(TOTEL), NEXT(N), 2629 & W(N) 2630 INTEGER NDENSE(N) 2631 INTEGER IVersion, THRESH 2632 INTEGER THRESM, MINDEN, MAXDEN, NDME 2633 INTEGER NBD,NBED, NBDM, LASTD, NELME 2634 LOGICAL IDENSE 2635 DOUBLE PRECISION RELDEN 2636 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 2637 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 2638 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 2639 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X 2640 INTEGER MAXINT_N 2641 INTEGER(8) HASH, HMOD 2642 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 2643 INTRINSIC max, min, mod 2644 LOGICAL COMPRESS 2645 IF (THRESH.GT.0) THEN 2646 THRESM = min(N,THRESH) 2647 DO I=1,N 2648 THRESM = max(THRESM, LEN(I)) 2649 ENDDO 2650 RELDEN = dble(PFREE-1)/dble(N) 2651 THRESM = int(RELDEN)*10 + (THRESM-int(RELDEN))/10 + 1 2652 ELSE 2653 THRESM = TOTEL 2654 ENDIF 2655 IF (THRESM.GE.0) THEN 2656 IF ((THRESM.GT.TOTEL).OR.(THRESM.LT.2)) THEN 2657 THRESM = TOTEL 2658 ENDIF 2659 ENDIF 2660 LASTD = 0 2661 NBD = 0 2662 NBED = 0 2663 NBDM = 0 2664 WFLG = 2 2665 MAXINT_N=huge(WFLG)-N 2666 MINDEG = 1 2667 NCMPA = 0 2668 NEL = 0 2669 HMOD = int(max (1, N-1),kind=8) 2670 DMAX = 0 2671 MEM = PFREE - 1 2672 MAXMEM = MEM 2673 DO 10 I = 1, N 2674 NDENSE(I)= 0 2675 LAST (I) = 0 2676 HEAD (I) = 0 2677 W (I) = 1 2678 ELEN (I) = 0 2679 10 CONTINUE 2680 HEAD(N:TOTEL) = 0 2681 LAST(N:TOTEL) = 0 2682 IF(NV(1) .LT. 0) THEN 2683 COMPRESS = .FALSE. 2684 ELSE 2685 COMPRESS = .TRUE. 2686 ENDIF 2687 IF(COMPRESS) THEN 2688 DO I=1,N 2689 DEGREE(I) = 0 2690 DO J= PE(I) , PE(I)+LEN(I)-1 2691 DEGREE(I) = DEGREE(I) + NV(IW(J)) 2692 ENDDO 2693 ENDDO 2694 ELSE 2695 DO I=1,N 2696 NV(I) = 1 2697 DEGREE (I) = LEN (I) 2698 ENDDO 2699 ENDIF 2700 DO 20 I = 1, N 2701 DEG = DEGREE (I) 2702 IF (DEG .GT. 0) THEN 2703 IF ( (THRESM.GE.0) .AND. 2704 & (DEG+NV(I).GE.THRESM) ) THEN 2705 NBD = NBD+1 2706 IF (DEG+NV(I).NE.TOTEL-NEL) THEN 2707 DEGREE(I) = DEGREE(I)+TOTEL+1 2708 DEG = TOTEL 2709 INEXT = HEAD (DEG) 2710 IF (INEXT .NE. 0) LAST (INEXT) = I 2711 NEXT (I) = INEXT 2712 HEAD (DEG) = I 2713 LAST(I) = 0 2714 IF (LASTD.EQ.0) LASTD=I 2715 ELSE 2716 NBED = NBED+1 2717 DEGREE(I) = TOTEL+1 2718 DEG = TOTEL 2719 IF (LASTD.EQ.0) THEN 2720 LASTD = I 2721 HEAD(DEG) = I 2722 NEXT(I) = 0 2723 LAST(I) = 0 2724 ELSE 2725 NEXT(LASTD) = I 2726 LAST(I) = LASTD 2727 LASTD = I 2728 NEXT(I) = 0 2729 ENDIF 2730 ENDIF 2731 ELSE 2732 INEXT = HEAD (DEG) 2733 IF (INEXT .NE. 0) LAST (INEXT) = I 2734 NEXT (I) = INEXT 2735 HEAD (DEG) = I 2736 ENDIF 2737 ELSE 2738 NEL = NEL + NV(I) 2739 ELEN (I) = -NEL 2740 PE (I) = 0 2741 W (I) = 0 2742 ENDIF 2743 20 CONTINUE 2744 IF (NBD.EQ.0) THRESM = TOTEL 2745 NLEFT = TOTEL - NEL 2746 30 IF (NEL .LT. TOTEL) THEN 2747 DO 40 DEG = MINDEG, TOTEL 2748 ME = HEAD (DEG) 2749 IF (ME .GT. 0) GO TO 50 2750 40 CONTINUE 2751 50 MINDEG = DEG 2752 IF (DEG.LT.TOTEL) THEN 2753 INEXT = NEXT (ME) 2754 IF (INEXT .NE. 0) LAST (INEXT) = 0 2755 HEAD (DEG) = INEXT 2756 ELSE 2757 NBDM = max(NBDM,NBD) 2758 IF (DEGREE(ME).GT.TOTEL+1) THEN 2759 MINDEN = NBD 2760 MAXDEN = 0 2761 IF (WFLG .GT. MAXINT_N) THEN 2762 DO 52 X = 1, N 2763 IF (W (X) .NE. 0) W (X) = 1 2764 52 CONTINUE 2765 WFLG = 2 2766 ENDIF 2767 WFLG = WFLG + 1 2768 51 CONTINUE 2769 INEXT = NEXT (ME) 2770 IF (INEXT .NE. 0) THEN 2771 LAST (INEXT) = 0 2772 ELSE 2773 LASTD = 0 2774 ENDIF 2775 NDENSE(ME) = 0 2776 W(ME) = WFLG 2777 P1 = PE(ME) 2778 P2 = P1 + LEN(ME) -1 2779 LN = P1 2780 ELN = P1 2781 DO 55 P=P1,P2 2782 E= IW(P) 2783 IF (W(E).EQ.WFLG) GOTO 55 2784 W(E) = WFLG 2785 IF (PE(E).LT.0) THEN 2786 X = E 2787 53 X = -PE(X) 2788 IF (W(X) .EQ.WFLG) GOTO 55 2789 W(X) = WFLG 2790 IF ( PE(X) .LT. 0 ) GOTO 53 2791 E = X 2792 ENDIF 2793 IF (ELEN(E).LT.0) THEN 2794 NDENSE(E) = NDENSE(E) - NV(ME) 2795 IW(LN) = IW(ELN) 2796 IW(ELN) = E 2797 LN = LN+1 2798 ELN = ELN + 1 2799 PME1 = PE(E) 2800 DO 54 PME = PME1, PME1+LEN(E)-1 2801 X = IW(PME) 2802 IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN 2803 NDENSE(ME) = NDENSE(ME) + NV(X) 2804 W(X) = WFLG 2805 ENDIF 2806 54 CONTINUE 2807 ELSE 2808 NDENSE(ME) = NDENSE(ME) + NV(E) 2809 IW(LN)=E 2810 LN = LN+1 2811 ENDIF 2812 55 CONTINUE 2813 WFLG = WFLG + 1 2814 LEN(ME) = LN-P1 2815 ELEN(ME) = ELN- P1 2816 NDME = NDENSE(ME)+NV(ME) 2817 MINDEN = min (MINDEN, NDME) 2818 MAXDEN = max (MAXDEN, NDME) 2819 IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 2820 IF (IVersion.EQ.1) THEN 2821 DEG = max (DEGREE(ME)-(TOTEL+1), 1) 2822 ELSE 2823 DEG = NDENSE(ME) 2824 ENDIF 2825 DEGREE(ME) = DEG 2826 MINDEG = min(DEG,MINDEG) 2827 JNEXT = HEAD(DEG) 2828 IF (JNEXT.NE. 0) LAST (JNEXT) = ME 2829 NEXT(ME) = JNEXT 2830 HEAD(DEG) = ME 2831 ME = INEXT 2832 IF (ME.NE.0) THEN 2833 IF (DEGREE(ME).GT.(TOTEL+1) ) GOTO 51 2834 ENDIF 2835 HEAD (TOTEL) = ME 2836 IF (IVersion .EQ.1 ) THEN 2837 THRESM = TOTEL 2838 ELSE 2839 THRESM=max(THRESM*2,MINDEN+(MAXDEN-MINDEN)/2) 2840 THRESM = min(THRESM,NBD) 2841 IF (THRESM.GE.NBD) THRESM=TOTEL 2842 ENDIF 2843 NBD = NBED 2844 GOTO 30 2845 ENDIF 2846 IF (DEGREE(ME).EQ.TOTEL+1) THEN 2847 IF (NBD.NE.NBED) THEN 2848 write(6,*) ' Internal ERROR quasi dense rows remains' 2849 CALL MUMPS_ABORT() 2850 ENDIF 2851 NELME = -(NEL+1) 2852 DO 59 X=1,N 2853 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 2854 PE(X) = -ME 2855 ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN 2856 NEL = NEL + NV(X) 2857 PE(X) = -ME 2858 ELEN(X) = 0 2859 NV(X) = 0 2860 ENDIF 2861 59 CONTINUE 2862 ELEN(ME) = NELME 2863 NV(ME) = NBD 2864 PE(ME) = 0 2865 IF (NEL.NE.TOTEL) THEN 2866 write(6,*) 'Internal ERROR 2 detected in QAMD' 2867 write(6,*) ' NEL not equal to N: N, NEL =',N,NEL 2868 CALL MUMPS_ABORT() 2869 ENDIF 2870 GOTO 265 2871 ENDIF 2872 ENDIF 2873 ELENME = ELEN (ME) 2874 ELEN (ME) = - (NEL + 1) 2875 NVPIV = NV (ME) 2876 NEL = NEL + NVPIV 2877 NDENSE(ME) = 0 2878 NV (ME) = -NVPIV 2879 DEGME = 0 2880 IF (ELENME .EQ. 0) THEN 2881 PME1 = PE (ME) 2882 PME2 = PME1 - 1 2883 DO 60 P = PME1, PME1 + LEN (ME) - 1 2884 I = IW (P) 2885 NVI = NV (I) 2886 IF (NVI .GT. 0) THEN 2887 DEGME = DEGME + NVI 2888 NV (I) = -NVI 2889 PME2 = PME2 + 1 2890 IW (PME2) = I 2891 IF (DEGREE(I).LE.TOTEL) THEN 2892 ILAST = LAST (I) 2893 INEXT = NEXT (I) 2894 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 2895 IF (ILAST .NE. 0) THEN 2896 NEXT (ILAST) = INEXT 2897 ELSE 2898 HEAD (DEGREE (I)) = INEXT 2899 ENDIF 2900 ELSE 2901 NDENSE(ME) = NDENSE(ME) + NVI 2902 ENDIF 2903 ENDIF 2904 60 CONTINUE 2905 NEWMEM = 0 2906 ELSE 2907 P = PE (ME) 2908 PME1 = PFREE 2909 SLENME = LEN (ME) - ELENME 2910 DO 120 KNT1 = 1, ELENME + 1 2911 IF (KNT1 .GT. ELENME) THEN 2912 E = ME 2913 PJ = P 2914 LN = SLENME 2915 ELSE 2916 E = IW (P) 2917 P = P + 1 2918 PJ = PE (E) 2919 LN = LEN (E) 2920 ENDIF 2921 DO 110 KNT2 = 1, LN 2922 I = IW (PJ) 2923 PJ = PJ + 1 2924 NVI = NV (I) 2925 IF (NVI .GT. 0) THEN 2926 IF (PFREE .GT. IWLEN) THEN 2927 PE (ME) = P 2928 LEN (ME) = LEN (ME) - KNT1 2929 IF (LEN (ME) .EQ. 0) PE (ME) = 0 2930 PE (E) = PJ 2931 LEN (E) = LN - KNT2 2932 IF (LEN (E) .EQ. 0) PE (E) = 0 2933 NCMPA = NCMPA + 1 2934 DO 70 J = 1, N 2935 PN = PE (J) 2936 IF (PN .GT. 0) THEN 2937 PE (J) = IW (PN) 2938 IW (PN) = -J 2939 ENDIF 2940 70 CONTINUE 2941 PDST = 1 2942 PSRC = 1 2943 PEND = PME1 - 1 2944 80 CONTINUE 2945 IF (PSRC .LE. PEND) THEN 2946 J = -IW (PSRC) 2947 PSRC = PSRC + 1 2948 IF (J .GT. 0) THEN 2949 IW (PDST) = PE (J) 2950 PE (J) = PDST 2951 PDST = PDST + 1 2952 LENJ = LEN (J) 2953 DO 90 KNT3 = 0, LENJ - 2 2954 IW (PDST + KNT3) = IW (PSRC + KNT3) 2955 90 CONTINUE 2956 PDST = PDST + LENJ - 1 2957 PSRC = PSRC + LENJ - 1 2958 ENDIF 2959 GO TO 80 2960 ENDIF 2961 P1 = PDST 2962 DO 100 PSRC = PME1, PFREE - 1 2963 IW (PDST) = IW (PSRC) 2964 PDST = PDST + 1 2965 100 CONTINUE 2966 PME1 = P1 2967 PFREE = PDST 2968 PJ = PE (E) 2969 P = PE (ME) 2970 ENDIF 2971 DEGME = DEGME + NVI 2972 NV (I) = -NVI 2973 IW (PFREE) = I 2974 PFREE = PFREE + 1 2975 IF (DEGREE(I).LE.TOTEL) THEN 2976 ILAST = LAST (I) 2977 INEXT = NEXT (I) 2978 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 2979 IF (ILAST .NE. 0) THEN 2980 NEXT (ILAST) = INEXT 2981 ELSE 2982 HEAD (DEGREE (I)) = INEXT 2983 ENDIF 2984 ELSE 2985 NDENSE(ME) = NDENSE(ME) + NVI 2986 ENDIF 2987 ENDIF 2988 110 CONTINUE 2989 IF (E .NE. ME) THEN 2990 PE (E) = -ME 2991 W (E) = 0 2992 ENDIF 2993 120 CONTINUE 2994 PME2 = PFREE - 1 2995 NEWMEM = PFREE - PME1 2996 MEM = MEM + NEWMEM 2997 MAXMEM = max (MAXMEM, MEM) 2998 ENDIF 2999 DEGREE (ME) = DEGME 3000 PE (ME) = PME1 3001 LEN (ME) = PME2 - PME1 + 1 3002 IF (WFLG .GT. MAXINT_N) THEN 3003 DO 130 X = 1, N 3004 IF (W (X) .NE. 0) W (X) = 1 3005 130 CONTINUE 3006 WFLG = 2 3007 ENDIF 3008 DO 150 PME = PME1, PME2 3009 I = IW (PME) 3010 IF (DEGREE(I).GT.TOTEL) GOTO 150 3011 ELN = ELEN (I) 3012 IF (ELN .GT. 0) THEN 3013 NVI = -NV (I) 3014 WNVI = WFLG - NVI 3015 DO 140 P = PE (I), PE (I) + ELN - 1 3016 E = IW (P) 3017 WE = W (E) 3018 IF (WE .GE. WFLG) THEN 3019 WE = WE - NVI 3020 ELSE IF (WE .NE. 0) THEN 3021 WE = DEGREE (E) + WNVI - NDENSE(E) 3022 ENDIF 3023 W (E) = WE 3024 140 CONTINUE 3025 ENDIF 3026 150 CONTINUE 3027 DO 180 PME = PME1, PME2 3028 I = IW (PME) 3029 IF (DEGREE(I).GT.TOTEL) GOTO 180 3030 P1 = PE (I) 3031 P2 = P1 + ELEN (I) - 1 3032 PN = P1 3033 HASH = 0_8 3034 DEG = 0 3035 DO 160 P = P1, P2 3036 E = IW (P) 3037 DEXT = W (E) - WFLG 3038 IF (DEXT .GT. 0) THEN 3039 DEG = DEG + DEXT 3040 IW (PN) = E 3041 PN = PN + 1 3042 HASH = HASH + int(E,kind=8) 3043#if defined (NOAGG5) 3044 ELSE IF (DEXT .EQ. 0) THEN 3045 IW (PN) = E 3046 PN = PN + 1 3047 HASH = HASH + int(E,kind=8) 3048#else 3049 ELSE IF ((DEXT .EQ. 0) .AND. 3050 & (NDENSE(ME).EQ.NBD)) THEN 3051 PE (E) = -ME 3052 W (E) = 0 3053 ELSE IF (DEXT.EQ.0) THEN 3054 IW(PN) = E 3055 PN = PN+1 3056 HASH = HASH + int(E,kind=8) 3057#endif 3058 ENDIF 3059 160 CONTINUE 3060 ELEN (I) = PN - P1 + 1 3061 P3 = PN 3062 DO 170 P = P2 + 1, P1 + LEN (I) - 1 3063 J = IW (P) 3064 NVJ = NV (J) 3065 IF (NVJ .GT. 0) THEN 3066 IF (DEGREE(J).LE.TOTEL) DEG=DEG+NVJ 3067 IW (PN) = J 3068 PN = PN + 1 3069 HASH = HASH + int(J,kind=8) 3070 ENDIF 3071 170 CONTINUE 3072#if defined (NOAGG5) 3073 IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN 3074#else 3075 IF ((DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) THEN 3076#endif 3077 PE (I) = -ME 3078 NVI = -NV (I) 3079 DEGME = DEGME - NVI 3080 NVPIV = NVPIV + NVI 3081 NEL = NEL + NVI 3082 NV (I) = 0 3083 ELEN (I) = 0 3084 ELSE 3085 DEGREE(I) = min (DEG+NBD-NDENSE(ME), 3086 & DEGREE(I)) 3087 IW (PN) = IW (P3) 3088 IW (P3) = IW (P1) 3089 IW (P1) = ME 3090 LEN (I) = PN - P1 + 1 3091 HASH = mod (HASH, HMOD) + 1_8 3092 J = HEAD (HASH) 3093 IF (J .LE. 0) THEN 3094 NEXT (I) = -J 3095 HEAD (HASH) = -I 3096 ELSE 3097 NEXT (I) = LAST (J) 3098 LAST (J) = I 3099 ENDIF 3100 LAST (I) = int(HASH,kind=kind(LAST)) 3101 ENDIF 3102 180 CONTINUE 3103 DEGREE (ME) = DEGME 3104 DMAX = max (DMAX, DEGME) 3105 WFLG = WFLG + DMAX 3106 IF (WFLG .GT. MAXINT_N) THEN 3107 DO 190 X = 1, N 3108 IF (W (X) .NE. 0) W (X) = 1 3109 190 CONTINUE 3110 WFLG = 2 3111 ENDIF 3112 DO 250 PME = PME1, PME2 3113 I = IW (PME) 3114 IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.TOTEL) ) THEN 3115 HASH = int(LAST (I),kind=8) 3116 J = HEAD (HASH) 3117 IF (J .EQ. 0) GO TO 250 3118 IF (J .LT. 0) THEN 3119 I = -J 3120 HEAD (HASH) = 0 3121 ELSE 3122 I = LAST (J) 3123 LAST (J) = 0 3124 ENDIF 3125 IF (I .EQ. 0) GO TO 250 3126 200 CONTINUE 3127 IF (NEXT (I) .NE. 0) THEN 3128 LN = LEN (I) 3129 ELN = ELEN (I) 3130 DO 210 P = PE (I) + 1, PE (I) + LN - 1 3131 W (IW (P)) = WFLG 3132 210 CONTINUE 3133 JLAST = I 3134 J = NEXT (I) 3135 220 CONTINUE 3136 IF (J .NE. 0) THEN 3137 IF (LEN (J) .NE. LN) GO TO 240 3138 IF (ELEN (J) .NE. ELN) GO TO 240 3139 DO 230 P = PE (J) + 1, PE (J) + LN - 1 3140 IF (W (IW (P)) .NE. WFLG) GO TO 240 3141 230 CONTINUE 3142 PE (J) = -I 3143 NV (I) = NV (I) + NV (J) 3144 NV (J) = 0 3145 ELEN (J) = 0 3146 J = NEXT (J) 3147 NEXT (JLAST) = J 3148 GO TO 220 3149 240 CONTINUE 3150 JLAST = J 3151 J = NEXT (J) 3152 GO TO 220 3153 ENDIF 3154 WFLG = WFLG + 1 3155 I = NEXT (I) 3156 IF (I .NE. 0) GO TO 200 3157 ENDIF 3158 ENDIF 3159 250 CONTINUE 3160 P = PME1 3161 NLEFT = TOTEL - NEL 3162 DO 260 PME = PME1, PME2 3163 I = IW (PME) 3164 NVI = -NV (I) 3165 IF (NVI .GT. 0) THEN 3166 NV (I) = NVI 3167 IF (DEGREE(I).LE.TOTEL) THEN 3168 DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) 3169 DEGREE (I) = DEG 3170 IDENSE = .FALSE. 3171 IF ( (Iversion .NE. 1).AND. (THRESM.GE.0)) THEN 3172 IF (DEG+NVI .GE. THRESM) THEN 3173 IF (THRESM.EQ.TOTEL) THEN 3174 IF ((ELEN(I).LE.2) .AND. ((DEG+NVI).EQ.NLEFT) ) THEN 3175 DEGREE(I) = TOTEL+1 3176 IDENSE = .TRUE. 3177 ENDIF 3178 ELSE 3179 IDENSE = .TRUE. 3180 IF ((ELEN(I).LE.2).AND.((DEG+NVI).EQ.NLEFT) ) THEN 3181 DEGREE(I) = TOTEL+1 3182 ELSE 3183 DEGREE(I) = TOTEL+1+DEGREE(I) 3184 ENDIF 3185 ENDIF 3186 ENDIF 3187 IF (IDENSE) THEN 3188 P1 = PE(I) 3189 P2 = P1 + ELEN(I) - 1 3190 IF (P2.GE.P1) THEN 3191 DO 264 PJ=P1,P2 3192 E= IW(PJ) 3193 NDENSE (E) = NDENSE(E) + NVI 3194 264 CONTINUE 3195 ENDIF 3196 NBD = NBD+NVI 3197 DEG = TOTEL 3198 IF (DEGREE(I).EQ.TOTEL+1) THEN 3199 NBED = NBED +NVI 3200 IF (LASTD.EQ.0) THEN 3201 LASTD = I 3202 HEAD(DEG) = I 3203 NEXT(I) = 0 3204 LAST(I) = 0 3205 ELSE 3206 NEXT(LASTD) = I 3207 LAST(I) = LASTD 3208 LASTD = I 3209 NEXT(I) = 0 3210 ENDIF 3211 ELSE 3212 INEXT = HEAD(DEG) 3213 IF (INEXT .NE. 0) LAST (INEXT) = I 3214 NEXT (I) = INEXT 3215 HEAD (DEG) = I 3216 LAST(I) = 0 3217 IF (LASTD.EQ.0) LASTD=I 3218 ENDIF 3219 ENDIF 3220 ENDIF 3221 IF (.NOT.IDENSE) THEN 3222 INEXT = HEAD (DEG) 3223 IF (INEXT .NE. 0) LAST (INEXT) = I 3224 NEXT (I) = INEXT 3225 LAST (I) = 0 3226 HEAD (DEG) = I 3227 ENDIF 3228 MINDEG = min (MINDEG, DEG) 3229 ENDIF 3230 IW (P) = I 3231 P = P + 1 3232 ENDIF 3233 260 CONTINUE 3234 NV (ME) = NVPIV + DEGME 3235 LEN (ME) = P - PME1 3236 IF (LEN (ME) .EQ. 0) THEN 3237 PE (ME) = 0 3238 W (ME) = 0 3239 ENDIF 3240 IF (NEWMEM .NE. 0) THEN 3241 PFREE = P 3242 MEM = MEM - NEWMEM + LEN (ME) 3243 ENDIF 3244 GO TO 30 3245 ENDIF 3246 265 CONTINUE 3247 DO 290 I = 1, N 3248 IF (ELEN (I) .EQ. 0) THEN 3249 J = -PE (I) 3250 270 CONTINUE 3251 IF (ELEN (J) .GE. 0) THEN 3252 J = -PE (J) 3253 GO TO 270 3254 ENDIF 3255 E = J 3256 K = -ELEN (E) 3257 J = I 3258 280 CONTINUE 3259 IF (ELEN (J) .GE. 0) THEN 3260 JNEXT = -PE (J) 3261 PE (J) = -E 3262 IF (ELEN (J) .EQ. 0) THEN 3263 ELEN (J) = K 3264 K = K + 1 3265 ENDIF 3266 J = JNEXT 3267 GO TO 280 3268 ENDIF 3269 ELEN (E) = -K 3270 ENDIF 3271 290 CONTINUE 3272 IF(COMPRESS) THEN 3273 LAST(1:N) = 0 3274 DEGREE(1:TOTEL-N)=0 3275 DO I = 1, N 3276 K = abs (ELEN (I)) 3277 IF ( K <= N ) THEN 3278 LAST (K) = I 3279 ELSE 3280 DEGREE(K-N)=I 3281 ENDIF 3282 ENDDO 3283 I = 1 3284 DO K = 1, N 3285 IF(LAST (K) .NE. 0) THEN 3286 LAST(I) = LAST(K) 3287 ELEN(LAST(K)) = I 3288 I = I + 1 3289 ENDIF 3290 ENDDO 3291 DO K = N+1, TOTEL 3292 IF (DEGREE(K-N) .NE. 0) THEN 3293 LAST(I)=DEGREE(K-N) 3294 ELEN(DEGREE(K-N)) = I 3295 I = I + 1 3296 ENDIF 3297 END DO 3298 ELSE 3299 DO 300 I = 1, N 3300 K = abs (ELEN (I)) 3301 LAST (K) = I 3302 ELEN (I) = K 3303 300 CONTINUE 3304 ENDIF 3305 PFREE = MAXMEM 3306 RETURN 3307 END SUBROUTINE MUMPS_421 3308 SUBROUTINE MUMPS_560(N, NBBUCK, 3309 & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, 3310 & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD, 3311 & CONSTRAINT,THESON) 3312 IMPLICIT NONE 3313 INTEGER N, IWLEN, PFREE, LEN(N), 3314 & ELEN(N), LAST(N), NCMPA, DEGREE(N), NEXT(N), 3315 & W(N) 3316 INTEGER PE(N), IW(IWLEN), NV(N) 3317 INTEGER NBBUCK 3318 INTEGER HEAD(0:NBBUCK+1), WF(N) 3319 INTEGER CONSTRAINT(N),THESON(N) 3320 INTEGER PREV,TOTO 3321 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 3322 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 3323 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 3324 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, 3325 & NBFLAG, NREAL, LASTD, NELME, WF3, WF4, N2, PAS 3326 INTEGER MAXINT_N 3327 INTEGER(8) HASH, HMOD 3328 DOUBLE PRECISION RMF, RMF1 3329 DOUBLE PRECISION dummy 3330 INTEGER idummy 3331 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 3332 INTRINSIC max, min, mod, huge 3333 INTEGER TOTEL 3334 idummy = huge(idummy) - 1 3335 dummy = dble(idummy) 3336 N2 = -NBBUCK-1 3337 PAS = max((N/8), 1) 3338 WFLG = 2 3339 MAXINT_N=huge(WFLG)-N 3340 NCMPA = 0 3341 NEL = 0 3342 HMOD = int(max (1, NBBUCK-1),kind=8) 3343 DMAX = 0 3344 MEM = PFREE - 1 3345 MAXMEM = MEM 3346 MINDEG = 0 3347 NBFLAG = 0 3348 LASTD = 0 3349 HEAD(0:NBBUCK+1) = 0 3350 DO 10 I = 1, N 3351 THESON(I) = 0 3352 LAST (I) = 0 3353 W (I) = 1 3354 ELEN (I) = 0 3355 10 CONTINUE 3356 TOTEL = 0 3357 DO I=1,N 3358 IF (LEN(I).LT.0) THEN 3359 DEGREE (I) = N2 3360 NBFLAG = NBFLAG +1 3361 IF (LEN(I).EQ.-N-1) THEN 3362 LEN (I) = 0 3363 PE (I) = 0 3364 ELSE 3365 LEN (I) = - LEN(I) 3366 ENDIF 3367 ELSE 3368 TOTEL = TOTEL + NV(I) 3369 DEGREE(I) = 0 3370 DO J= PE(I) , PE(I)+LEN(I)-1 3371 DEGREE(I) = DEGREE(I) + NV(IW(J)) 3372 ENDDO 3373 ENDIF 3374 ENDDO 3375 NREAL = N - NBFLAG 3376 DO 20 I = 1, N 3377 DEG = DEGREE (I) 3378 IF (DEG.EQ.N2) THEN 3379 DEG = NBBUCK + 1 3380 IF (LASTD.EQ.0) THEN 3381 LASTD = I 3382 HEAD(DEG) = I 3383 NEXT(I) = 0 3384 LAST(I) = 0 3385 ELSE 3386 NEXT(LASTD) = I 3387 LAST(I) = LASTD 3388 LASTD = I 3389 NEXT(I) = 0 3390 ENDIF 3391 GOTO 20 3392 ENDIF 3393 IF (DEG .GT. 0) THEN 3394 WF(I) = DEG 3395 IF (DEG.GT.N) THEN 3396 DEG = min(((DEG-N)/PAS) + N , NBBUCK) 3397 ENDIF 3398 INEXT = HEAD (DEG) 3399 IF (INEXT .NE. 0) LAST (INEXT) = I 3400 NEXT (I) = INEXT 3401 HEAD (DEG) = I 3402 ELSE 3403 NEL = NEL + NV(I) 3404 ELEN (I) = -NEL 3405 PE (I) = 0 3406 W (I) = 0 3407 ENDIF 3408 20 CONTINUE 3409 NLEFT = TOTEL-NEL 3410 30 IF (NEL .LT. TOTEL) THEN 3411 DO 40 DEG = MINDEG, NBBUCK 3412 ME = HEAD (DEG) 3413 IF (ME .GT. 0) GO TO 50 3414 40 CONTINUE 3415 50 MINDEG = DEG 3416 IF (ME.LE.0) THEN 3417 NCMPA = -N 3418 CALL MUMPS_ABORT() 3419 ENDIF 3420 IF (DEG.GT.N) THEN 3421 J = NEXT(ME) 3422 K = WF(ME) 3423 IF(CONSTRAINT(ME) .LT. 0) THEN 3424 K = -1 3425 ENDIF 3426 55 CONTINUE 3427 IF (J.GT.0) THEN 3428 IF(CONSTRAINT(J) .GE. 0) THEN 3429 IF (WF(J).LT.K .OR. K .LT. 0) THEN 3430 ME = J 3431 K = WF(ME) 3432 ENDIF 3433 ENDIF 3434 J= NEXT(J) 3435 GOTO 55 3436 ENDIF 3437 ILAST = LAST(ME) 3438 INEXT = NEXT(ME) 3439 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 3440 IF (ILAST .NE. 0) THEN 3441 NEXT (ILAST) = INEXT 3442 ELSE 3443 HEAD (DEG) = INEXT 3444 ENDIF 3445 ELSE 3446 IF(CONSTRAINT(ME) .GE. 0) GOTO 59 3447 56 CONTINUE 3448 IF(NEXT(ME) .NE. 0) THEN 3449 ME = NEXT(ME) 3450 IF(CONSTRAINT(ME) .GE. 0) THEN 3451 GOTO 59 3452 ELSE 3453 GOTO 56 3454 ENDIF 3455 ELSE 3456 57 DEG = DEG+1 3457 ME = HEAD(DEG) 3458 IF(ME .GT. 0) THEN 3459 IF(CONSTRAINT(ME) .GE. 0) THEN 3460 GOTO 59 3461 ELSE 3462 GOTO 56 3463 ENDIF 3464 ELSE 3465 GOTO 57 3466 ENDIF 3467 ENDIF 3468 59 PREV = LAST (ME) 3469 INEXT = NEXT (ME) 3470 IF(PREV .NE. 0) THEN 3471 NEXT(PREV) = INEXT 3472 ELSE 3473 HEAD (DEG) = INEXT 3474 ENDIF 3475 IF (INEXT .NE. 0) LAST (INEXT) = PREV 3476 ENDIF 3477 TOTO = ME 3478 5910 IF(TOTO .NE. 0) THEN 3479 J = CONSTRAINT(TOTO) 3480 IF(J .GT. 0) THEN 3481 CONSTRAINT(J) = 0 3482 ENDIF 3483 TOTO = THESON(TOTO) 3484 GOTO 5910 3485 ENDIF 3486 ELENME = ELEN (ME) 3487 ELEN (ME) = - (NEL + 1) 3488 NVPIV = NV (ME) 3489 NEL = NEL + NVPIV 3490 NV (ME) = -NVPIV 3491 DEGME = 0 3492 IF (ELENME .EQ. 0) THEN 3493 PME1 = PE (ME) 3494 PME2 = PME1 - 1 3495 DO 60 P = PME1, PME1 + LEN (ME) - 1 3496 I = IW (P) 3497 NVI = NV (I) 3498 IF (NVI .GT. 0) THEN 3499 DEGME = DEGME + NVI 3500 NV (I) = -NVI 3501 PME2 = PME2 + 1 3502 IW (PME2) = I 3503 IF (DEGREE(I).NE.N2) THEN 3504 ILAST = LAST (I) 3505 INEXT = NEXT (I) 3506 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 3507 IF (ILAST .NE. 0) THEN 3508 NEXT (ILAST) = INEXT 3509 ELSE 3510 IF (WF(I).GT.N) THEN 3511 DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) 3512 ELSE 3513 DEG = WF(I) 3514 ENDIF 3515 HEAD (DEG) = INEXT 3516 ENDIF 3517 ENDIF 3518 ENDIF 3519 60 CONTINUE 3520 NEWMEM = 0 3521 ELSE 3522 P = PE (ME) 3523 PME1 = PFREE 3524 SLENME = LEN (ME) - ELENME 3525 DO 120 KNT1 = 1, ELENME + 1 3526 IF (KNT1 .GT. ELENME) THEN 3527 E = ME 3528 PJ = P 3529 LN = SLENME 3530 ELSE 3531 E = IW (P) 3532 P = P + 1 3533 PJ = PE (E) 3534 LN = LEN (E) 3535 ENDIF 3536 DO 110 KNT2 = 1, LN 3537 I = IW (PJ) 3538 PJ = PJ + 1 3539 NVI = NV (I) 3540 IF (NVI .GT. 0) THEN 3541 IF (PFREE .GT. IWLEN) THEN 3542 PE (ME) = P 3543 LEN (ME) = LEN (ME) - KNT1 3544 IF (LEN (ME) .EQ. 0) PE (ME) = 0 3545 PE (E) = PJ 3546 LEN (E) = LN - KNT2 3547 IF (LEN (E) .EQ. 0) PE (E) = 0 3548 NCMPA = NCMPA + 1 3549 DO 70 J = 1, N 3550 PN = PE (J) 3551 IF (PN .GT. 0) THEN 3552 PE (J) = IW (PN) 3553 IW (PN) = -J 3554 ENDIF 3555 70 CONTINUE 3556 PDST = 1 3557 PSRC = 1 3558 PEND = PME1 - 1 3559 80 CONTINUE 3560 IF (PSRC .LE. PEND) THEN 3561 J = -IW (PSRC) 3562 PSRC = PSRC + 1 3563 IF (J .GT. 0) THEN 3564 IW (PDST) = PE (J) 3565 PE (J) = PDST 3566 PDST = PDST + 1 3567 LENJ = LEN (J) 3568 DO 90 KNT3 = 0, LENJ - 2 3569 IW (PDST + KNT3) = IW (PSRC + KNT3) 3570 90 CONTINUE 3571 PDST = PDST + LENJ - 1 3572 PSRC = PSRC + LENJ - 1 3573 ENDIF 3574 GO TO 80 3575 ENDIF 3576 P1 = PDST 3577 DO 100 PSRC = PME1, PFREE - 1 3578 IW (PDST) = IW (PSRC) 3579 PDST = PDST + 1 3580 100 CONTINUE 3581 PME1 = P1 3582 PFREE = PDST 3583 PJ = PE (E) 3584 P = PE (ME) 3585 ENDIF 3586 DEGME = DEGME + NVI 3587 NV (I) = -NVI 3588 IW (PFREE) = I 3589 PFREE = PFREE + 1 3590 IF (DEGREE(I).NE.N2) THEN 3591 ILAST = LAST (I) 3592 INEXT = NEXT (I) 3593 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 3594 IF (ILAST .NE. 0) THEN 3595 NEXT (ILAST) = INEXT 3596 ELSE 3597 IF (WF(I).GT.N) THEN 3598 DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) 3599 ELSE 3600 DEG = WF(I) 3601 ENDIF 3602 HEAD (DEG) = INEXT 3603 ENDIF 3604 ENDIF 3605 ENDIF 3606 110 CONTINUE 3607 IF (E .NE. ME) THEN 3608 PE (E) = -ME 3609 W (E) = 0 3610 ENDIF 3611 120 CONTINUE 3612 PME2 = PFREE - 1 3613 NEWMEM = PFREE - PME1 3614 MEM = MEM + NEWMEM 3615 MAXMEM = max (MAXMEM, MEM) 3616 ENDIF 3617 DEGREE (ME) = DEGME 3618 PE (ME) = PME1 3619 LEN (ME) = PME2 - PME1 + 1 3620 IF (WFLG .GT. MAXINT_N) THEN 3621 DO 130 X = 1, N 3622 IF (W (X) .NE. 0) W (X) = 1 3623 130 CONTINUE 3624 WFLG = 2 3625 ENDIF 3626 DO 150 PME = PME1, PME2 3627 I = IW (PME) 3628 ELN = ELEN (I) 3629 IF (ELN .GT. 0) THEN 3630 NVI = -NV (I) 3631 WNVI = WFLG - NVI 3632 DO 140 P = PE (I), PE (I) + ELN - 1 3633 E = IW (P) 3634 WE = W (E) 3635 IF (WE .GE. WFLG) THEN 3636 WE = WE - NVI 3637 ELSE IF (WE .NE. 0) THEN 3638 WE = DEGREE (E) + WNVI 3639 WF(E) = 0 3640 ENDIF 3641 W (E) = WE 3642 140 CONTINUE 3643 ENDIF 3644 150 CONTINUE 3645 DO 180 PME = PME1, PME2 3646 I = IW (PME) 3647 P1 = PE (I) 3648 P2 = P1 + ELEN (I) - 1 3649 PN = P1 3650 HASH = 0_8 3651 DEG = 0 3652 WF3 = 0 3653 WF4 = 0 3654 NVI = -NV(I) 3655 DO 160 P = P1, P2 3656 E = IW (P) 3657 DEXT = W (E) - WFLG 3658 IF (DEXT .GT. 0) THEN 3659 IF ( WF(E) .EQ. 0 ) THEN 3660 WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) 3661 ENDIF 3662 WF4 = WF4 + WF(E) 3663 DEG = DEG + DEXT 3664 IW (PN) = E 3665 PN = PN + 1 3666 HASH = HASH + int(E,kind=8) 3667 ELSE IF (DEXT .EQ. 0) THEN 3668#if defined (NOAGG4) 3669 IW (PN) = E 3670 PN = PN + 1 3671 HASH = HASH + int(E,kind=8) 3672#else 3673 PE (E) = -ME 3674 W (E) = 0 3675#endif 3676 ENDIF 3677 160 CONTINUE 3678 ELEN (I) = PN - P1 + 1 3679 P3 = PN 3680 DO 170 P = P2 + 1, P1 + LEN (I) - 1 3681 J = IW (P) 3682 NVJ = NV (J) 3683 IF (NVJ .GT. 0) THEN 3684 DEG = DEG + NVJ 3685 WF3 = WF3 + NVJ 3686 IW (PN) = J 3687 PN = PN + 1 3688 HASH = HASH + int(J,kind=8) 3689 ENDIF 3690 170 CONTINUE 3691 IF (DEGREE(I).EQ.N2) DEG = N2 3692#if defined (NOAGG4) 3693 IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN 3694#else 3695 IF (DEG .EQ. 0) THEN 3696#endif 3697 PE (I) = -ME 3698 NVI = -NV (I) 3699 DEGME = DEGME - NVI 3700 NVPIV = NVPIV + NVI 3701 NEL = NEL + NVI 3702 NV (I) = 0 3703 ELEN (I) = 0 3704 ELSE 3705 IF (DEGREE(I).NE.N2) THEN 3706 IF ( DEGREE (I).LT.DEG ) THEN 3707 WF4 = 0 3708 WF3 = 0 3709 ELSE 3710 DEGREE(I) = DEG 3711 ENDIF 3712 ENDIF 3713 WF(I) = WF4 + 2*NVI*WF3 3714 IW (PN) = IW (P3) 3715 IW (P3) = IW (P1) 3716 IW (P1) = ME 3717 LEN (I) = PN - P1 + 1 3718 IF (DEG.NE.N2) THEN 3719 HASH = mod (HASH, HMOD) + 1_8 3720 J = HEAD (HASH) 3721 IF (J .LE. 0) THEN 3722 NEXT (I) = -J 3723 HEAD (HASH) = -I 3724 ELSE 3725 NEXT (I) = LAST (J) 3726 LAST (J) = I 3727 ENDIF 3728 LAST (I) = int(HASH,kind=kind(LAST)) 3729 ENDIF 3730 ENDIF 3731 180 CONTINUE 3732 DEGREE (ME) = DEGME 3733 DMAX = max (DMAX, DEGME) 3734 WFLG = WFLG + DMAX 3735 IF (WFLG .GT. MAXINT_N) THEN 3736 DO 190 X = 1, N 3737 IF (W (X) .NE. 0) W (X) = 1 3738 190 CONTINUE 3739 WFLG = 2 3740 ENDIF 3741 DO 250 PME = PME1, PME2 3742 I = IW (PME) 3743 IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN 3744 HASH = int(LAST (I),kind=8) 3745 J = HEAD (HASH) 3746 IF (J .EQ. 0) GO TO 250 3747 IF (J .LT. 0) THEN 3748 I = -J 3749 HEAD (HASH) = 0 3750 ELSE 3751 I = LAST (J) 3752 LAST (J) = 0 3753 ENDIF 3754 IF (I .EQ. 0) GO TO 250 3755 200 CONTINUE 3756 IF (NEXT (I) .NE. 0) THEN 3757 LN = LEN (I) 3758 ELN = ELEN (I) 3759 DO 210 P = PE (I) + 1, PE (I) + LN - 1 3760 W (IW (P)) = WFLG 3761 210 CONTINUE 3762 JLAST = I 3763 J = NEXT (I) 3764 220 CONTINUE 3765 IF (J .NE. 0) THEN 3766 IF(CONSTRAINT(J) .LT. 0 3767 & .AND. CONSTRAINT(I) .LT. 0) THEN 3768 GOTO 240 3769 ENDIF 3770 IF(CONSTRAINT(I) .GE. 0) THEN 3771 IF(CONSTRAINT(J) .LT. 0) THEN 3772 TOTO = I 3773 221 IF(TOTO .NE. 0) THEN 3774 IF(CONSTRAINT(TOTO) .EQ. J) THEN 3775 GOTO 225 3776 ENDIF 3777 TOTO =THESON(TOTO) 3778 GOTO 221 3779 ENDIF 3780 ELSE 3781 GOTO 225 3782 ENDIF 3783 ELSE 3784 IF(CONSTRAINT(J) .GE. 0) THEN 3785 TOTO = J 3786 222 IF(TOTO .NE. 0) THEN 3787 IF(CONSTRAINT(TOTO) .EQ. I) THEN 3788 GOTO 225 3789 ENDIF 3790 TOTO =THESON(TOTO) 3791 GOTO 222 3792 ENDIF 3793 ENDIF 3794 ENDIF 3795 GOTO 240 3796 225 CONTINUE 3797 IF (LEN (J) .NE. LN) GO TO 240 3798 IF (ELEN (J) .NE. ELN) GO TO 240 3799 DO 230 P = PE (J) + 1, PE (J) + LN - 1 3800 IF (W (IW (P)) .NE. WFLG) GO TO 240 3801 230 CONTINUE 3802 TOTO = I 3803 231 IF(THESON(TOTO) .NE. 0) THEN 3804 TOTO = THESON(TOTO) 3805 GOTO 231 3806 ENDIF 3807 THESON(TOTO) = J 3808 IF(CONSTRAINT(I) .LT. 0) THEN 3809 CONSTRAINT(I) = 0 3810 ENDIF 3811 PE (J) = -I 3812 WF(I) = max(WF(I),WF(J)) 3813 NV (I) = NV (I) + NV (J) 3814 NV (J) = 0 3815 ELEN (J) = 0 3816 J = NEXT (J) 3817 NEXT (JLAST) = J 3818 GO TO 220 3819 240 CONTINUE 3820 JLAST = J 3821 J = NEXT (J) 3822 GO TO 220 3823 ENDIF 3824 WFLG = WFLG + 1 3825 I = NEXT (I) 3826 IF (I .NE. 0) GO TO 200 3827 ENDIF 3828 ENDIF 3829 250 CONTINUE 3830 P = PME1 3831 NLEFT = TOTEL - NEL 3832 DO 260 PME = PME1, PME2 3833 I = IW (PME) 3834 NVI = -NV (I) 3835 IF (NVI .GT. 0) THEN 3836 NV (I) = NVI 3837 IF (DEGREE(I).NE.N2) THEN 3838 DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) 3839 IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN 3840 DEG = DEGREE(I) 3841 RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) 3842 & - dble(WF(I)) 3843 DEGREE(I) = NLEFT - NVI 3844 DEG = DEGREE(I) 3845 RMF = dble(DEG)*dble(DEG-1) 3846 & - dble(DEGME-NVI)*dble(DEGME-NVI-1) 3847 RMF = min(RMF, RMF1) 3848 ELSE 3849 DEG = DEGREE(I) 3850 DEGREE(I) = DEGREE (I) + DEGME - NVI 3851 RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) 3852 & - dble(WF(I)) 3853 ENDIF 3854 RMF = RMF / dble(NVI+1) 3855 IF (RMF.LT.dummy) THEN 3856 WF(I) = int ( anint( RMF )) 3857 ELSEIF (RMF / dble(N) .LT. dummy) THEN 3858 WF(I) = int ( anint( RMF/dble(N) )) 3859 ELSE 3860 WF(I) = idummy 3861 ENDIF 3862 WF(I) = max(1,WF(I)) 3863 DEG = WF(I) 3864 IF (DEG.GT.N) THEN 3865 DEG = min(((DEG-N)/PAS) + N , NBBUCK) 3866 ENDIF 3867 INEXT = HEAD (DEG) 3868 IF (INEXT .NE. 0) LAST (INEXT) = I 3869 NEXT (I) = INEXT 3870 LAST (I) = 0 3871 HEAD (DEG) = I 3872 MINDEG = min (MINDEG, DEG) 3873 ENDIF 3874 IW (P) = I 3875 P = P + 1 3876 ENDIF 3877 260 CONTINUE 3878 NV (ME) = NVPIV + DEGME 3879 LEN (ME) = P - PME1 3880 IF (LEN (ME) .EQ. 0) THEN 3881 PE (ME) = 0 3882 W (ME) = 0 3883 ENDIF 3884 IF (NEWMEM .NE. 0) THEN 3885 PFREE = P 3886 MEM = MEM - NEWMEM + LEN (ME) 3887 ENDIF 3888 GO TO 30 3889 ENDIF 3890 IF (NEL.LT.N) THEN 3891 DO DEG = MINDEG, NBBUCK+1 3892 ME = HEAD (DEG) 3893 IF (ME .GT. 0) GO TO 51 3894 ENDDO 3895 51 MINDEG = DEG 3896 NELME = -(NEL+1) 3897 DO X=1,N 3898 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 3899 PE(X) = -ME 3900 ELSEIF (DEGREE(X).EQ.N2) THEN 3901 NEL = NEL + NV(X) 3902 PE(X) = -ME 3903 ELEN(X) = 0 3904 NV(X) = 0 3905 ENDIF 3906 ENDDO 3907 ELEN(ME) = NELME 3908 NV(ME) = N-NREAL 3909 PE(ME) = 0 3910 IF (NEL.NE.N) THEN 3911 NCMPA = -N - 1 3912 GOTO 500 3913 ENDIF 3914 ENDIF 3915 DO 290 I = 1, N 3916 IF (ELEN (I) .EQ. 0) THEN 3917 J = -PE (I) 3918 270 CONTINUE 3919 IF (ELEN (J) .GE. 0) THEN 3920 J = -PE (J) 3921 GO TO 270 3922 ENDIF 3923 E = J 3924 K = -ELEN (E) 3925 J = I 3926 280 CONTINUE 3927 IF (ELEN (J) .GE. 0) THEN 3928 JNEXT = -PE (J) 3929 PE (J) = -E 3930 IF (ELEN (J) .EQ. 0) THEN 3931 ELEN (J) = K 3932 K = K + 1 3933 ENDIF 3934 J = JNEXT 3935 GO TO 280 3936 ENDIF 3937 ELEN (E) = -K 3938 ENDIF 3939 290 CONTINUE 3940 IF(.TRUE.) THEN 3941 LAST(1:N) = 0 3942 DEGREE(1:TOTEL-N)=0 3943 DO I = 1, N 3944 K = abs (ELEN (I)) 3945 IF ( K <= N ) THEN 3946 LAST (K) = I 3947 ELSE 3948 DEGREE(K-N)=I 3949 ENDIF 3950 ENDDO 3951 I = 1 3952 DO K = 1, N 3953 IF(LAST (K) .NE. 0) THEN 3954 LAST(I) = LAST(K) 3955 ELEN(LAST(K)) = I 3956 I = I + 1 3957 ENDIF 3958 ENDDO 3959 DO K = N+1, TOTEL 3960 IF (DEGREE(K-N) .NE. 0) THEN 3961 LAST(I)=DEGREE(K-N) 3962 ELEN(DEGREE(K-N)) = I 3963 I = I + 1 3964 ENDIF 3965 END DO 3966 ELSE 3967 DO 300 I = 1, N 3968 K = abs (ELEN (I)) 3969 LAST (K) = I 3970 ELEN (I) = K 3971300 CONTINUE 3972 ENDIF 3973 500 PFREE = MAXMEM 3974 RETURN 3975 END SUBROUTINE MUMPS_560 3976 SUBROUTINE MUMPS_422 3977 & ( THRESH, NDENSE, 3978 & N, IWLEN, PE, PFREE, LEN, IW, NV, 3979 & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, 3980 & PERM, LISTVAR_SCHUR, SIZE_SCHUR, AGG6 ) 3981 IMPLICIT NONE 3982 INTEGER N, IWLEN, PE(N), PFREE, LEN(N), IW(IWLEN), NV(N), 3983 & ELEN(N), LAST(N), NCMPA, DEGREE(N), HEAD(N), NEXT(N), 3984 & W(N), SIZE_SCHUR 3985 LOGICAL AGG6 3986 INTEGER NDENSE(N), LISTVAR_SCHUR(max(1,SIZE_SCHUR)) 3987 INTEGER PERM(N) 3988 INTEGER THRESH 3989 INTEGER THRESM, NDME, PERMeqN 3990 INTEGER NBD,NBED, NBDM, LASTD, NELME 3991 LOGICAL IDENSE 3992 INTEGER FDEG, ThresMin, ThresPrev, IBEGSchur, NbSchur, 3993 & ThresMinINIT 3994 LOGICAL SchurON 3995 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 3996 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 3997 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 3998 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X 3999 INTEGER MAXINT_N 4000 INTEGER(8) HASH, HMOD 4001 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 4002 INTRINSIC max, min, mod 4003 IF (N.EQ.1) THEN 4004 ELEN(1) = 1 4005 LAST(1) = 1 4006 PE(1) = 0 4007 NV(1) = 1 4008 NCMPA = 0 4009 RETURN 4010 ENDIF 4011 SIZE_SCHUR = min(N,SIZE_SCHUR) 4012 SIZE_SCHUR = max(0,SIZE_SCHUR) 4013 SchurON = (SIZE_SCHUR > 0) 4014 IBEGSchur = N-SIZE_SCHUR+1 4015 IF (THRESH.GT.N) THRESH = N 4016 IF (THRESH.LT.0) THRESH = 0 4017 IF ( SchurON ) THEN 4018 DO I= 1, N 4019 IF ( PERM(I) .GE. IBEGSchur) THEN 4020 PERM(I) = N + 1 4021 IF (LEN(I) .EQ.0) THEN 4022 PE(I) = 0 4023 ENDIF 4024 ENDIF 4025 ENDDO 4026 ENDIF 4027 IF (SchurON) THEN 4028 THRESM = N 4029 ThresMin = N 4030 ThresPrev = N 4031 ELSE 4032 THRESM = max(int(31*N/32),THRESH) 4033 THRESM = max(THRESM,1) 4034 ThresMin = max( 3*THRESM / 4, 1) 4035 ThresPrev = THRESM 4036 ENDIF 4037 ThresMinINIT = ThresMin/4 4038 IF (THRESM.GT.0) THEN 4039 IF ((THRESM.GT.N).OR.(THRESM.LT.2)) THEN 4040 THRESM = N 4041 ENDIF 4042 ENDIF 4043 LASTD = 0 4044 NBD = 0 4045 NBED = 0 4046 NBDM = 0 4047 WFLG = 2 4048 MAXINT_N=huge(WFLG)-N 4049 MINDEG = 1 4050 NCMPA = 0 4051 NEL = 0 4052 HMOD = int(max (1, N-1),kind=8) 4053 DMAX = 0 4054 MEM = PFREE - 1 4055 MAXMEM = MEM 4056 DO 10 I = 1, N 4057 NDENSE(I)= 0 4058 LAST (I) = 0 4059 HEAD (I) = 0 4060 NV (I) = 1 4061 W (I) = 1 4062 ELEN (I) = 0 4063 DEGREE (I) = LEN (I) 4064 10 CONTINUE 4065 DO 20 I = 1, N 4066 DEG = DEGREE (I) 4067 IF (PERM(I).EQ.N) THEN 4068 PERMeqN = I 4069 PERM(I) = N-1 4070 ENDIF 4071 FDEG = PERM(I) 4072 IF ( (DEG .GT. 0).OR.(PERM(I).EQ.N+1) ) THEN 4073 IF ( (THRESM.GT.0) .AND. 4074 & (FDEG .GT.THRESM) ) THEN 4075 NBD = NBD+1 4076 IF (FDEG.NE.N+1) THEN 4077 DEGREE(I) = DEGREE(I)+N+2 4078 DEG = N 4079 INEXT = HEAD (DEG) 4080 IF (INEXT .NE. 0) LAST (INEXT) = I 4081 NEXT (I) = INEXT 4082 HEAD (DEG) = I 4083 LAST(I) = 0 4084 IF (LASTD.EQ.0) LASTD=I 4085 ELSE 4086 NBED = NBED+1 4087 DEGREE(I) = N+1 4088 DEG = N 4089 IF (LASTD.EQ.0) THEN 4090 LASTD = I 4091 HEAD(DEG) = I 4092 NEXT(I) = 0 4093 LAST(I) = 0 4094 ELSE 4095 NEXT(LASTD) = I 4096 LAST(I) = LASTD 4097 LASTD = I 4098 NEXT(I) = 0 4099 ENDIF 4100 ENDIF 4101 ELSE 4102 INEXT = HEAD (FDEG) 4103 IF (INEXT .NE. 0) LAST (INEXT) = I 4104 NEXT (I) = INEXT 4105 HEAD (FDEG) = I 4106 ENDIF 4107 ELSE 4108 NEL = NEL + 1 4109 ELEN (I) = -NEL 4110 PE (I) = 0 4111 W (I) = 0 4112 ENDIF 4113 20 CONTINUE 4114 IF ((NBD.EQ.0).AND.(THRESM.GT.0)) THRESM = N 4115 30 IF (NEL .LT. N) THEN 4116 DO 40 DEG = MINDEG, N 4117 ME = HEAD (DEG) 4118 IF (ME .GT. 0) GO TO 50 4119 40 CONTINUE 4120 50 MINDEG = DEG 4121 IF ( (DEG.NE.N) .AND. 4122 & (DEG.GT.THRESM+1) .AND. (NBD.GT.0) ) THEN 4123 MINDEG = N 4124 GOTO 30 4125 ENDIF 4126 IF (DEGREE(ME).LE.N) THEN 4127 INEXT = NEXT (ME) 4128 IF (INEXT .NE. 0) LAST (INEXT) = 0 4129 HEAD (DEG) = INEXT 4130 ELSE 4131 MINDEG = 1 4132 NBDM = max(NBDM,NBD) 4133 IF (DEGREE(ME).GT.N+1) THEN 4134 IF (WFLG .GT. MAXINT_N) THEN 4135 DO 52 X = 1, N 4136 IF (W (X) .NE. 0) W (X) = 1 4137 52 CONTINUE 4138 WFLG = 2 4139 ENDIF 4140 WFLG = WFLG + 1 4141 51 CONTINUE 4142 INEXT = NEXT (ME) 4143 IF (INEXT .NE. 0) THEN 4144 LAST (INEXT) = 0 4145 ELSE 4146 LASTD = 0 4147 ENDIF 4148 NDENSE(ME) = 0 4149 W(ME) = WFLG 4150 P1 = PE(ME) 4151 P2 = P1 + LEN(ME) -1 4152 LN = P1 4153 ELN = P1 4154 DO 55 P=P1,P2 4155 E= IW(P) 4156 IF (W(E).EQ.WFLG) GOTO 55 4157 W(E) = WFLG 4158 IF (PE(E).LT.0) THEN 4159 X = E 4160 53 X = -PE(X) 4161 IF (W(X) .EQ.WFLG) GOTO 55 4162 W(X) = WFLG 4163 IF ( PE(X) .LT. 0 ) GOTO 53 4164 E = X 4165 ENDIF 4166 IF (ELEN(E).LT.0) THEN 4167 NDENSE(E) = NDENSE(E) - NV(ME) 4168 IW(LN) = IW(ELN) 4169 IW(ELN) = E 4170 LN = LN+1 4171 ELN = ELN + 1 4172 PME1 = PE(E) 4173 DO 54 PME = PME1, PME1+LEN(E)-1 4174 X = IW(PME) 4175 IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN 4176 NDENSE(ME) = NDENSE(ME) + NV(X) 4177 W(X) = WFLG 4178 ENDIF 4179 54 CONTINUE 4180 ELSE 4181 NDENSE(ME) = NDENSE(ME) + NV(E) 4182 IW(LN)=E 4183 LN = LN+1 4184 ENDIF 4185 55 CONTINUE 4186 WFLG = WFLG + 1 4187 LEN(ME) = LN-P1 4188 ELEN(ME) = ELN- P1 4189 NDME = NDENSE(ME)+NV(ME) 4190 IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 4191 DEGREE(ME) = NDENSE(ME) 4192 DEG = PERM(ME) 4193 MINDEG = min(DEG,MINDEG) 4194 JNEXT = HEAD(DEG) 4195 IF (JNEXT.NE. 0) LAST (JNEXT) = ME 4196 NEXT(ME) = JNEXT 4197 HEAD(DEG) = ME 4198 ME = INEXT 4199 IF (ME.NE.0) THEN 4200 IF (DEGREE(ME).GT.(N+1) ) GOTO 51 4201 ENDIF 4202 HEAD (N) = ME 4203 IF (THRESM.LT.N) THEN 4204 ThresMin = max(THRESM+ThresMin,ThresPrev+ThresMin/2+1) 4205 ThresMin = min(ThresMin, N) 4206 ThresPrev = ThresPrev+(N-ThresPrev)/2+ThresMinINIT 4207 THRESM = max( 4208 & THRESM + int(sqrt(dble(ThresMin)))+ ThresMinINIT , 4209 & ThresPrev) 4210 THRESM = min(THRESM,N) 4211 ThresMin = min(THRESM, ThresMin) 4212 ThresPrev = THRESM 4213 ENDIF 4214 NBD = NBED 4215 GOTO 30 4216 ENDIF 4217 IF (DEGREE(ME).EQ.N+1) THEN 4218 IF (NBD.NE.NBED) THEN 4219 write(6,*) ' ERROR in MUMPS_422 quasi dense rows remains' 4220 CALL MUMPS_ABORT() 4221 ENDIF 4222 NbSchur = 0 4223 NELME = -(NEL+1) 4224 DO 59 X=1,N 4225 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 4226 PE(X) = -LISTVAR_SCHUR(1) 4227 ELSE IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 4228 PE(X) = -LISTVAR_SCHUR(1) 4229 ELSEIF (DEGREE(X).EQ.N+1) THEN 4230 NEL = NEL + NV(X) 4231 PE(X) = -ME 4232 ELEN(X) = 0 4233 NV(X) = 0 4234 NbSchur = NbSchur+ 1 4235 ENDIF 4236 59 CONTINUE 4237 IF (NbSchur.NE.SIZE_SCHUR) then 4238 write(6,*) ' Internal error 2 in QAMD :', 4239 & ' Schur size expected:',SIZE_SCHUR, 'Real:', NbSchur 4240 CALL MUMPS_ABORT() 4241 ENDIF 4242 ELEN(ME) = NELME 4243 NV(ME) = NBD 4244 PE(ME) = 0 4245 IF (NEL.NE.N) THEN 4246 write(6,*) 'Internal ERROR 2 detected in QAMD' 4247 write(6,*) ' NEL not equal to N: N, NEL =',N,NEL 4248 CALL MUMPS_ABORT() 4249 ENDIF 4250 IF (ME.NE. LISTVAR_SCHUR(1)) THEN 4251 DO I=1, SIZE_SCHUR 4252 PE(LISTVAR_SCHUR(I)) = -LISTVAR_SCHUR(1) 4253 ENDDO 4254 PE(LISTVAR_SCHUR(1)) = 0 4255 NV( LISTVAR_SCHUR(1))= NV(ME) 4256 NV(ME) = 0 4257 ELEN( LISTVAR_SCHUR(1)) = ELEN(ME) 4258 ELEN(ME) = 0 4259 ENDIF 4260 GOTO 265 4261 ENDIF 4262 ENDIF 4263 ELENME = ELEN (ME) 4264 ELEN (ME) = - (NEL + 1) 4265 NVPIV = NV (ME) 4266 NEL = NEL + NVPIV 4267 NDENSE(ME) = 0 4268 NV (ME) = -NVPIV 4269 DEGME = 0 4270 IF (ELENME .EQ. 0) THEN 4271 PME1 = PE (ME) 4272 PME2 = PME1 - 1 4273 DO 60 P = PME1, PME1 + LEN (ME) - 1 4274 I = IW (P) 4275 NVI = NV (I) 4276 IF (NVI .GT. 0) THEN 4277 DEGME = DEGME + NVI 4278 NV (I) = -NVI 4279 PME2 = PME2 + 1 4280 IW (PME2) = I 4281 IF (DEGREE(I).LE.N) THEN 4282 ILAST = LAST (I) 4283 INEXT = NEXT (I) 4284 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 4285 IF (ILAST .NE. 0) THEN 4286 NEXT (ILAST) = INEXT 4287 ELSE 4288 HEAD (PERM(I)) = INEXT 4289 ENDIF 4290 ELSE 4291 NDENSE(ME) = NDENSE(ME) + NVI 4292 ENDIF 4293 ENDIF 4294 60 CONTINUE 4295 NEWMEM = 0 4296 ELSE 4297 P = PE (ME) 4298 PME1 = PFREE 4299 SLENME = LEN (ME) - ELENME 4300 DO 120 KNT1 = 1, ELENME + 1 4301 IF (KNT1 .GT. ELENME) THEN 4302 E = ME 4303 PJ = P 4304 LN = SLENME 4305 ELSE 4306 E = IW (P) 4307 P = P + 1 4308 PJ = PE (E) 4309 LN = LEN (E) 4310 ENDIF 4311 DO 110 KNT2 = 1, LN 4312 I = IW (PJ) 4313 PJ = PJ + 1 4314 NVI = NV (I) 4315 IF (NVI .GT. 0) THEN 4316 IF (PFREE .GT. IWLEN) THEN 4317 PE (ME) = P 4318 LEN (ME) = LEN (ME) - KNT1 4319 IF (LEN (ME) .EQ. 0) PE (ME) = 0 4320 PE (E) = PJ 4321 LEN (E) = LN - KNT2 4322 IF (LEN (E) .EQ. 0) PE (E) = 0 4323 NCMPA = NCMPA + 1 4324 DO 70 J = 1, N 4325 PN = PE (J) 4326 IF (PN .GT. 0) THEN 4327 PE (J) = IW (PN) 4328 IW (PN) = -J 4329 ENDIF 4330 70 CONTINUE 4331 PDST = 1 4332 PSRC = 1 4333 PEND = PME1 - 1 4334 80 CONTINUE 4335 IF (PSRC .LE. PEND) THEN 4336 J = -IW (PSRC) 4337 PSRC = PSRC + 1 4338 IF (J .GT. 0) THEN 4339 IW (PDST) = PE (J) 4340 PE (J) = PDST 4341 PDST = PDST + 1 4342 LENJ = LEN (J) 4343 DO 90 KNT3 = 0, LENJ - 2 4344 IW (PDST + KNT3) = IW (PSRC + KNT3) 4345 90 CONTINUE 4346 PDST = PDST + LENJ - 1 4347 PSRC = PSRC + LENJ - 1 4348 ENDIF 4349 GO TO 80 4350 ENDIF 4351 P1 = PDST 4352 DO 100 PSRC = PME1, PFREE - 1 4353 IW (PDST) = IW (PSRC) 4354 PDST = PDST + 1 4355 100 CONTINUE 4356 PME1 = P1 4357 PFREE = PDST 4358 PJ = PE (E) 4359 P = PE (ME) 4360 ENDIF 4361 DEGME = DEGME + NVI 4362 NV (I) = -NVI 4363 IW (PFREE) = I 4364 PFREE = PFREE + 1 4365 IF (DEGREE(I).LE.N) THEN 4366 ILAST = LAST (I) 4367 INEXT = NEXT (I) 4368 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 4369 IF (ILAST .NE. 0) THEN 4370 NEXT (ILAST) = INEXT 4371 ELSE 4372 HEAD (PERM(I)) = INEXT 4373 ENDIF 4374 ELSE 4375 NDENSE(ME) = NDENSE(ME) + NVI 4376 ENDIF 4377 ENDIF 4378 110 CONTINUE 4379 IF (E .NE. ME) THEN 4380 PE (E) = -ME 4381 W (E) = 0 4382 ENDIF 4383 120 CONTINUE 4384 PME2 = PFREE - 1 4385 NEWMEM = PFREE - PME1 4386 MEM = MEM + NEWMEM 4387 MAXMEM = max (MAXMEM, MEM) 4388 ENDIF 4389 DEGREE (ME) = DEGME 4390 PE (ME) = PME1 4391 LEN (ME) = PME2 - PME1 + 1 4392 IF (WFLG .GT. MAXINT_N) THEN 4393 DO 130 X = 1, N 4394 IF (W (X) .NE. 0) W (X) = 1 4395 130 CONTINUE 4396 WFLG = 2 4397 ENDIF 4398 DO 150 PME = PME1, PME2 4399 I = IW (PME) 4400 IF (DEGREE(I).GT.N) GOTO 150 4401 ELN = ELEN (I) 4402 IF (ELN .GT. 0) THEN 4403 NVI = -NV (I) 4404 WNVI = WFLG - NVI 4405 DO 140 P = PE (I), PE (I) + ELN - 1 4406 E = IW (P) 4407 WE = W (E) 4408 IF (WE .GE. WFLG) THEN 4409 WE = WE - NVI 4410 ELSE IF (WE .NE. 0) THEN 4411 WE = DEGREE (E) + WNVI - NDENSE(E) 4412 ENDIF 4413 W (E) = WE 4414 140 CONTINUE 4415 ENDIF 4416 150 CONTINUE 4417 DO 180 PME = PME1, PME2 4418 I = IW (PME) 4419 IF (DEGREE(I).GT.N) GOTO 180 4420 P1 = PE (I) 4421 P2 = P1 + ELEN (I) - 1 4422 PN = P1 4423 HASH = 0_8 4424 DEG = 0 4425 DO 160 P = P1, P2 4426 E = IW (P) 4427 DEXT = W (E) - WFLG 4428 IF (DEXT .GT. 0) THEN 4429 DEG = DEG + DEXT 4430 IW (PN) = E 4431 PN = PN + 1 4432 HASH = HASH + int(E,kind=8) 4433 ELSE IF (.NOT. AGG6 .AND. DEXT .EQ. 0) THEN 4434 IW (PN) = E 4435 PN = PN + 1 4436 HASH = HASH + int(E,kind=8) 4437 ELSE IF (AGG6 .AND. (DEXT .EQ. 0) .AND. 4438 & ((NDENSE(ME).EQ.NBD).OR.(NDENSE(E).EQ.0))) THEN 4439 PE (E) = -ME 4440 W (E) = 0 4441 ELSE IF (AGG6 .AND. DEXT.EQ.0) THEN 4442 IW(PN) = E 4443 PN = PN+1 4444 HASH = HASH + int(E,kind=8) 4445 ENDIF 4446 160 CONTINUE 4447 ELEN (I) = PN - P1 + 1 4448 P3 = PN 4449 DO 170 P = P2 + 1, P1 + LEN (I) - 1 4450 J = IW (P) 4451 NVJ = NV (J) 4452 IF (NVJ .GT. 0) THEN 4453 IF (DEGREE(J).LE.N) DEG=DEG+NVJ 4454 IW (PN) = J 4455 PN = PN + 1 4456 HASH = HASH + int(J,kind=8) 4457 ENDIF 4458 170 CONTINUE 4459 IF (((ELEN(I).EQ.1).AND.(P3.EQ.PN)) 4460 & .OR. 4461 & (AGG6.AND.(DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) 4462 & ) 4463 & THEN 4464 PE (I) = -ME 4465 NVI = -NV (I) 4466 DEGME = DEGME - NVI 4467 NVPIV = NVPIV + NVI 4468 NEL = NEL + NVI 4469 NV (I) = 0 4470 ELEN (I) = 0 4471 ELSE 4472 DEGREE(I) = min (DEG+NBD-NDENSE(ME), 4473 & DEGREE(I)) 4474 IW (PN) = IW (P3) 4475 IW (P3) = IW (P1) 4476 IW (P1) = ME 4477 LEN (I) = PN - P1 + 1 4478 HASH = mod (HASH, HMOD) + 1_8 4479 J = HEAD (HASH) 4480 IF (J .LE. 0) THEN 4481 NEXT (I) = -J 4482 HEAD (HASH) = -I 4483 ELSE 4484 NEXT (I) = LAST (J) 4485 LAST (J) = I 4486 ENDIF 4487 LAST (I) = int(HASH,kind=kind(LAST)) 4488 ENDIF 4489 180 CONTINUE 4490 DEGREE (ME) = DEGME 4491 DMAX = max (DMAX, DEGME) 4492 WFLG = WFLG + DMAX 4493 IF (WFLG .GT. MAXINT_N) THEN 4494 DO 190 X = 1, N 4495 IF (W (X) .NE. 0) W (X) = 1 4496 190 CONTINUE 4497 WFLG = 2 4498 ENDIF 4499 DO 250 PME = PME1, PME2 4500 I = IW (PME) 4501 IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.N) ) THEN 4502 HASH = int(LAST (I),kind=8) 4503 J = HEAD (HASH) 4504 IF (J .EQ. 0) GO TO 250 4505 IF (J .LT. 0) THEN 4506 I = -J 4507 HEAD (HASH) = 0 4508 ELSE 4509 I = LAST (J) 4510 LAST (J) = 0 4511 ENDIF 4512 IF (I .EQ. 0) GO TO 250 4513 200 CONTINUE 4514 IF (NEXT (I) .NE. 0) THEN 4515 X = I 4516 LN = LEN (I) 4517 ELN = ELEN (I) 4518 DO 210 P = PE (I) + 1, PE (I) + LN - 1 4519 W (IW (P)) = WFLG 4520 210 CONTINUE 4521 JLAST = I 4522 J = NEXT (I) 4523 220 CONTINUE 4524 IF (J .NE. 0) THEN 4525 IF (LEN (J) .NE. LN) GO TO 240 4526 IF (ELEN (J) .NE. ELN) GO TO 240 4527 DO 230 P = PE (J) + 1, PE (J) + LN - 1 4528 IF (W (IW (P)) .NE. WFLG) GO TO 240 4529 230 CONTINUE 4530 IF (PERM(J).GT.PERM(X)) THEN 4531 PE (J) = -X 4532 NV (X) = NV (X) + NV (J) 4533 NV (J) = 0 4534 ELEN (J) = 0 4535 ELSE 4536 PE (X) = -J 4537 NV (J) = NV (X) + NV (J) 4538 NV (X) = 0 4539 ELEN (X) = 0 4540 X = J 4541 ENDIF 4542 J = NEXT (J) 4543 NEXT (JLAST) = J 4544 GO TO 220 4545 240 CONTINUE 4546 JLAST = J 4547 J = NEXT (J) 4548 GO TO 220 4549 ENDIF 4550 WFLG = WFLG + 1 4551 I = NEXT (I) 4552 IF (I .NE. 0) GO TO 200 4553 ENDIF 4554 ENDIF 4555 250 CONTINUE 4556 IF ( (THRESM .GT. 0).AND.(THRESM.LT.N) ) THEN 4557 THRESM = max(ThresMin, THRESM-NVPIV) 4558 ENDIF 4559 P = PME1 4560 NLEFT = N - NEL 4561 DO 260 PME = PME1, PME2 4562 I = IW (PME) 4563 NVI = -NV (I) 4564 IF (NVI .GT. 0) THEN 4565 NV (I) = NVI 4566 IF (DEGREE(I).LE.N) THEN 4567 DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) 4568 DEGREE (I) = DEG 4569 IDENSE = .FALSE. 4570 IF (THRESM.GT.0) THEN 4571 IF (PERM(I) .GT. THRESM) THEN 4572 IDENSE = .TRUE. 4573 DEGREE(I) = DEGREE(I)+N+2 4574 ENDIF 4575 IF (IDENSE) THEN 4576 P1 = PE(I) 4577 P2 = P1 + ELEN(I) - 1 4578 IF (P2.GE.P1) THEN 4579 DO 264 PJ=P1,P2 4580 E= IW(PJ) 4581 NDENSE (E) = NDENSE(E) + NVI 4582 264 CONTINUE 4583 ENDIF 4584 NBD = NBD+NVI 4585 FDEG = N 4586 DEG = N 4587 INEXT = HEAD(DEG) 4588 IF (INEXT .NE. 0) LAST (INEXT) = I 4589 NEXT (I) = INEXT 4590 HEAD (DEG) = I 4591 LAST(I) = 0 4592 IF (LASTD.EQ.0) LASTD=I 4593 ENDIF 4594 ENDIF 4595 IF (.NOT.IDENSE) THEN 4596 FDEG = PERM(I) 4597 INEXT = HEAD (FDEG) 4598 IF (INEXT .NE. 0) LAST (INEXT) = I 4599 NEXT (I) = INEXT 4600 LAST (I) = 0 4601 HEAD (FDEG) = I 4602 ENDIF 4603 MINDEG = min (MINDEG, FDEG) 4604 ENDIF 4605 IW (P) = I 4606 P = P + 1 4607 ENDIF 4608 260 CONTINUE 4609 NV (ME) = NVPIV + DEGME 4610 LEN (ME) = P - PME1 4611 IF (LEN (ME) .EQ. 0) THEN 4612 PE (ME) = 0 4613 W (ME) = 0 4614 ENDIF 4615 IF (NEWMEM .NE. 0) THEN 4616 PFREE = P 4617 MEM = MEM - NEWMEM + LEN (ME) 4618 ENDIF 4619 GO TO 30 4620 ENDIF 4621 265 CONTINUE 4622 DO 290 I = 1, N 4623 IF (ELEN (I) .EQ. 0) THEN 4624 J = -PE (I) 4625 270 CONTINUE 4626 IF (ELEN (J) .GE. 0) THEN 4627 J = -PE (J) 4628 GO TO 270 4629 ENDIF 4630 E = J 4631 K = -ELEN (E) 4632 J = I 4633 280 CONTINUE 4634 IF (ELEN (J) .GE. 0) THEN 4635 JNEXT = -PE (J) 4636 PE (J) = -E 4637 IF (ELEN (J) .EQ. 0) THEN 4638 ELEN (J) = K 4639 K = K + 1 4640 ENDIF 4641 J = JNEXT 4642 GO TO 280 4643 ENDIF 4644 ELEN (E) = -K 4645 ENDIF 4646 290 CONTINUE 4647 DO 300 I = 1, N 4648 K = abs (ELEN (I)) 4649 LAST (K) = I 4650 ELEN (I) = K 4651 300 CONTINUE 4652 IF (.NOT.SchurON) THEN 4653 PERM(PERMeqN) = N 4654 ENDIF 4655 PFREE = MAXMEM 4656 RETURN 4657 END SUBROUTINE MUMPS_422 4658 SUBROUTINE MUMPS_276( ICNTL, INFO, COMM, ID ) 4659 INTEGER ICNTL(40), INFO(40), COMM, ID 4660 INCLUDE 'mpif.h' 4661 INTEGER IN( 2 ), OUT( 2 ) 4662 INTEGER LP, IERR 4663 LP = ICNTL( 1 ) 4664 IN( 1 ) = INFO ( 1 ) 4665 IN( 2 ) = ID 4666 CALL MPI_ALLREDUCE( IN, OUT, 1, MPI_2INTEGER, MPI_MINLOC, 4667 & COMM, IERR) 4668 IF ( OUT( 1 ) .LT. 0 .and. INFO(1) .GE. 0 ) THEN 4669 INFO( 1 ) = -001 4670 INFO( 2 ) = OUT( 2 ) 4671 END IF 4672 RETURN 4673 END SUBROUTINE MUMPS_276 4674 SUBROUTINE MUMPS_137( INODE, N, PROCNODE_STEPS, 4675 & SLAVEF, 4676 & ND, FILS, FRERE_STEPS, STEP, PIMASTER, 4677 & KEEP28, KEEP50, KEEP253, 4678 & FLOP1, 4679 & IW, LIW, XSIZE ) 4680 IMPLICIT NONE 4681 INTEGER INODE, N, KEEP50, LIW, SLAVEF, KEEP28, KEEP253 4682 INTEGER PROCNODE_STEPS(KEEP28), ND(KEEP28), 4683 & FILS(N), FRERE_STEPS(KEEP28), 4684 & STEP(N), 4685 & PIMASTER(KEEP28), 4686 & IW( LIW ) 4687 INTEGER XSIZE 4688 DOUBLE PRECISION FLOP1 4689 INTEGER NUMORG, IN, NASS, IFSON, NUMSTK, NFRONT, NPIV, NCB, 4690 & LEVEL, ISON 4691 LOGICAL MUMPS_170 4692 INTEGER MUMPS_330 4693 EXTERNAL MUMPS_170, MUMPS_330 4694 INCLUDE 'mumps_headers.h' 4695 FLOP1 = 0.0D0 4696 IF (MUMPS_170(PROCNODE_STEPS(STEP(INODE)), 4697 & SLAVEF) ) RETURN 4698 IN = INODE 4699 NUMORG = 0 4700 10 NUMORG = NUMORG + 1 4701 IN = FILS(IN) 4702 IF (IN .GT. 0) GOTO 10 4703 NUMSTK = 0 4704 NASS = 0 4705 IFSON = -IN 4706 ISON = IFSON 4707 IF (ISON .EQ. 0) GOTO 30 4708 20 NUMSTK = NUMSTK + 1 4709 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 +XSIZE) 4710 ISON = FRERE_STEPS(STEP(ISON)) 4711 IF (ISON .GT. 0) GOTO 20 4712 30 NFRONT = ND(STEP(INODE)) + NASS + KEEP253 4713 NPIV = NASS + NUMORG 4714 NCB = NFRONT - NPIV 4715 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 4716 CALL MUMPS_511(NFRONT,NPIV,NPIV,KEEP50,LEVEL,FLOP1) 4717 RETURN 4718 END SUBROUTINE MUMPS_137 4719 SUBROUTINE MUMPS_511(NFRONT,NPIV,NASS, 4720 & KEEP50,LEVEL,COST) 4721 IMPLICIT NONE 4722 INTEGER, intent(in) :: NFRONT,NPIV,KEEP50,LEVEL, NASS 4723 DOUBLE PRECISION, intent(out) :: COST 4724 IF (KEEP50.EQ.0) THEN 4725 IF (LEVEL.EQ.1 .OR. LEVEL.EQ.3) THEN 4726 COST = dble(2) * dble(NFRONT) * dble(NPIV) * 4727 & dble(NFRONT - NPIV - 1) + 4728 & dble(NPIV) * dble(NPIV + 1) * dble(2 * NPIV + 1) 4729 & / dble(3) 4730 COST = COST + dble(2 * NFRONT - NPIV - 1) 4731 & * dble(NPIV) /dble(2) 4732 ELSEIF (LEVEL.EQ.2) THEN 4733 COST = dble(2*NASS)*dble(NFRONT) - 4734 & dble(NASS+NFRONT)*dble(NPIV+1) 4735 COST = dble(NPIV)*COST + 4736 & dble(2 * NASS - NPIV - 1) * dble(NPIV) / dble(2) + 4737 & dble(NPIV) * dble(NPIV + 1) * 4738 & dble(2 * NPIV + 1) /dble(3) 4739 ENDIF 4740 ELSE 4741 IF (LEVEL.EQ.1) THEN 4742 COST = dble(NPIV) * ( 4743 & dble( NFRONT ) * dble( NFRONT ) + 4744 & dble( NFRONT ) - ( 4745 & dble( NFRONT)*dble(NPIV) + dble(NPIV+1) 4746 & )) +( dble(NPIV)*dble(NPIV+1) 4747 & *dble(2*NPIV+1))/ dble(6) 4748 ELSE IF (LEVEL.EQ.3.AND.KEEP50.EQ.2) THEN 4749 COST = dble(2) * dble(NFRONT) * dble(NPIV) * 4750 & dble(NFRONT - NPIV - 1) + 4751 & dble(NPIV) * dble(NPIV + 1) * 4752 & dble(2 * NPIV + 1) / dble(3) 4753 COST = COST + dble(2 * NFRONT - NPIV - 1) 4754 & * dble(NPIV) / dble(2) 4755 ELSE 4756 COST = dble(NPIV) * ( 4757 & dble( NASS ) * dble( NASS ) + dble( NASS ) 4758 & - ( dble( NASS) * dble(NPIV) + dble( NPIV + 1 ) ) ) 4759 & + ( dble(NPIV)*dble(NPIV+1)*dble(2*NPIV+1) ) 4760 & / dble( 6 ) 4761 ENDIF 4762 ENDIF 4763 RETURN 4764 END SUBROUTINE MUMPS_511 4765 SUBROUTINE MUMPS_81(MYID, INODE, N, IOLDPS, 4766 & HF, NFRONT, NFRONT_EFF, DAD, 4767 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 4768 & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, 4769 & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, 4770 & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, 4771 & PROCNODE_STEPS, SLAVEF ) 4772 IMPLICIT NONE 4773 INTEGER, intent(in) :: INODE, N, IOLDPS, HF, NFRONT, 4774 & NASS1, LIW, NASS, 4775 & NUMSTK, NUMORG, IWPOSCB 4776 INTEGER, intent(in) :: KEEP(500) 4777 INTEGER(8) , intent(in) ::KEEP8(150) 4778 INTEGER STEP(N), 4779 & PIMASTER(KEEP(28)), 4780 & PTRAIW(N), IW(LIW), 4781 & ITLOC(N+KEEP(253)), FILS(N), FRERE(KEEP(28)) 4782 COMPLEX :: RHS_MUMPS(KEEP(255)) 4783 INTEGER INTARR(max(1,KEEP(14))) 4784 INTEGER, intent(inout) :: NBPROCFILS(KEEP(28)) 4785 LOGICAL, intent(in) :: NIV1 4786 INTEGER, intent(inout) :: IFLAG 4787 LOGICAL, intent(out) :: SON_LEVEL2 4788 INTEGER, intent(out) :: NFRONT_EFF 4789 INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF 4790 INTEGER, intent(in) :: DAD (KEEP(28)), IFSON, MYID 4791 INTEGER NEWEL, INEW, IOLDP2, INEW1, 4792 & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, 4793 & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, 4794 & NROWS, HS, IP1, IP2, K1, K2, IBROT, IORG, 4795 & I, K 4796 LOGICAL LEVEL1 4797 INTEGER MUMPS_810, MUMPS_330 4798 EXTERNAL MUMPS_810, MUMPS_330 4799 INTEGER TYPESPLIT 4800 INCLUDE 'mumps_headers.h' 4801 SON_LEVEL2 = .FALSE. 4802 IOLDP2 = IOLDPS + HF - 1 4803 ICT11 = IOLDP2 + NFRONT 4804 NTOTFS = 0 4805 TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), 4806 & SLAVEF) 4807 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN 4808 J2 = PIMASTER(STEP(IFSON)) 4809 LSTK = IW(J2 +KEEP(IXSZ)) 4810 NELIM = IW(J2 + 1+KEEP(IXSZ)) 4811 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 4812 IF (NPIVS.LT.0) NPIVS = 0 4813 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 4814 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 4815 LEVEL1 = NSLSON.EQ.0 4816 NCOLS = NPIVS + LSTK 4817 NROWS = NCOLS 4818 ITRANS = NROWS 4819 IF (NIV1) THEN 4820 write(6,*) MYID, ':', 4821 & ' Internal error 2 in MUMPS_BUILD__INDEX ', 4822 & ' interior split node of type 1 ' 4823 CALL MUMPS_ABORT() 4824 ELSE 4825 I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) 4826 J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), 4827 & SLAVEF) 4828 IF (LEVEL1.or.J.LT.4) THEN 4829 write(6,*) MYID, ':', 4830 & ' Internal error 3 in MUMPS_81 ', 4831 & ' son', IFSON, 4832 & ' of interior split node', INODE, ' of type 1 ', 4833 & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J 4834 CALL MUMPS_ABORT() 4835 ELSE 4836 NBPROCFILS(STEP(IFSON)) = NSLSON 4837 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 4838 & NBPROCFILS(STEP(IFSON)) 4839 ENDIF 4840 ENDIF 4841 IF ( J2.GT. IWPOSCB ) THEN 4842 NROWS = IW(J2 + 2+KEEP(IXSZ)) 4843 ITRANS = NPIVS + NROWS 4844 ENDIF 4845 HS = NSLSON + 6 + KEEP(IXSZ) 4846 J1 = J2 + HS + NROWS + NPIVS 4847 J2 = J1 + LSTK - 1 4848 J3 = J1 + NELIM - 1 4849 IF (NELIM.GT.0) THEN 4850 DO JJ=J1,J3 4851 NTOTFS = NTOTFS + 1 4852 JT1 = IW(JJ) 4853 IW(ICT11 + NTOTFS) = JT1 4854 IW(JJ) = NTOTFS 4855 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 4856 ENDDO 4857 ENDIF 4858 DO JJ =J3+1, J3+NUMORG 4859 NTOTFS = NTOTFS + 1 4860 JT1 = IW(JJ) 4861 ITLOC(JT1) = NTOTFS 4862 IW(JJ) = NTOTFS 4863 IW(ICT11 + NTOTFS) = JT1 4864 IW(IOLDP2 + NTOTFS) = JT1 4865 ENDDO 4866 DO JJ =J3+NUMORG+1, J2 4867 NTOTFS = NTOTFS + 1 4868 JT1 = IW(JJ) 4869 ITLOC(JT1) = NTOTFS 4870 IW(JJ) = NTOTFS 4871 IW(ICT11 + NTOTFS) = JT1 4872 IW(IOLDP2 + NTOTFS) = JT1 4873 ENDDO 4874 NFRONT_EFF = NTOTFS 4875 IBROT = INODE 4876 DO IORG = 1, NUMORG 4877 K1 = PTRAIW(IBROT) + 2 4878 JT1 = INTARR(K1) 4879 INTARR(K1) = ITLOC(JT1) 4880 IBROT = FILS(IBROT) 4881 K2 = K1 + INTARR(K1 - 2) - INTARR(K1 - 1) 4882 K1 = K1 + 1 4883 IF (K1 .LE. K2) THEN 4884 DO JJ = K1, K2 4885 J = INTARR(JJ) 4886 INTARR(JJ) = ITLOC(J) 4887 ENDDO 4888 ENDIF 4889 ENDDO 4890 K1 = IOLDPS+HF 4891 DO JJ=K1+NELIM,K1+NFRONT_EFF-1 4892 ITLOC(IW(JJ)) = 0 4893 ENDDO 4894 RETURN 4895 ENDIF 4896 NEWEL = IOLDP2 + NASS1 4897 NFRONT_EFF = NASS1 4898 IN = INODE 4899 INEW = IOLDPS + HF 4900 INEW1 = 1 4901 50 J1 = PTRAIW(IN) + 2 4902 JT1 = INTARR(J1) 4903 INTARR(J1) = INEW1 4904 ITLOC(JT1) = INEW1 4905 IW(INEW) = JT1 4906 INEW = INEW + 1 4907 INEW1 = INEW1 + 1 4908 IN = FILS(IN) 4909 IF (IN .GT. 0) GOTO 50 4910 IF (TYPESPLIT.EQ.4) THEN 4911 IBROT = INODE 4912 DO WHILE 4913 & ( 4914 & ( MUMPS_810 4915 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 4916 & .EQ.5 4917 & ) 4918 & .OR. 4919 & ( MUMPS_810 4920 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 4921 & .EQ.6 4922 & ) 4923 & ) 4924 IBROT = DAD(STEP(IBROT)) 4925 IN = IBROT 4926 DO WHILE (IN.GT.0) 4927 NFRONT_EFF = NFRONT_EFF+1 4928 NEWEL = NEWEL + 1 4929 ITLOC(IN) = NFRONT_EFF 4930 IW(NEWEL) = IN 4931 IN = FILS( IN ) 4932 ENDDO 4933 ENDDO 4934 ENDIF 4935 IF (NUMSTK .NE. 0) THEN 4936 NTOTFS = NUMORG 4937 ISON = IFSON 4938 DO 100 IELL = 1, NUMSTK 4939 J2 = PIMASTER(STEP(ISON)) 4940 LSTK = IW(J2+KEEP(IXSZ)) 4941 NELIM = IW(J2 + 1+KEEP(IXSZ)) 4942 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 4943 IF ( NPIVS .LT. 0 ) NPIVS = 0 4944 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 4945 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 4946 LEVEL1 = NSLSON.EQ.0 4947 NCOLS = NPIVS + LSTK 4948 NROWS = NCOLS 4949 ITRANS = NROWS 4950 IF (NIV1) THEN 4951 NBPROCFILS(STEP(ISON)) = NSLSON 4952 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON 4953 ELSE 4954 IF (LEVEL1) THEN 4955 NBPROCFILS(STEP(ISON)) = 1 4956 ELSE 4957 NBPROCFILS(STEP(ISON)) = NSLSON 4958 ENDIF 4959 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 4960 & NBPROCFILS(STEP(ISON)) 4961 ENDIF 4962 IF (J2.GT.IWPOSCB) THEN 4963 NROWS = IW(J2 + 2+KEEP(IXSZ)) 4964 ITRANS = NPIVS + NROWS 4965 ENDIF 4966 HS = NSLSON + 6 + KEEP(IXSZ) 4967 J1 = J2 + HS + NROWS + NPIVS 4968 J2 = J1 + LSTK - 1 - KEEP(253) 4969 J3 = J1 + NELIM - 1 4970 IF (NELIM .EQ. 0) GOTO 70 4971 DO 60 JJ = J1, J3 4972 NTOTFS = NTOTFS + 1 4973 JT1 = IW(JJ) 4974 IW(ICT11 + NTOTFS) = JT1 4975 ITLOC(JT1) = NTOTFS 4976 IW(JJ) = NTOTFS 4977 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 4978 60 CONTINUE 4979 70 J1 = J3 + 1 4980 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN 4981 DO 80 JJ = J1, J2 4982 J = IW(JJ) 4983 IF (ITLOC(J) .EQ. 0) THEN 4984 NEWEL = NEWEL + 1 4985 NFRONT_EFF = NFRONT_EFF + 1 4986 IW(NEWEL) = J 4987 IW(JJ) = NFRONT_EFF 4988 ITLOC(J) = NFRONT_EFF 4989 ELSE 4990 IW(JJ) = ITLOC(J) 4991 ENDIF 4992 80 CONTINUE 4993 ELSE 4994 DO 90 JJ = J1, J2 4995 IW(JJ) = ITLOC(IW(JJ)) 4996 90 CONTINUE 4997 ENDIF 4998 DO JJ=J2+1, J2+KEEP(253) 4999 IW(JJ)=NFRONT-KEEP(253)+JJ-J2 5000 ENDDO 5001 ISON = FRERE(STEP(ISON)) 5002 100 CONTINUE 5003 ENDIF 5004 IBROT = INODE 5005 DO 120 IORG = 1, NUMORG 5006 J1 = PTRAIW(IBROT) + 2 5007 IBROT = FILS(IBROT) 5008 J2 = J1 + INTARR(J1 - 2) - INTARR(J1 - 1) 5009 J1 = J1 + 1 5010 IF (J1 .LE. J2) THEN 5011 DO 110 JJ = J1, J2 5012 J = INTARR(JJ) 5013 IF (ITLOC(J) .EQ. 0) THEN 5014 NEWEL = NEWEL + 1 5015 NFRONT_EFF = NFRONT_EFF + 1 5016 IW(NEWEL) = J 5017 INTARR(JJ) = NFRONT_EFF 5018 ITLOC(J) = NFRONT_EFF 5019 ELSE 5020 INTARR(JJ) = ITLOC(J) 5021 ENDIF 5022 110 CONTINUE 5023 ENDIF 5024 120 CONTINUE 5025 IF ( (TYPESPLIT.EQ.4).AND.(NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN 5026 IBROT = INODE 5027 DO WHILE 5028 & ( 5029 & ( MUMPS_810 5030 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5031 & .EQ.5 5032 & ) 5033 & .OR. 5034 & ( MUMPS_810 5035 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5036 & .EQ.6 5037 & ) 5038 & ) 5039 IBROT = DAD(STEP(IBROT)) 5040 IN = IBROT 5041 DO WHILE (IN.GT.0.AND.NFRONT_EFF.LT.NFRONT-KEEP(253)) 5042 J1 = PTRAIW(IN) + 2 5043 J2 = J1 + INTARR(J1 - 2) - INTARR(J1-1) 5044 IN = FILS( IN ) 5045 DO JJ = J1+1, J2 5046 J = INTARR( JJ ) 5047 IF ( ITLOC( J ) .eq. 0 ) THEN 5048 NEWEL = NEWEL + 1 5049 NFRONT_EFF = NFRONT_EFF + 1 5050 IW( NEWEL ) = J 5051 ITLOC( J ) = NFRONT_EFF 5052 END IF 5053 ENDDO 5054 ENDDO 5055 IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT 5056 ENDDO 5057 ENDIF 5058 IF ( KEEP(253).NE.0) THEN 5059 IP1 = IOLDPS + HF + NFRONT_EFF 5060 IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF 5061 DO I= 1, KEEP(253) 5062 IW(IP1+I-1) = N+I 5063 IW(IP2+I-1) = N+I 5064 ENDDO 5065 NFRONT_EFF = NFRONT_EFF + KEEP(253) 5066 ENDIF 5067 IF (NFRONT.NE.NFRONT_EFF) THEN 5068 IF (NUMORG.EQ.NASS1) THEN 5069 IP1 = IOLDPS + HF 5070 IP2 = IOLDPS + HF + NFRONT_EFF - 1 5071 DO I = IP1, IP2 5072 IW(I + NFRONT_EFF) = IW(I) 5073 ENDDO 5074 ELSE 5075 IP1 = IOLDPS + NFRONT + HF + NUMORG 5076 IP2 = IOLDPS + HF + NFRONT_EFF + NUMORG 5077 DO I=1,NASS 5078 IW(IP2+I-1)=IW(IP1+I-1) 5079 ENDDO 5080 IP1 = IOLDPS + NASS1 + HF 5081 IP2 = IOLDPS + HF + NFRONT - 1 5082 DO I = IP1, IP2 5083 IW(I + NFRONT_EFF) = IW(I) 5084 ENDDO 5085 IP1 = IOLDPS + HF 5086 IP2 = IOLDPS + HF + NUMORG - 1 5087 DO I = IP1, IP2 5088 IW(I + NFRONT_EFF) = IW(I) 5089 ENDDO 5090 ENDIF 5091 ELSE 5092 IP1 = IOLDPS + NASS1 + HF 5093 IP2 = IOLDPS + HF + NFRONT - KEEP(253) - 1 5094 DO I = IP1, IP2 5095 IW(I + NFRONT) = IW(I) 5096 ENDDO 5097 IP1 = IOLDPS + HF 5098 IP2 = IOLDPS + HF + NUMORG - 1 5099 DO I = IP1, IP2 5100 IW(I + NFRONT) = IW(I) 5101 ENDDO 5102 ENDIF 5103 K1 = IOLDPS + HF + NUMORG 5104 K2 = K1 + NFRONT_EFF - 1 + NASS 5105 DO 150 K = K1, K2 5106 I = IW(K) 5107 ITLOC(I) = 0 5108 150 CONTINUE 5109 RETURN 5110 END SUBROUTINE MUMPS_81 5111 SUBROUTINE MUMPS_124( 5112 & NUMELT, LIST_ELT, 5113 & MYID, INODE, N, IOLDPS, 5114 & HF, NFRONT, NFRONT_EFF, 5115 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 5116 & IFSON, STEP, PIMASTER, PTRAIW, NELT, 5117 & IW, LIW, 5118 & INTARR, LINTARR, ITLOC, RHS_MUMPS, 5119 & FILS, FRERE_STEPS, 5120 & KEEP, 5121 & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, 5122 & DAD, PROCNODE_STEPS, SLAVEF, 5123 & FRT_PTR, FRT_ELT, Pos_First_NUMORG) 5124 IMPLICIT NONE 5125 INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, 5126 & NUMSTK, NUMORG, IWPOSCB, IFSON, MYID, IFLAG, 5127 & LINTARR, NUMELT, NFRONT_EFF 5128 INTEGER KEEP(500) 5129 INTEGER LIST_ELT(*) 5130 INTEGER STEP(N), 5131 & PIMASTER(KEEP(28)), 5132 & PTRAIW(NELT+1), IW(LIW), 5133 & ITLOC(N+KEEP(253)), FILS(N), 5134 & FRERE_STEPS(KEEP(28)), 5135 & NBPROCFILS(KEEP(28)) 5136 COMPLEX, POINTER, DIMENSION(:) :: RHS_MUMPS 5137 INTEGER INTARR(LINTARR) 5138 LOGICAL SON_LEVEL2, NIV1 5139 INTEGER, intent(in) :: DAD (KEEP(28)) 5140 INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF 5141 INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) 5142 INTEGER, intent(out) :: Pos_First_NUMORG 5143 INTEGER NEWEL, INEW, IOLDP2, INEW1, 5144 & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, 5145 & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, 5146 & NROWS, HS, IP1, IP2, K1, K2, 5147 & I, K, ELTI 5148 LOGICAL LEVEL1 5149 INTEGER MUMPS_810, MUMPS_330 5150 EXTERNAL MUMPS_810, MUMPS_330 5151 INTEGER TYPESPLIT, NUMELT_IBROT, IBROT 5152 INCLUDE 'mumps_headers.h' 5153 SON_LEVEL2 = .FALSE. 5154 IOLDP2 = IOLDPS + HF - 1 5155 NTOTFS = 0 5156 ICT11 = IOLDP2 + NFRONT 5157 TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), 5158 & SLAVEF) 5159 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN 5160 J2 = PIMASTER(STEP(IFSON)) 5161 LSTK = IW(J2 +KEEP(IXSZ)) 5162 NELIM = IW(J2 + 1+KEEP(IXSZ)) 5163 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 5164 IF (NPIVS.LT.0) NPIVS = 0 5165 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 5166 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 5167 LEVEL1 = NSLSON.EQ.0 5168 NCOLS = NPIVS + LSTK 5169 NROWS = NCOLS 5170 ITRANS = NROWS 5171 IF (NIV1) THEN 5172 write(6,*) MYID, ':', 5173 & ' Internal error 2 in MUMPS_BUILD__INDEX ', 5174 & ' interior split node of type 1 ' 5175 CALL MUMPS_ABORT() 5176 ELSE 5177 I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) 5178 J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), 5179 & SLAVEF) 5180 IF (LEVEL1.or.J.LT.4) THEN 5181 write(6,*) MYID, ':', 5182 & ' Internal error 3 in MUMPS_81 ', 5183 & ' son', IFSON, 5184 & ' of interior split node', INODE, ' of type 1 ', 5185 & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J 5186 CALL MUMPS_ABORT() 5187 ELSE 5188 NBPROCFILS(STEP(IFSON)) = NSLSON 5189 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 5190 & NBPROCFILS(STEP(IFSON)) 5191 ENDIF 5192 ENDIF 5193 IF ( J2.GT. IWPOSCB ) THEN 5194 NROWS = IW(J2 + 2+KEEP(IXSZ)) 5195 ITRANS = NPIVS + NROWS 5196 ENDIF 5197 HS = NSLSON + 6 + KEEP(IXSZ) 5198 J1 = J2 + HS + NROWS + NPIVS 5199 J2 = J1 + LSTK - 1 5200 J3 = J1 + NELIM - 1 5201 IF (NELIM.GT.0) THEN 5202 DO JJ=J1,J3 5203 NTOTFS = NTOTFS + 1 5204 JT1 = IW(JJ) 5205 IW(ICT11 + NTOTFS) = JT1 5206 IW(JJ) = NTOTFS 5207 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 5208 ENDDO 5209 ENDIF 5210 DO JJ =J3+1, J2 5211 NTOTFS = NTOTFS + 1 5212 JT1 = IW(JJ) 5213 ITLOC(JT1) = NTOTFS 5214 IW(JJ) = NTOTFS 5215 IW(ICT11 + NTOTFS) = JT1 5216 IW(IOLDP2 + NTOTFS) = JT1 5217 ENDDO 5218 NFRONT_EFF = NTOTFS 5219 DO IELL=1,NUMELT 5220 ELTI = LIST_ELT(IELL) 5221 J1= PTRAIW(ELTI) 5222 J2= PTRAIW(ELTI+1)-1 5223 DO JJ=J1,J2 5224 J = INTARR(JJ) 5225 INTARR(JJ) = ITLOC(J) 5226 END DO 5227 ENDDO 5228 K1 = IOLDPS+HF 5229 DO JJ=K1+NELIM,K1+NFRONT_EFF-1 5230 ITLOC(IW(JJ)) = 0 5231 ENDDO 5232 RETURN 5233 ENDIF 5234 NEWEL = IOLDP2 + NASS1 5235 NFRONT_EFF = NASS1 5236 IN = INODE 5237 INEW = IOLDPS + HF 5238 INEW1 = 1 5239 DO WHILE (IN.GT.0) 5240 ITLOC(IN) = INEW1 5241 IW(INEW) = IN 5242 INEW1 = INEW1 + 1 5243 INEW = INEW + 1 5244 IN = FILS(IN) 5245 END DO 5246 IF (TYPESPLIT.EQ.4) THEN 5247 IBROT = INODE 5248 DO WHILE 5249 & ( 5250 & ( MUMPS_810 5251 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5252 & .EQ.5 5253 & ) 5254 & .OR. 5255 & ( MUMPS_810 5256 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5257 & .EQ.6 5258 & ) 5259 & ) 5260 IBROT = DAD(STEP(IBROT)) 5261 IN = IBROT 5262 DO WHILE (IN.GT.0) 5263 NFRONT_EFF = NFRONT_EFF+1 5264 NEWEL = NEWEL + 1 5265 ITLOC(IN) = NFRONT_EFF 5266 IW(NEWEL) = IN 5267 IN = FILS( IN ) 5268 ENDDO 5269 ENDDO 5270 ENDIF 5271 IF (NUMSTK .NE. 0) THEN 5272 NTOTFS = NUMORG 5273 ISON = IFSON 5274 DO 100 IELL = 1, NUMSTK 5275 J2 = PIMASTER(STEP(ISON)) 5276 LSTK = IW(J2+KEEP(IXSZ)) 5277 NELIM = IW(J2 + 1+KEEP(IXSZ)) 5278 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 5279 IF ( NPIVS .LT. 0 ) NPIVS = 0 5280 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 5281 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 5282 LEVEL1 = NSLSON.EQ.0 5283 NCOLS = NPIVS + LSTK 5284 NROWS = NCOLS 5285 ITRANS = NROWS 5286 IF (NIV1) THEN 5287 NBPROCFILS(STEP(ISON)) = NSLSON 5288 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON 5289 ELSE 5290 IF (LEVEL1) THEN 5291 NBPROCFILS(STEP(ISON)) = 1 5292 ELSE 5293 NBPROCFILS(STEP(ISON)) = NSLSON 5294 ENDIF 5295 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 5296 & NBPROCFILS(STEP(ISON)) 5297 ENDIF 5298 IF (J2.GT.IWPOSCB) THEN 5299 NROWS = IW(J2 + 2+KEEP(IXSZ)) 5300 ITRANS = NPIVS + NROWS 5301 ENDIF 5302 HS = NSLSON + 6 +KEEP(IXSZ) 5303 J1 = J2 + HS + NROWS + NPIVS 5304 J2 = J1 + LSTK - 1 - KEEP(253) 5305 J3 = J1 + NELIM - 1 5306 IF (NELIM .EQ. 0) GOTO 70 5307 DO 60 JJ = J1, J3 5308 NTOTFS = NTOTFS + 1 5309 JT1 = IW(JJ) 5310 IW(ICT11 + NTOTFS) = JT1 5311 ITLOC(JT1) = NTOTFS 5312 IW(JJ) = NTOTFS 5313 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 5314 60 CONTINUE 5315 70 J1 = J3 + 1 5316 IF (NASS1 .NE. NFRONT) THEN 5317 DO 80 JJ = J1, J2 5318 J = IW(JJ) 5319 IF (ITLOC(J) .EQ. 0) THEN 5320 NEWEL = NEWEL + 1 5321 NFRONT_EFF = NFRONT_EFF + 1 5322 IW(NEWEL) = J 5323 IW(JJ) = NFRONT_EFF 5324 ITLOC(J) = NFRONT_EFF 5325 ELSE 5326 IW(JJ) = ITLOC(J) 5327 ENDIF 5328 80 CONTINUE 5329 ELSE 5330 DO 90 JJ = J1, J2 5331 IW(JJ) = ITLOC(IW(JJ)) 5332 90 CONTINUE 5333 ENDIF 5334 DO JJ=J2+1, J2+KEEP(253) 5335 IW(JJ)=NFRONT-KEEP(253)+JJ-J2 5336 ENDDO 5337 ISON = FRERE_STEPS(STEP(ISON)) 5338 100 CONTINUE 5339 ENDIF 5340 DO IELL=1,NUMELT 5341 ELTI = LIST_ELT(IELL) 5342 J1= PTRAIW(ELTI) 5343 J2= PTRAIW(ELTI+1)-1 5344 DO JJ=J1,J2 5345 J = INTARR(JJ) 5346 IF (ITLOC(J) .EQ. 0) THEN 5347 NEWEL = NEWEL + 1 5348 NFRONT_EFF = NFRONT_EFF + 1 5349 IW(NEWEL) = J 5350 INTARR(JJ) = NFRONT_EFF 5351 ITLOC(J) = NFRONT_EFF 5352 ELSE 5353 INTARR(JJ) = ITLOC(J) 5354 ENDIF 5355 END DO 5356 ENDDO 5357 IF ( (TYPESPLIT.EQ.4).AND.(NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN 5358 IBROT = INODE 5359 DO WHILE 5360 & ( 5361 & ( MUMPS_810 5362 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5363 & .EQ.5 5364 & ) 5365 & .OR. 5366 & ( MUMPS_810 5367 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5368 & .EQ.6 5369 & ) 5370 & ) 5371 IBROT = DAD(STEP(IBROT)) 5372 NUMELT_IBROT = FRT_PTR(IBROT+1) - FRT_PTR(IBROT) 5373 IF (NUMELT_IBROT.EQ.0) CYCLE 5374 DO IELL = FRT_PTR(IBROT), FRT_PTR(IBROT+1) 5375 ELTI = FRT_ELT(IELL) 5376 J1= PTRAIW(ELTI) 5377 J2= PTRAIW(ELTI+1)-1 5378 DO JJ=J1,J2 5379 J = INTARR( JJ ) 5380 IF ( ITLOC( J ) .eq. 0 ) THEN 5381 NEWEL = NEWEL + 1 5382 NFRONT_EFF = NFRONT_EFF + 1 5383 IW( NEWEL ) = J 5384 ITLOC( J ) = NFRONT_EFF 5385 END IF 5386 ENDDO 5387 ENDDO 5388 IF (NFRONT_EFF.EQ.NFRONT) EXIT 5389 ENDDO 5390 ENDIF 5391 IF ( KEEP(253).GT.0) THEN 5392 IP1 = IOLDPS + HF + NFRONT_EFF 5393 IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF 5394 DO I= 1, KEEP(253) 5395 IW(IP1+I-1) = N+I 5396 IW(IP2+I-1) = N+I 5397 ENDDO 5398 NFRONT_EFF = NFRONT_EFF + KEEP(253) 5399 ENDIF 5400 IF (NFRONT.NE.NFRONT_EFF) THEN 5401 IF (NUMORG.EQ.NASS1) THEN 5402 IP1 = IOLDPS + HF 5403 IP2 = IOLDPS + HF + NFRONT_EFF - 1 5404 DO I = IP1, IP2 5405 IW(I + NFRONT_EFF) = IW(I) 5406 ENDDO 5407 ELSE 5408 IP1 = IOLDPS + NFRONT + HF + NUMORG 5409 IP2 = IOLDPS + HF + NFRONT_EFF + NUMORG 5410 DO I=1,NASS 5411 IW(IP2+I-1)=IW(IP1+I-1) 5412 ENDDO 5413 IP1 = IOLDPS + NASS1 + HF 5414 IP2 = IOLDPS + HF + NFRONT - 1 5415 DO I = IP1, IP2 5416 IW(I + NFRONT_EFF) = IW(I) 5417 ENDDO 5418 IP1 = IOLDPS + HF 5419 IP2 = IOLDPS + HF + NUMORG - 1 5420 DO I = IP1, IP2 5421 IW(I + NFRONT_EFF) = IW(I) 5422 ENDDO 5423 ENDIF 5424 ELSE 5425 IP1 = IOLDPS + NASS1 + HF 5426 IP2 = IOLDPS + HF + NFRONT - 1 5427 DO I = IP1, IP2 5428 IW(I + NFRONT) = IW(I) 5429 ENDDO 5430 IP1 = IOLDPS + HF 5431 IP2 = IOLDPS + HF + NUMORG - 1 5432 DO I = IP1, IP2 5433 IW(I + NFRONT) = IW(I) 5434 ENDDO 5435 ENDIF 5436 Pos_First_NUMORG = ITLOC(INODE) 5437 K1 = IOLDPS + HF + NUMORG 5438 K2 = K1 + NFRONT_EFF - 1 + NASS 5439 DO 150 K = K1, K2 5440 I = IW(K) 5441 ITLOC(I) = 0 5442 150 CONTINUE 5443 RETURN 5444 END SUBROUTINE MUMPS_124 5445 SUBROUTINE MUMPS_86(MYID, INODE, N, IOLDPS, 5446 & HF, NFRONT, NFRONT_EFF, PERM, DAD, 5447 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 5448 & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, 5449 & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE_STEPS, 5450 & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, 5451 & ISON_IN_PLACE, PROCNODE_STEPS, SLAVEF ) 5452 IMPLICIT NONE 5453 INTEGER INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, 5454 & NUMSTK, NUMORG, IWPOSCB, IFSON, MYID 5455 INTEGER, intent(in) :: ISON_IN_PLACE 5456 INTEGER KEEP(500) 5457 INTEGER(8) KEEP8(150) 5458 INTEGER STEP(N), PIMASTER(KEEP(28)), 5459 & PTRAIW(N), IW(LIW), 5460 & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), 5461 & NBPROCFILS(KEEP(28)), PERM(N) 5462 COMPLEX :: RHS_MUMPS(KEEP(255)) 5463 INTEGER INTARR(max(1,KEEP(14))) 5464 LOGICAL, intent(in) :: NIV1 5465 INTEGER, intent(inout) :: IFLAG 5466 LOGICAL, intent(out) :: SON_LEVEL2 5467 INTEGER, intent(out) :: NFRONT_EFF 5468 INTEGER, intent(in) :: DAD (KEEP(28)) 5469 INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF 5470 INTEGER NELIM_SON_IN_PLACE 5471 INTEGER NEWEL, IOLDP2, INEW, INEW1, 5472 & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, 5473 & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, 5474 & NROWS, HS, IP1, IP2, K1, K2, IBROT, IORG, 5475 & I, K, JDEBROW, ILOC, NEWEL_SAVE, NEWEL1_SAVE, 5476 & LAST_J_ASS, JMIN, MIN_PERM 5477 LOGICAL LEVEL1 5478 INTEGER TYPESPLIT 5479 INCLUDE 'mumps_headers.h' 5480 INTEGER allocok 5481 INTEGER, ALLOCATABLE, DIMENSION(:) :: PTTRI, PTLAST 5482 INTEGER MUMPS_810, MUMPS_330 5483 EXTERNAL MUMPS_810, MUMPS_330 5484 TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), 5485 & SLAVEF) 5486 SON_LEVEL2 = .FALSE. 5487 IOLDP2 = IOLDPS + HF - 1 5488 ICT11 = IOLDP2 + NFRONT 5489 NTOTFS = 0 5490 NELIM_SON_IN_PLACE = 0 5491 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN 5492 J2 = PIMASTER(STEP(IFSON)) 5493 LSTK = IW(J2 +KEEP(IXSZ)) 5494 NELIM = IW(J2 + 1+KEEP(IXSZ)) 5495 IF ( ISON_IN_PLACE > 0 ) THEN 5496 IF (ISON_IN_PLACE.NE.IFSON) THEN 5497 write(6,*) MYID, ':', 5498 & ' Internal error 1 in MUMPS_86 ', 5499 & ' in place node is not the first son a interior split node ' 5500 CALL MUMPS_ABORT() 5501 ENDIF 5502 NELIM_SON_IN_PLACE = NELIM 5503 ENDIF 5504 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 5505 IF (NPIVS.LT.0) NPIVS = 0 5506 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 5507 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 5508 LEVEL1 = NSLSON.EQ.0 5509 NCOLS = NPIVS + LSTK 5510 NROWS = NCOLS 5511 ITRANS = NROWS 5512 IF (NIV1) THEN 5513 write(6,*) MYID, ':', 5514 & ' Internal error 2 in MUMPS_86 ', 5515 & ' interior split node of type 1 ' 5516 CALL MUMPS_ABORT() 5517 ELSE 5518 I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) 5519 J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), 5520 & SLAVEF) 5521 IF (LEVEL1.or.J.LT.4) THEN 5522 write(6,*) MYID, ':', 5523 & ' Internal error 3 in MUMPS_86 ', 5524 & ' son', IFSON, 5525 & ' of interior split node', INODE, ' of type 1 ', 5526 & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J 5527 CALL MUMPS_ABORT() 5528 ELSE 5529 NBPROCFILS(STEP(IFSON)) = NSLSON 5530 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 5531 & NBPROCFILS(STEP(IFSON)) 5532 ENDIF 5533 ENDIF 5534 IF ( J2.GT. IWPOSCB ) THEN 5535 NROWS = IW(J2 + 2+KEEP(IXSZ)) 5536 ITRANS = NPIVS + NROWS 5537 ENDIF 5538 HS = NSLSON + 6 + KEEP(IXSZ) 5539 J1 = J2 + HS + NROWS + NPIVS 5540 J2 = J1 + LSTK - 1 5541 J3 = J1 + NELIM - 1 5542 IF (NELIM.GT.0) THEN 5543 DO JJ=J1,J3 5544 NTOTFS = NTOTFS + 1 5545 JT1 = IW(JJ) 5546 IW(ICT11 + NTOTFS) = JT1 5547 IW(JJ) = NTOTFS 5548 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 5549 ENDDO 5550 ENDIF 5551 DO JJ =J3+1, J3+NUMORG 5552 NTOTFS = NTOTFS + 1 5553 JT1 = IW(JJ) 5554 ITLOC(JT1) = NTOTFS 5555 IW(JJ) = NTOTFS 5556 IW(ICT11 + NTOTFS) = JT1 5557 IW(IOLDP2 + NTOTFS) = JT1 5558 ENDDO 5559 DO JJ =J3+NUMORG+1, J2 5560 NTOTFS = NTOTFS + 1 5561 JT1 = IW(JJ) 5562 ITLOC(JT1) = NTOTFS 5563 IW(JJ) = NTOTFS 5564 IW(ICT11 + NTOTFS) = JT1 5565 IW(IOLDP2 + NTOTFS) = JT1 5566 ENDDO 5567 NFRONT_EFF = NTOTFS 5568 IBROT = INODE 5569 DO IORG = 1, NUMORG 5570 K1 = PTRAIW(IBROT) + 2 5571 JT1 = INTARR(K1) 5572 INTARR(K1) = ITLOC(JT1) 5573 IBROT = FILS(IBROT) 5574 K2 = K1 + INTARR(K1 - 2) - INTARR(K1 - 1) 5575 K1 = K1 + 1 5576 IF (K1 .LE. K2) THEN 5577 DO JJ = K1, K2 5578 J = INTARR(JJ) 5579 INTARR(JJ) = ITLOC(J) 5580 ENDDO 5581 ENDIF 5582 ENDDO 5583 K1 = IOLDPS+HF 5584 DO JJ=K1+NELIM,K1+NFRONT_EFF-1 5585 ITLOC(IW(JJ)) = 0 5586 ENDDO 5587 RETURN 5588 ENDIF 5589 ALLOCATE(PTTRI(NUMSTK+1), stat=allocok) 5590 IF (allocok .GT. 0) THEN 5591 IFLAG = -13 5592 GOTO 800 5593 ENDIF 5594 ALLOCATE(PTLAST(NUMSTK+1), stat=allocok) 5595 IF (allocok .GT. 0) THEN 5596 IFLAG = -13 5597 GOTO 800 5598 ENDIF 5599 NFRONT_EFF = NASS1 5600 IF ( ISON_IN_PLACE > 0 ) THEN 5601 ISON = ISON_IN_PLACE 5602 J2 = PIMASTER(STEP(ISON)) 5603 LSTK = IW(J2 +KEEP(IXSZ)) 5604 NELIM = IW(J2 + 1+KEEP(IXSZ)) 5605 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 5606 IF (NPIVS.LT.0) NPIVS = 0 5607 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 5608 NCOLS = NPIVS + LSTK 5609 NROWS = NCOLS 5610 ITRANS = NROWS 5611 IF ( J2.GT. IWPOSCB ) THEN 5612 NROWS = IW(J2 + 2+KEEP(IXSZ)) 5613 ITRANS = NPIVS + NROWS 5614 ENDIF 5615 HS = NSLSON + 6 + KEEP(IXSZ) 5616 J1 = J2 + HS + NROWS + NPIVS 5617 J2 = J1 + LSTK - 1 5618 J3 = J1 + NELIM - 1 5619 DO JJ = J1, J3 5620 NTOTFS = NTOTFS + 1 5621 JT1 = IW(JJ) 5622 IW(ICT11 + NTOTFS) = JT1 5623 ITLOC(JT1) = NTOTFS 5624 IW(JJ) = NTOTFS 5625 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 5626 ENDDO 5627 NELIM_SON_IN_PLACE = NTOTFS 5628 ENDIF 5629 IN = INODE 5630 INEW = IOLDPS + HF + NTOTFS 5631 INEW1 = NTOTFS + 1 5632 JDEBROW = PTRAIW(INODE)+3 5633 PTTRI(NUMSTK+1) = JDEBROW 5634 PTLAST(NUMSTK+1) = JDEBROW + INTARR(JDEBROW-3) - 1 5635 50 J1 = PTRAIW(IN) + 2 5636 JT1 = INTARR(J1) 5637 INTARR(J1) = INEW1 5638 ITLOC(JT1) = INEW1 5639 IW(INEW) = JT1 5640 IW(INEW+NFRONT) = JT1 5641 INEW = INEW + 1 5642 INEW1 = INEW1 + 1 5643 IN = FILS(IN) 5644 IF (IN .GT. 0) GOTO 50 5645 NTOTFS = NTOTFS + NUMORG 5646 IF (NUMSTK .NE. 0) THEN 5647 ISON = IFSON 5648 DO IELL = 1, NUMSTK 5649 J2 = PIMASTER(STEP(ISON)) 5650 LSTK = IW(J2 +KEEP(IXSZ)) 5651 NELIM = IW(J2 + 1+KEEP(IXSZ)) 5652 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 5653 IF (NPIVS.LT.0) NPIVS = 0 5654 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 5655 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 5656 LEVEL1 = NSLSON.EQ.0 5657 NCOLS = NPIVS + LSTK 5658 NROWS = NCOLS 5659 ITRANS = NROWS 5660 IF (NIV1) THEN 5661 NBPROCFILS(STEP(ISON)) = NSLSON 5662 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON 5663 ELSE 5664 IF (LEVEL1) THEN 5665 NBPROCFILS(STEP(ISON)) = 1 5666 ELSE 5667 NBPROCFILS(STEP(ISON)) = NSLSON 5668 ENDIF 5669 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 5670 & NBPROCFILS(STEP(ISON)) 5671 ENDIF 5672 IF (J2.GT.IWPOSCB) THEN 5673 NROWS = IW(J2 + 2+KEEP(IXSZ)) 5674 ITRANS = NPIVS + NROWS 5675 ENDIF 5676 HS = NSLSON + 6 + KEEP(IXSZ) 5677 J1 = J2 + HS + NROWS + NPIVS 5678 J2 = J1 + LSTK - 1 - KEEP(253) 5679 J3 = J1 + NELIM - 1 5680 IF (NELIM .NE. 0 .AND. ISON.NE.ISON_IN_PLACE) THEN 5681 DO JJ = J1, J3 5682 NTOTFS = NTOTFS + 1 5683 JT1 = IW(JJ) 5684 IW(ICT11 + NTOTFS) = JT1 5685 ITLOC(JT1) = NTOTFS 5686 IW(JJ) = NTOTFS 5687 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 5688 ENDDO 5689 ENDIF 5690 PTTRI(IELL) = J2+1 5691 PTLAST(IELL) = J2 5692 J1 = J3 + 1 5693 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN 5694 DO JJ = J1, J2 5695 J = IW(JJ) 5696 IF (ITLOC(J) .EQ. 0) THEN 5697 PTTRI(IELL) = JJ 5698 EXIT 5699 ENDIF 5700 ENDDO 5701 ELSE 5702 DO JJ = J1, J2 5703 IW(JJ) = ITLOC(IW(JJ)) 5704 ENDDO 5705 DO JJ=J2+1, J2+KEEP(253) 5706 IW(JJ)=NFRONT-KEEP(253)+JJ-J2 5707 ENDDO 5708 ENDIF 5709 ISON = FRERE_STEPS(STEP(ISON)) 5710 ENDDO 5711 ENDIF 5712 IF (NFRONT-KEEP(253).EQ.NASS1) GOTO 500 5713 199 CONTINUE 5714 IF ( PTTRI( NUMSTK + 1 ) .LE. PTLAST( NUMSTK + 1 ) ) THEN 5715 IF ( ITLOC( INTARR( PTTRI( NUMSTK + 1 ) ) ) .NE. 0 ) THEN 5716 PTTRI( NUMSTK + 1 ) = PTTRI( NUMSTK + 1 ) + 1 5717 GOTO 199 5718 END IF 5719 END IF 5720 MIN_PERM = N + 1 5721 DO IELL = 1, NUMSTK 5722 ILOC = PTTRI( IELL ) 5723 IF ( ILOC .LE. PTLAST( IELL ) ) THEN 5724 IF ( PERM( IW( ILOC ) ) .LT. MIN_PERM ) THEN 5725 JMIN = IW( ILOC ) 5726 MIN_PERM = PERM( JMIN ) 5727 END IF 5728 END IF 5729 END DO 5730 IELL = NUMSTK + 1 5731 ILOC = PTTRI( IELL ) 5732 IF ( ILOC .LE. PTLAST( IELL ) ) THEN 5733 IF ( PERM( INTARR( ILOC ) ) .LT. MIN_PERM ) THEN 5734 JMIN = INTARR( ILOC ) 5735 MIN_PERM = PERM( JMIN ) 5736 END IF 5737 END IF 5738 NEWEL = IOLDP2 + NASS1 + NFRONT 5739 DO WHILE ( MIN_PERM .NE. N + 1 ) 5740 NEWEL = NEWEL + 1 5741 NFRONT_EFF = NFRONT_EFF + 1 5742 IW( NEWEL ) = JMIN 5743 ITLOC( JMIN ) = NFRONT_EFF 5744 LAST_J_ASS = JMIN 5745 MIN_PERM = N + 1 5746 DO IELL = 1, NUMSTK 5747 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN 5748 IF ( IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) 5749 & PTTRI( IELL ) = PTTRI( IELL ) + 1 5750 ENDIF 5751 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN 5752 IF ( PERM(IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN 5753 JMIN = IW( PTTRI( IELL ) ) 5754 MIN_PERM = PERM( JMIN ) 5755 END IF 5756 END IF 5757 END DO 5758 IELL = NUMSTK + 1 5759 145 CONTINUE 5760 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN 5761 IF ( INTARR( PTTRI( IELL ) ) .eq. LAST_J_ASS ) THEN 5762 PTTRI( IELL ) = PTTRI( IELL ) + 1 5763 GOTO 145 5764 END IF 5765 END IF 5766 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN 5767 IF (PERM(INTARR( PTTRI(IELL) )) .LT. MIN_PERM) THEN 5768 JMIN = INTARR( PTTRI(IELL) ) 5769 MIN_PERM = PERM( JMIN ) 5770 END IF 5771 END IF 5772 END DO 5773 NEWEL_SAVE = NEWEL 5774 NEWEL1_SAVE = NFRONT_EFF 5775 IF (NEWEL1_SAVE.LT.NFRONT - KEEP(253)) THEN 5776 IBROT = INODE 5777 DO IORG = 1, NUMORG 5778 J1 = PTRAIW(IBROT) + 2 5779 J2 = J1 + INTARR(J1 - 2) - INTARR(J1-1) 5780 IBROT = FILS( IBROT ) 5781 IF ( IORG.EQ. 1) THEN 5782 IF ( KEEP(50).NE.0 ) CYCLE 5783 J1 = J1 + 1 + INTARR(J1-2) 5784 ELSE 5785 J1 = J1 + 1 5786 ENDIF 5787 DO JJ = J1, J2 5788 J = INTARR( JJ ) 5789 IF ( ITLOC( J ) .eq. 0 ) THEN 5790 NEWEL = NEWEL + 1 5791 NFRONT_EFF = NFRONT_EFF + 1 5792 IW( NEWEL ) = J 5793 ITLOC( J ) = NFRONT_EFF 5794 END IF 5795 ENDDO 5796 ENDDO 5797 IF ( (TYPESPLIT.EQ.4).AND. 5798 & (NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN 5799 IBROT = INODE 5800 DO WHILE 5801 & ( 5802 & ( MUMPS_810 5803 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5804 & .EQ.5 5805 & ) 5806 & .OR. 5807 & ( MUMPS_810 5808 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 5809 & .EQ.6 5810 & ) 5811 & ) 5812 IBROT = DAD(STEP(IBROT)) 5813 IN = IBROT 5814 DO WHILE (IN.GT.0.AND.NFRONT_EFF.LT.NFRONT-KEEP(253)) 5815 J1 = PTRAIW(IN) + 2 5816 J2 = J1 + INTARR(J1 - 2) - INTARR(J1-1) 5817 IN = FILS( IN ) 5818 DO JJ = J1, J2 5819 J = INTARR( JJ ) 5820 IF ( ITLOC( J ) .eq. 0 ) THEN 5821 NEWEL = NEWEL + 1 5822 NFRONT_EFF = NFRONT_EFF + 1 5823 IW( NEWEL ) = J 5824 ITLOC( J ) = NFRONT_EFF 5825 END IF 5826 ENDDO 5827 ENDDO 5828 IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT 5829 ENDDO 5830 ENDIF 5831 ENDIF 5832 IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN 5833 DO JJ=NASS1+1, NFRONT_EFF 5834 IW( IOLDP2+JJ ) = IW( ICT11+JJ ) 5835 ENDDO 5836 ELSE 5837 CALL MUMPS_308( N, PERM, 5838 & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) 5839 CALL MUMPS_309( N, NASS1, PERM, ITLOC, 5840 & IW( NEWEL_SAVE + 1), NFRONT_EFF - NEWEL1_SAVE, 5841 & IW( ICT11 + NASS1 + 1 ), NEWEL1_SAVE - NASS1, 5842 & IW( IOLDP2 + NASS1 + 1 ), NFRONT_EFF - NASS1 ) 5843 DO JJ = NASS1+1, NFRONT_EFF 5844 IW(ICT11 + JJ) = IW(IOLDP2+JJ) 5845 ENDDO 5846 END IF 5847 500 CONTINUE 5848 IF ( KEEP(253).GT.0) THEN 5849 IP1 = IOLDPS + HF + NFRONT_EFF 5850 IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF 5851 DO I= 1, KEEP(253) 5852 IW(IP1+I-1) = N+I 5853 IW(IP2+I-1) = N+I 5854 ITLOC(N+I) = NFRONT_EFF + I 5855 ENDDO 5856 NFRONT_EFF = NFRONT_EFF + KEEP(253) 5857 ENDIF 5858 IF (NFRONT.NE.NFRONT_EFF) THEN 5859 IP1 = IOLDPS + NFRONT + HF 5860 IP2 = IOLDPS + NFRONT_EFF + HF 5861 DO I=1, NFRONT_EFF 5862 IW(IP2+I-1)=IW(IP1+I-1) 5863 ENDDO 5864 ENDIF 5865 IF ((NUMSTK .NE. 0).AND.(NFRONT-KEEP(253).GT.NASS1)) THEN 5866 ISON = IFSON 5867 DO IELL = 1, NUMSTK 5868 J2 = PIMASTER(STEP(ISON)) 5869 LSTK = IW(J2+KEEP(IXSZ)) 5870 NELIM = IW(J2 + 1+KEEP(IXSZ)) 5871 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 5872 IF (NPIVS.LT.0) NPIVS = 0 5873 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 5874 NCOLS = NPIVS + LSTK 5875 NROWS = NCOLS 5876 IF (J2.GT.IWPOSCB) THEN 5877 NROWS = IW(J2 + 2+KEEP(IXSZ)) 5878 ENDIF 5879 HS = NSLSON + 6 +KEEP(IXSZ) 5880 J1 = J2 + HS + NROWS + NPIVS 5881 J2 = J1 + LSTK - 1 5882 J3 = J1 + NELIM - 1 5883 J1 = J3 + 1 5884 DO JJ = J1, J2 5885 J = IW(JJ) 5886 IW(JJ) = ITLOC(J) 5887 ENDDO 5888 ISON = FRERE_STEPS(STEP(ISON)) 5889 ENDDO 5890 ENDIF 5891 IBROT = INODE 5892 DO IORG = 1, NUMORG 5893 J1 = PTRAIW(IBROT) + 2 5894 IBROT = FILS(IBROT) 5895 J2 = J1 + INTARR(J1 - 2) - INTARR(J1 - 1) 5896 J1 = J1 + 1 5897 IF (J1 .LE. J2) THEN 5898 DO JJ = J1, J2 5899 J = INTARR(JJ) 5900 INTARR(JJ) = ITLOC(J) 5901 ENDDO 5902 ENDIF 5903 ENDDO 5904 K1 = IOLDPS + HF 5905 K2 = K1 + NFRONT_EFF -1 5906 IF (KEEP(50).EQ.0) K2 = K2 + NELIM_SON_IN_PLACE 5907 DO K = K1, K2 5908 I = IW(K) 5909 ITLOC(I) = 0 5910 ENDDO 5911 IF (KEEP(50).EQ.0) THEN 5912 K1 = IOLDPS+HF+NFRONT_EFF+NELIM_SON_IN_PLACE+NUMORG 5913 K2 = K1 + NASS -NELIM_SON_IN_PLACE - 1 5914 DO K = K1, K2 5915 I = IW(K) 5916 ITLOC(I) = 0 5917 ENDDO 5918 ENDIF 5919 800 CONTINUE 5920 IF (allocated(PTTRI)) DEALLOCATE(PTTRI) 5921 IF (allocated(PTLAST)) DEALLOCATE(PTLAST) 5922 RETURN 5923 END SUBROUTINE MUMPS_86 5924 SUBROUTINE MUMPS_308( N, PERM, IW, LIW ) 5925 IMPLICIT NONE 5926 INTEGER N, LIW 5927 INTEGER PERM( N ), IW( LIW ) 5928 INTEGER I, SWAP 5929 LOGICAL DONE 5930 DONE = .FALSE. 5931 DO WHILE ( .NOT. DONE ) 5932 DONE = .TRUE. 5933 DO I = 1, LIW - 1 5934 IF ( PERM( IW( I ) ) .GT. PERM( IW( I + 1 ) ) ) THEN 5935 DONE = .FALSE. 5936 SWAP = IW( I + 1 ) 5937 IW( I + 1 ) = IW( I ) 5938 IW( I ) = SWAP 5939 END IF 5940 END DO 5941 END DO 5942 RETURN 5943 END SUBROUTINE MUMPS_308 5944 SUBROUTINE MUMPS_309( N, NASS1, PERM, ITLOC, 5945 & SMALL, LSMALL, 5946 & LARGE, LLARGE, 5947 & MERGE, LMERGE ) 5948 IMPLICIT NONE 5949 INTEGER N, NASS1, LSMALL, LLARGE, LMERGE 5950 INTEGER PERM( N ), ITLOC( N ) 5951 INTEGER SMALL(LSMALL), LARGE(LLARGE), MERGE(LMERGE) 5952 INTEGER PSMALL, PLARGE, PMERGE, VSMALL, VLARGE, VMERGE 5953 PSMALL = 1 5954 PLARGE = 1 5955 PMERGE = 1 5956 DO WHILE ( PSMALL .LE. LSMALL .or. PLARGE.LE. LLARGE ) 5957 IF ( PSMALL .GT. LSMALL ) THEN 5958 VMERGE = LARGE( PLARGE ) 5959 PLARGE = PLARGE + 1 5960 ELSE IF ( PLARGE .GT. LLARGE ) THEN 5961 VMERGE = SMALL( PSMALL ) 5962 PSMALL = PSMALL + 1 5963 ELSE 5964 VSMALL = SMALL( PSMALL ) 5965 VLARGE = LARGE( PLARGE ) 5966 IF ( PERM( VSMALL ) .LT. PERM( VLARGE ) ) THEN 5967 VMERGE = VSMALL 5968 PSMALL = PSMALL + 1 5969 ELSE 5970 VMERGE = VLARGE 5971 PLARGE = PLARGE + 1 5972 END IF 5973 END IF 5974 MERGE( PMERGE ) = VMERGE 5975 ITLOC( VMERGE ) = PMERGE + NASS1 5976 PMERGE = PMERGE + 1 5977 END DO 5978 PMERGE = PMERGE - 1 5979 RETURN 5980 END SUBROUTINE MUMPS_309 5981 SUBROUTINE MUMPS_125( 5982 & NUMELT, LIST_ELT, 5983 & MYID, INODE, N, IOLDPS, 5984 & HF, NFRONT, NFRONT_EFF, PERM, 5985 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, 5986 & IFSON, STEP, PIMASTER, PTRAIW, NELT, 5987 & IW, LIW, 5988 & INTARR, LINTARR, ITLOC, RHS_MUMPS, 5989 & FILS, FRERE_STEPS, 5990 & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, 5991 & DAD, PROCNODE_STEPS, SLAVEF, 5992 & FRT_PTR, FRT_ELT, Pos_First_NUMORG) 5993 IMPLICIT NONE 5994 INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, 5995 & NUMSTK, NUMORG, IWPOSCB, IFSON, MYID, IFLAG, 5996 & LINTARR, NUMELT 5997 INTEGER KEEP(500) 5998 INTEGER LIST_ELT(*) 5999 INTEGER STEP(N), PIMASTER(KEEP(28)), 6000 & PTRAIW(NELT+1), IW(LIW), 6001 & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), 6002 & NBPROCFILS(KEEP(28)), PERM(N) 6003 COMPLEX :: RHS_MUMPS(KEEP(255)) 6004 INTEGER INTARR(LINTARR) 6005 LOGICAL, intent(in) :: NIV1 6006 LOGICAL, intent(out) :: SON_LEVEL2 6007 INTEGER, intent(out) :: NFRONT_EFF 6008 INTEGER, intent(in) :: DAD (KEEP(28)) 6009 INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF 6010 INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) 6011 INTEGER, intent(out) :: Pos_First_NUMORG 6012 INTEGER NEWEL, IOLDP2, INEW, INEW1, 6013 & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, 6014 & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, 6015 & NROWS, HS, IP1, IP2, K1, K2, IBROT, 6016 & I, K, ILOC, NEWEL_SAVE, NEWEL1_SAVE, 6017 & LAST_J_ASS, JMIN, MIN_PERM 6018 INTEGER TYPESPLIT, NUMELT_IBROT 6019 INTEGER ELTI 6020 INCLUDE 'mumps_headers.h' 6021 LOGICAL LEVEL1 6022 INTEGER allocok 6023 INTEGER , ALLOCATABLE, DIMENSION(:) :: PTTRI, PTLAST 6024 INTEGER MUMPS_810, MUMPS_330 6025 EXTERNAL MUMPS_810, MUMPS_330 6026 Pos_First_NUMORG = 1 6027 TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), 6028 & SLAVEF) 6029 SON_LEVEL2 = .FALSE. 6030 IOLDP2 = IOLDPS + HF - 1 6031 ICT11 = IOLDP2 + NFRONT 6032 NFRONT_EFF = NASS1 6033 NTOTFS = 0 6034 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN 6035 J2 = PIMASTER(STEP(IFSON)) 6036 LSTK = IW(J2 +KEEP(IXSZ)) 6037 NELIM = IW(J2 + 1+KEEP(IXSZ)) 6038 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 6039 IF (NPIVS.LT.0) NPIVS = 0 6040 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 6041 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 6042 LEVEL1 = NSLSON.EQ.0 6043 NCOLS = NPIVS + LSTK 6044 NROWS = NCOLS 6045 ITRANS = NROWS 6046 IF (NIV1) THEN 6047 write(6,*) MYID, ':', 6048 & ' Internal error 2 in MUMPS_86 ', 6049 & ' interior split node of type 1 ' 6050 CALL MUMPS_ABORT() 6051 ELSE 6052 I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) 6053 J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), 6054 & SLAVEF) 6055 IF (LEVEL1.or.J.LT.4) THEN 6056 write(6,*) MYID, ':', 6057 & ' Internal error 3 in MUMPS_86 ', 6058 & ' son', IFSON, 6059 & ' of interior split node', INODE, ' of type 1 ', 6060 & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J 6061 CALL MUMPS_ABORT() 6062 ELSE 6063 NBPROCFILS(STEP(IFSON)) = NSLSON 6064 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 6065 & NBPROCFILS(STEP(IFSON)) 6066 ENDIF 6067 ENDIF 6068 IF ( J2.GT. IWPOSCB ) THEN 6069 NROWS = IW(J2 + 2+KEEP(IXSZ)) 6070 ITRANS = NPIVS + NROWS 6071 ENDIF 6072 HS = NSLSON + 6 + KEEP(IXSZ) 6073 J1 = J2 + HS + NROWS + NPIVS 6074 J2 = J1 + LSTK - 1 6075 J3 = J1 + NELIM - 1 6076 IF (NELIM.GT.0) THEN 6077 DO JJ=J1,J3 6078 NTOTFS = NTOTFS + 1 6079 JT1 = IW(JJ) 6080 IW(ICT11 + NTOTFS) = JT1 6081 IW(JJ) = NTOTFS 6082 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 6083 ENDDO 6084 ENDIF 6085 DO JJ =J3+1, J2 6086 NTOTFS = NTOTFS + 1 6087 JT1 = IW(JJ) 6088 ITLOC(JT1) = NTOTFS 6089 IW(JJ) = NTOTFS 6090 IW(ICT11 + NTOTFS) = JT1 6091 IW(IOLDP2 + NTOTFS) = JT1 6092 ENDDO 6093 NFRONT_EFF = NTOTFS 6094 DO IELL=1,NUMELT 6095 ELTI = LIST_ELT(IELL) 6096 J1= PTRAIW(ELTI) 6097 J2= PTRAIW(ELTI+1)-1 6098 DO JJ=J1,J2 6099 J = INTARR(JJ) 6100 INTARR(JJ) = ITLOC(J) 6101 END DO 6102 ENDDO 6103 Pos_First_NUMORG = ITLOC(INODE) 6104 K1 = IOLDPS+HF 6105 DO JJ=K1+NELIM,K1+NFRONT_EFF-1 6106 ITLOC(IW(JJ)) = 0 6107 ENDDO 6108 RETURN 6109 ENDIF 6110 IF (NUMSTK.GT.0) THEN 6111 ALLOCATE(PTTRI(NUMSTK), stat=allocok) 6112 IF (allocok .GT. 0) THEN 6113 IFLAG = -13 6114 GOTO 800 6115 ENDIF 6116 ALLOCATE(PTLAST(NUMSTK), stat=allocok) 6117 IF (allocok .GT. 0) THEN 6118 IFLAG = -13 6119 GOTO 800 6120 ENDIF 6121 ENDIF 6122 IN = INODE 6123 INEW = IOLDPS + HF 6124 INEW1 = 1 6125 DO WHILE (IN.GT.0) 6126 ITLOC(IN) = INEW1 6127 IW(INEW) = IN 6128 IW(INEW+NFRONT) = IN 6129 INEW1 = INEW1 + 1 6130 INEW = INEW + 1 6131 IN = FILS(IN) 6132 END DO 6133 NTOTFS = NUMORG 6134 IF (NUMSTK .NE. 0) THEN 6135 ISON = IFSON 6136 DO IELL = 1, NUMSTK 6137 J2 = PIMASTER(STEP(ISON)) 6138 LSTK = IW(J2 +KEEP(IXSZ)) 6139 NELIM = IW(J2 + 1+KEEP(IXSZ)) 6140 NPIVS = IW(J2 + 3+KEEP(IXSZ)) 6141 IF (NPIVS.LT.0) NPIVS = 0 6142 NSLSON = IW(J2 + 5+KEEP(IXSZ)) 6143 IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. 6144 LEVEL1 = NSLSON.EQ.0 6145 NCOLS = NPIVS + LSTK 6146 NROWS = NCOLS 6147 ITRANS = NROWS 6148 IF (NIV1) THEN 6149 NBPROCFILS(STEP(ISON)) = NSLSON 6150 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON 6151 ELSE 6152 IF (LEVEL1) THEN 6153 NBPROCFILS(STEP(ISON)) = 1 6154 ELSE 6155 NBPROCFILS(STEP(ISON)) = NSLSON 6156 ENDIF 6157 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ 6158 & NBPROCFILS(STEP(ISON)) 6159 ENDIF 6160 IF (J2.GT.IWPOSCB) THEN 6161 NROWS = IW(J2 + 2+KEEP(IXSZ)) 6162 ITRANS = NPIVS + NROWS 6163 ENDIF 6164 HS = NSLSON + 6 + KEEP(IXSZ) 6165 J1 = J2 + HS + NROWS + NPIVS 6166 J2 = J1 + LSTK - 1 - KEEP(253) 6167 J3 = J1 + NELIM - 1 6168 IF (NELIM .NE. 0) THEN 6169 DO JJ = J1, J3 6170 NTOTFS = NTOTFS + 1 6171 JT1 = IW(JJ) 6172 IW(ICT11 + NTOTFS) = JT1 6173 ITLOC(JT1) = NTOTFS 6174 IW(JJ) = NTOTFS 6175 IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 6176 ENDDO 6177 ENDIF 6178 PTTRI(IELL) = J2+1 6179 PTLAST(IELL) = J2 6180 J1 = J3 + 1 6181 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN 6182 DO JJ = J1, J2 6183 J = IW(JJ) 6184 IF (ITLOC(J) .EQ. 0) THEN 6185 PTTRI(IELL) = JJ 6186 EXIT 6187 ENDIF 6188 ENDDO 6189 ELSE 6190 DO JJ = J1, J2 6191 IW(JJ) = ITLOC(IW(JJ)) 6192 ENDDO 6193 DO JJ=J2+1, J2+KEEP(253) 6194 IW(JJ)=NFRONT-KEEP(253)+JJ-J2 6195 ENDDO 6196 ENDIF 6197 ISON = FRERE_STEPS(STEP(ISON)) 6198 ENDDO 6199 ENDIF 6200 IF (NFRONT-KEEP(253).EQ.NASS1) GOTO 500 6201 MIN_PERM = N + 1 6202 JMIN = -1 6203 DO IELL = 1, NUMSTK 6204 ILOC = PTTRI( IELL ) 6205 IF ( ILOC .LE. PTLAST( IELL ) ) THEN 6206 IF ( PERM( IW( ILOC ) ) .LT. MIN_PERM ) THEN 6207 JMIN = IW( ILOC ) 6208 MIN_PERM = PERM( JMIN ) 6209 END IF 6210 END IF 6211 END DO 6212 NEWEL = IOLDP2 + NASS1 + NFRONT 6213 DO WHILE ( MIN_PERM .NE. N + 1 ) 6214 NEWEL = NEWEL + 1 6215 NFRONT_EFF = NFRONT_EFF + 1 6216 IW( NEWEL ) = JMIN 6217 ITLOC( JMIN ) = NFRONT_EFF 6218 LAST_J_ASS = JMIN 6219 MIN_PERM = N + 1 6220 DO IELL = 1, NUMSTK 6221 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN 6222 IF ( IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) 6223 & PTTRI( IELL ) = PTTRI( IELL ) + 1 6224 ENDIF 6225 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN 6226 IF ( PERM(IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN 6227 JMIN = IW( PTTRI( IELL ) ) 6228 MIN_PERM = PERM( JMIN ) 6229 END IF 6230 END IF 6231 END DO 6232 END DO 6233 NEWEL_SAVE = NEWEL 6234 NEWEL1_SAVE = NFRONT_EFF 6235 IF (NEWEL1_SAVE.LT.NFRONT-KEEP(253)) THEN 6236 DO IELL = 1,NUMELT 6237 ELTI = LIST_ELT(IELL) 6238 J1= PTRAIW(ELTI) 6239 J2= PTRAIW(ELTI+1)-1 6240 DO JJ=J1,J2 6241 J = INTARR( JJ ) 6242 IF ( ITLOC( J ) .eq. 0 ) THEN 6243 NEWEL = NEWEL + 1 6244 NFRONT_EFF = NFRONT_EFF + 1 6245 IW( NEWEL ) = J 6246 ITLOC( J ) = NFRONT_EFF 6247 END IF 6248 ENDDO 6249 ENDDO 6250 IF ( (TYPESPLIT.EQ.4).AND. 6251 & (NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN 6252 IBROT = INODE 6253 DO WHILE 6254 & ( 6255 & ( MUMPS_810 6256 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 6257 & .EQ.5 6258 & ) 6259 & .OR. 6260 & ( MUMPS_810 6261 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) 6262 & .EQ.6 6263 & ) 6264 & ) 6265 IBROT = DAD(STEP(IBROT)) 6266 NUMELT_IBROT = FRT_PTR(IBROT+1) - FRT_PTR(IBROT) 6267 IF (NUMELT_IBROT.EQ.0) CYCLE 6268 DO IELL = FRT_PTR(IBROT), FRT_PTR(IBROT+1) 6269 ELTI = FRT_ELT(IELL) 6270 J1= PTRAIW(ELTI) 6271 J2= PTRAIW(ELTI+1)-1 6272 DO JJ=J1,J2 6273 J = INTARR( JJ ) 6274 IF ( ITLOC( J ) .eq. 0 ) THEN 6275 NEWEL = NEWEL + 1 6276 NFRONT_EFF = NFRONT_EFF + 1 6277 IW( NEWEL ) = J 6278 ITLOC( J ) = NFRONT_EFF 6279 END IF 6280 ENDDO 6281 ENDDO 6282 IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT 6283 ENDDO 6284 ENDIF 6285 END IF 6286 IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN 6287 DO JJ=NASS1+1, NFRONT_EFF 6288 IW( IOLDP2+JJ ) = IW( ICT11+JJ ) 6289 ENDDO 6290 ELSE 6291 CALL MUMPS_308( N, PERM, 6292 & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) 6293 CALL MUMPS_309( N, NASS1, PERM, ITLOC, 6294 & IW( NEWEL_SAVE + 1), NFRONT_EFF - NEWEL1_SAVE, 6295 & IW( ICT11 + NASS1 + 1 ), NEWEL1_SAVE - NASS1, 6296 & IW( IOLDP2 + NASS1 + 1 ), NFRONT_EFF - NASS1 ) 6297 DO JJ = NASS1+1, NFRONT_EFF 6298 IW(ICT11 + JJ) = IW(IOLDP2+JJ) 6299 ENDDO 6300 END IF 6301 500 CONTINUE 6302 IF ( KEEP(253).GT.0) THEN 6303 IP1 = IOLDPS + HF + NFRONT_EFF 6304 IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF 6305 DO I= 1, KEEP(253) 6306 IW(IP1+I-1) = N+I 6307 IW(IP2+I-1) = N+I 6308 ITLOC(N+I) = NFRONT_EFF + I 6309 ENDDO 6310 NFRONT_EFF = NFRONT_EFF + KEEP(253) 6311 ENDIF 6312 IF (NFRONT.GT.NFRONT_EFF) THEN 6313 IP1 = IOLDPS + NFRONT + HF 6314 IP2 = IOLDPS + NFRONT_EFF + HF 6315 DO I=1,NFRONT_EFF 6316 IW(IP2+I)=IW(IP1+I) 6317 ENDDO 6318 ELSE IF (NFRONT .LT. NFRONT_EFF) THEN 6319 WRITE(*,*) "Internal error in MUMPS_125", 6320 & NFRONT, NFRONT_EFF 6321 CALL MUMPS_ABORT() 6322 ENDIF 6323 IF ((NUMSTK .NE. 0).AND. 6324 & (NFRONT-KEEP(253).GT.NASS1)) THEN 6325 ISON = IFSON 6326 DO IELL = 1, NUMSTK 6327 J2 = PIMASTER(STEP(ISON)) 6328 LSTK = IW(J2+KEEP(IXSZ)) 6329 NELIM = IW(J2 + 1 +KEEP(IXSZ)) 6330 NPIVS = IW(J2 + 3 +KEEP(IXSZ)) 6331 IF (NPIVS.LT.0) NPIVS = 0 6332 NSLSON = IW(J2 + 5 +KEEP(IXSZ)) 6333 NCOLS = NPIVS + LSTK 6334 NROWS = NCOLS 6335 IF (J2.GT.IWPOSCB) THEN 6336 NROWS = IW(J2 + 2+KEEP(IXSZ)) 6337 ENDIF 6338 HS = NSLSON + 6 +KEEP(IXSZ) 6339 J1 = J2 + HS + NROWS + NPIVS 6340 J2 = J1 + LSTK - 1 6341 J3 = J1 + NELIM - 1 6342 J1 = J3 + 1 6343 DO JJ = J1, J2 6344 J = IW(JJ) 6345 IW(JJ) = ITLOC(J) 6346 ENDDO 6347 ISON = FRERE_STEPS(STEP(ISON)) 6348 ENDDO 6349 ENDIF 6350 DO IELL=1,NUMELT 6351 ELTI = LIST_ELT(IELL) 6352 J1= PTRAIW(ELTI) 6353 J2= PTRAIW(ELTI+1)-1 6354 DO JJ=J1,J2 6355 J = INTARR(JJ) 6356 INTARR(JJ) = ITLOC(J) 6357 END DO 6358 ENDDO 6359 K1 = IOLDPS + HF + NUMORG 6360 K2 = K1 + NFRONT_EFF - 1 + NASS 6361 DO K = K1, K2 6362 I = IW(K) 6363 ITLOC(I) = 0 6364 ENDDO 6365 800 CONTINUE 6366 IF (allocated(PTTRI)) DEALLOCATE(PTTRI) 6367 IF (allocated(PTLAST)) DEALLOCATE(PTLAST) 6368 RETURN 6369 END SUBROUTINE MUMPS_125 6370 INTEGER FUNCTION MUMPS_50 6371 & ( SLAVEF, K48, K821, K50, 6372 & NFRONT, NCB) 6373 IMPLICIT NONE 6374 INTEGER, INTENT (IN) :: SLAVEF, K48, K50, NFRONT, NCB 6375 INTEGER(8), INTENT (IN) :: K821 6376 INTEGER NSLAVESMIN, NASS, KMAX 6377 REAL Wmaster, Wtotal, Wmax 6378 INTEGER ACC,X 6379 REAL MUMPS_45 6380 INTEGER MUMPS_497 6381 EXTERNAL MUMPS_45, MUMPS_497 6382 KMAX = MUMPS_497( K821, NCB ) 6383 NASS = NFRONT - NCB 6384 NSLAVESMIN = 1 6385 IF ( K48 .EQ.0 .OR. (K48.EQ.5 .AND.K50.EQ.0)) THEN 6386 NSLAVESMIN = max(NCB/max(1,KMAX),1) 6387 ELSE IF (K48 .EQ. 3 .OR.(K48.EQ.5 .AND.K50.NE.0) ) THEN 6388 Wmax = MUMPS_45(KMAX,NFRONT,NASS) 6389 Wtotal = MUMPS_45(NCB,NFRONT,NASS) 6390 Wmaster = real(NASS*NASS)*real(NASS)/(3.0) 6391 IF ( Wmaster .GT. Wmax ) THEN 6392 NSLAVESMIN = max ( nint ( Wtotal / Wmaster ), 1 ) 6393 ELSE 6394 NSLAVESMIN = max ( nint ( Wtotal / Wmax ), 1 ) 6395 ENDIF 6396 IF (K48 .EQ. 5) THEN 6397 NSLAVESMIN = max ( NSLAVESMIN/2, 1 ) 6398 END IF 6399 ELSE IF (K48 .EQ. 4 ) THEN 6400 IF ( K821 > 0_8 ) THEN 6401 WRITE(*,*) 'Internal Error 1 in MUMPS_50' 6402 CALL MUMPS_ABORT() 6403 ENDIF 6404 CALL MUMPS_ABORT_ON_OVERFLOW(K821, 6405 & "K821 too large in MUMPS_50" ) 6406 KMAX=int(abs(K821)) 6407 IF(K50.EQ.0)THEN 6408 NSLAVESMIN = max(int( 6409 & (int(NCB,8)*int(NCB,8))/int(KMAX,8) 6410 & ),1) 6411 ELSE 6412 ACC=0 6413 NSLAVESMIN=0 6414 DO WHILE (ACC.NE.NCB) 6415 X=int((-real(NFRONT-NCB+ACC) 6416 & +sqrt(((real(NFRONT-NCB+ACC)* 6417 & real(NFRONT-NCB+ACC))+real(4)* 6418 & real(KMAX))))/ 6419 & real(2)) 6420 ACC=ACC+X 6421 NSLAVESMIN=NSLAVESMIN+1 6422 IF (((NCB-ACC)*NCB).LT.KMAX)THEN 6423 ACC=NCB 6424 NSLAVESMIN=NSLAVESMIN+1 6425 ENDIF 6426 ENDDO 6427 ENDIF 6428 ENDIF 6429 NSLAVESMIN = min ( NSLAVESMIN,(SLAVEF-1) ) 6430 MUMPS_50 = 6431 & min ( NSLAVESMIN, NCB ) 6432 RETURN 6433 END FUNCTION MUMPS_50 6434 INTEGER FUNCTION MUMPS_52 6435 & ( SLAVEF, K48, K821, K50, 6436 & NFRONT, NCB) 6437 IMPLICIT NONE 6438 INTEGER, INTENT (IN) :: SLAVEF, K48, K50,NFRONT, NCB 6439 INTEGER(8), INTENT(IN) :: K821 6440 INTEGER NSLAVESMAX, KMAX, KMIN 6441 INTEGER NSLAVESMIN 6442 INTEGER MUMPS_497,MUMPS_442, 6443 & MUMPS_50, 6444 & MUMPS_46 6445 EXTERNAL MUMPS_497,MUMPS_442, 6446 & MUMPS_50, 6447 & MUMPS_46 6448 IF (K48 .eq. 0 .OR. K48.eq.3.OR.K48.EQ.5) THEN 6449 KMAX = MUMPS_497( K821, NCB ) 6450 KMIN = MUMPS_442( K821, K50, KMAX, NCB) 6451 NSLAVESMAX = MUMPS_46( 6452 & SLAVEF, K48, K50, KMIN, NFRONT, NCB ) 6453 ELSE 6454 NSLAVESMAX = SLAVEF-1 6455 ENDIF 6456 NSLAVESMIN = MUMPS_50( 6457 & SLAVEF, K48, K821, K50, NFRONT, NCB ) 6458 NSLAVESMAX = max ( NSLAVESMAX, NSLAVESMIN ) 6459 MUMPS_52 = 6460 & min ( NSLAVESMAX, NCB ) 6461 RETURN 6462 END FUNCTION MUMPS_52 6463 SUBROUTINE MUMPS_503( WHAT, KEEP,KEEP8, 6464 & NCB, NFR, SLAVEF, NBROWMAX, MAXSURFCB8 6465 & ) 6466 IMPLICIT NONE 6467 INTEGER, intent(in) :: WHAT, NCB, NFR, SLAVEF 6468 INTEGER, intent(in) :: KEEP(500) 6469 INTEGER(8) KEEP8(150) 6470 INTEGER, intent(out) :: NBROWMAX 6471 INTEGER(8), intent(out) :: MAXSURFCB8 6472 INTEGER KMAX, KMIN, NSLAVES, SIZEDUMMY, TABDUMMY(1) 6473 EXTERNAL MUMPS_497, MUMPS_442, 6474 & MUMPS_50 6475 INTEGER MUMPS_497, MUMPS_442, 6476 & MUMPS_50 6477 IF ( WHAT .NE. 1 .and. WHAT .NE. 2 ) THEN 6478 IF (WHAT .NE. 4 .and. WHAT .NE. 5 .AND. 6479 & KEEP(48).NE.5 ) THEN 6480 WRITE(*,*) "Internal error 1 in MUMPS_503" 6481 CALL MUMPS_ABORT() 6482 END IF 6483 ENDIF 6484 KMAX = MUMPS_497( KEEP8(21), NCB ) 6485 IF (WHAT .EQ.1.OR.WHAT.EQ.2) THEN 6486 NSLAVES = MUMPS_50( SLAVEF, KEEP(48), 6487 & KEEP8(21), KEEP(50), 6488 & NFR, NCB ) 6489 ELSE 6490 NSLAVES=SLAVEF 6491 ENDIF 6492 IF ( KEEP(48) == 0 .OR. (KEEP(48).EQ.5.AND.KEEP(50).EQ.0)) THEN 6493 NBROWMAX = NCB / NSLAVES + mod( NCB, NSLAVES ) 6494 IF ( WHAT == 2 .OR. WHAT == 5 ) 6495 & MAXSURFCB8 = int(NBROWMAX,8) * int(NCB,8) 6496 ELSE IF (KEEP(48) == 3.OR.(KEEP(48).EQ.5.AND.KEEP(50).NE.0))THEN 6497 KMIN = MUMPS_442( KEEP8(21), KEEP(50), KMAX, NCB ) 6498 SIZEDUMMY = 1 6499 IF (WHAT.GT.3) THEN 6500 CALL MUMPS_440( 6501 & WHAT-3, NSLAVES, NFR, NCB, 6502 & KMIN, KMAX, SLAVEF, 6503 & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) 6504 ELSE 6505 CALL MUMPS_440( 6506 & WHAT, NSLAVES, NFR, NCB, 6507 & KMIN, KMAX, SLAVEF, 6508 & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) 6509 ENDIF 6510 ELSE IF ( KEEP(48) == 4 ) THEN 6511 IF (KEEP8(21) > 0_8) THEN 6512 WRITE(*,*) "Internal error 2 in MUMPS_503" 6513 CALL MUMPS_ABORT() 6514 END IF 6515 IF(KEEP(50).EQ.0)THEN 6516 IF ( abs(KEEP8(21)) * int( SLAVEF - 1,8 ) > 6517 & int( NCB,8) * int(NFR,8) ) THEN 6518 NBROWMAX = (NCB + SLAVEF -2 ) / ( SLAVEF - 1 ) 6519 IF ( WHAT == 2 ) MAXSURFCB8 = int(NBROWMAX,8) *int(NCB,8) 6520 ELSE 6521 NBROWMAX=int( 6522 & (abs(KEEP8(21)) + int(NFR - 1,8)) 6523 & / int(NFR,8) 6524 & ) 6525 IF ( WHAT == 2 ) MAXSURFCB8 = abs(KEEP8(21)) 6526 ENDIF 6527 ELSE 6528 NBROWMAX=int((-real(NFR-NCB) 6529 & +sqrt((real(NFR-NCB)* 6530 & real(NFR-NCB))+real(4)* 6531 & real(abs(KEEP8(21)))))/ 6532 & real(2)) 6533 IF ( WHAT == 2 ) MAXSURFCB8 = abs(KEEP8(21)) 6534 ENDIF 6535 ELSE 6536 NBROWMAX = NCB 6537 IF (WHAT == 2) MAXSURFCB8 = int(NCB,8) * int(NCB,8) 6538 ENDIF 6539 NBROWMAX = min ( max(NBROWMAX, 1), NCB) 6540 RETURN 6541 END SUBROUTINE MUMPS_503 6542 INTEGER FUNCTION MUMPS_46( SLAVEF, K48, K50, 6543 & BLSIZE, NFRONT, NCB) 6544 IMPLICIT NONE 6545 INTEGER, INTENT (IN) :: SLAVEF, K48, K50, BLSIZE, NFRONT, NCB 6546 INTEGER NSLAVES, NASS 6547 REAL Wtotal, Wblsize 6548 REAL MUMPS_45 6549 EXTERNAL MUMPS_45 6550 NASS = NFRONT - NCB 6551 NSLAVES = SLAVEF-1 6552 IF ( K48 .EQ.0 .OR. (K48.EQ.5 .AND. K50.EQ.0)) THEN 6553 NSLAVES = max(NCB/max(1,BLSIZE),1) 6554 ELSE IF (K48.EQ.3 .OR. (K48.EQ.5 .AND. K50.NE.0))THEN 6555 Wblsize = MUMPS_45(BLSIZE,NFRONT,NASS) 6556 Wtotal = MUMPS_45(NCB,NFRONT,NASS) 6557 NSLAVES = max(nint ( Wtotal / Wblsize ), 1) 6558 ENDIF 6559 MUMPS_46 = 6560 & min ( NSLAVES,(SLAVEF-1) ) 6561 RETURN 6562 END FUNCTION MUMPS_46 6563 SUBROUTINE MUMPS_440( 6564 & GETPOSITIONS, NSLAVES, NFRONT, NCB, 6565 & KMIN, KMAX, SLAVEF, 6566 & NBROWMAX, MAXSURFCB, TABPOS, SIZETABPOS) 6567 IMPLICIT NONE 6568 INTEGER, INTENT (IN) :: GETPOSITIONS, 6569 & NSLAVES, NFRONT, NCB, 6570 & KMIN, KMAX, SLAVEF, SIZETABPOS 6571 INTEGER, INTENT (OUT) :: NBROWMAX 6572 INTEGER(8), INTENT(OUT) :: MAXSURFCB 6573 INTEGER, INTENT (OUT) :: TABPOS(SIZETABPOS) 6574 REAL W, COSTni 6575 REAL delta 6576 INTEGER SumNi, NCOLim1, I, BLSIZE, NASS 6577 LOGICAL GETROW, GETSURF, GETPOS, GET_AVGROW, GET_AVGSURF 6578 REAL MUMPS_45 6579 EXTERNAL MUMPS_45 6580 GETROW = (GETPOSITIONS.EQ.1) 6581 GETSURF= (GETPOSITIONS.EQ.2) 6582 GETPOS = (GETPOSITIONS.EQ.3) 6583 GET_AVGROW = (GETPOSITIONS.EQ.4) 6584 GET_AVGSURF = (GETPOSITIONS.EQ.5) 6585 NBROWMAX = 0 6586 MAXSURFCB = 0_8 6587 IF (GETPOS) THEN 6588 TABPOS (1) = 1 6589 TABPOS (NSLAVES+1)= NCB+1 6590 TABPOS (SLAVEF+2) = NSLAVES 6591 ENDIF 6592 IF (NSLAVES.EQ.1) THEN 6593 IF ( GETSURF ) THEN 6594 NBROWMAX = NCB 6595 MAXSURFCB = int(NCB,8)*int(NCB,8) 6596 ELSEIF ( GETROW ) THEN 6597 NBROWMAX = NCB 6598 ENDIF 6599 ELSE 6600 NASS = NFRONT - NCB 6601 W = MUMPS_45(NCB,NFRONT,NASS) 6602 SumNi = 0 6603 NCOLim1 = NASS 6604 DO I = 1, NSLAVES-1 6605 delta = real(2*NCOLim1-NASS+1)**2 + 6606 & (real(4)*W)/real(NASS*(NSLAVES-I+1)) 6607 delta = sqrt(delta) 6608 delta = (real(-2*NCOLim1+NASS-1) + delta )/real(2) 6609 BLSIZE = max(int(delta), 1) 6610 IF ( (NFRONT-NCOLim1-BLSIZE) .LE. NSLAVES-I ) THEN 6611 BLSIZE = 1 6612 ENDIF 6613 NCOLim1 = NCOLim1+BLSIZE 6614 COSTni = MUMPS_45(BLSIZE,NCOLim1,NASS) 6615 W = W - COSTni 6616 IF (GETPOS) TABPOS(I) = SumNi + 1 6617 IF (GETSURF) THEN 6618 NBROWMAX = max ( NBROWMAX, 6619 & BLSIZE ) 6620 MAXSURFCB = max ( MAXSURFCB, 6621 & int(BLSIZE,8)* int(SumNi+BLSIZE,8) ) 6622 ELSEIF ( GETROW ) THEN 6623 NBROWMAX = max ( NBROWMAX, 6624 & BLSIZE ) 6625 RETURN 6626 ELSEIF (GET_AVGSURF) THEN 6627 NBROWMAX = NBROWMAX + BLSIZE 6628 MAXSURFCB = MAXSURFCB + int(BLSIZE,8)*int(SumNi+BLSIZE,8) 6629 ELSEIF (GET_AVGROW) THEN 6630 NBROWMAX = NBROWMAX + BLSIZE 6631 ENDIF 6632 SumNi = SumNi + BLSIZE 6633 ENDDO 6634 BLSIZE = NCB - SumNi 6635 IF (BLSIZE.LE.0) THEN 6636 write(*,*) ' Error in MUMPS_440: ', 6637 & ' size lastbloc ', BLSIZE 6638 CALL MUMPS_ABORT() 6639 ENDIF 6640 if (NCOLim1+BLSIZE.NE.NFRONT) then 6641 write(*,*) ' Error in MUMPS_440: ', 6642 & ' NCOLim1, BLSIZE, NFRONT=', 6643 & NCOLim1, BLSIZE, NFRONT 6644 CALL MUMPS_ABORT() 6645 endif 6646 IF (GETPOS) TABPOS(NSLAVES) = SumNi + 1 6647 IF (GETSURF) THEN 6648 NBROWMAX = max ( NBROWMAX, 6649 & BLSIZE ) 6650 MAXSURFCB = max ( MAXSURFCB, 6651 & int(BLSIZE,8)* int(SumNi+BLSIZE,8 )) 6652 ELSEIF ( GETROW ) THEN 6653 NBROWMAX = max ( NBROWMAX, 6654 & BLSIZE ) 6655 ELSEIF (GET_AVGSURF) THEN 6656 NBROWMAX = NBROWMAX + BLSIZE 6657 MAXSURFCB = MAXSURFCB + int(BLSIZE,8)*int(SumNi+BLSIZE,8) 6658 NBROWMAX=(NBROWMAX+NSLAVES-1)/NSLAVES 6659 MAXSURFCB=(MAXSURFCB+int(NSLAVES-1,8))/int(NSLAVES,8) 6660 ELSEIF (GET_AVGROW) THEN 6661 NBROWMAX = NBROWMAX + BLSIZE 6662 NBROWMAX=(NBROWMAX+NSLAVES-1)/NSLAVES 6663 ENDIF 6664 ENDIF 6665 RETURN 6666 END SUBROUTINE MUMPS_440 6667 SUBROUTINE MUMPS_441( 6668 & KEEP,KEEP8, SLAVEF, 6669 & TAB_POS_IN_PERE, 6670 & NSLAVES, NFRONT, NCB 6671 & ) 6672 IMPLICIT NONE 6673 INTEGER, INTENT( IN ) :: NCB, NSLAVES, SLAVEF, NFRONT, 6674 & KEEP(500) 6675 INTEGER(8) KEEP8(150) 6676 INTEGER TAB_POS_IN_PERE(SLAVEF+2) 6677 INTEGER :: I, BLSIZE 6678 INTEGER KMIN, KMAX, NBROWDUMMY, 6679 & GETPOSITIONS, SIZECOLTAB 6680 INTEGER(8) MAXSURFDUMMY8 6681 INTEGER MUMPS_442, MUMPS_497 6682 EXTERNAL MUMPS_442, MUMPS_497, 6683 & MUMPS_440 6684 IF (KEEP(48).EQ.0) THEN 6685 BLSIZE = NCB / NSLAVES 6686 TAB_POS_IN_PERE( 1 ) = 1 6687 DO I = 1, NSLAVES-1 6688 TAB_POS_IN_PERE( I+1 ) = TAB_POS_IN_PERE(I) + 6689 & BLSIZE 6690 ENDDO 6691 TAB_POS_IN_PERE(NSLAVES+1) = NCB+1 6692 TAB_POS_IN_PERE(SLAVEF+2) = NSLAVES 6693 RETURN 6694 ELSE IF (KEEP(48).EQ.3 ) THEN 6695 KMAX = MUMPS_497(KEEP8(21), NCB) 6696 KMIN = MUMPS_442(KEEP8(21), KEEP(50), KMAX, NCB) 6697 GETPOSITIONS = 3 6698 SIZECOLTAB = SLAVEF+2 6699 CALL MUMPS_440( 6700 & GETPOSITIONS, NSLAVES, NFRONT, NCB, 6701 & KMIN, KMAX, SLAVEF, 6702 & NBROWDUMMY, MAXSURFDUMMY8, 6703 & TAB_POS_IN_PERE(1), SIZECOLTAB) 6704 ENDIF 6705 RETURN 6706 END SUBROUTINE MUMPS_441 6707 SUBROUTINE MUMPS_49( 6708 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 6709 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 6710 & 6711 & ISLAVE, NCB, NSLAVES, SIZE, FIRST_INDEX ) 6712 IMPLICIT NONE 6713 INTEGER, INTENT( IN ) :: ISLAVE, NCB, NSLAVES, SLAVEF, 6714 & KEEP(500), INODE, N 6715 INTEGER(8) KEEP8(150) 6716 INTEGER, INTENT( IN ) :: STEP(N), 6717 & ISTEP_TO_INIV2(KEEP(71)), 6718 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 6719 INTEGER, INTENT( OUT ):: SIZE, FIRST_INDEX 6720 INTEGER BLSIZE, J 6721 IF (KEEP(48).EQ.0) THEN 6722 BLSIZE = NCB / NSLAVES 6723 IF ( ISLAVE .NE. NSLAVES ) THEN 6724 SIZE = BLSIZE 6725 ELSE 6726 SIZE = BLSIZE + mod( NCB, NSLAVES ) 6727 END IF 6728 FIRST_INDEX = ( ISLAVE - 1 ) * BLSIZE + 1 6729 ELSEIF (KEEP(48).EQ.3) THEN 6730 J = ISTEP_TO_INIV2 ( STEP(INODE) ) 6731 FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) 6732 SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX 6733 ELSEIF (KEEP(48).EQ.4) THEN 6734 J = ISTEP_TO_INIV2 ( STEP(INODE) ) 6735 FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) 6736 SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX 6737 ELSEIF (KEEP(48).EQ.5) THEN 6738 J = ISTEP_TO_INIV2 ( STEP(INODE) ) 6739 FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) 6740 SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX 6741 ELSE 6742 WRITE(*,*) 'Error in MUMPS_BLOC2 undef strat' 6743 CALL MUMPS_ABORT() 6744 ENDIF 6745 RETURN 6746 END SUBROUTINE MUMPS_49 6747 REAL FUNCTION MUMPS_45(NROW,NCOL,NASS) 6748 IMPLICIT NONE 6749 INTEGER, INTENT (IN) :: NROW,NCOL,NASS 6750 MUMPS_45 = real(NASS*NROW)* 6751 & real(2*NCOL - NASS - NROW + 1) 6752 RETURN 6753 END FUNCTION MUMPS_45 6754 INTEGER FUNCTION MUMPS_12 6755 & (K821, K48, K50, SLAVEF, 6756 & NCB, NFRONT, NSLAVES_less, NMB_OF_CAND ) 6757 IMPLICIT NONE 6758 INTEGER, INTENT( IN ) :: NCB, NFRONT, NSLAVES_less, 6759 & K48, K50, SLAVEF, NMB_OF_CAND 6760 INTEGER(8), INTENT(IN) :: K821 6761 INTEGER NSLAVES 6762 INTEGER KMAX, NPIV, 6763 & NSLAVES_ref, NSLAVES_max 6764 REAL WK_MASTER, WK_SLAVE 6765 INTEGER MUMPS_497, MUMPS_50, 6766 & MUMPS_52 6767 REAL MUMPS_45 6768 EXTERNAL MUMPS_497, MUMPS_50, 6769 & MUMPS_52 6770 EXTERNAL MUMPS_45 6771 IF (NMB_OF_CAND.LE.0) THEN 6772 ENDIF 6773 IF ( (K48.EQ.0).OR. (K48.EQ.3) ) THEN 6774 KMAX = MUMPS_497( K821, NCB ) 6775 NSLAVES_ref = MUMPS_50( 6776 & SLAVEF, K48, K821, K50, NFRONT, NCB ) 6777 NSLAVES = NSLAVES_ref 6778 IF ( NSLAVES_ref.LT.SLAVEF ) THEN 6779 NSLAVES_max = MUMPS_52( 6780 & SLAVEF, K48, K821, K50, NFRONT, NCB ) 6781 IF ( NSLAVES_max .LT. NSLAVES_less ) THEN 6782 NSLAVES = NSLAVES_max 6783 ELSE 6784 NSLAVES = NSLAVES_less 6785 ENDIF 6786 NSLAVES = max(NSLAVES_ref,NSLAVES) 6787 ENDIF 6788 NSLAVES = min (NSLAVES, NMB_OF_CAND) 6789 IF ( NSLAVES.GT.NSLAVES_ref) THEN 6790 NPIV = NFRONT - NCB 6791 IF ( K50.EQ.0 ) THEN 6792 WK_SLAVE = real( NPIV ) * real( NCB ) * 6793 & ( 2.0E0 * real(NFRONT) - real(NPIV) ) 6794 & / real(NSLAVES) 6795 WK_MASTER = 0.66667E0 * 6796 & real(NPIV)*real(NPIV)*real(NPIV)+ 6797 & real(NPIV)*real(NPIV)*real(NCB) 6798 ELSE 6799 WK_SLAVE = MUMPS_45(NCB,NFRONT,NPIV) 6800 & / real(NSLAVES) 6801 WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV)/3.0E0 6802 ENDIF 6803 IF ( (WK_MASTER.GT.WK_SLAVE).AND. 6804 & (WK_SLAVE.GT.1.0E0) ) THEN 6805 NSLAVES = 6806 & int( real(NSLAVES) * (WK_SLAVE/WK_MASTER)) 6807 NSLAVES = max(NSLAVES_ref, NSLAVES) 6808 ENDIF 6809 ENDIF 6810 ELSE 6811 NSLAVES = NSLAVES_less 6812 ENDIF 6813 NSLAVES = min (NSLAVES, NCB) 6814 NSLAVES = min (NSLAVES, NMB_OF_CAND) 6815 MUMPS_12 = NSLAVES 6816 RETURN 6817 END FUNCTION MUMPS_12 6818 SUBROUTINE MUMPS_47( 6819 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 6820 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 6821 & 6822 & NASS, NCB, 6823 & NSLAVES, POSITION, ISLAVE, IPOSSLAVE ) 6824 IMPLICIT NONE 6825 INTEGER, INTENT( IN ) :: KEEP(500),INODE,N,SLAVEF 6826 INTEGER(8) KEEP8(150) 6827 INTEGER, INTENT( IN ) :: STEP(N), 6828 & ISTEP_TO_INIV2(KEEP(71)), 6829 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 6830 INTEGER, INTENT( IN ) :: NASS, NCB, 6831 & NSLAVES, POSITION 6832 INTEGER, INTENT( OUT ) :: ISLAVE, IPOSSLAVE 6833 INTEGER BLSIZE, J, ISHIFT 6834 IF ((NSLAVES.LE.0).OR.(POSITION.LE.NASS)) THEN 6835 ISLAVE = 0 6836 IPOSSLAVE = POSITION 6837 RETURN 6838 ENDIF 6839 IF ( KEEP(48).EQ.0) THEN 6840 BLSIZE = NCB / NSLAVES 6841 ISLAVE = min( NSLAVES, 6842 & ( POSITION - NASS - 1 ) / BLSIZE + 1 ) 6843 IPOSSLAVE = POSITION - NASS - ( ISLAVE - 1 ) * BLSIZE 6844 ELSEIF (KEEP(48).EQ.3) THEN 6845 J = ISTEP_TO_INIV2 ( STEP(INODE) ) 6846 ISHIFT = POSITION - NASS 6847 DO ISLAVE = NSLAVES,1,-1 6848 IF ( ISHIFT .GE. TAB_POS_IN_PERE(ISLAVE,J)) THEN 6849 IPOSSLAVE = ISHIFT - TAB_POS_IN_PERE(ISLAVE,J) + 1 6850 EXIT 6851 END IF 6852 END DO 6853 ELSEIF (KEEP(48).EQ.4) THEN 6854 J = ISTEP_TO_INIV2 ( STEP(INODE) ) 6855 ISHIFT = POSITION - NASS 6856 DO ISLAVE = NSLAVES,1,-1 6857 IF ( ISHIFT .GE. TAB_POS_IN_PERE(ISLAVE,J)) THEN 6858 IPOSSLAVE = ISHIFT - TAB_POS_IN_PERE(ISLAVE,J) + 1 6859 EXIT 6860 END IF 6861 END DO 6862 ELSEIF (KEEP(48).EQ.5) THEN 6863 J = ISTEP_TO_INIV2 ( STEP(INODE) ) 6864 ISHIFT = POSITION - NASS 6865 DO ISLAVE = NSLAVES,1,-1 6866 IF ( ISHIFT .GE. TAB_POS_IN_PERE(ISLAVE,J)) THEN 6867 IPOSSLAVE = ISHIFT - TAB_POS_IN_PERE(ISLAVE,J) + 1 6868 EXIT 6869 END IF 6870 END DO 6871 ELSE 6872 WRITE(*,*) 'Error in MUMPS_47: undef strat' 6873 CALL MUMPS_ABORT() 6874 ENDIF 6875 RETURN 6876 END SUBROUTINE MUMPS_47 6877 INTEGER FUNCTION MUMPS_442( K821, K50, KMAX, NCB ) 6878 IMPLICIT NONE 6879 INTEGER, INTENT( IN ) :: KMAX, NCB, K50 6880 INTEGER(8), INTENT(IN) :: K821 6881 INTEGER KMIN, MINGRAN 6882 INTEGER(8) :: KMINSURF 6883 IF ( ( NCB .LE.0 ).OR. (KMAX.LE.0) ) THEN 6884 MUMPS_442 = 1 6885 RETURN 6886 ENDIF 6887 IF (K50.EQ.0) THEN 6888 KMINSURF = 60000_8 6889#if defined(t3e) || defined(sgi) 6890 MINGRAN = 40 6891#else 6892 MINGRAN = 50 6893#endif 6894 ELSE 6895 KMINSURF = 30000_8 6896#if defined(t3e) || defined(sgi) 6897 MINGRAN = 10 6898#else 6899 MINGRAN = 20 6900#endif 6901 ENDIF 6902 IF (K821.GT.0_8) THEN 6903#if defined(t3e) || defined(sgi) 6904 KMIN = max(MINGRAN,KMAX/10) 6905#else 6906 KMIN = max(MINGRAN,KMAX/20) 6907#endif 6908 ELSE 6909 KMINSURF = max( abs(K821)/500_8, KMINSURF ) 6910 KMIN = max( 6911 & int( KMINSURF / int(max(NCB,1),8) ), 6912 & 1 6913 & ) 6914 ENDIF 6915 KMIN = min(KMIN,KMAX) 6916 KMIN = max(KMIN,1) 6917 MUMPS_442 = KMIN 6918 RETURN 6919 END FUNCTION MUMPS_442 6920 INTEGER FUNCTION MUMPS_497( KEEP821, NCB ) 6921 IMPLICIT NONE 6922 INTEGER, intent( in ) :: NCB 6923 INTEGER(8), intent( in ) :: KEEP821 6924 INTEGER KMAX 6925 IF ( NCB .LE.0 ) THEN 6926 MUMPS_497 = 1 6927 RETURN 6928 ENDIF 6929 IF ( KEEP821.GT.0_8 ) THEN 6930 KMAX = int(KEEP821) 6931 ELSE 6932 KMAX = -int(KEEP821/int(NCB,8)) 6933 ENDIF 6934 KMAX = min (NCB, KMAX) 6935 MUMPS_497 = max ( KMAX, 1 ) 6936 RETURN 6937 END FUNCTION MUMPS_497 6938 SUBROUTINE MUMPS_546( IS, DS ) 6939 INTEGER IS, DS 6940#if defined(t3e) 6941 IS = 8 6942 DS = 16 6943#else 6944 IS = 4 6945 DS = 8 6946#endif 6947 END SUBROUTINE MUMPS_546 6948 SUBROUTINE MUMPS_SET_VERSION( VERSION_STR ) 6949 IMPLICIT NONE 6950 CHARACTER(LEN=*) :: VERSION_STR 6951 CHARACTER(LEN=*) :: V; 6952 PARAMETER (V = "4.10.0" ) 6953 IF ( len(V) .GT. 14 ) THEN 6954 WRITE(*,*) "Version string too long ( >14 characters )" 6955 CALL MUMPS_ABORT() 6956 END IF 6957 VERSION_STR = V 6958 RETURN 6959 END SUBROUTINE MUMPS_SET_VERSION 6960 SUBROUTINE MUMPS_420 6961 & ( JOB, THRESH, NDENSE, 6962 & N, IWLEN, PE, PFREE, LEN, IW, NV, 6963 & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, 6964 & PERM, COMPLEM_LIST, SIZE_COMPLEM_LIST, AGG6 ) 6965 IMPLICIT NONE 6966 INTEGER JOB 6967 INTEGER N, IWLEN, PE(N), PFREE, LEN(N), IW(IWLEN), NV(N), 6968 & ELEN(N), LAST(N), NCMPA, DEGREE(N), HEAD(N), NEXT(N), 6969 & W(N) 6970 LOGICAL AGG6 6971 INTEGER, intent(in) :: SIZE_COMPLEM_LIST 6972 INTEGER NDENSE(N) 6973 INTEGER, intent (in) :: COMPLEM_LIST(max(1,SIZE_COMPLEM_LIST)) 6974 INTEGER PERM(N) 6975 INTEGER THRESH 6976 INTEGER THRESM, NDME, PERMeqN 6977 INTEGER NBD,NBED, NBDM, LASTD, NELME 6978 LOGICAL IDENSE 6979 INTEGER FDEG, ThresMin, ThresPrev, IBEGSchur, 6980 & ThresMinINIT 6981 LOGICAL SchurON 6982 INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, 6983 & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, 6984 & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, 6985 & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X 6986 INTEGER MAXINT_N 6987 INTEGER(8) HASH, HMOD 6988 INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC 6989 INTRINSIC max, min, mod 6990 IF (N.EQ.1) THEN 6991 ELEN(1) = 1 6992 LAST(1) = 1 6993 PE(1) = 0 6994 NV(1) = 1 6995 RETURN 6996 ENDIF 6997 IF ( SIZE_COMPLEM_LIST < 0 .OR. SIZE_COMPLEM_LIST > N ) THEN 6998 WRITE(*,*) "Internal MUMPS_420", SIZE_COMPLEM_LIST,N 6999 CALL MUMPS_ABORT() 7000 ENDIF 7001 IF (JOB.EQ.2) THEN 7002 SchurON = .FALSE. 7003 ENDIF 7004 IF (JOB.NE.2) THEN 7005 SchurON = (SIZE_COMPLEM_LIST > 0) 7006 IF ((JOB.EQ.1) .AND. (.NOT.SchurON) .AND. (N .GT. 0)) THEN 7007 WRITE(6,*) ' WARNING MUMPS_420 on Options ' 7008 ENDIF 7009 IBEGSchur = N-SIZE_COMPLEM_LIST+1 7010 IF (THRESH.GT.N) THRESH = N 7011 IF (THRESH.LT.0) THRESH = 0 7012 IF ( SchurON ) THEN 7013 DO I= 1, N 7014 IF ( PERM(I) .GE. IBEGSchur) THEN 7015 PERM(I) = N + 1 7016 IF (LEN(I) .EQ.0) THEN 7017 PE(I) = 0 7018 ENDIF 7019 ENDIF 7020 ENDDO 7021 ENDIF 7022 ENDIF 7023 IF (SchurON) THEN 7024 THRESM = N 7025 ThresMin = N 7026 ThresPrev = N 7027 ELSE 7028 THRESM = max(int(31*N/32),THRESH) 7029 THRESM = max(THRESM,1) 7030 ThresMin = max( 3*THRESM / 4, 1) 7031 ThresPrev = THRESM 7032 ENDIF 7033 ThresMinINIT = ThresMin/4 7034 IF (THRESM.GT.0) THEN 7035 IF ((THRESM.GT.N).OR.(THRESM.LT.2)) THEN 7036 THRESM = N 7037 ENDIF 7038 ENDIF 7039 IF (JOB.EQ.2) THEN 7040 ENDIF 7041 PERMeqN = 0 7042 LASTD = 0 7043 NBD = 0 7044 NBED = 0 7045 NBDM = 0 7046 NEL = 0 7047 WFLG = 2 7048 MAXINT_N=huge(WFLG)-N 7049 MINDEG = 1 7050 NCMPA = 0 7051 HMOD = int(max (1, N-1),kind=8) 7052 DMAX = 0 7053 MEM = PFREE - 1 7054 MAXMEM = MEM 7055 DO 10 I = 1, N 7056 NDENSE(I)= 0 7057 LAST (I) = 0 7058 HEAD (I) = 0 7059 NV (I) = 1 7060 W (I) = 1 7061 10 CONTINUE 7062 IF (JOB.EQ.2) THEN 7063 DO I = 1,SIZE_COMPLEM_LIST 7064 X = COMPLEM_LIST(I) 7065 ELEN(X) = -I 7066 NV(X) = LEN(X)+1 7067 DMAX = max(DMAX, LEN(X)) 7068 ENDDO 7069 NEL = NEL + SIZE_COMPLEM_LIST 7070 DO I=1,N 7071 DEGREE (I) = LEN (I) 7072 ENDDO 7073 ELSE 7074 DO I=1, N 7075 ELEN (I) = 0 7076 DEGREE (I) = LEN (I) 7077 ENDDO 7078 ENDIF 7079 DO 20 I = 1, N 7080 IF (ELEN(I).LT.0) CYCLE 7081 DEG = DEGREE (I) 7082 IF (PERM(I).EQ.N) THEN 7083 PERMeqN = I 7084 PERM(I) = N-1 7085 ENDIF 7086 FDEG = PERM(I) 7087 IF ( (DEG .GT. 0).OR.(PERM(I).EQ.N+1) ) THEN 7088 IF ( (THRESM.GT.0) .AND. 7089 & (FDEG .GT.THRESM) ) THEN 7090 NBD = NBD+1 7091 IF (FDEG.NE.N+1) THEN 7092 DEGREE(I) = DEGREE(I)+N+2 7093 DEG = N 7094 INEXT = HEAD (DEG) 7095 IF (INEXT .NE. 0) LAST (INEXT) = I 7096 NEXT (I) = INEXT 7097 HEAD (DEG) = I 7098 LAST(I) = 0 7099 IF (LASTD.EQ.0) LASTD=I 7100 ELSE 7101 NBED = NBED+1 7102 DEGREE(I) = N+1 7103 DEG = N 7104 IF (LASTD.EQ.0) THEN 7105 LASTD = I 7106 HEAD(DEG) = I 7107 NEXT(I) = 0 7108 LAST(I) = 0 7109 ELSE 7110 NEXT(LASTD) = I 7111 LAST(I) = LASTD 7112 LASTD = I 7113 NEXT(I) = 0 7114 ENDIF 7115 ENDIF 7116 ELSE 7117 INEXT = HEAD (FDEG) 7118 IF (INEXT .NE. 0) LAST (INEXT) = I 7119 NEXT (I) = INEXT 7120 HEAD (FDEG) = I 7121 ENDIF 7122 ELSE 7123 NEL = NEL + 1 7124 ELEN (I) = -NEL 7125 PE (I) = 0 7126 W (I) = 0 7127 ENDIF 7128 20 CONTINUE 7129 IF ((NBD.EQ.0).AND.(THRESM.GT.0)) THRESM = N 7130 30 IF (NEL .LT. N) THEN 7131 DO 40 DEG = MINDEG, N 7132 ME = HEAD (DEG) 7133 IF (ME .GT. 0) GO TO 50 7134 40 CONTINUE 7135 50 MINDEG = DEG 7136 IF ( (DEG.NE.N) .AND. 7137 & (DEG.GT.THRESM+1) .AND. (NBD.GT.0) ) THEN 7138 MINDEG = N 7139 GOTO 30 7140 ENDIF 7141 IF (DEGREE(ME).LE.N) THEN 7142 INEXT = NEXT (ME) 7143 IF (INEXT .NE. 0) LAST (INEXT) = 0 7144 HEAD (DEG) = INEXT 7145 ELSE 7146 MINDEG = 1 7147 NBDM = max(NBDM,NBD) 7148 IF (DEGREE(ME).GT.N+1) THEN 7149 IF (WFLG .GT. MAXINT_N) THEN 7150 DO 52 X = 1, N 7151 IF (W (X) .NE. 0) W (X) = 1 7152 52 CONTINUE 7153 WFLG = 2 7154 ENDIF 7155 WFLG = WFLG + 1 7156 51 CONTINUE 7157 INEXT = NEXT (ME) 7158 IF (INEXT .NE. 0) THEN 7159 LAST (INEXT) = 0 7160 ELSE 7161 LASTD = 0 7162 ENDIF 7163 NDENSE(ME) = 0 7164 W(ME) = WFLG 7165 P1 = PE(ME) 7166 P2 = P1 + LEN(ME) -1 7167 LN = P1 7168 ELN = P1 7169 DO 55 P=P1,P2 7170 E= IW(P) 7171 IF (W(E).EQ.WFLG) GOTO 55 7172 W(E) = WFLG 7173 IF (PE(E).LT.0) THEN 7174 X = E 7175 53 X = -PE(X) 7176 IF (W(X) .EQ.WFLG) GOTO 55 7177 W(X) = WFLG 7178 IF ( PE(X) .LT. 0 ) GOTO 53 7179 E = X 7180 ENDIF 7181 IF (ELEN(E).LT.0) THEN 7182 NDENSE(E) = NDENSE(E) - NV(ME) 7183 IW(LN) = IW(ELN) 7184 IW(ELN) = E 7185 LN = LN+1 7186 ELN = ELN + 1 7187 PME1 = PE(E) 7188 DO 54 PME = PME1, PME1+LEN(E)-1 7189 X = IW(PME) 7190 IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN 7191 NDENSE(ME) = NDENSE(ME) + NV(X) 7192 W(X) = WFLG 7193 ENDIF 7194 54 CONTINUE 7195 ELSE 7196 NDENSE(ME) = NDENSE(ME) + NV(E) 7197 IW(LN)=E 7198 LN = LN+1 7199 ENDIF 7200 55 CONTINUE 7201 WFLG = WFLG + 1 7202 LEN(ME) = LN-P1 7203 ELEN(ME) = ELN- P1 7204 NDME = NDENSE(ME)+NV(ME) 7205 IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 7206 DEGREE(ME) = NDENSE(ME) 7207 DEG = PERM(ME) 7208 MINDEG = min(DEG,MINDEG) 7209 JNEXT = HEAD(DEG) 7210 IF (JNEXT.NE. 0) LAST (JNEXT) = ME 7211 NEXT(ME) = JNEXT 7212 HEAD(DEG) = ME 7213 ME = INEXT 7214 IF (ME.NE.0) THEN 7215 IF (DEGREE(ME).GT.(N+1) ) GOTO 51 7216 ENDIF 7217 HEAD (N) = ME 7218 IF (THRESM.LT.N) THEN 7219 ThresMin = max(THRESM+ThresMin,ThresPrev+ThresMin/2+1) 7220 ThresMin = min(ThresMin, N) 7221 ThresPrev = ThresPrev+(N-ThresPrev)/2+ThresMinINIT 7222 THRESM = max( 7223 & THRESM + int(sqrt(dble(ThresMin)))+ ThresMinINIT , 7224 & ThresPrev) 7225 THRESM = min(THRESM,N) 7226 ThresMin = min(THRESM, ThresMin) 7227 ThresPrev = THRESM 7228 ENDIF 7229 NBD = NBED 7230 GOTO 30 7231 ENDIF 7232 IF (DEGREE(ME).EQ.N+1) THEN 7233 IF (NBD.NE.NBED) THEN 7234 write(6,*) ' ERROR in MUMPS_420 ', 7235 & ' quasi dense rows remains' 7236 CALL MUMPS_ABORT() 7237 ENDIF 7238 IF (JOB.EQ.1) THEN 7239 DO I = 1,SIZE_COMPLEM_LIST 7240 X = COMPLEM_LIST(I) 7241 ELEN(X) = -(N-SIZE_COMPLEM_LIST+I) 7242 NV(X) = 1 7243 PE(X) = 0 7244 ENDDO 7245 GOTO 265 7246 ENDIF 7247 NELME = -(NEL+1) 7248 DO 59 X=1,N 7249 IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN 7250 PE(X) = -COMPLEM_LIST(1) 7251 ELSEIF (DEGREE(X).EQ.N+1) THEN 7252 NEL = NEL + NV(X) 7253 PE(X) = -ME 7254 ELEN(X) = 0 7255 NV(X) = 0 7256 ENDIF 7257 59 CONTINUE 7258 ELEN(ME) = NELME 7259 NV(ME) = NBD 7260 PE(ME) = 0 7261 IF (NEL.NE.N) THEN 7262 write(6,*) 'Internal ERROR 2 detected in QAMD' 7263 write(6,*) ' NEL not equal to N: N, NEL =',N,NEL 7264 CALL MUMPS_ABORT() 7265 ENDIF 7266 IF (ME.NE. COMPLEM_LIST(1)) THEN 7267 DO I=1, SIZE_COMPLEM_LIST 7268 PE(COMPLEM_LIST(I)) = -COMPLEM_LIST(1) 7269 ENDDO 7270 PE(COMPLEM_LIST(1)) = 0 7271 NV( COMPLEM_LIST(1))= NV(ME) 7272 NV(ME) = 0 7273 ELEN( COMPLEM_LIST(1)) = ELEN(ME) 7274 ELEN(ME) = 0 7275 ENDIF 7276 GOTO 265 7277 ENDIF 7278 ENDIF 7279 ELENME = ELEN (ME) 7280 ELEN (ME) = - (NEL + 1) 7281 NVPIV = NV (ME) 7282 NEL = NEL + NVPIV 7283 NDENSE(ME) = 0 7284 NV (ME) = -NVPIV 7285 DEGME = 0 7286 IF (ELENME .EQ. 0) THEN 7287 PME1 = PE (ME) 7288 PME2 = PME1 - 1 7289 DO 60 P = PME1, PME1 + LEN (ME) - 1 7290 I = IW (P) 7291 NVI = NV (I) 7292 IF (NVI .GT. 0) THEN 7293 DEGME = DEGME + NVI 7294 NV (I) = -NVI 7295 PME2 = PME2 + 1 7296 IW (PME2) = I 7297 IF (DEGREE(I).LE.N) THEN 7298 ILAST = LAST (I) 7299 INEXT = NEXT (I) 7300 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 7301 IF (ILAST .NE. 0) THEN 7302 NEXT (ILAST) = INEXT 7303 ELSE 7304 HEAD (PERM(I)) = INEXT 7305 ENDIF 7306 ELSE 7307 NDENSE(ME) = NDENSE(ME) + NVI 7308 ENDIF 7309 ENDIF 7310 60 CONTINUE 7311 NEWMEM = 0 7312 ELSE 7313 P = PE (ME) 7314 PME1 = PFREE 7315 SLENME = LEN (ME) - ELENME 7316 DO 120 KNT1 = 1, ELENME + 1 7317 IF (KNT1 .GT. ELENME) THEN 7318 E = ME 7319 PJ = P 7320 LN = SLENME 7321 ELSE 7322 E = IW (P) 7323 P = P + 1 7324 PJ = PE (E) 7325 LN = LEN (E) 7326 ENDIF 7327 DO 110 KNT2 = 1, LN 7328 I = IW (PJ) 7329 PJ = PJ + 1 7330 NVI = NV (I) 7331 IF (NVI .GT. 0) THEN 7332 IF (PFREE .GT. IWLEN) THEN 7333 PE (ME) = P 7334 LEN (ME) = LEN (ME) - KNT1 7335 IF (LEN (ME) .EQ. 0) PE (ME) = 0 7336 PE (E) = PJ 7337 LEN (E) = LN - KNT2 7338 IF (LEN (E) .EQ. 0) PE (E) = 0 7339 NCMPA = NCMPA + 1 7340 DO 70 J = 1, N 7341 PN = PE (J) 7342 IF (PN .GT. 0) THEN 7343 PE (J) = IW (PN) 7344 IW (PN) = -J 7345 ENDIF 7346 70 CONTINUE 7347 PDST = 1 7348 PSRC = 1 7349 PEND = PME1 - 1 7350 80 CONTINUE 7351 IF (PSRC .LE. PEND) THEN 7352 J = -IW (PSRC) 7353 PSRC = PSRC + 1 7354 IF (J .GT. 0) THEN 7355 IW (PDST) = PE (J) 7356 PE (J) = PDST 7357 PDST = PDST + 1 7358 LENJ = LEN (J) 7359 DO 90 KNT3 = 0, LENJ - 2 7360 IW (PDST + KNT3) = IW (PSRC + KNT3) 7361 90 CONTINUE 7362 PDST = PDST + LENJ - 1 7363 PSRC = PSRC + LENJ - 1 7364 ENDIF 7365 GO TO 80 7366 ENDIF 7367 P1 = PDST 7368 DO 100 PSRC = PME1, PFREE - 1 7369 IW (PDST) = IW (PSRC) 7370 PDST = PDST + 1 7371 100 CONTINUE 7372 PME1 = P1 7373 PFREE = PDST 7374 PJ = PE (E) 7375 P = PE (ME) 7376 ENDIF 7377 DEGME = DEGME + NVI 7378 NV (I) = -NVI 7379 IW (PFREE) = I 7380 PFREE = PFREE + 1 7381 IF (DEGREE(I).LE.N) THEN 7382 ILAST = LAST (I) 7383 INEXT = NEXT (I) 7384 IF (INEXT .NE. 0) LAST (INEXT) = ILAST 7385 IF (ILAST .NE. 0) THEN 7386 NEXT (ILAST) = INEXT 7387 ELSE 7388 HEAD (PERM(I)) = INEXT 7389 ENDIF 7390 ELSE 7391 NDENSE(ME) = NDENSE(ME) + NVI 7392 ENDIF 7393 ENDIF 7394 110 CONTINUE 7395 IF (E .NE. ME) THEN 7396 PE (E) = -ME 7397 W (E) = 0 7398 ENDIF 7399 120 CONTINUE 7400 PME2 = PFREE - 1 7401 NEWMEM = PFREE - PME1 7402 MEM = MEM + NEWMEM 7403 MAXMEM = max (MAXMEM, MEM) 7404 ENDIF 7405 DEGREE (ME) = DEGME 7406 PE (ME) = PME1 7407 LEN (ME) = PME2 - PME1 + 1 7408 IF (WFLG .GT. MAXINT_N) THEN 7409 DO 130 X = 1, N 7410 IF (W (X) .NE. 0) W (X) = 1 7411 130 CONTINUE 7412 WFLG = 2 7413 ENDIF 7414 DO 150 PME = PME1, PME2 7415 I = IW (PME) 7416 IF (DEGREE(I).GT.N) GOTO 150 7417 ELN = ELEN (I) 7418 IF (ELN .GT. 0) THEN 7419 NVI = -NV (I) 7420 WNVI = WFLG - NVI 7421 DO 140 P = PE (I), PE (I) + ELN - 1 7422 E = IW (P) 7423 WE = W (E) 7424 IF (WE .GE. WFLG) THEN 7425 WE = WE - NVI 7426 ELSE IF (WE .NE. 0) THEN 7427 WE = DEGREE (E) + WNVI - NDENSE(E) 7428 ENDIF 7429 W (E) = WE 7430 140 CONTINUE 7431 ENDIF 7432 150 CONTINUE 7433 DO 180 PME = PME1, PME2 7434 I = IW (PME) 7435 IF (DEGREE(I).GT.N) GOTO 180 7436 P1 = PE (I) 7437 P2 = P1 + ELEN (I) - 1 7438 PN = P1 7439 HASH = 0_8 7440 DEG = 0 7441 DO 160 P = P1, P2 7442 E = IW (P) 7443 DEXT = W (E) - WFLG 7444 IF (DEXT .GT. 0) THEN 7445 DEG = DEG + DEXT 7446 IW (PN) = E 7447 PN = PN + 1 7448 HASH = HASH + int(E,kind=8) 7449 ELSE IF (.NOT. AGG6 .AND. DEXT .EQ. 0) THEN 7450 IW (PN) = E 7451 PN = PN + 1 7452 HASH = HASH + int(E,kind=8) 7453 ELSE IF (AGG6 .AND. (DEXT .EQ. 0) .AND. 7454 & ((NDENSE(ME).EQ.NBD).OR.(NDENSE(E).EQ.0))) THEN 7455 PE (E) = -ME 7456 W (E) = 0 7457 ELSE IF (AGG6 .AND. DEXT.EQ.0) THEN 7458 IW(PN) = E 7459 PN = PN+1 7460 HASH = HASH + int(E,kind=8) 7461 ENDIF 7462 160 CONTINUE 7463 ELEN (I) = PN - P1 + 1 7464 P3 = PN 7465 DO 170 P = P2 + 1, P1 + LEN (I) - 1 7466 J = IW (P) 7467 NVJ = NV (J) 7468 IF (NVJ .GT. 0) THEN 7469 IF (DEGREE(J).LE.N) DEG=DEG+NVJ 7470 IW (PN) = J 7471 PN = PN + 1 7472 HASH = HASH + int(J,kind=8) 7473 ENDIF 7474 170 CONTINUE 7475 IF (((ELEN(I).EQ.1).AND.(P3.EQ.PN)) 7476 & .OR. 7477 & (AGG6.AND.(DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) 7478 & ) 7479 & THEN 7480 PE (I) = -ME 7481 NVI = -NV (I) 7482 DEGME = DEGME - NVI 7483 NVPIV = NVPIV + NVI 7484 NEL = NEL + NVI 7485 NV (I) = 0 7486 ELEN (I) = 0 7487 ELSE 7488 DEGREE(I) = min (DEG+NBD-NDENSE(ME), 7489 & DEGREE(I)) 7490 IW (PN) = IW (P3) 7491 IW (P3) = IW (P1) 7492 IW (P1) = ME 7493 LEN (I) = PN - P1 + 1 7494 HASH = mod (HASH, HMOD) + 1_8 7495 J = HEAD (HASH) 7496 IF (J .LE. 0) THEN 7497 NEXT (I) = -J 7498 HEAD (HASH) = -I 7499 ELSE 7500 NEXT (I) = LAST (J) 7501 LAST (J) = I 7502 ENDIF 7503 LAST (I) = int(HASH,kind=kind(LAST)) 7504 ENDIF 7505 180 CONTINUE 7506 DEGREE (ME) = DEGME 7507 DMAX = max (DMAX, DEGME) 7508 WFLG = WFLG + DMAX 7509 IF (WFLG .GT. MAXINT_N) THEN 7510 DO 190 X = 1, N 7511 IF (W (X) .NE. 0) W (X) = 1 7512 190 CONTINUE 7513 WFLG = 2 7514 ENDIF 7515 DO 250 PME = PME1, PME2 7516 I = IW (PME) 7517 IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.N) ) THEN 7518 HASH = int(LAST (I),kind=8) 7519 J = HEAD (HASH) 7520 IF (J .EQ. 0) GO TO 250 7521 IF (J .LT. 0) THEN 7522 I = -J 7523 HEAD (HASH) = 0 7524 ELSE 7525 I = LAST (J) 7526 LAST (J) = 0 7527 ENDIF 7528 IF (I .EQ. 0) GO TO 250 7529 200 CONTINUE 7530 IF (NEXT (I) .NE. 0) THEN 7531 X = I 7532 LN = LEN (I) 7533 ELN = ELEN (I) 7534 DO 210 P = PE (I) + 1, PE (I) + LN - 1 7535 W (IW (P)) = WFLG 7536 210 CONTINUE 7537 JLAST = I 7538 J = NEXT (I) 7539 220 CONTINUE 7540 IF (J .NE. 0) THEN 7541 IF (LEN (J) .NE. LN) GO TO 240 7542 IF (ELEN (J) .NE. ELN) GO TO 240 7543 DO 230 P = PE (J) + 1, PE (J) + LN - 1 7544 IF (W (IW (P)) .NE. WFLG) GO TO 240 7545 230 CONTINUE 7546 IF (PERM(J).GT.PERM(X)) THEN 7547 PE (J) = -X 7548 NV (X) = NV (X) + NV (J) 7549 NV (J) = 0 7550 ELEN (J) = 0 7551 ELSE 7552 PE (X) = -J 7553 NV (J) = NV (X) + NV (J) 7554 NV (X) = 0 7555 ELEN (X) = 0 7556 X = J 7557 ENDIF 7558 J = NEXT (J) 7559 NEXT (JLAST) = J 7560 GO TO 220 7561 240 CONTINUE 7562 JLAST = J 7563 J = NEXT (J) 7564 GO TO 220 7565 ENDIF 7566 WFLG = WFLG + 1 7567 I = NEXT (I) 7568 IF (I .NE. 0) GO TO 200 7569 ENDIF 7570 ENDIF 7571 250 CONTINUE 7572 IF ( (THRESM .GT. 0).AND.(THRESM.LT.N) ) THEN 7573 THRESM = max(ThresMin, THRESM-NVPIV) 7574 ENDIF 7575 P = PME1 7576 NLEFT = N - NEL 7577 DO 260 PME = PME1, PME2 7578 I = IW (PME) 7579 NVI = -NV (I) 7580 IF (NVI .GT. 0) THEN 7581 NV (I) = NVI 7582 IF (DEGREE(I).LE.N) THEN 7583 DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) 7584 DEGREE (I) = DEG 7585 IDENSE = .FALSE. 7586 IF (THRESM.GT.0) THEN 7587 IF (PERM(I) .GT. THRESM) THEN 7588 IDENSE = .TRUE. 7589 DEGREE(I) = DEGREE(I)+N+2 7590 ENDIF 7591 IF (IDENSE) THEN 7592 P1 = PE(I) 7593 P2 = P1 + ELEN(I) - 1 7594 IF (P2.GE.P1) THEN 7595 DO 264 PJ=P1,P2 7596 E= IW(PJ) 7597 NDENSE (E) = NDENSE(E) + NVI 7598 264 CONTINUE 7599 ENDIF 7600 NBD = NBD+NVI 7601 FDEG = N 7602 DEG = N 7603 INEXT = HEAD(DEG) 7604 IF (INEXT .NE. 0) LAST (INEXT) = I 7605 NEXT (I) = INEXT 7606 HEAD (DEG) = I 7607 LAST(I) = 0 7608 IF (LASTD.EQ.0) LASTD=I 7609 ENDIF 7610 ENDIF 7611 IF (.NOT.IDENSE) THEN 7612 FDEG = PERM(I) 7613 INEXT = HEAD (FDEG) 7614 IF (INEXT .NE. 0) LAST (INEXT) = I 7615 NEXT (I) = INEXT 7616 LAST (I) = 0 7617 HEAD (FDEG) = I 7618 ENDIF 7619 MINDEG = min (MINDEG, FDEG) 7620 ENDIF 7621 IW (P) = I 7622 P = P + 1 7623 ENDIF 7624 260 CONTINUE 7625 NV (ME) = NVPIV + DEGME 7626 LEN (ME) = P - PME1 7627 IF (LEN (ME) .EQ. 0) THEN 7628 PE (ME) = 0 7629 W (ME) = 0 7630 ENDIF 7631 IF (NEWMEM .NE. 0) THEN 7632 PFREE = P 7633 MEM = MEM - NEWMEM + LEN (ME) 7634 ENDIF 7635 GO TO 30 7636 ENDIF 7637 265 CONTINUE 7638 DO 290 I = 1, N 7639 IF (ELEN (I) .EQ. 0) THEN 7640 J = -PE (I) 7641 270 CONTINUE 7642 IF (ELEN (J) .GE. 0) THEN 7643 J = -PE (J) 7644 GO TO 270 7645 ENDIF 7646 E = J 7647 K = -ELEN (E) 7648 J = I 7649 280 CONTINUE 7650 IF (ELEN (J) .GE. 0) THEN 7651 JNEXT = -PE (J) 7652 PE (J) = -E 7653 IF (ELEN (J) .EQ. 0) THEN 7654 ELEN (J) = K 7655 K = K + 1 7656 ENDIF 7657 J = JNEXT 7658 GO TO 280 7659 ENDIF 7660 ELEN (E) = -K 7661 ENDIF 7662 290 CONTINUE 7663 DO 300 I = 1, N 7664 K = abs (ELEN (I)) 7665 LAST (K) = I 7666 ELEN (I) = K 7667 300 CONTINUE 7668 IF (.NOT.SchurON) THEN 7669 IF (PERMeqN.GT.0) PERM(PERMeqN) = N 7670 ENDIF 7671 PFREE = MAXMEM 7672 RETURN 7673 END SUBROUTINE MUMPS_420 7674 SUBROUTINE MUMPS_209( N, FRERE, FILS, NFSIZ, THEROOT ) 7675 IMPLICIT NONE 7676 INTEGER, intent( in ) :: N 7677 INTEGER, intent( in ) :: NFSIZ( N ) 7678 INTEGER, intent( inout ) :: FRERE( N ), FILS( N ) 7679 INTEGER, intent( out ) :: THEROOT 7680 INTEGER INODE, IROOT, IFILS, IN, IROOTLAST, SIZE 7681 IROOT = -9999 7682 SIZE = 0 7683 DO INODE = 1, N 7684 IF ( FRERE( INODE ) .EQ. 0 ) THEN 7685 IF ( NFSIZ( INODE ) .GT. SIZE ) THEN 7686 SIZE = NFSIZ( INODE ) 7687 IROOT = INODE 7688 END IF 7689 ENDIF 7690 END DO 7691 IN = IROOT 7692 DO WHILE ( FILS( IN ) .GT. 0 ) 7693 IN = FILS( IN ) 7694 END DO 7695 IROOTLAST = IN 7696 IFILS = - FILS ( IN ) 7697 DO INODE = 1, N 7698 IF ( FRERE( INODE ) .eq. 0 .and. INODE .ne. IROOT ) THEN 7699 IF ( IFILS .eq. 0 ) THEN 7700 FILS( IROOTLAST ) = - INODE 7701 FRERE( INODE ) = -IROOT 7702 IFILS = INODE 7703 ELSE 7704 FRERE( INODE ) = -FILS( IROOTLAST ) 7705 FILS( IROOTLAST ) = - INODE 7706 END IF 7707 END IF 7708 END DO 7709 THEROOT = IROOT 7710 RETURN 7711 END SUBROUTINE MUMPS_209 7712 INTEGER FUNCTION MUMPS_330(PROCINFO_INODE, SLAVEF) 7713 IMPLICIT NONE 7714 INTEGER SLAVEF 7715 INTEGER PROCINFO_INODE, TPN 7716 IF (PROCINFO_INODE <= SLAVEF ) THEN 7717 MUMPS_330 = 1 7718 ELSE 7719 TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 7720 IF ( TPN .LT. 1 ) TPN = 1 7721 IF (TPN.EQ.4.OR.TPN.EQ.5.OR.TPN.EQ.6) TPN = 2 7722 MUMPS_330 = TPN 7723 END IF 7724 RETURN 7725 END FUNCTION MUMPS_330 7726 INTEGER FUNCTION MUMPS_275(PROCINFO_INODE, SLAVEF) 7727 IMPLICIT NONE 7728 INTEGER SLAVEF 7729 INTEGER PROCINFO_INODE 7730 IF (SLAVEF == 1) THEN 7731 MUMPS_275 = 0 7732 ELSE 7733 MUMPS_275=mod(2*SLAVEF+PROCINFO_INODE-1,SLAVEF) 7734 END IF 7735 RETURN 7736 END FUNCTION MUMPS_275 7737 INTEGER FUNCTION MUMPS_810 (PROCINFO_INODE, SLAVEF) 7738 IMPLICIT NONE 7739 INTEGER, intent(in) :: SLAVEF 7740 INTEGER PROCINFO_INODE, TPN 7741 IF (PROCINFO_INODE <= SLAVEF ) THEN 7742 MUMPS_810 = 1 7743 ELSE 7744 TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 7745 IF ( TPN .LT. 1 ) TPN = 1 7746 MUMPS_810 = TPN 7747 ENDIF 7748 RETURN 7749 END FUNCTION MUMPS_810 7750 LOGICAL FUNCTION MUMPS_283( PROCINFO_INODE, SLAVEF ) 7751 IMPLICIT NONE 7752 INTEGER SLAVEF 7753 INTEGER TPN, PROCINFO_INODE 7754 TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 7755 MUMPS_283 = ( TPN .eq. 0 ) 7756 RETURN 7757 END FUNCTION MUMPS_283 7758 LOGICAL FUNCTION MUMPS_167( PROCINFO_INODE, SLAVEF ) 7759 IMPLICIT NONE 7760 INTEGER SLAVEF 7761 INTEGER TPN, PROCINFO_INODE 7762 TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 7763 MUMPS_167 = ( TPN .eq. -1 ) 7764 RETURN 7765 END FUNCTION MUMPS_167 7766 LOGICAL FUNCTION MUMPS_170 7767 & ( PROCINFO_INODE, SLAVEF ) 7768 IMPLICIT NONE 7769 INTEGER SLAVEF 7770 INTEGER TPN, PROCINFO_INODE 7771 TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 7772 MUMPS_170 = 7773 & ( TPN .eq. -1 .OR. TPN .eq. 0 ) 7774 RETURN 7775 END FUNCTION MUMPS_170 7776 LOGICAL FUNCTION MUMPS_358( MYID, SLAVEF, INODE, 7777 & NMB_PAR2, ISTEP_TO_INIV2 , K71, STEP, N, 7778 & CANDIDATES, KEEP24 ) 7779 IMPLICIT NONE 7780 INTEGER MYID, SLAVEF, INODE, NMB_PAR2, KEEP24, I 7781 INTEGER K71, N 7782 INTEGER ISTEP_TO_INIV2 ( K71 ), STEP ( N ) 7783 INTEGER CANDIDATES(SLAVEF+1, max(NMB_PAR2,1)) 7784 INTEGER NCAND, POSINODE 7785 MUMPS_358 = .FALSE. 7786 IF (KEEP24 .eq. 0) RETURN 7787 POSINODE = ISTEP_TO_INIV2 ( STEP (INODE) ) 7788 NCAND = CANDIDATES( SLAVEF+1, POSINODE ) 7789 DO I = 1, NCAND 7790 IF (MYID .EQ. CANDIDATES( I, POSINODE )) 7791 & MUMPS_358 = .TRUE. 7792 END DO 7793 RETURN 7794 END FUNCTION MUMPS_358 7795 SUBROUTINE MUMPS_291(T) 7796 DOUBLE PRECISION T 7797 DOUBLE PRECISION MPI_WTIME 7798 EXTERNAL MPI_WTIME 7799 T=MPI_WTIME() 7800 RETURN 7801 END SUBROUTINE MUMPS_291 7802 SUBROUTINE MUMPS_292(T) 7803 DOUBLE PRECISION T 7804 DOUBLE PRECISION MPI_WTIME 7805 EXTERNAL MPI_WTIME 7806 T=MPI_WTIME()-T 7807 RETURN 7808 END SUBROUTINE MUMPS_292 7809 SUBROUTINE MUMPS_558( N, VAL, ID ) 7810 INTEGER N 7811 INTEGER ID( N ) 7812 DOUBLE PRECISION VAL( N ) 7813 INTEGER I, ISWAP 7814 DOUBLE PRECISION SWAP 7815 LOGICAL DONE 7816 DONE = .FALSE. 7817 DO WHILE ( .NOT. DONE ) 7818 DONE = .TRUE. 7819 DO I = 1, N - 1 7820 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN 7821 DONE = .FALSE. 7822 ISWAP = ID( I ) 7823 ID ( I ) = ID ( I + 1 ) 7824 ID ( I + 1 ) = ISWAP 7825 SWAP = VAL( I ) 7826 VAL( I ) = VAL( I + 1 ) 7827 VAL( I + 1 ) = SWAP 7828 END IF 7829 END DO 7830 END DO 7831 RETURN 7832 END SUBROUTINE MUMPS_558 7833#if defined (PESSL) 7834 SUBROUTINE DESCINIT( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, 7835 & LLD, INFO ) 7836 INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB 7837 INTEGER DESC( * ) 7838 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, 7839 & LLD_, MB_, M_, NB_, N_, RSRC_ 7840# if defined(DESC8) 7841 PARAMETER ( DLEN_ = 8, DTYPE_ = 1, 7842 & CTXT_ = 7, M_ = 1, N_ = 2, MB_ = 3, NB_ = 4, 7843 & RSRC_ = 5, CSRC_ = 6, LLD_ = 8 ) 7844# else 7845 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, 7846 & CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, 7847 & RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) 7848# endif 7849 INTEGER MYCOL, MYROW, NPCOL, NPROW 7850 EXTERNAL blacs_gridinfo, PXERBLA 7851 INTEGER NUMROC 7852 EXTERNAL NUMROC 7853 INTRINSIC max, min 7854 CALL blacs_gridinfo( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 7855 INFO = 0 7856 IF( M.LT.0 ) THEN 7857 INFO = -2 7858 ELSE IF( N.LT.0 ) THEN 7859 INFO = -3 7860 ELSE IF( MB.LT.1 ) THEN 7861 INFO = -4 7862 ELSE IF( NB.LT.1 ) THEN 7863 INFO = -5 7864 ELSE IF( IRSRC.LT.0 .OR. IRSRC.GE.NPROW ) THEN 7865 INFO = -6 7866 ELSE IF( ICSRC.LT.0 .OR. ICSRC.GE.NPCOL ) THEN 7867 INFO = -7 7868 ELSE IF( NPROW.EQ.-1 ) THEN 7869 INFO = -8 7870 ELSE IF( LLD.LT.max( 1, numroc( M, MB, MYROW, IRSRC, 7871 & NPROW ) ) ) THEN 7872 INFO = -9 7873 END IF 7874 IF( INFO.NE.0 ) 7875 & CALL PXERBLA( ICTXT, 'DESCINIT', -INFO ) 7876# ifndef DESC8 7877 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D 7878# endif 7879 DESC( M_ ) = max( 0, M ) 7880 DESC( N_ ) = max( 0, N ) 7881 DESC( MB_ ) = max( 1, MB ) 7882 DESC( NB_ ) = max( 1, NB ) 7883 DESC( RSRC_ ) = max( 0, min( IRSRC, NPROW-1 ) ) 7884 DESC( CSRC_ ) = max( 0, min( ICSRC, NPCOL-1 ) ) 7885 DESC( CTXT_ ) = ICTXT 7886 DESC( LLD_ ) = max( LLD, max( 1, numroc( DESC( M_ ), DESC( MB_ ), 7887 & MYROW, DESC( RSRC_ ), NPROW ) ) ) 7888 RETURN 7889 END SUBROUTINE DESCINIT 7890 SUBROUTINE PXERBLA( ICTXT, SRNAME, INFO ) 7891 INTEGER ICTXT, INFO 7892 CHARACTER*(*) SRNAME 7893 INTEGER MYCOL, MYROW, NPCOL, NPROW 7894 EXTERNAL blacs_gridinfo 7895 CALL blacs_gridinfo( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 7896 WRITE( *, FMT = 9999 ) MYROW, MYCOL, SRNAME, INFO 7897 9999 FORMAT( '{', I5, ',', I5, '}: On entry to ', A, 7898 & ' parameter number', I4, ' had an illegal value' ) 7899 END SUBROUTINE PXERBLA 7900#endif 7901 SUBROUTINE MUMPS_243(MYID, COMM, INFO, INFOG, IRANK) 7902 IMPLICIT NONE 7903 INTEGER MYID, COMM, IRANK, INFO, INFOG(2) 7904 INCLUDE 'mpif.h' 7905 INTEGER IERR_MPI, MASTER 7906 INTEGER TEMP1(2), TEMP2(2) 7907 PARAMETER( MASTER = 0 ) 7908 CALL MPI_REDUCE( INFO, INFOG(1), 1, MPI_INTEGER, 7909 & MPI_MAX, MASTER, COMM, IERR_MPI ) 7910 CALL MPI_REDUCE( INFO, INFOG(2), 1, MPI_INTEGER, 7911 & MPI_SUM, MASTER, COMM, IERR_MPI ) 7912 TEMP1(1) = INFO 7913 TEMP1(2) = MYID 7914 CALL MPI_REDUCE( TEMP1, TEMP2, 1, MPI_2INTEGER, 7915 & MPI_MAXLOC, MASTER, COMM, IERR_MPI ) 7916 IF ( MYID.eq. MASTER ) THEN 7917 IF ( INFOG(1) .ne. TEMP2(1) ) THEN 7918 write(*,*) 'Error in MUMPS_243' 7919 CALL MUMPS_ABORT() 7920 END IF 7921 IRANK = TEMP2(2) 7922 ELSE 7923 IRANK = -1 7924 END IF 7925 RETURN 7926 END SUBROUTINE MUMPS_243 7927 SUBROUTINE MUMPS_362(N, LEAF, NBROOT, NROOT_LOC, 7928 & MYID_NODES, 7929 & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, 7930 & PROCNODE_STEPS, IPOOL, LPOOL) 7931 IMPLICIT NONE 7932 INTEGER N, LEAF, NROOT_LOC, NBROOT, MYID_NODES, 7933 & SLAVEF, LPOOL, LNA 7934 INTEGER KEEP(500) 7935 INTEGER(8) KEEP8(150) 7936 INTEGER STEP(N) 7937 INTEGER PROCNODE_STEPS(KEEP(28)), NA(LNA), 7938 & IPOOL(LPOOL) 7939 INTEGER NBLEAF, INODE, I 7940 INTEGER MUMPS_275 7941 EXTERNAL MUMPS_275 7942 NBLEAF = NA(1) 7943 NBROOT = NA(2) 7944 LEAF = 1 7945 DO I = 1, NBLEAF 7946 INODE = NA(I+2) 7947 IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 7948 & .EQ.MYID_NODES) THEN 7949 IPOOL(LEAF) = INODE 7950 LEAF = LEAF + 1 7951 ENDIF 7952 ENDDO 7953 NROOT_LOC = 0 7954 DO I = 1, NBROOT 7955 INODE = NA(I+2+NBLEAF) 7956 IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)), 7957 & SLAVEF).EQ.MYID_NODES) THEN 7958 NROOT_LOC = NROOT_LOC + 1 7959 END IF 7960 ENDDO 7961 RETURN 7962 END SUBROUTINE MUMPS_362 7963 LOGICAL FUNCTION MUMPS_438(TAB1,TAB2,LEN1,LEN2) 7964 IMPLICIT NONE 7965 INTEGER LEN1 , LEN2 ,I 7966 INTEGER TAB1(LEN1) 7967 INTEGER TAB2(LEN2) 7968 MUMPS_438=.FALSE. 7969 IF(LEN1 .NE. LEN2) THEN 7970 RETURN 7971 ENDIF 7972 DO I=1 , LEN1 7973 IF(TAB1(I) .NE. TAB2(I)) THEN 7974 RETURN 7975 ENDIF 7976 ENDDO 7977 MUMPS_438=.TRUE. 7978 RETURN 7979 END FUNCTION MUMPS_438 7980 SUBROUTINE MUMPS_463( N, VAL, ID ) 7981 INTEGER N 7982 INTEGER ID( N ) 7983 INTEGER VAL( N ) 7984 INTEGER I, ISWAP 7985 INTEGER SWAP 7986 LOGICAL DONE 7987 DONE = .FALSE. 7988 DO WHILE ( .NOT. DONE ) 7989 DONE = .TRUE. 7990 DO I = 1, N - 1 7991 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN 7992 DONE = .FALSE. 7993 ISWAP = ID( I ) 7994 ID ( I ) = ID ( I + 1 ) 7995 ID ( I + 1 ) = ISWAP 7996 SWAP = VAL( I ) 7997 VAL( I ) = VAL( I + 1 ) 7998 VAL( I + 1 ) = SWAP 7999 END IF 8000 END DO 8001 END DO 8002 RETURN 8003 END SUBROUTINE MUMPS_463 8004 SUBROUTINE MUMPS_466( N, VAL, ID ) 8005 INTEGER N 8006 INTEGER ID( N ) 8007 INTEGER VAL( N ) 8008 INTEGER I, ISWAP 8009 INTEGER SWAP 8010 LOGICAL DONE 8011 DONE = .FALSE. 8012 DO WHILE ( .NOT. DONE ) 8013 DONE = .TRUE. 8014 DO I = 1, N - 1 8015 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN 8016 DONE = .FALSE. 8017 ISWAP = ID( I ) 8018 ID ( I ) = ID ( I + 1 ) 8019 ID ( I + 1 ) = ISWAP 8020 SWAP = VAL( I ) 8021 VAL( I ) = VAL( I + 1 ) 8022 VAL( I + 1 ) = SWAP 8023 END IF 8024 END DO 8025 END DO 8026 RETURN 8027 END SUBROUTINE MUMPS_466 8028 SUBROUTINE MUMPS_ABORT() 8029 IMPLICIT NONE 8030 INCLUDE 'mpif.h' 8031 INTEGER IERR, IERRCODE 8032 IERRCODE = -99 8033 CALL MPI_ABORT(MPI_COMM_WORLD, IERRCODE, IERR) 8034 RETURN 8035 END SUBROUTINE MUMPS_ABORT 8036 SUBROUTINE MUMPS_633(KEEP12,ICNTL14, 8037 & KEEP50,KEEP54,ICNTL6,ICNTL8) 8038 IMPLICIT NONE 8039 INTEGER, intent(out)::KEEP12 8040 INTEGER, intent(in)::ICNTL14,KEEP50,KEEP54,ICNTL6,ICNTL8 8041 KEEP12 = ICNTL14 8042 IF(ICNTL6.EQ.0 .AND. ICNTL8.EQ.0) RETURN 8043 IF ( (KEEP54.NE.0).AND. (KEEP50.NE.1) 8044 & .AND. (KEEP12 .GT. 0) ) KEEP12= KEEP12+5 8045 RETURN 8046 END SUBROUTINE MUMPS_633 8047 SUBROUTINE MUMPS_749( I8_VALUE, ROOT, MYID, COMM, IERR) 8048 IMPLICIT NONE 8049 INCLUDE 'mpif.h' 8050 INTEGER ROOT, MYID, COMM, IERR 8051 INTEGER(8) :: I8_VALUE 8052 DOUBLE PRECISION :: DBLE_VALUE 8053 IF (MYID .EQ. ROOT) THEN 8054 DBLE_VALUE = dble(I8_VALUE) 8055 ENDIF 8056 CALL MPI_BCAST( DBLE_VALUE, 1, MPI_DOUBLE_PRECISION, 8057 & ROOT, COMM, IERR ) 8058 I8_VALUE = int( DBLE_VALUE,8) 8059 RETURN 8060 END SUBROUTINE MUMPS_749 8061 SUBROUTINE MUMPS_646( IN, OUT, MPI_OP, ROOT, COMM) 8062 IMPLICIT NONE 8063 INCLUDE 'mpif.h' 8064 INTEGER ROOT, COMM, MPI_OP 8065 INTEGER(8) IN, OUT 8066 INTEGER IERR 8067 DOUBLE PRECISION DIN, DOUT 8068 DIN =dble(IN) 8069 DOUT=0.0D0 8070 CALL MPI_REDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, 8071 & MPI_OP, ROOT, COMM, IERR) 8072 OUT=int(DOUT,kind=8) 8073 RETURN 8074 END SUBROUTINE MUMPS_646 8075 SUBROUTINE MUMPS_736( IN, OUT, MPI_OP, COMM) 8076 IMPLICIT NONE 8077 INCLUDE 'mpif.h' 8078 INTEGER COMM, MPI_OP 8079 INTEGER(8) IN, OUT 8080 INTEGER IERR 8081 DOUBLE PRECISION DIN, DOUT 8082 DIN =dble(IN) 8083 DOUT=0.0D0 8084 CALL MPI_ALLREDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, 8085 & MPI_OP, COMM, IERR) 8086 OUT=int(DOUT,kind=8) 8087 RETURN 8088 END SUBROUTINE MUMPS_736 8089 SUBROUTINE MUMPS_754(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, 8090 & STRING, MEMCNT, ERRCODE) 8091 INTEGER, POINTER :: ARRAY(:) 8092 INTEGER :: INFO(:) 8093 INTEGER :: MINSIZE, LP 8094 LOGICAL, OPTIONAL :: FORCE 8095 LOGICAL, OPTIONAL :: COPY 8096 CHARACTER, OPTIONAL :: STRING*(*) 8097 INTEGER, OPTIONAL :: ERRCODE, MEMCNT 8098 LOGICAL :: ICOPY, IFORCE 8099 INTEGER, POINTER :: TEMP(:) 8100 INTEGER :: I, IERR, ERRTPL(2) 8101 CHARACTER :: FMTA*60, FMTD*60 8102 IF(present(COPY)) THEN 8103 ICOPY = COPY 8104 ELSE 8105 ICOPY = .FALSE. 8106 END IF 8107 IF (present(FORCE)) THEN 8108 IFORCE = FORCE 8109 ELSE 8110 IFORCE = .FALSE. 8111 END IF 8112 IF (present(STRING)) THEN 8113 FMTA = "Allocation failed inside realloc: "//STRING 8114 FMTD = "Deallocation failed inside realloc: "//STRING 8115 ELSE 8116 FMTA = "Allocation failed inside realloc: " 8117 FMTD = "Deallocation failed inside realloc: " 8118 END IF 8119 IF (present(ERRCODE)) THEN 8120 ERRTPL = (/ERRCODE, MINSIZE/) 8121 ELSE 8122 ERRTPL = (/-13, MINSIZE/) 8123 END IF 8124 IF(ICOPY) THEN 8125 IF(associated(ARRAY)) THEN 8126 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8127 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8128 allocate(TEMP(MINSIZE), STAT=IERR) 8129 IF(IERR .LT. 0) THEN 8130 WRITE(LP,FMTA) 8131 INFO(1:2) = ERRTPL 8132 RETURN 8133 ELSE 8134 IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE 8135 END IF 8136 DO I=1, min(size(ARRAY), MINSIZE) 8137 TEMP(I) = ARRAY(I) 8138 END DO 8139 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8140 deallocate(ARRAY, STAT=IERR) 8141 IF(IERR .LT. 0) THEN 8142 WRITE(LP,FMTD) 8143 INFO(1:2) = ERRTPL 8144 RETURN 8145 END IF 8146 NULLIFY(ARRAY) 8147 ARRAY => TEMP 8148 NULLIFY(TEMP) 8149 END IF 8150 ELSE 8151 WRITE(LP, 8152 & '("Input array is not associated. nothing to copy here")') 8153 RETURN 8154 END IF 8155 ELSE 8156 IF(associated(ARRAY)) THEN 8157 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8158 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8159 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8160 deallocate(ARRAY, STAT=IERR) 8161 IF(IERR .LT. 0) THEN 8162 WRITE(LP,FMTD) 8163 INFO(1:2) = ERRTPL 8164 RETURN 8165 END IF 8166 ELSE 8167 RETURN 8168 END IF 8169 END IF 8170 allocate(ARRAY(MINSIZE), STAT=IERR) 8171 IF(IERR .LT. 0) THEN 8172 WRITE(LP,FMTA) 8173 INFO(1:2) = ERRTPL 8174 RETURN 8175 ELSE 8176 IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE 8177 END IF 8178 END IF 8179 RETURN 8180 END SUBROUTINE MUMPS_754 8181 SUBROUTINE MUMPS_750(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, 8182 & STRING, MEMCNT, ERRCODE) 8183 REAL(kind(1.E0)), POINTER :: ARRAY(:) 8184 INTEGER :: INFO(:) 8185 INTEGER :: MINSIZE, LP 8186 LOGICAL, OPTIONAL :: FORCE 8187 LOGICAL, OPTIONAL :: COPY 8188 CHARACTER, OPTIONAL :: STRING*(*) 8189 INTEGER, OPTIONAL :: ERRCODE, MEMCNT 8190 LOGICAL :: ICOPY, IFORCE 8191 REAL(kind(1.E0)), POINTER :: TEMP(:) 8192 INTEGER :: I, IERR, ERRTPL(2) 8193 CHARACTER :: FMTA*60, FMTD*60 8194 IF(present(COPY)) THEN 8195 ICOPY = COPY 8196 ELSE 8197 ICOPY = .FALSE. 8198 END IF 8199 IF (present(FORCE)) THEN 8200 IFORCE = FORCE 8201 ELSE 8202 IFORCE = .FALSE. 8203 END IF 8204 IF (present(STRING)) THEN 8205 FMTA = "Allocation failed inside realloc: "//STRING 8206 FMTD = "Deallocation failed inside realloc: "//STRING 8207 ELSE 8208 FMTA = "Allocation failed inside realloc: " 8209 FMTD = "Deallocation failed inside realloc: " 8210 END IF 8211 IF (present(ERRCODE)) THEN 8212 ERRTPL = (/ERRCODE, MINSIZE/) 8213 ELSE 8214 ERRTPL = (/-13, MINSIZE/) 8215 END IF 8216 IF(ICOPY) THEN 8217 IF(associated(ARRAY)) THEN 8218 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8219 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8220 allocate(TEMP(MINSIZE), STAT=IERR) 8221 IF(IERR .LT. 0) THEN 8222 WRITE(LP,FMTA) 8223 INFO(1:2) = ERRTPL 8224 RETURN 8225 ELSE 8226 IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE 8227 END IF 8228 DO I=1, min(size(ARRAY), MINSIZE) 8229 TEMP(I) = ARRAY(I) 8230 END DO 8231 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8232 deallocate(ARRAY, STAT=IERR) 8233 IF(IERR .LT. 0) THEN 8234 WRITE(LP,FMTD) 8235 INFO(1:2) = ERRTPL 8236 RETURN 8237 END IF 8238 NULLIFY(ARRAY) 8239 ARRAY => TEMP 8240 NULLIFY(TEMP) 8241 END IF 8242 ELSE 8243 WRITE(LP, 8244 & '("Input array is not associated. nothing to copy here")') 8245 RETURN 8246 END IF 8247 ELSE 8248 IF(associated(ARRAY)) THEN 8249 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8250 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8251 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8252 deallocate(ARRAY, STAT=IERR) 8253 IF(IERR .LT. 0) THEN 8254 WRITE(LP,FMTD) 8255 INFO(1:2) = ERRTPL 8256 RETURN 8257 END IF 8258 ELSE 8259 RETURN 8260 END IF 8261 END IF 8262 allocate(ARRAY(MINSIZE), STAT=IERR) 8263 IF(IERR .LT. 0) THEN 8264 WRITE(LP,FMTA) 8265 INFO(1:2) = ERRTPL 8266 RETURN 8267 ELSE 8268 IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE 8269 END IF 8270 END IF 8271 RETURN 8272 END SUBROUTINE MUMPS_750 8273 SUBROUTINE MUMPS_752(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, 8274 & STRING, MEMCNT, ERRCODE) 8275 REAL(kind(1.D0)), POINTER :: ARRAY(:) 8276 INTEGER :: INFO(:) 8277 INTEGER :: MINSIZE, LP 8278 LOGICAL, OPTIONAL :: FORCE 8279 LOGICAL, OPTIONAL :: COPY 8280 CHARACTER, OPTIONAL :: STRING*(*) 8281 INTEGER, OPTIONAL :: ERRCODE, MEMCNT 8282 LOGICAL :: ICOPY, IFORCE 8283 REAL(kind(1.D0)), POINTER :: TEMP(:) 8284 INTEGER :: I, IERR, ERRTPL(2) 8285 CHARACTER :: FMTA*60, FMTD*60 8286 IF(present(COPY)) THEN 8287 ICOPY = COPY 8288 ELSE 8289 ICOPY = .FALSE. 8290 END IF 8291 IF (present(FORCE)) THEN 8292 IFORCE = FORCE 8293 ELSE 8294 IFORCE = .FALSE. 8295 END IF 8296 IF (present(STRING)) THEN 8297 FMTA = "Allocation failed inside realloc: "//STRING 8298 FMTD = "Deallocation failed inside realloc: "//STRING 8299 ELSE 8300 FMTA = "Allocation failed inside realloc: " 8301 FMTD = "Deallocation failed inside realloc: " 8302 END IF 8303 IF (present(ERRCODE)) THEN 8304 ERRTPL = (/ERRCODE, MINSIZE/) 8305 ELSE 8306 ERRTPL = (/-13, MINSIZE/) 8307 END IF 8308 IF(ICOPY) THEN 8309 IF(associated(ARRAY)) THEN 8310 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8311 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8312 allocate(TEMP(MINSIZE), STAT=IERR) 8313 IF(IERR .LT. 0) THEN 8314 WRITE(LP,FMTA) 8315 INFO(1:2) = ERRTPL 8316 RETURN 8317 ELSE 8318 IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE 8319 END IF 8320 DO I=1, min(size(ARRAY), MINSIZE) 8321 TEMP(I) = ARRAY(I) 8322 END DO 8323 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8324 deallocate(ARRAY, STAT=IERR) 8325 IF(IERR .LT. 0) THEN 8326 WRITE(LP,FMTD) 8327 INFO(1:2) = ERRTPL 8328 RETURN 8329 END IF 8330 NULLIFY(ARRAY) 8331 ARRAY => TEMP 8332 NULLIFY(TEMP) 8333 END IF 8334 ELSE 8335 WRITE(LP, 8336 & '("Input array is not associated. nothing to copy here")') 8337 RETURN 8338 END IF 8339 ELSE 8340 IF(associated(ARRAY)) THEN 8341 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8342 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8343 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8344 deallocate(ARRAY, STAT=IERR) 8345 IF(IERR .LT. 0) THEN 8346 WRITE(LP,FMTD) 8347 INFO(1:2) = ERRTPL 8348 RETURN 8349 END IF 8350 ELSE 8351 RETURN 8352 END IF 8353 END IF 8354 allocate(ARRAY(MINSIZE), STAT=IERR) 8355 IF(IERR .LT. 0) THEN 8356 WRITE(LP,FMTA) 8357 INFO(1:2) = ERRTPL 8358 RETURN 8359 ELSE 8360 IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE 8361 END IF 8362 END IF 8363 RETURN 8364 END SUBROUTINE MUMPS_752 8365 SUBROUTINE MUMPS_751(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, 8366 & STRING, MEMCNT, ERRCODE) 8367 COMPLEX(kind((1.E0,1.E0))), POINTER :: ARRAY(:) 8368 INTEGER :: INFO(:) 8369 INTEGER :: MINSIZE, LP 8370 LOGICAL, OPTIONAL :: FORCE 8371 LOGICAL, OPTIONAL :: COPY 8372 CHARACTER, OPTIONAL :: STRING*(*) 8373 INTEGER, OPTIONAL :: ERRCODE, MEMCNT 8374 LOGICAL :: ICOPY, IFORCE 8375 COMPLEX(kind((1.E0,1.E0))), POINTER :: TEMP(:) 8376 INTEGER :: I, IERR, ERRTPL(2) 8377 CHARACTER :: FMTA*60, FMTD*60 8378 IF(present(COPY)) THEN 8379 ICOPY = COPY 8380 ELSE 8381 ICOPY = .FALSE. 8382 END IF 8383 IF (present(FORCE)) THEN 8384 IFORCE = FORCE 8385 ELSE 8386 IFORCE = .FALSE. 8387 END IF 8388 IF (present(STRING)) THEN 8389 FMTA = "Allocation failed inside realloc: "//STRING 8390 FMTD = "Deallocation failed inside realloc: "//STRING 8391 ELSE 8392 FMTA = "Allocation failed inside realloc: " 8393 FMTD = "Deallocation failed inside realloc: " 8394 END IF 8395 IF (present(ERRCODE)) THEN 8396 ERRTPL = (/ERRCODE, MINSIZE/) 8397 ELSE 8398 ERRTPL = (/-13, MINSIZE/) 8399 END IF 8400 IF(ICOPY) THEN 8401 IF(associated(ARRAY)) THEN 8402 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8403 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8404 allocate(TEMP(MINSIZE), STAT=IERR) 8405 IF(IERR .LT. 0) THEN 8406 WRITE(LP,FMTA) 8407 INFO(1:2) = ERRTPL 8408 RETURN 8409 ELSE 8410 IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE 8411 END IF 8412 DO I=1, min(size(ARRAY), MINSIZE) 8413 TEMP(I) = ARRAY(I) 8414 END DO 8415 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8416 deallocate(ARRAY, STAT=IERR) 8417 IF(IERR .LT. 0) THEN 8418 WRITE(LP,FMTD) 8419 INFO(1:2) = ERRTPL 8420 RETURN 8421 END IF 8422 NULLIFY(ARRAY) 8423 ARRAY => TEMP 8424 NULLIFY(TEMP) 8425 END IF 8426 ELSE 8427 WRITE(LP, 8428 & '("Input array is not associated. nothing to copy here")') 8429 RETURN 8430 END IF 8431 ELSE 8432 IF(associated(ARRAY)) THEN 8433 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8434 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8435 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8436 deallocate(ARRAY, STAT=IERR) 8437 IF(IERR .LT. 0) THEN 8438 WRITE(LP,FMTD) 8439 INFO(1:2) = ERRTPL 8440 RETURN 8441 END IF 8442 ELSE 8443 RETURN 8444 END IF 8445 END IF 8446 allocate(ARRAY(MINSIZE), STAT=IERR) 8447 IF(IERR .LT. 0) THEN 8448 WRITE(LP,FMTA) 8449 INFO(1:2) = ERRTPL 8450 RETURN 8451 ELSE 8452 IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE 8453 END IF 8454 END IF 8455 RETURN 8456 END SUBROUTINE MUMPS_751 8457 SUBROUTINE MUMPS_753(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, 8458 & STRING, MEMCNT, ERRCODE) 8459 COMPLEX(kind((1.D0,1.D0))), POINTER :: ARRAY(:) 8460 INTEGER :: INFO(:) 8461 INTEGER :: MINSIZE, LP 8462 LOGICAL, OPTIONAL :: FORCE 8463 LOGICAL, OPTIONAL :: COPY 8464 CHARACTER, OPTIONAL :: STRING*(*) 8465 INTEGER, OPTIONAL :: ERRCODE, MEMCNT 8466 LOGICAL :: ICOPY, IFORCE 8467 COMPLEX(kind((1.D0,1.D0))), POINTER :: TEMP(:) 8468 INTEGER :: I, IERR, ERRTPL(2) 8469 CHARACTER :: FMTA*60, FMTD*60 8470 IF(present(COPY)) THEN 8471 ICOPY = COPY 8472 ELSE 8473 ICOPY = .FALSE. 8474 END IF 8475 IF (present(FORCE)) THEN 8476 IFORCE = FORCE 8477 ELSE 8478 IFORCE = .FALSE. 8479 END IF 8480 IF (present(STRING)) THEN 8481 FMTA = "Allocation failed inside realloc: "//STRING 8482 FMTD = "Deallocation failed inside realloc: "//STRING 8483 ELSE 8484 FMTA = "Allocation failed inside realloc: " 8485 FMTD = "Deallocation failed inside realloc: " 8486 END IF 8487 IF (present(ERRCODE)) THEN 8488 ERRTPL = (/ERRCODE, MINSIZE/) 8489 ELSE 8490 ERRTPL = (/-13, MINSIZE/) 8491 END IF 8492 IF(ICOPY) THEN 8493 IF(associated(ARRAY)) THEN 8494 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8495 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8496 allocate(TEMP(MINSIZE), STAT=IERR) 8497 IF(IERR .LT. 0) THEN 8498 WRITE(LP,FMTA) 8499 INFO(1:2) = ERRTPL 8500 RETURN 8501 ELSE 8502 IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE 8503 END IF 8504 DO I=1, min(size(ARRAY), MINSIZE) 8505 TEMP(I) = ARRAY(I) 8506 END DO 8507 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8508 deallocate(ARRAY, STAT=IERR) 8509 IF(IERR .LT. 0) THEN 8510 WRITE(LP,FMTD) 8511 INFO(1:2) = ERRTPL 8512 RETURN 8513 END IF 8514 NULLIFY(ARRAY) 8515 ARRAY => TEMP 8516 NULLIFY(TEMP) 8517 END IF 8518 ELSE 8519 WRITE(LP, 8520 & '("Input array is not associated. nothing to copy here")') 8521 RETURN 8522 END IF 8523 ELSE 8524 IF(associated(ARRAY)) THEN 8525 IF ((size(ARRAY) .LT. MINSIZE) .OR. 8526 & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN 8527 IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 8528 deallocate(ARRAY, STAT=IERR) 8529 IF(IERR .LT. 0) THEN 8530 WRITE(LP,FMTD) 8531 INFO(1:2) = ERRTPL 8532 RETURN 8533 END IF 8534 ELSE 8535 RETURN 8536 END IF 8537 END IF 8538 allocate(ARRAY(MINSIZE), STAT=IERR) 8539 IF(IERR .LT. 0) THEN 8540 WRITE(LP,FMTA) 8541 INFO(1:2) = ERRTPL 8542 RETURN 8543 ELSE 8544 IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE 8545 END IF 8546 END IF 8547 RETURN 8548 END SUBROUTINE MUMPS_753 8549 SUBROUTINE MUMPS_735(I8, I4) 8550 IMPLICIT NONE 8551 INTEGER , INTENT(OUT) :: I4 8552 INTEGER(8), INTENT(IN) :: I8 8553 IF ( I8 .GT. int(huge(I4),8) ) THEN 8554 I4 = -int(I8/1000000_8,kind(I4)) 8555 ELSE 8556 I4 = int(I8,kind(I4)) 8557 ENDIF 8558 RETURN 8559 END SUBROUTINE MUMPS_735 8560 SUBROUTINE MUMPS_ABORT_ON_OVERFLOW(I8, STRING) 8561 IMPLICIT NONE 8562 INTEGER(8), INTENT(IN) :: I8 8563 CHARACTER(*), INTENT(IN) :: STRING 8564 INTEGER I4 8565 IF ( I8 .GT. int(huge(I4),8)) THEN 8566 WRITE(*,*) STRING 8567 CALL MUMPS_ABORT() 8568 ENDIF 8569 RETURN 8570 END SUBROUTINE MUMPS_ABORT_ON_OVERFLOW 8571 SUBROUTINE MUMPS_731( SIZE8, IERROR ) 8572 INTEGER(8), INTENT(IN) :: SIZE8 8573 INTEGER, INTENT(OUT) :: IERROR 8574 CALL MUMPS_735(SIZE8, IERROR) 8575 RETURN 8576 END SUBROUTINE MUMPS_731 8577 SUBROUTINE MUMPS_730(I8, INT_ARRAY) 8578 IMPLICIT NONE 8579 INTEGER(8), intent(in) :: I8 8580 INTEGER, intent(out) :: INT_ARRAY(2) 8581 INTEGER(kind(0_4)) :: I32 8582 INTEGER(8) :: IDIV, IPAR 8583 PARAMETER (IPAR=int(huge(I32),8)) 8584 PARAMETER (IDIV=IPAR+1_8) 8585 IF ( I8 .LT. IDIV ) THEN 8586 INT_ARRAY(1) = 0 8587 INT_ARRAY(2) = int(I8) 8588 ELSE 8589 INT_ARRAY(1) = int(I8 / IDIV) 8590 INT_ARRAY(2) = int(mod(I8,IDIV)) 8591 ENDIF 8592 RETURN 8593 END SUBROUTINE MUMPS_730 8594 SUBROUTINE MUMPS_729(I8, INT_ARRAY) 8595 IMPLICIT NONE 8596 INTEGER(8), intent(out) :: I8 8597 INTEGER, intent(in) :: INT_ARRAY(2) 8598 INTEGER(kind(0_4)) :: I32 8599 INTEGER(8) :: IDIV, IPAR 8600 PARAMETER (IPAR=int(huge(I32),8)) 8601 PARAMETER (IDIV=IPAR+1_8) 8602 IF ( INT_ARRAY(1) .EQ. 0 ) THEN 8603 I8=int(INT_ARRAY(2),8) 8604 ELSE 8605 I8=int(INT_ARRAY(1),8)*IDIV+int(INT_ARRAY(2),8) 8606 ENDIF 8607 RETURN 8608 END SUBROUTINE MUMPS_729 8609 SUBROUTINE MUMPS_723( INT_ARRAY, I8 ) 8610 IMPLICIT NONE 8611 INTEGER(8), intent(in) :: I8 8612 INTEGER, intent(inout) :: INT_ARRAY(2) 8613 INTEGER(8) :: I8TMP 8614 CALL MUMPS_729(I8TMP, INT_ARRAY) 8615 I8TMP = I8TMP + I8 8616 CALL MUMPS_730(I8TMP, INT_ARRAY) 8617 RETURN 8618 END SUBROUTINE MUMPS_723 8619 SUBROUTINE MUMPS_724( INT_ARRAY, I8 ) 8620 IMPLICIT NONE 8621 INTEGER(8), intent(in) :: I8 8622 INTEGER, intent(inout) :: INT_ARRAY(2) 8623 INTEGER(8) :: I8TMP 8624 CALL MUMPS_729(I8TMP, INT_ARRAY) 8625 I8TMP = I8TMP - I8 8626 CALL MUMPS_730(I8TMP, INT_ARRAY) 8627 RETURN 8628 END SUBROUTINE MUMPS_724 8629 FUNCTION MUMPS_815(WHICH) 8630 LOGICAL :: MUMPS_815 8631 CHARACTER :: WHICH*(*) 8632 LOGICAL :: PTSCOTCH=.FALSE., PARMETIS=.FALSE. 8633#if defined(ptscotch) 8634 PTSCOTCH = .TRUE. 8635#endif 8636#if defined(parmetis) 8637 PARMETIS = .TRUE. 8638#endif 8639 SELECT CASE(WHICH) 8640 CASE('ptscotch','PTSCOTCH') 8641 MUMPS_815 = PTSCOTCH 8642 CASE('parmetis','PARMETIS') 8643 MUMPS_815 = PARMETIS 8644 CASE('both','BOTH') 8645 MUMPS_815 = PTSCOTCH .AND. PARMETIS 8646 CASE('any','ANY') 8647 MUMPS_815 = PTSCOTCH .OR. PARMETIS 8648 CASE default 8649 write(*,'("Invalid input in MUMPS_815")') 8650 END SELECT 8651 RETURN 8652 END FUNCTION MUMPS_815 8653