dfac_process_blfac_slave.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 dmumps_process_blfac_slave(
     &   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 dmumps_buf
      USE dmumps_load
      USE dmumps_lr_core
      USE dmumps_lr_type
      USE dmumps_fac_lr
      USE dmumps_lr_data_m
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      USE dmumps_dynamic_memory_m, ONLY : dmumps_dm_set_dynptr
      USE dmumps_fac_front_aux_m, ONLY : dmumps_get_size_schur_in_front
#if defined(BLR_MT)
!$    USE OMP_LIB
#endif
      IMPLICIT NONE
      TYPE (dmumps_root_struc) :: root
      INTEGER icntl( 60 ), keep( 500 )
      INTEGER(8) keep8(150)
      DOUBLE PRECISION       dkeep(230)
      INTEGER lbufr, lbufr_bytes
      INTEGER comm_load, ass_irecv
      INTEGER bufr( lbufr )
      INTEGER n, slavef, iwpos, iwposcb, liw
      INTEGER(8) :: posfac, iptrlu, lrlu, lrlus, la
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER comp
      INTEGER iflag, ierror, nbfin, msgsou
      INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
     &        nstk_s(keep(28))
      INTEGER perm(n), step(n), pimaster(keep(28))
      INTEGER iw( liw )
      DOUBLE PRECISION a( la )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER nelt, lptrar
      INTEGER frtptr( n + 1 ), frtelt( NELT )
      INTEGER(8), INTENT(IN) :: ptraiw( lptrar ), ptrarw( lptrar )
      INTEGER istep_to_iniv2(keep(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER comm, myid
      INTEGER ptlust_s(keep(28))
      INTEGER itloc( n + keep(253)), fils( n ), dad( keep(28) )
      DOUBLE PRECISION :: rhs_mumps(keep(255))
      INTEGER nd( keep(28) ), frere_steps( keep(28) )
      DOUBLE PRECISION opassw, opeliw
      DOUBLE PRECISION flop1
      DOUBLE PRECISION dblarr( keep8(26) )
      INTEGER intarr( keep8(27) )
      INTEGER leaf, lpool 
      INTEGER ipool( lpool )
      include 'mumps_headers.h'
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER :: status(mpi_status_size)
      INTEGER mumps_procnode
      EXTERNAL mumps_procnode
      INTEGER inode, iposk, jposk, ncolu, npiv, position, ierr
      INTEGER(8) poselt, posblocfacto
      INTEGER(8) laell
      INTEGER(8) :: la_ptr 
      DOUBLE PRECISION, DIMENSION(:), POINTER :: a_ptr
      INTEGER ioldps, lcont1, nrow1, ncol1, npiv1
      INTEGER nslaves_tot, hs, dest, nslaves_follow
      INTEGER fpere
      INTEGER(8) cpos, lpos
      LOGICAL dynamic_alloc
      LOGICAL blocking, set_irecv, message_received
      INTEGER allocok
      INTEGER lr_activated_int
      LOGICAL lr_activated, compress_cb
      INTEGER nb_blr_u, current_blr_u
      TYPE (lrb_type), DIMENSION(:), ALLOCATABLE :: blr_u
      INTEGER, POINTER, DIMENSION(:) :: begs_blr_u
      TYPE (lrb_type), DIMENSION(:), POINTER :: blr_ls
      TYPE (lrb_type), POINTER, DIMENSION(:,:) :: cb_lrb
      INTEGER, POINTER, DIMENSION(:) :: begs_blr_ls, begs_blr_col
      INTEGER    :: nb_blr_ls, ipanel,
     &           maxi_cluster_ls, maxi_cluster, 
     &           nb_blr_col, maxi_cluster_col, npartsass_master
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: work, tau
      INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: blocklr
      DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: rwork
      INTEGER :: omp_num, lwork
      INTEGER :: ii,jj
      INTEGER :: nfs4father, nass1, nelim, info_tmp(2)
      INTEGER :: nvschur_k253, nslaves_l, irow_l
      INTEGER :: nbrowsinf
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: m_array
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: udynamic
      DOUBLE PRECISION one,alpha
      PARAMETER (one = 1.0d0, alpha=-1.0d0)
      dynamic_alloc = .false.
      position  = 0
      CALL mpi_unpack( bufr, lbufr_bytes, position, inode, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, iposk, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, jposk, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, npiv, 1,
     &                 mpi_integer, comm, ierr )
      IF ( npiv .LE. 0 ) THEN
        npiv = - npiv
        WRITE(*,*) myid,':error, received negative NPIV in BLFAC'
        CALL mumps_abort()
      END IF
      CALL mpi_unpack( bufr, lbufr_bytes, position, fpere, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, ncolu, 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, 
     &                 ipanel, 1,
     &                 mpi_integer, comm, ierr )
      IF (lr_activated) THEN
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 nb_blr_u, 1, mpi_integer,
     &                 comm, ierr )
          current_blr_u = 1 
          ALLOCATE(blr_u(max(nb_blr_u,1)),
     &             begs_blr_u(nb_blr_u+2), stat=allocok)
          if (allocok .GT. 0) THEN
             iflag = -13 
             ierror = max(nb_blr_u,1) + nb_blr_u+2
             GOTO 700
          endif
          CALL dmumps_mpi_unpack_lr(bufr, lbufr, lbufr_bytes,
     &                        position, jposk-1, 0, 'V',
     &                        blr_u, nb_blr_u, 
     &                        begs_blr_u(1),
     &                        keep8, comm, ierr, iflag, ierror)
          IF (iflag.LT.0) GOTO 700
      ELSE
      laell = int(npiv,8) * int(ncolu,8)
      CALL dmumps_get_size_needed(
     &        0, laell, .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 - laell
      lrlus = lrlus - laell
      keep8(67) = min(lrlus, keep8(67))
      keep8(69) = keep8(69) + laell
      keep8(68) = max(keep8(69), keep8(68))
      posblocfacto = posfac
      posfac = posfac + laell
      CALL dmumps_load_mem_update(.false.,.false.,
     &                           la-lrlus,0_8, laell,keep,keep8,lrlus)
      CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 a(posblocfacto), npiv*ncolu,
     &                 mpi_double_precision,
     &                 comm, ierr )
      ENDIF
      IF (ptrist(step( inode )) .EQ. 0) dynamic_alloc = .true.
      IF ( (ptrist(step( inode )).NE.0) .AND.
     &  (iposk + npiv -1 .GT.
     &   iw(ptrist(step(inode))+3+keep(ixsz))) )THEN
        dynamic_alloc = .true.
      ENDIF
      IF (lr_activated) THEN
       dynamic_alloc = .false.
      ENDIF
      IF (dynamic_alloc)  THEN
        ALLOCATE(udynamic(laell), stat=allocok)
        if (allocok .GT. 0) THEN
          iflag = -13 
          CALL mumps_set_ierror(laell,ierror)
          GOTO 700
        endif
        udynamic(1_8:laell) = a(posblocfacto:posblocfacto+laell-1_8)
        lrlu  = lrlu + laell
        lrlus = lrlus + laell
        keep8(69) = keep8(69) - laell
        posfac = posfac - laell
      CALL dmumps_load_mem_update(.false.,.false.,
     &          la-lrlus,0_8,-laell,keep,keep8,lrlus)
      ENDIF
      IF (ptrist(step( inode )) .EQ. 0) THEN
          CALL dmumps_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
      DO WHILE ( iposk + npiv -1 .GT.
     &            iw( ptrist(step( inode )) + 3 +keep(ixsz)) )
        msgsou = mumps_procnode( procnode_steps(step(inode)),
     &                           keep(199) )
        blocking  = .true.
        set_irecv = .false.
        message_received = .false.
        CALL dmumps_try_recvtreat( comm_load,
     &    ass_irecv, blocking, set_irecv, message_received,
     &    msgsou, bloc_facto_sym, 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
        set_irecv = .true.
        blocking  = .false.
        message_received = .true.
        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_steps,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere, .true. 
     &               , lrgroups
     &     )
      ioldps  = ptrist(step( inode ))
      CALL dmumps_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) )
      nrow1   = iw( ioldps + 2  + keep(ixsz))
      npiv1   = iw( ioldps + 3  + keep(ixsz))
      nslaves_tot = iw( ioldps + 5  + keep(ixsz))
      hs      = 6 + nslaves_tot + keep(ixsz)
      ncol1   = lcont1 + npiv1
      IF (lr_activated) THEN
         CALL dmumps_blr_dec_and_retrieve_l (iw(ioldps+xxf), ipanel, 
     &        begs_blr_ls, blr_ls)
         nb_blr_ls = size(begs_blr_ls)-2   
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
         CALL dmumps_blr_update_trailing_i (
     &        a_ptr(poselt), la_ptr, 1_8,
     &        iflag, ierror, ncol1,
     &        begs_blr_ls(1), size(begs_blr_ls),
     &        begs_blr_u(1), size(begs_blr_u),
     &        current_blr_u, 
     &        blr_ls(1),  nb_blr_ls+1,
     &        blr_u(1), nb_blr_u+1,
     &        0,       
     &        .true.,  
     &        0,       
     &        2,       
     &        1,
     &        keep(481), dkeep(11), keep(466), keep(477) 
     &         )
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
          CALL dealloc_blr_panel(blr_u, nb_blr_u, keep8, keep(34))
          IF (allocated(blr_u)) DEALLOCATE(blr_u)
          IF (associated(begs_blr_u)) DEALLOCATE(begs_blr_u)
          IF (iflag.LT.0) GOTO 700
         IF (keep(486).EQ.3) THEN
         CALL dmumps_blr_try_free_panel(iw(ioldps+xxf), ipanel, 
     &                            keep8, keep(34)) 
         ENDIF
      ELSE
      cpos = poselt + int(jposk - 1,8)
      lpos = poselt + int(iposk - 1,8)
      IF ( npiv .GT. 0 ) THEN
          IF (dynamic_alloc) THEN
            CALL dgemm( 'T', 'N', ncolu, nrow1, npiv, alpha,
     &            udynamic(1), npiv,
     &            a_ptr( lpos ), ncol1, one,
     &            a_ptr( cpos ), ncol1 )
          ELSE
            CALL dgemm( 'T', 'N', ncolu, nrow1, npiv, alpha,
     &            a( posblocfacto ), npiv,
     &            a_ptr( lpos ), ncol1, one,
     &            a_ptr( cpos ), ncol1 )
          ENDIF
      ENDIF 
      ENDIF
      IF (npiv .GT. 0) THEN
        flop1 = dble(ncolu*npiv)*dble(2*nrow1)
        flop1 = -flop1
        CALL dmumps_load_update(1, .false., flop1, keep,keep8 )
      ENDIF
      IF ( iw(ioldps+6+keep(ixsz)).EQ.
     &    huge(iw(ioldps+6+keep(ixsz))) ) THEN
          iw(ioldps+6+keep(ixsz)) = 1
      ENDIF
      iw(ioldps+6+keep(ixsz)) =
     &         iw(ioldps+6+keep(ixsz)) + 1
      IF (.NOT.lr_activated) THEN
      IF (dynamic_alloc) THEN
       DEALLOCATE(udynamic)
      ELSE
        lrlu  = lrlu + laell
        lrlus = lrlus + laell
        keep8(69) = keep8(69) - laell
        posfac = posfac - laell
      CALL dmumps_load_mem_update(.false.,.false.,
     &                      la-lrlus,0_8,-laell,keep,keep8,lrlus)
      ENDIF
      ENDIF
      nslaves_follow = iw( ioldps + 5 +keep(ixsz) ) - xtra_slaves_sym
      IF ( iw( ioldps + 6  +keep(ixsz)) .eq. 0 .and.
     &     keep(50) .ne. 0 .and. nslaves_follow .eq. 0 )
     &     THEN
         dest = mumps_procnode( procnode_steps(step(inode)), keep(199) )
         CALL dmumps_buf_send_1int( inode, dest, end_niv2_ldlt,
     &                             comm, keep, ierr )
         IF ( ierr .LT. 0 ) THEN
           write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.'
           iflag = -99
           GOTO 700
         END IF
      END IF
      IF (iw(ptrist(step(inode)) + 6+keep(ixsz) ) .eq. 0) THEN
           npiv1 = iw( ioldps + 3  + keep(ixsz))
           nass1 = iw( ioldps + 4 + keep(ixsz))  
           nelim = nass1 - npiv1
          compress_cb= .false.
          IF (lr_activated) THEN
            compress_cb = ((iw(ptrist(step(inode))+xxlr).EQ.1).OR.
     &                     (iw(ptrist(step(inode))+xxlr).EQ.3))
             IF (compress_cb.AND.npiv.EQ.0) THEN
              compress_cb = .false.
              iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
             ENDIF
            IF (compress_cb) THEN
              CALL dmumps_blr_retrieve_begs_blr_c (iw(ioldps+xxf), 
     &                  begs_blr_col,  npartsass_master)
              nb_blr_col   = size(begs_blr_col) - 1
              allocate(cb_lrb(nb_blr_ls,nb_blr_col-npartsass_master),
     &                 stat=allocok)
              IF (allocok > 0) THEN
                iflag  = -13
                ierror = nb_blr_ls*(nb_blr_col-npartsass_master)
                GOTO 700
              ENDIF
              DO ii=1,nb_blr_ls
              DO jj=1,nb_blr_col-npartsass_master
                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 dmumps_blr_save_cb_lrb(iw(ioldps+xxf),cb_lrb)
              call max_cluster(begs_blr_ls,nb_blr_ls+1,maxi_cluster_ls)
              CALL max_cluster(begs_blr_col,nb_blr_col,maxi_cluster_col)
              maxi_cluster = max(maxi_cluster_ls,
     &         maxi_cluster_col+nelim,npiv)
              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
              nfs4father = -9999
              IF ( (keep(219).NE.0).AND.(keep(50).EQ.2) ) THEN
               CALL dmumps_blr_retrieve_nfs4father ( iw(ioldps+xxf),
     &             nfs4father )
               nfs4father = max(nfs4father,0) + nelim
              ENDIF
              ALLOCATE(m_array(max(nfs4father,1)), stat=allocok)
              IF (allocok.gt.0) THEN
                iflag = -13
                ierror = max(nfs4father,1)
                GOTO 700
              ENDIF
              begs_blr_col(1+npartsass_master) = 
     &               begs_blr_col(1+npartsass_master) - nelim
              nbrowsinf = 0
              IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
     &             nfs4father.GT.0  ) THEN
                CALL dmumps_compute_nbrowsinf (
     &                n, inode, fpere, keep, 
     &                ioldps, hs, 
     &                iw, liw, 
     &                nrow1, ncol1, npiv1,
     &                nelim, nfs4father,
     &                nbrowsinf
     &                )
              ENDIF
              IF ((keep(114).EQ.1) .AND. (keep(116).GT.0)
     &            .AND. (keep(50).EQ.2)
     &           ) THEN
                 nslaves_l = iw(ptrist(step(inode)) + 5 + keep(ixsz))
                 irow_l    = ptrist(step(inode)) + 6 + nslaves_l + 
     &                       keep(ixsz)
                 CALL dmumps_get_size_schur_in_front ( 
     &                n, 
     &                nrow1,
     &                keep(116), 
     &                iw(irow_l),
     &                perm, nvschur_k253 )
              ELSE
                 nvschur_k253 = 0
              ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
              CALL dmumps_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_master,
     &          npartsass_master, 
     &          nrow1, ncol1-npiv1, 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, nvschur_k253, keep(1), 
     &          m_array,
     &          nelim, nbrowsinf )
