ana_blk.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 mumps_ab_free_lmat ( LMAT )
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      TYPE(lmatrix_t) :: LMAT
      INTEGER :: J
      IF (associated(lmat%COL)) THEN
        DO j = 1,lmat%NBCOL
         IF (associated(lmat%COL(j)%IRN)) THEN
           DEALLOCATE(lmat%COL(j)%IRN)
           NULLIFY(lmat%COL(j)%IRN)
         ENDIF
        ENDDO
        DEALLOCATE(lmat%COL)
        NULLIFY(lmat%COL)
      ENDIF
      RETURN
      END SUBROUTINE mumps_ab_free_lmat
      SUBROUTINE mumps_ab_free_gcomp ( GCOMP )
      USE mumps_ana_blk_m, ONLY : compact_graph_t
      IMPLICIT NONE
      TYPE(compact_graph_t) :: GCOMP
      IF (associated(gcomp%IPE)) THEN
          DEALLOCATE(gcomp%IPE)
          NULLIFY(gcomp%IPE)
      ENDIF
      IF (associated(gcomp%ADJ)) THEN
          DEALLOCATE(gcomp%ADJ)
          NULLIFY(gcomp%ADJ)
      ENDIF
      RETURN
      END SUBROUTINE mumps_ab_free_gcomp
      SUBROUTINE mumps_ab_compute_sizeofblock (
     &          NBLK, NDOF, BLKPTR, BLKVAR,
     &          SIZEOFBLOCKS, DOF2BLOCK )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NBLK, NDOF
      INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(NDOF)
      INTEGER, INTENT(OUT):: SIZEOFBLOCKS(NBLK), DOF2BLOCK(NDOF)
      INTEGER :: IB, I, IDOF
      DO ib=1, nblk
        sizeofblocks(ib)= blkptr(ib+1)-blkptr(ib)
        DO i=blkptr(ib), blkptr(ib+1)-1
          idof = blkvar(i)
          dof2block(idof) = ib
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE mumps_ab_compute_sizeofblock 
      SUBROUTINE mumps_ab_coord_to_lmat (  MYID, 
     &     NBLK, NDOF, NNZ, IRN, JCN,
     &     DOF2BLOCK, 
     &     IFLAG, IERROR, LP, LPOK,
     &     LMAT)
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      INTEGER, INTENT(IN)    :: MYID, NBLK, NDOF
      INTEGER(8), INTENT(IN) :: NNZ
      INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ))
      INTEGER, INTENT(IN) :: DOF2BLOCK(NDOF)
      INTEGER             :: LP, IFLAG, IERROR
      LOGICAL, INTENT(IN) :: LPOK
      TYPE(lmatrix_t)     :: LMAT
      INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAG
      INTEGER :: allocok
      INTEGER :: I, J, JJB, IIB, IB, JB, NB, PT
      INTEGER(8) :: I8
      lmat%NBCOL = nblk
      lmat%NZL   = 0_8
      ALLOCATE(lmat%COL(nblk),flag(nblk), stat=allocok)
      IF (allocok.NE.0) THEN
           iflag = -7
           ierror = 2*nblk
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LMAT%COL"
           END IF
           RETURN
      ENDIF
      DO ib=1,nblk
       lmat%COL(ib)%NBINCOL = 0
       flag(ib)             = 0
      ENDDO
      ierror = 0 
      DO i8=1, nnz
         i = irn(i8)
         j = jcn(i8)
         IF ( (i.GT.ndof).OR.(j.GT.ndof).OR.(i.LT.1)
     &                     .OR.(j.LT.1)) THEN
           ierror = ierror + 1
         ELSE
          ib  = dof2block(i)
          jb  = dof2block(j)
          jjb = min(ib,jb)
          IF (ib.NE.jb) THEN
           lmat%NZL = lmat%NZL+1_8
           lmat%COL(jjb)%NBINCOL =  lmat%COL(jjb)%NBINCOL + 1
          ENDIF
         ENDIF
      ENDDO
      IF (ierror.GE.1) THEN
         IF (mod(iflag,2) .EQ. 0) iflag = iflag+1
      ENDIF
      DO jb=1,nblk
       nb =  lmat%COL(jb)%NBINCOL
       IF (nb.GT.0) THEN
        ALLOCATE(lmat%COL(jb)%IRN(nb), stat=allocok)
        IF (allocok.NE.0) THEN
           iflag  = -7
           ierror = nblk
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LMAT%COL"
           END IF
           RETURN
        ENDIF
       ENDIF
      ENDDO
      DO i8=1, nnz
         i = irn(i8)
         j = jcn(i8)
         IF ( (i.LE.ndof).AND.(j.LE.ndof).AND.(i.GE.1)
     &                     .AND.(j.GE.1)) THEN
          ib  = dof2block(i)
          jb  = dof2block(j)
          jjb = min(ib,jb)
          iib = max(ib,jb)
          IF (iib.NE.jjb) THEN
             pt        = flag(jjb)+1
             flag(jjb) = pt
             lmat%COL(jjb)%IRN(pt) = iib
          ENDIF
         ENDIF
      ENDDO
      CALL mumps_ab_localclean_lmat ( myid,
     &     nblk, lmat, flag(1), iflag, ierror, lp, lpok
     & )
      DEALLOCATE(flag)
      RETURN
      END SUBROUTINE mumps_ab_coord_to_lmat
      SUBROUTINE mumps_ab_localclean_lmat (  MYID,
     &     NBLK, LMAT, FLAG, IFLAG, IERROR, LP, LPOK
     &     )
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: MYID, NBLK, LP
      LOGICAL, INTENT(IN) :: LPOK
      INTEGER, INTENT(OUT) :: FLAG(NBLK)
      INTEGER, INTENT(INOUT) :: IFLAG, IERROR
      TYPE(LMATRIX_T), INTENT(INOUT)  :: LMAT
      INTEGER, POINTER, DIMENSION(:)     :: PTCLEAN
      INTEGER :: allocok, IB, JB, NB
      DO jb=1, nblk
        flag(jb) = 0
      ENDDO
      lmat%NZL = 0_8
      DO jb=1, nblk
       IF ( lmat%COL(jb)%NBINCOL.EQ.0) cycle
       nb = 0
       DO ib=1,  lmat%COL(jb)%NBINCOL
        IF (flag(lmat%COL(jb)%IRN(ib)).EQ.jb) THEN
         lmat%COL(jb)%IRN(ib)=0
        ELSE
         nb = nb+1
         lmat%NZL = lmat%NZL+1_8
         flag(lmat%COL(jb)%IRN(ib)) = jb
        ENDIF
       ENDDO
       IF (nb.GT.0) THEN
         ALLOCATE(ptclean(nb), stat=allocok)
         IF (allocok.NE.0) THEN
           iflag     = -7
           ierror    = nb
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate PTCLEAN of size", 
     &                     ierror
           END IF
           RETURN
         ENDIF
         nb=0
         DO ib=1,  lmat%COL(jb)%NBINCOL
          IF (lmat%COL(jb)%IRN(ib).NE.0) THEN
           nb = nb+1
           ptclean(nb)=lmat%COL(jb)%IRN(ib)
          ENDIF
         ENDDO
         lmat%COL(jb)%NBINCOL  = nb
         deallocate(lmat%COL(jb)%IRN)
         lmat%COL(jb)%IRN => ptclean
         NULLIFY(ptclean)
       ELSE
          deallocate(lmat%COL(jb)%IRN)
          NULLIFY(lmat%COL(jb)%IRN)
       ENDIF
      ENDDO
      RETURN
      END SUBROUTINE mumps_ab_localclean_lmat
      SUBROUTINE mumps_ab_lmat_to_lumat( 
     &     LMAT, LUMAT, INFO, ICNTL )
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      TYPE(lmatrix_t)        :: LMAT, LUMAT
      INTEGER, INTENT(IN)    :: ICNTL(60)
      INTEGER, INTENT(INOUT) :: INFO(80)
      INTEGER    :: IB, IIB, JB, allocok, LP, MPG, NB, IERR
      LOGICAL LPOK, PROKG
      lp    = icntl( 1 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      mpg   = icntl( 3 )
      prokg = ( mpg .GT. 0 .and. (icntl(4).GE.2) ) 
      lumat%NBCOL  = lmat%NBCOL
      lumat%NZL    = 2_8*lmat%NZL
      ALLOCATE( lumat%COL(lmat%NBCOL),stat=allocok)
      IF (allocok.NE.0) THEN
           info( 1 ) = -7
           info( 2 ) = lmat%NBCOL
           IF ( lpok ) THEN
             WRITE(lp, *) " ERROR allocating LUMAT%COL "
           END IF
           RETURN
      ENDIF
      DO jb=1,  lmat%NBCOL
         lumat%COL(jb)%NBINCOL = lmat%COL(jb)%NBINCOL
      ENDDO
      DO jb=1,  lmat%NBCOL
        DO ib=1, lmat%COL(jb)%NBINCOL
          iib=lmat%COL(jb)%IRN(ib)
          lumat%COL(iib)%NBINCOL = lumat%COL(iib)%NBINCOL + 1
        ENDDO
      ENDDO
      DO jb=1,  lmat%NBCOL
        nb = lumat%COL(jb)%NBINCOL
        ALLOCATE(lumat%COL(jb)%IRN(nb), stat=ierr)
        IF (ierr.NE.0) THEN
           info(1)  = -7
           info(2)  = nb
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocating columns of LUMAT"
           END IF
           RETURN
        ENDIF
      ENDDO
      DO jb=1, lmat%NBCOL
        lumat%COL(jb)%NBINCOL = 0
      ENDDO
      DO jb=1, lmat%NBCOL
        DO ib=1, lmat%COL(jb)%NBINCOL
          iib=lmat%COL(jb)%IRN(ib)
          nb = lumat%COL(jb)%NBINCOL+1
          lumat%COL(jb)%NBINCOL = nb
          lumat%COL(jb)%IRN(nb)= iib
          nb = lumat%COL(iib)%NBINCOL+1
          lumat%COL(iib)%NBINCOL = nb
          lumat%COL(iib)%IRN(nb)= jb
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE mumps_ab_lmat_to_lumat
      SUBROUTINE mumps_ab_print_lmatrix (LMAT, MYID, LP)
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      TYPE(lmatrix_t), INTENT(IN) :: LMAT
      INTEGER, INTENT(IN)         :: MYID, LP
      INTEGER :: JB
      write(lp,*) myid, " ... LMATRIX  %NBCOL, %NZL= ", 
     &                  lmat%NBCOL, lmat%NZL
      IF (lmat%NBCOL.GE.0.AND.associated(lmat%COL)) THEN
       DO jb=1,  lmat%NBCOL
        IF (lmat%COL(jb)%NBINCOL.GT.0) THEN
         WRITE(lp,*) myid, " ... Column=", jb , " nb entries =", 
     &    lmat%COL(jb)%NBINCOL, " List of entries:",
     &    lmat%COL(jb)%IRN(1:lmat%COL(jb)%NBINCOL)
        ENDIF
       ENDDO
      ENDIF
      RETURN
      END SUBROUTINE mumps_ab_print_lmatrix
      SUBROUTINE mumps_ab_lmat_to_clean_g( MYID, UNFOLD, 
     &     READY_FOR_ANA_F,
     &     LMAT, GCOMP, INFO, ICNTL )
      USE mumps_ana_blk_m, ONLY : lmatrix_t, compact_graph_t
      IMPLICIT NONE
      INTEGER, INTENT(IN)    :: MYID
      LOGICAL, INTENT(IN)    :: UNFOLD, READY_FOR_ANA_F
      TYPE(lmatrix_t)        :: LMAT
      TYPE(compact_graph_t)  :: GCOMP
      INTEGER, INTENT(IN)    :: ICNTL(60)
      INTEGER, INTENT(INOUT) :: INFO(80)
      INTEGER    :: IB, IIB, JJB, allocok, LP, MPG
      INTEGER(8) :: JPOS, SIZEGCOMPALLOCATED
      INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ
#if defined(DETERMINISTIC_PARALLEL_GRAPH)
      INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK
      INTEGER(8) :: IFIRST, ILAST
      INTEGER :: L
#endif
      LOGICAL LPOK, PROKG
      lp    = icntl( 1 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      mpg   = icntl( 3 )
      prokg = ( mpg .GT. 0 .and. (icntl(4).GE.2) ) 
      gcomp%NG  = lmat%NBCOL
      IF (unfold) THEN 
       gcomp%NZG = 2_8*lmat%NZL
       sizegcompallocated = gcomp%NZG + int(gcomp%NG,8)+1_8
      ELSE IF (ready_for_ana_f) THEN
       gcomp%NZG = lmat%NZL
       sizegcompallocated = gcomp%NZG + int(gcomp%NG,8)+1_8
      ELSE
       gcomp%NZG = lmat%NZL
       sizegcompallocated = gcomp%NZG
      ENDIF
      gcomp%SIZEADJALLOCATED= sizegcompallocated
      ALLOCATE( gcomp%ADJ(sizegcompallocated), 
     &          gcomp%IPE(gcomp%NG+1), 
     &          iq(gcomp%NG),stat=allocok)
      IF (allocok.NE.0) THEN
           info( 1 ) = -7
           CALL mumps_set_ierror(
     &        gcomp%NZG + 3_8*int(gcomp%NG,8)+1_8, info(2))
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocating graph in",
     &                     " MUMPS_AB_LMAT_TO_CLEAN_G"
           END IF
           RETURN
      ENDIF
      DO jjb=1, gcomp%NG
         iq(jjb)=0_8
      ENDDO
      IF (unfold) THEN 
       DO jjb=1, gcomp%NG
        DO ib=1, lmat%COL(jjb)%NBINCOL
          iib=lmat%COL(jjb)%IRN(ib)
          iq(jjb)=iq(jjb)+1
          iq(iib)=iq(iib)+1
        ENDDO
       ENDDO
      ELSE
       DO jjb=1, gcomp%NG
         iq(jjb) = lmat%COL(jjb)%NBINCOL
       ENDDO
      ENDIF
      gcomp%IPE(1) = 1_8
      DO jjb=1, gcomp%NG
        gcomp%IPE(jjb+1) = gcomp%IPE(jjb)+iq(jjb)
      ENDDO
      IF (unfold) THEN 
       DO jjb=1, gcomp%NG
        iq(jjb)= gcomp%IPE(jjb)
       ENDDO
       DO jjb=1, gcomp%NG
        DO ib=1, lmat%COL(jjb)%NBINCOL
          iib=lmat%COL(jjb)%IRN(ib)
          gcomp%ADJ(iq(iib))= jjb
          iq(iib)           = iq(iib)+1_8
          gcomp%ADJ(iq(jjb))= iib
          iq(jjb)           = iq(jjb)+1_8
        ENDDO
       ENDDO
      ELSE
       DO jjb=1, gcomp%NG
        jpos =  gcomp%IPE(jjb)
        DO ib=1, lmat%COL(jjb)%NBINCOL
          iib=lmat%COL(jjb)%IRN(ib)
          gcomp%ADJ(jpos)= iib
          jpos           = jpos+1_8
       ENDDO
      ENDDO
      ENDIF
      DEALLOCATE(iq)
#if defined(DETERMINISTIC_PARALLEL_GRAPH)
      IF (.NOT.ready_for_ana_f) THEN
        ALLOCATE(work(0:gcomp%NG),stat=allocok)
        IF (allocok.NE.0) THEN
          info( 1 ) = -7
          info( 2 ) = gcomp%NG
          IF ( lpok ) THEN
             WRITE(lp, *) " ERROR allocating WORK in",
     &                    " MUMPS_AB_LMAT_TO_CLEAN_G"
          END IF
          RETURN
        ENDIF
        DO jjb=1, gcomp%NG
          ifirst = gcomp%IPE(jjb)
          ilast= gcomp%IPE(jjb+1)-1
          l = int(ilast-ifirst+1)
          IF ( l .GE. 2 ) THEN 
            IF (l .GE. gcomp%NG ) THEN
              WRITE(*,*) " Internal error in MUMPS_AB_LMAT_TO_CLEAN_G",
     &        l, gcomp%NG
              CALL mumps_abort()
            ENDIF
            CALL mumps_mergesort( l,
     &      gcomp%ADJ(ifirst:ilast), work(0:l+1) )
            CALL mumps_mergeswap1( l,
     &      work(0:l+1), gcomp%ADJ(ifirst:ilast) )
          ENDIF
        ENDDO
        DEALLOCATE(work)
      ENDIF
#endif
      RETURN
#if defined(DETERMINISTIC_PARALLEL_GRAPH)
      CONTAINS
      SUBROUTINE mumps_mergesort(N, K, L)
      INTEGER    :: N
      INTEGER    :: K(:), L(0:)
      INTEGER    :: P, Q, S, T
      CONTINUE
      l(0) = 1
      t = n + 1
      DO  p = 1,n - 1
         IF (k(p) <= k(p+1)) THEN
            l(p) = p + 1
         ELSE
            l(t) = - (p+1)
            t = p
       END IF
      END DO
      l(t) = 0
      l(n) = 0
      IF (l(n+1) == 0) THEN
         RETURN 
      ELSE
         l(n+1) = iabs(l(n+1))
      END IF
 200  CONTINUE
      s = 0
      t = n+1
      p = l(s)
      q = l(t)
      IF(q .EQ. 0) RETURN
 300  CONTINUE
      IF(k(p) .GT. k(q)) GOTO 600 
      CONTINUE
      l(s) = sign(p,l(s))
      s = p
      p = l(p)
      IF (p .GT. 0) GOTO 300
      CONTINUE
      l(s) = q
      s = t
      DO
         t = q
         q = l(q)
         IF (q .LE. 0) EXIT
      END DO
      GOTO 800
 600  CONTINUE
      l(s) = sign(q, l(s))
      s = q
      q = l(q)
      IF (q .GT. 0) GOTO 300
      CONTINUE
      l(s) = p
      s = t
      DO
         t = p
         p = l(p)
         IF (p .LE. 0) EXIT
      END DO
 800  CONTINUE
      p = -p
      q = -q
      IF(q.EQ.0) THEN
         l(s) = sign(p, l(s))
         l(t) = 0
         GOTO 200
      END IF
      GOTO 300
      END SUBROUTINE mumps_mergesort
      SUBROUTINE mumps_mergeswap1(N, L, A)
      INTEGER   :: I, LP, ISWAP, N
      INTEGER   :: L(0:), A(:)
      lp = l(0)
      i  = 1
      DO 
         IF ((lp==0).OR.(i>n)) EXIT
         DO 
            IF (lp >= i) EXIT
            lp = l(lp)
         END DO
         iswap    = a(lp)
         a(lp)   = a(i)
         a(i)    = iswap
         iswap    = l(lp)
         l(lp) = l(i)
         l(i)  = lp
         lp = iswap 
         i  = i + 1
      ENDDO
      END SUBROUTINE mumps_mergeswap1
#endif
      END SUBROUTINE mumps_ab_lmat_to_clean_g
      SUBROUTINE mumps_ab_col_distribution ( OPTION,
     &     INFO, ICNTL, COMM, NBLK, MYID, NPROCS,
     &     LMAT, MAPCOL )
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER IERR
      INTEGER, INTENT(IN) :: OPTION, NBLK
      INTEGER, INTENT(IN) :: ICNTL(60), COMM, MYID, NPROCS
      INTEGER             :: INFO(80)
      TYPE(LMATRIX_T)     :: LMAT
      INTEGER, INTENT(OUT):: MAPCOL(NBLK)
      INTEGER    :: LP, SIZE_NZROW, I
      LOGICAL    :: LPOK
      INTEGER(8) :: NZL, NNZ
      INTEGER, DIMENSION(:), ALLOCATABLE :: NZ_ROW
      lp  = icntl( 1 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      IF (option.EQ.1) THEN
       nnz        = -9999 
       size_nzrow = 1
      ELSE
       nzl  = lmat%NZL
       size_nzrow = nblk
      ENDIF
      ALLOCATE(nz_row(nblk), stat=ierr)
      IF (ierr.NE.0) THEN
           info(1)  = -7
           info(2)  = size_nzrow
           IF ( lpok ) THEN
              WRITE(lp, *) 
     &     " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", info(2)
           END IF
      ENDIF
      CALL mumps_propinfo( icntl(1), info(1),
     &     comm, myid )
      IF (info(1).LT.0) GOTO 500
      IF (option.NE.1) THEN
        DO i = 1, nblk
         mapcol(i) = lmat%COL(i)%NBINCOL
        ENDDO
        CALL mpi_allreduce(mapcol(1), nz_row(1), nblk, 
     &        mpi_integer, mpi_sum, comm, ierr)
        CALL mpi_allreduce(nzl, nnz, 1, 
     &        mpi_integer8, mpi_sum, comm, ierr)
      ENDIF
      CALL mumps_ab_compute_mapcol (option, info, icntl, myid,
     &   nnz, nz_row(1), size_nzrow, nblk, nprocs, mapcol(1))
 500  CONTINUE
      IF (allocated(nz_row)) DEALLOCATE(nz_row)
      RETURN
      END SUBROUTINE mumps_ab_col_distribution
      SUBROUTINE mumps_ab_compute_mapcol (OPTION, INFO, ICNTL, 
     &    MYID, NNZ, NZ_ROW, SIZE_NZROW, NBLK,  NPROCS, MAPCOL )
      INTEGER, INTENT(IN) :: OPTION, MYID, SIZE_NZROW, NBLK
      INTEGER, INTENT(IN) :: ICNTL(60), NPROCS
      INTEGER             :: INFO(80)
      INTEGER(8)          :: NNZ
      INTEGER, INTENT(IN) :: NZ_ROW(SIZE_NZROW)
      INTEGER, INTENT(OUT):: MAPCOL(NBLK)
      INTEGER    :: I, J, P, F, LP, IERR
      LOGICAL    :: LPOK
      INTEGER(8) :: SHARE, T
      INTEGER, DIMENSION(:), ALLOCATABLE :: FIRST
      lp  = icntl( 1 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      ALLOCATE(first(nprocs+1), stat=ierr)
      IF (ierr.NE.0) THEN
           info(1)  = -7
           info(2)  = nprocs+1
           IF ( lpok ) THEN
              WRITE(lp, *) 
     &     " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", info(2)
           END IF
           GOTO 500
      ENDIF
      DO i=1,nprocs+1
       first(i) = 0
      ENDDO
      IF (option.EQ.1) THEN
       share = int(nblk/nprocs,8)
       DO i=1, nprocs
          first(i) = (i-1)*int(share)+1
       END DO
       first(nprocs+1)=nblk+1
      ELSE
       share = (nnz-1_8)/int(nprocs,8) + 1_8
         p = 0
         t = 0_8
         f = 1
         DO i=1, nblk
            t = t+int(nz_row(i),8)
            IF (
     &           (t .GE. share) .OR.
     &           ((nblk-i).EQ.(nprocs-p-1)) .OR.
     &           (i.EQ.nblk)
     &           ) THEN
               p             = p+1
               IF(p.EQ.nprocs) THEN
                  first(p) = f
                  EXIT
               ELSE
                  first(p) = f
                  f             = i+1
                  t             = 0_8
               END IF
            END IF
            IF ((i.EQ.nblk).AND.(p.NE.nprocs)) THEN 
             DO j=p,nprocs
              first(j) = first(p)
             ENDDO
            ENDIF
         END DO
         first(nprocs+1) = nblk+1
      ENDIF
      DO i=1,nprocs
        DO j=first(i), first(i+1)-1
          mapcol(j) = i-1
        ENDDO
      ENDDO
      IF (allocated(first))  DEALLOCATE(first)
 500  CONTINUE
      RETURN
      END SUBROUTINE mumps_ab_compute_mapcol
      SUBROUTINE mumps_ab_build_dclean_lumatrix ( 
     &     MAPCOLonLUMAT, MAPCOL_IN_NSTEPS,
     &     INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS,
     &     LMAT, MAPCOL, SIZEMAPCOL,
     &     STEP, SIZESTEP, 
     &     LUMAT)
      USE mumps_ana_blk_m 
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      LOGICAL, INTENT(IN) :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS
      INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, SIZEMAPCOL
      INTEGER, INTENT(IN) :: ICNTL(60), COMM, KEEP(500)
      INTEGER, INTENT(IN) :: SIZESTEP
      INTEGER, INTENT(IN) :: STEP(SIZESTEP)
      INTEGER, INTENT(INOUT) ::  INFO(80)
      TYPE(lmatrix_t), INTENT(INOUT)  :: LMAT
      INTEGER, INTENT(INOUT)          :: MAPCOL(SIZEMAPCOL)
      TYPE(lmatrix_t), INTENT(OUT)    :: LUMAT
      INTEGER ::      NBLKloc, IERR, JB, IB, LP, NB, I,
     &                NBRECORDS
      INTEGER(8)  ::  NNZ, NZ_locMAX8, NSEND8, NLOCAL8
      LOGICAL :: LPOK
      INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL
      INTEGER OPTION
      parameter(option=2)
      nblkloc = lmat%NBCOL
      IF (nblkloc.NE.nblk) THEN
       write(6,*) "Internal error in MUMPS_AB_BUILD_DCLEAN_LUMATRIX ",
     &       "nblkloc, nblk=", NBLKloc, NBLK
      ENDIF
      LP  = ICNTL( 1 )
.GT..AND..GE.      LPOK  = ((LP0)(ICNTL(4)1))
      ALLOCATE(WT(NBLK), WNBINCOL(NBLK), STAT=IERR)
.NE.      IF (IERR0) THEN
           INFO(1) = -7
           INFO(2) = 2*NBLK
           IF ( LPOK ) THEN
              WRITE(LP, *) " error allocate of lumat%COL; wt"
           END IF
           GOTO 500
      ENDIF
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
       IF ( info(1) .LT. 0 ) GOTO 500
      DO jb=1, nblk
       wt(jb) = lmat%COL(jb)%NBINCOL
      ENDDO
      DO jb=1,nblk
       IF ( lmat%COL(jb)%NBINCOL.EQ.0) cycle
       DO ib=1,  lmat%COL(jb)%NBINCOL
        i = lmat%COL(jb)%IRN(ib)
        wt(i)= wt(i)+1
       ENDDO
      ENDDO
      CALL mpi_allreduce(wt(1), wnbincol(1), nblk, 
     &        mpi_integer, mpi_sum, comm, ierr)
      IF (allocated(wt)) DEALLOCATE(wt)
      IF (mapcolonlumat) THEN
       nnz = 0_8
       DO i=1, nblk
        nnz=nnz+int(wnbincol(i),8)
       ENDDO
       CALL  mumps_ab_compute_mapcol (option, info, icntl,
     &     myid, nnz, wnbincol(1), nblk, 
     &     nblk, nprocs, mapcol(1))
       CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
       IF ( info(1) .LT. 0 ) GOTO 500
      ENDIF
      lumat%NBCOL = nblk
      lumat%NZL   = 0_8
      ALLOCATE(lumat%COL(nblk), stat=ierr)
      IF (ierr.NE.0) THEN
           info(1) = -7
           info(2) = nblk
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LUMAT%COL; WT"
           END IF
      ENDIF
      IF ( info(1) .GE. 0 ) THEN
       DO jb=1,nblk
        nb =  wnbincol(jb)
        IF (mapcol_in_nsteps) THEN
         IF (mapcol(abs(step(jb))).EQ.myid) THEN
          lumat%NZL             = lumat%NZL + int(nb,8)
         ELSE
          nb = 0
         ENDIF
        ELSE
         IF (mapcol(jb).EQ.myid) THEN
          lumat%NZL             = lumat%NZL + int(nb,8)
         ELSE
          nb = 0
         ENDIF
        ENDIF
        lumat%COL(jb)%NBINCOL = nb
        IF (nb.GT.0) THEN
         ALLOCATE(lumat%COL(jb)%IRN(nb), stat=ierr)
         IF (ierr.NE.0) THEN
           info(1)  = -7
           info(2)  = nb
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LUMAT%COL"
           END IF
           EXIT
         ENDIF
        ENDIF
       ENDDO
      ENDIF
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
      CALL mpi_allreduce(lumat%NZL, nz_locmax8, 1, mpi_integer8,
     &                   mpi_max, comm, ierr)
      nbrecords = keep(39)
      IF (nz_locmax8 .LT. int(nbrecords,8)) THEN
            nbrecords = int(nz_locmax8)
      ENDIF
      CALL mumps_ab_dist_lmat_to_lumat ( 
     &  .true.,   
     &  mapcol_in_nsteps,  
     &  info, icntl, comm, myid, nblk, nprocs,
     &  lmat, mapcol, sizemapcol, step, sizestep, 
     &  lumat, nbrecords, nsend8, nlocal8
     &  )
      CALL mumps_ab_free_lmat(lmat)
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      ALLOCATE(wt(nblk), stat=ierr)
      IF (ierr.NE.0) THEN
           info(1) = -7
           info(2) = 2*nblk
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LUMAT%COL; WT"
           END IF
           GOTO 500
      ENDIF
      CALL mumps_ab_localclean_lmat ( myid,
     &     nblk, lumat, wt(1), info(1), info(2), lp, lpok
     & )
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      DEALLOCATE(wt)
      GOTO 600
  500 CONTINUE
      IF (allocated(wt)) DEALLOCATE(wt)
      IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
  600 CONTINUE
      RETURN
      END SUBROUTINE mumps_ab_build_dclean_lumatrix
      SUBROUTINE mumps_inialize_redist_lumat (
     &  INFO, ICNTL, KEEP, COMM, MYID, NBLK, 
     &  LUMAT, PROCNODE_STEPS, NSTEPS, MAPCOL,
     &  LUMAT_REMAP, NBRECORDS, STEP 
     &  )
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER  :: IERR, MASTER
      PARAMETER (MASTER=0)
      integer, INTENT(IN) :: myid, nblk, nsteps, keep(500)
      INTEGER, INTENT(IN)   :: ICNTL(60), COMM
      INTEGER               :: INFO(80)
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS)
      TYPE(lmatrix_t), INTENT(IN)  :: LUMAT
      INTEGER, INTENT(IN)          :: STEP(NBLK)
      TYPE(lmatrix_t), INTENT(INOUT) :: LUMAT_REMAP
      INTEGER, INTENT(OUT) :: NBRECORDS
      INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS)
      INTEGER :: LP, MP, ISTEP, JB, NB
      LOGICAL :: LPOK
      INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL
      INTEGER MUMPS_PROCNODE
      INTEGER(8) :: NZ_locMAX8
      LP  = icntl( 1 )
      mp  = icntl( 2 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      ALLOCATE(wt(nblk), wnbincol(nblk), stat=ierr)
      IF (ierr.NE.0) THEN
        info(1) = -7
        info(2) = 2*nblk
        IF ( lpok ) THEN
           WRITE(lp, *) " ERROR allocate WT"
        END IF
      ENDIF
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      DO jb=1, nblk
       wt(jb) = lumat%COL(jb)%NBINCOL
      ENDDO
      CALL mpi_allreduce(wt(1), wnbincol(1), nblk, 
     &        mpi_integer, mpi_sum, comm, ierr)
      IF (allocated(wt)) DEALLOCATE(wt)
      IF (myid.EQ.master) THEN
       DO istep=1, nsteps
        mapcol(istep) = 
     &              mumps_procnode(procnode_steps(istep),keep(199))
       ENDDO
      ENDIF
      CALL mpi_bcast( mapcol(1), nsteps, mpi_integer,
     &     master, comm, ierr )
      CALL mpi_bcast( step(1), nblk, mpi_integer,
     &     master, comm, ierr )
      lumat_remap%NBCOL = nblk
      ALLOCATE(lumat_remap%COL(nblk), stat=ierr)
      IF (ierr.NE.0) THEN
           info(1) = -7
           info(2) = nblk
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LUMAT_REMAP%COL"
           END IF
      ENDIF
      IF ( info(1) .GE. 0 ) THEN
        lumat_remap%NZL = 0_8
       DO jb=1,nblk
        nb =  wnbincol(jb)
        IF (mapcol(abs(step(jb))).EQ.myid) THEN
         lumat_remap%NZL             = lumat_remap%NZL + int(nb,8)
        ELSE
         nb = 0
        ENDIF
        lumat_remap%COL(jb)%NBINCOL = nb
        IF (nb.GT.0) THEN
         ALLOCATE(lumat_remap%COL(jb)%IRN(nb), stat=ierr)
         IF (ierr.NE.0) THEN
           info(1)  = -7
           info(2)  = nb
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate of LUMAT_REMAP%COL"
           END IF
           EXIT
         ENDIF
        ENDIF
       ENDDO
      ENDIF
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
       CALL mpi_allreduce(lumat_remap%NZL, nz_locmax8, 1, mpi_integer8,
     &                   mpi_max, comm, ierr)
        nbrecords = keep(39)
      IF (nz_locmax8 .LT. int(nbrecords,8)) THEN
            nbrecords = int(nz_locmax8)
      ENDIF
      GOTO 600
  500 CONTINUE
      IF (allocated(wt)) DEALLOCATE(wt)
      IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
  600 CONTINUE
      RETURN
      END SUBROUTINE mumps_inialize_redist_lumat
      SUBROUTINE mumps_ab_dcoord_to_dcompg ( 
     &     MYID, NPROCS, COMM, 
     &     NBLK, NDOF, NNZ, 
     &     IRN, JCN, DOF2BLOCK, 
     &     ICNTL, INFO, KEEP, 
     &     LUMAT, GCOMP, READY_FOR_ANA_F)
      USE mumps_ana_blk_m, ONLY: lmatrix_t, compact_graph_t
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER IERR, MASTER
      parameter( master = 0 )
      INTEGER, INTENT(IN)    :: MYID, NPROCS, NBLK, NDOF
      INTEGER(8), INTENT(IN) :: NNZ
      INTEGER, INTENT(IN)    :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ))
      LOGICAL, INTENT(IN)    :: READY_FOR_ANA_F
      INTEGER, INTENT(INOUT) :: DOF2BLOCK(NDOF)
      INTEGER, INTENT(IN)    :: ICNTL(60), COMM
      INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80)
      TYPE(compact_graph_t)  :: GCOMP
      TYPE(lmatrix_t)        :: LUMAT  
      TYPE(lmatrix_t)        :: LMAT
      INTEGER :: IDUMMY_ARRAY(1)
      INTEGER :: allocok, LP, MPG
      LOGICAL :: LPOK, PROKG
      INTEGER, DIMENSION(:), ALLOCATABLE :: MAPCOL
      LOGICAL :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS
      INTEGER OPTION
      parameter(option=2)
      lp  = icntl( 1 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      mpg = icntl( 3 )
      prokg = ( mpg .GT. 0 .and. myid .eq. master )
      mapcolonlumat    = .false.
      mapcol_in_nsteps = .false.
      IF (keep(14).EQ.1) THEN
         CALL mumps_abort()
      ENDIF
      IF (keep(14).EQ.0) THEN
         CALL mpi_bcast( dof2block, ndof, mpi_integer, master, 
     &     comm, ierr )
      ENDIF
      CALL mumps_ab_coord_to_lmat (  myid, 
     &          nblk, ndof, nnz, irn, jcn,
     &          dof2block, 
     &          info(1), info(2), lp, lpok, 
     &          lmat)
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      ALLOCATE(mapcol(nblk), stat=allocok) 
      IF (allocok.NE.0) THEN
           info(1)  = -7
           info(2)  = nblk
           IF ( lpok ) THEN
              WRITE(lp, *) " ERROR allocate MAPCOL of size", 
     &           info(2)
           END IF
      ENDIF
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      IF (.NOT.mapcolonlumat) THEN 
        CALL mumps_ab_col_distribution (option, 
     &     info, icntl, comm, nblk, myid, nprocs,
     &     lmat, mapcol)
        CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
        IF ( info(1) .LT. 0 ) GOTO 500
      ENDIF
      CALL mumps_ab_build_dclean_lumatrix (
     &    mapcolonlumat, mapcol_in_nsteps,
     &    info, icntl, keep, comm,  myid, nblk, nprocs,
     &    lmat, mapcol, nblk, 
     &    idummy_array, 1, 
     &    lumat)
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
       IF (allocated(mapcol))  DEALLOCATE(mapcol)
       CALL mumps_ab_lmat_to_clean_g ( myid, .false., 
     &         ready_for_ana_f,
     &         lumat, gcomp, info, icntl
     &      )
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      IF (keep(494).EQ.0) THEN
       CALL mumps_ab_free_lmat(lumat)
      ENDIF
      GOTO 600
  500 CONTINUE
      IF (allocated(mapcol))  DEALLOCATE(mapcol)
      CALL mumps_ab_free_lmat(lmat)
      CALL mumps_ab_free_lmat(lumat)
  600 CONTINUE
      RETURN
      END SUBROUTINE mumps_ab_dcoord_to_dcompg
      SUBROUTINE mumps_ab_dcoord_to_dtree_lumat ( 
     &     MYID, NPROCS, COMM, 
     &     NBLK, NDOF, NNZ, 
     &     IRN, JCN, 
     &     PROCNODE_STEPS, NSTEPS, STEP,
     &     ICNTL, INFO, KEEP, 
     &     MAPCOL, LUMAT)
      USE mumps_ana_blk_m, ONLY: lmatrix_t
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER IERR, MASTER
      parameter( master = 0 )
      INTEGER, INTENT(IN)    :: MYID, NPROCS, NBLK, NDOF, NSTEPS
      INTEGER(8), INTENT(IN) :: NNZ
      INTEGER, INTENT(IN)    :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ))
      INTEGER, INTENT(IN)    :: ICNTL(60), COMM
      INTEGER, INTENT(IN)    :: PROCNODE_STEPS(NSTEPS)
      INTEGER, INTENT(IN)    :: STEP(NBLK)
      INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80)
      INTEGER, INTENT(OUT)   :: MAPCOL(NSTEPS)
      TYPE(LMATRIX_T)        :: LUMAT  
      INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK
      TYPE(lmatrix_t)        :: LMAT
      INTEGER :: allocok, LP
      LOGICAL :: LPOK
      INTEGER :: IDOF, ISTEP
      LOGICAL :: MAPCOL_IN_NSTEPS, MAPCOLonLUMAT
      INTEGER OPTION
      parameter(option=2)
      INTEGER MUMPS_PROCNODE
      lp  = icntl( 1 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      mapcolonlumat    = .false.
      mapcol_in_nsteps = .true.
      IF (keep(14).EQ.1) THEN
         CALL mumps_abort()
      ENDIF
      allocate(dof2block(ndof), stat=allocok)
      IF (allocok.NE.0) THEN
           info( 1 ) = -7
           info( 2 ) = ndof
           IF ( lpok ) WRITE(lp, 150) ' DOF2BLOCK'
      ENDIF
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      DO idof=1, ndof
       dof2block(idof) = idof
      ENDDO
      CALL mumps_ab_coord_to_lmat (  myid, 
     &          nblk, ndof, nnz, irn, jcn,
     &          dof2block, 
     &          info(1), info(2), lp, lpok, 
     &          lmat)
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      IF (allocated(dof2block))  DEALLOCATE(dof2block)
      IF (myid.EQ.master) THEN
       DO istep=1, nsteps
        mapcol(istep) = 
     &              mumps_procnode(procnode_steps(istep),keep(199))
       ENDDO
      ENDIF
      CALL mpi_bcast( mapcol(1), nsteps, mpi_integer,
     &     master, comm, ierr )
      CALL mpi_bcast( step(1), nblk, mpi_integer,
     &     master, comm, ierr )
      CALL mumps_ab_build_dclean_lumatrix(
     &    mapcolonlumat, mapcol_in_nsteps,
     &    info, icntl, keep, comm,  myid, nblk, nprocs,
     &    lmat, mapcol, nsteps,
     &    step, nblk, lumat)
      CALL mumps_propinfo(  icntl(1), info(1),
     &     comm, myid )
      IF ( info(1) .LT. 0 ) GOTO 500
      GOTO 600
  500 CONTINUE
      IF (allocated(dof2block))  DEALLOCATE(dof2block)
      CALL mumps_ab_free_lmat(lmat)
      CALL mumps_ab_free_lmat(lumat)
  600 CONTINUE
      RETURN
 150  FORMAT(
     & /' ** FAILURE IN MUMPS_AB_DCOORD_TO_DTREE_LUMAT, ', 
     &  ' DYNAMIC ALLOCATION OF ',
     &     a30)
      END SUBROUTINE mumps_ab_dcoord_to_dtree_lumat
      SUBROUTINE mumps_ab_dist_lmat_to_lumat ( 
     &  UNFOLD,
     &  MAPCOL_IN_NSTEPS,
     &  INFO, ICNTL, COMM, MYID, NBLK, SLAVEF,
     &  LMAT, MAPCOL, SIZEMAPCOL, STEP, SIZESTEP, 
     &  LUMAT, NBRECORDS, NSEND8, NLOCAL8
     &  )
      USE mumps_ana_blk_m, ONLY : lmatrix_t
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER  :: IERR, MASTER, MSGSOU
      parameter(master=0)
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      LOGICAL, INTENT(IN) :: UNFOLD, MAPCOL_IN_NSTEPS
      INTEGER, INTENT(IN) :: MYID, SLAVEF, NBLK 
      INTEGER, INTENT(IN) :: SIZEMAPCOL, SIZESTEP 
      INTEGER, INTENT(IN) :: ICNTL(60), COMM, NBRECORDS
      INTEGER             :: INFO(80)
      TYPE(LMATRIX_T), INTENT(IN)  :: LMAT
      INTEGER, INTENT(IN)          :: MAPCOL(SIZEMAPCOL)
      INTEGER, INTENT(IN)          :: STEP(SIZESTEP)
      TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT
      INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8
      INTEGER :: LP, MP, allocok
      INTEGER :: IB, JB, I, II, ISEND, JSEND, ITOSEND
      LOGICAL :: LPOK 
      INTEGER :: NBTOSEND
      INTEGER END_MSG_2_RECV
      INTEGER KPROBE, FREQPROBE
      INTEGER, ALLOCATABLE, DIMENSION(:) :: PTLOC
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI
      INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE
      INTEGER  :: DEST
      LOGICAL  :: FLAG
      LP  = icntl( 1 )
      mp  = icntl( 2 )
      lpok  = ((lp.GT.0).AND.(icntl(4).GE.1))
      IF (unfold) THEN
        nbtosend = 2
      ELSE
        nbtosend = 1
      ENDIF
      nsend8  = 0_8
      nlocal8 = 0_8
      end_msg_2_recv = slavef-1
      ALLOCATE( iact(slavef), stat=allocok)
      IF ( allocok .GT. 0 ) THEN
        IF ( lp > 0 ) THEN
          WRITE(lp,*)
     &     '** Error allocating IACT in matrix distribution'
        END IF
        info(1) = -7
        info(2) = slavef
        GOTO 20
      END IF
      ALLOCATE( ireqi(slavef), stat=allocok)
      IF ( allocok .GT. 0 ) THEN
        IF ( lp > 0 ) THEN
          WRITE(lp,*)
     &     '** Error allocating IREQI in matrix distribution'
        END IF
        info(1) = -7
        info(2) = slavef
        GOTO 20
      END IF
      ALLOCATE( send_active(slavef), stat=allocok)
      IF ( allocok .GT. 0 ) THEN
        IF ( lp > 0 ) THEN
          WRITE(lp,*)
     &     '** Error allocating SEND_ACTIVE in matrix distribution'
        END IF
        info(1) = -7
        info(2) = slavef
        GOTO 20
      END IF
      ALLOCATE( bufi( nbrecords * 2 + 1, 2, slavef ), stat=allocok)
      IF ( allocok .GT. 0 ) THEN
        IF ( lp > 0 ) THEN
          WRITE(lp,*)
     &     '** Error allocating int buffer for matrix distribution'
        END IF
        info(1) = -7
        info(2) = ( nbrecords * 2 + 1 ) * slavef * 2
        GOTO 20
      END IF
      ALLOCATE( bufreci( nbrecords * 2 + 1 ), stat = allocok )
      IF ( allocok .GT. 0 ) THEN
        IF ( lp > 0 ) THEN
          WRITE(lp,*)
     &    '** error allocating int recv buffer for matrix distribution'
        END IF
        INFO(1) = -7
        INFO(2) = NBRECORDS * 2 + 1
        GOTO 20
      END IF
      ALLOCATE( PTLOC( NBLK ), stat = allocok )
.GT.      IF ( allocok  0 ) THEN
        IF ( LP > 0 ) THEN
          WRITE(LP,*)
     &    '** error allocating int recv buffer for matrix distribution'
        END IF
        INFO(1) = -7
        INFO(2) = NBLK
        GOTO 20
      END IF
 20   CONTINUE
      CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID )
.LT.      IF ( INFO(1)  0 ) GOTO 100
      DO I = 1, SLAVEF
        BUFI( 1, 1, I ) = 0
      END DO
      DO I = 1, SLAVEF
        BUFI( 1, 2, I ) = 0
      END DO
      DO I = 1, SLAVEF
        SEND_ACTIVE( I ) = .FALSE.
        IACT( I ) = 1
      END DO
      DO I = 1, NBLK
        PTLOC(I) = 0
      END DO
      KPROBE = 0
      FREQPROBE = max(1,NBRECORDS/10)
.EQ.      IF (SLAVEF  1) FREQPROBE = huge(FREQPROBE)
      DO JB=1,NBLK
.EQ.       IF ( LMAT%COL(JB)%NBINCOL0) CYCLE
       DO II=1,  LMAT%COL(JB)%NBINCOL
        KPROBE = KPROBE + 1
.eq.        IF ( KPROBE  FREQPROBE ) THEN
          KPROBE = 0
          CALL MPI_IPROBE( MPI_ANY_SOURCE, LMATDIST, COMM,
     &                     FLAG, STATUS, IERR )
          IF ( FLAG ) THEN
            MSGSOU = STATUS( MPI_SOURCE )
            CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, 
     &                 MPI_INTEGER,
     &                 MSGSOU, LMATDIST, COMM, STATUS, IERR )
            CALL MUMPS_AB_LMAT_TREAT_RECV_BUF(
     &             MYID, BUFRECI(1), NBRECORDS, LUMAT, 
     &             NBLK, PTLOC(1), END_MSG_2_RECV
     &             )
          END IF
        END IF
        IB = LMAT%COL(JB)%IRN(II)
        DO ITOSEND=1,NBTOSEND
