sfac_process_blocfacto.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, 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  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      RECURSIVE SUBROUTINE smumps_process_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, PERM,
     &   COMP, STEP, PIMASTER, PAMASTER, POSFAC,
     &   MYID, COMM, IFLAG, IERROR, NBFIN,
     &
     &    PTLUST_S, PTRFAC, root, OPASSW, OPELIW,
     &    ITLOC, RHS_MUMPS, FILS, DAD,
     &    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 smumps_ooc, ONLY : io_block
      USE mumps_ooc_common, ONLY : typef_l, strat_try_write
      USE smumps_load
      USE smumps_lr_core
      USE smumps_lr_type
      USE smumps_lr_stats
      USE smumps_fac_lr
      USE smumps_ana_lr, ONLY : get_cut
      USE smumps_lr_data_m
      USE smumps_struc_def, ONLY : smumps_root_struc
      USE smumps_dynamic_memory_m, ONLY : smumps_dm_set_dynptr
!$    USE OMP_LIB
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (smumps_root_struc) :: root
      INTEGER icntl( 60 ), keep( 500 )
      INTEGER(8) keep8(150)
      REAL dkeep(230)
      INTEGER lbufr, lbufr_bytes
      INTEGER comm_load, ass_irecv
      INTEGER bufr( lbufr )
      INTEGER n, slavef, iwpos, iwposcb, liw
      INTEGER(8) :: iptrlu, lrlu, lrlus, la
      INTEGER(8) :: posfac
      INTEGER comp
      INTEGER iflag, ierror, nbfin, msgsou
      INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
     &        nstk_s(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER perm(n), step(n), 
     & pimaster(keep(28))
      INTEGER IW( liw )
      REAL a( la )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER comm, myid
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER ptlust_s(keep(28)),
     &        itloc(n+keep(253)), fils(n), dad(keep(28)), nd(keep(28))
      REAL :: 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) )
      REAL 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)))
      include 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      LOGICAL :: I_HAVE_SET_K117
      INTEGER INODE, POSITION, NPIV, IERR, LP
      INTEGER NCOL
      INTEGER(8) :: POSBLOCFACTO
      INTEGER :: LD_BLOCFACTO 
      INTEGER(8) :: LA_BLOCFACTO 
      INTEGER(8) :: LA_PTR 
      INTEGER(8) :: POSELT
      REAL, DIMENSION(:), POINTER :: A_PTR
      INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1
      INTEGER NSLAV1, HS, ISW
      INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS
      INTEGER ICT11
      INTEGER I, IPIV, FPERE
      LOGICAL LASTBL, KEEP_BEGS_BLR_L
      LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      REAL ONE,ALPHA
      PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0)
      INTEGER LIWFAC, STRAT, NextPivDummy
      TYPE(IO_BLOCK) :: MonBloc
      LOGICAL LAST_CALL
      INTEGER LRELAY_INFO
      INTEGER :: INFO_TMP(2)
      INTEGER :: IDUMMY(1)
      INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX,
     &           IPANEL, 
     &           CURRENT_BLR, 
     &           NB_BLR_L, NB_BLR_U, NB_BLR_COL
      TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB
      TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L
      LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL
      LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
      INTEGER :: LR_ACTIVATED_INT
      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U,
     & BEGS_BLR_COL
      REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU
      INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT
      REAL,ALLOCATABLE,DIMENSION(:) :: RWORK
      REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCK
      INTEGER :: OMP_NUM
      INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK,
     &        MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL
      INTEGER  :: allocok
      INTEGER MUMPS_PROCNODE
      EXTERNAL MUMPS_PROCNODE
      KEEP_BEGS_BLR_L = .FALSE.
      nullify(BEGS_BLR_L)
      NB_BLR_U = -7654321
      NULLIFY(BEGS_BLR_U)
      I_HAVE_SET_K117 = .FALSE.
      FPERE    = -1
      POSITION = 0
      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 )
.LE.      LASTBL = (NPIV0)
      IF (LASTBL) THEN 
         NPIV = -NPIV
         CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 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, LR_ACTIVATED_INT,
     &                 1, MPI_INTEGER, COMM, IERR )
.EQ.      LR_ACTIVATED    = (LR_ACTIVATED_INT1)
      IF ( LR_ACTIVATED ) THEN
        LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8)
      ELSE
        LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8)
      ENDIF
      CALL SMUMPS_GET_SIZE_NEEDED(
     &      NPIV, LA_BLOCFACTO, .FALSE.,
     &      KEEP(1), KEEP8(1),
     &      N, IW, LIW, A, LA,
     &      LRLU, IPTRLU,
     &      IWPOS, IWPOSCB, PTRIST, PTRAST,
     &      STEP, PIMASTER, PAMASTER, LRLUS,
     &      KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, 
     &      DAD, IFLAG, IERROR)
.LT.      IF (IFLAG0) GOTO 700
      LRLU  = LRLU - LA_BLOCFACTO
      LRLUS = LRLUS - LA_BLOCFACTO
      KEEP8(67) = min(LRLUS, KEEP8(67))
      KEEP8(69) = KEEP8(69) + LA_BLOCFACTO
      KEEP8(68) = max(KEEP8(69), KEEP8(68))
      POSBLOCFACTO = POSFAC
      POSFAC = POSFAC + LA_BLOCFACTO
      CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE.,
     &               LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
.EQ.      IF ((NPIV  0) 
     &     ) THEN
        IPIV=1
      ELSE
        IPIV = IWPOS
        IWPOS = IWPOS + NPIV
.GT.        IF (NPIV  0) THEN
          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 IW( IPIV ), NPIV,
     &                 MPI_INTEGER, COMM, IERR )
        ENDIF
        IF ( LR_ACTIVATED ) THEN
            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 A(POSBLOCFACTO), NPIV*(NPIV+NELIM),
     &                 MPI_REAL,
     &                 COMM, IERR )
            LD_BLOCFACTO = NPIV+NELIM
            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 NB_BLR_U, 1, MPI_INTEGER,
     &                 COMM, IERR )
            ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok)
            IF (allocok > 0 ) THEN
               IFLAG = -13
               IERROR = max(NB_BLR_U,1)
               LP = ICNTL(1)
.LE.               IF (ICNTL(4)  0) LP=-1
               IF (LP > 0) WRITE(LP,*) MYID,
     &              ': error allocation during smumps_process_blocfacto'
               GOTO 700
            ENDIF
            ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok)
            IF (allocok > 0 ) THEN
               IFLAG = -13
               IERROR = NB_BLR_U+2
               LP = ICNTL(1)
.LE.               IF (ICNTL(4)  0) LP=-1
               IF (LP > 0) WRITE(LP,*) MYID,
     &              ': error allocation during smumps_process_blocfacto'
               GOTO 700
            ENDIF
            CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, 
     &                             POSITION, NPIV, NELIM, 'h',
     &                             BLR_U(1), NB_BLR_U, 
     &                             BEGS_BLR_U(1),
     &                             KEEP8, COMM, IERR, IFLAG, IERROR)
.LT.            IF (IFLAG0) GOTO 700
        ELSE
          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 A(POSBLOCFACTO), NPIV*NCOL,
     &                 MPI_REAL,
     &                 COMM, IERR )
          LD_BLOCFACTO = NCOL
        ENDIF
      ENDIF 
      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 
     &                 LRELAY_INFO, 1,
     &                 MPI_INTEGER, COMM, IERR )
.EQ.      IF (PTRIST(STEP( INODE ))  0) THEN
          CALL SMUMPS_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,
     &    PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
     &               , LRGROUPS
     &    )
.LT.          IF ( IFLAG  0 ) GOTO 600
      ENDIF
.EQ.      IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ))  0 ) THEN
.NE.       DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR)  0)
        BLOCKING = .TRUE.
        SET_IRECV = .FALSE.
        MESSAGE_RECEIVED = .FALSE.
        CALL SMUMPS_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,
     &    PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 
     &               , LRGROUPS
     &      )
.LT.        IF ( IFLAG  0 ) GOTO 600
       END  DO
      ENDIF
        SET_IRECV = .TRUE.
        BLOCKING  = .FALSE.
        MESSAGE_RECEIVED = .TRUE.
        CALL SMUMPS_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,
     &    PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, 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))
      CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA,
     &     PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR),
     &     A_PTR, POSELT, LA_PTR )
      LCONT1 = IW( IOLDPS + KEEP(IXSZ))
      NASS1  = IW( IOLDPS + 1 + KEEP(IXSZ))
.GE.      COMPRESS_PANEL = (IW(IOLDPS+XXLR)2)
      OOCWRITE_COMPATIBLE_WITH_BLR = 
.NOT..OR..NOT..OR.     &          ( LR_ACTIVATED  (COMPRESS_PANEL)
.NE.     &            (KEEP(486)2) 
     &          )
      IF ( NASS1 < 0 ) THEN
        NASS1 = -NASS1
        IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1