#if defined(BLR_MT)
!$OMP END PARALLEL
#endif
              IF (iflag.LT.0) GOTO 650
              IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
     &             nfs4father.GT.0  ) THEN
                 info_tmp(1) = iflag
                 info_tmp(2) = ierror
                 CALL dmumps_blr_save_m_array( iw(ioldps+xxf),
     &            m_array, info_tmp)
                 iflag  = info_tmp(1) 
                 ierror = info_tmp(2) 
              ENDIF
 650          CONTINUE         
              IF (allocated(m_array)) DEALLOCATE(m_array)
              IF (allocated(blocklr)) DEALLOCATE(blocklr)
              IF (allocated(rwork)) DEALLOCATE(rwork)
              IF (allocated(tau)) DEALLOCATE(tau)
              IF (allocated(jpvt)) DEALLOCATE(jpvt)
              IF (allocated(work)) DEALLOCATE(work)           
              IF (iflag.LT.0) GOTO 700
            ENDIF 
          ENDIF
         CALL dmumps_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 
      RETURN
 700  CONTINUE
      CALL dmumps_bdc_error( myid, slavef, comm, keep )
 600  CONTINUE
      IF (allocated(blr_u)) DEALLOCATE(blr_u)
      IF (compress_cb) THEN
        IF (allocated(blocklr)) DEALLOCATE(blocklr)
        IF (allocated(rwork)) DEALLOCATE(rwork)
        IF (allocated(tau)) DEALLOCATE(tau)
        IF (allocated(jpvt)) DEALLOCATE(jpvt)
        IF (allocated(work)) DEALLOCATE(work)
      ENDIF
      IF (allocated(m_array)) DEALLOCATE(m_array)
      IF (dynamic_alloc) THEN
       IF (allocated(udynamic)) DEALLOCATE(udynamic)
      ENDIF
      RETURN
      END SUBROUTINE dmumps_process_blfac_slave