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_FAC_LR 14 USE ZMUMPS_LR_CORE 15 USE ZMUMPS_LR_TYPE 16 USE ZMUMPS_LR_STATS 17 USE ZMUMPS_ANA_LR 18 IMPLICIT NONE 19 CONTAINS 20 SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT( 21 & A, LA, POSELT, IFLAG, IERROR, NFRONT, 22 & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, 23 & NELIM, IW2, BLOCK, 24 & MAXI_CLUSTER, NPIV, NIV, 25 & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT) 26!$ USE OMP_LIB 27 INTEGER(8), intent(in) :: LA 28 INTEGER(8), intent(in) :: POSELT 29 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, 30 & NELIM, MAXI_CLUSTER, NPIV, NIV 31 INTEGER, intent(out) :: IFLAG, IERROR 32 COMPLEX(kind=8), intent(inout) :: A(LA) 33 TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR-CURRENT_BLR) 34 COMPLEX(kind=8), INTENT(INOUT), TARGET :: BLOCK(:,:) 35 INTEGER, intent(in) :: IW2(*) 36 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR 37 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT 38 DOUBLE PRECISION,intent(in) :: TOLEPS 39 INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK 40 COMPLEX(kind=8), POINTER, DIMENSION(:) :: BLOCK_PTR 41 LOGICAL :: BUILDQ 42 INTEGER :: OMP_NUM 43 INTEGER :: IBIS 44#if defined(BLR_MT) 45 INTEGER :: CHUNK 46#endif 47 INTEGER(8) :: POSELTT, POSELTD 48 COMPLEX(kind=8) :: ONE, MONE, ZERO 49 PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) 50 PARAMETER (ZERO=(0.0D0,0.0D0)) 51 NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR 52 POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) 53 & + int(BEGS_BLR(CURRENT_BLR) - 1,8) 54 OMP_NUM = 0 55 BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,1) 56#if defined(BLR_MT) 57 CHUNK = 1 58!$OMP DO SCHEDULE(DYNAMIC, CHUNK) 59!$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, BLOCK_PTR, 60!$OMP& MID_RANK, BUILDQ) 61#endif 62 DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) 63 IF (IFLAG.LT.0) CYCLE 64 I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 65 J = IBIS - I*(I-1)/2 66#if defined(BLR_MT) 67!$ OMP_NUM = OMP_GET_THREAD_NUM() 68 BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1) 69#endif 70 POSELTT = POSELT + int(NFRONT,8) * 71 & int(BEGS_BLR(CURRENT_BLR+I)-1,8) 72 & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) 73 CALL ZMUMPS_LRGEMM3('N', 'T', MONE, 74 & BLR_L(J),BLR_L(I), ONE, A, LA, 75 & POSELTT, NFRONT, 1, NIV, IFLAG, IERROR, 76 & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, 77 & MID_RANK, BUILDQ, 78 & POSELTD, NFRONT, 79 & IW2, 80 & BLOCK_PTR, 81 & MAXI_CLUSTER) 82 IF (IFLAG.LT.0) CYCLE 83 CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_L(J), BLR_L(I), 'N', 84 & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ 85 & , (I.EQ.J) 86 & ) 87 ENDDO 88#if defined(BLR_MT) 89!$OMP END DO 90#endif 91 END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT 92 SUBROUTINE ZMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, 93 & IFLAG, IERROR, NCOL, NROW, POSBLOCFACTO, LD_BLOCFACTO, 94 & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, 95 & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, 96 & CURRENT_BLR_LM, CURRENT_BLR_LS, 97 & IW2, BLOCK, 98 & MAXI_CLUSTER, 99 & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT 100 & ) 101!$ USE OMP_LIB 102 INTEGER(8), intent(in) :: LA, POSBLOCFACTO 103 COMPLEX(kind=8), intent(inout) :: A(LA) 104 INTEGER(8), intent(in) :: POSELT 105 INTEGER, intent(out) :: IFLAG, IERROR 106 INTEGER, intent(in) :: NCOL, NROW, IW2(*), 107 & MAXI_CLUSTER, LD_BLOCFACTO 108 INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, 109 & ISHIFT_LM, ISHIFT_LS, 110 & CURRENT_BLR_LM, CURRENT_BLR_LS 111 COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER) 112 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS 113 TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), 114 & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) 115 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT 116 DOUBLE PRECISION,intent(in) :: TOLEPS 117 INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK 118 LOGICAL :: BUILDQ 119 INTEGER :: IBIS 120#if defined(BLR_MT) 121 INTEGER :: CHUNK 122#endif 123 INTEGER(8) :: POSELTT, POSELTD 124 COMPLEX(kind=8) :: ONE, MONE, ZERO 125 PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) 126 PARAMETER (ZERO=(0.0D0,0.0D0)) 127 NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM 128 NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS 129 POSELTD = POSBLOCFACTO 130#if defined(BLR_MT) 131 CHUNK = 1 132!$OMP DO SCHEDULE(DYNAMIC,CHUNK) 133!$OMP& PRIVATE(I, J, POSELTT, MID_RANK, BUILDQ) 134#endif 135 DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) 136 IF (IFLAG.LT.0) CYCLE 137 I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 138 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM 139 POSELTT = POSELT 140 & + int(NCOL,8) * 141 & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) 142 & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) 143 CALL ZMUMPS_LRGEMM3('N', 'T', MONE, 144 & BLR_LM(J),BLR_LS(I), ONE, A, LA, 145 & POSELTT, NCOL, 146 & 1, 2, IFLAG, IERROR, 147 & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, 148 & MID_RANK, BUILDQ, 149 & POSELTD, LD_BLOCFACTO, 150 & IW2, 151 & BLOCK, 152 & MAXI_CLUSTER) 153 IF (IFLAG.LT.0) CYCLE 154 CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LM(J), BLR_LS(I), 155 & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, 156 & .FALSE.) 157 ENDDO 158#if defined(BLR_MT) 159!$OMP END DO 160 IF (IFLAG.LT.0) RETURN 161!$OMP DO SCHEDULE(DYNAMIC,CHUNK) 162!$OMP& PRIVATE(I, J, POSELTT, MID_RANK, BUILDQ) 163#endif 164 DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) 165 IF (IFLAG.LT.0) CYCLE 166 I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 167 J = IBIS - I*(I-1)/2 168 POSELTT = POSELT 169 & + int(NCOL,8) * 170 & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) 171 & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) 172 CALL ZMUMPS_LRGEMM3('N', 'T', MONE, 173 & BLR_LS(J),BLR_LS(I), ONE, A, LA, 174 & POSELTT, NCOL, 175 & 1, 2, IFLAG, IERROR, 176 & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, 177 & MID_RANK, BUILDQ, 178 & POSELTD, LD_BLOCFACTO, 179 & IW2, 180 & BLOCK, 181 & MAXI_CLUSTER) 182 IF (IFLAG.LT.0) CYCLE 183 CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LS(J), BLR_LS(I), 184 & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, 185 & (I.EQ.J)) 186 ENDDO 187#if defined(BLR_MT) 188!$OMP END DO 189#endif 190 END SUBROUTINE ZMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT 191 SUBROUTINE ZMUMPS_BLR_UPDATE_NELIM_VAR( 192 & A, LA, POSELT, IFLAG, IERROR, NFRONT, 193 & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, 194 & FIRST_BLOCK, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM) 195!$ USE OMP_LIB 196 INTEGER(8), intent(in) :: LA 197 INTEGER(8), intent(in) :: POSELT 198 INTEGER, intent(in) :: NFRONT, NB_BLR_L, CURRENT_BLR, 199 & NELIM, SYM, NIV, FIRST_BLOCK 200 LOGICAL, intent(in) :: LBANDSLAVE 201 INTEGER, intent(out) :: IFLAG, IERROR 202 INTEGER, intent(in) :: ISHIFT 203 COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) 204 TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) 205 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 206 INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL, IS 207 INTEGER :: allocok 208 INTEGER(8) :: POSELT_INCB, POSELT_TOP 209 COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK 210 COMPLEX(kind=8) :: ONE, MONE, ZERO 211 PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) 212 PARAMETER (ZERO=(0.0D0,0.0D0)) 213 NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR 214 IF (LBANDSLAVE) THEN 215 IS = ISHIFT 216 ELSE 217 IS = 0 218 ENDIF 219#if defined(BLR_MT) 220!$OMP SINGLE 221#endif 222 IF (NELIM.NE.0) THEN 223 DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L 224 KL = BLR_L(I)%K 225 ML = BLR_L(I)%M 226 NL = BLR_L(I)%N 227 IF (BLR_L(I)%ISLR) THEN 228 IF (KL.GT.0) THEN 229 allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) 230 IF (allocok .GT. 0) THEN 231 IFLAG = -13 232 IERROR = NELIM * KL 233 write(*,*) 'Allocation problem in BLR routine 234 & ZMUMPS_BLR_UPDATE_NELIM_VAR: ', 235 & 'not enough memory? memory requested = ', IERROR 236 GOTO 100 237 ENDIF 238 POSELT_TOP = POSELT 239 & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) 240 & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) 241 POSELT_INCB = POSELT 242 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) 243 & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) 244 CALL zgemm('N' , 'T' , NELIM, KL, NL , ONE , 245 & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , 246 & ZERO , TEMP_BLOCK , NELIM) 247 CALL zgemm('N' , 'T' , NELIM , ML , KL , MONE , 248 & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , 249 & ONE , A(POSELT_INCB) , NFRONT) 250 deallocate(TEMP_BLOCK) 251 ENDIF 252 ELSE 253 IF (SYM.EQ.0) THEN 254 POSELT_TOP = POSELT 255 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) 256 & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) 257 POSELT_INCB = POSELT 258 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) 259 & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) 260 CALL zgemm('N' , 'T' , NELIM, ML, NL , MONE , 261 & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , 262 & ONE , A(POSELT_INCB) , NFRONT) 263 ELSE 264 POSELT_TOP = POSELT + int(NFRONT,8) 265 & * int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) 266 & + int((BEGS_BLR_L(CURRENT_BLR)-1),8) 267 POSELT_INCB = POSELT 268 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) 269 & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) 270 CALL zgemm('T' , 'T' , NELIM, ML, NL , MONE , 271 & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , 272 & ONE , A(POSELT_INCB) , NFRONT) 273 ENDIF 274 ENDIF 275 ENDDO 276 ENDIF 277 100 CONTINUE 278#if defined(BLR_MT) 279!$OMP END SINGLE 280#endif 281 END SUBROUTINE ZMUMPS_BLR_UPDATE_NELIM_VAR 282 SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING( 283 & A, LA, POSELT, IFLAG, IERROR, NFRONT, 284 & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, 285 & BLR_U, 286 & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, K470, 287 & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT) 288!$ USE OMP_LIB 289 INTEGER(8), intent(in) :: LA 290 INTEGER(8), intent(in) :: POSELT 291 INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, 292 & CURRENT_BLR, K470, 293 & NELIM, NIV, SYM 294 INTEGER, intent(out) :: IFLAG, IERROR 295 LOGICAL, intent(in) :: LBANDSLAVE 296 INTEGER, intent(in) :: ISHIFT 297 COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) 298 TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) 299 TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) 300 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 301 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT 302 DOUBLE PRECISION,intent(in) :: TOLEPS 303 INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, 304 & KL, ML, NL, J, IS, MID_RANK 305 INTEGER :: allocok 306 LOGICAL :: BUILDQ 307 INTEGER :: OMP_NUM 308 CHARACTER(len=1) :: TRANSB1 309 INTEGER :: IBIS 310#if defined(BLR_MT) 311 INTEGER :: CHUNK 312#endif 313 INTEGER(8) :: POSELT_INCB, POSELT_TOP 314 COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK 315 COMPLEX(kind=8) :: ONE, MONE, ZERO 316 PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) 317 PARAMETER (ZERO=(0.0D0,0.0D0)) 318 NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR 319 NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR 320 IF (LBANDSLAVE) THEN 321 IS = ISHIFT 322 ELSE 323 IS = 0 324 ENDIF 325#if defined(BLR_MT) 326!$OMP SINGLE 327#endif 328 IF (NELIM.NE.0) THEN 329 DO I = 1, NB_BLOCKS_PANEL_L 330 KL = BLR_L(I)%K 331 ML = BLR_L(I)%M 332 NL = BLR_L(I)%N 333 IF (BLR_L(I)%ISLR) THEN 334 IF (KL.GT.0) THEN 335 allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) 336 IF (allocok .GT. 0) THEN 337 IFLAG = -13 338 IERROR = NELIM * KL 339 write(*,*) 'Allocation problem in BLR routine 340 & ZMUMPS_BLR_UPDATE_TRAILING: ', 341 & 'not enough memory? memory requested = ', IERROR 342 GOTO 100 343 ENDIF 344 POSELT_TOP = POSELT 345 & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) 346 & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) 347 POSELT_INCB = POSELT 348 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) 349 & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) 350 CALL zgemm('N' , 'T' , NELIM, KL, NL , ONE , 351 & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , 352 & ZERO , TEMP_BLOCK , NELIM) 353 CALL zgemm('N' , 'T' , NELIM , ML , KL , MONE , 354 & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , 355 & ONE , A(POSELT_INCB) , NFRONT) 356 deallocate(TEMP_BLOCK) 357 ENDIF 358 ELSE 359 POSELT_TOP = POSELT 360 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) 361 & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) 362 POSELT_INCB = POSELT 363 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) 364 & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) 365 CALL zgemm('N' , 'T' , NELIM, ML, NL , MONE , 366 & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , 367 & ONE , A(POSELT_INCB) , NFRONT) 368 ENDIF 369 ENDDO 370 ENDIF 371 100 CONTINUE 372#if defined(BLR_MT) 373!$OMP END SINGLE 374#endif 375 IF (IFLAG.LT.0) GOTO 200 376 OMP_NUM = 0 377#if defined(BLR_MT) 378 CHUNK = 1 379!$OMP DO SCHEDULE(DYNAMIC,CHUNK) 380!$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) 381#endif 382 DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) 383 IF (IFLAG.LT.0) CYCLE 384 I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 385 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U 386 POSELT_INCB = POSELT 387 & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) 388 & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) 389 IF (SYM.EQ.0) THEN 390 IF (K470.EQ.1) THEN 391 TRANSB1 = 'N' 392 ELSE 393 TRANSB1 = 'T' 394 ENDIF 395 CALL ZMUMPS_LRGEMM3(TRANSB1, 'T', MONE, BLR_U(J), 396 & BLR_L(I), ONE, A, LA, POSELT_INCB, 397 & NFRONT, 0, NIV, IFLAG, IERROR, 398 & COMPRESS_MID_PRODUCT, TOLEPS, 399 & KPERCENT, MID_RANK, BUILDQ) 400 IF (IFLAG.LT.0) CYCLE 401 CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 402 & TRANSB1, 403 & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) 404 ELSE 405 CALL ZMUMPS_LRGEMM3('N', 'T', MONE, BLR_U(J), 406 & BLR_L(I), ONE, A, LA, POSELT_INCB, 407 & NFRONT, 0, NIV, IFLAG, IERROR, 408 & COMPRESS_MID_PRODUCT, TOLEPS, 409 & KPERCENT, MID_RANK, BUILDQ) 410 IF (IFLAG.LT.0) CYCLE 411 CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 'N', 412 & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) 413 ENDIF 414 ENDDO 415#if defined(BLR_MT) 416!$OMP END DO 417#endif 418 200 CONTINUE 419 END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING 420 SUBROUTINE ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, 421 & COPY_DENSE_BLOCKS, 422 & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, 423 & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, 424 & LD_OR_NPIV, K470, 425 & BEG_I_IN, END_I_IN) 426!$ USE OMP_LIB 427 INTEGER(8), intent(in) :: LA 428 COMPLEX(kind=8), intent(inout) :: A(LA) 429 INTEGER(8), intent(in) :: POSELT 430 LOGICAL, intent(in) :: COPY_DENSE_BLOCKS 431 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR 432 INTEGER, intent(in) :: BEGS_BLR_DIAG, 433 & BEGS_BLR_FIRST_OFFDIAG 434 TYPE(LRB_TYPE),intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) 435 CHARACTER(len=1) :: DIR 436 INTEGER, intent(in) :: LD_OR_NPIV, K470 437 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN 438 INTEGER :: IP, M, N, BIP, BEG_I, END_I 439#if defined(BLR_MT) 440 INTEGER :: LAST_IP, CHUNK 441#endif 442 INTEGER :: K, I 443 INTEGER(8) :: POSELT_BLOCK, NFRONT8, LD_BLK_IN_FRONT 444 COMPLEX(kind=8) :: ONE, ALPHA, ZERO 445 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 446 PARAMETER (ZERO=(0.0D0,0.0D0)) 447 IF(present(BEG_I_IN)) THEN 448 BEG_I = BEG_I_IN 449 ELSE 450 BEG_I = CURRENT_BLR+1 451 ENDIF 452 IF(present(END_I_IN)) THEN 453 END_I = END_I_IN 454 ELSE 455 END_I = NB_BLR 456 ENDIF 457 NFRONT8 = int(NFRONT,8) 458 LD_BLK_IN_FRONT = NFRONT8 459 BIP = BEGS_BLR_FIRST_OFFDIAG 460#if defined(BLR_MT) 461 LAST_IP = BEG_I 462 CHUNK = 1 463!$OMP PARALLEL DO PRIVATE(POSELT_BLOCK, M, N, K, I) 464!$OMP& FIRSTPRIVATE(BIP, LAST_IP) SCHEDULE(DYNAMIC, CHUNK) 465#endif 466 DO IP = BEG_I, END_I 467#if defined(BLR_MT) 468 DO I = 1, IP - LAST_IP 469 IF (DIR .eq. 'V') THEN 470 BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M 471 ELSE 472 IF (K470.EQ.1) THEN 473 BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M 474 ELSE 475 BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N 476 ENDIF 477 ENDIF 478 ENDDO 479 LAST_IP = IP 480#endif 481 IF (DIR .eq. 'V') THEN 482 IF (BIP .LE. LD_OR_NPIV) THEN 483 POSELT_BLOCK = POSELT + NFRONT8*int(BIP-1,8) + 484 & int(BEGS_BLR_DIAG - 1,8) 485 ELSE 486 POSELT_BLOCK = POSELT +NFRONT8*int(LD_OR_NPIV,8)+ 487 & int(BEGS_BLR_DIAG - 1,8) 488 POSELT_BLOCK = POSELT_BLOCK + 489 & int(LD_OR_NPIV,8)*int(BIP-1-LD_OR_NPIV,8) 490 LD_BLK_IN_FRONT=int(LD_OR_NPIV,8) 491 ENDIF 492 ELSE 493 POSELT_BLOCK = POSELT + 494 & NFRONT8*int(BEGS_BLR_DIAG-1,8) + 495 & int(BIP - 1,8) 496 ENDIF 497 M = BLR_PANEL(IP-CURRENT_BLR)%M 498 N = BLR_PANEL(IP-CURRENT_BLR)%N 499 K = BLR_PANEL(IP-CURRENT_BLR)%K 500 IF ((BLR_PANEL(IP-CURRENT_BLR)%ISLR).AND. 501 & (BLR_PANEL(IP-CURRENT_BLR)%LRFORM.EQ.1)) THEN 502 IF (K.EQ.0) THEN 503 IF (K470.NE.1.OR.DIR .eq. 'V') THEN 504 DO I = 1, M 505 A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : 506 & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT 507 & + int(N-1,8)) 508 & = ZERO 509 ENDDO 510 ELSE 511 DO I = 1, N 512 A(POSELT_BLOCK+int(I-1,8)*NFRONT8: 513 & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) 514 & = ZERO 515 ENDDO 516 ENDIF 517 GOTO 1800 518 ENDIF 519 IF (K470.NE.1.OR.DIR .eq. 'V') THEN 520 CALL zgemm('T', 'T', N, M, K, ONE , 521 & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, 522 & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, 523 & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) 524 ELSE 525 CALL zgemm('N', 'N', M, N, K, ONE , 526 & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, 527 & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, 528 & ZERO, A(POSELT_BLOCK), NFRONT) 529 ENDIF 530 ELSE IF (COPY_DENSE_BLOCKS) THEN 531 IF (K470.NE.1.OR.DIR .eq. 'V') THEN 532 DO I = 1, M 533 A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : 534 & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT 535 & + int(N-1,8)) 536 & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) 537 ENDDO 538 ELSE 539 DO I = 1, N 540 A(POSELT_BLOCK+int(I-1,8)*NFRONT8: 541 & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) 542 & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) 543 ENDDO 544 ENDIF 545 ENDIF 546 1800 CONTINUE 547#if !defined(BLR_MT) 548 IF (DIR .eq. 'V') THEN 549 BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M 550 ELSE 551 IF (K470.EQ.1) THEN 552 BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M 553 ELSE 554 BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N 555 ENDIF 556 ENDIF 557#endif 558 END DO 559#if defined(BLR_MT) 560!$OMP END PARALLEL DO 561#endif 562 END SUBROUTINE ZMUMPS_DECOMPRESS_PANEL 563 SUBROUTINE ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, 564 & BEGS_BLR_L, NB_BLR_L, 565 & BEGS_BLR_U, NB_BLR_U, NPARTSASS_U, 566 & TOLEPS, NASS, NROW, 567 & SYM, WORK, TAU, JPVT, LWORK, RWORK, 568 & BLOCK, MAXI_CLUSTER, INODE, NIV, 569 & LBANDSLAVE, ISHIFT,KPERCENT) 570 INTEGER(8), intent(in) :: LA 571 COMPLEX(kind=8), intent(inout) :: A(LA) 572 INTEGER(8), intent(in) :: POSELT 573 INTEGER, intent(in) :: NFRONT, INODE 574 INTEGER, INTENT(IN) :: NIV, NROW, KPERCENT 575 INTEGER :: MAXI_CLUSTER, LWORK, SYM, NASS, 576 & NB_BLR_L, NB_BLR_U, NPARTSASS_U 577 DOUBLE PRECISION,intent(in) :: TOLEPS 578 LOGICAL, intent(in) :: LBANDSLAVE 579 INTEGER, intent(in) :: ISHIFT 580 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 581 COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER) 582 DOUBLE PRECISION,DIMENSION(:) :: RWORK 583 COMPLEX(kind=8), DIMENSION(:) :: WORK, TAU 584 INTEGER, DIMENSION(:) :: JPVT 585 INTEGER :: M, N, NCB, BEGLOOP, RANK, MAXRANK, FRONT_CB_BLR_SAVINGS 586 INTEGER :: INFO, I, J, JJ, IB, JDEB, IS 587 INTEGER :: allocok, MREQ 588 INTEGER(8) :: POSELT_BLOCK 589 DOUBLE PRECISION :: HR_COST, BUILDQ_COST, CB_DEMOTE_COST, 590 & CB_PROMOTE_COST 591 INTEGER T1, T2, COUNT_RATE 592 DOUBLE PRECISION :: LOC_PROMOTING_TIME 593 DOUBLE PRECISION :: LOC_CB_DEMOTING_TIME 594 COMPLEX(kind=8), ALLOCATABLE :: R(:,:) 595 COMPLEX(kind=8) :: ONE, ZERO 596 PARAMETER (ONE=(1.0D0,0.0D0)) 597 PARAMETER (ZERO=(0.0D0,0.0D0)) 598 LOC_PROMOTING_TIME = 0.0D0 599 LOC_CB_DEMOTING_TIME = 0.0D0 600 CB_DEMOTE_COST = 0.0D0 601 CB_PROMOTE_COST = 0.0D0 602 allocate(R(MAXI_CLUSTER,MAXI_CLUSTER),stat=allocok) 603 IF (allocok .GT. 0) THEN 604 MREQ=MAXI_CLUSTER*MAXI_CLUSTER 605 write(*,*) 'Allocation problem in BLR routine 606 & ZMUMPS_FAKE_COMPRESS_CB: ', 607 & 'not enough memory? memory requested = ', MREQ 608 CALL MUMPS_ABORT() 609 ENDIF 610 FRONT_CB_BLR_SAVINGS = 0 611 NCB = NFRONT - NASS 612 IF (NCB.LE.0) RETURN 613 IF (LBANDSLAVE) THEN 614 IS = ISHIFT 615 ELSE 616 IS = 0 617 ENDIF 618 DO J = NPARTSASS_U+1, NB_BLR_U 619 IF (NIV.EQ.1) THEN 620 IF (SYM.GT.0) THEN 621 BEGLOOP = J 622 ELSE 623 BEGLOOP = NPARTSASS_U + 1 624 ENDIF 625 ELSE 626 BEGLOOP = 2 627 ENDIF 628 IF ((BEGS_BLR_U(J+1)+IS).LE.NASS+1) CYCLE 629 JDEB = max(BEGS_BLR_U(J)+IS,NASS+1) 630 N = BEGS_BLR_U(J+1)+IS-JDEB 631 DO I = BEGLOOP, NB_BLR_L 632 CALL SYSTEM_CLOCK(T1) 633 JPVT = 0 634 M = BEGS_BLR_L(I+1)-BEGS_BLR_L(I) 635 POSELT_BLOCK = POSELT 636 & + int(NFRONT,8) * int((BEGS_BLR_L(I)-1),8) 637 & + int(JDEB - 1,8) 638 DO IB=1,M 639 IF((I.EQ.J).AND.(SYM.GT.0).AND.(NIV.EQ.1)) THEN 640 BLOCK(IB,1:IB) = 641 & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : 642 & POSELT_BLOCK+ 643 & int((IB-1),8)*int(NFRONT,8)+int(IB-1,8) ) 644 BLOCK(1:IB-1,IB) = BLOCK(IB,1:IB-1) 645 ELSE 646 BLOCK(IB,1:N) = 647 & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : 648 & POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8)+int(N-1,8) ) 649 ENDIF 650 END DO 651 MAXRANK = floor(dble(M*N)/dble(M+N)) 652 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) 653 CALL ZMUMPS_TRUNCATED_RRQR( M, N, BLOCK(1,1), 654 & MAXI_CLUSTER, JPVT(1), TAU(1), WORK(1), N, 655 & RWORK(1), TOLEPS, RANK, MAXRANK, INFO ) 656 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 657 LOC_CB_DEMOTING_TIME = LOC_CB_DEMOTING_TIME 658 & + DBLE(T2-T1)/DBLE(COUNT_RATE) 659 IF (INFO < 0) THEN 660 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, 661 & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK 662 & IN CB (FAKE COMPRESSION anyway) " 663 CALL MUMPS_ABORT() 664 END IF 665 HR_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(RANK)/3.0D0 666 & + 4.0D0*dble(RANK)*dble(M)*dble(N) 667 & - 2.0D0*dble((M+N))*dble(RANK)*dble(RANK) 668 IF (RANK.LE.MAXRANK) THEN 669 CALL SYSTEM_CLOCK(T1) 670 DO JJ=1, N 671 R(1:MIN(RANK,JJ),JPVT(JJ)) = 672 & BLOCK(1:MIN(RANK,JJ),JJ) 673 IF(JJ.LT.RANK) R(MIN(RANK,JJ)+1: 674 & RANK,JPVT(JJ))= ZERO 675 END DO 676 CALL zungqr(M, RANK, RANK, 677 & BLOCK(1,1), MAXI_CLUSTER, 678 & TAU(1), WORK(1), LWORK, INFO) 679 CALL zgemm('T', 'T', N, M, RANK, ONE , 680 & R , MAXI_CLUSTER, 681 & BLOCK(1,1) , MAXI_CLUSTER, 682 & ZERO, A(POSELT_BLOCK), NFRONT) 683 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 684 LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + 685 & DBLE(T2-T1)/DBLE(COUNT_RATE) 686 BUILDQ_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(M) 687 & - dble(RANK)*dble(RANK)*dble(RANK) 688 & 689 CB_DEMOTE_COST = CB_DEMOTE_COST + 690 & (HR_COST+BUILDQ_COST) 691 CB_PROMOTE_COST = CB_PROMOTE_COST + 692 & 2.0D0*dble(RANK)*dble(M)*dble(N) 693 FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + 694 & (M-RANK)*(N-RANK)-RANK*RANK 695 ELSE 696 CB_DEMOTE_COST = CB_DEMOTE_COST + HR_COST 697 END IF 698 END DO 699 END DO 700 deallocate(R) 701 CALL STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, SYM, NIV, INODE, 702 & FRONT_CB_BLR_SAVINGS) 703 CALL UPDATE_FLOP_STATS_CB_DEMOTE(CB_DEMOTE_COST, NIV) 704 CALL UPDATE_FLOP_STATS_CB_PROMOTE(CB_PROMOTE_COST, NIV) 705 CALL UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) 706 CALL UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) 707 END SUBROUTINE ZMUMPS_FAKE_COMPRESS_CB 708 SUBROUTINE ZMUMPS_COMPRESS_PANEL( 709 & A, LA, POSELT, IFLAG, IERROR, NFRONT, 710 & BEGS_BLR, NB_BLR, TOLEPS, K473, BLR_PANEL, CURRENT_BLR, 711 & DIR, WORK, TAU, JPVT, 712 & LWORK, RWORK, BLOCK, 713 & MAXI_CLUSTER, NELIM, 714 & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, 715 & K470, KEEP8, K480, 716 & BEG_I_IN, END_I_IN 717 & ) 718!$ USE OMP_LIB 719 INTEGER(8), intent(in) :: LA 720 INTEGER(8), intent(in) :: POSELT 721 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV 722 INTEGER, intent(out) :: IFLAG, IERROR 723 TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) 724 COMPLEX(kind=8), intent(inout) :: A(LA) 725 DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK 726 COMPLEX(kind=8), TARGET, DIMENSION(:,:) :: BLOCK 727 COMPLEX(kind=8), TARGET, DIMENSION(:) :: WORK, TAU 728 INTEGER, TARGET, DIMENSION(:) :: JPVT 729 INTEGER, POINTER :: BEGS_BLR(:) 730 INTEGER(8) :: KEEP8(150) 731 INTEGER, OPTIONAL, intent(in) :: K480 732 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN 733 INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, K470 734 LOGICAL, intent(in) :: LBANDSLAVE 735 INTEGER :: MAXI_CLUSTER, LWORK, NELIM 736 DOUBLE PRECISION,intent(in) :: TOLEPS 737 CHARACTER(len=1) :: DIR 738 INTRINSIC maxval 739 INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK 740 INTEGER :: INFO, I, J, IS, BEG_I, END_I 741 INTEGER(8) :: POSELT_BLOCK 742 LOGICAL :: ISLR 743 COMPLEX(kind=8) :: ONE, ALPHA, ZERO 744 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 745 PARAMETER (ZERO=(0.0D0,0.0D0)) 746 INTEGER :: OMP_NUM 747 DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR 748 COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: BLOCK_THR 749 COMPLEX(kind=8), POINTER, DIMENSION(:) :: WORK_THR, TAU_THR 750 INTEGER, POINTER, DIMENSION(:) :: JPVT_THR 751#if defined(BLR_MT) 752 INTEGER :: CHUNK 753#endif 754 IF(present(BEG_I_IN)) THEN 755 BEG_I = BEG_I_IN 756 ELSE 757 BEG_I = CURRENT_BLR+1 758 ENDIF 759 IF(present(END_I_IN)) THEN 760 END_I = END_I_IN 761 ELSE 762 END_I = NB_BLR 763 ENDIF 764 IF (LBANDSLAVE) THEN 765 IS = ISHIFT 766 ELSE 767 IS=0 768 ENDIF 769 IF (DIR .eq. 'V') THEN 770 IF (LBANDSLAVE) THEN 771 N = NPIV 772 ELSE 773 N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM 774 ENDIF 775 ELSE IF (DIR .eq. 'H') THEN 776 IF (K470.EQ.1) THEN 777 N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM 778 ELSE 779 M = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM 780 ENDIF 781 ELSE 782 WRITE(*,*) " WRONG ARGUMENT IN ZMUMPS_COMPRESS_PANEL " 783 CALL MUMPS_ABORT() 784 END IF 785 NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR 786 OMP_NUM = 0 787#if defined(BLR_MT) 788 CHUNK = 1 789!$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM) 790!$OMP& SCHEDULE(DYNAMIC,CHUNK) 791#endif 792 DO IP = BEG_I, END_I 793 IF (IFLAG.LT.0) CYCLE 794#if defined(BLR_MT) 795!$ OMP_NUM = OMP_GET_THREAD_NUM() 796#endif 797 BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: 798 & (OMP_NUM+1)*MAXI_CLUSTER) 799 JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: 800 & (OMP_NUM+1)*MAXI_CLUSTER) 801 TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: 802 & (OMP_NUM+1)*MAXI_CLUSTER) 803 WORK_THR => WORK(OMP_NUM*LWORK+1: 804 & (OMP_NUM+1)*LWORK) 805 RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: 806 & (OMP_NUM+1)*2*MAXI_CLUSTER) 807 IF (DIR .eq. 'V') THEN 808 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) 809 POSELT_BLOCK = POSELT + 810 & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + 811 & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) 812 ELSE 813 IF (K470.EQ.1) THEN 814 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) 815 ELSE 816 N = BEGS_BLR(IP+1)-BEGS_BLR(IP) 817 ENDIF 818 POSELT_BLOCK = POSELT + 819 & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + 820 & int( BEGS_BLR(IP) - 1,8) 821 END IF 822 JPVT_THR(1:MAXI_CLUSTER) = 0 823 IF (K473.EQ.1) THEN 824 MAXRANK = 1 825 RANK = MAXRANK+1 826 INFO = 0 827 GOTO 3800 828 ENDIF 829 IF (K470.NE.1.OR.DIR .eq. 'V') THEN 830 DO I=1,M 831 BLOCK_THR(I,1:N)= 832 & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : 833 & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) 834 END DO 835 ELSE 836 DO I=1,N 837 BLOCK_THR(1:M,I)= 838 & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : 839 & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) 840 END DO 841 END IF 842 MAXRANK = floor(dble(M*N)/dble(M+N)) 843 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) 844 CALL ZMUMPS_TRUNCATED_RRQR( M, N, 845 & BLOCK_THR(1,1), 846 & MAXI_CLUSTER, JPVT_THR(1), 847 & TAU_THR(1), 848 & WORK_THR(1), N, 849 & RWORK_THR(1), 850 & TOLEPS, RANK, MAXRANK, INFO) 851 3800 CONTINUE 852 IF (INFO < 0) THEN 853 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, 854 & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " 855 CALL MUMPS_ABORT() 856 END IF 857 ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) 858 CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK, RANK, 859 & M, N, ISLR, IFLAG, IERROR, KEEP8) 860 IF (IFLAG.LT.0) CYCLE 861 IF (ISLR) THEN 862 IF (RANK .EQ. 0) THEN 863 ELSE 864 BLR_PANEL(IP-CURRENT_BLR)%Q = ZERO 865 DO I=1,RANK 866 BLR_PANEL(IP-CURRENT_BLR)%Q(I,I) = ONE 867 END DO 868 CALL zunmqr 869 & ('L', 'N', M, RANK, RANK, 870 & BLOCK_THR(1,1), 871 & MAXI_CLUSTER, TAU_THR(1), 872 & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), 873 & M, WORK_THR(1), LWORK, INFO ) 874 IF (INFO < 0) THEN 875 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, 876 & " OF CUNMQR WHILE COMPRESSING A BLOCK " 877 CALL MUMPS_ABORT() 878 END IF 879 DO J=1,N 880 BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J), 881 & JPVT_THR(J)) = 882 & BLOCK_THR(1:MIN(RANK,J),J) 883 IF(J.LT.RANK) BLR_PANEL(IP-CURRENT_BLR)% 884 & R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO 885 ENDDO 886 CALL UPDATE_FLOP_STATS_DEMOTE( 887 & BLR_PANEL(IP-CURRENT_BLR), NIV) 888 END IF 889 ELSE 890 IF (K470.NE.1.OR.DIR .eq. 'V') THEN 891 DO I=1,M 892 BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) = 893 & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : 894 & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) 895 & +int(N-1,8) ) 896 END DO 897 ELSE 898 DO I=1,N 899 BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = 900 & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : 901 & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) 902 & +int(M-1,8) ) 903 END DO 904 END IF 905 IF (K473.EQ.0) THEN 906 CALL UPDATE_FLOP_STATS_DEMOTE(BLR_PANEL(IP-CURRENT_BLR), 907 & NIV) 908 ENDIF 909 BLR_PANEL(IP-CURRENT_BLR)%K = -1 910 END IF 911 END DO 912#if defined(BLR_MT) 913!$OMP END DO NOWAIT 914#endif 915 END SUBROUTINE ZMUMPS_COMPRESS_PANEL 916 END MODULE ZMUMPS_FAC_LR 917