.EQ.        IF (KEEP(55)  0) THEN 
          CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW,
     &       IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC,
     &       FILS, PTRAIW,
     &       PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, 
     &       LRGROUPS)
        ELSE
          CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW,
     &       IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC,
     &       FILS, PTRAIW,
     &       PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26),
     &       FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS)
        ENDIF
      ENDIF
      NROW1  = IW( IOLDPS + 2 +KEEP(IXSZ))
      NPIV1  = IW( IOLDPS + 3 +KEEP(IXSZ))
      NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ))
      HS     = 6 + NSLAV1 + KEEP(IXSZ)
      NCOL1  = LCONT1 + NPIV1
.GT.      IF (NPIV0) THEN
        ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1
          DO I = 1, NPIV
.EQ.            IF (IW(IPIV+I-1)I) CYCLE
            ISW = IW(ICT11+I)
            IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1))
            IW(ICT11+IW(IPIV+I-1)) = ISW
            IPOS = POSELT + int(NPIV1 + I - 1,8)
            KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8)
            CALL sswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1)
          ENDDO
        LPOS2 = POSELT + int(NPIV1,8)
        LPOS  = LPOS2 + int(NPIV,8)
.NOT..OR..EQ.        IF (( LR_ACTIVATED)KEEP(475)0) THEN
              CALL strsm('l','l','n','n', NPIV, NROW1, ONE,
     &             A(POSBLOCFACTO), LD_BLOCFACTO,
     &             A_PTR(LPOS2), NCOL1)
        ENDIF
      ENDIF 
      COMPRESS_CB = .FALSE.
      IF ( LR_ACTIVATED) THEN 
.EQ..OR.        COMPRESS_CB    = ((IW(IOLDPS+XXLR)1)
.EQ.     &                    (IW(IOLDPS+XXLR)3))
.AND..EQ.        IF (COMPRESS_CBNPIV0) THEN
           COMPRESS_CB = .FALSE.
           IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1
        ENDIF
.NE.        IF (NPIV0) THEN
.EQ.        IF ( (NPIV10) 
     &     ) THEN
          IOLDPS = PTRIST(STEP(INODE))
          CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0,
     &                    NROW1, LRGROUPS, NPARTSCB, 
     &                    NPARTSASS, BEGS_BLR_L)
          CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB,
     &                        NROW1-0, KEEP(488), .TRUE., KEEP(472))
          NB_BLR_L =  NPARTSCB
.EQ.          IF (IPANEL1) THEN
           BEGS_BLR_COL=>BEGS_BLR_U
          ELSE
           ALLOCATE(BEGS_BLR_COL(size(BEGS_BLR_U)+IPANEL-1),
     &               stat=allocok)
           IF (allocok > 0 ) THEN
               IFLAG = -13
               IERROR = size(BEGS_BLR_U)+IPANEL-1
               LP = ICNTL(1)
.LE.               IF (ICNTL(4)  0) LP=-1
               IF (LP > 0) WRITE(LP,*) MYID,
     &           ': error allocation during smumps_process_blocfacto'
               GOTO 700
            ENDIF
            BEGS_BLR_COL(1:IPANEL-1) = 1
            DO I=1,size(BEGS_BLR_U)
               BEGS_BLR_COL(IPANEL+I-1) =  BEGS_BLR_U(I)
            ENDDO
          ENDIF
          INFO_TMP(1) = IFLAG
          INFO_TMP(2) = IERROR
.LT.          IF (IFLAG0) GOTO 700
          CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), 
     &           .FALSE.,       
     &           .TRUE.,        
     &           .TRUE.,        
     &           NPARTSASS_MASTER, 
     &           BEGS_BLR_L, 
     &           BEGS_BLR_COL, 
     &           huge(NPARTSASS_MASTER),
     &           INFO_TMP)
          IFLAG  = INFO_TMP(1) 
          IERROR = INFO_TMP(2) 
.NE.          IF (IPANEL1) THEN
            DEALLOCATE(BEGS_BLR_COL)
          ENDIF
.LT.          IF (IFLAG0) GOTO 700
        ELSE           
          CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), 
     &                  BEGS_BLR_L)
          KEEP_BEGS_BLR_L = .TRUE.  
          NB_BLR_L  = size(BEGS_BLR_L) - 2
          NPARTSASS = 1
          NPARTSCB  = NB_BLR_L
        ENDIF 
      ENDIF
      ENDIF