.EQ.         IF (ITOSEND1) THEN
          IF (MAPCOL_IN_NSTEPS) THEN
           DEST  = MAPCOL(abs(STEP(JB)))
          ELSE
           DEST  = MAPCOL(JB)
          ENDIF
          ISEND = IB
          JSEND = JB
         ELSE
          IF (MAPCOL_IN_NSTEPS) THEN
           DEST  = MAPCOL(abs(STEP(IB)))
          ELSE
           DEST  = MAPCOL(IB)
          ENDIF
          ISEND = JB
          JSEND = IB
         ENDIF
.EQ.         IF (DESTMYID) THEN
          LUMAT%COL(JSEND)%IRN(1+PTLOC(JSEND))= ISEND
          PTLOC(JSEND)    = PTLOC(JSEND) + 1
          NLOCAL8 = NLOCAL8 + 1_8
         ELSE
          NSEND8 = NSEND8 + 1_8
          CALL MUMPS_AB_LMAT_FILL_BUFFER( 
     &     DEST, ISEND, JSEND, NBLK,
     &     BUFI, BUFRECI, PTLOC,
     &     NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, 
     &     SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV
     &      )
         ENDIF
        ENDDO
       ENDDO
      ENDDO
      DEST = -3
      CALL MUMPS_AB_LMAT_FILL_BUFFER(DEST, ISEND, JSEND, 
     &     NBLK, BUFI, BUFRECI, PTLOC,
     &     NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, 
     &     SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV
     &      )
