C C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_FAC_LR USE ZMUMPS_ANA_LR USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER NBPROCFILS( KEEP(28) ), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), ND(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 COMPLEX(kind=8) MULT1,MULT2, A11, DETPIV, A22, A12 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL, LD_BLOCFACTO INTEGER(8) LAELL, POSBLOCFACTO INTEGER(8) POSELT INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW, DEST INTEGER ICT11 INTEGER(8) LPOS, LPOS2, DPOS, UPOS INTEGER (8) IPOS, KPOS INTEGER I, IPIV, FPERE, NSLAVES_TOT, & NSLAVES_FOLLOW, NB_BLOC_FAC INTEGER IPOSK, JPOSK, NPIVSENT, Block, IROW, BLSIZE INTEGER allocok, TO_UPDATE_CPT_END COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: UIP21K INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR LOGICAL :: SEND_LR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: SEND_LR_INT, NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR INTEGER T1, T2, COUNT_RATE, LWORK DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, MY_NUM INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) XSIZE = KEEP(IXSZ) KEEP_BEGS_BLR_LS =.FALSE. KEEP_BEGS_BLR_COL =.FALSE. KEEP_BLR_LS =.FALSE. IF ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( NPIV.GT.0 ) THEN IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN ZMUMPS_PROCESS_SYM_BLOCFACTO, & REAL WORKSPACE TOO SMALL" GOTO 700 END IF CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_PROCESS_SYM_BLOCFACTO,", & " LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN ZMUMPS_PROCESS_SYM_BLOCFACTO, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(70) = KEEP8(70) - LAELL KEEP8(71) = KEEP8(71) - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLUS) IF ( NPIV.EQ.0 ) THEN IPIV = 1 LD_BLOCFACTO = NPIV+NELIM ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1))) ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2)) CALL ZMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, KEEP(470), & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, MPI_DOUBLE_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NCOL ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif BLOCKING = .TRUE. SET_IRECV=.FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF ( LASTBL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF ( NPIV1 + NCOL .NE. NASS1 ) THEN WRITE(*,*) 'SymBLFC Error: NPIV1 + NCOL .NE. NASS1 :', & NPIV1,NCOL,NASS1 CALL MUMPS_ABORT() END IF ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV PIVI = abs(IW(IPIV+I-1)) IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL zswap(NROW1, A(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO IF (.NOT.SEND_LR) THEN ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF ELSE ALLOCATE( UIP21K( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * 1 GOTO 700 END IF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T1) ENDIF CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A(POSELT+int(NPIV1,8)), NCOL1 ) IF (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (.NOT.SEND_LR) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL zscal( NROW1, A11, A(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A(LPOS1)+A12*A(LPOS1+1_8) MULT2 = A12*A(LPOS1)+A22*A(LPOS1+1_8) A(LPOS1) = MULT1 A(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDIF IF (SEND_LR) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) CALL MUMPS_ABORT() IF (SEND_LR) THEN IF (NPIV1.NE.0) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_LS = NPARTSCB ENDIF call MAX_CLUSTER(BEGS_BLR_LM,NB_BLR_LM+1,MAXI_CLUSTER_LM) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (KEEP(489).EQ.1) THEN IF (NPIV1.EQ.0) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_MASTER ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL) ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT=0 IF (NSLAVES_PREC.GT.0) THEN NB_ACCESSES_INIT=NSLAVES_PREC+1 ENDIF CALL ZMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_MASTER, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) write(6,*) 'ERROR 2 allocate temporary BLR blocks during', & ' ZMUMPS_PROCESS_SYM_BLOCFACTO', IERROR GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS)) CALL SYSTEM_CLOCK(T1) MY_NUM=0 #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, DKEEP(8), KEEP(473), BLR_LS, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & ( .NOT. SEND_LR .OR. (NPIV.EQ.0) .OR. & (KEEP(485).EQ.0) ) & ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL zgemm('N','N', NELIM,NROW1,NPIV,ALPHA, & A(UPOS),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL ZMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL1, NROW1, & POSBLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM+1, BLR_LM, NPIV1, & BEGS_BLR_LS, NB_BLR_LS+1, BLR_LS, 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR(1:MAXI_CLUSTER,MY_NUM*MAXI_CLUSTER+1), & MAXI_CLUSTER, & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_LS, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS, & CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8, .FALSE.) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL,BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV,ALPHA,A(UPOS),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) DPOS = POSELT + int(NCOL1 - NROW1,8) IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL zgemv( 'T', NPIV, Block-I+1, ALPHA, & A( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL zgemm( 'T', 'N', Block, NROW1-IROW+1-Block, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, ONE, & A( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF ENDIF FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL ZMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS + 3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ)) IF ( .NOT. SEND_LR ) THEN LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV IERR = -1 DO WHILE ( IERR .eq. -1 ) CALL ZMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & SEND_LR, BLR_LS, IPANEL, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) IF (IERR .EQ. -1 ) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO #if defined(IBC_TEST) WRITE(*,*) MYID,":Send2slave worked" #endif IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & ZMUMPS_PROCESS_SYM_BLOCFACTO" WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1 IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( NPIV.GT. 0 .AND. SEND_LR ) THEN IF (NSLAVES_PREC.GT.0) THEN IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, .TRUE.) ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) DEALLOCATE( UIP21K ) ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (SEND_LR) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL ZMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN IF (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) ENDIF ENDIF CALL ZMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (SEND_LR) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(work)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (NPIV.GT.0) THEN IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN CALL DEALLOC_BLR_PANEL (BLR_LS, NB_BLR_LS, KEEP8, .TRUE.) IF (associated(BLR_LS)) DEALLOCATE(BLR_LS) ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (KEEP(489).EQ.1) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if defined(IBC_TEST) write(6,*) MYID,' :Exiting ZMUMPS_PROCESS_SYM_BLOCFACTO for &INODE=', INODE #endif RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO