dfac_mem_stack.F File Reference

Go to the source code of this file.

Functions/Subroutines

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)

Function/Subroutine Documentation

dmumps_fac_stack()

subroutine dmumps_fac_stack	(	integer	comm_load,
		integer	ass_irecv,
		integer	n,
		integer	inode,
		integer	type,
		integer	typef,
		integer(8)	la,
		integer, dimension(liw)	iw,
		integer	liw,
		double precision, dimension(la)	a,
		integer	iflag,
		integer	ierror,
		double precision	opeliw,
		integer	nelvaw,
		integer	nmaxnpiv,
		integer, dimension(keep(28))	ptrist,
		integer, dimension(keep(28))	ptlust_s,
		integer(8), dimension (keep(28))	ptrfac,
		integer(8), dimension (keep(28))	ptrast,
		integer, dimension(n)	step,
		integer, dimension(keep(28))	pimaster,
		integer(8), dimension(keep(28))	pamaster,
		integer, dimension(keep(28))	ne,
		integer(8)	posfac,
		integer(8)	lrlu,
		integer(8)	lrlus,
		integer(8)	lrlusm,
		integer(8)	iptrlu,
		integer, dimension(60)	icntl,
		integer, dimension(500)	keep,
		integer(8), dimension(150)	keep8,
		double precision, dimension(230)	dkeep,
		integer	comp,
		integer	iwpos,
		integer	iwposcb,
		integer, dimension(keep(28))	procnode_steps,
		integer	slavef,
		integer	fpere,
		integer	comm,
		integer	myid,
		integer, dimension( lpool )	ipool,
		integer	lpool,
		integer	leaf,
		integer, dimension( keep(28) )	nstk_s,
		integer, dimension(n)	perm,
		integer, dimension( lbufr )	bufr,
		integer	lbufr,
		integer	lbufr_bytes,
		integer	nbfin,
		type (dmumps_root_struc)	root,
		double precision	opassw,
		integer, dimension( n + keep(253) )	itloc,
		double precision, dimension(keep(255))	rhs_mumps,
		integer, dimension( n )	fils,
		integer, dimension( keep(28) )	dad,
		integer(8), dimension( lptrar ), intent(in)	ptrarw,
		integer(8), dimension( lptrar ), intent(in)	ptraiw,
		integer, dimension(keep8(27))	intarr,
		double precision, dimension(keep8(26))	dblarr,
		integer, dimension( keep(28) )	nd,
		integer, dimension( keep(28) )	frere,
		integer	lptrar,
		integer	nelt,
		integer, dimension( n+1 )	frtptr,
		integer, dimension( nelt )	frtelt,
		integer, dimension(keep(71))	istep_to_iniv2,
		integer, dimension(slavef+2,max(1,keep(56)))	tab_pos_in_pere,
		integer, dimension(n), intent(in)	lrgroups,
		double precision	flop_estim_acc )

Definition at line 14 of file dfac_mem_stack.F.

      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