.NE.      DO WHILE ( END_MSG_2_RECV  0 )
        CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER,
     &                 MPI_ANY_SOURCE, LMATDIST, COMM, STATUS, IERR )
        CALL MUMPS_AB_LMAT_TREAT_RECV_BUF(
     &             MYID, BUFRECI(1), NBRECORDS, LUMAT, 
     &             NBLK, PTLOC(1), END_MSG_2_RECV
     &             )
      END DO
      DO I = 1, SLAVEF
        IF ( SEND_ACTIVE( I ) ) THEN
          CALL MPI_WAIT( IREQI( I ), STATUS, IERR )
        END IF
      END DO
 100  CONTINUE
      IF (ALLOCATED(PTLOC))   DEALLOCATE( PTLOC )
      IF (ALLOCATED(BUFI))    DEALLOCATE( BUFI )
      IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI )
      IF (ALLOCATED(IACT))    DEALLOCATE( IACT )
      IF (ALLOCATED(IREQI))   DEALLOCATE( IREQI )
      IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE )
      RETURN
      END SUBROUTINE MUMPS_AB_DIST_LMAT_TO_LUMAT
      SUBROUTINE MUMPS_AB_LMAT_TREAT_RECV_BUF (
     &   MYID, BUFI, NBRECORDS, LUMAT,  
     &   NBLK, PTLOC, END_MSG_2_RECV
     & )
      USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INTEGER, INTENT(IN)   :: NBLK, MYID, NBRECORDS
      INTEGER, INTENT(IN)   :: BUFI( NBRECORDS * 2 + 1 ) 
      INTEGER, INTENT(INOUT):: END_MSG_2_RECV, PTLOC(NBLK)
      TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT
      INTEGER :: IREC, NB_REC, IB, JB
      NB_REC = BUFI( 1 )
