dfac_mem_stack.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
      SUBROUTINE dmumps_fac_stack(COMM_LOAD, ASS_IRECV, 
     &    N, INODE, TYPE, TYPEF, 
     &    LA, IW, LIW, A,
     &    IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV,
     &    PTRIST, PTLUST_S,
     &    PTRFAC, PTRAST,
     &    STEP, PIMASTER, PAMASTER, NE,
     &    POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP,
     &    COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF,
     &    FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S,
     &    PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root,
     &    OPASSW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR,
     &    ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT,
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &               , LRGROUPS
     &  , FLOP_ESTIM_ACC
     &    )
      USE dmumps_buf
      USE dmumps_load
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      TYPE (DMUMPS_ROOT_STRUC) :: root
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER COMM, MYID, TYPE, TYPEF
      INTEGER N, LIW, INODE,IFLAG,IERROR
      INTEGER ICNTL(60), KEEP(500)
      DOUBLE PRECISION    DKEEP(230)
      INTEGER(8) KEEP8(150)
      INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU
      INTEGER IWPOSCB, IWPOS,
     &        FPERE, SLAVEF, NELVAW, NMAXNPIV
      INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28))
      INTEGER(8) :: PTRAST  (KEEP(28))
      INTEGER(8) :: PTRFAC  (KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28))
      INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28))
      DOUBLE PRECISION    A(LA)
      INTEGER, intent(in) :: LRGROUPS(N)
      DOUBLE PRECISION OPASSW, OPELIW
      DOUBLE PRECISION DBLARR(KEEP8(26))
      INTEGER INTARR(KEEP8(27)) 
      INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ),
     &        nd( keep(28) ), frere( keep(28) )
      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER NELT, LPTRAR
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR )
      INTEGER LPOOL, LEAF, COMP
      INTEGER IPOOL( LPOOL )
      INTEGER NSTK_S( KEEP(28) )
      INTEGER PERM(N) 
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER NBFIN
      INTEGER NFRONT_ESTIM,NELIM_ESTIM
      DOUBLE PRECISION FLOP_ESTIM_ACC
      INTEGER MUMPS_PROCNODE
      EXTERNAL MUMPS_PROCNODE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER LP
      INTEGER NBROWS_ALREADY_SENT 
      INTEGER(8) :: POSELT, OPSFAC
      INTEGER(8) :: IOLD, INEW, FACTOR_POS
      INTEGER NSLAVES, NCB,
     &        h_inode, ierr, nbcol, nbrow, nbrow_send,
     &        nelim
      INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK
      INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED,
     &ncbrow_newly_moved
      INTEGER(8) :: LAST_ALLOWED_POS
      INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE
      INTEGER(8) :: SHIFT_VAL_SON
      INTEGER SHIFT_LIST_ROW_SON,
     &        shift_list_col_son,
     &        list_row_son, list_col_son, list_slaves
      INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND,
     &        lreqi, lcont
      INTEGER I,LDA, INIV2
      INTEGER MSGDEST, MSGTAG, CHK_LOAD
      include 'mumps_headers.h'
      LOGICAL  MUST_COMPACT_FACTORS
      LOGICAL  PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE
      LOGICAL  INPLACE
      INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES
      INTEGER INTSIZ
      DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE
      LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR,
     & mumps_in_or_root_ssarbr, mumps_rootssarbr
      EXTERNAL mumps_inssarbr, mumps_in_or_root_ssarbr,
     & mumps_rootssarbr
      lp = icntl(1)
      IF (icntl(4) .LE. 0) lp = -1
      inplace = .false.
      min_space_in_place = 0_8
      ioldps = ptlust_s(step(inode))
      intsiz = iw(ioldps+xxi)
      nfront = iw(ioldps+keep(ixsz))
      npiv   = iw(ioldps + 1+keep(ixsz))       
      nmaxnpiv = max(npiv, nmaxnpiv)
      nass   = iabs(iw(ioldps + 2+keep(ixsz))) 
      nslaves=  iw(ioldps+5+keep(ixsz))
      h_inode= 6 + nslaves + keep(ixsz)
      lcont = nfront - npiv
      nbcol = lcont
      ssarbr = mumps_inssarbr(procnode_steps(step(inode)),keep(199))
      ssarbr_root = mumps_in_or_root_ssarbr
     &              (procnode_steps(step(inode)),keep(199))
      lreqcb = 0_8
      inplace = .false.
      packed_cb  = ((keep(215).EQ.0)
     &             .AND.(keep(50).NE.0)
     &             .AND.(typef.EQ.1
     &             .OR.typef.EQ.2
     &              )
     &             .AND.(type.EQ.1))
      compress_panel = (iw(ioldps+xxlr).GE.2)
      compress_cb    = (iw(ioldps+xxlr).EQ.1.OR.iw(ioldps+xxlr).EQ.3)
      lr_solve       = (keep(486).EQ.2)
      must_compact_factors = .true.
      IF (keep(201).EQ.1 .OR. keep(201).EQ.-1 
     &    .OR. (compress_panel.AND.lr_solve)
     &    ) THEN
            must_compact_factors = .false.
      ENDIF
      IF ((fpere.EQ.0).AND.(nass.NE.npiv)) THEN 
        iflag = -10
        GOTO 600
      ENDIF
      nbrow      = lcont
      IF (type.EQ.2) nbrow = nass - npiv
      IF ((keep(50).NE.0).AND.(type.EQ.2)) THEN
        lda = nass
      ELSE
        lda = nfront
      ENDIF
      nbrow_send = nbrow
      nelim = nass-npiv
      IF (typef.EQ.2) nbrow_send = nelim 
      poselt = ptrast(step(inode))
      IF (poselt .ne. ptrfac(step(inode))) THEN
        WRITE(*,*) myid,":Error 1 in DMUMPS_FAC_STACK:"
        WRITE(*,*) "INODE,  PTRAST, PTRFAC =", 
     &  inode, ptrast(step(inode)), ptrfac(step(inode))
        WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES",
     &  packed_cb, nfront, npiv, nass, nslaves
        WRITE(*,*) "TYPE, TYPEF, FPERE ", 
     & TYPE, typef, fpere
        CALL mumps_abort()
      END IF
      nelvaw = nelvaw + nass - npiv
      IF (keep(50) .eq. 0) THEN
        fac_entries = int(npiv,8) * int(nfront,8)
      ELSE
        fac_entries = ( int(npiv,8)*int(npiv+1,8) )/ 2_8
      ENDIF
      fac_entries = fac_entries + int(nbrow,8) * int(npiv,8)
      IF ( keep(405) .EQ. 0 ) THEN
        keep8(10) = keep8(10) + fac_entries
        keep(429) = keep(429) - 1
      ELSE
