zfac_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 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, 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 zmumps_ooc, ONLY : io_block
      USE mumps_ooc_common, ONLY : typef_l, strat_try_write
      USE zmumps_load
      USE zmumps_buf
      USE zmumps_lr_core
      USE zmumps_lr_type
      USE zmumps_lr_stats
      USE zmumps_fac_lr
      USE zmumps_ana_lr, ONLY : get_cut
      USE zmumps_lr_data_m
      USE zmumps_struc_def, ONLY : zmumps_root_struc
      USE zmumps_dynamic_memory_m, ONLY : zmumps_dm_set_dynptr
      USE zmumps_fac_front_aux_m, ONLY : zmumps_get_size_schur_in_front
!$    USE OMP_LIB
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (zmumps_root_struc) :: root
      INTEGER icntl( 60 ), 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 perm(n), 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), dad(keep(28)), 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
      INTEGER :: nfs4father, nvschur_k253, nslaves_l, IROW_L
      DOUBLE PRECISION, 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
      COMPLEX(kind=8), 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
      COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: uip21k
      COMPLEX(kind=8), 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
      COMPLEX(kind=8) one,alpha
      parameter(one=(1.0d0,0.0d0), alpha=(-1.0d0,0.0d0))
      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
      COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: work, tau
      INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
      COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: blocklr
      DOUBLE PRECISION,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 zmumps_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 zmumps_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 ",
     &     "ZMUMPS_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_double_complex,
     &                 comm, ierr )
        ELSE
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 a(posblocfacto), int(la_blocfacto),
     &                 mpi_double_complex,
     &                 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 ",
     &            "ZMUMPS_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 ",
     &            "ZMUMPS_PROCESS_SYM_BLOCFACTO"
             iflag = -13
             ierror = nb_blr_lm+2
             GOTO 700
          END IF
          CALL zmumps_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 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,
     &      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 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,
     &    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 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,
     &    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 zmumps_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 zmumps_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 zmumps_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 zswap(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 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 ((.NOT. lr_activated).OR.keep(475).EQ.0) THEN
            IF (dynamic_alloc) THEN
              CALL ztrsm( 'l', 'u', 't', 'u', npiv, nrow1, one,
     &             dyn_blocfacto, ld_blocfacto,
     &             a_ptr(poselt+int(npiv1,8)), ncol1)
            ELSE
              CALL ztrsm( '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 zscal( 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 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 (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",
     &            "ZMUMPS_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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          
.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 ZMUMPS_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 (NPIV0) THEN
        IF (LR_ACTIVATED) THEN
.GT.          IF (NELIM0) THEN
            LPOS2 = POSELT + int(NPIV1,8)
            UPOS = 1_8+int(NPIV,8)
            LPOS  = LPOS2 + int(NPIV,8)
            IF (DYNAMIC_ALLOC) THEN
              CALL ZMUMPS_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 ZMUMPS_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 ZMUMPS_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 ZMUMPS_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
.LT.          IF (IFLAG0) GOTO 400
 400      CONTINUE          
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
.LT.          IF (IFLAG0) 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)
.GT.          IF (NSLAVES_PREC0
.OR.     &       
     &       (
.EQ.     &         (KEEP(486)2) 
     &       )
     &     ) THEN
            CALL ZMUMPS_BLR_SAVE_PANEL_LORU(
     &          IW(IOLDPS+XXF),
     &          0,   
     &          IPANEL, BLR_LS)
             KEEP_BLR_LS = .TRUE.
          ENDIF
        ELSE 
.GT..AND..GT.          IF (NPIV  0  NCOL-NPIV0)THEN
          LPOS2 = POSELT + int(NPIV1,8)
          LPOS  = LPOS2 + int(NPIV,8)
            IF (DYNAMIC_ALLOC) THEN
              UPOS = int(NPIV+1,8)
              CALL zgemm('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 zgemm('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)
.EQ.            IF ( KEEP(421) -1) THEN
              LPOS2 = POSELT + int(NPIV1,8)
              UPOS  = 1_8
              CALL zgemmt( 'u', 't', 'n', NROW1, NPIV, ALPHA,
     &         UIP21K( UPOS ), NPIV,
     &         A_PTR( LPOS2 ), NCOL1, ONE,
     &         A_PTR( DPOS ), NCOL1 )
            ELSE
#endif
.GT.              IF ( NROW1  KEEP(7) ) THEN
                BLSIZE = KEEP(8)
              ELSE
                BLSIZE = NROW1
              ENDIF
.GT.              IF ( NROW1  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_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
.ne.                  IF ( NROW1-IROW+1-Block  0 )
     &            CALL zgemm( '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 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))
.NOT.      IF (  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 ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
     &                LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
      ENDIF 
      ENDIF 
.NE..and..NE.      IF ( NSLAVES_FOLLOW  0  NPIV  0 ) THEN
         IPOSK = NPIV1 + 1
         JPOSK = NCOL1 - NROW1 + 1
           NPIVSENT = NPIV
           IERR = -1
.eq.           DO WHILE ( IERR  -1 )
            IF (DYNAMIC_ALLOC) THEN
              CALL ZMUMPS_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 ZMUMPS_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
.EQ.            IF (IERR  -1 ) THEN
              IOLDPS = PTRIST(STEP(INODE))
.eq.              IF ( IW(IOLDPS+6+KEEP(IXSZ)) 
     &              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,
     &         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
.AND.              IF ( COUNTER_WAS_HUGE 
.EQ.     &             IW(IOLDPS+6+KEEP(IXSZ))1 ) THEN
                IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ)))
              ENDIF
.LT.              IF ( IFLAG  0 ) GOTO 600
            END IF
           END DO
.eq.           IF ( IERR  -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
.eq.           IF ( IERR  -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 ( LR_ACTIVATED ) THEN
.GT..AND..GT.        IF (NPIV0  NSLAVES_PREC0
.AND..EQ.     &      KEEP(486)3
     &    ) THEN
          IOLDPS = PTRIST(STEP(INODE))
          CALL ZMUMPS_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
.GT.        ELSE IF (NPIV  0) THEN
          LRLU  = LRLU + LA_BLOCFACTO
          LRLUS = LRLUS + LA_BLOCFACTO
          KEEP8(69) = KEEP8(69) - LA_BLOCFACTO
          POSFAC = POSFAC - LA_BLOCFACTO
          IWPOS = IWPOS - NPIV
      CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
     &             LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
        ENDIF 
      ENDIF 
.NE.      IF ( NPIV  0 )  THEN
        IF (allocated(UIP21K)) THEN
          DEALLOCATE( UIP21K )
        ENDIF
      ENDIF
      IOLDPS = PTRIST(STEP(INODE))
      CALL ZMUMPS_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
.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
.EQ.         IF ( IW(IOLDPS+6+KEEP(IXSZ))
     &     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 
.eq.         IF ( IW(IOLDPS+6+KEEP(IXSZ) )  0
.and..ne..and..eq.     &        KEEP(50)  0  NSLAVES_FOLLOW  0
.and..NE.     &        NSLAVES_TOT1 ) THEN
          DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)),
     &                           KEEP(199) )
          CALL ZMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT,
     &                              COMM, KEEP, IERR )
.LT.          IF ( IERR  0 ) THEN
            write(*,*) ' internal error in process_sym_blocfacto.'
            IFLAG = -99
            GOTO 700
          END IF
        ENDIF
      END IF
.eq.        IF (IW(IOLDPS+6+KEEP(IXSZ))  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 ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB)
            ENDIF
            IF (COMPRESS_CB) THEN
              NFS4FATHER = -9999
.NE..AND..EQ.              IF ( (KEEP(219)0)(KEEP(50)2) ) THEN
               CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF),
     &             NFS4FATHER )
                NFS4FATHER = max(NFS4FATHER,0) + NELIM
              ENDIF
              ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok)