.LE.      IF ( NB_REC  0 ) THEN
        END_MSG_2_RECV = END_MSG_2_RECV - 1
        NB_REC = - NB_REC
      END IF
.eq.      IF ( NB_REC  0 ) RETURN
      DO IREC = 1, NB_REC
       IB = BUFI( IREC * 2 )
       JB = BUFI( IREC * 2 + 1 )
       LUMAT%COL(JB)%IRN(1+PTLOC(JB))= IB
       PTLOC(JB) = PTLOC(JB) + 1
      ENDDO
      RETURN
      END SUBROUTINE MUMPS_AB_LMAT_TREAT_RECV_BUF
      SUBROUTINE MUMPS_AB_LMAT_FILL_BUFFER (
     &     DEST, ISEND, JSEND, NBLK,
     &     BUFI, BUFRECI, PTLOC,
     &     NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, 
     &     SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV
     &      )
      USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER, INTENT(IN)  :: DEST, ISEND, JSEND, SLAVEF, COMM, MYID, 
     &                        NBRECORDS, NBLK
      INTEGER, INTENT(INOUT) :: END_MSG_2_RECV, PTLOC(NBLK)
      TYPE(LMATRIX_T), INTENT(IN)     :: LMAT
      TYPE(LMATRIX_T), INTENT(INOUT)  :: LUMAT
      LOGICAL, INTENT(INOUT) ::  SEND_ACTIVE(SLAVEF)
      INTEGER, INTENT(INOUT) ::  IREQI(SLAVEF), IACT(SLAVEF)
      INTEGER, INTENT(INOUT) ::  BUFI( NBRECORDS * 2 + 1, 2, SLAVEF )
      INTEGER, INTENT(INOUT) ::  BUFRECI( NBRECORDS * 2 + 1)
      INTEGER :: IBEG, IEND, ISLAVE, TAILLE_SEND_I, IREQ, MSGSOU,
     &           NBREC, IERR
      LOGICAL :: FLAG
