tools_common.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_find_unit(IUNIT)
      IMPLICIT NONE
      INTEGER :: IUNIT
      INTEGER, PARAMETER :: UNIT_MIN = 10 
      INTEGER, PARAMETER :: UNIT_MAX = 500
      INTEGER :: I
      LOGICAL :: BUSY
      iunit = -1
      DO i = unit_min, unit_max
        INQUIRE(unit=i, opened=busy)
        IF ( .NOT. busy ) THEN
          iunit = i
          RETURN
        END IF
      ENDDO
      RETURN
      END SUBROUTINE mumps_find_unit
      SUBROUTINE mumps_make1root( N, FRERE, FILS, NFSIZ, THEROOT )
      IMPLICIT NONE
      INTEGER, intent( in    )  :: N
      INTEGER, intent( in    )  :: NFSIZ( N )
      INTEGER, intent( inout )  :: FRERE( N ), FILS( N )
      INTEGER, intent( out   )  :: THEROOT
      INTEGER INODE, IROOT, IFILS, IN, IROOTLAST, SIZE
      iroot = -9999
      SIZE  = 0
      DO inode = 1, n
        IF ( frere( inode ) .EQ. 0 )  THEN
          IF ( nfsiz( inode ) .GT. SIZE ) THEN
            SIZE  = nfsiz( inode )
            iroot = inode
          END IF
        ENDIF
      END DO
      in = iroot
      DO WHILE ( fils( in ) .GT. 0 )
        in = fils( in )
      END DO
      irootlast = in
      ifils     = - fils( in )
      DO inode = 1, n
        IF ( frere( inode ) .eq. 0 .and. inode .ne. iroot ) THEN
          IF ( ifils .eq. 0 ) THEN
            fils( irootlast ) = - inode
            frere( inode )    = -iroot
            ifils             = inode
          ELSE
            frere( inode ) = -fils( irootlast )
            fils( irootlast ) = - inode
          END IF
        END IF
      END DO
      theroot = iroot
      RETURN
      END SUBROUTINE mumps_make1root
      INTEGER FUNCTION mumps_encode_tpn_iproc(TPN,IPROC,K199)
      INTEGER, INTENT(IN) :: TPN, iproc, k199
      IF (k199 < 0) THEN
        mumps_encode_tpn_iproc = iproc + ishft(tpn+1, 24)
      ELSE
        mumps_encode_tpn_iproc = (tpn-1)*k199+iproc+1
      ENDIF
      RETURN
      END FUNCTION mumps_encode_tpn_iproc
      INTEGER FUNCTION mumps_typenode_rough(PROCINFO_INODE, K199)
      IMPLICIT NONE
      INTEGER k199 
      INTEGER procinfo_inode
      IF (k199 < 0) THEN
        mumps_typenode_rough = ishft(procinfo_inode,-24) - 1
      ELSE
        mumps_typenode_rough = (procinfo_inode-1+2*k199)/k199 - 1
      ENDIF
      RETURN 
      END FUNCTION mumps_typenode_rough
      INTEGER FUNCTION mumps_typenode(PROCINFO_INODE, K199)
      IMPLICIT NONE
      INTEGER k199 
      INTEGER procinfo_inode, tpn
      IF (k199 < 0) THEN
        tpn = ishft(procinfo_inode,-24) - 1
        IF (tpn < 1 ) THEN
          tpn = 1
        ELSE IF (tpn.GE.4) THEN
          tpn = 2
        ENDIF
      ELSE
        IF (procinfo_inode <= k199 ) THEN
          tpn = 1
        ELSE
          tpn = (procinfo_inode-1+2*k199)/k199 - 1
          IF ( tpn .LT. 1 ) tpn = 1
          IF (tpn.EQ.4.OR.tpn.EQ.5.OR.tpn.EQ.6) tpn = 2
        END IF
      END IF
      mumps_typenode = tpn
      RETURN 
      END FUNCTION mumps_typenode
      SUBROUTINE mumps_typeandprocnode( TPN,
     &  MUMPS_PROCNODE, PROCINFO_INODE, K199 )
      INTEGER, INTENT(IN) :: K199, PROCINFO_INODE
      INTEGER, intent(out) :: TPN, MUMPS_PROCNODE
      IF (k199 < 0 ) THEN
        mumps_procnode=iand(procinfo_inode,
#if defined(MUMPS_F2003)
     &         int(b"111111111111111111111111"))
#else
     &         16777215)
#endif
        tpn = ishft(procinfo_inode,-24) - 1
        IF (tpn < 1 ) THEN
          tpn = 1
        ELSE IF (tpn.GE.4) THEN
          tpn = 2
        ENDIF
      ELSE
        IF (k199 == 1) THEN
          mumps_procnode = 0
          IF (procinfo_inode <= k199) THEN
            tpn = 1
          ELSE
            tpn = 3
          ENDIF
        ELSE
          tpn = (procinfo_inode-1+2*k199)/k199-1
          mumps_procnode = (procinfo_inode-1+2*k199)-
     &                      (tpn+1)*k199
          IF (tpn .LT. 1) THEN
            tpn = 1
          ELSE IF (tpn .ge. 4) THEN
            tpn = 2
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE mumps_typeandprocnode
      INTEGER FUNCTION mumps_procnode(PROCINFO_INODE, K199)
      IMPLICIT NONE
      INTEGER k199 
      INTEGER procinfo_inode
      IF ( k199 < 0 ) THEN
        mumps_procnode=iand(procinfo_inode,
#if defined(MUMPS_F2003)
     &         int(b"111111111111111111111111"))
#else
     &          16777215 )
#endif
      ELSE
        IF (k199 == 1) THEN
          mumps_procnode = 0
        ELSE
          mumps_procnode=mod(2*k199+procinfo_inode-1,k199)
        END IF
      ENDIF
      RETURN
      END FUNCTION mumps_procnode
      INTEGER FUNCTION mumps_typesplit (PROCINFO_INODE, K199)
      IMPLICIT NONE
      INTEGER, intent(in) ::  k199 
      INTEGER procinfo_inode, tpn
      IF (k199 < 0) THEN
        tpn = ishft(procinfo_inode,-24) - 1
        IF (tpn < 1 ) tpn = 1
      ELSE
        IF (procinfo_inode <= k199 ) THEN
           tpn = 1
        ELSE
          tpn = (procinfo_inode-1+2*k199)/k199 - 1
          IF ( tpn .LT. 1 ) tpn = 1
        ENDIF
      ENDIF
      mumps_typesplit = tpn
      RETURN
      END FUNCTION mumps_typesplit
      LOGICAL FUNCTION mumps_rootssarbr( PROCINFO_INODE, K199 )
      IMPLICIT NONE
      INTEGER k199
      INTEGER tpn, procinfo_inode
      IF (k199 < 0) THEN
        tpn = ishft(procinfo_inode,-24) - 1
      ELSE
        tpn = (procinfo_inode-1+2*k199)/k199 - 1
      ENDIF
      mumps_rootssarbr = ( tpn .eq. 0 )
      RETURN
      END FUNCTION mumps_rootssarbr
      LOGICAL FUNCTION mumps_inssarbr( PROCINFO_INODE, K199 )
      IMPLICIT NONE
      INTEGER k199
      INTEGER tpn, procinfo_inode
      IF (k199 < 0) THEN
        tpn = ishft(procinfo_inode,-24) - 1
      ELSE
        tpn = (procinfo_inode-1+k199+k199)/k199 - 1
      ENDIF
      mumps_inssarbr = ( tpn .eq. -1 )
      RETURN 
      END FUNCTION mumps_inssarbr
      LOGICAL FUNCTION mumps_in_or_root_ssarbr
     &        ( procinfo_inode, k199 )
      IMPLICIT NONE
      INTEGER k199
      INTEGER tpn, procinfo_inode
      IF (k199 < 0) THEN
        tpn = ishft(procinfo_inode,-24) - 1
      ELSE
        tpn = (procinfo_inode-1+k199+k199)/k199 - 1
      ENDIF
      mumps_in_or_root_ssarbr =
     &           ( tpn .eq. -1 .OR. tpn .eq. 0 )
      RETURN
      END FUNCTION mumps_in_or_root_ssarbr
            SUBROUTINE mumps_set_ssarbr_dad(
     &           SSARBR, INODE, DAD, N,
     &           KEEP28,
     &           STEP, PROCNODE_STEPS, K199)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: N, KEEP28, K199, INODE
            INTEGER, INTENT(IN) :: DAD(KEEP28), PROCNODE_STEPS(KEEP28)
            INTEGER, INTENT(IN) :: STEP(N)
            LOGICAL, INTENT(OUT) :: SSARBR
            INTEGER :: DADINODE, TYPEDAD
            LOGICAL, EXTERNAL :: MUMPS_INSSARBR
            INTEGER, EXTERNAL :: MUMPS_TYPENODE
            ssarbr   = .false.
            dadinode = dad(step(inode))
            IF (dadinode .NE. 0) THEN
              typedad  = mumps_typenode(procnode_steps(step(dadinode)),
     &                                  k199)
              IF (typedad.EQ.1) THEN
                ssarbr=mumps_inssarbr(procnode_steps(step(dadinode)),
     &                                k199)
              ENDIF
            ENDIF
            RETURN
            END SUBROUTINE mumps_set_ssarbr_dad
      LOGICAL FUNCTION mumps_i_am_candidate( MYID, SLAVEF, INODE,
     &                 NMB_PAR2, ISTEP_TO_INIV2 , K71, STEP, N, 
     &                 CANDIDATES, KEEP24 )
      IMPLICIT NONE
      INTEGER myid, slavef, inode, nmb_par2, keep24, i
      INTEGER k71, n
      INTEGER istep_to_iniv2 ( k71 ), step ( n )
      INTEGER candidates(slavef+1, max(nmb_par2,1))
      INTEGER ncand, posinode
      mumps_i_am_candidate = .false.
      IF (keep24 .eq. 0) RETURN
      posinode = istep_to_iniv2( step(inode) )
      ncand = candidates( slavef+1, posinode )
      DO i = 1, ncand
        IF (myid .EQ. candidates( i, posinode ))
     &     mumps_i_am_candidate = .true.
      END DO
      RETURN
      END FUNCTION mumps_i_am_candidate
      SUBROUTINE mumps_secdeb(T)
      DOUBLE PRECISION T
      DOUBLE PRECISION MPI_WTIME
      EXTERNAL mpi_wtime
      t=mpi_wtime()
      RETURN
      END SUBROUTINE mumps_secdeb
      SUBROUTINE mumps_secfin(T)
      DOUBLE PRECISION T
      DOUBLE PRECISION MPI_WTIME
      EXTERNAL mpi_wtime
      t=mpi_wtime()-t
      RETURN
      END SUBROUTINE mumps_secfin
      SUBROUTINE mumps_sort_doubles( N, VAL, ID )
      INTEGER N
      INTEGER ID( N )
      DOUBLE PRECISION VAL( N )
      INTEGER I, ISWAP
      DOUBLE PRECISION SWAP
      LOGICAL DONE
      done = .false.
      DO WHILE ( .NOT. done )
        done = .true.
        DO i = 1, n - 1
          IF ( val( i ) .GT. val( i + 1 ) ) THEN
            done = .false.
            iswap = id( i )
            id( i ) = id( i + 1 )
            id( i + 1 ) = iswap
            swap = val( i )
            val( i ) = val( i + 1 )
            val( i + 1 ) = swap
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE mumps_sort_doubles
      SUBROUTINE mumps_sort_doubles_dec( N, VAL, ID )
      INTEGER N
      INTEGER ID( N )
      DOUBLE PRECISION VAL( N )
      INTEGER I, ISWAP
      DOUBLE PRECISION SWAP
      LOGICAL DONE
      done = .false.
      DO WHILE ( .NOT. done )
        done = .true.
        DO i = 1, n - 1
          IF ( val( i ) .LT. val( i + 1 ) ) THEN
            done = .false.
            iswap = id( i )
            id( i ) = id( i + 1 )
            id( i + 1 ) = iswap
            swap = val( i )
            val( i ) = val( i + 1 )
            val( i + 1 ) = swap
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE mumps_sort_doubles_dec
#if defined (PESSL)
      SUBROUTINE descinit( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT,
     &                     LLD, INFO )
      INTEGER            ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB
      INTEGER            DESC( * )
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     &                   lld_, mb_, m_, nb_, n_, rsrc_
# if defined(DESC8)
      parameter( dlen_ = 8, dtype_ = 1,
     &                     ctxt_ = 7, m_ = 1, n_ = 2, mb_ = 3, nb_ = 4,
     &                     rsrc_ = 5, csrc_ = 6, lld_ = 8 )
# else
      parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
     &                     ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     &                     rsrc_ = 7, csrc_ = 8, lld_ = 9 )