.GT.              IF ( allocok  0 ) THEN
                IF (LP > 0 ) WRITE(LP,*) MYID,
     &          ": ALLOCATION FAILURE FOR M_ARRAY ",
     &          "ZMUMPS_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
.NE..AND..EQ..AND.              IF ( (KEEP(219)0)(KEEP(50)2)
.GT.     &             NFS4FATHER0  ) THEN
               CALL ZMUMPS_COMPUTE_NBROWSinF (
     &                N, INODE, FPERE, KEEP, 
     &                IOLDPS, HS, 
     &                IW, LIW, 
     &                NROW1, NCOL1, NPIV+NPIV1,
     &                NELIM, NFS4FATHER,
     &                NBROWSinF
     &                )
.EQ..AND..GT.               IF ((KEEP(114)1)  (KEEP(116)0) ) THEN
                  NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ))
                  IROW_L    = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + 
     &                        KEEP(IXSZ)
                  CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( 
     &                 N, 
     &                 NROW1,
     &                 KEEP(116), 
     &                 IW(IROW_L),
     &                 PERM, NVSCHUR_K253 )
.NE.               ELSE IF (KEEP(253)0) THEN
                  NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ))
                  IROW_L    = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + 
     &                        KEEP(IXSZ)
                  CALL ZMUMPS_GET_SIZE_SCHUR_IN_FRONT ( 
     &                 N, 
     &                 NROW1,
     &                 0,  
     &                 IW(IROW_L),
     &                 PERM, NVSCHUR_K253 )
               ENDIF
              ENDIF
.LT.              IF (IFLAG0) GOTO 700
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
              CALL ZMUMPS_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
.LT.              IF (IFLAG0) GOTO 650
.NE..AND..EQ..AND.              IF ( (KEEP(219)0)(KEEP(50)2)
.GT.     &             NFS4FATHER0  ) THEN
                 INFO_TMP(1) = IFLAG
                 INFO_TMP(2) = IERROR
                 CALL ZMUMPS_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 
.LT.            IF (IFLAG0) GOTO 700
          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, 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)
.GT.          IF (NPIV0) THEN
.NOT.            IF (KEEP_BEGS_BLR_LS) THEN
              IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS)
            ENDIF
.NOT.            IF (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)
.NOT.            IF (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 ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO