sfac_process_blocfacto_LDLT.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_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, 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_buf
      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 smumps_fac_front_aux_m, ONLY : smumps_get_size_schur_in_front
!$    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 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 perm(N), step(n), 
     & pimaster(keep(28))
      INTEGER iw( liw )
      REAL 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), 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)))
      INTEGER pivi
      INTEGER (8) pospv1,pospv2,offdag,lpos1
      INTEGER j2
      REAL mult1,mult2, a11, detpiv, a22, a12
      INTEGER :: nfs4father, nvschur_k253, nslaves_l, irow_l
      REAL, ALLOCATABLE, DIMENSION(:) :: m_array
      INTEGER nbrowsinf
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER :: status(mpi_status_size)
      INTEGER lp
      INTEGER inode, position, npiv, ierr
      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, 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
      REAL, DIMENSION(:), ALLOCATABLE :: uip21k
      REAL, DIMENSION(:), ALLOCATABLE :: dyn_blocfacto
      INTEGER, DIMENSION(:), ALLOCATABLE :: list_slaves_follow
      INTEGER, DIMENSION(:), ALLOCATABLE :: dyn_pivinfo
      LOGICAL lastbl
      INTEGER src_descband
      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
      LOGICAL counter_was_huge
      INTEGER to_update_cpt_recur
      INTEGER :: lr_activated_int
      LOGICAL :: lr_activated, compress_cb, compress_panel
      LOGICAL :: dynamic_alloc
      LOGICAL oocwrite_compatible_with_blr
      INTEGER :: xsize, current_blr, nslaves_prec, info_tmp(2)
      INTEGER :: 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
      TYPE(lrb_type), POINTER, DIMENSION(:,:) :: cb_lrb
      INTEGER, POINTER, DIMENSION(:) :: begs_blr_lm, begs_blr_ls, 
     &                                  begs_blr_col, begs_blr_col_tmp
      LOGICAL keep_begs_blr_ls, keep_begs_blr_col, keep_blr_ls
      REAL, ALLOCATABLE, DIMENSION(:) :: work, tau
      INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
      REAL, ALLOCATABLE, DIMENSION(:,:) :: blocklr
      REAL,ALLOCATABLE,DIMENSION(:) :: rwork
      INTEGER :: omp_num, lwork
      INTEGER :: ii,jj, shift
      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 )
       npartsass_col = npartsass_master
      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 )
      lr_activated    = (lr_activated_int.EQ.1)
      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 ( lr_activated ) THEN
        la_blocfacto = int(npiv,8) * int(npiv+nelim,8)
        ld_blocfacto = max(npiv+nelim,1)
      ELSE
        la_blocfacto = int(npiv,8) * int(ncol,8)
        ld_blocfacto = max(ncol,1)
      ENDIF
      IF (lr_activated) THEN
        dynamic_alloc = .true.
      ELSE
        dynamic_alloc = .false.
      ENDIF
      IF ( .NOT. dynamic_alloc ) THEN
        IF ( npiv .EQ. 0 ) THEN
          ipiv = 1  
          posblocfacto = 1_8 
        ELSE 
          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)
          IF (iflag.LT.0) GOTO 700
          lrlu  = lrlu - la_blocfacto
          lrlus = lrlus - la_blocfacto
          keep8(69) = keep8(69) + la_blocfacto
          keep8(67) = min(lrlus, keep8(67))
          keep8(68) = max(keep8(69), keep8(68))
          posblocfacto = posfac
          posfac = posfac + la_blocfacto
          ipiv = iwpos
          iwpos = iwpos + npiv
          CALL smumps_load_mem_update(.false.,.false.,
     &               la-lrlus,0_8,la_blocfacto,keep,keep8,lrlus)
        ENDIF
      ELSE 
        ALLOCATE(dyn_pivinfo(max(1,npiv)),
     &           dyn_blocfacto(max(1_8,la_blocfacto)),
     &           stat=allocok)
        IF (allocok.GT.0) THEN
           IF (lp > 0 ) WRITE(lp,*) myid,
     &     ": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ",
     &     "SMUMPS_PROCESS_SYM_BLOCFACTO"
           iflag = -13
           CALL mumps_set_ierror(max(1_8,la_blocfacto), ierror)
           GOTO 700
        ENDIF
        posblocfacto = 1_8
        ipiv = 1
      ENDIF
      IF (npiv.GT.0) THEN
        IF (dynamic_alloc) THEN
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 dyn_pivinfo, npiv,
     &                 mpi_integer, comm, ierr )
        ELSE
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 iw( ipiv ), npiv,
     &                 mpi_integer, comm, ierr )
        ENDIF
        IF (dynamic_alloc) THEN
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                dyn_blocfacto, int(la_blocfacto),
     &                 mpi_real,
     &                 comm, ierr )
        ELSE
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 a(posblocfacto), int(la_blocfacto),
     &                 mpi_real,
     &                 comm, ierr )
        ENDIF
        IF ( lr_activated ) THEN
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 nb_blr_lm, 1, mpi_integer,
     &                 comm, ierr )
          ALLOCATE(blr_lm(max(nb_blr_lm,1)), stat=allocok)
          IF ( allocok .GT. 0 ) THEN
             IF (lp > 0 ) WRITE(lp,*) myid,
     &            ": ALLOCATION FAILURE FOR BLR_LM IN ",
     &            "SMUMPS_PROCESS_SYM_BLOCFACTO"
             iflag = -13
             ierror = max(nb_blr_lm,1)
             GOTO 700
          END IF
          ALLOCATE(begs_blr_lm(nb_blr_lm+2), stat=allocok)
          IF ( allocok .GT. 0 ) THEN
             IF (lp > 0 ) WRITE(lp,*) myid,
     &            ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ",
     &            "SMUMPS_PROCESS_SYM_BLOCFACTO"
             iflag = -13
             ierror = nb_blr_lm+2
             GOTO 700
          END IF
          CALL smumps_mpi_unpack_lr(
     &          bufr, lbufr, lbufr_bytes, position, npiv, nelim, 
     &          'V', blr_lm, nb_blr_lm,
     &          begs_blr_lm(1), keep8, comm, ierr, iflag, ierror)
          IF (iflag.LT.0) GOTO 700
        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)), keep(199) )
          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
     &        )
          IF ( iflag .LT. 0 ) GOTO 600
      ENDIF
      IF ( iw( ptrist(step(inode)) + 3 + keep(ixsz)) .EQ. 0 ) THEN
       DO WHILE ( iw(ptrist(step(inode)) + xxnbpr) .NE. 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
     &      )
        IF ( iflag .LT. 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))
      compress_panel = (iw(ioldps+xxlr).GE.2)
      oocwrite_compatible_with_blr = 
     &          ( .NOT.lr_activated.OR.  (.NOT.compress_panel).OR.
     &            (keep(486).NE.2) 
     &          )
      IF ( nass1 < 0 ) THEN
        nass1 = -nass1
        iw( ioldps + 1 + keep(ixsz)) = nass1
        IF (keep(55) .EQ. 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))
      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
        ict11 = ioldps+hs+nrow1+npiv1 - 1
        DO i = 1, npiv
          IF (dynamic_alloc) THEN
            pivi = abs(dyn_pivinfo(i))
          ELSE
            pivi = abs(iw(ipiv+i-1))
          ENDIF
          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 sswap(nrow1, a_ptr(ipos), ncol1, a_ptr(kpos), ncol1)
        ENDDO
        IF (.NOT.lr_activated) THEN
          ALLOCATE( uip21k( npiv * nrow1 ), stat = allocok )
          IF ( allocok .GT. 0 ) THEN
            IF (lp > 0 ) WRITE(lp,*) myid,
     &": ALLOCATION FAILURE FOR UIP21K IN SMUMPS_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 SMUMPS_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 SMUMPS_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 ((.NOT. lr_activated).OR.keep(475).EQ.0) THEN
            IF (dynamic_alloc) THEN
              CALL strsm( 'L', 'U', 'T', 'U', npiv, nrow1, one,
     &             dyn_blocfacto, ld_blocfacto,
     &             a_ptr(poselt+int(npiv1,8)), ncol1)
            ELSE
              CALL strsm( 'L', 'U', 'T', 'U', npiv, nrow1, one,
     &             a( posblocfacto ), ld_blocfacto,
     &             a_ptr(poselt+int(npiv1,8)), ncol1)
            ENDIF
        ENDIF
        IF (.NOT.lr_activated) THEN
         lpos = poselt + int(npiv1,8)
         upos = 1_8
         DO i = 1, nrow1
          uip21k( upos: upos + int(npiv-1,8) ) = 
     &                       a_ptr(lpos: lpos+int(npiv-1,8))
          lpos = lpos + int(ncol1,8)
          upos = upos + int(npiv,8)
         END DO
        ENDIF
        IF ((.NOT. lr_activated).OR.keep(475).EQ.0) THEN
          lpos = poselt + int(npiv1,8)
          IF (dynamic_alloc) THEN
            dpos = 1_8
          ELSE
            dpos = posblocfacto
          ENDIF
          i = 1
          DO
            IF(i .GT. npiv) EXIT
            IF (dynamic_alloc) THEN
              pivi = dyn_pivinfo(i)
            ELSE
              pivi = iw(ipiv+i-1)
            ENDIF
            IF(pivi .GT. 0) THEN
              IF (dynamic_alloc) THEN
                a11 = one/dyn_blocfacto(dpos)
              ELSE
                a11 = one/a(dpos)
              ENDIF
              CALL sscal( nrow1, a11, a_ptr(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
              IF (dynamic_alloc) THEN
                a11 = dyn_blocfacto(pospv1)
                a22 = dyn_blocfacto(pospv2)
                a12 = dyn_blocfacto(offdag)
                detpiv = a11*a22 - a12**2
                a22 = a11/detpiv
                a11 = dyn_blocfacto(pospv2)/detpiv
                a12 = -a12/detpiv
              ELSE
                a11 = a(pospv1)
                a22 = a(pospv2)
                a12 = a(offdag)
                detpiv = a11*a22 - a12**2
                a22 = a11/detpiv
                a11 = a(pospv2)/detpiv
                a12 = -a12/detpiv
              ENDIF
              lpos1 = lpos
              DO j2 = 1,nrow1
                 mult1 = a11*a_ptr(lpos1)+a12*a_ptr(lpos1+1_8)
                 mult2 = a12*a_ptr(lpos1)+a22*a_ptr(lpos1+1_8)
                 a_ptr(lpos1) = mult1
                 a_ptr(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
      ENDIF 
      compress_cb = .false.
      IF ( lr_activated) THEN
        nslaves_prec = nslaves_tot - nslaves_follow -1
        compress_cb    = ((iw(ioldps+xxlr).EQ.1).OR.
     &                    (iw(ioldps+xxlr).EQ.3))
      ENDIF
      IF (compress_cb.AND.npiv.EQ.0) THEN
           compress_cb = .false.
           iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
      ENDIF
      IF (npiv.GT.0) THEN
         IF (nrow1.LE.0) THEN
            CALL mumps_abort()  
         ENDIF
       IF (lr_activated) THEN
        IF (npiv1.NE.0) THEN
           CALL smumps_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 (compress_cb) 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
          IF (npartsass_master.NE.npartsass_col) THEN
             IF (npartsass_master.GT.npartsass_col) THEN
             ENDIF
             shift = npartsass_col-npartsass_master
             ALLOCATE(begs_blr_col_tmp(size(begs_blr_col)-shift), 
     &        stat=allocok)
              IF ( allocok .GT. 0 ) THEN
                IF (lp > 0 ) WRITE(lp,*) myid,
     &            ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in",
     &            "SMUMPS_PROCESS_SYM_BLOCFACTO"
                iflag = -13
                ierror = size(begs_blr_col)-shift
                GOTO 700
              END IF
              DO ii= 1, size(begs_blr_col)-shift
               begs_blr_col_tmp(ii) = begs_blr_col(ii+shift)
              ENDDO
              begs_blr_col_tmp(1) = 1
              DEALLOCATE(begs_blr_col)
              begs_blr_col => begs_blr_col_tmp
              npartsass_col = npartsass_master
              nb_blr_col = npartscb_col + npartsass_col
          ENDIF
         ELSE
            CALL smumps_blr_retrieve_begs_blr_c (iw(ioldps+xxf), 
     &                  begs_blr_col, npartsass_col )
            keep_begs_blr_col = .true.  
            nb_blr_col   = size(begs_blr_col) - 1
            npartscb_col = nb_blr_col - npartsass_col 
         ENDIF
         CALL max_cluster(begs_blr_col,nb_blr_col,maxi_cluster_col)
         maxi_cluster = max(maxi_cluster,maxi_cluster_col+nelim)
        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
          IF ( (keep(486).EQ.2) 
     &       ) THEN
            nb_accesses_init = huge(npartsass_master)
          END IF
          info_tmp(1) = iflag
          info_tmp(2) = ierror
          IF (iflag.LT.0) GOTO 700
          CALL smumps_blr_save_init(iw(ioldps+xxf), 
     &              .true., .true., .true., npartsass_col, 
     &              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))
           GOTO 700
        ENDIF
          current_blr = 1
          ALLOCATE(blr_ls(nb_blr_ls), stat=allocok)
          IF (allocok > 0 ) THEN
             iflag  = -13
             ierror = nb_blr_ls
             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_ls(1), size(begs_blr_ls), nb_blr_ls+1,
     &        dkeep(8), keep(466), keep(473),
     &        blr_ls(1), 
     &        current_blr, 'V', work, tau, jpvt, lwork, rwork,
     &        blocklr, maxi_cluster, nelim, 
     &        .true.,  
     &        npiv, npiv1,
     &        2, keep(483), keep8, 
     &        omp_num)
#if defined(BLR_MT)          
!$OMP BARRIER
#endif
          IF (iflag.LT.0) GOTO 300
          IF (keep(475).GE.1) THEN
            IF (dynamic_alloc) THEN
              CALL smumps_blr_panel_lrtrsm(
     &              dyn_blocfacto, la_blocfacto, 1_8,
     &              ld_blocfacto, -6666, 
     &              nb_blr_ls+1, 
     &              blr_ls, current_blr, current_blr+1, nb_blr_ls+1, 
     &              2, 1, 0, 
     &              .true., 
     &              dyn_pivinfo, offset_iw=1)
            ELSE
            CALL smumps_blr_panel_lrtrsm(a, la, posblocfacto, 
     &              ld_blocfacto, -6666, 
     &              nb_blr_ls+1, 
     &              blr_ls, current_blr, current_blr+1, nb_blr_ls+1, 
     &              2, 1, 0, 
     &              .true., 
     &              iw, offset_iw=ipiv)
            ENDIF
#if defined(BLR_MT)          
!$OMP BARRIER
#endif          
            IF (keep(486).NE.2) THEN
              CALL smumps_decompress_panel_i_noopt(
     &        a_ptr(poselt), la_ptr, 1_8,
     &        ncol1, ncol1,
     &        .true.,    
     &        npiv1+1,   
     &        1,         
     &        nb_blr_ls+1, blr_ls(1), current_blr, 'V', 1)
            ENDIF
          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. 
     &    (oocwrite_compatible_with_blr .OR. npiv.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)
        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
      IF (npiv.GT.0) THEN
        IF (lr_activated) THEN
          IF (nelim.GT.0) THEN
            lpos2 = poselt + int(npiv1,8)
            upos = 1_8+int(npiv,8)
            lpos  = lpos2 + int(npiv,8)
            IF (dynamic_alloc) THEN
              CALL smumps_blr_upd_nelim_var_l_i(
     &        dyn_blocfacto, la_blocfacto, upos,
     &        a_ptr(poselt), la_ptr, lpos-poselt+1_8,
     &        iflag, ierror, ld_blocfacto, ncol1,
     &        begs_blr_ls(1), size(begs_blr_ls),
     &        current_blr, blr_ls(1), nb_blr_ls+1, 
     &        current_blr+1, nelim, 'N')
            ELSE
              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_ls(1), size(begs_blr_ls),
     &        current_blr, blr_ls(1), nb_blr_ls+1, 
     &        current_blr+1, nelim, 'N')
            ENDIF
          ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif          
          IF (dynamic_alloc) THEN
            CALL smumps_blr_slv_upd_trail_ldlt_i(
     &        a_ptr(poselt), la_ptr, 1_8, 
     &        iflag, ierror, ncol1, nrow1,
     &        dyn_blocfacto, la_blocfacto,
     &        ld_blocfacto, 
     &        begs_blr_lm(1), size(begs_blr_lm), nb_blr_lm+1,
     &        blr_lm(1), npiv1, 
     &        begs_blr_ls(1), size(begs_blr_ls), nb_blr_ls+1,
     &        blr_ls(1), 0, 
     &        current_blr, current_blr,   
     &        dyn_pivinfo, 
     &        blocklr,
     &        maxi_cluster, omp_num,
     &        keep(481), dkeep(11), keep(466), keep(477) 
     &        )
          ELSE
            CALL smumps_blr_slv_upd_trail_ldlt_i(
     &        a_ptr(poselt), la_ptr, 1_8, 
     &        iflag, ierror, ncol1, nrow1,
     &        a(posblocfacto), la_blocfacto,
     &        ld_blocfacto, 
     &        begs_blr_lm(1), size(begs_blr_lm), nb_blr_lm+1,
     &        blr_lm(1), npiv1, 
     &        begs_blr_ls(1), size(begs_blr_ls), nb_blr_ls+1,
     &        blr_ls(1), 0, 
     &        current_blr, current_blr,   
     &        iw(ipiv), 
     &        blocklr,
     &        maxi_cluster, omp_num,
     &        keep(481), dkeep(11), keep(466), keep(477) 
     &        )
          ENDIF
          IF (iflag.LT.0) GOTO 400
 400      CONTINUE          
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
          IF (iflag.LT.0) GOTO 700
          CALL upd_mry_lu_lrgain(blr_ls, npartscb
     &               )
          CALL dealloc_blr_panel(blr_lm, nb_blr_lm, keep8, keep(34))
          DEALLOCATE(blr_lm)
          IF (nslaves_prec.GT.0
     &       .OR.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &     ) THEN
            CALL smumps_blr_save_panel_loru(
     &          iw(ioldps+xxf),
     &          0,   
     &          ipanel, blr_ls)
             keep_blr_ls = .true.
          ENDIF
        ELSE 
          IF (npiv .GT. 0 .AND. ncol-npiv.GT.0)THEN
          lpos2 = poselt + int(npiv1,8)
          lpos  = lpos2 + int(npiv,8)
            IF (dynamic_alloc) THEN
              upos = int(npiv+1,8)
              CALL sgemm('N','N', ncol-npiv, nrow1, npiv,
     &             alpha, dyn_blocfacto(upos), ncol,
     &             a_ptr(lpos2), ncol1, one, a_ptr(lpos), ncol1)
            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
          dpos = poselt + int(ncol1 - nrow1,8)
#if defined(GEMMT_AVAILABLE)
            IF ( keep(421).EQ. -1) THEN
              lpos2 = poselt + int(npiv1,8)
              upos  = 1_8
              CALL sgemmt( 'U', 'T', 'N', nrow1, npiv, alpha,
     &         uip21k( upos ), npiv,
     &         a_ptr( lpos2 ), ncol1, one,
     &         a_ptr( dpos ), ncol1 )
            ELSE
#endif
              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 sgemv( 'T', npiv, block-i+1, alpha,
     &             a_ptr( lpos2 + int(i - 1,8) * int(ncol1,8) ), ncol1,
     &             uip21k( upos + int(npiv,8) * int( i - 1, 8 ) ),
     &             1, one, a_ptr(dpos+int(ncol1+1,8)*int(i-1,8)),ncol1 )
                  END DO
                  IF ( nrow1-irow+1-block .ne. 0 )
     &            CALL sgemm( 'T', 'N', block, nrow1-irow+1-block,
     &            npiv, alpha,
     &            uip21k( upos ), npiv,
     &            a_ptr( lpos2 + int(block,8) * int(ncol1,8) ), ncol1,
     &            one,
     &            a_ptr( dpos + int(block,8) * int(ncol1,8) ), ncol1 )
                ENDDO
              ENDIF