# endif
      INTEGER            MYCOL, MYROW, NPCOL, NPROW
      EXTERNAL           blacs_gridinfo, PXERBLA
      INTEGER            NUMROC
      EXTERNAL           numroc
      INTRINSIC          max, min
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
      info = 0
      IF( m.LT.0 ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( mb.LT.1 ) THEN
         info = -4
      ELSE IF( nb.LT.1 ) THEN
         info = -5
      ELSE IF( irsrc.LT.0 .OR. irsrc.GE.nprow ) THEN
         info = -6
      ELSE IF( icsrc.LT.0 .OR. icsrc.GE.npcol ) THEN
         info = -7
      ELSE IF( nprow.EQ.-1 ) THEN
         info = -8
      ELSE IF( lld.LT.max( 1, numroc( m, mb, myrow, irsrc,
     &                                nprow ) ) ) THEN
         info = -9
      END IF
      IF( info.NE.0 )
     &   CALL pxerbla( ictxt, 'DESCINIT', -info )
# ifndef DESC8
      desc( dtype_ ) = block_cyclic_2d
# endif
      desc( m_ )  = max( 0, m )
      desc( n_ )  = max( 0, n )
      desc( mb_ ) = max( 1, mb )
      desc( nb_ ) = max( 1, nb )
      desc( rsrc_ ) = max( 0, min( irsrc, nprow-1 ) )
      desc( csrc_ ) = max( 0, min( icsrc, npcol-1 ) )
      desc( ctxt_ ) = ictxt
      desc( lld_ )  = max( lld, max( 1, numroc( desc( m_ ), desc( mb_ ),
     &                              myrow, desc( rsrc_ ), nprow ) ) )
      RETURN
      END SUBROUTINE descinit
      SUBROUTINE pxerbla( ICTXT, SRNAME, INFO )
      INTEGER            ICTXT, INFO
      CHARACTER*(*)      SRNAME
      INTEGER            MYCOL, MYROW, NPCOL, NPROW
      EXTERNAL           blacs_gridinfo
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
      WRITE( *, fmt = 9999 ) myrow, mycol, srname, info
 9999 FORMAT( '{', i5, ',', i5, '}:  On entry to ', a,
     &        ' parameter number', i4, ' had an illegal value' )
      END SUBROUTINE pxerbla
#endif
      SUBROUTINE mumps_mem_centralize(MYID, COMM, INFO, INFOG, IRANK)
      IMPLICIT NONE
      INTEGER MYID, COMM, IRANK, INFO, INFOG(2)
      include 'mpif.h'
      INTEGER IERR_MPI, MASTER
#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
      INTEGER(4) :: TEMP1(2),TEMP2(2)
#else
      INTEGER :: TEMP1(2),TEMP2(2)
#endif
      parameter( master = 0 )
      CALL mpi_reduce( info, infog(1), 1, mpi_integer,
     &                 mpi_max, master, comm, ierr_mpi )
      CALL mpi_reduce( info, infog(2), 1, mpi_integer,
     &                 mpi_sum, master, comm, ierr_mpi )
      temp1(1) = info
      temp1(2) = myid
      CALL mpi_reduce( temp1, temp2, 1, mpi_2integer,
     &                 mpi_maxloc, master, comm, ierr_mpi )
      IF ( myid.eq. master ) THEN
         IF ( infog(1) .ne. temp2(1) ) THEN
          write(*,*) 'Error in MUMPS_MEM_CENTRALIZE'
          CALL mumps_abort()
        END IF
        irank    = temp2(2)
      ELSE
        irank    = -1
      END IF
      RETURN
      END SUBROUTINE mumps_mem_centralize
      INTEGER FUNCTION mumps_get_pool_length
     &        (max_active_nodes,keep,keep8)
      IMPLICIT NONE
      INTEGER max_active_nodes
      INTEGER keep(500)
      INTEGER(8) keep8(150)
      mumps_get_pool_length = max_active_nodes + 1 + 3
      RETURN
      END FUNCTION mumps_get_pool_length
      SUBROUTINE mumps_init_pool_dist_bwd(N,
     &           nb_prun_roots, Pruned_Roots,
     &           MYROOT, MYID_NODES,
     &           KEEP, KEEP8, STEP, PROCNODE_STEPS,
     &           IPOOL, LPOOL )
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: N, MYID_NODES, LPOOL, nb_prun_roots
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER, INTENT(IN)  :: STEP(N)
      INTEGER, INTENT(IN)  :: PROCNODE_STEPS(KEEP(28))
      INTEGER, INTENT(IN)  :: Pruned_Roots(nb_prun_roots)
      INTEGER, INTENT(OUT) :: MYROOT
      INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER :: I, INODE
      myroot = 0
      DO i = nb_prun_roots, 1, -1
        inode = pruned_roots(i)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &      keep(199)) .EQ. myid_nodes) THEN
          myroot = myroot + 1
          ipool(myroot) = inode
        ENDIF
      END DO
      RETURN
      END SUBROUTINE mumps_init_pool_dist_bwd
      SUBROUTINE mumps_init_pool_dist_bwd_l0(N,
     &           nb_prun_roots, Pruned_Roots,
     &           MYROOT, MYID_NODES,
     &           KEEP, KEEP8, STEP, PROCNODE_STEPS,
     &           IPOOL, LPOOL, TO_PROCESS )
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: N, MYID_NODES, LPOOL, nb_prun_roots
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER, INTENT(IN)  :: STEP(N)
      INTEGER, INTENT(IN)  :: PROCNODE_STEPS(KEEP(28))
      LOGICAL, INTENT(IN)  :: TO_PROCESS(KEEP(28))
      INTEGER, INTENT(IN)  :: Pruned_Roots(nb_prun_roots)
      INTEGER, INTENT(OUT) :: MYROOT
      INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER :: I, INODE
      MYROOT = 0
      do i = nb_prun_roots, 1, -1
        inode = pruned_roots(i)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &      keep(199)) .EQ. myid_nodes) THEN
          IF ( to_process(step(inode)) ) THEN
            myroot = myroot + 1
            ipool(myroot) = inode
          ENDIF
        ENDIF
      END DO
      RETURN
      END SUBROUTINE mumps_init_pool_dist_bwd_l0
      SUBROUTINE mumps_init_pool_dist_na_bwd(N, MYROOT, MYID_NODES,
     &           NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
     &           IPOOL, LPOOL )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER, INTENT(IN) :: STEP(N)
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA)
      INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
      INTEGER, INTENT(OUT) :: MYROOT
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER :: NBLEAF, NBROOT, I, INODE
      nbleaf = na(1)
      nbroot = na(2)
      myroot = 0
      DO i = nbroot, 1, -1
        inode = na(nbleaf+i+2)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &      keep(199)) .EQ. myid_nodes) THEN
          myroot = myroot + 1
          ipool(myroot) = inode
        ENDIF
      END DO
      RETURN
      END SUBROUTINE mumps_init_pool_dist_na_bwd
      SUBROUTINE mumps_init_pool_dist_na_bwd_l0(N, MYROOT, MYID_NODES,
     &           NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
     &           IPOOL, LPOOL, L0_OMP_MAPPING )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER, INTENT(IN) :: STEP(N)
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA)
      INTEGER, INTENT(IN) :: L0_OMP_MAPPING(KEEP(28))
      INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
      INTEGER, INTENT(OUT) :: MYROOT
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER :: NBLEAF, NBROOT, I, INODE
      nbleaf = na(1)
      nbroot = na(2)
      myroot = 0
      DO i = nbroot, 1, -1
        inode = na(nbleaf+i+2)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &      keep(199)) .EQ. myid_nodes) THEN
          IF ( l0_omp_mapping(step(inode)).EQ.0 ) THEN
            myroot = myroot + 1
            ipool(myroot) = inode
          ENDIF
        ENDIF
      END DO
      RETURN
      END SUBROUTINE mumps_init_pool_dist_na_bwd_l0
      SUBROUTINE mumps_init_pool_dist_na_bwdl0es(N, MYROOT,
     &           MYID_NODES,
     &           NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
     &           IPOOL, LPOOL, L0_OMP_MAPPING, TO_PROCESS )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER, INTENT(IN)  :: STEP(N)
      INTEGER, INTENT(IN)  :: PROCNODE_STEPS(KEEP(28)), NA(LNA)
      INTEGER, INTENT(IN)  :: L0_OMP_MAPPING(KEEP(28))
      INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
      INTEGER, INTENT(OUT) :: MYROOT
      LOGICAL, INTENT(IN)  :: TO_PROCESS( KEEP(28) )
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER :: NBLEAF, NBROOT, I, INODE
      nbleaf = na(1)
      nbroot = na(2)
      myroot = 0
      DO i = nbroot, 1, -1
        inode = na(nbleaf+i+2)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &      keep(199)) .EQ. myid_nodes) THEN
          IF ( l0_omp_mapping(step(inode)).EQ.0 ) THEN
            IF ( to_process( step(inode) ) ) THEN
              myroot = myroot + 1
              ipool(myroot) = inode
            ENDIF
          ENDIF
        ENDIF
      END DO
      RETURN
      END SUBROUTINE mumps_init_pool_dist_na_bwdl0es
      SUBROUTINE mumps_init_pool_dist(N, LEAF,
     &           MYID_NODES,
     &           K199, NA, LNA, KEEP,KEEP8, STEP,
     &           PROCNODE_STEPS, IPOOL, LPOOL)
      IMPLICIT NONE
      INTEGER N, LEAF, MYID_NODES,
     &        k199, lpool, lna
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER STEP(N)
      INTEGER PROCNODE_STEPS(KEEP(28)), NA(LNA),
     &        ipool(lpool)
      INTEGER NBLEAF, INODE, I
      INTEGER MUMPS_PROCNODE
      EXTERNAL MUMPS_PROCNODE
      nbleaf = na(1)
      leaf = 1
      DO i = 1, nbleaf
        inode = na(i+2)
        IF (mumps_procnode(procnode_steps(step(inode)),keep(199))
     &   .EQ.myid_nodes) THEN
           ipool(leaf) = inode
           leaf        = leaf + 1
          ENDIF
      ENDDO
      RETURN
      END SUBROUTINE mumps_init_pool_dist
      SUBROUTINE mumps_init_pool_dist_nona
     &           (n, leaf, myid_nodes,
     &           lleaves, leaves, keep,keep8, step,
     &           procnode_steps, ipool, lpool)
      IMPLICIT NONE
      INTEGER N, LEAF, MYID_NODES,
     &        lpool, lleaves
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER STEP(N)
      INTEGER PROCNODE_STEPS(KEEP(28)), LEAVES(LLEAVES),
     &        ipool(lpool)
      INTEGER I, INODE
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      leaf = 1
      DO i = 1, lleaves
        inode = leaves(i)
        IF ( mumps_procnode(procnode_steps(step(inode)),keep(199))
     &   .EQ.myid_nodes ) THEN
          ipool( leaf ) = inode
          leaf = leaf + 1
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE mumps_init_pool_dist_nona
      SUBROUTINE mumps_init_nroot_dist(N, NBROOT,
     &           NROOT_LOC, MYID_NODES,
     &           SLAVEF, NA, LNA, KEEP, STEP,
     &           PROCNODE_STEPS)
      IMPLICIT NONE
      INTEGER, INTENT( OUT ) :: NROOT_LOC 
      INTEGER, INTENT( OUT ) :: NBROOT 
      INTEGER, INTENT( IN ) :: KEEP( 500 )
      INTEGER, INTENT( IN ) :: SLAVEF
      INTEGER, INTENT( IN ) :: N
      INTEGER, INTENT( IN ) :: STEP(N)
      INTEGER, INTENT( IN ) :: LNA
      INTEGER, INTENT( IN ) :: NA(LNA)
      INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28))
      INTEGER, INTENT( IN ) :: MYID_NODES
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER :: INODE, I, NBLEAF
      nbleaf = na(1)
      nbroot = na(2)
      nroot_loc = 0
      DO i = 1, nbroot
        inode = na(i+2+nbleaf)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &    keep(199)).EQ.myid_nodes) THEN
            nroot_loc = nroot_loc + 1
        END IF
      ENDDO
      RETURN
      END SUBROUTINE mumps_init_nroot_dist
      SUBROUTINE mumps_nblocal_roots_or_leaves
     &           (n, nbrorl, rorl_list,
     &           nrorl_loc, myid_nodes,
     &           slavef, keep, step,
     &           procnode_steps)
      IMPLICIT NONE
      INTEGER, INTENT( OUT ) :: NRORL_LOC 
      INTEGER, INTENT( IN ) :: NBRORL 
      INTEGER, INTENT( IN ) :: RORL_LIST(NBRORL)
      INTEGER, INTENT( IN ) :: KEEP( 500 )
      INTEGER, INTENT( IN ) :: SLAVEF
      INTEGER, INTENT( IN ) :: N
      INTEGER, INTENT( IN ) :: STEP(N)
      INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28))
      INTEGER, INTENT( IN ) :: MYID_NODES
      INTEGER I, INODE
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      nrorl_loc = 0
      DO i = 1, nbrorl
        inode = rorl_list(i)
        IF (mumps_procnode(procnode_steps(step(inode)),
     &    keep(199)).EQ.myid_nodes) THEN
            nrorl_loc = nrorl_loc + 1
        END IF
      ENDDO
      RETURN
      END SUBROUTINE mumps_nblocal_roots_or_leaves
      LOGICAL FUNCTION mumps_compare_tab(TAB1,TAB2,LEN1,LEN2)
      IMPLICIT NONE
      INTEGER len1 , len2 ,i
      INTEGER tab1(len1)
      INTEGER tab2(len2)
      mumps_compare_tab=.false.
      IF(len1 .NE. len2) THEN
         RETURN
      ENDIF
      DO i=1 , len1
         IF(tab1(i) .NE. tab2(i)) THEN
            RETURN
         ENDIF
      ENDDO
      mumps_compare_tab=.true.
      RETURN
      END FUNCTION mumps_compare_tab
      SUBROUTINE mumps_sort_int( N, VAL, ID )
      INTEGER N
      INTEGER ID( N )
      INTEGER VAL( N )
      INTEGER I, ISWAP
      INTEGER SWAP
      LOGICAL DONE
      done = .false.
      DO WHILE ( .NOT. done )
        done = .true.
        DO i = 1, n - 1
           IF ( val( i ) .GT. val( i + 1 ) ) THEN
              done = .false.
              iswap = id( i )
              id( i ) = id( i + 1 )
              id( i + 1 ) = iswap
              swap = val( i )
              val( i ) = val( i + 1 )
              val( i + 1 ) = swap
           END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE mumps_sort_int
      SUBROUTINE mumps_sort_int_dec( N, VAL, ID )
      INTEGER N
      INTEGER ID( N )
      INTEGER VAL( N )
      INTEGER I, ISWAP
      INTEGER SWAP
      LOGICAL DONE
      done = .false.
      DO WHILE ( .NOT. done )
        done = .true.
        DO i = 1, n - 1
           IF ( val( i ) .LT. val( i + 1 ) ) THEN
              done = .false.
              iswap = id( i )
              id( i ) = id( i + 1 )
              id( i + 1 ) = iswap
              swap = val( i )
              val( i ) = val( i + 1 )
              val( i + 1 ) = swap
           END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE mumps_sort_int_dec
      SUBROUTINE mumps_sort_int8( N, VAL, ID )
      INTEGER N
      INTEGER ID( N )
      INTEGER(8) :: VAL( N )
      INTEGER I, ISWAP
      INTEGER(8) SWAP
      LOGICAL DONE
      done = .false.
      DO WHILE ( .NOT. done )
        done = .true.
        DO i = 1, n - 1
           IF ( val( i ) .GT. val( i + 1 ) ) THEN
              done = .false.
              iswap = id( i )
              id( i ) = id( i + 1 )
              id( i + 1 ) = iswap
              swap = val( i )
              val( i ) = val( i + 1 )
              val( i + 1 ) = swap
           END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE mumps_sort_int8
      SUBROUTINE mumps_abort()
