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 ZMUMPS_FAC2_LDLT_M 14 CONTAINS 15 SUBROUTINE ZMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, 16 & N, INODE, FPERE, IW, LIW, A, LA, 17 & UU, NOFFW, 18 & NPVW, 19 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 20 & IFLAG, IERROR, IPOOL,LPOOL, 21 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 22 & LRLUS, COMP, 23 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 24 & PIMASTER, PAMASTER, 25 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 26 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 27 & FILS, PTRARW, PTRAIW, 28 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 29 & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, 30 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, 31 & DKEEP,PIVNUL_LIST,LPN_LIST 32 & , LRGROUPS 33 & ) 34 USE ZMUMPS_FAC_FRONT_AUX_M 35 USE ZMUMPS_FAC_FRONT_TYPE2_AUX_M 36 USE ZMUMPS_OOC 37 USE ZMUMPS_FAC_LR 38 USE ZMUMPS_LR_TYPE 39 USE ZMUMPS_LR_STATS 40 USE ZMUMPS_ANA_LR 41!$ USE OMP_LIB 42 IMPLICIT NONE 43 INCLUDE 'zmumps_root.h' 44 INTEGER COMM_LOAD, ASS_IRECV 45 INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 46 INTEGER(8) :: LA 47 INTEGER, TARGET :: IW( LIW ) 48 COMPLEX(kind=8) A( LA ) 49 DOUBLE PRECISION UU, SEUIL 50 TYPE (ZMUMPS_ROOT_STRUC) :: root 51 INTEGER COMM, MYID, LBUFR, LBUFR_BYTES 52 INTEGER LPTRAR, NELT 53 INTEGER ICNTL(40), KEEP(500) 54 INTEGER(8) KEEP8(150) 55 INTEGER NBFIN, SLAVEF, 56 & IFLAG, IERROR, LEAF, LPOOL 57 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS 58 INTEGER IWPOS, IWPOSCB, COMP 59 INTEGER NB_BLOC_FAC 60 INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) 61 INTEGER BUFR( LBUFR ), IPOOL(LPOOL), 62 & ITLOC(N+KEEP(253)), FILS(N), 63 & ND( KEEP(28) ), FRERE( KEEP(28) ) 64 INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) 65 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 66 INTEGER(8) :: PTRAST(KEEP(28)) 67 INTEGER(8) :: PTRFAC(KEEP(28)) 68 INTEGER(8) :: PAMASTER(KEEP(28)) 69 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), 70 & STEP(N), PIMASTER(KEEP(28)), 71 & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), 72 & PROCNODE_STEPS(KEEP(28)) 73 INTEGER ISTEP_TO_INIV2(KEEP(71)), 74 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 75 DOUBLE PRECISION OPASSW, OPELIW 76 COMPLEX(kind=8) DBLARR(KEEP8(26)) 77 INTEGER INTARR(KEEP8(27)) 78 LOGICAL AVOID_DELAYED 79 INTEGER LPN_LIST 80 INTEGER PIVNUL_LIST(LPN_LIST) 81 DOUBLE PRECISION DKEEP(230) 82 INTEGER :: LRGROUPS(N) 83 INTEGER(8) :: POSELT 84 INTEGER IOLDPS, allocok, K263 85 INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK 86 INTEGER NASS, LDAFS, IBEG_BLOCK 87 INTEGER :: IBEG_BLOCK_FOR_IPIV 88 LOGICAL LASTBL, LR_ACTIVATED 89 INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR 90 INTEGER Inextpiv 91 LOGICAL RESET_TO_ONE 92 INTEGER K109_SAVE 93 INTEGER XSIZE, NBKJIB_ORIG 94 DOUBLE PRECISION UUTEMP 95 INCLUDE 'mumps_headers.h' 96 INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV 97 DOUBLE PRECISION , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG 98 INTEGER :: SIZEDIAG_ORIG 99 INTEGER(8) :: LAFAC 100 INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, 101 & IDUMMY, NELIM 102 TYPE(IO_BLOCK) :: MonBloc 103 LOGICAL LAST_CALL 104 INTEGER PP_FIRST2SWAP_L, IFLAG_OOC 105 INTEGER PP_LastPIVRPTRFilled 106 INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR 107 INTEGER MAXI_CLUSTER, LWORK 108 INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP 109 INTEGER TTOT1, TTOT2, COUNT_RATETOT 110 INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR 111 DOUBLE PRECISION :: LOC_UPDT_TIME, 112 & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, 113 & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, 114 & LOC_TRSM_TIME, 115 & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, 116 & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME 117 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR 118 TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND 119 TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY 120 COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) 121 INTEGER, ALLOCATABLE :: JPVT(:) 122 DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) 123 COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) 124 INTEGER :: OMP_NUM 125 INTEGER PIVOT_OPTION 126 EXTERNAL ZMUMPS_BDC_ERROR 127 LOGICAL STATICMODE 128 DOUBLE PRECISION SEUIL_LOC 129 DOUBLE PRECISION GW_FACTCUMUL 130 INTEGER PIVSIZ,IWPOSPIV 131 COMPLEX(kind=8) ONE 132 PARAMETER (ONE=(1.0D0,0.0D0)) 133 NULLIFY(BLR_L) 134 IF (KEEP(486).NE.0) THEN 135 LOC_UPDT_TIME = 0.D0 136 LOC_PROMOTING_TIME = 0.D0 137 LOC_DEMOTING_TIME = 0.D0 138 LOC_CB_DEMOTING_TIME = 0.D0 139 LOC_FRPANELS_TIME = 0.0D0 140 LOC_FRFRONTS_TIME = 0.0D0 141 LOC_TRSM_TIME = 0.D0 142 LOC_LR_MODULE_TIME = 0.D0 143 LOC_FAC_I_TIME = 0.D0 144 LOC_FAC_MQ_TIME = 0.D0 145 LOC_FAC_SQ_TIME = 0.D0 146 ENDIF 147 IF (KEEP(206).GE.1) THEN 148 Inextpiv = 1 149 ELSE 150 Inextpiv = 0 151 ENDIF 152 INOPV = 0 153 IF(KEEP(97) .EQ. 0) THEN 154 STATICMODE = .FALSE. 155 ELSE 156 STATICMODE = .TRUE. 157 ENDIF 158 IF (AVOID_DELAYED) THEN 159 STATICMODE = .TRUE. 160 UUTEMP=UU 161 SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) 162 ELSE 163 SEUIL_LOC=SEUIL 164 UUTEMP=UU 165 ENDIF 166 PIVOT_OPTION = MIN(2,KEEP(468)) 167 IF (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) THEN 168 ENDIF 169 RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) 170 IF (RESET_TO_ONE) THEN 171 K109_SAVE = KEEP(109) 172 ENDIF 173 IBEG_BLOCK = 1 174 NB_BLOC_FAC = 0 175 XSIZE = KEEP(IXSZ) 176 IOLDPS = PTLUST_S(STEP( INODE )) 177 POSELT = PTRAST(STEP( INODE )) 178 NFRONT = IW(IOLDPS+XSIZE) 179 NASS = iabs(IW(IOLDPS+2+XSIZE)) 180 LDAFS = NASS 181 IW(IOLDPS+3+XSIZE) = -99999 182 LR_ACTIVATED= .FALSE. 183 NULLIFY(BEGS_BLR) 184 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 185 IF (NASS.LT.KEEP(4)) THEN 186 NBKJIB_ORIG = NASS 187 ELSE IF (NASS .GT. KEEP(3)) THEN 188 NBKJIB_ORIG = min( KEEP(6), NASS ) 189 ELSE 190 NBKJIB_ORIG = min( KEEP(5), NASS ) 191 ENDIF 192 IF (.not.LR_ACTIVATED) THEN 193 NBLR_ORIG = KEEP(420) 194 ELSE 195 NBLR_ORIG = -9999 196 ENDIF 197 IF (LR_ACTIVATED) THEN 198 K263 = 1 199 ELSE 200 K263 = KEEP(263) 201 IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN 202 K263 = 0 203 ENDIF 204 ENDIF 205 IEND_BLOCK = 0 206 IEND_BLR = 0 207 CURRENT_BLR = 0 208 ALLOCATE( IPIV( NASS ), stat = allocok ) 209 IF ( allocok .GT. 0 ) THEN 210 WRITE(*,*) MYID, ' : ZMUMPS_FAC2_LDLT failed to allocate ', 211 & NASS, ' integers' 212 IFLAG = -13 213 IERROR=NASS 214 GO TO 490 215 END IF 216 IF (KEEP(219).GE.3) THEN 217 SIZEDIAG_ORIG = NASS 218 ELSE 219 SIZEDIAG_ORIG = 1 220 ENDIF 221 ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) 222 IF ( allocok .GT. 0 ) THEN 223 WRITE(*,*) MYID, 224 & ' : FAC_NIV2 failed to allocate ', 225 & NASS, ' REAL/COMPLEX entries' 226 IFLAG=-13 227 IERROR=NASS 228 GO TO 490 229 END IF 230 IF (KEEP(201).EQ.1) THEN 231 IDUMMY = -9876 232 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) 233 LIWFAC = IW(IOLDPS+XXI) 234 TYPEFile = TYPEF_L 235 NextPiv2beWritten = 1 236 PP_FIRST2SWAP_L = NextPiv2beWritten 237 MonBloc%LastPanelWritten_L = 0 238 MonBloc%INODE = INODE 239 MonBloc%MASTER = .TRUE. 240 MonBloc%Typenode = 2 241 MonBloc%NROW = NASS 242 MonBloc%NCOL = NASS 243 MonBloc%NFS = NASS 244 MonBloc%Last = .FALSE. 245 MonBloc%LastPiv = -66666 246 MonBloc%INDICES => 247 & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) 248 & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) 249 ENDIF 250 IF (LR_ACTIVATED) THEN 251 CNT_NODES = CNT_NODES + 1 252 CALL SYSTEM_CLOCK(TTOT1) 253 ELSE IF (KEEP(486).GT.0) THEN 254 CALL SYSTEM_CLOCK(TTOT1FR) 255 ENDIF 256 HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE 257 IF (KEEP(201).EQ.1) THEN 258 IF (PIVOT_OPTION.LT.2) PIVOT_OPTION=2 259 ENDIF 260 IF (LR_ACTIVATED) THEN 261 CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, 262 & 0, LRGROUPS, NPARTSCB, 263 & NPARTSASS, BEGS_BLR) 264 CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, 265 & 0, KEEP(488), .FALSE., KEEP(472)) 266 NB_BLR = NPARTSASS + NPARTSCB 267 call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) 268 LWORK = MAXI_CLUSTER*MAXI_CLUSTER 269 OMP_NUM = 1 270#if defined(BLR_MT) 271!$ OMP_NUM = OMP_GET_MAX_THREADS() 272#endif 273 ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), 274 & RWORK(2*MAXI_CLUSTER*OMP_NUM), 275 & TAU(MAXI_CLUSTER*OMP_NUM), 276 & JPVT(MAXI_CLUSTER*OMP_NUM), 277 & WORK(LWORK*OMP_NUM),stat=allocok) 278 IF (allocok > 0) THEN 279 IFLAG = -13 280 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) 281 GOTO 480 282 ENDIF 283 ENDIF 284 LASTBL = .FALSE. 285 DO WHILE (IEND_BLR < NASS ) 286 CURRENT_BLR = CURRENT_BLR + 1 287 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 288 IF (.NOT. LR_ACTIVATED)THEN 289 IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) 290 ELSE 291 IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) 292 BEGS_BLR( CURRENT_BLR ) = IBEG_BLR 293 IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN 294 MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 295 LWORK = MAXI_CLUSTER*MAXI_CLUSTER 296 DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) 297 ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), 298 & RWORK(2*MAXI_CLUSTER*OMP_NUM), 299 & TAU(MAXI_CLUSTER*OMP_NUM), 300 & JPVT(MAXI_CLUSTER*OMP_NUM), 301 & WORK(LWORK*OMP_NUM),stat=allocok) 302 IF (allocok > 0) THEN 303 IFLAG = -13 304 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) 305 GOTO 480 306 ENDIF 307 ENDIF 308 ENDIF 309 IF (LR_ACTIVATED) THEN 310 CALL SYSTEM_CLOCK(T1) 311 ENDIF 312 DO WHILE (IEND_BLOCK < IEND_BLR ) 313 IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 314 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 315 50 CONTINUE 316 IF (K263.EQ.0) THEN 317 IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK 318 ELSE 319 IBEG_BLOCK_FOR_IPIV = IBEG_BLR 320 ENDIF 321 IF (LR_ACTIVATED) THEN 322 CALL SYSTEM_CLOCK(T1P) 323 ENDIF 324 CALL ZMUMPS_FAC_I_LDLT_NIV2( 325 & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, 326 & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, 327 & IBEG_BLOCK, IEND_BLOCK, 328 & NASS, IPIV, 329 & N,INODE,IW,LIW,A,LA,NOFFW,INOPV, 330 & IFLAG,IOLDPS,POSELT,UU, SEUIL_LOC, 331 & KEEP,KEEP8,PIVSIZ, 332 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, 333 & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, 334 & PP_LastPIVRPTRFilled, 335 & PIVOT_OPTION, 336 & Inextpiv, IEND_BLR) 337 IF (LR_ACTIVATED) THEN 338 CALL SYSTEM_CLOCK(T2P,CRP) 339 LOC_FAC_I_TIME = LOC_FAC_I_TIME + 340 & dble(T2P-T1P)/dble(CRP) 341 ENDIF 342 IF (IFLAG.LT.0) GOTO 490 343 IF(KEEP(109).GT. 0) THEN 344 IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN 345 IWPOSPIV = IOLDPS+IW(IOLDPS+1+XSIZE)+6 346 & +IW(IOLDPS+5+XSIZE) 347 PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+XSIZE) 348 ENDIF 349 ENDIF 350 IF (INOPV.EQ. 1) THEN 351 IF (STATICMODE) THEN 352 INOPV = -1 353 GOTO 50 354 ENDIF 355 LASTBL = .TRUE. 356 ELSE IF (INOPV .LE. 0) THEN 357 NPVW = NPVW + PIVSIZ 358 IF (LR_ACTIVATED) THEN 359 CALL SYSTEM_CLOCK(T1P) 360 ENDIF 361 CALL ZMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, 362 & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, 363 & LDAFS, POSELT,IFINB, 364 & PIVSIZ, 365 & KEEP(219), 366 & PIVOT_OPTION, IEND_BLR) 367 IF (LR_ACTIVATED) THEN 368 CALL SYSTEM_CLOCK(T2P,CRP) 369 LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + 370 & dble(T2P-T1P)/dble(CRP) 371 ENDIF 372 IF(PIVSIZ .EQ. 2) THEN 373 IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ 374 & IW(IOLDPS+5+XSIZE) 375 IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) 376 ENDIF 377 IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ 378 IF (IFINB.EQ.0) THEN 379 GOTO 50 380 ELSE IF (IFINB .EQ. -1) THEN 381 LASTBL = .TRUE. 382 ENDIF 383 ENDIF 384 NPIV = IW(IOLDPS+1+XSIZE) 385 IF ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) 386 & .AND. 387 & ( .NOT. LR_ACTIVATED .OR. 388 & ( (KEEP(485).EQ.0) .AND. (PIVOT_OPTION.GT.2) ) 389 & ) 390 & ) THEN 391 IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN 392 MonBloc%Last = .FALSE. 393 MonBloc%LastPiv= NPIV 394 LAST_CALL=.FALSE. 395 CALL ZMUMPS_OOC_IO_LU_PANEL( 396 & STRAT_TRY_WRITE, 397 & TYPEFile, A(POSELT), 398 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 399 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 400 IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC 401 IF (IFLAG .LT. 0 ) RETURN 402 ENDIF 403 ENDIF 404 IF (K263.eq.0) THEN 405 NELIM = IEND_BLR-NPIV 406 CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, 407 & N, INODE, FPERE, IW, LIW, 408 & IOLDPS, POSELT, A, LA, LDAFS, 409 & IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, 410 & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, 411 & IFLAG, IERROR, IPOOL,LPOOL, 412 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 413 & LRLUS, COMP, 414 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 415 & PIMASTER, PAMASTER, 416 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 417 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 418 & FILS, PTRARW, PTRAIW, 419 & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, 420 & LPTRAR, NELT, FRTPTR, FRTELT, 421 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 422 & , NELIM, .FALSE. 423 & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS 424 & ) 425 IF ( IFLAG .LT. 0 ) GOTO 500 426 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN 427 CALL ZMUMPS_RESET_TO_ONE( 428 & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), 429 & NPIV, IBEG_BLOCK, 430 & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, 431 & A, POSELT, LA, LDAFS) 432 ENDIF 433 IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) THEN 434 MonBloc%Last = .FALSE. 435 MonBloc%LastPiv= NPIV 436 LAST_CALL=.FALSE. 437 CALL ZMUMPS_OOC_IO_LU_PANEL( 438 & STRAT_TRY_WRITE, 439 & TYPEFile, A(POSELT), 440 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 441 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 442 IF (IFLAG_OOC .LT. 0 ) THEN 443 IFLAG = IFLAG_OOC 444 RETURN 445 ENDIF 446 ENDIF 447 ENDIF 448 IF ( IEND_BLR .GT. IEND_BLOCK ) THEN 449 IF (LR_ACTIVATED) THEN 450 CALL SYSTEM_CLOCK(T1P) 451 ENDIF 452 CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, 453 & NASS,NASS,IEND_BLR,INODE,A,LA, 454 & LDAFS, POSELT, 455 & KEEP,KEEP8, 456 & PIVOT_OPTION, .FALSE.) 457 IF (LR_ACTIVATED) THEN 458 CALL SYSTEM_CLOCK(T2P,CRP) 459 LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + 460 & dble(T2P-T1P)/dble(CRP) 461 ENDIF 462 ENDIF 463 END DO 464 NPIV = IW(IOLDPS+1+XSIZE) 465 IF (LR_ACTIVATED) THEN 466 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 467 LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + 468 & dble(T2-T1)/dble(COUNT_RATE) 469 CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, 470 & NPIV - IBEG_BLR + 1, 2, 1) 471 ENDIF 472 IF (LR_ACTIVATED) THEN 473 NELIM = IEND_BLOCK - NPIV 474 IF (IEND_BLR.NE.IEND_BLOCK) THEN 475 WRITE(*,*) "Internal error 1 in ZMUMPS_FAC2_LDLT", 476 & IEND_BLR, IEND_BLOCK 477 CALL MUMPS_ABORT() 478 ENDIF 479 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN 480 GOTO 101 481 ENDIF 482 ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) 483 CALL SYSTEM_CLOCK(T1) 484#if defined(BLR_MT) 485!$OMP PARALLEL 486#endif 487 CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, 488 & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, 489 & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, 490 & BLOCK, MAXI_CLUSTER, NELIM, 491 & .FALSE., 0, 0, 492 & 2, KEEP(483), KEEP(470), KEEP8 493 & ) 494 IF (IFLAG.LT.0) GOTO 400 495#if defined(BLR_MT) 496!$OMP BARRIER 497!$OMP MASTER 498#endif 499 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 500 LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + 501 & DBLE(T2-T1)/DBLE(COUNT_RATE) 502 CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, 503 & NB_BLR-CURRENT_BLR-NPARTSCB, 504 & NPARTSCB, 'V', 2) 505 CALL SYSTEM_CLOCK(T1) 506#if defined(BLR_MT) 507!$OMP END MASTER 508#endif 509 400 CONTINUE 510#if defined(BLR_MT) 511!$OMP END PARALLEL 512#endif 513 IF (IFLAG.LT.0) GOTO 490 514 ENDIF 515 101 CONTINUE 516 IF (K263.NE.0) THEN 517 NELIM = IEND_BLR-NPIV 518 BLR_SEND=>BLR_DUMMY 519 IF (associated(BLR_L)) THEN 520 BLR_SEND=>BLR_L 521 ENDIF 522 CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, 523 & N, INODE, FPERE, IW, LIW, 524 & IOLDPS, POSELT, A, LA, LDAFS, 525 & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, 526 & 527 & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, 528 & IFLAG, IERROR, IPOOL,LPOOL, 529 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 530 & LRLUS, COMP, 531 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 532 & PIMASTER, PAMASTER, 533 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 534 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 535 & FILS, PTRARW, PTRAIW, 536 & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, 537 & LPTRAR, NELT, FRTPTR, FRTELT, 538 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 539 & , NELIM, LR_ACTIVATED 540 & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS 541 & ) 542 IF ( IFLAG .LT. 0 ) GOTO 500 543 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN 544 CALL ZMUMPS_RESET_TO_ONE( 545 & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), 546 & NPIV, IBEG_BLR, 547 & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, 548 & A, POSELT, LA, LDAFS) 549 ENDIF 550 IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) THEN 551 MonBloc%Last = .FALSE. 552 MonBloc%LastPiv= NPIV 553 LAST_CALL=.FALSE. 554 CALL ZMUMPS_OOC_IO_LU_PANEL( 555 & STRAT_TRY_WRITE, 556 & TYPEFile, A(POSELT), 557 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 558 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 559 IF (IFLAG_OOC .LT. 0 ) THEN 560 IFLAG = IFLAG_OOC 561 RETURN 562 ENDIF 563 ENDIF 564 ENDIF 565 IF (.NOT. LR_ACTIVATED) THEN 566 CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, 567 & NASS,NASS,NASS,INODE,A,LA, 568 & LDAFS, POSELT, 569 & KEEP,KEEP8,PIVOT_OPTION, .TRUE.) 570 ELSE 571 NELIM = IEND_BLOCK - NPIV 572 IF (IEND_BLR.NE.IEND_BLOCK) CALL MUMPS_ABORT() 573#if defined(BLR_MT) 574!$OMP PARALLEL 575#endif 576 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 577 CALL ZMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, 578 & IFLAG, IERROR, NASS, 579 & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, 580 & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, 581 & MAXI_CLUSTER, NPIV, 582 & 2, 583 & KEEP(481), DKEEP(8), KEEP(477) 584 & ) 585 IF (IFLAG.LT.0) GOTO 450 586 450 CONTINUE 587#if defined(BLR_MT) 588!$OMP END PARALLEL 589#endif 590 IF (IFLAG.LT.0) GOTO 490 591 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 100 592 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 593 LOC_UPDT_TIME = LOC_UPDT_TIME + 594 & DBLE(T2-T1)/DBLE(COUNT_RATE) 595 IF (PIVOT_OPTION.LE.2) THEN 596 CALL SYSTEM_CLOCK(T1) 597 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, 598 & .TRUE., 599 & BEGS_BLR(CURRENT_BLR), 600 & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', 601 & NASS, KEEP(470)) 602 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 603 LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + 604 & dble(T2-T1)/dble(COUNT_RATE) 605 ELSE 606 IF (KEEP(485).NE.0) THEN 607 CALL SYSTEM_CLOCK(T1) 608 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, 609 & .FALSE., 610 & BEGS_BLR(CURRENT_BLR), 611 & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', 612 & NASS, KEEP(470)) 613 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 614 LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + 615 & DBLE(T2-T1)/DBLE(COUNT_RATE) 616 END IF 617 ENDIF 618 CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, 619 & .TRUE.) 620 DEALLOCATE(BLR_L) 621 NULLIFY(BLR_L) 622 ENDIF 623 IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) THEN 624 MonBloc%Last = .FALSE. 625 MonBloc%LastPiv= NPIV 626 LAST_CALL=.FALSE. 627 CALL ZMUMPS_OOC_IO_LU_PANEL( 628 & STRAT_TRY_WRITE, 629 & TYPEFile, A(POSELT), 630 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 631 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 632 IF (IFLAG_OOC < 0 ) THEN 633 IFLAG = IFLAG_OOC 634 GOTO 490 635 ENDIF 636 ENDIF 637 100 CONTINUE 638 END DO 639 IF (KEEP(201).EQ.1) THEN 640 STRAT = STRAT_WRITE_MAX 641 MonBloc%Last = .TRUE. 642 MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) 643 LAST_CALL = .TRUE. 644 CALL ZMUMPS_OOC_IO_LU_PANEL 645 & ( STRAT, TYPEFile, 646 & A(POSELT), LAFAC, MonBloc, 647 & NextPiv2beWritten, IDUMMY, 648 & IW(IOLDPS), LIWFAC, 649 & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) 650 IF (IFLAG_OOC .LT. 0 ) THEN 651 IFLAG = IFLAG_OOC 652 RETURN 653 ENDIF 654 CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, 655 & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) 656 ENDIF 657 GOTO 500 658 480 CONTINUE 659 write(*,*) 'Allocation problem in BLR routine 660 & ZMUMPS_FAC_FRONT_LDLT_TYPE2: ', 661 & 'not enough memory? memory requested = ' , IERROR 662 490 CONTINUE 663 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 664 500 CONTINUE 665 IF(allocated(IPIV)) DEALLOCATE( IPIV ) 666 IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) 667 IF (LR_ACTIVATED) THEN 668 CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 1, INODE, 669 & NELIM) 670 CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), 671 & INODE, NELIM) 672 CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) 673 LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 674 IF (allocated(RWORK)) DEALLOCATE(RWORK) 675 IF (allocated(WORK)) deallocate(WORK) 676 IF (allocated(TAU)) deallocate(TAU) 677 IF (allocated(JPVT)) deallocate(JPVT) 678 IF (allocated(BLOCK)) deallocate(BLOCK) 679 IF (associated(BEGS_BLR)) THEN 680 DEALLOCATE(BEGS_BLR) 681 NULLIFY(BEGS_BLR) 682 ENDIF 683 ENDIF 684 IF (KEEP(486).NE.0) THEN 685 IF (.NOT.LR_ACTIVATED) THEN 686 CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) 687 LOC_FRFRONTS_TIME = 688 & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) 689 CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 690 & 2) 691 ENDIF 692 CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, 693 & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, 694 & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, 695 & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, 696 & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, 697 & LOC_FAC_SQ_TIME) 698 ENDIF 699 RETURN 700 END SUBROUTINE ZMUMPS_FAC2_LDLT 701 SUBROUTINE ZMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, 702 & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST, LPN_LIST, 703 & A, POSELT, LA, LDAFS) 704 INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK 705 INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) 706 INTEGER, INTENT(IN) :: K109 707 INTEGER, INTENT(INOUT) :: K109_SAVE 708 INTEGER, INTENT(IN) :: LPN_LIST 709 INTEGER, INTENT(IN) :: PIVNUL_LIST(LPN_LIST) 710 INTEGER(8), INTENT(IN) :: POSELT, LA 711 INTEGER, INTENT(IN) :: LDAFS 712 COMPLEX(kind=8), INTENT(INOUT) :: A(LA) 713 LOGICAL :: TO_UPDATE 714 INTEGER :: I, JJ, K 715 COMPLEX(kind=8) ONE 716 PARAMETER (ONE=(1.0D0,0.0D0)) 717 DO K = K109_SAVE+1, K109 718 TO_UPDATE = .FALSE. 719 I = PIVNUL_LIST(K) 720 DO JJ=IBEG_BLOCK, NPIV 721 IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN 722 TO_UPDATE=.TRUE. 723 EXIT 724 ENDIF 725 ENDDO 726 IF (TO_UPDATE) THEN 727 A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE 728 TO_UPDATE=.FALSE. 729 ELSE 730 write(*,*) ' Internal error related ', 731 & 'to null pivot row detection' 732 CALL MUMPS_ABORT() 733 ENDIF 734 ENDDO 735 K109_SAVE = K109 736 RETURN 737 END SUBROUTINE ZMUMPS_RESET_TO_ONE 738 END MODULE ZMUMPS_FAC2_LDLT_M 739