!$OMP ATOMIC UPDATE
        keep8(10) = keep8(10) + fac_entries
!$OMP END ATOMIC
      ENDIF
      CALL mumps_get_flops_cost( nfront, npiv, nass,
     &     keep(50), TYPE,flop1 )
      IF ( (.NOT. ssarbr_root) .and. TYPE == 1) then
        IF (ne(step(inode))==0) THEN
          chk_load=0
        ELSE
          chk_load=1
        ENDIF
        CALL dmumps_load_update(chk_load, .false., -flop1,
     &                      keep,keep8)
      ENDIF
      flop1_effective = flop1
      opeliw = opeliw + flop1
      IF ( npiv .NE. nass ) THEN
        CALL mumps_get_flops_cost( nfront, nass, nass,
     &       keep(50), TYPE,FLOP1 )
         IF (.NOT. ssarbr_root ) THEN
            IF (ne(step(inode))==0) THEN
              chk_load=0
            ELSE
              chk_load=1
            ENDIF
            CALL dmumps_load_update(chk_load, .false.,
     &                         flop1_effective-flop1,
     &                         keep,keep8)
         ENDIF
      END IF
      IF ( ssarbr_root ) THEN
        nfront_estim=nd(step(inode)) + keep(253)
        nelim_estim=nass-(nfront-nfront_estim)
        CALL mumps_get_flops_cost(nfront_estim,nelim_estim,nelim_estim,
     &       keep(50),1,flop1)
      END IF
      flop1=-flop1
      IF (keep(400).GT.0) THEN
        flop_estim_acc = flop_estim_acc + flop1
      ENDIF
      IF (ssarbr_root) THEN
        CALL dmumps_load_update(0,.false.,flop1,keep,keep8)
      ELSE
        CALL dmumps_load_update(2,.false.,flop1,keep,keep8)
      ENDIF
      IF ( fpere .EQ. 0 ) THEN
        IF ( keep(253) .NE. 0 .AND. keep(201).NE.-1
     &       .AND. keep(201).NE.1 
     &    .AND. (.NOT.compress_panel.OR..NOT.lr_solve)
     &       ) THEN
          must_compact_factors = .true.
          GOTO 190 
        ELSE IF ( keep(50) .NE. 0 .AND. keep(459).GT.1) THEN
          must_compact_factors = .true.
          GOTO 190 
        ELSE
          must_compact_factors = .false.
          GOTO 190 
        ENDIF
      ENDIF
      IF ( fpere.EQ.keep(38) ) THEN
       ncb   = nfront - nass
       shift_list_row_son = h_inode + nass
       shift_list_col_son = h_inode + nfront + nass
       shift_val_son      = int(nass,8)*int(nfront+1,8)
       IF (type.EQ.1) THEN
         CALL dmumps_build_and_send_cb_root(
     &    comm_load, ass_irecv, 
     &    n, inode, fpere,
     &    ptlust_s, ptrast,
     &    root, ncb, ncb, shift_list_row_son,
     &    shift_list_col_son , shift_val_son, nfront,
     &    root_cont_static, 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,.false., nd, frere,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &     )
          IF (iflag < 0 ) GOTO 500
       ENDIF
       msgdest=  mumps_procnode(procnode_steps(step(fpere)),keep(199))
       ioldps = ptlust_s(step(inode))
       list_row_son = ioldps + h_inode + npiv
       list_col_son = ioldps + h_inode + nfront + npiv
       list_slaves  = ioldps + 6 + keep(ixsz)
       IF (msgdest.EQ.myid) THEN
         CALL dmumps_process_rtnelind( root, 
     &      inode, nelim, nslaves, iw(list_row_son), 
     &      iw(list_col_son), iw(list_slaves),
     &
     &      procnode_steps, iwpos, iwposcb, iptrlu,
     &      lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &      ptlust_s, ptrfac,
     &      ptrast, step, pimaster, pamaster, nstk_s,
     &      itloc, rhs_mumps, comp,
     &      iflag, ierror, 
     &      ipool, lpool, leaf, myid, slavef,
     &      keep, keep8, dkeep,
     &      comm, comm_load, fils, dad, nd)
         IF (iflag.LT.0) GOTO 600
       ELSE
        ierr = -1
        DO WHILE (ierr.EQ.-1)
         CALL dmumps_buf_send_rtnelind( inode, nelim, 
     &     iw(list_row_son), iw(list_col_son), nslaves, 
     &     iw(list_slaves), msgdest, comm, keep, ierr)
         IF ( ierr .EQ. -1 ) THEN
            blocking   =.false.
            set_irecv  =.true.
            message_received = .false.
            CALL dmumps_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, lptrar, nelt,
     &       frtptr, frtelt, 
     &       istep_to_iniv2, tab_pos_in_pere,
     &       .true., lrgroups
     &        )
            IF ( iflag .LT. 0 ) GOTO 500
            ioldps = ptlust_s(step(inode))
            list_row_son = ioldps + h_inode + npiv
            list_col_son = ioldps + h_inode + nfront + npiv
            list_slaves  = ioldps + 6 + keep(ixsz)
         ENDIF
        ENDDO
        IF ( ierr .EQ. -2 ) THEN 
            ierror = ( 3 + nslaves + 2 * nelim ) * keep( 34 ) 
            iflag  = - 17
            GOTO 600
        ELSE IF ( ierr .EQ. -3 ) THEN
            ierror = ( 3 + nslaves + 2 * nelim ) * keep( 34 ) 
            iflag  = -20
            GOTO 600
        ENDIF
       ENDIF
       IF (nelim.EQ.0) THEN 
          poselt = ptrast(step(inode))
          opsfac = poselt + int(npiv,8) * int(nfront,8) + int(npiv,8)
          GOTO 190
       ELSE
          GOTO 500
       ENDIF
      ENDIF
      opsfac = poselt + int(npiv,8) * int(lda,8) + int(npiv,8)
      IF ( mumps_procnode(procnode_steps(step(fpere)),
     &     keep(199)) .NE. myid ) THEN
        msgtag =noeud
        msgdest=mumps_procnode( procnode_steps(step(fpere)), keep(199) )
        ierr = -1 
        nbrows_already_sent = 0
        DO WHILE (ierr.EQ.-1)
          IF ( (type.EQ.1) .AND. (typef.EQ.1) ) THEN
             CALL dmumps_buf_send_cb( nbrows_already_sent,
     &         inode, fpere, nfront, 
     &         lcont, nass, npiv, iw( ioldps +  h_inode + npiv ),
     &         iw( ioldps +  h_inode + npiv + nfront ),
     &         a( opsfac ), packed_cb,
     &         msgdest, msgtag, comm, keep, ierr )
          ELSE
             IF ( type.EQ.2 ) THEN
              iniv2 = istep_to_iniv2( step(inode) )
             ELSE
              iniv2 = -9999
             ENDIF
             CALL dmumps_buf_send_maitre2( nbrows_already_sent,
     &             fpere, inode, 
     &             nbrow_send, iw(ioldps +  h_inode + npiv ), 
     &             nbcol, iw(ioldps +  h_inode + npiv + nfront ),
     &             a(opsfac), lda, nelim, TYPE,
     &             nslaves, iw(ioldps+6+keep(ixsz)), msgdest, 
     &             comm, ierr, 
     & 
     &             slavef, keep,keep8, iniv2, tab_pos_in_pere )
          END IF
          IF ( ierr .EQ. -1 ) THEN
            blocking  = .false.
            set_irecv = .true.
            message_received = .false.
            CALL dmumps_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,
     &       lptrar, nelt, frtptr, frtelt,
     &       istep_to_iniv2, tab_pos_in_pere, .true.  
     &               , lrgroups )
             IF ( iflag .LT. 0 ) GOTO 500
          ENDIF
          ioldps = ptlust_s(step( inode ))
          opsfac = poselt + int(npiv,8) * int(lda,8) + int(npiv,8)
        END DO
        IF ( ierr .EQ. -2 .OR. ierr .EQ. -3 ) THEN 
          IF ( (type.EQ.1) .AND. (typef.EQ.1) ) THEN
            ierror = ( 2*lcont + 9 ) * keep( 34 ) + 
     &          lcont*lcont * keep( 35 )
          ELSE IF (keep(50).ne.0 .AND. TYPE .eq. 2 ) then
            ierror = ( nbrow_send + nbcol+ 5 + nslaves) 
     &                 * keep( 34 ) + 
     &          nbrow_send*nbrow_send*keep( 35 )
          ELSE
            ierror = ( nbrow_send + nbcol+ 5 + nslaves) * keep( 34 ) + 
     &          nbrow_send*nbcol*keep( 35 )
          ENDIF
          IF (ierr .EQ. -2) THEN
            iflag = -17
            IF ( lp  >  0 ) THEN
              WRITE(lp, *) myid,
     & ": FAILURE, SEND BUFFER TOO SMALL DURING
     & DMUMPS_FAC_STACK", TYPE, typef
            ENDIF
          ENDIF
          IF (ierr .EQ. -3) THEN
            iflag = -20
            IF ( lp  >  0 ) THEN
              WRITE(lp, *) myid,
     & ": FAILURE, RECV BUFFER TOO SMALL DURING
     & DMUMPS_FAC_STACK", TYPE, TYPEF
            ENDIF
          ENDIF
          GOTO 600
        ENDIF
      ENDIF
      IF ( mumps_procnode(procnode_steps(step(fpere)),
     &     keep(199)) .EQ. myid ) THEN
        nbrow_send = 0
        lreqi = 2 + keep(ixsz)
        nbrow_stack   = nbrow
        nbrow_indices = nbrow
        IF ((keep(50).NE.0).AND.(type.EQ.2)) THEN
          nbcol_stack = nelim
        ELSE
          nbcol_stack = nbcol
        ENDIF
        IF (compress_cb) THEN
          nbrow_stack=nelim
          IF (keep(50).NE.0) nbcol_stack = nelim
        ENDIF
      ELSE
        nbrow_stack   = nbrow-nbrow_send
        nbrow_indices = nbrow-nbrow_send
        nbcol_stack = nbcol
        IF (compress_cb) THEN
          nbrow_stack = 0
          nbcol_stack = 0 
        ENDIF
        lreqi       = 6 + nbrow_indices + nbcol + keep(ixsz)
        IF (.NOT. (type.EQ.1 .AND. typef.EQ.2 ) ) GOTO 190
        IF (fpere.EQ.0) GOTO 190
      ENDIF
      IF (packed_cb) THEN
       IF (nbrow_stack.EQ.0.OR.nbcol_stack.EQ.0) THEN
        lreqcb = 0
       ELSE
        lreqcb = ( int(nbcol_stack,8) * int( nbcol_stack + 1, 8) ) / 2_8
     &         - ( int(nbrow_send ,8) * int( nbrow_send  + 1, 8) ) / 2_8
       ENDIF
      ELSE
        lreqcb = int(nbrow_stack,8) * int(nbcol_stack,8)
      ENDIF
      inplace = ( keep(234).NE.0 )
      IF (keep(50).NE.0 .AND. TYPE .EQ. 2) inplace = .false.
      inplace = inplace .OR. .NOT. must_compact_factors
      inplace = inplace .AND.
     &            ( ptlust_s(step(inode)) + intsiz .EQ. iwpos )
      min_space_in_place = 0_8
      IF ( inplace .AND. keep(50).eq. 0 .AND.
     &     must_compact_factors) THEN
        min_space_in_place = int(nbcol_stack,8)
      ENDIF
      IF ( min_space_in_place .GT. lreqcb ) THEN
        inplace = .false.
      ENDIF
      CALL dmumps_alloc_cb( inplace, min_space_in_place,
     &   ssarbr, .false.,
     &   myid,n,keep,keep8,dkeep,iw, liw, a, la,
     &   lrlu, iptrlu,iwpos,iwposcb, slavef, procnode_steps, dad,
     &   ptrist,ptrast,step, pimaster,pamaster,
     &   lreqi, lreqcb, inode, s_notfree, .true.,
     &   comp, lrlus, lrlusm, iflag, ierror )
      IF (iflag.LT.0) GOTO 600
      iw(iwposcb+1+xxf)  = iw(ioldps+xxf)
      iw(iwposcb+1+xxlr) = iw(ioldps+xxlr)
      ptrist(step(inode)) = iwposcb+1
      IF ( mumps_procnode(procnode_steps(step(fpere)),
     &     keep(199)) .EQ. myid ) THEN
        pimaster(step(inode)) = ptlust_s(step(inode))
        pamaster(step(inode)) = iptrlu + 1_8
        ptrast(step(inode)) = -99999999_8
          iw(iwposcb+1+keep(ixsz)) = min(-nbcol_stack,-1)
          iw(iwposcb+2+keep(ixsz)) = nbrow_stack
          IF (packed_cb) iw(iwposcb+1+xxs) = s_cb1comp
      ELSE
        ptrast(step(inode)) = iptrlu+1_8
        IF (packed_cb) iw(iwposcb+1+xxs)=s_cb1comp
        iw(iwposcb+1+keep(ixsz)) = nbcol
        iw(iwposcb+2+keep(ixsz)) = 0
        iw(iwposcb+3+keep(ixsz)) = nbrow_stack
        iw(iwposcb+4+keep(ixsz)) = 0
        iw(iwposcb+5+keep(ixsz)) = 1
        iw(iwposcb+6+keep(ixsz)) = 0
        ioldp1   = ptlust_s(step(inode))+h_inode
        ptrowend = iwposcb+6+nbrow_stack+keep(ixsz)
        DO i = 1, nbrow_stack
          iw(iwposcb+7+keep(ixsz)+i-1) =
     &    iw(ioldp1+nfront-nbrow_stack+i-1)
        ENDDO
        DO i = 1, nbcol
          iw(ptrowend+i)=iw(ioldp1+nfront+npiv+i-1)
        ENDDO
      END IF 
      IF ( keep(50).NE.0 .AND. TYPE .EQ. 1 
     &     .AND. must_compact_factors ) THEN
        poselt = ptrfac(step(inode))
        CALL dmumps_compact_factors( a(poselt), lda, 
     &             npiv, nbrow, keep,
     &             int(lda,8)*int(nbrow+npiv,8),
     &             iw( ptlust_s(step(inode)) + h_inode + nfront ) )
        must_compact_factors = .false.
      ENDIF
      IF (compress_cb.AND.(lreqcb.EQ.0)) GOTO 190
      IF (  keep(50).EQ.0 .AND. must_compact_factors )
     &     THEN
        last_allowed_pos = poselt + int(lda,8)*int(npiv+nbrow-1,8)
     &                     + int(npiv,8)
      ELSE
        last_allowed_pos = -1_8
      ENDIF
      ncbrow_already_moved = 0
      count_extra_ip_copies = 0_8 
 10   CONTINUE
      ncbrow_previously_moved = ncbrow_already_moved
      IF (iptrlu .LT. posfac ) THEN
        CALL dmumps_copy_cb_right_to_left( a, la, lda,
     &  poselt, iptrlu, npiv, nbcol_stack, nbrow_stack,
     &  nbrow_send, lreqcb, keep, packed_cb,
     &  last_allowed_pos, ncbrow_already_moved )
      ELSE
        CALL dmumps_copy_cb_left_to_right( a, la, lda,
     &  poselt, iptrlu, npiv, nbcol_stack, nbrow_stack,
     &  nbrow_send, lreqcb, keep, packed_cb )
        ncbrow_already_moved = nbrow_stack
      ENDIF
      IF (last_allowed_pos .NE. -1_8) THEN
        must_compact_factors =.false.
        IF ( ncbrow_already_moved .EQ. nbrow_stack ) THEN
         IF (compress_cb) THEN
          ncbrow_already_moved = nbrow
         ELSE
          ncbrow_already_moved = ncbrow_already_moved + nbrow_send
         ENDIF
        ENDIF
        ncbrow_newly_moved = ncbrow_already_moved
     &                    - ncbrow_previously_moved
        factor_pos = poselt +
     &         int(lda,8)*int(npiv+nbrow-ncbrow_already_moved,8)
        CALL dmumps_compact_factors_unsym( a(factor_pos), lda, npiv,
     &       ncbrow_newly_moved,
     &       int(ncbrow_newly_moved,8) * int(lda,8) )
        inew = factor_pos + int(npiv,8) * int(ncbrow_newly_moved,8)
        iold = inew + int(ncbrow_newly_moved,8) * int(nbcol_stack,8)
        DO i = 1, ncbrow_previously_moved*npiv
            a(inew) = a(iold)
            iold = iold + 1_8
            inew = inew + 1_8
        ENDDO
        count_extra_ip_copies = count_extra_ip_copies +
     &                      int(ncbrow_previously_moved,8)
     &                    * int(npiv,8)
        last_allowed_pos = inew
        IF (ncbrow_already_moved.LT.nbrow_stack) THEN
          GOTO 10
        ENDIF
      ENDIF
      IF ( count_extra_ip_copies .GT. 0_8 ) THEN