#if defined(PRINT_BACKTRACE_ON_ABORT) 
#if defined(__INTEL_COMPILER)
      USE ifcore
#endif
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR, IERRCODE
#if defined(__GFORTRAN__)
      CALL backtrace()
#endif
#if defined(__INTEL_COMPILER)
!$OMP CRITICAL(MUMPS_TRACEBACKQQ)
      CALL tracebackqq("MUMPS_ABORT calls TRACEBACKQQ:",
     &                 user_exit_code=-1)
!$OMP END CRITICAL(MUMPS_TRACEBACKQQ)
#endif
#else
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR, IERRCODE
#endif
      ierrcode = -99
      CALL mpi_abort(mpi_comm_world, ierrcode, ierr)
      RETURN
      END SUBROUTINE mumps_abort
      SUBROUTINE mumps_get_perlu(KEEP12,ICNTL14,
     &     KEEP50,KEEP54,ICNTL6,ICNTL8)
      IMPLICIT NONE
      INTEGER, intent(out)::KEEP12
      INTEGER, intent(in)::ICNTL14,KEEP50,KEEP54,ICNTL6,ICNTL8
      KEEP12 = icntl14 
      RETURN
      END SUBROUTINE mumps_get_perlu
      SUBROUTINE mumps_reducei8( IN, OUT, MPI_OP, ROOT, COMM)
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER ROOT, COMM, MPI_OP
      INTEGER(8) IN, OUT
      INTEGER IERR
      DOUBLE PRECISION DIN, DOUT
      DIN =dble(in)
      dout=0.0d0
      CALL mpi_reduce(din, dout, 1, mpi_double_precision,
     &                   mpi_op, root, comm, ierr)
      out=int(dout,kind=8)
      RETURN
      END SUBROUTINE mumps_reducei8
      SUBROUTINE mumps_allreducei8( IN, OUT, MPI_OP, COMM)
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, MPI_OP
      INTEGER(8) IN, OUT
      INTEGER IERR
      DOUBLE PRECISION DIN, DOUT
      din =dble(in)
      dout=0.0d0
      CALL mpi_allreduce(din, dout, 1, mpi_double_precision,
     &                   mpi_op, comm, ierr)
      out=int(dout,kind=8)
      RETURN
      END SUBROUTINE mumps_allreducei8
      SUBROUTINE mumps_seti8toi4(I8, I)
      IMPLICIT NONE
      INTEGER   , INTENT(OUT) :: I
      INTEGER(8), INTENT(IN)  :: I8
      IF ( i8 .GT. int(huge(i),8) ) THEN
        i = -int(i8/1000000_8,kind(i))
      ELSE
        i = int(i8,kind(i))
      ENDIF
      RETURN
      END SUBROUTINE mumps_seti8toi4
      SUBROUTINE mumps_abort_on_overflow(I8, STRING)
      IMPLICIT NONE
      INTEGER(8), INTENT(IN) :: I8
      CHARACTER(*), INTENT(IN) :: STRING
      INTEGER I
      IF ( i8 .GT. int(huge(i),8)) THEN
        WRITE(*,*) string
        CALL mumps_abort()
      ENDIF
      RETURN
      END SUBROUTINE mumps_abort_on_overflow
      SUBROUTINE mumps_set_ierror( SIZE8, IERROR  )
      INTEGER(8), INTENT(IN) :: SIZE8
      INTEGER, INTENT(OUT) :: IERROR
      CALL MUMPS_SETI8TOI4(SIZE8, IERROR)
      RETURN
      END SUBROUTINE mumps_set_ierror
      SUBROUTINE mumps_storei8(I8, INT_ARRAY)
      IMPLICIT NONE
      INTEGER(8), intent(in)  :: I8
      INTEGER,    intent(out) :: INT_ARRAY(2)
      INTEGER(kind(0_4)) :: I32
      INTEGER(8) :: IDIV, IPAR
      parameter(ipar=int(huge(i32),8))
      parameter(idiv=ipar+1_8)
      IF ( i8 .LT. idiv ) THEN
        int_array(1) = 0
        int_array(2) = int(i8)
      ELSE
        int_array(1) = int(i8 / idiv)
        int_array(2) = int(mod(i8,idiv))
      ENDIF
      RETURN
      END SUBROUTINE mumps_storei8
      SUBROUTINE mumps_geti8(I8, INT_ARRAY)
      IMPLICIT NONE
      INTEGER(8), intent(out)  :: I8
      INTEGER,    intent(in)  :: INT_ARRAY(2)
      INTEGER(kind(0_4)) :: I32
      INTEGER(8) :: IDIV, IPAR
      parameter(ipar=int(huge(i32),8))
      parameter(idiv=ipar+1_8)
      IF ( int_array(1) .EQ. 0 ) THEN
        i8=int(int_array(2),8)
      ELSE
        i8=int(int_array(1),8)*idiv+int(int_array(2),8)
      ENDIF
      RETURN
      END SUBROUTINE mumps_geti8
      SUBROUTINE mumps_addi8toarray( INT_ARRAY, I8 )
      IMPLICIT NONE
      INTEGER(8), intent(in) :: I8
      INTEGER, intent(inout) :: INT_ARRAY(2)
      INTEGER(8) :: I8TMP
      CALL mumps_geti8(i8tmp, int_array)
      i8tmp = i8tmp + i8
      CALL mumps_storei8(i8tmp, int_array)
      RETURN
      END SUBROUTINE mumps_addi8toarray
      SUBROUTINE mumps_subtri8toarray( INT_ARRAY, I8 )
      IMPLICIT NONE
      INTEGER(8), intent(in) :: I8
      INTEGER, intent(inout) :: INT_ARRAY(2)
      INTEGER(8) :: I8TMP
      CALL mumps_geti8(i8tmp, int_array)
      i8tmp = i8tmp - i8
      CALL mumps_storei8(i8tmp, int_array)
      RETURN
      END SUBROUTINE mumps_subtri8toarray
      FUNCTION mumps_seqana_avail(ICNTL7)
      LOGICAL :: mumps_seqana_avail
      INTEGER, INTENT(IN) :: icntl7
      LOGICAL :: scotch=.false.
      LOGICAL :: metis =.false.
#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
      metis = .true.
#endif
#if defined(scotch) || defined(ptscotch)
      scotch = .true.
#endif
      IF ( icntl7 .LT. 0 .OR. icntl7 .GT. 7 ) THEN
        mumps_seqana_avail = .false.
      ELSE
        mumps_seqana_avail = .true.
      ENDIF
      IF ( icntl7 .EQ. 5 ) mumps_seqana_avail = metis
      IF ( icntl7 .EQ. 3 ) mumps_seqana_avail = scotch
      RETURN
      END FUNCTION mumps_seqana_avail
      FUNCTION mumps_parana_avail(WHICH)
      LOGICAL :: mumps_parana_avail
      CHARACTER :: which*(*)
      LOGICAL :: ptscotch=.false., parmetis=.false.
#if defined(ptscotch)
      ptscotch = .true.
#endif
#if defined(parmetis) || defined(parmetis3)
      parmetis = .true.