.eq.      IF ( DEST  -3 ) THEN
        IBEG = 1
        IEND = SLAVEF
      ELSE
        IBEG = DEST + 1
        IEND = DEST + 1
      END IF
      DO ISLAVE = IBEG, IEND
        NBREC = BUFI(1,IACT(ISLAVE),ISLAVE)
.eq.        IF ( DEST  -3 ) THEN
          BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC
        END IF
.eq..or.        IF ( DEST  -3  NBREC + 1 > NBRECORDS ) THEN
          DO WHILE ( SEND_ACTIVE( ISLAVE ) )
            CALL MPI_TEST( IREQI( ISLAVE ), FLAG, STATUS, IERR )
.NOT.            IF (  FLAG ) THEN
                CALL MPI_IPROBE( MPI_ANY_SOURCE, LMATDIST, COMM,
     &                           FLAG, STATUS, IERR )
                IF ( FLAG ) THEN
                  MSGSOU = STATUS(MPI_SOURCE)
                  CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1,
     &                  MPI_INTEGER, MSGSOU, LMATDIST, COMM,
     &                  STATUS, IERR )
                  CALL MUMPS_AB_LMAT_TREAT_RECV_BUF(
     &             MYID, BUFRECI, NBRECORDS, LUMAT, 
     &             NBLK, PTLOC(1), END_MSG_2_RECV
     &             )
                END IF
            ELSE
              SEND_ACTIVE( ISLAVE ) = .FALSE.
            END IF
          END DO
