1C 2C This file is part of MUMPS 5.1.2, released 3C on Mon Oct 2 07:37:01 UTC 2017 4C 5C 6C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, 7C University of Bordeaux. 8C 9C This version of MUMPS is provided to you free of charge. It is 10C released under the CeCILL-C license: 11C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html 12C 13 MODULE SMUMPS_FAC_FRONT_TYPE2_AUX_M 14 CONTAINS 15 SUBROUTINE SMUMPS_FAC_I_LDLT_NIV2( 16 & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, 17 & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, 18 & NASS2, TIPIV, 19 & N, INODE, IW, LIW, A, LA, NNEG, 20 & INOPV, IFLAG, 21 & IOLDPS, POSELT, UU, 22 & SEUIL,KEEP,KEEP8,PIVSIZ, 23 & DKEEP,PIVNUL_LIST,LPN_LIST, 24 & PP_FIRST2SWAP_L, PP_LastPanelonDisk, 25 & PP_LastPIVRPTRIndexFilled, 26 & PIVOT_OPTION, 27 & Inextpiv, IEND_BLR) 28 USE MUMPS_OOC_COMMON, ONLY : TYPEF_L 29 USE SMUMPS_FAC_FRONT_AUX_M 30 IMPLICIT NONE 31 INTEGER SIZEDIAG_ORIG 32 REAL DIAG_ORIG(SIZEDIAG_ORIG) 33 REAL GW_FACTCUMUL 34 INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV 35 INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, NNEG 36 INTEGER TIPIV( NASS2 ) 37 INTEGER PIVSIZ,LPIV 38 INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR 39 INTEGER, intent(inout) :: Inextpiv 40 INTEGER(8) :: LA 41 REAL A(LA) 42 REAL UU, UULOC, SEUIL 43 REAL CSEUIL 44 INTEGER IW(LIW) 45 INTEGER IOLDPS 46 INTEGER(8) :: POSELT 47 INTEGER KEEP(500) 48 INTEGER(8) KEEP8(150) 49 INTEGER LPN_LIST 50 INTEGER PIVNUL_LIST(LPN_LIST) 51 REAL DKEEP(230) 52 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk 53 INTEGER PP_LastPIVRPTRIndexFilled 54 include 'mpif.h' 55 INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ 56 INTEGER JMAX 57 REAL RMAX,AMAX,TMAX,RMAX_NORELAX 58 REAL MAXPIV, ABS_PIVOT 59 REAL RMAX_NOSLAVE, TMAX_NOSLAVE 60 REAL PIVOT,DETPIV 61 REAL ABSDETPIV 62 INCLUDE 'mumps_headers.h' 63 INTEGER(8) :: APOSMAX 64 INTEGER(8) :: APOS 65 INTEGER(8) :: J1, J2, JJ, KK 66 REAL :: GROWTH, RSWOP 67 REAL :: UULOCM1 68 INTEGER :: LDAFS 69 INTEGER(8) :: LDAFS8 70 REAL, PARAMETER :: RZERO = 0.0E0 71 REAL, PARAMETER :: RONE = 1.0E0 72 REAL ZERO, ONE 73 PARAMETER( ZERO = 0.0E0 ) 74 PARAMETER( ONE = 1.0E0 ) 75 REAL PIVNUL, VALTMP 76 REAL FIXA 77 INTEGER NPIV,IPIV,K219 78 INTEGER NPIVP1,ILOC,K,J 79 INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT 80 INTRINSIC max 81 INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 82 REAL GW_FACT 83 GW_FACT = RONE 84 AMAX = RZERO 85 RMAX = RZERO 86 TMAX = RZERO 87 RMAX_NOSLAVE = RZERO 88 PIVOT = ONE 89 K206 = KEEP(206) 90 PIVNUL = DKEEP(1) 91 FIXA = DKEEP(2) 92 CSEUIL = SEUIL 93 LDAFS = NASS 94 LDAFS8 = int(LDAFS,8) 95 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 96 CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, 97 & I_PIVRPTR, I_PIVR, 98 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) 99 & +KEEP(IXSZ), 100 & IW, LIW) 101 ENDIF 102 UULOC = UU 103 K219 = KEEP(219) 104 IF (UULOC.GT.RZERO) THEN 105 UULOCM1 = RONE/UULOC 106 ELSE 107 K219=0 108 UULOCM1 = RONE 109 ENDIF 110 IF (K219.LT.2) GW_FACTCUMUL = RONE 111 PIVSIZ = 1 112 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 113 NPIVP1 = NPIV + 1 114 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 115 TIPIV( ILOC ) = ILOC 116 APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 117 IF(INOPV .EQ. -1) THEN 118 APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) 119 POSPV1 = APOS 120 IF(abs(A(APOS)).LT.SEUIL) THEN 121 IF(real(A(APOS)) .GE. RZERO) THEN 122 A(APOS) = CSEUIL 123 ELSE 124 A(APOS) = -CSEUIL 125 NNEG = NNEG+1 126 ENDIF 127 ELSE IF (KEEP(258) .NE.0 ) THEN 128 CALL SMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) 129 ENDIF 130 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 131 CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, 132 & IW(I_PIVR), NASS, NPIVP1, NPIVP1, 133 & PP_LastPanelonDisk, 134 & PP_LastPIVRPTRIndexFilled) 135 ENDIF 136 GO TO 420 137 ENDIF 138 INOPV = 0 139 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN 140 GW_FACTCUMUL = RONE 141 IF (K219.EQ.3) THEN 142 DO IPIV=1,NASS 143 APOS = POSELT + LDAFS8*int(IPIV-1,8) 144 POSPV1 = APOS + int(IPIV - 1,8) 145 DIAG_ORIG (IPIV) = abs(A(POSPV1)) 146 ENDDO 147 ELSE IF (K219.GE.4) THEN 148 DIAG_ORIG = RZERO 149 DO IPIV=1,NASS 150 APOS = POSELT + LDAFS8*int(IPIV-1,8) 151 POSPV1 = APOS + int(IPIV - 1,8) 152 DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) 153 DO J=IPIV+1,NASS 154 DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) 155 DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), 156 & DIAG_ORIG(IPIV+J-IPIV) ) 157 POSPV1 = POSPV1 + LDAFS8 158 ENDDO 159 ENDDO 160 ENDIF 161 ENDIF 162 ISHIFT = 0 163 IPIV_END = IEND_BLOCK 164 IF (K206.GE.1) THEN 165 IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN 166 ISHIFT = Inextpiv - NPIVP1 167 ENDIF 168 IF ( K206.EQ.1 169 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN 170 IPIV_END = IEND_BLOCK + ISHIFT 171 ENDIF 172 ENDIF 173 DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END 174 IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN 175 IPIV=IPIV_SHIFT 176 ELSE 177 IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 178 IF (IBEG_BLOCK.EQ.NPIVP1) THEN 179 EXIT 180 ENDIF 181 ENDIF 182 APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) 183 POSPV1 = APOS + int(IPIV - NPIVP1,8) 184 PIVOT = A(POSPV1) 185 ABS_PIVOT = abs(PIVOT) 186 IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN 187 IF (ABS_PIVOT.EQ.RZERO) GO TO 630 188 IF (PIVOT.LT.RZERO) NNEG = NNEG+1 189 IF (KEEP(258) .NE. 0) THEN 190 CALL SMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 191 ENDIF 192 GO TO 420 193 ENDIF 194 AMAX = -RONE 195 JMAX = 0 196 J1 = APOS 197 J2 = POSPV1 - 1_8 198 DO JJ=J1,J2 199 IF(abs(A(JJ)) .GT. AMAX) THEN 200 AMAX = abs(A(JJ)) 201 JMAX = IPIV - int(POSPV1-JJ) 202 ENDIF 203 ENDDO 204 J1 = POSPV1 + LDAFS8 205 DO J=1, IEND_BLOCK - IPIV 206 IF(abs(A(J1)) .GT. AMAX) THEN 207 AMAX = max(abs(A(J1)),AMAX) 208 JMAX = IPIV + J 209 ENDIF 210 J1 = J1 + LDAFS8 211 ENDDO 212 RMAX_NOSLAVE = RZERO 213 IF (PIVOT_OPTION.EQ.2) THEN 214 DO J=1,NASS - IEND_BLOCK 215 RMAX_NOSLAVE = max(abs(A(J1)),RMAX_NOSLAVE) 216 J1 = J1 + LDAFS8 217 ENDDO 218 ENDIF 219 IF (K219.NE.0) THEN 220 RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) 221 RMAX = RMAX_NORELAX 222 IF (K219.GE.2) THEN 223 IF (ABS_PIVOT.NE.RZERO.AND. 224 & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) 225 & THEN 226 GROWTH = RONE 227 IF (K219.EQ.3) THEN 228 IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN 229 DIAG_ORIG(IPIV) = ABS_PIVOT 230 ELSE 231 GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) 232 ENDIF 233 ELSE IF (K219.GE.4) THEN 234 IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN 235 DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) 236 ELSE 237 GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ 238 & DIAG_ORIG(IPIV) 239 ENDIF 240 ENDIF 241 RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) 242 ENDIF 243 ENDIF 244 ELSE 245 RMAX = RZERO 246 RMAX_NORELAX = RZERO 247 ENDIF 248 RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) 249 RMAX = max(RMAX,RMAX_NOSLAVE) 250 IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN 251 KEEP(109) = KEEP(109)+1 252 PIVNUL_LIST(KEEP(109)) = -1 253 IF (real(FIXA).GT.RZERO) THEN 254 IF(real(PIVOT) .GE. RZERO) THEN 255 A(POSPV1) = FIXA 256 ELSE 257 A(POSPV1) = -FIXA 258 ENDIF 259 ELSE 260 J1 = APOS 261 J2 = POSPV1 - 1_8 262 DO JJ=J1,J2 263 A(JJ) = ZERO 264 ENDDO 265 J1 = POSPV1 + LDAFS8 266 DO J=1, IEND_BLOCK - IPIV 267 A(J1) = ZERO 268 J1 = J1 + LDAFS8 269 ENDDO 270 DO J=1,NASS - IEND_BLOCK 271 A(J1) = ZERO 272 J1 = J1 + LDAFS8 273 ENDDO 274 VALTMP = max(1.0E10*RMAX, sqrt(huge(RMAX))/1.0E8) 275 A(POSPV1) = VALTMP 276 ENDIF 277 PIVOT = A(POSPV1) 278 ABS_PIVOT = abs(PIVOT) 279 GO TO 415 280 ENDIF 281 IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) 282 & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN 283 IF (A(POSPV1).LT.RZERO) NNEG = NNEG+1 284 IF (KEEP(258) .NE.0 ) THEN 285 CALL SMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) 286 ENDIF 287 GO TO 415 288 END IF 289 IF (NPIVP1.EQ.IEND_BLOCK) THEN 290 GOTO 460 291 ENDIF 292 IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN 293 GOTO 460 294 ENDIF 295 IF (RMAX_NOSLAVE.LT.AMAX) THEN 296 J1 = APOS 297 J2 = POSPV1 - 1_8 298 DO JJ=J1,J2 299 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN 300 RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) 301 ENDIF 302 ENDDO 303 J1 = POSPV1 + LDAFS8 304 DO J=1,NASS-IPIV 305 IF(IPIV+J .NE. JMAX) THEN 306 RMAX_NOSLAVE = max(abs(A(J1)),RMAX_NOSLAVE) 307 ENDIF 308 J1 = J1 + LDAFS8 309 ENDDO 310 RMAX = max(RMAX, RMAX_NOSLAVE) 311 ENDIF 312 APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) 313 POSPV2 = APOSJ + int(JMAX - NPIVP1,8) 314 IF (IPIV.LT.JMAX) THEN 315 OFFDAG = APOSJ + int(IPIV - NPIVP1,8) 316 ELSE 317 OFFDAG = APOS + int(JMAX - NPIVP1,8) 318 END IF 319 TMAX_NOSLAVE = RZERO 320 IF(JMAX .LT. IPIV) THEN 321 JJ = POSPV2 322 DO K = 1, NASS-JMAX 323 JJ = JJ+LDAFS8 324 IF (JMAX+K.NE.IPIV) THEN 325 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) 326 ENDIF 327 ENDDO 328 DO KK = APOSJ, POSPV2-1_8 329 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) 330 ENDDO 331 ELSE 332 JJ = POSPV2 333 DO K = 1, NASS-JMAX 334 JJ = JJ+LDAFS8 335 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) 336 ENDDO 337 DO KK = APOSJ, POSPV2 - 1_8 338 IF (KK.NE.OFFDAG) THEN 339 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) 340 ENDIF 341 ENDDO 342 ENDIF 343 IF (K219.NE.0) THEN 344 TMAX = max(SEUIL*UULOCM1,real(A(APOSMAX+int(JMAX,8)))) 345 ELSE 346 TMAX = SEUIL*UULOCM1 347 ENDIF 348 IF (K219.GE.2) THEN 349 GROWTH = RONE 350 IF (K219.EQ.3) THEN 351 IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN 352 DIAG_ORIG(JMAX) = abs(A(POSPV2)) 353 ELSE 354 GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) 355 ENDIF 356 ELSE IF (K219.EQ.4) THEN 357 IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN 358 DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) 359 ELSE 360 GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) 361 & / DIAG_ORIG(JMAX) 362 ENDIF 363 ENDIF 364 TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) 365 ENDIF 366 TMAX = max (TMAX,TMAX_NOSLAVE) 367 DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) 368 ABSDETPIV = abs(DETPIV) 369 IF (SEUIL.GT.RZERO) THEN 370 IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN 371 GOTO 460 372 ENDIF 373 ENDIF 374 MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) 375 IF (MAXPIV.EQ.RZERO) MAXPIV = RONE 376 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. 377 & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN 378 GO TO 460 379 ENDIF 380 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. 381 & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN 382 GO TO 460 383 ENDIF 384 IF (KEEP(258).NE.0) THEN 385 CALL SMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) 386 ENDIF 387 PIVSIZ = 2 388 KEEP(105) = KEEP(105)+1 389 IF(DETPIV .LT. RZERO) THEN 390 NNEG = NNEG+1 391 ELSE IF(A(POSPV2) .LT. RZERO) THEN 392 NNEG = NNEG+2 393 ENDIF 394 415 CONTINUE 395 IF (K206.GE.1) THEN 396 Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) 397 ENDIF 398 DO K=1,PIVSIZ 399 IF (PIVSIZ .EQ. 2 ) THEN 400 IF (K==1) THEN 401 LPIV = min(IPIV, JMAX) 402 TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) 403 ELSE 404 LPIV = max(IPIV, JMAX) 405 TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) 406 ENDIF 407 ELSE 408 LPIV = IPIV 409 TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 410 ENDIF 411 IF (LPIV.EQ.NPIVP1) THEN 412 GOTO 416 413 ENDIF 414 CALL SMUMPS_SWAP_LDLT( A, LA, IW, LIW, 415 & IOLDPS, NPIVP1, LPIV, POSELT, NASS, 416 & LDAFS, NFRONT, 2, K219, KEEP(50), 417 & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) 418 IF (K219.GE.3) THEN 419 RSWOP = DIAG_ORIG(LPIV) 420 DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) 421 DIAG_ORIG(NPIVP1) = RSWOP 422 ENDIF 423 416 CONTINUE 424 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 425 CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, 426 & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, 427 & PP_LastPIVRPTRIndexFilled) 428 ENDIF 429 NPIVP1 = NPIVP1+1 430 ENDDO 431 IF(PIVSIZ .EQ. 2) THEN 432 A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV 433 ENDIF 434 GOTO 420 435 460 CONTINUE 436 IF (K206 .GE. 1) THEN 437 Inextpiv=IEND_BLOCK+1 438 ENDIF 439 IF (IEND_BLOCK.EQ.NASS) THEN 440 INOPV = 1 441 ELSE 442 INOPV = 2 443 ENDIF 444 GO TO 420 445 630 CONTINUE 446 IFLAG = -10 447 420 CONTINUE 448 IF (K219.GE.2) THEN 449 IF(INOPV .EQ. 0) THEN 450 IF(PIVSIZ .EQ. 1) THEN 451 GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT 452 ELSE IF(PIVSIZ .EQ. 2) THEN 453 GW_FACT = max( 454 & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) 455 & / ABSDETPIV , 456 & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) 457 & / ABSDETPIV 458 & ) 459 ENDIF 460 GW_FACT = min(GW_FACT, UULOCM1) 461 GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) 462 ENDIF 463 ENDIF 464 RETURN 465 END SUBROUTINE SMUMPS_FAC_I_LDLT_NIV2 466 SUBROUTINE SMUMPS_FAC_MQ_LDLT_NIV2 467 & (IEND_BLOCK, 468 & NASS, NPIV, INODE, A, LA, LDAFS, 469 & POSELT,IFINB,PIVSIZ, 470 & K219, PIVOT_OPTION, IEND_BLR) 471 IMPLICIT NONE 472 INTEGER(8), intent(in) :: LA, POSELT 473 INTEGER, intent(in) :: K219 474 REAL, intent(inout) :: A(LA) 475 INTEGER, intent(in) :: IEND_BLOCK 476 INTEGER, intent(in) :: NPIV, PIVSIZ 477 INTEGER, intent(in) :: NASS,INODE,LDAFS 478 INTEGER, intent(out) :: IFINB 479 INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR 480 REAL VALPIV 481 INTEGER NCB1 482 INTEGER(8) :: APOS, APOSMAX 483 INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS 484 INTEGER(8) :: JJ, K1, K2 485 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD 486 INTEGER(8) :: LDAFS8 487 INTEGER NEL2 488 REAL ONE, ALPHA 489 REAL ZERO 490 INTEGER NPIV_NEW, I 491 INTEGER(8) :: IBEG, IEND, IROW, J8 492 INTEGER :: J2 493 REAL SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 494 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 495 PARAMETER (ZERO=0.0E0) 496 INCLUDE 'mumps_headers.h' 497 LDAFS8 = int(LDAFS,8) 498 NPIV_NEW = NPIV + PIVSIZ 499 IFINB = 0 500 NEL2 = IEND_BLOCK - NPIV_NEW 501 IF (NEL2.EQ.0) THEN 502 IF (IEND_BLOCK.EQ.NASS) THEN 503 IFINB = -1 504 ELSE 505 IFINB = 1 506 ENDIF 507 ENDIF 508 IF(PIVSIZ .EQ. 1) THEN 509 APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) 510 VALPIV = ONE/A(APOS) 511 LPOS = APOS + LDAFS8 512 DO I = 1, NEL2 513 K1POS = LPOS + int(I-1,8)*LDAFS8 514 A(APOS+int(I,8))=A(K1POS) 515 A(K1POS) = A(K1POS) * VALPIV 516 DO JJ=1_8, int(I,8) 517 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 518 ENDDO 519 ENDDO 520 IF (PIVOT_OPTION.EQ.2) THEN 521 NCB1 = NASS - IEND_BLOCK 522 ELSE 523 NCB1 = IEND_BLR - IEND_BLOCK 524 ENDIF 525!$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) 526 DO I=NEL2+1, NEL2 + NCB1 527 K1POS = LPOS+ int(I-1,8)*LDAFS8 528 A(APOS+int(I,8))=A(K1POS) 529 A(K1POS) = A(K1POS) * VALPIV 530 DO JJ = 1_8, int(NEL2,8) 531 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 532 ENDDO 533 ENDDO 534!$OMP END PARALLEL DO 535 IF (K219.eq. -1) THEN 536 APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) 537 A(APOSMAX) = A(APOSMAX) * abs(VALPIV) 538 DO J8 = 1_8, int(NASS - NPIV_NEW,8) 539 A(APOSMAX+J8) = A(APOSMAX+J8) + 540 & A(APOSMAX) * abs(A(APOS+J8)) 541 ENDDO 542 ENDIF 543 ELSE 544 POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) 545 POSPV2 = POSPV1+LDAFS8+1_8 546 OFFDAG_OLD = POSPV2 - 1_8 547 OFFDAG = POSPV1+1_8 548 SWOP = A(POSPV2) 549 DETPIV = A(OFFDAG) 550 A22 = A(POSPV1)/DETPIV 551 A11 = SWOP/DETPIV 552 A12 = -A(OFFDAG_OLD)/DETPIV 553 A(OFFDAG) = A(OFFDAG_OLD) 554 A(OFFDAG_OLD) = ZERO 555 LPOS1 = POSPV2 + LDAFS8 - 1_8 556 LPOS2 = LPOS1 + 1_8 557 CALL scopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) 558 CALL scopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) 559 JJ = POSPV2 + int(NASS-1,8) 560 IBEG = JJ + 2_8 561 IEND = IBEG 562 DO J2 = 1,NEL2 563 K1 = JJ 564 K2 = JJ+1_8 565 MULT1 = - (A11*A(K1)+A12*A(K2)) 566 MULT2 = - (A12*A(K1)+A22*A(K2)) 567 K1 = POSPV1+2_8 568 K2 = POSPV2+1_8 569 DO IROW = IBEG,IEND 570 A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) 571 K1 = K1 + 1_8 572 K2 = K2 + 1_8 573 ENDDO 574 A(JJ) = -MULT1 575 A(JJ+1_8) = -MULT2 576 IBEG = IBEG + int(NASS,8) 577 IEND = IEND + int(NASS + 1,8) 578 JJ = JJ+int(NASS,8) 579 ENDDO 580 IEND = IEND-1_8 581 DO J2 = IEND_BLOCK+1,NASS 582 K1 = JJ 583 K2 = JJ+1_8 584 MULT1 = - (A11*A(K1)+A12*A(K2)) 585 MULT2 = - (A12*A(K1)+A22*A(K2)) 586 K1 = POSPV1+2_8 587 K2 = POSPV2+1_8 588 DO IROW = IBEG,IEND 589 A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) 590 K1 = K1 + 1_8 591 K2 = K2 + 1_8 592 ENDDO 593 A(JJ) = -MULT1 594 A(JJ+1_8) = -MULT2 595 IBEG = IBEG + int(NASS,8) 596 IEND = IEND + int(NASS,8) 597 JJ = JJ+int(NASS,8) 598 ENDDO 599 IF (K219.eq. -1) THEN 600 APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) 601 JJ = APOSMAX 602 K1 = JJ 603 K2 = JJ + 1_8 604 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) 605 MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) 606 K1 = POSPV1 + 2_8 607 K2 = POSPV2 + 1_8 608 IBEG = APOSMAX + 2_8 609 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW 610 DO IROW = IBEG, IEND 611 A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) 612 K1 = K1 + 1_8 613 K2 = K2 + 1_8 614 ENDDO 615 A(JJ) = MULT1 616 A(JJ+1_8) = MULT2 617 ENDIF 618 ENDIF 619 RETURN 620 END SUBROUTINE SMUMPS_FAC_MQ_LDLT_NIV2 621 SUBROUTINE SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, N, 622 & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, 623 & IBEG_BLOCK, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC, 624 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 625 & IFLAG, IERROR, IPOOL,LPOOL, 626 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 627 & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, 628 & STEP, PIMASTER, PAMASTER, 629 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 630 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 631 & FILS, PTRARW, PTRAIW, 632 & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, 633 & LPTRAR, NELT, FRTPTR, FRTELT, 634 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 635 & , NELIM, SEND_LR, NPARTSASS, CURRENT_BLR_PANEL 636 & , BLR_LorU 637 & , LRGROUPS 638 & ) 639 USE SMUMPS_BUF 640 USE SMUMPS_LOAD 641 USE SMUMPS_LR_TYPE 642 IMPLICIT NONE 643 INCLUDE 'smumps_root.h' 644 INCLUDE 'mpif.h' 645 TYPE (SMUMPS_ROOT_STRUC) :: root 646 INTEGER COMM_LOAD, ASS_IRECV 647 INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV, 648 & IOLDPS, LDA_FS, NB_BLOC_FAC 649 INTEGER(8) :: POSELT, LA 650 INTEGER IW(LIW), TIPIV(LPIV) 651 LOGICAL LASTBL 652 REAL A(LA) 653 INTEGER COMM, MYID, LBUFR, LBUFR_BYTES 654 INTEGER NELT, LPTRAR 655 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 656 INTEGER KEEP(500) 657 INTEGER(8) KEEP8(150) 658 REAL DKEEP(230) 659 INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, 660 & SLAVEF, ICNTL(40) 661 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS 662 INTEGER IWPOS, IWPOSCB, COMP 663 INTEGER BUFR( LBUFR ), IPOOL(LPOOL), 664 & ITLOC(N+KEEP(253)), FILS(N), 665 & ND( KEEP(28) ), FRERE( KEEP(28) ) 666 INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) 667 REAL :: RHS_MUMPS(KEEP(255)) 668 INTEGER(8) :: PTRAST (KEEP(28)) 669 INTEGER(8) :: PTRFAC (KEEP(28)) 670 INTEGER(8) :: PAMASTER(KEEP(28)) 671 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), 672 & STEP(N), PIMASTER(KEEP(28)), 673 & NSTK_S(KEEP(28)), 674 & NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28)) 675 INTEGER ISTEP_TO_INIV2(KEEP(71)), 676 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 677 DOUBLE PRECISION OPASSW, OPELIW 678 REAL DBLARR(KEEP8(26)) 679 INTEGER INTARR(KEEP8(27)) 680 LOGICAL, intent(in) :: SEND_LR 681 TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU 682 INTEGER, intent(in) :: LRGROUPS(N) 683 INTEGER :: NELIM 684 INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL 685 INCLUDE 'mumps_headers.h' 686 INTEGER(8) :: APOS, LREQA 687 INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH 688 INTEGER IERR, LREQI 689 INTEGER :: STATUS(MPI_STATUS_SIZE) 690 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 691 DOUBLE PRECISION FLOP1,FLOP2 692 NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) 693 IF (NSLAVES.EQ.0) THEN 694 WRITE(6,*) ' ERROR 1 in SMUMPS_SEND_FACTORED_BLK ' 695 CALL MUMPS_ABORT() 696 ENDIF 697 NPIV = IEND - IBEG_BLOCK + 1 698 NCOL = LDA_FS - IBEG_BLOCK + 1 699 APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + 700 & int(IBEG_BLOCK - 1,8) 701 IF (IBEG_BLOCK > 0) THEN 702 CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_BLOCK-1, LPIV, 703 & KEEP(50),2,FLOP1) 704 ELSE 705 FLOP1=0.0D0 706 ENDIF 707 CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, 708 & KEEP(50),2,FLOP2) 709 FLOP2 = FLOP1 - FLOP2 710 CALL SMUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) 711 IF ((NPIV.GT.0) .OR. 712 & ((NPIV.EQ.0).AND.(LASTBL)) 713 & ) THEN 714 PDEST = IOLDPS + 6 + KEEP(IXSZ) 715 IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN 716 NB_BLOC_FAC = NB_BLOC_FAC + 1 717 END IF 718 IERR = -1 719 DO WHILE (IERR .EQ.-1) 720 WIDTH = NSLAVES 721 CALL SMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, 722 & NPIV, FPERE, LASTBL, TIPIV, A(APOS), 723 & IW(PDEST), NSLAVES, KEEP, 724 & NB_BLOC_FAC, 725 & NSLAVES, WIDTH, COMM, 726 & NELIM, NPARTSASS, CURRENT_BLR_PANEL, 727 & SEND_LR, BLR_LorU, 728 & IERR ) 729 IF (IERR.EQ.-1) THEN 730 BLOCKING = .FALSE. 731 SET_IRECV = .TRUE. 732 MESSAGE_RECEIVED = .FALSE. 733 CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, 734 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 735 & MPI_ANY_SOURCE, MPI_ANY_TAG, 736 & STATUS, BUFR, LBUFR, 737 & LBUFR_BYTES, 738 & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, 739 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 740 & PTLUST_S, PTRFAC, 741 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, 742 & IERROR, COMM, 743 & NBPROCFILS, 744 & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 745 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 746 & FILS, PTRARW, PTRAIW, 747 & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, 748 & LPTRAR, NELT, FRTPTR, FRTELT, 749 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 750 & , LRGROUPS 751 & ) 752 IF (MESSAGE_RECEIVED) THEN 753 POSELT = PTRAST(STEP(INODE)) 754 APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + 755 & int(IBEG_BLOCK - 1,8) 756 ENDIF 757 IF ( IFLAG .LT. 0 ) GOTO 500 758 ENDIF 759 ENDDO 760 IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN 761 IF (IERR.EQ.-2) IFLAG = -17 762 IF (IERR.EQ.-3) IFLAG = -20 763 LREQA = int(NCOL,8)*int(NPIV,8) 764 LREQI = NPIV + 6 + 2*NSLAVES + 2 765 CALL MUMPS_SET_IERROR( 766 & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), 767 & IERROR) 768 GOTO 300 769 ENDIF 770 ENDIF 771 GOTO 500 772 300 CONTINUE 773 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 774 500 CONTINUE 775 RETURN 776 END SUBROUTINE SMUMPS_SEND_FACTORED_BLK 777 END MODULE SMUMPS_FAC_FRONT_TYPE2_AUX_M 778