#endif
      SELECT CASE(which)
      CASE('ptscotch','PTSCOTCH')
         mumps_parana_avail = ptscotch
      CASE('parmetis','PARMETIS')
         mumps_parana_avail = parmetis
      CASE('both','BOTH')
         mumps_parana_avail = ptscotch .AND. parmetis
      CASE('any','ANY')
         mumps_parana_avail = ptscotch .OR. parmetis
      CASE default
         write(*,'("Invalid input in MUMPS_PARANA_AVAIL")')
      END SELECT
      RETURN
      END FUNCTION mumps_parana_avail
      SUBROUTINE mumps_sort_step(N,FRERE,STEP,FILS,
     &     NA,LNA,NE,ND,DAD,LDAD,USE_DAD,
     &     NSTEPS,INFO,LP,
     &     PROCNODE,SLAVEF
     &     )
      IMPLICIT NONE
      INTEGER N, NSTEPS, LNA, LP,LDAD
      INTEGER FRERE(NSTEPS), FILS(N), STEP(N)
      INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS)
      INTEGER DAD(LDAD)
      LOGICAL USE_DAD
      INTEGER INFO(80)
      INTEGER SLAVEF,PROCNODE(NSTEPS)
      INTEGER  POSTORDER,TMP_SWAP
      INTEGER, DIMENSION (:), ALLOCATABLE :: STEP_TO_NODE
      INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK
      INTEGER I,II,allocok
      INTEGER NBLEAF,NBROOT,LEAF,IN,INODE,IFATH
      EXTERNAL MUMPS_TYPENODE
      INTEGER MUMPS_TYPENODE
      postorder=1
      nbleaf = na(1)
      nbroot = na(2)
      ALLOCATE( ipool(nbleaf), tnstk(nsteps), stat=allocok )
      IF (allocok > 0) THEN
        IF ( lp .GT. 0 )
     &    WRITE(lp,*)'Memory allocation error in MUMPS_SORT_STEP'
        info(1)=-7
        info(2)=nsteps
        RETURN
      ENDIF
      DO i=1,nsteps
         tnstk(i) = ne(i)
      ENDDO
      ALLOCATE(step_to_node(nsteps),stat=allocok)
      IF (allocok > 0) THEN
         IF ( lp .GT. 0 )
     &        WRITE(lp,*)'Memory allocation error in
     &MUMPS_SORT_STEP'
         info(1)=-7
         info(2)=nsteps
         RETURN
      ENDIF
      DO i=1,n
         IF(step(i).GT.0)THEN
            step_to_node(step(i))=i
         ENDIF
      ENDDO
      ipool(1:nbleaf)=na(3:2+nbleaf)
      leaf = nbleaf + 1
 91   CONTINUE
      IF (leaf.NE.1) THEN
         leaf = leaf -1
         inode = ipool(leaf)
      ENDIF
 96   CONTINUE
      IF (use_dad) THEN
         ifath = dad( step(inode) )
      ELSE
         in = inode
 113     in = frere(in)
         IF (in.GT.0) GO TO 113
         ifath = -in
      ENDIF
      tmp_swap=frere(step(inode))
      frere(step(inode))=frere(postorder)
      frere(postorder)=tmp_swap
      tmp_swap=nd(step(inode))
      nd(step(inode))=nd(postorder)
      nd(postorder)=tmp_swap
      tmp_swap=ne(step(inode))
      ne(step(inode))=ne(postorder)
      ne(postorder)=tmp_swap
      tmp_swap=procnode(step(inode))
      procnode(step(inode))=procnode(postorder)
      procnode(postorder)=tmp_swap
      IF(use_dad)THEN
         tmp_swap=dad(step(inode))
         dad(step(inode))=dad(postorder)
         dad(postorder)=tmp_swap
      ENDIF
      tmp_swap=tnstk(step(inode))
      tnstk(step(inode))=tnstk(postorder)
      tnstk(postorder)=tmp_swap
      ii=step_to_node(postorder)
      tmp_swap=step(inode)
      step(step_to_node(postorder))=tmp_swap
      step(inode)=postorder
      step_to_node(postorder)=inode
      step_to_node(tmp_swap)=ii
      in=ii
 101  in = fils(in)
      IF (in .GT. 0 ) THEN
         step(in)=-step(ii)
         GOTO 101
      ENDIF
      in=inode
 102  in = fils(in)
      IF (in .GT. 0 ) THEN
         step(in)=-step(inode)
         GOTO 102
      ENDIF
      postorder = postorder + 1
      IF (ifath.EQ.0) THEN
         nbroot = nbroot - 1
         IF (nbroot.EQ.0) GOTO 116
         GOTO 91
      ENDIF
      tnstk(step(ifath)) = tnstk(step(ifath)) - 1
      IF ( tnstk(step(ifath)) .EQ. 0 ) THEN      
         inode = ifath
         GOTO 96
      ELSE
         GOTO 91
      ENDIF
 116  CONTINUE
      DEALLOCATE(step_to_node)
      DEALLOCATE(ipool,tnstk)
      RETURN
      END SUBROUTINE mumps_sort_step
      SUBROUTINE mumps_check_comm_nodes(COMM_NODES, EXIT_FLAG)
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: COMM_NODES
      LOGICAL, INTENT(OUT) :: EXIT_FLAG
      include 'mumps_tags.h'
      include 'mpif.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE), IERR
      CALL mpi_iprobe( mpi_any_source, terreur, comm_nodes,
     &            exit_flag, status, ierr)
      RETURN
      END SUBROUTINE mumps_check_comm_nodes
      SUBROUTINE mumps_get_proc_per_node(K414, MyID, NbProcs, COMM)
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER :: K414, MyID, NbProcs, COMM, ALLOCOK
      INTEGER :: ierr,MyNAME_length,MyNAME_length_RCV,i,j
      CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MyNAME
      CHARACTER, dimension(:), allocatable :: MyNAME_TAB,MyNAME_TAB_RCV
      logical :: SAME_NAME
      call mpi_get_processor_name(myname, myname_length, ierr)
      allocate(myname_tab(myname_length), stat=allocok)
      IF(allocok.LT.0) THEN
         write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE"
         call mumps_abort()
      ENDIF
      DO i=1, myname_length
         myname_tab(i) = myname(i:i)
      ENDDO
      k414=0
      do i=0, nbprocs-1
         if(myid .eq. i) then
            myname_length_rcv  = myname_length
         else
            myname_length_rcv = 0
         endif
         call mpi_bcast(myname_length_rcv,1,mpi_integer,
     &        i,comm,ierr)
         allocate(myname_tab_rcv(myname_length_rcv), stat=allocok)
         IF(allocok.LT.0) THEN
            write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE"
            call mumps_abort()
         ENDIF
         if(myid .eq. i) then
            myname_tab_rcv = myname_tab
         endif
         call mpi_bcast(myname_tab_rcv,myname_length_rcv,mpi_character,
     &        i,comm,ierr)
         same_name=.false.
         IF(myname_length .EQ. myname_length_rcv) THEN
            DO j=1, myname_length
               IF(myname_tab(j) .NE. myname_tab_rcv(j)) THEN
                  goto 100
               ENDIF
            ENDDO
            same_name=.true.
         ENDIF
 100     continue
         IF(same_name) k414=k414+1
         deallocate(myname_tab_rcv)
      enddo
      deallocate(myname_tab)
      END SUBROUTINE mumps_get_proc_per_node
      SUBROUTINE mumps_icopy_32to64 (INTAB, SIZETAB, OUTTAB8)
      INTEGER, intent(in)     ::  SIZETAB
      INTEGER, intent(in)     ::  INTAB(SIZETAB)
      INTEGER(8), intent(out) ::  OUTTAB8(SIZETAB)
      INTEGER :: I
      DO i=1,sizetab
       outtab8(i) = int(intab(i),8)
      ENDDO
      RETURN
      END SUBROUTINE mumps_icopy_32to64
      SUBROUTINE mumps_icopy_32to64_64c(INTAB, SIZETAB8, OUTTAB8)
      INTEGER(8), intent(in)  ::  SIZETAB8
      INTEGER, intent(in)     ::  INTAB(SIZETAB8)
      INTEGER(8), intent(out) ::  OUTTAB8(SIZETAB8)
      INTEGER(8) :: I8
      LOGICAL    :: OMP_FLAG
      omp_flag = (sizetab8 .GE.500000_8 )
!$OMP PARALLEL DO PRIVATE(I8)
!$OMP&         IF(OMP_FLAG)
      DO i8=1_8, sizetab8
        outtab8(i8) = int(intab(i8),8)
      ENDDO