.GT.      IF ( (NPIV  0)
     &   ) THEN
        IF (LR_ACTIVATED) THEN
        call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L)
        call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U)
.AND.        IF (LASTBLCOMPRESS_CB) THEN
          MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L)
        ELSE
          MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L)
        ENDIF
        LWORK = MAXI_CLUSTER*MAXI_CLUSTER
        OMP_NUM = 1
#if defined(BLR_MT)
!$      OMP_NUM = OMP_GET_MAX_THREADS()
#endif
        ALLOCATE(BLOCK(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 = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER
     &          + 2*MAXI_CLUSTER*OMP_NUM
     &          + MAXI_CLUSTER*OMP_NUM
     &          + MAXI_CLUSTER*OMP_NUM
     &          + LWORK*OMP_NUM
           LP = ICNTL(1)
.LE.           IF (ICNTL(4)  0) LP=-1
           IF (LP > 0) WRITE(LP,*) MYID,
     &          ': error allocation during smumps_process_blocfacto'
           GOTO 700
        ENDIF
        CURRENT_BLR=1 
        ALLOCATE(BLR_L(NB_BLR_L), stat=allocok)
        IF (allocok > 0 ) THEN
              IFLAG = -13
              IERROR = NB_BLR_L
              LP = ICNTL(1)
.LE.              IF (ICNTL(4)  0) LP=-1
              IF (LP > 0) WRITE(LP,*) MYID,
     &             ': error allocation during smumps_process_blocfacto'
              GOTO 700
           ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
        CALL SMUMPS_COMPRESS_PANEL_I_NOOPT
     &        (A_PTR(POSELT), LA_PTR, 1_8,
     &        IFLAG, IERROR, NCOL1,
     &        BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1,
     &        DKEEP(8), KEEP(466), KEEP(473),
     &        BLR_L(1), 
     &        CURRENT_BLR, 'v', WORK, TAU, JPVT, LWORK, RWORK,
     &        BLOCK, MAXI_CLUSTER, NELIM, 
     &        .TRUE.,  
     &        NPIV, NPIV1,
     &        2, KEEP(483), KEEP8,
     &        OMP_NUM )
#if defined(BLR_MT)
!$OMP MASTER
#endif
.EQ.        IF ( (KEEP(486)2) 
     &     ) THEN
          CALL SMUMPS_BLR_SAVE_PANEL_LORU (
     &         IW(IOLDPS+XXF),
     &         0, 
     &         IPANEL, BLR_L)
        ENDIF
#if defined(BLR_MT)          
!$OMP END MASTER
!$OMP BARRIER
#endif
.LT.          IF (IFLAG0) GOTO 300
.GE.          IF (KEEP(475)1) THEN
              CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, 
     &              LD_BLOCFACTO, -6666, 
     &              NB_BLR_L+1,  
     &              BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, 
     &              2, 0, 0,  
     &              .TRUE.) 
#if defined(BLR_MT)          
!$OMP BARRIER
#endif          
.NE.            IF (KEEP(486)2) THEN
              CALL SMUMPS_DECOMPRESS_PANEL_I_NOOPT(
     &        A_PTR(POSELT), LA_PTR, 1_8,
     &        NCOL1, NCOL1,
     &        .TRUE.,    
     &        NPIV1+1,   
     &        1,         
     &        NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'v', 1)
            ENDIF
          ENDIF
 300      CONTINUE
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
.LT.          IF (IFLAG0) GOTO 700
        ENDIF
      ENDIF
.eq..AND.      IF ( (KEEP(201)1)  
.OR..EQ.     &    (OOCWRITE_COMPATIBLE_WITH_BLR  NPIV0) ) 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)
        LAST_CALL = .FALSE.
        CALL SMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L,
     &       A_PTR(POSELT),
     &       LA_PTR, MonBloc, NextPivDummy, NextPivDummy,
     &       IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL)
      ENDIF
.GT.      IF ( (NPIV  0)
     &   ) THEN
        IF (LR_ACTIVATED) THEN
