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 RECURSIVE SUBROUTINE ZMUMPS_PROCESS_BLOCFACTO( 14 & COMM_LOAD, ASS_IRECV, 15 & BUFR, LBUFR, 16 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, 17 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 18 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 19 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 20 & MYID, COMM, IFLAG, IERROR, NBFIN, 21 & 22 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, 23 & ITLOC, RHS_MUMPS, FILS, 24 & PTRARW, PTRAIW, INTARR, DBLARR, 25 & ICNTL, KEEP,KEEP8, DKEEP, 26 & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, 27 & LPTRAR, NELT, FRTPTR, FRTELT, 28 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 29 & , LRGROUPS 30 & ) 31 USE ZMUMPS_OOC 32 USE ZMUMPS_LOAD 33 USE ZMUMPS_LR_STATS 34 USE ZMUMPS_LR_CORE 35 USE ZMUMPS_LR_TYPE 36 USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_DECOMPRESS_PANEL, 37 & ZMUMPS_COMPRESS_PANEL, 38 & ZMUMPS_BLR_UPDATE_TRAILING, 39 & ZMUMPS_FAKE_COMPRESS_CB 40 USE ZMUMPS_ANA_LR, ONLY : GET_CUT 41!$ USE OMP_LIB 42 IMPLICIT NONE 43 INCLUDE 'zmumps_root.h' 44 INCLUDE 'mumps_headers.h' 45 TYPE (ZMUMPS_ROOT_STRUC) :: root 46 INTEGER ICNTL( 40 ), KEEP( 500 ) 47 INTEGER(8) KEEP8(150) 48 DOUBLE PRECISION DKEEP(230) 49 INTEGER LBUFR, LBUFR_BYTES 50 INTEGER COMM_LOAD, ASS_IRECV 51 INTEGER BUFR( LBUFR ) 52 INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW 53 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA 54 INTEGER(8) :: POSFAC 55 INTEGER COMP 56 INTEGER IFLAG, IERROR, NBFIN, MSGSOU 57 INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), 58 & NSTK_S(KEEP(28)) 59 INTEGER(8) :: PAMASTER(KEEP(28)) 60 INTEGER(8) :: PTRAST(KEEP(28)) 61 INTEGER(8) :: PTRFAC(KEEP(28)) 62 INTEGER NBPROCFILS( KEEP(28) ), STEP(N), 63 & PIMASTER(KEEP(28)) 64 INTEGER IW( LIW ) 65 COMPLEX(kind=8) A( LA ) 66 INTEGER, intent(in) :: LRGROUPS(N) 67 INTEGER COMM, MYID 68 INTEGER NELT, LPTRAR 69 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 70 INTEGER PTLUST_S(KEEP(28)), 71 & ITLOC(N+KEEP(253)), FILS(N), ND(KEEP(28)) 72 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 73 INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) 74 INTEGER FRERE_STEPS(KEEP(28)) 75 DOUBLE PRECISION OPASSW, OPELIW 76 DOUBLE PRECISION FLOP1 77 INTEGER INTARR( KEEP8(27) ) 78 COMPLEX(kind=8) DBLARR( KEEP8(26) ) 79 INTEGER LEAF, LPOOL 80 INTEGER IPOOL( LPOOL ) 81 INTEGER ISTEP_TO_INIV2(KEEP(71)), 82 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 83 INCLUDE 'mpif.h' 84 INCLUDE 'mumps_tags.h' 85 INTEGER :: STATUS(MPI_STATUS_SIZE) 86 LOGICAL :: I_HAVE_SET_K117 87 INTEGER INODE, POSITION, NPIV, IERR, LP 88 INTEGER NCOL 89 INTEGER(8) :: POSBLOCFACTO 90 INTEGER :: LD_BLOCFACTO 91 INTEGER(8) :: LAELL 92 INTEGER(8) :: POSELT 93 INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 94 INTEGER NSLAV1, HS, ISW 95 INTEGER (8) :: LPOS, LPOS1, LPOS2, IPOS, KPOS 96 INTEGER ICT11 97 INTEGER I, IPIV, FPERE 98 LOGICAL LASTBL 99 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 100 COMPLEX(kind=8) ONE,ALPHA 101 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 102 INTEGER(8) :: LAFAC 103 INTEGER LIWFAC, STRAT, NextPivDummy 104 TYPE(IO_BLOCK) :: MonBloc 105 LOGICAL LAST_CALL 106 INTEGER LRELAY_INFO 107 INTEGER :: SEND_LR_INT, NELIM, NPARTSASS_MASTER, 108 & CURRENT_BLR_PANEL, 109 & CURRENT_BLR, 110 & NB_BLR_L, NB_BLR_U 111 TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L 112 LOGICAL :: SEND_LR 113 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 114 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU 115 INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT 116 DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK 117 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCK 118 INTEGER :: OMP_NUM 119 INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, 120 & MAXI_CLUSTER_L, MAXI_CLUSTER_U 121 INTEGER T1, T2, COUNT_RATE 122 COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO 123 INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO 124 LOGICAL :: DYNAMIC_ALLOC 125 INTEGER MUMPS_PROCNODE 126 EXTERNAL MUMPS_PROCNODE 127 I_HAVE_SET_K117 = .FALSE. 128 DYNAMIC_ALLOC = .FALSE. 129 FPERE = -1 130 POSITION = 0 131 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, 132 & MPI_INTEGER, COMM, IERR ) 133 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, 134 & MPI_INTEGER, COMM, IERR ) 135 LASTBL = (NPIV.LE.0) 136 IF (LASTBL) THEN 137 NPIV = -NPIV 138 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, 139 & MPI_INTEGER, COMM, IERR ) 140 ENDIF 141 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, 142 & MPI_INTEGER, COMM, IERR ) 143 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, 144 & MPI_INTEGER, COMM, IERR ) 145 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 146 & NPARTSASS_MASTER , 1, 147 & MPI_INTEGER, COMM, IERR ) 148 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, CURRENT_BLR_PANEL, 149 & 1, MPI_INTEGER, COMM, IERR ) 150 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, 151 & MPI_INTEGER, COMM, IERR ) 152 IF ( SEND_LR_INT .EQ. 1) THEN 153 SEND_LR = .TRUE. 154 ELSE 155 SEND_LR = .FALSE. 156 ENDIF 157 IF ( SEND_LR ) THEN 158 LAELL = int(NPIV,8) * int(NPIV+NELIM,8) 159 ELSE 160 LAELL = int(NPIV,8) * int(NCOL,8) 161 ENDIF 162 IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN 163 IF ( LRLUS .LT. LAELL ) THEN 164 IFLAG = -9 165 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) 166 IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN 167 LP=ICNTL(1) 168 WRITE(LP,*) 169 &" FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_PROCESS_BLOCFACTO" 170 ENDIF 171 GOTO 700 172 END IF 173 CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), IW, LIW, A, LA, 174 & LRLU, IPTRLU, 175 & IWPOS, IWPOSCB, PTRIST, PTRAST, 176 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 177 & KEEP(IXSZ),COMP,DKEEP(97),MYID) 178 IF ( LRLU .NE. LRLUS ) THEN 179 WRITE(*,*) 'PB compress ZMUMPS_PROCESS_BLOCFACTO, LRLU,LRLUS=' 180 & ,LRLU,LRLUS 181 IFLAG = -9 182 CALL MUMPS_SET_IERROR( LAELL-LRLUS, IERROR ) 183 GOTO 700 184 END IF 185 IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN 186 IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN 187 LP=ICNTL(1) 188 WRITE(LP,*) 189 &" FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_PROCESS_BLOCFACTO" 190 ENDIF 191 IFLAG = -8 192 IERROR = IWPOS + NPIV - 1 - IWPOSCB 193 GOTO 700 194 END IF 195 END IF 196 LRLU = LRLU - LAELL 197 LRLUS = LRLUS - LAELL 198 KEEP8(67) = min(LRLUS, KEEP8(67)) 199 KEEP8(70) = KEEP8(70) - LAELL 200 KEEP8(68) = min(KEEP8(70), KEEP8(68)) 201 KEEP8(71) = KEEP8(71) - LAELL 202 KEEP8(69) = min(KEEP8(71), KEEP8(69)) 203 POSBLOCFACTO = POSFAC 204 POSFAC = POSFAC + LAELL 205 CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., 206 & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLUS) 207 IF ((NPIV .EQ. 0) 208 & ) THEN 209 IPIV=1 210 ELSE 211 IPIV = IWPOS 212 IWPOS = IWPOS + NPIV 213 IF (NPIV .GT. 0) THEN 214 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 215 & IW( IPIV ), NPIV, 216 & MPI_INTEGER, COMM, IERR ) 217 ENDIF 218 IF ( SEND_LR ) THEN 219 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 220 & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), 221 & MPI_DOUBLE_COMPLEX, 222 & COMM, IERR ) 223 LD_BLOCFACTO = NPIV+NELIM 224 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 225 & NB_BLR_U, 1, MPI_INTEGER, 226 & COMM, IERR ) 227 ALLOCATE(BLR_U(max(NB_BLR_U,1))) 228 ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) 229 CALL ZMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, 230 & POSITION, NPIV, NELIM, 'H', 231 & BLR_U(1), NB_BLR_U, KEEP(470), 232 & BEGS_BLR_U(1), 233 & KEEP8, COMM, IERR, IFLAG, IERROR) 234 IF (IFLAG.LT.0) GOTO 700 235 ELSE 236 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 237 & A(POSBLOCFACTO), NPIV*NCOL, 238 & MPI_DOUBLE_COMPLEX, 239 & COMM, IERR ) 240 LD_BLOCFACTO = NCOL 241 ENDIF 242 ENDIF 243 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 244 & LRELAY_INFO, 1, 245 & MPI_INTEGER, COMM, IERR ) 246 IF (PTRIST(STEP( INODE )) .EQ. 0) THEN 247 CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, 248 & ASS_IRECV, 249 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 250 & IWPOS, IWPOSCB, IPTRLU, 251 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 252 & PTLUST_S, PTRFAC, 253 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 254 & IFLAG, IERROR, COMM, 255 & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 256 & 257 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 258 & FILS, PTRARW, PTRAIW, 259 & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, 260 & LPTRAR, NELT, FRTPTR, FRTELT, 261 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 262 & , LRGROUPS 263 & ) 264 IF ( IFLAG .LT. 0 ) GOTO 600 265 ENDIF 266 IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN 267#if ! defined(NO_XXNBPR) 268 CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), 269 & IW(PTRIST(STEP(INODE))+XXNBPR)) 270 DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) 271#else 272 DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) 273#endif 274 BLOCKING = .TRUE. 275 SET_IRECV = .FALSE. 276 MESSAGE_RECEIVED = .FALSE. 277 CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, 278 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 279 & MPI_ANY_SOURCE, CONTRIB_TYPE2, 280 & STATUS, 281 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 282 & IWPOS, IWPOSCB, IPTRLU, 283 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 284 & PTLUST_S, PTRFAC, 285 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 286 & IFLAG, IERROR, COMM, 287 & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 288 & 289 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 290 & FILS, PTRARW, PTRAIW, 291 & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, 292 & LPTRAR, NELT, FRTPTR, FRTELT, 293 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 294 & , LRGROUPS 295 & ) 296 IF ( IFLAG .LT. 0 ) GOTO 600 297 END DO 298 ENDIF 299 SET_IRECV = .TRUE. 300 BLOCKING = .FALSE. 301 MESSAGE_RECEIVED = .TRUE. 302 CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, 303 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 304 & MPI_ANY_SOURCE, MPI_ANY_TAG, 305 & STATUS, 306 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 307 & IWPOS, IWPOSCB, IPTRLU, 308 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 309 & PTLUST_S, PTRFAC, 310 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 311 & IFLAG, IERROR, COMM, 312 & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, 313 & 314 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 315 & FILS, PTRARW, PTRAIW, 316 & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, 317 & LPTRAR, NELT, FRTPTR, FRTELT, 318 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 319 & , LRGROUPS 320 & ) 321 IOLDPS = PTRIST(STEP(INODE)) 322 POSELT = PTRAST(STEP(INODE)) 323 LCONT1 = IW( IOLDPS +KEEP(IXSZ)) 324 NASS1 = IW( IOLDPS + 1 +KEEP(IXSZ)) 325 IF ( NASS1 < 0 ) THEN 326 NASS1 = -NASS1 327 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 328 IF (KEEP(55) .EQ. 0) THEN 329 CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, 330 & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, 331 & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) 332 ELSE 333 CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, 334 & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, 335 & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), 336 & FRTPTR, FRTELT, RHS_MUMPS) 337 ENDIF 338 ENDIF 339 NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) 340 NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) 341 NSLAV1 = IW( IOLDPS + 5 +KEEP(IXSZ)) 342 HS = 6 + NSLAV1 + KEEP(IXSZ) 343 NCOL1 = LCONT1 + NPIV1 344 IF (NPIV.GT.0) THEN 345 ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 346 IF (DYNAMIC_ALLOC) THEN 347 DO I = 1, NPIV 348 IF (DYN_PIVINFO(I).EQ.I) CYCLE 349 ISW = IW(ICT11+I) 350 IW(ICT11+I) = IW(ICT11+DYN_PIVINFO(I)) 351 IW(ICT11+DYN_PIVINFO(I)) = ISW 352 IPOS = POSELT + int(NPIV1 + I - 1,8) 353 KPOS = POSELT + int(NPIV1 + DYN_PIVINFO(I) - 1,8) 354 CALL zswap(NROW1, A(IPOS), NCOL1, A(KPOS), NCOL1) 355 ENDDO 356 ELSE 357 DO I = 1, NPIV 358 IF (IW(IPIV+I-1).EQ.I) CYCLE 359 ISW = IW(ICT11+I) 360 IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1)) 361 IW(ICT11+IW(IPIV+I-1)) = ISW 362 IPOS = POSELT + int(NPIV1 + I - 1,8) 363 KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8) 364 CALL zswap(NROW1, A(IPOS), NCOL1, A(KPOS), NCOL1) 365 ENDDO 366 ENDIF 367 LPOS2 = POSELT + int(NPIV1,8) 368 LPOS = LPOS2 + int(NPIV,8) 369 IF (KEEP(486) .GT.0) THEN 370 CALL SYSTEM_CLOCK(T1) 371 ENDIF 372 IF (DYNAMIC_ALLOC) THEN 373 CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, 374 & DYN_BLOCFACTO, LD_BLOCFACTO, A(LPOS2), NCOL1) 375 ELSE 376 CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, 377 & A(POSBLOCFACTO), LD_BLOCFACTO, A(LPOS2), NCOL1) 378 ENDIF 379 IF (KEEP(486) .GT.0) THEN 380 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 381 ACC_TRSM_TIME = ACC_TRSM_TIME + 382 & DBLE(T2-T1)/DBLE(COUNT_RATE) 383 ENDIF 384 ENDIF 385 IF ( (NPIV .GT. 0) 386 & ) THEN 387 IF (SEND_LR) THEN 388 CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, 389 & NROW1, LRGROUPS, NPARTSCB, 390 & NPARTSASS, BEGS_BLR_L) 391 CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB, 392 & NROW1-0, KEEP(488), .TRUE., KEEP(472)) 393 NB_BLR_L = NPARTSCB 394 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) 395 call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U) 396 MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) 397 LWORK = MAXI_CLUSTER*MAXI_CLUSTER 398 OMP_NUM = 1 399#if defined(BLR_MT) 400!$ OMP_NUM = OMP_GET_MAX_THREADS() 401#endif 402 ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), 403 & RWORK(2*MAXI_CLUSTER*OMP_NUM), 404 & TAU(MAXI_CLUSTER*OMP_NUM), 405 & JPVT(MAXI_CLUSTER*OMP_NUM), 406 & WORK(LWORK*OMP_NUM)) 407 CURRENT_BLR=1 408 ALLOCATE(BLR_L(NB_BLR_L)) 409 CALL SYSTEM_CLOCK(T1) 410#if defined(BLR_MT) 411!$OMP PARALLEL 412#endif 413 CALL ZMUMPS_COMPRESS_PANEL 414 & (A, LA, POSELT, IFLAG, IERROR, NCOL1, 415 & BEGS_BLR_L, NB_BLR_L+1, DKEEP(8), KEEP(473), BLR_L, 416 & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, 417 & BLOCK, MAXI_CLUSTER, NELIM, 418 & .TRUE., 419 & NPIV, NPIV1, 420 & 2, KEEP(483), KEEP(470), KEEP8 421 & ) 422 IF (IFLAG.LT.0) GOTO 300 423#if defined(BLR_MT) 424!$OMP BARRIER 425!$OMP MASTER 426#endif 427 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 428 ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + 429 & DBLE(T2-T1)/DBLE(COUNT_RATE) 430 CALL SYSTEM_CLOCK(T1) 431#if defined(BLR_MT) 432!$OMP END MASTER 433#endif 434 300 CONTINUE 435#if defined(BLR_MT) 436!$OMP END PARALLEL 437#endif 438 IF (IFLAG.LT.0) GOTO 700 439 ENDIF 440 ENDIF 441 IF ( (KEEP(201).eq.1) .AND. 442 & ( .NOT. SEND_LR .OR. (NPIV .EQ.0) .OR. 443 & (KEEP(485).EQ.0) ) 444 & ) THEN 445 MonBloc%INODE = INODE 446 MonBloc%MASTER = .FALSE. 447 MonBloc%Typenode = 2 448 MonBloc%NROW = NROW1 449 MonBloc%NCOL = NCOL1 450 MonBloc%NFS = NASS1 451 MonBloc%LastPiv = NPIV1 + NPIV 452 MonBloc%LastPanelWritten_L=-9999 453 MonBloc%LastPanelWritten_U=-9999 454 NULLIFY(MonBloc%INDICES) 455 MonBloc%Last = LASTBL 456 STRAT = STRAT_TRY_WRITE 457 NextPivDummy = -8888 458 LIWFAC = IW(IOLDPS+XXI) 459 CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) 460 LAST_CALL = .FALSE. 461 CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), 462 & LAFAC, MonBloc, NextPivDummy, NextPivDummy, 463 & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) 464 ENDIF 465 IF ( (NPIV .GT. 0) 466 & ) THEN 467 IF (SEND_LR) THEN 468 IF (NELIM.GT.0) THEN 469 IF (DYNAMIC_ALLOC) THEN 470 LPOS1 = int(NPIV+1,8) 471 CALL zgemm('N','N', NELIM,NROW1,NPIV, 472 & ALPHA,DYN_BLOCFACTO(LPOS1),LD_BLOCFACTO, 473 & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 474 ELSE 475 LPOS1 = POSBLOCFACTO+int(NPIV,8) 476 CALL zgemm('N','N', NELIM,NROW1,NPIV, 477 & ALPHA,A(LPOS1),LD_BLOCFACTO, 478 & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 479 ENDIF 480 ENDIF 481#if defined(BLR_MT) 482!$OMP PARALLEL 483#endif 484 CALL ZMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, 485 & IFLAG, IERROR, NCOL1, 486 & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, 487 & BLR_L, NB_BLR_L+1, 488 & BLR_U, NB_BLR_U+1, 489 & 0, 490 & .TRUE., 491 & NPIV1, 492 & 2, 0, KEEP(470), 493 & KEEP(481), DKEEP(8), KEEP(477) 494 & ) 495 400 CONTINUE 496#if defined(BLR_MT) 497!$OMP END PARALLEL 498#endif 499 IF (IFLAG.LT.0) GOTO 700 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 501 ACC_UPDT_TIME = ACC_UPDT_TIME + 502 & DBLE(T2-T1)/DBLE(COUNT_RATE) 503 CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, 504 & 0, NPARTSCB, 'V', 2) 505 IF (KEEP(485).NE.0) THEN 506 CALL SYSTEM_CLOCK(T1) 507 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, 508 & .FALSE., 509 & NPIV1+1, 510 & 1, 511 & NB_BLR_L+1, BLR_L, CURRENT_BLR, 'V', NCOL1, KEEP(470)) 512 CALL SYSTEM_CLOCK(T2,COUNT_RATE) 513 ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + 514 & DBLE(T2-T1)/DBLE(COUNT_RATE) 515 IF (KEEP(201).eq.1) THEN 516 MonBloc%INODE = INODE 517 MonBloc%MASTER = .FALSE. 518 MonBloc%Typenode = 2 519 MonBloc%NROW = NROW1 520 MonBloc%NCOL = NCOL1 521 MonBloc%NFS = NASS1 522 MonBloc%LastPiv = NPIV1 + NPIV 523 MonBloc%LastPanelWritten_L=-9999 524 MonBloc%LastPanelWritten_U=-9999 525 NULLIFY(MonBloc%INDICES) 526 MonBloc%Last = LASTBL 527 STRAT = STRAT_TRY_WRITE 528 NextPivDummy = -8888 529 LIWFAC = IW(IOLDPS+XXI) 530 CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) 531 LAST_CALL = .FALSE. 532 CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), 533 & LAFAC, MonBloc, NextPivDummy, NextPivDummy, 534 & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) 535 ENDIF 536 ENDIF 537 ELSE 538 IF (DYNAMIC_ALLOC) THEN 539 LPOS1 = int(NPIV+1,8) 540 CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV, 541 & ALPHA,DYN_BLOCFACTO(LPOS1),NCOL, 542 & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 543 ELSE 544 LPOS1 = POSBLOCFACTO+int(NPIV,8) 545 CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV, 546 & ALPHA,A(LPOS1),NCOL, 547 & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 548 ENDIF 549 ENDIF 550 ENDIF 551 IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV 552 IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV 553 IF (LASTBL) THEN 554 IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) ) 555 ENDIF 556 IF ( .not. LASTBL .AND. 557 & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN 558 write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' 559 CALL MUMPS_ABORT() 560 ENDIF 561 IF (SEND_LR) THEN 562 IF ((NPIV.GT.0) 563 & ) THEN 564 CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, .FALSE.) 565 DEALLOCATE(BLR_U) 566 CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, .TRUE.) 567 DEALLOCATE(BLR_L) 568 ENDIF 569 ENDIF 570 IF (DYNAMIC_ALLOC) THEN 571 DEALLOCATE(DYN_BLOCFACTO) 572 DEALLOCATE(DYN_PIVINFO) 573 ELSE 574 LRLU = LRLU + LAELL 575 LRLUS = LRLUS + LAELL 576 KEEP8(70) = KEEP8(70) + LAELL 577 KEEP8(71) = KEEP8(71) + LAELL 578 POSFAC = POSFAC - LAELL 579 CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., 580 & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) 581 IWPOS = IWPOS - NPIV 582 ENDIF 583 FLOP1 = dble( NPIV1*NROW1 ) + 584 & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1) 585 & - 586 & dble((NPIV1+NPIV)*NROW1 ) - 587 & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1) 588 CALL ZMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) 589 IF (LASTBL) THEN 590 IF (KEEP(486).NE.0) THEN 591 IF (SEND_LR) THEN 592 CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, 593 & KEEP(50), INODE) 594 ELSE 595 CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, 596 & KEEP(50), INODE) 597 ENDIF 598 ENDIF 599 IF (SEND_LR) THEN 600 IF (KEEP(489) .EQ. 1) THEN 601 CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, 602 & BEGS_BLR_L, NB_BLR_L+1, 603 & BEGS_BLR_U, NB_BLR_U+1, 1, 604 & DKEEP(8), NASS1, NROW1, 605 & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, 606 & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 2, 607 & .TRUE., NPIV1, KEEP(484)) 608 ENDIF 609 ENDIF 610 CALL ZMUMPS_END_FACTO_SLAVE( 611 & COMM_LOAD, ASS_IRECV, 612 & N, INODE, FPERE, 613 & root, 614 & MYID, COMM, 615 & 616 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 617 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 618 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, 619 & PAMASTER, 620 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 621 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 622 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 623 & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, 624 & LPTRAR, NELT, FRTPTR, FRTELT, 625 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 626 & , LRGROUPS 627 & ) 628 ENDIF 629 IF (SEND_LR) THEN 630 IF (allocated(RWORK)) DEALLOCATE(RWORK) 631 IF (allocated(work)) DEALLOCATE(WORK) 632 IF (allocated(TAU)) DEALLOCATE(TAU) 633 IF (allocated(JPVT)) DEALLOCATE(JPVT) 634 IF (allocated(BLOCK)) DEALLOCATE(BLOCK) 635 IF ((NPIV.GT.0) 636 & ) THEN 637 IF (associated(BEGS_BLR_L)) DEALLOCATE(BEGS_BLR_L) 638 IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) 639 ENDIF 640 ENDIF 641 600 CONTINUE 642 RETURN 643 700 CONTINUE 644 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 645 RETURN 646 END SUBROUTINE ZMUMPS_PROCESS_BLOCFACTO 647 SUBROUTINE ZMUMPS_MPI_UNPACK_LR( 648 & BUFR, LBUFR, LBUFR_BYTES, POSITION, 649 & NPIV, NELIM, DIR, 650 & BLR_U, NB_BLOCK_U, K470, 651 & BEGS_BLR_U, KEEP8, 652 & COMM, IERR, IFLAG, IERROR) 653 USE ZMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB 654 USE ZMUMPS_LR_TYPE 655 IMPLICIT NONE 656 INTEGER, INTENT(IN) :: LBUFR 657 INTEGER, INTENT(IN) :: LBUFR_BYTES 658 INTEGER, INTENT(IN) :: BUFR(LBUFR) 659 INTEGER, INTENT(INOUT) :: POSITION 660 INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV, K470 661 CHARACTER(len=1) :: DIR 662 INTEGER, INTENT(IN) :: COMM 663 INTEGER, INTENT(OUT) :: IERR, IFLAG, IERROR 664 TYPE (LRB_TYPE), INTENT(OUT), 665 & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U 666 INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U 667 INTEGER(8) :: KEEP8(150) 668 LOGICAL :: ISLR 669 INTEGER :: ISLR_INT, I 670 INTEGER :: LRFORM, K, M, N, KSVD 671 INCLUDE 'mpif.h' 672 INCLUDE 'mumps_tags.h' 673 IERR = 0 674 IF (size(BLR_U) .NE. 675 & MAX(NB_BLOCK_U,1) ) THEN 676 WRITE(*,*) "Internal error 1 in ZMUMPS_MPI_UNPACK", 677 & NB_BLOCK_U,size(BLR_U) 678 CALL MUMPS_ABORT() 679 ENDIF 680 BEGS_BLR_U(1) = 1 681 BEGS_BLR_U(2) = NPIV+NELIM+1 682 DO I = 1, NB_BLOCK_U 683 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 684 & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) 685 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 686 & LRFORM, 1, 687 & MPI_INTEGER, COMM, IERR ) 688 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 689 & K, 1, 690 & MPI_INTEGER, COMM, IERR ) 691 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 692 & M, 1, 693 & MPI_INTEGER, COMM, IERR ) 694 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 695 & N, 1, 696 & MPI_INTEGER, COMM, IERR ) 697 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 698 & KSVD, 1, 699 & MPI_INTEGER, COMM, IERR ) 700 IF (DIR.EQ.'H') THEN 701 IF (K470.EQ.1) THEN 702 BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M 703 ELSE 704 BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + N 705 ENDIF 706 ELSE 707 BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M 708 ENDIF 709 IF (ISLR_INT .eq. 1) THEN 710 ISLR = .TRUE. 711 ELSE 712 ISLR = .FALSE. 713 ENDIF 714 CALL ALLOC_LRB( BLR_U(I), K, KSVD, M, N, ISLR, 715 & IFLAG, IERROR, KEEP8 ) 716 IF (IFLAG.LT.0) RETURN 717 IF (LRFORM .NE. BLR_U(I)%LRFORM) THEN 718 WRITE(*,*) "Internal error 2 in ALLOC_LRB", 719 & LRFORM, BLR_U(I)%LRFORM 720 ENDIF 721 IF (ISLR) THEN 722 IF (K .GT. 0) THEN 723 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 724 & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_COMPLEX, 725 & COMM, IERR ) 726 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 727 & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_COMPLEX, 728 & COMM, IERR) 729 ENDIF 730 ELSE 731 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 732 & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_COMPLEX, 733 & COMM, IERR) 734 ENDIF 735 ENDDO 736 RETURN 737 END SUBROUTINE ZMUMPS_MPI_UNPACK_LR 738