!$OMP END PARALLEL DO
      RETURN
      END SUBROUTINE mumps_icopy_32to64_64c
      SUBROUTINE mumps_icopy_32to64_64c_ip(IN_OUT_TAB48, SIZETAB)
      INTEGER(8), intent(in) :: SIZETAB
      INTEGER, intent(inout) :: IN_OUT_TAB48(2*SIZETAB)
      CALL mumps_icopy_32to64_64c_ip_rec(in_out_tab48, sizetab)
      RETURN
      END SUBROUTINE mumps_icopy_32to64_64c_ip
      RECURSIVE SUBROUTINE mumps_icopy_32to64_64c_ip_rec(
     &                     IN_OUT_TAB48, SIZETAB)
      IMPLICIT NONE
      INTEGER(8), intent(in) :: sizetab
      INTEGER :: in_out_tab48(2*sizetab)
      INTEGER(8) :: ibeg24, ibeg28, size1, size2
      IF (sizetab.LE. 1000_8) THEN
        CALL mumps_icopy_32to64_64c_ip_c(in_out_tab48(1),
     &       sizetab)
      ELSE
        size2  = sizetab / 2
        size1  = sizetab - size2
        ibeg24 = size1+1                 
        ibeg28 = 2*size1+1_8             
        CALL mumps_icopy_32to64_64c(in_out_tab48(ibeg24),
     &                           size2, in_out_tab48(ibeg28))
        CALL mumps_icopy_32to64_64c_ip_rec(in_out_tab48,
     &                           size1)
      ENDIF
      RETURN
      END SUBROUTINE mumps_icopy_32to64_64c_ip_rec
      SUBROUTINE mumps_icopy_64to32(INTAB8, SIZETAB, OUTTAB)
      INTEGER, intent(in) ::  SIZETAB
      INTEGER(8), intent(in) ::  INTAB8(SIZETAB)
      INTEGER, intent(out)   ::  OUTTAB(SIZETAB)
      INTEGER :: I
      DO i=1,sizetab
       outtab(i) = int(intab8(i))
      ENDDO
      RETURN
      END SUBROUTINE mumps_icopy_64to32
      SUBROUTINE mumps_icopy_64to32_64c (INTAB8, SIZETAB, OUTTAB)
      INTEGER(8), intent(in)    ::  SIZETAB
      INTEGER(8), intent(in) ::  INTAB8(SIZETAB)
      INTEGER, intent(out)   ::  OUTTAB(SIZETAB)
      INTEGER(8) :: I8
      DO i8=1_8,sizetab
       outtab(i8) = int(intab8(i8))
      ENDDO
      RETURN
      END SUBROUTINE mumps_icopy_64to32_64c
      SUBROUTINE mumps_icopy_64to32_64c_ip(IN_OUT_TAB48, SIZETAB)
      INTEGER(8), intent(in) :: SIZETAB
      INTEGER, intent(inout) :: IN_OUT_TAB48(2*SIZETAB)
      CALL mumps_icopy_64to32_64c_ip_rec(in_out_tab48, sizetab)
      RETURN
      END SUBROUTINE mumps_icopy_64to32_64c_ip
      RECURSIVE SUBROUTINE mumps_icopy_64to32_64c_ip_rec(
     &                     IN_OUT_TAB48, SIZETAB)
      IMPLICIT NONE
      INTEGER(8), intent(in) :: sizetab
      INTEGER :: in_out_tab48(2*sizetab)
      INTEGER(8) :: ibeg24, ibeg28, size1, size2
      IF (sizetab.LE. 1000_8) THEN
        CALL mumps_icopy_64to32_64c_ip_c(in_out_tab48(1),
     &       sizetab)
      ELSE
        size2  = sizetab / 2
        size1  = sizetab - size2
        ibeg24 = size1 + 1
        ibeg28 = size1 + size1 + 1_8
        CALL mumps_icopy_64to32_64c_ip_rec(in_out_tab48,
     &                                        size1)
        CALL mumps_icopy_64to32_64c(in_out_tab48(ibeg28),
     &                           size2, in_out_tab48(ibeg24))
      ENDIF
      RETURN
      END SUBROUTINE mumps_icopy_64to32_64c_ip_rec
      SUBROUTINE mumps_get_nnz_internal( NNZ, NZ, NNZ_i )
      INTEGER   , INTENT(IN)  :: NZ
      INTEGER(8), INTENT(IN)  :: NNZ
      INTEGER(8), INTENT(OUT) :: NNZ_i
      IF (nnz > 0_8) THEN
        nnz_i = nnz
      ELSE
        nnz_i = int(nz, 8)
      ENDIF
      END SUBROUTINE mumps_get_nnz_internal
      SUBROUTINE mumps_npiv_critical_path(
     &     N, NSTEPS, STEP, FRERE, FILS,
     &     NA, LNA, NE, MAXNPIVTREE )
      IMPLICIT NONE
      INTEGER, intent(in) :: N, NSTEPS, LNA
      INTEGER, intent(in) :: FRERE(NSTEPS), FILS(N), STEP(N)
      INTEGER, intent(in) :: NA(LNA), NE(NSTEPS)
      INTEGER, intent(out) :: MAXNPIVTREE
      INTEGER :: IFATH,INODE,ISON
      INTEGER :: NPIV,ILEAF,NBLEAF,NBROOT
      INTEGER, DIMENSION(:) , ALLOCATABLE :: MAXNPIV
      INTEGER :: I, allocok
      maxnpivtree = -9999
      ALLOCATE ( maxnpiv(nsteps), stat=allocok)
      IF (allocok .gt.0) THEN
         WRITE(*, *) 'Allocation error in MUMPS_NPIV_CRITICAL_PATH' 
     &           ,nsteps
         CALL mumps_abort()
      ENDIF
      nbleaf = na(1)      
      nbroot = na(2)
      maxnpiv = 0
      nbleaf = na(1)
      nbroot = na(2)
      DO ileaf = 1, nbleaf
        inode = na(2+ileaf)
 95     CONTINUE
        npiv = 0
        ison = inode
 100    npiv = npiv + 1
        ison = fils(ison)
        IF (ison .GT. 0 ) GOTO 100
        ison = -ison
        maxnpiv( step(inode) ) = npiv
        DO i = 1, ne(step(inode))
          maxnpiv(step(inode)) = max( maxnpiv(step(inode)),
     &                                npiv + maxnpiv(step(ison)) )
          ison     = frere(step(ison))
        ENDDO
        ifath = inode
        DO WHILE (ifath .GT. 0)
          ifath = frere(step(ifath))
        ENDDO
        ifath = -ifath
        IF (ifath.EQ.0) THEN 
          maxnpivtree = max(maxnpivtree, maxnpiv(step(inode)))
        ELSE 
          IF (frere(step(inode)) .LT. 0) THEN
            inode = ifath
            GOTO 95
          ENDIF
        ENDIF
      ENDDO
      DEALLOCATE( maxnpiv )
      RETURN
      END SUBROUTINE mumps_npiv_critical_path
      SUBROUTINE mumps_ldltpanel_nbtarget( NPIV, NB_TARGET, KEEP )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NPIV
      INTEGER, INTENT(IN) :: KEEP(500)
      INTEGER, INTENT(OUT) :: NB_TARGET
      INTEGER :: NBPANELS, NBCOLMIN, NBPANELSMAX
      IF (npiv .EQ. 0) THEN
        nb_target = 0
      ELSE
        nbcolmin    = keep(460)
        nbpanelsmax = keep(459)
        nbpanels = min( (npiv+nbcolmin-1) / nbcolmin, nbpanelsmax  )
        nb_target = ( npiv+nbpanels-1 ) / nbpanels
      ENDIF
      RETURN
      END SUBROUTINE mumps_ldltpanel_nbtarget
      SUBROUTINE mumps_ldltpanel_storage
     &           ( npiv, keep, iw, nb_entries )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NPIV 
      INTEGER, INTENT(IN) :: KEEP(500), IW(*) 
      INTEGER(8), INTENT(OUT) :: NB_ENTRIES 
      INTEGER :: NB_TARGET, NBCOLS_PANEL, NBROWS_PANEL
      INTEGER :: ICOL_BEG, ICOL_END, NBPANELS
      CALL mumps_ldltpanel_nbtarget( npiv, nb_target, keep )
      nb_entries = 0_8
      nbrows_panel = npiv
      icol_beg = 1
      nbpanels = 0
      DO WHILE ( icol_beg .LE. npiv )
        nbpanels = nbpanels + 1
        icol_end = min(nb_target * nbpanels, npiv)
        IF (iw(1) .NE. 0) THEN
          IF ( iw( icol_end ) < 0 ) THEN 
            icol_end = icol_end + 1
          ENDIF
        ENDIF
        nbcols_panel = icol_end - icol_beg + 1
        nb_entries = nb_entries + int(nbcols_panel,8) *
     &                            int(nbrows_panel,8)
        nbrows_panel = nbrows_panel - nbcols_panel
        icol_beg = icol_end + 1
      ENDDO
      RETURN
      END SUBROUTINE mumps_ldltpanel_storage
      SUBROUTINE mumps_ldltpanel_panelinfos( NPIV, KEEP, IW,
     &       NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE,
     &       IGNORE_K459 )
      IMPLICIT NONE
      INTEGER,    INTENT(IN)  :: NPIV
      INTEGER,    INTENT(IN)  :: IW( NPIV )
      INTEGER,    INTENT(IN)  :: KEEP(500)
      INTEGER,    INTENT(IN)  :: PANEL_TABSIZE
      INTEGER,    INTENT(OUT) :: NB_TARGET, NBPANELS
      INTEGER,    INTENT(OUT) :: PANEL_COL( PANEL_TABSIZE )
      INTEGER(8), INTENT(OUT) :: PANEL_POS( PANEL_TABSIZE )
      LOGICAL,    INTENT(IN)  :: IGNORE_K459
      INTEGER :: IPANEL, ICOL_END, NBROWS_PANEL, NBCOLS_PANEL
      IF ( ignore_k459 ) THEN
        nb_target = npiv
      ELSE
        CALL mumps_ldltpanel_nbtarget( npiv, nb_target, keep )
      ENDIF
      panel_pos(1) = 1_8
      panel_col(1) = 1
      nbrows_panel = npiv
      nbpanels     = 1
      IF ( keep(459) .GT. 1 .AND. keep(50) .NE. 0 .AND.
     &   nb_target.NE.npiv ) THEN
        nbpanels = ( npiv + nb_target -1 ) / nb_target
        IF ( panel_tabsize .LT. nbpanels + 1 ) THEN
          WRITE(*,*) " Internal error in MUMPS_LDLTPANEL_PANELINFOS",
     &    panel_tabsize, nbpanels
          CALL mumps_abort()
        ENDIF
        DO ipanel=1, nbpanels
          icol_end = min(ipanel*nb_target, npiv)
          IF ( iw(icol_end) .LT. 0 ) THEN
            icol_end = icol_end + 1
          ENDIF
          nbcols_panel = icol_end - panel_col(ipanel) + 1
          panel_pos(ipanel+1) = panel_pos(ipanel) + 
     &    int(nbrows_panel,8)*int(nbcols_panel,8)
          panel_col(ipanel+1) = panel_col(ipanel) + nbcols_panel
          nbrows_panel = nbrows_panel - nbcols_panel
        ENDDO
      ELSE
          panel_pos(2)  = int(npiv,8)*int(npiv,8)+1_8
          panel_col(2) = npiv+1
      ENDIF
      END SUBROUTINE mumps_ldltpanel_panelinfos
      SUBROUTINE mumps_ldltpanel_sizes
     &           ( npiv, keep, iw, panel_sizes, nbpanels )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NPIV 
      INTEGER, INTENT(IN) :: KEEP(500), IW(NPIV) 
      INTEGER(8), INTENT(OUT) :: PANEL_SIZES( KEEP(459) ) 
      INTEGER, INTENT(OUT) :: NBPANELS
      INTEGER :: NB_TARGET
      INTEGER :: ICOL_BEG, ICOL_END
      nbpanels = 0
      CALL mumps_ldltpanel_nbtarget( npiv, nb_target, keep )
      icol_beg = 1
      nbpanels = 0
      DO WHILE ( icol_beg .LE. npiv )
        nbpanels = nbpanels + 1
        icol_end = min(nb_target * nbpanels, npiv)
        IF ( iw( icol_end ) < 0 ) THEN 
          icol_end = icol_end + 1
        ENDIF
        panel_sizes(nbpanels) = icol_end-icol_beg+1
        icol_beg = icol_end + 1
      ENDDO
      panel_sizes(nbpanels+1:keep(459))=0
      RETURN
      END SUBROUTINE mumps_ldltpanel_sizes
      SUBROUTINE mumps_build_arch_node_comm
     &           ( comm, newcomm, newsize, newrank )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER, INTENT(IN)  :: COMM
      INTEGER, INTENT(OUT) :: NEWCOMM, NEWSIZE, NEWRANK
      INTEGER :: SMALLEST_ID_ON_SAME_NODE, IPROC, MYID, IERR, NPROCS
      INTEGER :: TMPNAME_LENGTH, MYNAME_LENGTH
      CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MYNAME, TMPNAME
      smallest_id_on_same_node = -1
      CALL mpi_comm_rank( comm, myid, ierr )
      CALL mpi_comm_size( comm, nprocs, ierr )
      CALL mpi_get_processor_name(myname, myname_length, ierr )
      DO iproc = 0, nprocs - 1
        IF (myid .EQ. iproc) THEN
          tmpname = myname
          tmpname_length = myname_length
        ENDIF
        CALL mpi_bcast( tmpname_length, 1, mpi_integer,
     &                  iproc, comm, ierr )
        CALL mpi_bcast( tmpname, tmpname_length, mpi_character,
     &                  iproc, comm, ierr)
        IF (smallest_id_on_same_node .LT. 0) THEN
         IF ( tmpname_length .EQ. myname_length ) THEN
          IF ( tmpname(1:tmpname_length) .EQ. myname(1:myname_length) )
     &    THEN
            smallest_id_on_same_node = iproc
          ENDIF
         ENDIF
        ENDIF
      ENDDO
      CALL mpi_comm_split( comm, smallest_id_on_same_node, 0,
     &                     newcomm, ierr )
      CALL mpi_comm_rank( newcomm, newrank, ierr )
      CALL mpi_comm_size( newcomm, newsize, ierr )
      RETURN
      END SUBROUTINE mumps_build_arch_node_comm
      SUBROUTINE mumps_destroy_arch_node_comm( ARCH_NODE_COMM )
      IMPLICIT NONE
      INTEGER :: ARCH_NODE_COMM, IERR
      INCLUDE 'mpif.h'
      CALL mpi_comm_free( arch_node_comm, ierr )
      RETURN
      END SUBROUTINE mumps_destroy_arch_node_comm
      SUBROUTINE  mumps_dm_fac_upd_dyn_memcnts
     &                    ( mem_count_allocated, atomic_updates, keep8,
     &                      iflag, ierror, k69upd, k71upd )
      IMPLICIT NONE
      INTEGER(8), INTENT(IN)        :: MEM_COUNT_ALLOCATED
      INTEGER(8), INTENT(INOUT)     :: KEEP8(150)
      LOGICAL, INTENT(IN)           :: ATOMIC_UPDATES
      INTEGER, INTENT(INOUT)        :: IFLAG, IERROR
      LOGICAL, INTENT(IN) :: K69UPD
      LOGICAL, INTENT(IN) :: K71UPD
      INTEGER(8) :: KEEP8TMPCOPY
      IF (mem_count_allocated.GT.0) THEN
           IF (atomic_updates ) THEN