.ne.          IF ( ISLAVE - 1  MYID ) THEN
            TAILLE_SEND_I = NBREC * 2 + 1
            CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ),
     &          TAILLE_SEND_I,
     &          MPI_INTEGER, ISLAVE - 1, LMATDIST, COMM,
     &          IREQI( ISLAVE ), IERR )
            SEND_ACTIVE( ISLAVE ) = .TRUE.
          ELSE
.NE.            IF (NBREC0) THEN 
              write(*,*) " Internal error in ", 
     &                    " MUMPS_AB_LMAT_FILL_BUFFER "
              CALL MUMPS_ABORT()
            ENDIF
          END IF
          IACT( ISLAVE ) = 3 - IACT( ISLAVE )
          BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0
        END IF
.ne.        IF ( DEST  -3 ) THEN
          IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1
          BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ
          BUFI(IREQ*2,IACT(ISLAVE),ISLAVE)  = ISEND
          BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND
        END IF
      ENDDO
      RETURN
      END SUBROUTINE MUMPS_AB_LMAT_FILL_BUFFER
      SUBROUTINE MUMPS_AB_GATHER_GRAPH (
     &    ICNTL, KEEP, COMM, MYID, NPROCS, INFO, 
     &    GCOMP_DIST, GCOMP)
      USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INTEGER IERR, MASTER
      PARAMETER( MASTER = 0 )
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      TYPE(COMPACT_GRAPH_T), INTENT(IN)  :: GCOMP_DIST
      INTEGER, INTENT(IN)    :: MYID, NPROCS,  ICNTL(60), COMM,
     &                          KEEP(500)
      INTEGER, INTENT(INOUT) ::  INFO(80)
      TYPE(COMPACT_GRAPH_T) :: GCOMP
       INTEGER    :: NG, allocok, LP, MPG, I, J, K
       INTEGER    :: INDX, NB_BLOCK_SENT, MAX_NBBLOCK_loc, NRECV,
     &               BLOCKSIZE, SIZE_SENT, NB_BLOCKS, NBNONEMPTY,
     &               FIRSTNONEMPTY, LASTNONEMPTY, NBBLOCK_loc
       INTEGER(4) :: IOVFLO
       INTEGER(8) :: NZG, NZG_CENT, I8, IBEG8, IEND8, 
     &               SIZEGCOMPALLOCATED
       LOGICAL    :: LPOK, PROKG
       INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ
      INTEGER, ALLOCATABLE :: REQPTR(:)
      INTEGER(8), ALLOCATABLE :: GPTR(:), GPTR_cp(:)
      LP  = ICNTL( 1 )
.GT..AND..GE.      LPOK  = ((LP0)(ICNTL(4)1))
      MPG = ICNTL( 3 )
.GT..and..eq.      PROKG = ( MPG  0  MYID  MASTER )
.AND..GE.      PROKG = (PROKG(ICNTL(4)2))
      IOVFLO = huge(IOVFLO)  
      BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8))
      NZG =  GCOMP_DIST%NZG
      NG  =  GCOMP_DIST%NG
      CALL MPI_REDUCE( NZG, NZG_CENT, 1, MPI_INTEGER8, 
     &     MPI_SUM, MASTER, COMM, IERR )