#if defined(GEMMT_AVAILABLE)
            ENDIF 
#endif
        ENDIF 
        flop1 = dble(nrow1) * dble(npiv) *
     &           dble( 2 * ncol  - npiv + nrow1 +1 )
        flop1 = -flop1
        CALL smumps_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. lr_activated ) THEN
      IF (dynamic_alloc) THEN
        IF (allocated(dyn_pivinfo)  ) DEALLOCATE(dyn_pivinfo)
        IF (allocated(dyn_blocfacto)) THEN
           DEALLOCATE(dyn_blocfacto)
        ENDIF
      ELSE
      lrlu  = lrlu + la_blocfacto
      lrlus = lrlus + la_blocfacto
      keep8(69) = keep8(69) - la_blocfacto
      posfac = posfac - la_blocfacto
      iwpos = iwpos - npiv
      CALL smumps_load_mem_update(.false.,.false.,
     &                la-lrlus,0_8,-la_blocfacto,keep,keep8,lrlus)
      ENDIF 
      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 )
            IF (dynamic_alloc) THEN
              CALL smumps_buf_send_blfac_slave(
     &                    inode, npivsent, fpere,
     &                    iposk, jposk,
     &                    uip21k, nrow1,
     &                    nslaves_follow,
     &                    list_slaves_follow(1),
     &                    comm, keep,
     &             lr_activated, blr_ls, ipanel, 
     &             dyn_blocfacto, la_blocfacto,
     &             1_8, ld_blocfacto,
     &             dyn_pivinfo, maxi_cluster,
     &                    ierr )
            ELSE
              CALL smumps_buf_send_blfac_slave(
     &                    inode, npivsent, fpere,
     &                    iposk, jposk,
     &                    uip21k, nrow1,
     &                    nslaves_follow,
     &                    list_slaves_follow(1),
     &                    comm, keep,
     &             lr_activated, blr_ls, ipanel, 
     &             a, la, 
     &             posblocfacto, ld_blocfacto,
     &             iw(ipiv), maxi_cluster,
     &                    ierr )
            ENDIF
            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 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))
              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 ( ierr .eq. -2 ) THEN
              IF (lp > 0 ) WRITE(lp,*) myid,
     &": FAILURE, SEND BUFFER TOO SMALL DURING
     & SMUMPS_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
     & SMUMPS_PROCESS_SYM_BLOCFACTO"
             iflag = -20
             ierror = 5 * keep(34) + npiv * nrow1 * keep(35)
             GOTO 700
           END IF
           DEALLOCATE(list_slaves_follow)
      END IF
      IF ( lr_activated ) THEN
        IF (npiv.GT.0 .AND. nslaves_prec.GT.0
     &     .AND. keep(486).EQ.3
     &    ) THEN
          ioldps = ptrist(step(inode))
          CALL smumps_blr_dec_and_tryfree_l(iw(ioldps+xxf),ipanel,
     &                       keep8, keep(34))
        ENDIF 
        IF (dynamic_alloc) THEN
          IF (allocated(dyn_pivinfo))   DEALLOCATE(dyn_pivinfo)
          IF (allocated(dyn_blocfacto)) THEN
            DEALLOCATE(dyn_blocfacto)
          ENDIF
        ELSE IF (npiv .GT. 0) THEN
          lrlu  = lrlu + la_blocfacto
          lrlus = lrlus + la_blocfacto
          keep8(69) = keep8(69) - la_blocfacto
          posfac = posfac - la_blocfacto
          iwpos = iwpos - npiv
      CALL smumps_load_mem_update(.false.,.false.,
     &             la-lrlus,0_8,-la_blocfacto,keep,keep8,lrlus)
        ENDIF 
      ENDIF 
      IF ( npiv .NE. 0 )  THEN
        IF (allocated(uip21k)) THEN
          DEALLOCATE( uip21k )
        ENDIF
      ENDIF
      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 )
      IF (lastbl) THEN
         IF ( keep(486) .NE. 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 ( 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)),
     &                           keep(199) )
          CALL smumps_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 
          nelim =  iw( ioldps + 4 + keep(ixsz)) - 
     &              iw( ioldps + 3  + keep(ixsz))
          IF (lr_activated) THEN
            IF (compress_cb) THEN
              allocate(cb_lrb(nb_blr_ls,nb_blr_col-npartsass_col),
     &                 stat=allocok)
              IF (allocok > 0) THEN
                iflag  = -13
                ierror = nb_blr_ls*(nb_blr_col-npartsass_col)
                GOTO 700
              ENDIF
              DO ii=1,nb_blr_ls
              DO jj=1,nb_blr_col-npartsass_col
                cb_lrb(ii,jj)%M=0
                cb_lrb(ii,jj)%N=0
                NULLIFY(cb_lrb(ii,jj)%Q)
                NULLIFY(cb_lrb(ii,jj)%R)
                cb_lrb(ii,jj)%ISLR = .false.
              ENDDO
              ENDDO
              CALL smumps_blr_save_cb_lrb(iw(ioldps+xxf),cb_lrb)
            ENDIF
            IF (compress_cb) THEN
              nfs4father = -9999
              IF ( (keep(219).NE.0).AND.(keep(50).EQ.2) ) THEN
               CALL smumps_blr_retrieve_nfs4father ( iw(ioldps+xxf),
     &             nfs4father )
                nfs4father = max(nfs4father,0) + nelim
              ENDIF
              ALLOCATE(m_array(max(1,nfs4father)), stat=allocok)
              IF ( allocok .GT. 0 ) THEN
                IF (lp > 0 ) WRITE(lp,*) myid,
     &          ": ALLOCATION FAILURE FOR M_ARRAY ",
     &          "SMUMPS_PROCESS_SYM_BLOCFACTO"
                iflag = -13
                ierror = max(1,nfs4father)
              ENDIF
              begs_blr_col(1+npartsass_col) = 
     &               begs_blr_col(1+npartsass_col) - nelim
              nbrowsinf    = 0
              nvschur_k253 =  0
              IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
     &             nfs4father.GT.0  ) THEN
               CALL smumps_compute_nbrowsinf (
     &                n, inode, fpere, keep, 
     &                ioldps, hs, 
     &                iw, liw, 
     &                nrow1, ncol1, npiv+npiv1,
     &                nelim, nfs4father,
     &                nbrowsinf
     &                )
               IF ((keep(114).EQ.1) .AND. (keep(116).GT.0) ) THEN
                  nslaves_l = iw(ptrist(step(inode)) + 5 + keep(ixsz))
                  irow_l    = ptrist(step(inode)) + 6 + nslaves_l + 
     &                        keep(ixsz)
                  CALL smumps_get_size_schur_in_front ( 
     &                 n, 
     &                 nrow1,
     &                 keep(116), 
     &                 iw(irow_l),
     &                 perm, nvschur_k253 )
               ELSE IF (keep(253).NE.0) THEN
                  nslaves_l = iw(ptrist(step(inode)) + 5 + keep(ixsz))
                  irow_l    = ptrist(step(inode)) + 6 + nslaves_l + 
     &                        keep(ixsz)
                  CALL smumps_get_size_schur_in_front ( 
     &                 n, 
     &                 nrow1,
     &                 0,  
     &                 iw(irow_l),
     &                 perm, nvschur_k253 )
               ENDIF
              ENDIF
              IF (iflag.LT.0) GOTO 700
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
              CALL smumps_compress_cb_i(
     &        a_ptr(poselt), la_ptr, 1_8, ncol1,
     &        begs_blr_ls(1), size(begs_blr_ls),
     &        begs_blr_col(1), size(begs_blr_col),
     &        nb_blr_ls, nb_blr_col-npartsass_col,
     &        npartsass_col, 
     &        nrow1, ncol1-npiv1-npiv, inode,
     &        iw(ioldps+xxf), 1, 2, iflag, ierror,
     &        dkeep(12), keep(466), keep(484), keep(489),
     &        cb_lrb(1,1),
     &        work, tau, jpvt, lwork, rwork, blocklr,
     &        maxi_cluster, keep8, omp_num,
     &        nfs4father, npiv1+npiv, nvschur_k253, keep(1), 
     &        m_array
     &        , nelim, nbrowsinf
     &        )
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif
              IF (iflag.LT.0) GOTO 650
              IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
     &             nfs4father.GT.0  ) THEN
                 info_tmp(1) = iflag
                 info_tmp(2) = ierror
                 CALL smumps_blr_save_m_array( iw(ioldps+xxf),
     &            m_array, info_tmp)
                 iflag  = info_tmp(1) 
                 ierror = info_tmp(2) 
              ENDIF
              DEALLOCATE(m_array)
 650          CONTINUE         
            ENDIF 
            IF (iflag.LT.0) 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(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, keep(34))
              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 (compress_cb) THEN
                IF (associated(begs_blr_col)) THEN 
                  DEALLOCATE( begs_blr_col)
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
 600  CONTINUE
      RETURN
 700  CONTINUE
      CALL smumps_bdc_error( myid, slavef, comm, keep )
      RETURN
      END SUBROUTINE smumps_process_sym_blocfacto