!$OMP        ATOMIC CAPTURE
             keep8(73) = keep8(73) + mem_count_allocated
             keep8tmpcopy = keep8(73)
!$OMP        END ATOMIC
!$OMP        ATOMIC UPDATE
             keep8(74) = max(keep8(74), keep8tmpcopy)
!$OMP        END ATOMIC
           ELSE
             keep8(73) = keep8(73) + mem_count_allocated
             keep8tmpcopy = keep8(73)
             keep8(74) = max(keep8(74), keep8(73))
           ENDIF
           IF ( keep8tmpcopy .GT. keep8(75) ) THEN
             iflag = -19
             CALL mumps_set_ierror(
     &            (keep8tmpcopy-keep8(75)), ierror)
           ENDIF
           IF ( k69upd ) THEN
             IF ( atomic_updates ) THEN
!$OMP          ATOMIC CAPTURE
               keep8(69) = keep8(69) + mem_count_allocated
               keep8tmpcopy = keep8(69)
!$OMP          END ATOMIC
!$OMP          ATOMIC UPDATE
               keep8(68) = max(keep8(68), keep8tmpcopy)
!$OMP          END ATOMIC
             ELSE
               keep8(69) = keep8(69) + mem_count_allocated
               keep8(68) = max(keep8(69), keep8(68))
             ENDIF
           ENDIF
           IF ( k71upd ) THEN
             IF ( atomic_updates ) THEN
!$OMP          ATOMIC CAPTURE
               keep8(71) = keep8(71) + mem_count_allocated
               keep8tmpcopy = keep8(71)
!$OMP          END ATOMIC
!$OMP          ATOMIC UPDATE
               keep8(70) = max(keep8(70), keep8tmpcopy)
!$OMP          END ATOMIC
             ELSE
               keep8(71) = keep8(71) + mem_count_allocated
               keep8(70) = max(keep8(71), keep8(70))
             ENDIF
           ENDIF
      ELSE
           IF (atomic_updates) THEN
!$OMP ATOMIC UPDATE
             keep8(73) = keep8(73) + mem_count_allocated
!$OMP END ATOMIC
             IF ( k69upd ) THEN
!$OMP ATOMIC UPDATE
               keep8(69) = keep8(69) + mem_count_allocated
!$OMP END ATOMIC
             ENDIF
             IF ( k71upd ) THEN
!$OMP ATOMIC UPDATE
               keep8(71) = keep8(71) + mem_count_allocated