.EQ.      IF (MYIDMASTER) THEN
        GCOMP%NZG = NZG_CENT
        GCOMP%NG  = NG
        SIZEGCOMPALLOCATED     = NZG_CENT+int(NG,8)+1_8
        GCOMP%SIZEADJALLOCATED = SIZEGCOMPALLOCATED
        ALLOCATE( GCOMP%ADJ(SIZEGCOMPALLOCATED),
     &          GCOMP%IPE(NG+1), 
     &          GPTR( NPROCS ),
     &          GPTR_cp( NPROCS ),
     &          REQPTR( NPROCS-1 ),
     &          IQ(NG+1),STAT=allocok)
.NE.        IF (allocok0) THEN
           INFO( 1 ) = -7
           CALL MUMPS_SET_IERROR(
     &        NZG_CENT + 3_8*int(NG,8)+3_8+3_8*int(NPROCS,8)-1_8, 
     &        INFO(2))
           IF ( LPOK )
     &     WRITE(LP, *) " ERROR allocating graph in",
     &                  " MUMPS_AB_GATHER_GRAPH"
        ENDIF
      ELSE
        ALLOCATE( IQ(NG+1), STAT=allocok)
.NE.        IF (allocok0) THEN
           INFO( 1 ) = -7
           INFO( 2 ) = NG+1
           IF ( LPOK )
     &     WRITE(LP, *) " ERROR allocating pointers",
     &                  " MUMPS_AB_GATHER_GRAPH"
        END IF
      ENDIF
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &     COMM, MYID )
.LT.      IF (INFO(1)0) GOTO 500
      FIRSTNONEMPTY = 0
      LASTNONEMPTY  = -1
      DO I=1,NG
       IQ(I) = int(GCOMP_DIST%IPE(I+1)-GCOMP_DIST%IPE(I))
.NE.       IF (IQ(I)0) THEN
.EQ.         IF (FIRSTNONEMPTY0) FIRSTNONEMPTY=I
         LASTNONEMPTY = I
       ENDIF
      ENDDO
      NBNONEMPTY = LASTNONEMPTY-FIRSTNONEMPTY+1
.EQ.      IF (MYIDMASTER) THEN
       DO J=1, NG
        GCOMP%IPE(J) = 0
       ENDDO
       J=FIRSTNONEMPTY   
.GT.       IF (NBNONEMPTY0) THEN
        DO I=FIRSTNONEMPTY, LASTNONEMPTY
          GCOMP%IPE(J) = IQ(I)
          J = J+1
        ENDDO
       ENDIF
       DO I = 1, NPROCS - 1
         CALL MPI_RECV( NBNONEMPTY, 1, 
     &           MPI_INTEGER, I,
     &           GATHERG_NB, COMM, STATUS, IERR )
.GT.         IF (NBNONEMPTY0) THEN
           CALL MPI_RECV( J, 1, 
     &           MPI_INTEGER, I,
     &           GATHERG_FIRST, COMM, STATUS, IERR )
           CALL MPI_RECV( GCOMP%IPE(J), NBNONEMPTY, 
     &           MPI_INTEGER8, I,
     &           GATHERG_IPE, COMM, STATUS, IERR )
         ENDIF
       ENDDO
      ELSE
        CALL MPI_SEND( NBNONEMPTY, 1, MPI_INTEGER, MASTER,
     &       GATHERG_NB, COMM, IERR )
.GT.        IF (NBNONEMPTY0) THEN
          CALL MPI_SEND( FIRSTNONEMPTY, 1, MPI_INTEGER, MASTER,
     &       GATHERG_FIRST, COMM, IERR )
          CALL MPI_SEND( IQ(FIRSTNONEMPTY), NBNONEMPTY, 
     &       MPI_INTEGER8, MASTER,
     &       GATHERG_IPE, COMM, IERR )
        ENDIF
      ENDIF
.EQ.      IF (MYIDMASTER) THEN
       IQ(1) = 1_8
       DO I=1,NG
         IQ(I+1) = IQ(I) + GCOMP%IPE(I)
         GCOMP%IPE(I) = IQ(I)
       ENDDO
       GCOMP%IPE(NG+1) = IQ(NG+1)
       DEALLOCATE(IQ)
      ELSE
       DEALLOCATE(IQ)
      ENDIF
.EQ.      IF (MYIDMASTER) THEN
        NB_BLOCK_SENT = 0
        MAX_NBBLOCK_loc  = 0
        DO I = 1, NPROCS - 1
            CALL MPI_RECV( GPTR( I+1 ), 1, 
     &           MPI_INTEGER8, I,
     &           GATHERG_NZG, COMM, STATUS, IERR )
         NBBLOCK_loc = ceiling(dble(GPTR(I+1))/dble(BLOCKSIZE))
         MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc)
         NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc
        ENDDO
        GPTR( 1 ) = NZG + 1_8
         DO I = 2, NPROCS
            GPTR( I ) = GPTR( I ) + GPTR( I-1 )
         END DO
      ELSE
        CALL MPI_SEND( NZG, 1, MPI_INTEGER8, MASTER,
     &        GATHERG_NZG, COMM, IERR )
      ENDIF
.EQ.      IF (MYIDMASTER) THEN
        DO I=1, NPROCS
         GPTR_cp(I) = GPTR(I) 
        ENDDO
.GT.        IF (NZG0_8) THEN
         DO I8=1, NZG
          GCOMP%ADJ(I8) = GCOMP_DIST%ADJ(I8)
         ENDDO
        ENDIF
        NB_BLOCKS = 0
        DO K = 1, MAX_NBBLOCK_loc
         NRECV = 0
         DO I = 1, NPROCS - 1
            IBEG8     = GPTR_cp( I )
.LT.            IF ( IBEG8  GPTR(I+1))  THEN
              NRECV = NRECV + 1
              IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, 
     &                    GPTR(I+1)-1_8)
              GPTR_cp( I ) = IEND8 + 1_8
              SIZE_SENT   = int(IEND8 -  IBEG8 + 1_8)
              NB_BLOCKS   = NB_BLOCKS + 1
              CALL MPI_IRECV( GCOMP%ADJ(IBEG8), SIZE_SENT, 
     &           MPI_INTEGER,
     &           I, GATHERG_ADJ, COMM, REQPTR(I), IERR )
            ELSE
             REQPTR( I ) = MPI_REQUEST_NULL
            ENDIF
         END DO
         DO I = 1, NRECV
             CALL MPI_WAITANY
     &           ( NPROCS-1, REQPTR, INDX, 
     &           STATUS, IERR )
         ENDDO
      END DO
        DEALLOCATE( REQPTR )
        DEALLOCATE( GPTR )
        DEALLOCATE( GPTR_cp )
      ELSE
.EQ.        IF (NZG0) GOTO 600
        DO I8=1_8, NZG, int(BLOCKSIZE,8)
         SIZE_SENT = BLOCKSIZE
.LT.         IF (NZG-I8+1_8int(BLOCKSIZE,8)) THEN
              SIZE_SENT = int(NZG-I8+1_8)
         ENDIF
         CALL MPI_SEND( 
     &           GCOMP_DIST%ADJ(I8), SIZE_SENT,
     &           MPI_INTEGER, MASTER,
     &           GATHERG_ADJ, COMM, IERR )
        ENDDO
      ENDIF
       GOTO 600
 500  CONTINUE
.EQ.      IF (MYIDMASTER) THEN
       IF (associated(GCOMP%ADJ)) THEN
          DEALLOCATE(GCOMP%ADJ)
          nullify(GCOMP%ADJ)
       ENDIF
       IF (associated(GCOMP%IPE)) THEN
        DEALLOCATE(GCOMP%IPE)
        nullify(GCOMP%IPE)
       ENDIF
      ENDIF
 600  CONTINUE
      IF (allocated(IQ)) DEALLOCATE(IQ)
      RETURN
      END SUBROUTINE MUMPS_AB_GATHER_GRAPH