!$OMP ATOMIC UPDATE
        keep8(8) = keep8(8) + count_extra_ip_copies
!$OMP END ATOMIC
        count_extra_ip_copies = 0_8
      ENDIF
 190  CONTINUE
      IF (must_compact_factors) THEN
       poselt = ptrfac(step(inode))
       CALL dmumps_compact_factors( a(poselt), lda,
     &             npiv, nbrow, keep,
     &             int(lda,8)*int(nbrow+npiv,8),
     &             iw( ptlust_s(step(inode)) + h_inode + nfront ) )
       must_compact_factors = .false.
      ENDIF
      ioldps = ptlust_s(step(inode))
      iw(ioldps+keep(ixsz))     = nbcol       
      iw(ioldps + 1+keep(ixsz)) = nass - npiv 
      IF (type.EQ.2) THEN
        iw(ioldps + 2+keep(ixsz)) = nass      
      ELSE
        iw(ioldps + 2+keep(ixsz)) = nfront
      ENDIF
      iw(ioldps + 3+keep(ixsz)) = npiv
      IF (inplace) THEN
        size_inplace = lreqcb - min_space_in_place
      ELSE
        size_inplace = 0_8
      ENDIF
      CALL dmumps_compress_lu(size_inplace,myid,n,ioldps,TYPE, iw, liw, 
     &    a, la, posfac, lrlu, lrlus, 
     &    iwpos, ptrast, ptrfac, step, keep,keep8, ssarbr,inode,ierr
     &    , lrgroups, nass
     &    )
      IF(ierr.LT.0)THEN
         iflag=ierr
         ierror=0
         GOTO 600
      ENDIF
 500  CONTINUE
      RETURN
  600 CONTINUE
      IF (iflag .NE. -1 .AND. keep(405) .EQ. 0) THEN
        CALL dmumps_bdc_error( myid, slavef, comm, keep )
      ENDIF
      RETURN
      END SUBROUTINE dmumps_fac_stack