!$OMP END ATOMIC
             ENDIF
           ELSE
             keep8(73) = keep8(73) + mem_count_allocated
             IF ( k69upd ) THEN
               keep8(69) = keep8(69) + mem_count_allocated
             ENDIF
             IF ( k71upd ) THEN
               keep8(71) = keep8(71) + mem_count_allocated
             ENDIF
           ENDIF
      ENDIF
      RETURN
      END SUBROUTINE mumps_dm_fac_upd_dyn_memcnts
      SUBROUTINE mumps_set_parti_regular(
     &     SLAVEF,
     &     KEEP,KEEP8,
     &     PROCS,
     &     MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE,
     &     TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE,
     &     TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX
     &     )
      IMPLICIT NONE
      INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST
      INTEGER(8) KEEP8(150)
      INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID
      INTEGER, intent(in) :: PROCS(SLAVEF+1)
      INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1)
      INTEGER, intent(in) :: SUP_PROC_ARG(2)
      INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE
      INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST)
      INTEGER, intent(out):: TAB_POS(SLAVEF+2)
      INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX
      INTEGER(8), intent(out):: MAX_SURF
      LOGICAL :: FORCE_LDLTRegular_NIV2
      INTEGER NSLAVES,ACC
      INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1))
      INTEGER TMP_NROW,X,K
      LOGICAL SUP,MEM_CSTR
      DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA,
     &     load_corr
      INTEGER IDWLOAD(SLAVEF)
      INTEGER(8) MEM_CONSTRAINT(2)
      k50=keep(50)
      force_ldltregular_niv2 = .false.
      max_surf=0
      nb_row_max=0
      nelim=nfront-ncb
      nb_sup=0
      total_load=0.0d0
      sup=.false.
      IF(sup_proc_arg(1).NE.
     &     0)THEN
         mem_constraint(1)=tab_maxs_arg(procs(1))
         total_load=total_load+dble(sup_proc_arg(1))/100.0d0
         nb_sup=nb_sup+1
      ENDIF
      IF(sup_proc_arg(2).NE.
     &     0)THEN
         mem_constraint(2)=tab_maxs_arg(procs(procs(slavef+1)))
         total_load=total_load+dble(sup_proc_arg(2))/100.0d0
         nb_sup=nb_sup+1
      ENDIF
      total_load=total_load+(procs(slavef+1)-nb_sup)
      IF(k50.EQ.0)THEN
         max_load=dble( nelim ) * dble( ncb ) +
     *        dble(ncb) * dble(nelim)*dble(2*nfront-nelim-1)
      ELSE
         max_load=dble(nelim) * dble( ncb ) *
     *        dble(nfront+1)
      ENDIF
      tmp=min(max_load,max_load/total_load)
      j=1
      DO i=1,procs(slavef+1)
         IF((nb_sup.GT.0).AND.(i.EQ.1))THEN
            cycle
         ELSEIF((nb_sup.EQ.2).AND.(i.EQ.procs(slavef+1)))THEN
            cycle
         ENDIF
         idwload(j)=procs(i)
         j=j+1
      ENDDO
      DO i=1,nb_sup
         IF(i.EQ.1)THEN
            idwload(j)=procs(1)
         ELSE
            idwload(j)=procs(procs(slavef+1))
         ENDIF
         j=j+1
      ENDDO
      IF ((k50.EQ.0).OR.force_ldltregular_niv2) THEN
         acc=0
         j=procs(slavef+1)-nb_sup+1
         DO i=1,nb_sup
            var=dble(sup_proc_arg(i))/100.0d0
            tmp_nrow=int(dble(mem_constraint(i))/dble(nfront))
            nb_rows(j)=int(max((var*dble(tmp))/
     &           (dble(nelim)*dble(2*nfront-nelim)),
     &           dble(1)))
            IF(nb_rows(j).GT.tmp_nrow)THEN
               nb_rows(j)=tmp_nrow
            ENDIF
            IF(ncb-acc.LT.nb_rows(j)) THEN 
               nb_rows(j)=ncb-acc
               acc=ncb
               EXIT
            ENDIF
            acc=acc+nb_rows(j)
            j=j+1
         ENDDO
         IF(acc.EQ.ncb)THEN
            GOTO 777
         ENDIF
         DO i=1,procs(slavef+1)-nb_sup
            var=1.0d0
            tmp_nrow=int((dble(tab_maxs_arg(idwload(i))))/dble(nfront))
            nb_rows(i)=int((dble(var)*dble(tmp))/
     &           (dble(nelim)*dble(2*nfront-nelim)))
            IF(nb_rows(i).GT.tmp_nrow)THEN
               nb_rows(i)=tmp_nrow
            ENDIF
            IF(ncb-acc.LT.nb_rows(i)) THEN 
               nb_rows(i)=ncb-acc
               acc=ncb
               EXIT
            ENDIF
            acc=acc+nb_rows(i)
         ENDDO
         IF(acc.NE.ncb)THEN
            IF(procs(slavef+1).EQ.nb_sup)THEN
               tmp_nrow=(ncb-acc)/procs(slavef+1)+1
               DO i=1,procs(slavef+1)
                  nb_rows(i)=nb_rows(i)+tmp_nrow
                  IF(acc+tmp_nrow.GT.ncb)THEN
                     nb_rows(i)=nb_rows(i)-tmp_nrow+ncb-acc
                     acc=ncb
                     EXIT
                  ENDIF
                  acc=acc+tmp_nrow
               ENDDO
            ELSE
               tmp_nrow=(ncb-acc)/(procs(slavef+1)-nb_sup)+1
               DO i=1,procs(slavef+1)-nb_sup
                  nb_rows(i)=nb_rows(i)+tmp_nrow
                  acc=acc+tmp_nrow
                  IF(acc.GT.ncb) THEN 
                     nb_rows(i)=nb_rows(i)-tmp_nrow+
     &                    (ncb-(acc-tmp_nrow))
                     EXIT
                  ENDIF
               ENDDO
            ENDIF
         ENDIF
      ELSE
         acc=0
         i=procs(slavef+1)-nb_sup+1
         x=ncb
         load_corr=0.0d0
         mem_cstr=.false.
         DO j=1,nb_sup
            var=dble(sup_proc_arg(j))/dble(100)
            a=1.0d0
            b=dble(x+nelim)
            c=-dble(max(mem_constraint(j),0_8))
            delta=((b*b)-(4*a*c))
            tmp_nrow=int((-b+sqrt(delta))/(2*a))
            a=dble(-nelim)
            b=dble(nelim)*(dble(-nelim)+dble(2*(x+nelim)+1))
            c=-(var*tmp)
            delta=(b*b-(4*a*c))
            nb_rows(i)=int((-b+sqrt(delta))/(2*a))
            IF(nb_rows(i).GT.tmp_nrow)THEN
               nb_rows(i)=tmp_nrow
               mem_cstr=.true.               
            ENDIF
            IF(acc+nb_rows(i).GT.ncb)THEN
               nb_rows(i)=ncb-acc
               acc=ncb
               x=0
               EXIT
            ENDIF
            x=x-nb_rows(i)
            acc=acc+nb_rows(i) 
            load_corr=load_corr+(dble(nelim) * dble(nb_rows(i)) *
     *           dble(2*(x+nelim) - nelim - nb_rows(i) + 1))
            i=i+1
         ENDDO
         IF(acc.EQ.ncb)THEN
            GOTO 777
         ENDIF
            IF((procs(slavef+1).NE.nb_sup).AND.mem_cstr)THEN
               tmp=(max_load-load_corr)/(procs(slavef+1)-nb_sup)
            ENDIF
         x=acc
         acc=0
         DO i=1,procs(slavef+1)-nb_sup
            IF (keep(375) .EQ. 1) THEN 
              var=1.0d0
              a=dble(nelim)
              b=dble(nelim)*(dble(nelim)+dble(2*acc+1))
              c=-(var*tmp)
            ELSE    
              a=1.0d0
              b=dble(acc+nelim)
              c=-tmp
            ENDIF
            delta=((b*b)-(4*a*c))
            nb_rows(i)=int((-b+sqrt(delta))/(2*a))
            IF(ncb-acc-x.LT.nb_rows(i))THEN
               nb_rows(i)=ncb-acc-x
               acc=ncb-x
               EXIT
            ENDIF
            acc=acc+nb_rows(i)
         ENDDO
         acc=acc+x
         IF(acc.NE.ncb)THEN
            IF(procs(slavef+1).EQ.nb_sup)THEN
               tmp_nrow=(ncb-acc)/procs(slavef+1)+1
               DO i=1,procs(slavef+1)
                  nb_rows(i)=nb_rows(i)+tmp_nrow
                  IF(acc+tmp_nrow.GT.ncb)THEN
                     nb_rows(i)=nb_rows(i)-tmp_nrow+ncb-acc
                     acc=ncb
                     EXIT
                  ENDIF
                  acc=acc+tmp_nrow
               ENDDO
            ELSE
               nb_rows(procs(slavef+1)-nb_sup)=
     &              nb_rows(procs(slavef+1)
     &              -nb_sup)+ncb-acc
            ENDIF
         ENDIF
      ENDIF
 777  CONTINUE
      nslaves=0
      acc=1
      j=1
      k=1
      DO i=1,procs(slavef+1)
         IF(nb_rows(i).NE.0)THEN
            slaves_list(j)=idwload(i)
            tab_pos(j)=acc
            acc=acc+nb_rows(i)
            nb_row_max=max(nb_row_max,nb_rows(i))
            IF(k50.EQ.0)THEN
               max_surf=max(int(nb_rows(i),8)*int(ncb,8),int(0,8))
            ELSE
               max_surf=max(int(nb_rows(i),8)*int(acc,8),int(0,8))
            ENDIF
            nslaves=nslaves+1
            j=j+1
         ELSE
            slaves_list(procs(slavef+1)-k+1)=idwload(i)
            k=k+1
         ENDIF
      ENDDO
      tab_pos(slavef+2) = nslaves
      tab_pos(nslaves+1)= ncb+1
      nslaves_node=nslaves
      END SUBROUTINE mumps_set_parti_regular