.GT.          IF (NELIM0) THEN
            UPOS = 1_8+int(NPIV,8)
              CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I(
     &        A(POSBLOCFACTO), LA_BLOCFACTO, UPOS,
     &        A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8,
     &        IFLAG, IERROR, LD_BLOCFACTO, NCOL1,
     &        BEGS_BLR_L(1), size(BEGS_BLR_L),
     &        CURRENT_BLR, BLR_L(1), NB_BLR_L+1, 
     &        CURRENT_BLR+1, NELIM, 'n')
          ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
         CALL SMUMPS_BLR_UPDATE_TRAILING_I(
     &        A_PTR(POSELT), LA_PTR, 1_8, 
     &        IFLAG, IERROR, NCOL1,
     &        BEGS_BLR_L(1), size(BEGS_BLR_L),
     &        BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, 
     &        BLR_L(1), NB_BLR_L+1, 
     &        BLR_U(1), NB_BLR_U+1, 
     &        0,      
     &        .TRUE., 
     &        NPIV1,  
     &        2, 0, 
     &        KEEP(481), DKEEP(11), KEEP(466), KEEP(477) 
     &        )
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
.LT.          IF (IFLAG0) GOTO 700
        ELSE 
              UPOS = POSBLOCFACTO+int(NPIV,8)
              CALL sgemm('n','n', NCOL-NPIV, NROW1, NPIV,
     &             ALPHA,A(UPOS), NCOL,
     &             A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1)
        ENDIF 
      ENDIF 
      IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV
      IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV
      IF (LASTBL) THEN
        IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) )
      ENDIF
.not..AND.      IF (  LASTBL  
.EQ.     &   (IW(IOLDPS+1+KEEP(IXSZ))  IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN
        write(*,*) 'internal error 1 **** in blacfacto '
        CALL MUMPS_ABORT()
      ENDIF
      IF (LR_ACTIVATED) THEN
.GT.        IF ((NPIV0)
     &     ) THEN
          CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34))
          DEALLOCATE(BLR_U)
.EQ.          IF (KEEP(486)3) THEN
            CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, KEEP(34))
            DEALLOCATE(BLR_L)
          ELSE
            CALL UPD_MRY_LU_LRGAIN(BLR_L, NPARTSCB
     &               )
          ENDIF
      ENDIF 
      ENDIF 
        LRLU  = LRLU + LA_BLOCFACTO
        LRLUS = LRLUS + LA_BLOCFACTO
        KEEP8(69) = KEEP8(69) - LA_BLOCFACTO
        POSFAC = POSFAC - LA_BLOCFACTO
        CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
     &             LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
        IWPOS = IWPOS - NPIV
      FLOP1 = dble( NPIV1*NROW1 ) +
     &        dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1)
     &   -
     &        dble((NPIV1+NPIV)*NROW1 ) -
     &        dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1)
      CALL SMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 )
      IF (LASTBL) THEN
.NE.        IF (KEEP(486)0) THEN
          IF (LR_ACTIVATED) 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 (LR_ACTIVATED) THEN
         IF (COMPRESS_CB) THEN
           CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), 
     &                  BEGS_BLR_COL, NPARTSASS_MASTER_AUX)
           BEGS_BLR_COL(1+NPARTSASS_MASTER) = 
     &               BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM
           NB_BLR_COL = size(BEGS_BLR_COL) - 1
.EQ.           IF (NPIV0) THEN
             call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L)
             call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL)
             IF (COMPRESS_CB) THEN
              MAXI_CLUSTER=max(MAXI_CLUSTER_COL+NELIM,MAXI_CLUSTER_L)
             ELSE
              MAXI_CLUSTER=max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L)
             ENDIF
             LWORK = MAXI_CLUSTER*MAXI_CLUSTER
             OMP_NUM = 1
#if defined(BLR_MT)
!$           OMP_NUM = OMP_GET_MAX_THREADS()
#endif
             ALLOCATE(BLOCK(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 = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER
     &           + 2*MAXI_CLUSTER*OMP_NUM
     &           + MAXI_CLUSTER*OMP_NUM
     &           + MAXI_CLUSTER*OMP_NUM
     &           + LWORK*OMP_NUM
               LP = ICNTL(1)
.LE.               IF (ICNTL(4)  0) LP=-1
               IF (LP > 0) WRITE(LP,*) MYID,
     &          ': error allocation during smumps_process_blocfacto'
               GOTO 700
             ENDIF
           ENDIF
           allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER),
     &                 stat=allocok)
           IF (allocok > 0) THEN
             IFLAG  = -13
             IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER)
             GOTO 700
           ENDIF
           CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB)
         ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
         IF (COMPRESS_CB) THEN
           CALL SMUMPS_COMPRESS_CB_I(
     &      A_PTR(POSELT), LA_PTR, 1_8, NCOL1,
     &      BEGS_BLR_L(1), size(BEGS_BLR_L),
     &      BEGS_BLR_COL(1), size(BEGS_BLR_COL),
     &      NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER,
     &      NPARTSASS_MASTER, 
     &      NROW1, NCOL1-NPIV1-NPIV, INODE,
     &      IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR,
     &      DKEEP(12), KEEP(466), KEEP(484), KEEP(489),
     &      CB_LRB(1,1),
     &      WORK, TAU, JPVT, LWORK, RWORK, BLOCK,
     &      MAXI_CLUSTER, KEEP8, OMP_NUM,
     &      -9999, -9999, -9999, KEEP(1),
     &      IDUMMY, 0, -9999 )
#if defined(BLR_MT)
!$OMP BARRIER
#endif
         ENDIF
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif
.LT.         IF (IFLAG0) GOTO 700
       ENDIF
         CALL SMUMPS_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, PERM,
     &    IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
     &    OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, 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 (LR_ACTIVATED) THEN
        IF (allocated(RWORK))  DEALLOCATE(RWORK)
        IF (allocated(WORK)) DEALLOCATE(WORK)
        IF (allocated(TAU)) DEALLOCATE(TAU)
        IF (allocated(JPVT)) DEALLOCATE(JPVT)
        IF (allocated(BLOCK)) DEALLOCATE(BLOCK)
        IF (associated(BEGS_BLR_L)) THEN
.NOT.            IF ( KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L)
        ENDIF
.GT.        IF ((NPIV0)
     &     ) THEN
          IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U)
        ENDIF
      ENDIF
 600  CONTINUE
      RETURN
 700  CONTINUE
      CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE SMUMPS_PROCESS_BLOCFACTO
      SUBROUTINE SMUMPS_MPI_UNPACK_LR(
     &           BUFR, LBUFR, LBUFR_BYTES, POSITION,
     &                             NPIV, NELIM, DIR, 
     &                             BLR_U, NB_BLOCK_U,
     &                             BEGS_BLR_U, KEEP8,
     &                             COMM, IERR, IFLAG, IERROR)
      USE SMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB
      USE SMUMPS_LR_TYPE
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: LBUFR
      INTEGER, INTENT(IN) :: LBUFR_BYTES
      INTEGER, INTENT(IN) :: BUFR(LBUFR)
      INTEGER, INTENT(INOUT) :: POSITION
      INTEGER, INTENT(IN)    :: NB_BLOCK_U, NELIM, NPIV
      CHARACTER(len=1) :: DIR
      INTEGER, INTENT(IN) :: COMM
      INTEGER, INTENT(INOUT) :: IFLAG, IERROR
      INTEGER, INTENT(OUT) :: IERR
      TYPE (LRB_TYPE), INTENT(OUT), 
     &          DIMENSION(max(NB_BLOCK_U,1)):: BLR_U
      INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2)  :: BEGS_BLR_U 
      INTEGER(8) :: KEEP8(150)
      LOGICAL :: ISLR
      INTEGER :: ISLR_INT, I
      INTEGER :: K, M, N
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      IERR = 0
.NE.      IF (size(BLR_U)  
     &     MAX(NB_BLOCK_U,1) ) THEN
        WRITE(*,*) "Internal error 1 in SMUMPS_MPI_UNPACK",
     &             NB_BLOCK_U,size(BLR_U)
        CALL MUMPS_ABORT()
      ENDIF
      BEGS_BLR_U(1) = 1
      BEGS_BLR_U(2) = NPIV+NELIM+1 
      DO I = 1, NB_BLOCK_U
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 ISLR_INT, 1, MPI_INTEGER, COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 K, 1,
     &                 MPI_INTEGER, COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 M, 1,
     &                 MPI_INTEGER, COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                 N, 1,
     &                 MPI_INTEGER, COMM, IERR )
        BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M
.eq.        IF (ISLR_INT  1) THEN
          ISLR = .TRUE.
        ELSE
          ISLR = .FALSE.
        ENDIF
        CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, 
     &             IFLAG, IERROR, KEEP8 )
.LT.        IF (IFLAG0) RETURN
        IF (ISLR) THEN
.GT.          IF (K  0) THEN
            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                     BLR_U(I)%Q(1,1), M*K, MPI_REAL,
     &                     COMM, IERR )
            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                     BLR_U(I)%R(1,1), N*K, MPI_REAL,
     &                     COMM, IERR)
          ENDIF
        ELSE
          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                     BLR_U(I)%Q(1,1), M*N, MPI_REAL,
     &                     COMM, IERR)
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE SMUMPS_MPI_UNPACK_LR