zana_driver.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
C
      SUBROUTINE zmumps_ana_driver(id)
      USE zmumps_load
      USE mumps_static_mapping
      USE zmumps_struc_def
      USE mumps_memory_mod
      USE zmumps_parallel_analysis
      USE zmumps_ana_lr
      USE zmumps_lr_core
      USE zmumps_lr_stats
      USE mumps_lr_common
      USE zmumps_ana_aux_m
      USE mumps_ana_blk_m, ONLY: compact_graph_t, lmatrix_t
      USE mumps_ana_omp_m
      USE zmumps_facsol_l0omp_m, ONLY: zmumps_free_l0_omp_factors
      IMPLICIT NONE
C     
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER IERR, MASTER
      parameter( master = 0 )
C
C     Purpose
C     =======
C
C     Performs analysis and (if required) Max-trans on the master, then
C     broadcasts information to the slaves. Also includes mapping.
C     
C     
C     Parameters
C     ==========
C     
      TYPE(zmumps_struc), TARGET :: id
C     
C     Local variables
C     ===============
C     
C     
C     Pointers inside integer array, various data
      INTEGER IKEEP, NE, NA
      INTEGER I, allocok
C     Other locals
      INTEGER NB_NIV2, IDEST
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER LOCAL_M, LOCAL_N
      INTEGER numroc
      EXTERNAL numroc
      INTEGER IRANK
      INTEGER MP, LP, MPG
      LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK
      INTEGER SIZE_SCHUR_PASSED
      INTEGER SBUF_SEND_FR, SBUF_REC_FR
      INTEGER SBUF_SEND_LR, SBUF_REC_LR
      INTEGER TOTAL_MBYTES
      INTEGER(8) SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE
      INTEGER SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE
      INTEGER SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE
      INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8
      LOGICAL UPDATE_BUFFER
      INTEGER MIN_BUF_SIZE
      INTEGER(8) MAX_SIZE_FACTOR_TMP
      INTEGER LEAF, INODE, ISTEP, INN, LPTRAR
      INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2
      DOUBLE PRECISION TIMEG
      INTEGER    :: TOTAL_MBYTES_UNDER_L0
      INTEGER(8) :: TOTAL_BYTES_UNDER_L0
      INTEGER :: NBSTATS_I4, NBSTATS_I8
      parameter(nbstats_i4=4, nbstats_i8=24)
      INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: TNSTK_afterL0
      INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAGGED_LEAVES
      INTEGER(8) :: PEAK_UNDER_L0, PEAK_ABOVE_L0
      INTEGER(8) :: SUM_NRLADU, MAX_NRLADU, MIN_NRLADU,
     &              SUM_NRLADU_if_LR_LU, 
     &              SUM_NRLADULR_UD, SUM_NRLADULR_WC,
     &              SUM_NRLNEC, SUM_NRLNEC_ACTIVE, 
     &              MIN_NRLNEC
      INTEGER ::    SUM_NIRADU,
     &              SUM_NIRADU_OOC, 
     &              SUM_NIRNEC, SUM_NIRNEC_OOC
      INTEGER :: LIPOOL_local
      INTEGER(8) ::  MAX_FRONT_SURFACE_LOCAL_L0, 
     &               MAX_SIZE_FACTOR_L0,
     &               ENTRIES_IN_FACTORS_UNDER_L0, 
     &               ENTRIES_IN_FACTORS_MASTERS_LO
      INTEGER             :: MAXFR_UNDER_L0
      DOUBLE PRECISION    :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0
C     to store the size of the sequencial peak of stack
C     (or an estimation for not calling REORDER_TREE_N )
      DOUBLE PRECISION      :: PEAK
      INTEGER(8)::  SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB
      LOGICAL   :: ABOVE_L0
C     
C     INTEGER WORKSPACE 
C     
      INTEGER, ALLOCATABLE, DIMENSION(:):: IPOOL
      INTEGER                           :: LIPOOL
      INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES
      INTEGER, DIMENSION(:), POINTER             :: PAR2_NODESPTR
      INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE
      INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp
      INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL
      INTEGER, DIMENSION(:), POINTER :: SSARBR
C     Element matrix entry
      INTEGER, POINTER ::  NELT, LELTVAR
      INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG
      INTEGER(8), DIMENSION(:), POINTER :: KEEP8
      INTEGER(8)                   :: ENTRIES_IN_FACTORS_LOC_MASTERS
      DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO
      DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG
      INTEGER, DIMENSION(:), POINTER :: ICNTL
      LOGICAL :: I_AM_SLAVE, PERLU_ON, COND
      INTEGER :: OOC_STRAT, BLR_STRAT
      INTEGER :: IDUMMY
      INTEGER, TARGET    :: IDUMMY_ARRAY(1)
      INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR
      INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR
      INTEGER, POINTER, DIMENSION(:) :: IRN_PTR
      INTEGER, POINTER, DIMENSION(:) :: JCN_PTR
      INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR
      INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR
      LOGICAL :: BDUMMY
      INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed,
     &              K8_50relaxed
      LOGICAL :: SUM_OF_PEAKS
      INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE
      EXTERNAL mumps_typenode, mumps_procnode
      INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC
      INTEGER :: PROCNODE_VALUE
      INTEGER K,J, IFS
      INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV
      LOGICAL IS_BUILD_LOAD_MEM_CALLED
      LOGICAL PRINT_MAXAVG, PRINT_NODEINFO
      DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: TEMP_MEM
      INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_ROOT
      INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_LEAF
      INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_SIZE
      INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST
      INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST_SEQ
      INTEGER, DIMENSION (:), ALLOCATABLE :: SBTR_ID
      DOUBLE PRECISION, DIMENSION (:), ALLOCATABLE :: COST_TRAV_TMP
      INTEGER(8) :: TOTAL_BYTES, ITMP8
      INTEGER          :: SIZE_PAR2_NODESPTR
      INTEGER          :: LSIZEOFBLOCKS_PTR
      LOGICAL          :: READY_FOR_ANA_F
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL
      LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED
      INTEGER :: IB, BLKSIZE
      INTEGER :: IBcurrent, IPOS, IPOSB, II
C      Internal work arrays:
C      DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK]
C      SIZEBLOCK(1:NBLK) (for node valuation) 
      INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS
      INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK
      INTEGER    :: NBRECORDS
      INTEGER(8) :: NSEND8, NLOCAL8
C     LMAT_BLOCK: in case of centralized matrix, 
C                 to store on MASTER the cleaned Lmatrix
C                 used to compute GCOMP
C                 LMAT_BLOCK might also be saved to 
C                 be used during grouping
C     LUMAT     : in case of distributed matrix
C                 to store distributed the cleaned LU matrix
C                 LUMAT might also be saved to 
C                 be used for MPI based grouping
C     LUMAT_REMAP : in case of distributed matrix
C                 it is used to remap LUMAT
C 
C     GCOMP     : Graph "ready" to be called by orderings
C
      TYPE(lmatrix_t)         :: LMAT_BLOCK, LUMAT, LUMAT_REMAP
      LOGICAL                 :: GCOMP_PROVIDED
      TYPE(compact_graph_t)   :: GCOMP
      TYPE(compact_graph_t)   :: GCOMP_DIST
      INTEGER(4) :: I4
      INTEGER, POINTER, DIMENSION(:) ::  
     &     NFSIZPTR,
     &     FILSPTR,
     &     FREREPTR, NE_STEPSPTR,
     &     IKEEP1, IKEEP2, IKEEP3,
     &     STEPPTR, LRGROUPSPTR
      INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC
      INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC
      ! Used because of multithreaded SIM_NP_
      INTEGER :: locMYID, locMYID_NODES
      LOGICAL, POINTER :: locI_AM_CAND(:)
      INTEGER(kind=8) :: NZ8, LIW8
C     NBLK : id%N or order of blocked matrix
      INTEGER :: NBLK
      INTEGER :: LIW_ELT
C     GATHER_MATRIX_ALLOCATED: 
C     To be sure that id%IRN and id%JCN are
C     deallocated only when ZMUMPS_GATHER_MATRIX was called
      LOGICAL :: GATHER_MATRIX_ALLOCATED
C
      INTERFACE
      SUBROUTINE zmumps_free_onentry_ana_driver(id)
      USE zmumps_struc_def
      TYPE (ZMUMPS_STRUC), TARGET :: id
      END SUBROUTINE zmumps_free_onentry_ana_driver
C     Explicit interface because of pointer arguments:
      SUBROUTINE zmumps_free_id_data_modules(id_FDM_F_ENCODING,
     &  id_BLRARRAY_ENCODING, KEEP8, K34)
#     if defined(mumps_f2003)
      CHARACTER, DIMENSION(:), POINTER, intent(inout) ::
     &                                            id_blrarray_encoding
      CHARACTER, DIMENSION(:), POINTER, intent(inout) ::
     &                                            id_fdm_f_encoding
#     else
      CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING
      CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING
#     endif
      INTEGER(8), intent(inout) :: KEEP8(150)
      INTEGER, intent(in) :: K34
      END SUBROUTINE zmumps_free_id_data_modules
      END INTERFACE
C
C  Beginning of executable statements
C
C     Free data that might have been computed during
C     a previous analysis step for factorization and 
C     that will be recomputed
      CALL zmumps_free_onentry_ana_driver (id)
      is_build_load_mem_called=.false.
      keep   => id%KEEP
      keep8  => id%KEEP8
      info   => id%INFO
      rinfo  => id%RINFO
      infog  => id%INFOG
      rinfog => id%RINFOG
      icntl  => id%ICNTL
      nelt    => id%NELT
      leltvar => id%LELTVAR
      keep(264) = 0    ! reinitialise out-of-range status (0=yes)
      keep(265) = 0    ! reinitialise dupplicates (0=yes)
      print_maxavg = .NOT.(id%NSLAVES.EQ.1 .AND. keep(46).EQ.1)
C     Print per node information only in case there are several
C     compute nodes (id%KEEP(412): #MPI procs on compute node)
      print_nodeinfo = print_maxavg .AND. id%NPROCS .NE. id%KEEP(412)
      gather_matrix_allocated = .false.
      NULLIFY ( nfsizptr,
     &     filsptr,
     &     frereptr, ne_stepsptr,
     &     ikeep1, ikeep2, ikeep3, stepptr, lrgroupsptr, 
     &     ssarbr, sizeofblocks_ptr, irn_loc_ptr, jcn_loc_ptr,
     &     irn_ptr, jcn_ptr,
     &     par2_nodesptr )
      IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM)
      nullify(id%UNS_PERM)
      idummy = 1
      bdummy = .false.
C     Set default value that witl be reset in
C     case of blocked format matrices
      nblk = id%N
      gcomp_provided   = .false.
      blkptr_allocated = .false.
      blkvar_allocated = .false.
C     -------------------------------------
C     Depending on the type of parallelism,
C     the master can now (soon) potentially
C     have the role of a slave
C     -------------------------------------
      i_am_slave = ( id%MYID .ne. master  .OR.
     &     ( id%MYID .eq. master .AND.
     &     id%KEEP(46) .eq. 1 ) )
      lp  = icntl( 1 )
      mp  = icntl( 2 )
      mpg = icntl( 3 )
C     LP     : errors
C     MP     : INFO
      lpok  = ((lp.GT.0).AND.(id%ICNTL(4).GE.1))
      prok  = (( mp  .GT. 0 ).AND.(icntl(4).GE.2))
      prokg = ( mpg .GT. 0 .and. id%MYID .eq. master )
      prokg = (prokg.AND.(icntl(4).GE.2))
      IF ( prok ) THEN
         IF ( keep(50) .eq. 0 ) THEN
            WRITE(mp, '(A)') 'L U Solver for unsymmetric matrices'
         ELSE IF ( keep(50) .eq. 1 ) THEN
            WRITE(mp, '(A)') 
     & 'L D L^T Solver for symmetric positive definite matrices'
         ELSE
            WRITE(mp, '(A)') 
     &           'L D L^T Solver for general symmetric matrices'
         END IF
         IF ( keep(46) .eq. 1 ) THEN
            WRITE(mp, '(A)') 'Type of parallelism: Working host'
         ELSE
            WRITE(mp, '(a)') 'Type of parallelism: host not working'
         END IF
      END IF
.AND..NE.      IF ( PROKG  (MPMPG)) THEN
.eq.         IF ( KEEP(50)  0 ) THEN
            WRITE(MPG, '(a)') 'L U Solver for unsymmetric matrices'
         ELSE IF ( keep(50) .eq. 1 ) THEN
            WRITE(mpg, '(A)') 
     & 'L D L^T Solver for symmetric positive definite matrices'
         ELSE
            WRITE(mpg, '(A)') 
     &           'L D L^T Solver for general symmetric matrices'
         END IF
         IF ( keep(46) .eq. 1 ) THEN
            WRITE(mpg, '(A)') 'Type of parallelism: Working host'
         ELSE
            WRITE(mpg, '(A)') 'Type of parallelism: Host not working'
         END IF
      END IF      
      IF (prok) WRITE( mp, 110 )
      IF (prokg .AND. (mpg.NE.mp)) WRITE( mpg, 110 )
C
C     BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS
C     ----------------------------------------
C     Free some memory from factorization,
C     if allocated, at least large arrays.
C     This will also limit the amount of useless
C     data saved to disk in case of save-restore
C     ----------------------------------------
      IF (id%KEEP8(24).EQ.0_8) THEN
C       -- deallocate only when not provided/allocated by the user
         IF (associated(id%S)) THEN
            DEALLOCATE(id%S)
            id%KEEP8(23)=0_8
         ENDIF
      ENDIF
      NULLIFY(id%S)
      keep8(24) = 0_8  ! reinitialize last used size of WK_USER
      IF (associated(id%IS)) THEN
        DEALLOCATE(id%IS)
        NULLIFY(id%IS)
      ENDIF
C     also avoid keeping BLR factors allocated if analysis
C     called after a previous BLR factorization without
C     an intermediate JOB=-2 call.
      CALL zmumps_free_id_data_modules(id%FDM_F_ENCODING,
     &            id%BLRARRAY_ENCODING, id%KEEP8(1), id%KEEP(34))
      IF (associated(id%root%RG2L_ROW))THEN
        DEALLOCATE(id%root%RG2L_ROW)
        NULLIFY(id%root%RG2L_ROW)
      ENDIF
      IF (associated(id%root%RG2L_COL))THEN
        DEALLOCATE(id%root%RG2L_COL)
        NULLIFY(id%root%RG2L_COL)
      ENDIF
      IF (associated( id%PTLUST_S )) THEN
        DEALLOCATE(id%PTLUST_S)
        NULLIFY(id%PTLUST_S)
      ENDIF
      IF (associated(id%PTRFAC)) THEN
        DEALLOCATE(id%PTRFAC)
        NULLIFY(id%PTRFAC)
      END IF
      IF (associated(id%RHSCOMP)) THEN
        DEALLOCATE(id%RHSCOMP)
        NULLIFY(id%RHSCOMP)
        id%KEEP8(25)=0_8
      ENDIF
      IF (associated(id%POSINRHSCOMP_ROW)) THEN
        DEALLOCATE(id%POSINRHSCOMP_ROW)
        NULLIFY(id%POSINRHSCOMP_ROW)
      ENDIF
      IF (id%POSINRHSCOMP_COL_ALLOC) THEN
        DEALLOCATE(id%POSINRHSCOMP_COL)
        NULLIFY(id%POSINRHSCOMP_COL)
        id%POSINRHSCOMP_COL_ALLOC = .false.
      ENDIF
C     --------------------------------------------
C     If analysis redone, suppress old,
C     meaningless, Step2node array.
C     This is necessary since we could otherwise
C     end up having a wrong Step2node during solve
C     --------------------------------------------
      IF (associated(id%Step2node)) THEN
        DEALLOCATE(id%Step2node)
        NULLIFY(id%Step2node)
      ENDIF
      IF (associated(id%IPOOL_B_L0_OMP)) THEN
        DEALLOCATE(id%IPOOL_B_L0_OMP)
        NULLIFY(id%IPOOL_B_L0_OMP)
      ENDIF
      IF (associated(id%IPOOL_A_L0_OMP)) THEN
        DEALLOCATE(id%IPOOL_A_L0_OMP)
        NULLIFY(id%IPOOL_A_L0_OMP)
      ENDIF
      IF (associated(id%PHYS_L0_OMP)) THEN
         DEALLOCATE(id%PHYS_L0_OMP)
         NULLIFY(id%PHYS_L0_OMP)
      ENDIF
      IF (associated(id%VIRT_L0_OMP)) THEN
         DEALLOCATE(id%VIRT_L0_OMP)
         NULLIFY(id%VIRT_L0_OMP)
      ENDIF
      IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN
         DEALLOCATE(id%VIRT_L0_OMP_MAPPING)
         NULLIFY(id%VIRT_L0_OMP_MAPPING)
      ENDIF
      IF (associated(id%PERM_L0_OMP)) THEN
        DEALLOCATE(id%PERM_L0_OMP)
        NULLIFY(id%PERM_L0_OMP)
      ENDIF
      IF (associated(id%PTR_LEAFS_L0_OMP)) THEN
        DEALLOCATE(id%PTR_LEAFS_L0_OMP )
        NULLIFY(id%PTR_LEAFS_L0_OMP)
      ENDIF
      IF (associated(id%I4_L0_OMP)) THEN
        DEALLOCATE(id%I4_L0_OMP)
        NULLIFY(id%I4_L0_OMP)
      ENDIF
      IF (associated(id%I8_L0_OMP)) THEN
        DEALLOCATE(id%I8_L0_OMP)
        NULLIFY(id%I8_L0_OMP)
      ENDIF
      IF (.NOT.i_am_slave) THEN
        ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok)
        IF (allocok.gt.0) THEN
            info(1)= -7
            info(2)= 2 
        ENDIF
      ENDIF
      IF (associated(id%L0_OMP_MAPPING)) THEN
        DEALLOCATE(id%L0_OMP_MAPPING)
        NULLIFY(id%L0_OMP_MAPPING)
      ENDIF
      IF (associated(id%L0_OMP_FACTORS)) THEN
        CALL zmumps_free_l0_omp_factors(id%L0_OMP_FACTORS)
      END IF
C     END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS
C
C     Decode API (ICNTL parameters, mainly)
C     and check consistency of the KEEP array.
C     Note: ZMUMPS_ANA_CHECK_KEEP also sets
C     some INFOG parameters
      CALL zmumps_ana_check_keep(id, i_am_slave)
      CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
      IF ( info(1) .LT. 0 ) GOTO 500
C     -------------------------------------------
C     Broadcast KEEP(60) since we need to broadcast
C     related information
C     ------------------------------------------
      CALL mpi_bcast( keep(60), 1, mpi_integer, master, id%COMM, ierr )
C        broadcast also size of schur
      IF (id%KEEP(60) .NE. 0 ) THEN
       CALL mpi_bcast( keep(116), 1, mpi_integer, master, 
     &                   id%COMM, ierr )
      ENDIF
      IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). eq. 3) THEN
         CALL mpi_bcast( id%NPROW, 1,
     &        mpi_integer, master, id%COMM, ierr )
         CALL mpi_bcast( id%NPCOL, 1,
     &        mpi_integer, master, id%COMM, ierr )
         CALL mpi_bcast( id%MBLOCK, 1,
     &        mpi_integer, master, id%COMM, ierr )
         CALL mpi_bcast( id%NBLOCK, 1,
     &        mpi_integer, master, id%COMM, ierr )
C     Note that ZMUMPS_INIT_ROOT_ANA will
C     then use that information.
      ENDIF
C     ----------------------------------------------
C     Broadcast KEEP(54) now to know if the
C     structure of the graph is intially distributed
C     and should be assembled on the master
C     Broadcast KEEP(55) now to know if the
C     matrix is in assembled or elemental format
C     ----------------------------------------------
      CALL mpi_bcast( keep(54), 2, mpi_integer, master, id%COMM, ierr )
C     ----------------------------------------------
C     Broadcast KEEP(69) now to know if
C     we will need to communicate during analysis
C     ----------------------------------------------
      CALL mpi_bcast( keep(69), 1, mpi_integer, master, id%COMM, ierr )
C     ----------------------------------------------
C     Broadcast Out of core strategy (used only on master so far)
C     ----------------------------------------------
      CALL mpi_bcast( keep(201), 1, mpi_integer, master, id%COMM, ierr )
C     ----------------------------------------------
C     Broadcast analysis strategy (used only on master so far)
C     ----------------------------------------------
      CALL mpi_bcast( keep(244), 1, mpi_integer, master, id%COMM, ierr )
C     ---------------------------
C     Fwd in facto
C     Broadcast KEEP(251,252,253) defined on master so far
      CALL mpi_bcast( keep(251), 3, mpi_integer,master,id%COMM,ierr)
C
      CALL mpi_bcast( keep(400), 1, mpi_integer,master,id%COMM,ierr)
      CALL mpi_bcast( id%KEEP(490), 5, mpi_integer, master,
     &     id%COMM, ierr )
C     ----------------------------------------------
C     Broadcast N 
C     ----------------------------------------------
      CALL mpi_bcast( id%N, 1, mpi_integer, master, id%COMM, ierr )
C     ----------------------------------------------
C     Broadcast NZ for assembled entry
C     ----------------------------------------------
      IF ( keep(55) .EQ. 0) THEN
         IF ( keep(54) .eq. 3 ) THEN
C     Compute total number of non-zeros
          CALL mpi_allreduce( id%KEEP8(29), id%KEEP8(28), 1,
     &       mpi_integer8, 
     &       mpi_sum, id%COMM, ierr )
         ELSE
C     Broadcast NZ from the master node
            CALL mpi_bcast( id%KEEP8(28), 1, mpi_integer8, master,
     &           id%COMM, ierr )
         END IF
      ELSE
C     Broadcast NA_ELT <=> KEEP8(30) for elemental entry
         CALL mpi_bcast( id%KEEP8(30), 1, mpi_integer8, master,
     &        id%COMM, ierr )
      ENDIF
      IF( id%KEEP(54).EQ.3) THEN
C     test IRN_loc and JCN_loc allocated on working procs
       IF (i_am_slave .AND. id%KEEP8(29).GT.0 .AND.
     &     ( (.NOT. associated(id%IRN_loc)) .OR. 
     &       (.NOT. associated(id%JCN_loc)) )
     &   ) THEN
         id%INFO(1) = -22
         id%INFO(2) = 16
       ENDIF
      ENDIF
      IF ( associated(id%MEM_DIST) ) THEN
         DEALLOCATE( id%MEM_DIST )
      ENDIF
      allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), stat=ierr )
      IF ( ierr .GT. 0 ) THEN
         info(1) = -7
         info(2) = id%NSLAVES
         IF ( lpok ) THEN
            WRITE(lp, 150) 'MEM_DIST'
         END IF
      END IF
      CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
      IF ( info(1) .LT. 0 ) GOTO 500
      id%MEM_DIST(0:id%NSLAVES-1) = 0
      CALL mumps_init_arch_parameters(
     &     id%COMM,id%COMM_NODES,keep(69),keep(46),
     &     id%NSLAVES,id%MEM_DIST,info)
C     ========================
C     Write problem to a file,
C     if requested by the user
C     ========================
      CALL zmumps_dump_problem(id)
      IF ( id%INFO(1) .LT. 0 ) GOTO 500
C     =================
C     ANALYSIS BY BLOCK 
C     =================
      IF ( id%MYID .EQ. master ) THEN
       IF (keep(13).NE.0) THEN
C      Analysis by block with block data provided by user
C
C       Check if block structure is centralized or distributed
        IF (.NOT.associated(id%BLKVAR)) THEN
C        BLKVAR is identity and implicitly centralized
         keep(14) = 0
        ELSE
         IF (size(id%BLKVAR).EQ.id%N) THEN
C         Centralized block stucture
          keep(14) = 0
         ELSE
C         Distributed block stucture
          keep(14) = 1
          IF ( lpok ) THEN
             WRITE(lp,'(A,A,I8)') 
     &       " ERROR with centralized matrix. Size of id%BLKVAR ", 
     &       "should be equal to id%N instead of ", 
     &       size(id%BLKVAR)
          ENDIF
          id%INFO(1) = -57
          id%INFO(2) = 3
         ENDIF
        ENDIF
        IF (keep(13).GE.1) THEN
C        BLKPTR provided by user
C        check input data
         IF ( .NOT.associated(id%BLKPTR)) THEN
          IF ( lpok ) THEN
             WRITE(lp,'(A,I8)') 
     &       " id%BLKPTR should be provided by user on host "
          ENDIF
          id%INFO(1) = -57
          id%INFO(2) = 2
         ENDIF 
         IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N)
     &       .OR. (id%NBLK+1.NE.size(id%BLKPTR))
     &      ) THEN
          IF ( lpok ) THEN
             WRITE(lp,'(A,I8)') 
     &       " ERROR incorrect value of id%NBLK:", id%NBLK
          ENDIF
          id%INFO(1) = -57
          id%INFO(2) = 1
         ENDIF 
         nblk=id%NBLK
         IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN
           IF ( lpok ) THEN
             WRITE(lp,'(A,A,I8)') 
     &       " ERROR id%BLKPTR(id%NBLK+1)-1 ", 
     &       "should be equal to id%N instead of ", 
     &       id%BLKPTR(id%NBLK+1)-1
           ENDIF
           id%INFO(1) = -57
           id%INFO(2) = 2
         ENDIF
         IF (id%BLKPTR(1).NE.1) THEN
           IF ( lpok ) THEN
             WRITE(lp,'(A,A,I8)') 
     &       " ERROR id%BLKPTR(1)", 
     &       "should be equal to 1 instead of ", 
     &       id%BLKPTR(1)
           ENDIF
           id%INFO(1) = -57
           id%INFO(2) = 2
         ENDIF
        ELSE IF (keep(13).LT.0) THEN
C        regular blocks in BLKVAR of size -KEEP(13)
C        mod(id%N,-KEEP(13)) has already been checked
         nblk = id%N/(-keep(13))
        ENDIF
C      end of KEEP(13).NE.0
       ENDIF 
C      end of  id%MYID .EQ. MASTER 
      ENDIF 
      CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
     &     id%COMM, id%MYID )
      IF ( id%INFO(1) .LT. 0 ) GOTO 500
C
C     Broadcast KEEP(13-14), NBLK
      CALL mpi_bcast( keep(13), 2, mpi_integer, master, id%COMM, ierr )
      CALL mpi_bcast( nblk, 1, mpi_integer, master, id%COMM, ierr )
C
C     ===========================
      IF (keep(13).NE.0) THEN
C     { BEGIN preparation ANA_BLK
C     ===========================
       IF ( ( (keep(54).NE.3).AND.(id%MYID.EQ.master) ) 
     &    .OR.  (keep(54).EQ.3) ) THEN
C         ----------------------------------------
C         Allocate SIZEOFBLOCKS, DOF2BLOCK
C         ----------------------------------------
          IF (allocated(sizeofblocks)) DEALLOCATE(sizeofblocks)
          IF (allocated(dof2block)) DEALLOCATE(dof2block)
          allocate(sizeofblocks(nblk), dof2block(id%N), 
     &                  stat=allocok)
C
          IF (allocok.NE.0) THEN
           id%INFO( 1 ) = -7
           id%INFO( 2 ) = id%N+nblk
           IF ( lpok ) WRITE(lp, 150) ' SIZEOFBLOCKS, DOF2BLOCK'
          ENDIF
C
          IF (id%MYID.EQ.master.AND.allocok.EQ.0) THEN
C          BLKPTR and BLKVAR needed for ZMUMPS_EXPAND_TREE
C          allocate then if not associated
           IF (.NOT.associated(id%BLKPTR)) THEN
            blkptr_allocated = .true.
            allocate(id%BLKPTR(nblk+1), stat=allocok)
            IF (allocok.NE.0) THEN
             blkptr_allocated = .true.
             id%INFO( 1 ) = -7
             id%INFO( 2 ) = nblk+1
             IF ( lpok ) WRITE(lp, 150) ' id%BLKPTR '
            ENDIF
           ENDIF
           IF (.NOT.associated(id%BLKVAR).AND.allocok.EQ.0) THEN
            allocate(id%BLKVAR(id%N), stat=allocok)
            blkvar_allocated = .true.
            IF (allocok.NE.0) THEN
             blkvar_allocated = .false.
             id%INFO( 1 ) = -7
             id%INFO( 2 ) = id%N
             IF ( lpok ) WRITE(lp, 150) ' id%BLKVAR '
            ENDIF
           ENDIF
          ENDIF
       ENDIF
       CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
       IF (info(1).LT.0) GOTO 500
       IF ( id%MYID .EQ. master ) THEN
C      -----------------------------------------
C      Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER
C      based on id%BLKPTR and id%BLKVAR 
C      and compute id%BLKPTR and id%BLKVAR if not 
C      provided by user
C      -----------------------------------------
           IF (blkvar_allocated) THEN
C           implicitly id%BLKVAR(I)=I
            DO i=1, id%N
             id%BLKVAR(i)=i
            ENDDO
           ENDIF
           IF (blkptr_allocated) THEN
            ib=0
            blksize=-keep(13)
            DO i=1, id%N, blksize
              ib=ib+1
              id%BLKPTR(ib) = i
            ENDDO
            id%BLKPTR(nblk+1) = id%N+1
           ENDIF
C
           CALL mumps_ab_compute_sizeofblock (
     &          nblk, id%N, id%BLKPTR(1), id%BLKVAR(1),
     &          sizeofblocks, dof2block)
       ENDIF
C      =======================
       IF (keep(54).NE.3) THEN
C      =======================
C{
C      ---------------------
C      Matrix structure available on host
C      ---------------------
        keep(14) = 0 
        IF (id%MYID.EQ.master) THEN
C         Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix 
C         of nodes (indices \in [1,NBLK])
          IF (id%KEEP8(28) .EQ. 0_8) THEN
            irn_ptr => idummy_array
            jcn_ptr => idummy_array
          ELSE
            irn_ptr => id%IRN
            jcn_ptr => id%JCN
          ENDIF
          CALL mumps_ab_coord_to_lmat ( id%MYID,
     &          nblk, id%N, id%KEEP8(28), irn_ptr(1), jcn_ptr(1),
     &          dof2block, 
     &          info(1), info(2), lp, lpok, 
     &          lmat_block )
        ENDIF
        CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
        IF ( info(1) .LT. 0 ) GOTO 500
C
        IF (id%MYID.EQ.master) THEN
C         From LMAT_BLOCK build GCOMP format wich requires
C         symmetrizing the Lmatrix
          CALL mumps_ab_lmat_to_clean_g ( id%MYID, .true.,
     &         .true., ! not relevant because unfold is true
     &         lmat_block, gcomp, 
     &         info(1), icntl(1))
          gcomp_provided = .true.
          IF (keep(494).EQ.0) THEN
            CALL mumps_ab_free_lmat(lmat_block)
          ENDIF
        ENDIF
        CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
        IF ( info(1) .LT. 0 ) GOTO 500
C}
C      ====
       ELSE
C      ====
C{
C      -------------------------------
C      Matrix structure is distributed
C      -------------------------------
C 
         IF (.NOT. i_am_slave .OR. ! non-working master
     &       id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc
C          Master non-working
           irn_loc_ptr => idummy_array
           jcn_loc_ptr => idummy_array
           id%KEEP8(29) = 0_8
         ELSE
           irn_loc_ptr => id%IRN_loc
           jcn_loc_ptr => id%JCN_loc
         ENDIF
C
C        Given distributed matrix  IRN_loc_PTR, JCN_loc_PTR
C        build distributed cleaned graph GCOMP and
C        save  distributed LUMAT in case of grouping
C
         IF (id%NPROCS.EQ.1) THEN
C          Build GCOMP, the centralized final cleaned graph
           ready_for_ana_f = .true.
           CALL mumps_ab_dcoord_to_dcompg ( 
     &          id%MYID, id%NPROCS, id%COMM, 
     &          nblk, id%N,
     &          id%KEEP8(29),  ! => NNZ_loc or NZ_loc
     &          irn_loc_ptr(1), jcn_loc_ptr(1), 
     &          dof2block(1), 
     &          id%ICNTL(1), id%INFO(1), id%KEEP(1),
     &          lumat, gcomp, ready_for_ana_f)
           gcomp_provided = .true.
         ELSE
           ready_for_ana_f = .false.
           CALL mumps_ab_dcoord_to_dcompg ( 
     &          id%MYID, id%NPROCS, id%COMM, 
     &          nblk, id%N,
     &          id%KEEP8(29),  ! => NNZ_loc or NZ_loc
     &          irn_loc_ptr(1), jcn_loc_ptr(1), 
     &          dof2block(1), 
     &          id%ICNTL(1), id%INFO(1), id%KEEP(1),
     &          lumat, gcomp_dist, ready_for_ana_f)
         ENDIF
C
C
         CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
          IF ( info(1) .LT. 0 ) GOTO 500
C}
C      =====
       ENDIF
C      =====
       IF (allocated(dof2block)) THEN
C        DOF2BLOCK reused on master if pivot order given by user
         IF ( (id%MYID.EQ.master).AND. (keep(256) .NE. 1)) THEN
           DEALLOCATE(dof2block)
         ENDIF
       ENDIF
C     ========================
      ENDIF
C     } END preparation ANA_BLK
C     =========================
C     ====================================================
C     TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244))
C     ====================================================
      IF ( (keep(244).EQ.1) .AND. (keep(54) .eq. 3) ) THEN
C     -----------------------------------------------
C     Sequential analysis: 
C     Collect on the host -- if matrix is distributed
C     at analysis -- all integer information needed
C     to perform ordering
C     -----------------------------------------------
          IF (keep(13).NE.0) THEN
           IF (id%NPROCS.NE.1) THEN
             CALL mumps_ab_gather_graph(
     &       id%ICNTL(1), keep(1), id%COMM, id%MYID, id%NPROCS,
     &       id%INFO(1), 
     &       gcomp_dist, gcomp)
             gcomp_provided = .true.
C
             CALL mumps_ab_free_gcomp(gcomp_dist)
           ENDIF
          ELSE
            CALL zmumps_gather_matrix(id)
            gather_matrix_allocated = .true.
            CALL mumps_propinfo( icntl(1), info(1),
     &            id%COMM, id%MYID )
          ENDIF
          IF ( info(1) .LT. 0 ) GOTO 500
      ENDIF
 1234 CONTINUE
      IF (keep(244) .EQ. 1) THEN
C     Sequential analysis : Schur
        IF ( id%MYID .eq. master ) THEN
C           Prepare arguments for call to ZMUMPS_ANA_F and
C           ZMUMPS_ANA_F_ELT in case id%SCHUR was not allocated
C           by user. The objective is to avoid passing a null
C           pointer. 
C FIXME  Block fomat for Schur
            IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN
               size_schur_passed = 1
               listvar_schur_2be_freed=.true.
               allocate( id%LISTVAR_SCHUR( 1 ), stat=allocok )
               IF ( allocok .GT. 0 ) THEN
                  WRITE(*,*)
     &                 'PB allocating an array of size 1 for Schur!! '
                  info(1)=-7
                  info(2)=1
               END IF
            ELSE
               size_schur_passed=id%SIZE_SCHUR
               listvar_schur_2be_freed = .false.
            END IF
        ENDIF
        CALL mumps_propinfo( icntl(1), info(1),
     &            id%COMM, id%MYID )
        IF ( info(1) < 0 ) GOTO 500
      ENDIF
C
      IF ((id%MYID.EQ.master).AND.(keep(244) .EQ. 1) 
     &     .AND. (id%N.EQ.nblk) 
     &   ) THEN
C     Sequential analysis : maximum transversal on master
         IF  ((keep(50).NE.1).AND.
     &        .NOT.((keep(23).EQ.7).AND.keep(50).EQ.0) 
     &       ) THEN
C             (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) :
C             For unsymmetric matrix, if automatic setting is requested
C             default setting of Maximum Transversal is decided during
C             ZMUMPS_ANA_F and is based on matrix unsymmetry. 
C             Thus in this case we skip ZMUMPS_ANA_O
              IF ( ( keep(23) .NE. 0 )  .OR.
C                Automatic choice for scaling does not force Maxtrans
C                Only when scaling is explicitly asked during analysis
C                (KEEP(52)=-2) ZMUMPS_ANA_O is called
     &           keep(52) .EQ. -2 ) THEN
C
C                Maximum Trans. algorithm called on original matrix.
C                We compute a permutation of the original matrix to
C                have a zero free diagonal
C                KEEP(23)=7 means that automatic choice
C                      of max trans value will be done during analysis
C                Permutation is held in UNS_PERM(1, ...,N).  
C                Maximum transversal is not available for element 
C                entry format
C              UNS_PERM that might be set to
C              to permutation computed during Max transversal
               ALLOCATE(id%UNS_PERM(id%N),ikeepalloc(3*id%N),
     &                  work2alloc(id%N), stat=ierr)
               IF (ierr.GT.0) THEN
                info(1)=-7
                info(2)=5*id%N
               ELSE
                CALL zmumps_ana_o(id%N, id%KEEP8(28), keep(23),
     &              id%UNS_PERM, ikeepalloc, id%IRN, id%JCN, id%A,
     &              id%ROWSCA, id%COLSCA,
     &              work2alloc, id%KEEP, id%ICNTL, id%INFO, id%INFOG)
                IF (allocated(work2alloc)) DEALLOCATE(work2alloc)
                IF (keep(23).EQ.0) THEN
C                 Maximum tranversal did not produce a permutation
                  IF (associated( id%UNS_PERM )) 
     &                    DEALLOCATE(id%UNS_PERM)
                  NULLIFY(id%UNS_PERM)
                ENDIF
C               Check if IKEEPALLOC needed for ANA_F
                IF (keep(23).EQ.0.AND.(keep(95).EQ.1)) THEN
                  IF (allocated(ikeepalloc)) DEALLOCATE(ikeepalloc)
                ENDIF
               ENDIF
               IF (info(1) .LT. 0) THEN
C              Fatal error
C              Permutation was not computed; reset keep(23)
                  keep(23) = 0
               ELSE
               ENDIF
              ELSE
                keep(23)    = 0
C               Switch off
C               compressed/contrained ordering
                id%KEEP(95) = 1
              END IF
         ENDIF
C     END OF MAX-TRANS ON THE MASTER
      ENDIF
      CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
      IF ( info(1) < 0 ) GOTO 500
C
      IF ( keep(244) .EQ. 1) THEN
C        Sequential analysis: allocate data for ordering on MASTER
         IF (id%MYID.EQ.master) THEN
C          allocate IKEEPALLOC and TREE related pointers
C          IKEEPALLOC might have been allocated in ZMUMPS_ANA_O
C          and IKEEPALLOC(1:N) might hold information to 
C          be given to ANA_F.
           IF (allocated(ikeepalloc)) THEN
             ALLOCATE( filsptr(nblk), frereptr(nblk),
     &               nfsizptr(nblk), stat=ierr)
             IF (ierr.GT.0) THEN
              info(1)=-7
              info(2)=3*nblk
             ENDIF
           ELSE
             ALLOCATE(ikeepalloc(nblk+2*id%N), 
     &               filsptr(nblk), frereptr(nblk),
     &               nfsizptr(nblk), stat=ierr)
            IF (ierr.GT.0) THEN
             info(1)=-7
             info(2)=4*nblk+2*id%N
            ENDIF
           ENDIF
         ENDIF
         CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
         IF ( info(1) < 0 ) GOTO 500
      ENDIF
C
      IF (keep(244) .EQ. 1) THEN
C     Sequential analysis
        IF ( id%MYID .eq. master ) THEN
C       BEGINNING OF ANALYSIS ON THE MASTER
C       ------------------------------------------------------
C       For element entry (KEEP(55).ne.0), we do not know NZ, 
C       and so the whole allocation of IW cannot be done at this 
C       point and more workspace is declared/allocated/used
C       inside ZMUMPS_ANA_F_ELT.
C       ------------------------------------------------------
C
            IF (keep(55) .EQ. 0) THEN
C              ----------------
C              Assembled format
C              ----------------
               nz8=id%KEEP8(28)
C              Compute LIW8:
C              For local orderings a contiguous space IW 
C              of size LIW8 must be provided. 
C              IW must hold the graph (with double adjacency 
C              list) and and extra space of size the number of 
C              nodes in the graph: 
C                ==>   LIW8 = 2_8 * NZ8 +  int(NBLK,8) + 1_8
C              In case of analysis by block and 
C              However, when GCOMP is provided directly then 
C              IW is not allocated 
C                ==>   LIW8 = 0
C              In this case 
C                size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 
C                should hold
               IF (keep(13).NE.0) THEN
C                Compact graph is provided on entry to ZMUMPS_ANA_F
                 nz8=0_8 ! GCOMP is provided on entry
               ENDIF
               IF (nz8.EQ.0_8) THEN 
                 liw8 = 0_8
               ELSE
                 liw8 = 2_8 * nz8 +  int(nblk,8) + 1_8
               ENDIF
C        
            ELSE
C              ----------------
C              Elemental format
C              ----------------
C              Only available for AMD, METIS, and given ordering
#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
               cond = (keep(60) .NE. 0) .OR. (keep(256) .EQ. 5)
#else
               cond = (keep(60) .NE. 0)
#endif
               IF( cond ) THEN
C
C
C                 we suppress supervariable detection when Schur
C                 is active or when METIS is applied
C                 Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1)
                  liw_elt = id%N + id%N + 1
               ELSE
C                 Spaces FLAG(N), LEN(N), N+3, SVAR(0:N),
                  liw_elt =  id%N + id%N + id%N + 3 + id%N + 1
               ENDIF
C     
            ENDIF
C           We must ensure that an array of order
C           3*N is available for ZMUMPS_ANA_LNEW
            IF (keep(55) .EQ. 0) THEN
              IF (liw8.LT.3_8*int(nblk,8)) liw8 = 3_8*int(nblk,8)
            ELSE
              IF (liw_elt.LT.3*id%N) liw_elt = 3*id%N
            ENDIF
C
            IF ( keep(256) .EQ. 1 ) THEN
C            It has been checked that id%PERM_IN is associated but
C            values of pivot order will be checked later and
C            should be checked here too
C            PERM_IN( I ) = position of I in the pivot order
             ikeep2 => ikeepalloc(nblk+1:nblk+id%N)
C            Build inverse permutation and check PERM_IN 
             DO i = 1, id%N
                ikeep2(i) = 0
             ENDDO
             DO i = 1, id%N
                IF ( id%PERM_IN(i) .LT.1 .OR.
     &               id%PERM_IN(i) .GT. id%N ) THEN
C                 PERM_IN entry is out-of-range
                  info(1) = -4
                  info(2) = i
                  GOTO 10
                ELSE IF ( ikeep2(id%PERM_IN(i)) .NE. 0 ) THEN
C                 Duplicate entry in PERM_IN was found
                  info(1) = -4
                  info(2) = i
                  GOTO 10
                ELSE
C                 Store entry in inverse permutation
                  ikeep2(id%PERM_IN( i )) = i
                ENDIF
             ENDDO
             IF ((keep(55) .EQ. 0).AND.(keep(13).NE.0)
     &           .AND.(keep(13).NE.-1)
     &         ) THEN
C             Build blocked permutation:
C              IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK]
C             IKEEP2 holds inverse permutation
              iposb = 0
              ipos  = 1
              DO WHILE (ipos.LE.id%N)
                iposb     = iposb+1
                i         = ikeep2(ipos)
                ibcurrent = dof2block(i)
                blksize   = sizeofblocks(ibcurrent)
                ikeepalloc(ibcurrent) = iposb
                IF (blksize.GT.1) THEN
                 DO ii = 1, blksize-1
                  ipos    = ipos+1
                  i       = ikeep2(ipos)
                  ib      = dof2block(i)
                  IF (ib.NE.ibcurrent) THEN
                   info(1)= -4
                   info(2)= i
                   GOTO 10
                  ENDIF
                 ENDDO
                ENDIF
                ipos = ipos+1
              ENDDO
C             IF PERM_IN is correct then
C             on exit last position should be NBLK
              IF (iposb.NE.nblk) THEN
                   info(1)= -4
C                  N+1 to indicate "global" error
                   info(2)= id%N+1
                   GOTO 10
              ENDIF
             ELSE
               DO i = 1, id%N
                  ikeepalloc( i ) = id%PERM_IN( i )
               END DO
             ENDIF
             IF (allocated(dof2block)) DEALLOCATE(dof2block)
            END IF
            infog(1) = 0
            infog(2) = 0
C           Initialize structural symmetry value to not yet computed.
            infog(8) = -1
            IF (keep(55) .EQ. 0) THEN
               ikeep1 => ikeepalloc(1:nblk)
               ikeep2 => ikeepalloc(nblk+1:nblk+id%N)
               ikeep3 => ikeepalloc(nblk+id%N+1:nblk+2*id%N)
C              id%UNS_PERM corresponds to argument PIV
C              in ZMUMPS_ANA_F, it should be an assumed-shape
C              array rather than a possibly null pointer:
               IF (associated(id%UNS_PERM)) THEN
                 uns_perm_ptr => id%UNS_PERM
               ELSE
                 uns_perm_ptr => idummy_array
               ENDIF
               IF (keep(13).EQ.0) THEN
                CALL zmumps_ana_f(id%N, nz8,
     &              id%IRN, id%JCN,
     &              liw8, ikeep1, ikeep2, ikeep3,
     &              keep(256), nfsizptr,
     &              filsptr, frereptr,
     &              id%LISTVAR_SCHUR, size_schur_passed,
     &              id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, 
     &              uns_perm_ptr,
     &              id%CNTL(4), id%COLSCA,  id%ROWSCA
#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)         
     &              , id%METIS_OPTIONS(1)
#endif               
     &          )               
               ELSE
                irn_loc_ptr => idummy_array
                jcn_loc_ptr => idummy_array
                CALL zmumps_ana_f(nblk, nz8,
     &              irn_loc_ptr, jcn_loc_ptr,
     &              liw8, ikeep1, ikeep2, ikeep3,
     &              keep(256), nfsizptr,
     &              filsptr, frereptr,
     &              id%LISTVAR_SCHUR, size_schur_passed,
     &              id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, 
     &              uns_perm_ptr,
     &              id%CNTL(4), id%COLSCA,  id%ROWSCA
#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)         
     &              , id%METIS_OPTIONS(1)
#endif               
     &              , id%N, sizeofblocks, gcomp_provided, gcomp
     &          )              
                IF (gcomp_provided) CALL mumps_ab_free_gcomp(gcomp)
C
               ENDIF
               infog(7)     = keep(256)
C              UNS_PERM_PTR was only used locally
C              for the call to ZMUMPS_ANA_F
               NULLIFY(uns_perm_ptr)
            ELSE
               allocate( xnodel( id%N+1 ), stat = ierr )
               IF ( ierr .GT. 0 ) THEN
                  info( 1 ) = -7
                  info( 2 ) = id%N + 1
                  IF ( lpok ) THEN
                     WRITE(lp, 150) 'XNODEL'
                  END IF
                  GOTO 10
               ENDIF
               IF (leltvar.ne.id%ELTPTR(nelt+1)-1)  THEN
C     -- internal error
                  info(1) = -2002
                  info(2) = id%ELTPTR(nelt+1)-1
                  GOTO 10
               ENDIF
               allocate( nodel( leltvar ), stat = ierr )
               IF ( ierr .GT. 0 ) THEN
                  info( 1 ) = -7
                  info( 2 ) = leltvar
                  IF ( lpok ) THEN
                     WRITE(lp, 150) 'NODEL'
                  END IF
                  GOTO 10
               ENDIF
               CALL zmumps_ana_f_elt(id%N, nelt,
     &              id%ELTPTR(1), id%ELTVAR(1), liw_elt,
     &              ikeepalloc(1),
     &              keep(256), nfsizptr(1), filsptr(1),
     &              frereptr(1), id%LISTVAR_SCHUR(1),
     &              size_schur_passed,
     &              icntl(1), infog(1), keep(1),keep8(1),
     &              id%NSLAVES,
     &              xnodel(1), nodel(1)
#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)         
     &              , id%METIS_OPTIONS(1)
#endif               
     &          )
               infog(7)=keep(256)
C     
C              XNODEL and NODEL as output to ZMUMPS_ANA_F_ELT 
C              be used in ZMUMPS_FRTELT and thus 
C              cannot be deallocated at this point
C     
            ENDIF
            IF ( listvar_schur_2be_freed ) THEN
C              We do not want to have LISTVAR_SCHUR
C              allocated of size 1 if Schur is off. 
               DEALLOCATE( id%LISTVAR_SCHUR )
               NULLIFY   ( id%LISTVAR_SCHUR )
               listvar_schur_2be_freed = .true.
            ENDIF
C           ------------------------------
C           Significant error codes should
C           always be in INFO(1/2)
C           ------------------------------
            info(1)=infog(1)
            info(2)=infog(2)
C           save statistics in KEEP array.
            keep(28) = infog(6)
            ikeep = 1
            na      = ikeep +     id%N
            ne      = ikeep + 2 * id%N
C       -- if (id%myid.eq.master)
        ENDIF
C       -- if sequential analysis
      ENDIF
C
  10  CONTINUE
      IF (keep(244).EQ.1) THEN
         CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
         IF ( info(1) < 0 ) GOTO 500
      ENDIF
      IF ((keep(244).EQ.1).AND.(keep(55).EQ.0)) THEN
C     Sequential analysis on assembled matrix
C     check if  max transversal should be called
        CALL mpi_bcast(keep(23),1,mpi_integer,master,id%COMM,ierr)
        IF ( (keep(23).LE.-1).AND.(keep(23).GE.-6) ) THEN
C          -- Perform max transversal
           keep(23) = -keep(23)
           IF (id%MYID.EQ.master) THEN
             IF (.NOT. associated(id%A)) keep(23) = 1
             IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM)
             NULLIFY(id%UNS_PERM)
             IF (allocated(ikeepalloc)) DEALLOCATE(ikeepalloc)
             IF (associated(filsptr) ) THEN
               DEALLOCATE(filsptr)
               NULLIFY(filsptr)
             ENDIF
             IF (associated(frereptr) ) THEN
               DEALLOCATE(frereptr)
               NULLIFY(frereptr)
             ENDIF
             IF (associated(nfsizptr) ) THEN
               DEALLOCATE(nfsizptr)
               NULLIFY(nfsizptr)
             ENDIF
           ENDIF
        GOTO 1234
        ENDIF
      ENDIF
      IF (id%MYID.EQ.master) THEN
        IF ((keep(244).EQ.1).AND. (keep(55).EQ.0))  THEN
C              Sequential ordering on assembled matrix
               IF ((keep(54).EQ.3).AND.keep(494).EQ.0) THEN
                 IF (gather_matrix_allocated) THEN
                    IF (associated(id%IRN)) THEN
                      DEALLOCATE(id%IRN)
                      NULLIFY(id%IRN)
                    ENDIF
                    IF (associated(id%JCN)) THEN
                      DEALLOCATE(id%JCN)
                      NULLIFY(id%JCN)
                    ENDIF
                    gather_matrix_allocated= .false.
                 ENDIF
               ENDIF
        ENDIF
      ENDIF
      IF (keep(244).NE.1) THEN
C     Parallel analysis
         ikeep   = 1
         na      = ikeep +     id%N
         ne      = ikeep + 2 * id%N
         IF (id%MYID .EQ. master) THEN
            ALLOCATE( ikeepalloc(3*id%N), work2alloc(4*id%N), 
     &                filsptr(id%N), frereptr(id%N), nfsizptr(id%N),
     &      stat=ierr)
         ELSE
C           Because our purpose is to minimize the peak memory consumption,
C           we can afford to allocate on processes other than host
            ALLOCATE(ikeepalloc(3*id%N),work2alloc(4*id%N), stat=ierr )
         ENDIF
         IF (ierr.GT.0) THEN
           info(1) = -7
           IF (id%MYID .EQ. master) THEN
             info( 2 ) = 10*id%N 
           ELSE
             info( 2 ) = 7*id%N 
          ENDIF
         ENDIF
         CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
         IF ( info(1) < 0 ) GOTO 500
         CALL zmumps_ana_f_par(id,
     &        ikeepalloc,
     &        work2alloc,
     &        nfsizptr,
     &        filsptr,
     &        frereptr)
         DEALLOCATE(work2alloc) 
         IF(id%MYID .NE. master) THEN
           DEALLOCATE(ikeepalloc)
         ENDIF
         keep(28) = infog(6)
      END IF
C     Allocated PROCNODE on MASTER
      IF (id%MYID.EQ.master) THEN
       allocok = 0
       allocate(procnode(nblk), stat=allocok)
       IF (allocok .ne. 0) THEN
            info(1) = -7
            info(2) = nblk
       ENDIF
      ENDIF
      CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
      IF ( info(1) < 0 ) GOTO 500
      IF(id%MYID .EQ. master) THEN
C        Save ICNTL(14) value into KEEP(12)
         CALL mumps_get_perlu(keep(12),icntl(14),
     &        keep(50),keep(54),icntl(6),keep(52))
         CALL zmumps_ana_r(nblk, filsptr(1), frereptr(1),
     &        ikeepalloc(ne), ikeepalloc(na))
C      **********************************************************
C      Continue with CALL to MAPPING routine
C        *********************
C        BEGIN SEQUENTIAL CODE
C        No mapping computed
C        *********************
C
C        In sequential, if no special root
C        reset KEEP(20) and KEEP(38) to 0
C
         IF (id%NSLAVES .EQ. 1
     &      ) THEN
            id%NBSA = 0
            IF ( (id%KEEP(60).EQ.0).
     &           and.(id%KEEP(53).EQ.0))  THEN 
C     If Schur is on (keep(60).ne.0)
C     or if RR is on (keep (53) > 0 
C     then we keep root numbers
C              root node number in seq  
               id%KEEP(20)=0    
C              root node number in paral  
               id%KEEP(38)=0   
            ENDIF
C     No type 2 nodes:
            id%KEEP(56)=0
C     All mapped on MPI process 0, and of type TPN=0
C     (treated as if they were all root of subtree)
            procnode_value = mumps_encode_tpn_iproc(0, 0, keep(199))
            DO i = 1, nblk
              procnode(i) = procnode_value
            END DO
C     It may also happen that KEEP(38) has already been set,
C     in the case of a distributed Schur complement (KEEP(60)=2 or 3).
C     In that case, PROCNODE should be set accordingly and KEEP(38) is
C     not modified.
            IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN
               procnode_value = mumps_encode_tpn_iproc(3, 0, keep(199))
               CALL zmumps_set_procnode(id%KEEP(38), procnode(1),
     &              procnode_value, filsptr(1), nblk)
            ENDIF
C        *******************
C        END SEQUENTIAL CODE
C        *******************
         ELSE
C        *****************************
C        BEGIN MAPPING WITH CANDIDATES
C        (NSLAVES > 1)
C        *****************************
C     
C     
C      peak is set by default to 1 largest front + One largest CB
       peak = dble(id%INFOG(5))*dble(id%INFOG(5)) + ! front matrix
     &        dble(id%KEEP(2))*dble(id%KEEP(2))     ! cb bloc
C     IKEEP(1:N,1) can be used as a work space since it is set
C     to its final state by the SORT_PERM subroutine below.
            ssarbr => ikeepalloc(ikeep:ikeep+nblk-1)
C     ======================================================
C     Map nodes and assign candidates for dynamic scheduling
C     ======================================================
      IF ((keep(13).NE.0).AND.(nblk.NE.id%N)) THEN
       sizeofblocks_ptr => sizeofblocks(1:nblk)
       lsizeofblocks_ptr = nblk
      ELSE
       sizeofblocks_ptr => idummy_array
       lsizeofblocks_ptr = 1
       idummy_array(1) = -1
      ENDIF
            CALL zmumps_dist_avoid_copies(
     &           nblk,id%NSLAVES,icntl(1),
     &           infog(1),
     &           ikeepalloc(ne),
     &           nfsizptr(1),
     &           frereptr(1),
     &           filsptr(1),
     &           keep(1),keep8(1),procnode(1),
     &           ssarbr(1),id%NBSA,peak,ierr
     &           , sizeofblocks_ptr(1), lsizeofblocks_ptr 
     &           )
            NULLIFY(ssarbr)
            if(ierr.eq.-999) then 
               write(6,*) ' Internal error during static mapping '
               info(1) = ierr
               GOTO 11
            ENDIF
            IF(ierr.NE.0) THEN 
               info(1) = -135
               info(2) = ierr
               GOTO 11
            ENDIF
            CALL zmumps_ana_r(nblk, filsptr(1),
     &           frereptr(1), ikeepalloc(ne),
     &           ikeepalloc(na))
         ENDIF
 11      CONTINUE
      ENDIF
      CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
      IF ( info(1) < 0 ) GOTO 500
C     The following part is done in parallel
      CALL mpi_bcast( id%NELT, 1, mpi_integer, master,
     &     id%COMM, ierr )
      IF (keep(55) .EQ. 0) THEN
C     Assembled matrix format. Fill up the id%PTRAR array
C     Broadcast id%SYM_PERM needed to fill up id%PTRAR
C     postpone to after computation  of id%SYM_PERM 
C     computed after id%DAD_STEPS
         if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR)
         if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT)
         allocate( id%FRTPTR(1), id%FRTELT(1) ,stat=allocok)
         IF (allocok .GT. 0) THEN
            IF ( lpok ) THEN
               WRITE(lp, 150) 'FRTPTR,FRTELT'
            END IF
            info(1)= -7
            info(2)= 2
         END IF
      ELSE
C     Element Entry: 
C     -------------------------------
C     COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED
C     AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE
C     FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED.
C     
C     FRTPTR is an INTEGER array of length N+1 which need not be set by
C     the user. On output, FRTPTR(I) points in FRTELT to first element 
C     in the list of elements assigned to node I in the elimination tree.
C     
C     FRTELT is an INTEGER array of length NELT which need not be set by
C     the user. On output, positions FRTELT(FRTPTR(I)) to
C     FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to 
C     node I in the elimination tree.
C     
         lptrar = id%NELT+id%NELT+2
         CALL mumps_i8realloc(id%PTRAR, lptrar, id%INFO, lp,
     &        force=.true., string='id%PTRAR (Analysis)', errcode=-7)
         CALL mumps_realloc(id%FRTPTR, id%N+1, id%INFO, lp,
     &        force=.true., string='id%FRTPTR (Analysis)', errcode=-7)
         CALL mumps_realloc(id%FRTELT, id%NELT, id%INFO, lp,
     &        force=.true., string='id%FRTELT (Analysis)', errcode=-7)
         CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
         IF ( info(1) < 0 ) GOTO 500
         IF(id%MYID .EQ. master) THEN
C     In the elemental format case, PTRAR&friends are still
C     computed sequentially and then broadcasted
            CALL zmumps_frtelt(
     &           id%N, nelt, id%ELTPTR(nelt+1)-1, frereptr(1),
     &           filsptr(1),
     &           ikeepalloc(na), ikeepalloc(ne), xnodel, 
     &           nodel, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1))
            DO i=1, id%NELT+1
C              PTRAR declared 64-bit
               id%PTRAR(id%NELT+i+1)=int(id%ELTPTR(i),8)
            ENDDO
            DEALLOCATE(xnodel)
            DEALLOCATE(nodel)
         END IF
         CALL mpi_bcast( id%PTRAR(id%NELT+2), id%NELT+1, mpi_integer8,
     &        master, id%COMM, ierr )
         CALL mpi_bcast( id%FRTPTR(1), id%N+1, mpi_integer,
     &        master, id%COMM, ierr )
         CALL mpi_bcast( id%FRTELT(1), id%NELT,  mpi_integer,
     &        master, id%COMM, ierr )
      ENDIF
      CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
      IF ( info(1) < 0 ) GOTO 500
C     We switch again to sequential computations on the master node
      IF(id%MYID .EQ. master) THEN
         IF ( info( 1 ) .LT. 0 ) GOTO 12
         IF ( keep(55) .ne. 0 ) THEN
C        ---------------------------------------
C        Build ELTPROC: correspondance between elements and slave ranks
C        in COMM_NODES with special values -1 (all procs) and -2 and -3
C        (no procs). This is used later to distribute the elements on
C        the processes at the beginning of the factorisation phase
C        ---------------------------------------
            CALL zmumps_eltproc(nblk, nelt, id%ELTPROC(1),id%NSLAVES,
     &           procnode(1), id%KEEP(1))
         END IF
         nb_niv2 = keep(56)
         IF ( nb_niv2.GT.0 ) THEN
C     
            allocate(par2_nodes(nb_niv2),
     &           stat=allocok)
            IF (allocok .GT.0) then
               info(1)= -7
               info(2)= nb_niv2
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'PAR2_NODES'
               END IF
               GOTO 12
            END IF
         ENDIF
         IF ((nb_niv2.GT.0) .AND. (keep(24).EQ.0)) THEN
            iniv2 = 0
            DO 777 inode = 1, nblk
               IF ( ( frereptr(inode) .NE. nblk ) .AND.
     &              ( mumps_typenode(procnode(inode),id%KEEP(199))
     &              .eq. 2) ) THEN
                  iniv2 = iniv2 + 1
                  par2_nodes(iniv2) = inode
               END IF
 777        CONTINUE
            IF ( iniv2 .NE. nb_niv2 ) THEN
               WRITE(*,*) "Internal Error 2 in ZMUMPS_ANA_DRIVER",
     &              iniv2, nb_niv2
               CALL mumps_abort()
            ENDIF
         ENDIF
         IF ( (keep(24) .NE. 0) .AND. (nb_niv2.GT.0) ) THEN
C           allocate array to store cadidates stategy
C           for each level two nodes
            IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES)
            allocate( id%CANDIDATES(id%NSLAVES+1,nb_niv2),
     &           stat=allocok)
            if (allocok .gt.0) then
               info(1)= -7
               info(2)= nb_niv2*(id%NSLAVES+1)
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'CANDIDATES'
               END IF
               GOTO 12
            END IF
            CALL mumps_return_candidates
     &           (par2_nodes,id%CANDIDATES,
     &            ierr)
            IF(ierr.NE.0)  THEN
               info(1) = -2002
               GOTO 12
            ENDIF
C     deallocation of variables of module mumps_static_mapping
            CALL mumps_end_arch_cv()
            IF(ierr.NE.0)  THEN
               info(1) = -2002
               GOTO 12
            ENDIF
         ELSE
            IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES)
            allocate(id%CANDIDATES(1,1), stat=allocok)
            IF (allocok .NE. 0) THEN
               info(1)= -7
               info(2)= 1
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'CANDIDATES'
               END IF
               GOTO 12
            ENDIF
         ENDIF
C*******************************************************************
C     ---------------
 12      CONTINUE
C     ---------------
*     
*     ===============================
*     End of analysis phase on master
*     ===============================
*     
      END IF
      CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
      IF ( info(1) < 0 ) GOTO 500
C     
C     We now allocate and compute arrays in NSTEPS
C     on the master, as this makes more sense.
C     
C     Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP
      CALL mpi_bcast( id%KEEP8(101), 1, mpi_integer8, master,
     &     id%COMM, ierr )
C
C     ==============================
C     PREPARE DATA FOR FACTORIZATION
C     ==============================
C     ------------------
      CALL mpi_bcast( id%KEEP(1), 110, mpi_integer, master,
     &     id%COMM, ierr )
C     We also need to broadcast KEEP8(21) 
      CALL mpi_bcast( id%KEEP8(21), 1, mpi_integer8, master,
     &     id%COMM, ierr )
C     --------------------------------------------------
C     Broadcast KEEP(205) which is outside the first 110
C     KEEP entries but is needed for factorization.
C     --------------------------------------------------
      CALL mpi_bcast( id%KEEP(205), 1, mpi_integer, master,
     &     id%COMM, ierr )
C     --------------
C     Broadcast NBSA 
      CALL mpi_bcast( id%NBSA, 1, mpi_integer, master,
     &     id%COMM, ierr )
C     -----------------
C     Global MAXFRT (computed in ZMUMPS_ANA_M)
C     is needed on all the procs during ZMUMPS_ANA_DISTM
C     to evaluate workspace for solve. 
C     We could also recompute it in ZMUMPS_ANA_DISTM
      IF (id%MYID==master) keep(127)=infog(5)
      CALL mpi_bcast( id%KEEP(127), 1, mpi_integer, master,
     &     id%COMM, ierr )
C     -----------------
C     Global max panel size KEEP(226)
      CALL mpi_bcast( id%KEEP(226), 1, mpi_integer, master,
     &     id%COMM, ierr )
C     -----------------
      CALL mpi_bcast( id%KEEP(464), 2, mpi_integer, master,
     &     id%COMM, ierr )
      CALL mpi_bcast( id%KEEP(471), 2, mpi_integer, master,
     &     id%COMM, ierr )
      CALL mpi_bcast( id%KEEP(475), 1, mpi_integer, master,
     &     id%COMM, ierr )
      CALL mpi_bcast( id%KEEP(482), 1, mpi_integer, master,
     &     id%COMM, ierr )
      CALL mpi_bcast( id%KEEP(487), 2, mpi_integer, master,
     &     id%COMM, ierr )
C     Number of leaves not belonging to L0 KEEP(262)
C              and KEEP(263) : inner or outer sends for blocked facto
      CALL mpi_bcast( id%KEEP(262), 2, mpi_integer, master,
     &     id%COMM, ierr )
C     ----------------------------------------
C     Allocate new workspace on all processors
C     ----------------------------------------
      IF (id%MYID.EQ.master) THEN
C        id%STEP is of size NBLK because it 
C                is computed on compressed graph and then extended
C                and broadcasted on all procs
        CALL mumps_realloc(id%STEP, nblk, id%INFO, lp, force=.true.,
     &     string='id%STEP (Analysis)', errcode=-7)
      ELSE
C        id%STEP is of size id%N because it 
C                is received in extended form
        CALL mumps_realloc(id%STEP, id%N, id%INFO, lp, force=.true.,
     &     string='id%STEP (Analysis)', errcode=-7)
      ENDIF
      IF(info(1).LT.0) GOTO 94
      CALL mumps_realloc(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, lp,
     &     force=.true.,
     &     string='id%PROCNODE_STEPS (Analysis)', errcode=-7)
      IF(info(1).LT.0) GOTO 94
      CALL mumps_realloc(id%NE_STEPS, id%KEEP(28), id%INFO, lp, 
     &     force=.true., 
     &     string='id%NE_STEPS (Analysis)', errcode=-7)
      IF(info(1).LT.0) GOTO 94
      CALL mumps_realloc(id%ND_STEPS, id%KEEP(28), id%INFO, lp,
     &     force=.true., 
     &     string='id%ND_STEPS (Analysis)', errcode=-7)
      IF(info(1).LT.0) GOTO 94
      CALL mumps_realloc(id%FRERE_STEPS, id%KEEP(28), id%INFO, lp,
     &     force=.true., 
     &     string='id%FRERE_STEPS (Analysis)', errcode=-7)
      IF(info(1).LT.0) GOTO 94
      CALL mumps_realloc(id%DAD_STEPS, id%KEEP(28), id%INFO, lp, 
     &     force=.true., 
     &     string='id%DAD_STEPS (Analysis)', errcode=-7)
      IF(info(1).LT.0) GOTO 94
C     id%FILS is allocated before expand tree
      IF (keep(55) .EQ. 0) THEN
        lptrar = id%N+id%N
        CALL mumps_i8realloc(id%PTRAR, lptrar, id%INFO, lp,
     &       force=.true., string='id%PTRAR (Analysis)', errcode=-7)
        IF(info(1).LT.0) GOTO 94
      ENDIF
      IF (id%MYID.EQ.master) THEN
       CALL mumps_realloc(id%LRGROUPS, nblk, id%INFO, lp, 
     &     force=.true.
     &     ,string='id%LRGROUPS (Analysis)', errcode=-7)
      ELSE
       CALL mumps_realloc(id%LRGROUPS, id%N, id%INFO, lp, 
     &     force=.true.
     &     ,string='id%LRGROUPS (Analysis)', errcode=-7)
      ENDIF
      IF(info(1).LT.0) GOTO 94
C     Copy data for factorization and/or solve.
C     ================================
C     COMPUTE ON THE MASTER, BROADCAST
C     TO OTHER PROCESSES
C     ================================
      IF ( id%MYID .NE. master .OR. id%KEEP(23) .EQ. 0 ) THEN
       IF ( associated( id%UNS_PERM ) ) THEN
         DEALLOCATE(id%UNS_PERM)
       ENDIF
      ENDIF
 94   CONTINUE
      CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
      IF ( id%MYID .EQ. master ) THEN
C     NA -> compressed NA containing only list
C     of leaves of the elimination tree and list of roots 
C     (the two useful informations for factorization/solve).
         IF (nblk.eq.1) THEN
            nbroot = 1
            nbleaf = 1
         ELSE IF (ikeepalloc(na+nblk-1) .LT.0) THEN
            nbleaf= nblk
            nbroot= nblk
         ELSE IF (ikeepalloc(na+nblk-2) .LT.0) THEN
            nbleaf = nblk-1
            nbroot = ikeepalloc(na+nblk-1)
         ELSE
            nbleaf = ikeepalloc(na+nblk-2)
            nbroot = ikeepalloc(na+nblk-1)
         ENDIF
         id%LNA = 2+nbleaf+nbroot
      ENDIF
      CALL mpi_bcast( id%LNA, 1, mpi_integer,
     &     master, id%COMM, ierr )
      CALL mumps_realloc(id%NA, id%LNA, id%INFO, lp, force=.true., 
     &     string='id%NA (Analysis)', errcode=-7)
      CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
      IF ( info(1).LT.0 ) GOTO 500
      IF (id%MYID .EQ.master ) THEN
C{    The structure of NA is the following:
C        NA(1) is the number of leaves.
C        NA(2) is the number of roots.
C        NA(3:2+NA(1)) are the leaves.
C        NA(3+NA(1):2+NA(1)+NA(2)) are the roots.
         id%NA(1) = nbleaf
         id%NA(2) = nbroot
C     
C        Initialize NA with the leaves and roots
         leaf = 3
         IF ( nblk == 1 ) THEN
            id%NA(leaf) = 1
            leaf = leaf + 1
         ELSE IF (ikeepalloc(na+nblk-1) < 0) THEN
            id%NA(leaf) = - ikeepalloc(na+nblk-1)-1
            leaf = leaf + 1
            DO i = 1, nbleaf - 1
               id%NA(leaf) = ikeepalloc(na+i-1)
               leaf = leaf + 1
            ENDDO
         ELSE IF (ikeepalloc(na+nblk-2) < 0 ) THEN
            inode = - ikeepalloc(na+nblk-2) - 1
            id%NA(leaf) = inode
            leaf =leaf + 1
            IF ( nbleaf > 1 ) THEN
               DO i = 1, nbleaf - 1
                  id%NA(leaf) = ikeepalloc(na+i-1)
                  leaf = leaf + 1
               ENDDO
            ENDIF
         ELSE
            DO i = 1, nbleaf
               id%NA(leaf) = ikeepalloc(na+i-1)
               leaf = leaf + 1
            ENDDO
         END IF
C
C        Build array STEP(1:id%N) to hold step numbers in
C        range 1..id%KEEP(28), allowing compression of
C        other arrays from id%N to id%KEEP(28)
C        (the number of nodes/steps in the assembly tree)
         istep = 0
         DO i = 1, nblk
            IF ( frereptr(i) .ne. nblk + 1 ) THEN
C        New node in the tree.
c        (Set step( inode_n ) = inode_nsteps for principal
C        variables and -inode_nsteps for internal variables
C        of the node)
               istep = istep + 1
               id%STEP(i)=istep
               inn = filsptr(i)
               DO WHILE ( inn .GT. 0 )
                  id%STEP(inn) = - istep
                  inn = filsptr(inn)
               END DO
               IF (frereptr(i) .eq. 0) THEN
C              Keep root nodes list in NA
                  id%NA(leaf) = i
                  leaf = leaf + 1
               ENDIF
            ENDIF
         END DO
         IF ( leaf - 1 .NE. 2+nbroot + nbleaf ) THEN
            WRITE(*,*) 'Internal error 2 in ZMUMPS_ANA_DRIVER'
            CALL mumps_abort()
         ENDIF
         IF ( istep .NE. id%KEEP(28) ) THEN
            write(*,*) 'Internal error 3 in ZMUMPS_ANA_DRIVER', 
     &        istep, id%KEEP(28)
            CALL mumps_abort()
         ENDIF
C        ============
C        SET PROCNODE, FRERE, NE
C        ============
C        copies to NSTEP array should be ok
         DO i = 1, nblk
            IF (frereptr(i) .NE. nblk+1) THEN
               id%PROCNODE_STEPS(id%STEP(i)) = procnode( i )
               id%FRERE_STEPS(id%STEP(i))    = frereptr(i)
               id%NE_STEPS(id%STEP(i))    = ikeepalloc(ne+i-1)
               id%ND_STEPS(id%STEP(i))    = nfsizptr(i)
            ENDIF
         ENDDO
C        ===============================
C        Algorithm to compute array DAD_STEPS:
C        ----
C        For each node set dad for all of its sons
C        plus, for root nodes set dad to zero.
C     
C        ===============================
         DO i = 1, nblk
C     -- skip non principal nodes
            IF ( id%STEP(i) .LE. 0) cycle
C     -- (I) is a principal node
            IF (frereptr(i) .eq. 0) THEN
C     -- I is a root node and has no father
               id%DAD_STEPS(id%STEP(i)) = 0
            ENDIF
C     -- Find first son node (IFS)
            ifs = filsptr(i)
            DO WHILE ( ifs .GT. 0 )
               ifs= filsptr(ifs)
            END DO
C     -- IFS > 0 if I is not a leave node
C     -- Go through list of brothers of IFS if any
            ifs = -ifs
            DO WHILE (ifs.GT.0) 
C     -- I is not a leave node and has a son node IFS
               id%DAD_STEPS(id%STEP(ifs)) = i
               ifs   = frereptr(ifs)
            ENDDO
         END DO
C
C     
C        Following arrays (PROCNODE and IKEEPALLOC) not used anymore 
C        during analysis
         IF (allocated(procnode)) DEALLOCATE(procnode)
         IF (allocated(ikeepalloc)) DEALLOCATE(ikeepalloc)
         IF (associated(frereptr)) DEALLOCATE(frereptr)
         NULLIFY(frereptr)
         IF (associated(nfsizptr)) DEALLOCATE(nfsizptr)
         NULLIFY(nfsizptr)
      ENDIF 
      IF (keep(494).NE.0) THEN
C{
         IF (id%MYID.EQ.master) THEN
            IF (prokg) THEN
                  CALL mumps_secdeb(timeg)
            END IF
         ENDIF
C     =======================================================
C     Compute a grouping of variables for LR approximations.
C     Grouping may be performed on a distributed matrix
C     =======================================================
C     
C     I/ Prepare data before call to grouping
        IF ((keep(54).EQ.3).AND.(keep(13).NE.0)) THEN
C         Matrix is distributed on entry and compression computed
          IF (keep(487).NE.1) CALL mumps_abort()
          ALLOCATE(mapcol(id%KEEP(28)), stat=allocok)
          IF (allocok .ne.0) then
           info(1)= -7
           info(2)= id%KEEP(28)
          ENDIF
C         Broadcast errors
          CALL mumps_propinfo( icntl(1), info(1),
     &      id%COMM, id%MYID )
          IF ( info(1).LT.0 ) GOTO 500
C
          CALL mumps_inialize_redist_lumat ( 
     &     id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, nblk,
     &     lumat, id%PROCNODE_STEPS(1), id%KEEP(28), mapcol, 
     &     lumat_remap, nbrecords, id%STEP(1))
C         INFO(1) has been broadcasted already in routine
          IF ( id%INFO(1).LT.0 ) GOTO 500
C
C         -- Redistribute LUMAT into LU_REMAP relying on procnode
          CALL mumps_ab_dist_lmat_to_lumat ( 
     &      .false., ! do not UNFOLD
     &      .true.,  ! MAPCOL in NSTEPS=> STEP array needed 
     &      id%INFO, id%ICNTL, id%COMM, id%MYID, nblk, id%NPROCS,
     &      lumat, mapcol, id%KEEP(28), id%STEP(1), nblk,
     &      lumat_remap, nbrecords, nsend8, nlocal8
     &     )
          CALL mumps_ab_free_lmat(lumat)
C         Distribute SIZEOFBLOCKS that was defined only on master
          CALL mpi_bcast( sizeofblocks, nblk, mpi_integer, master, 
     &     id%COMM, ierr )
C
        ELSE IF ((keep(54).NE.3).AND.(keep(13).NE.0)
     &         .AND. (keep(487).EQ.1) ) THEN
C         Centralized matrix and LMAT_BLOCK available
C         ---> build LUMAT_REMAP on MASTER
          IF (id%MYID.EQ.master) THEN
           CALL mumps_ab_lmat_to_lumat ( 
     &              lmat_block, lumat_remap,
     &              info(1), icntl(1))
C            --- LMAT_BLOCK not needed anymore
           CALL mumps_ab_free_lmat(lmat_block)
          ENDIF
C         Broadcast errors
          CALL mumps_propinfo( icntl(1), info(1),
     &      id%COMM, id%MYID )
          IF ( info(1).LT.0 ) GOTO 500
C
        ELSE IF ((keep(54).EQ.3).AND.(keep(13).EQ.0)
     &           .AND. keep(487).EQ.1) THEN
C        Matrix is distributed on entry and compression not requested
C        (this will be the case when ICNTL(15).EQ.0 and 
C         // analysis, or Schur, etc...)
C        note that with distributed matrix and centralized ordering
C        compression is forced to limit memory peak)
C        Free centralized matrix before grouping to 
C        limit memory peak
         IF (gather_matrix_allocated) THEN
             IF (associated(id%IRN)) THEN
                      DEALLOCATE(id%IRN)
                      NULLIFY(id%IRN)
             ENDIF
             IF (associated(id%JCN)) THEN
                      DEALLOCATE(id%JCN)
                      NULLIFY(id%JCN)
             ENDIF
             gather_matrix_allocated= .false.
         ENDIF
         IF (.NOT. i_am_slave .OR. ! non-working master
     &       id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc
C          Master non-working
           irn_loc_ptr => idummy_array
           jcn_loc_ptr => idummy_array
         ELSE
           irn_loc_ptr => id%IRN_loc
           jcn_loc_ptr => id%JCN_loc
         ENDIF
         ALLOCATE(mapcol(id%KEEP(28)), stat=allocok)
         IF (allocok .ne.0) then
           info(1)= -7
           info(2)= id%KEEP(28)
         ENDIF
C        Broadcast errors
         CALL mumps_propinfo( icntl(1), info(1),
     &      id%COMM, id%MYID )
         IF ( info(1).LT.0 ) GOTO 500
C
C        Build MAPCOL and LUMAT_REMAP mapped according 
C        to MAPCOL (outputs available on all MPI procs).
         CALL mumps_ab_dcoord_to_dtree_lumat ( 
     &          id%MYID, id%NPROCS, id%COMM, 
     &          nblk, id%N,
     &          id%KEEP8(29),  ! => NNZ_loc or NZ_loc
     &          irn_loc_ptr(1), jcn_loc_ptr(1), 
     &          id%PROCNODE_STEPS(1), id%KEEP(28), id%STEP(1),
     &          id%ICNTL(1), id%INFO(1), id%KEEP(1),
     &          mapcol, lumat_remap )
         IF (info(1).GE.0) THEN
C         SIZEOFBLOCKS needed on all procs during MPI grouping
          ALLOCATE(sizeofblocks(nblk), stat=allocok)
          IF (allocok .ne.0) then
           info(1)= -7
           info(2)= nblk
          ENDIF
          DO i=1, nblk
            sizeofblocks(i) = 1
          ENDDO
         ENDIF
C        Broadcast errors
         CALL mumps_propinfo( icntl(1), info(1),
     &      id%COMM, id%MYID )
         IF ( info(1).LT.0 ) GOTO 500
        ELSE IF ((keep(54).EQ.3) .AND. (keep(244).EQ.2)
     &       .AND.  (keep(487).NE.1) 
     &     ) THEN
C        Grouping preparation on slaves:
C        If the input matrix is distributed and the parallel analysis is
C        chosen, the graph used to be centralized in order to compute the
C        clustering. 
C
            CALL zmumps_gather_matrix(id)
            gather_matrix_allocated = .true.
        ENDIF
C     ============
C     ============
C     II/ GROUPING
C     ============
        IF ((keep(54).EQ.3).AND.(keep(487).EQ.1)) THEN
C         Matrix is distributed on entry and halo of size 1
C         Distributed memory based grouping is used
          IF (id%MYID.NE.master) THEN
            ALLOCATE(filsptr(nblk), stat=ierr)
            IF (ierr.GT.0) THEN
             info(1)=-7
             info(2)=nblk
            ENDIF
          ENDIF
C         Broadcast errors
          CALL mumps_propinfo( icntl(1), info(1),
     &      id%COMM, id%MYID )
          IF ( info(1).LT.0 ) GOTO 500
C         Distribute SIZEOFBLOCKS that was defined only on master
C          CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, 
C     &     id%COMM, IERR )
          CALL zmumps_ab_lr_mpi_grouping(nblk, 
     &           mapcol, id%KEEP(28), 
     &           id%KEEP(28), lumat_remap, filsptr, 
     &           id%FRERE_STEPS,
     &           id%DAD_STEPS, id%STEP, id%NA,
     &           id%LNA, id%LRGROUPS, sizeofblocks(1), id%KEEP(50),
     &           id%ICNTL(1), id%KEEP(487), id%KEEP(488),
     &           id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), 
     &           id%INFO(1), id%INFO(2),
     &           id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
     &           id%KEEP(127), id%KEEP(469), id%KEEP(10), 
     &           id%KEEP(54), id%KEEP(142), 
     &           lpok, lp, id%COMM, id%MYID, id%NPROCS)
          IF (allocated(mapcol)) DEALLOCATE(mapcol)
          IF (id%MYID.NE.master) THEN
            DEALLOCATE(filsptr)
            NULLIFY(filsptr)
          ENDIF
C
        ELSE IF (id%MYID.EQ.master) THEN
            IF ((keep(54).NE.3).AND.(keep(13).NE.0)
     &         .AND. (keep(487).EQ.1) ) THEN
C            Centralized matrix and LMAT_BLOCK available
C            --- build LUMAT
C            -- LR grouping exploiting LUMAT
C            -- centralized => MAPCOL not needed
C
             idummy_array(1) = -1
             CALL zmumps_ab_lr_grouping(nblk, 
     &           idummy_array, 1,
     &           id%KEEP(28), lumat_remap, filsptr, 
     &           id%FRERE_STEPS,
     &           id%DAD_STEPS, id%STEP, id%NA,
     &           id%LNA, id%LRGROUPS, sizeofblocks(1), id%KEEP(50),
     &           id%ICNTL(1), id%KEEP(487), id%KEEP(488),
     &           id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), 
     &           id%INFO(1), id%INFO(2),
     &           id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
     &           id%KEEP(127), id%KEEP(469), id%KEEP(10), 
     &           id%KEEP(54), id%KEEP(142), 
     &           lpok, lp, id%MYID, id%COMM)
            ELSE
C            grouping based on centralized matrix
             IF (keep(469).EQ.0) THEN
               CALL zmumps_lr_grouping(id%N, id%KEEP8(28), id%KEEP(28),
     &           id%IRN,
     &           id%JCN, filsptr, id%FRERE_STEPS,
     &           id%DAD_STEPS, id%NE_STEPS, id%STEP, id%NA,
     &           id%LNA, id%LRGROUPS,
     &           id%KEEP(50),
     &           id%ICNTL(1), id%KEEP(487), id%KEEP(488), 
     &           id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60),
     &           id%INFO(1), id%INFO(2),
     &           id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
     &           id%KEEP(127), id%KEEP(10), 
     &           id%KEEP(54), id%KEEP(142), 
     &           lpok, lp, gather_matrix_allocated)
             ELSE
               CALL zmumps_lr_grouping_new(id%N, id%KEEP8(28), 
     &           id%KEEP(28), id%IRN,
     &           id%JCN, filsptr, id%FRERE_STEPS,
     &           id%DAD_STEPS, id%STEP, id%NA,
     &           id%LNA, id%LRGROUPS, id%KEEP(50),
     &           id%ICNTL(1), id%KEEP(487), id%KEEP(488),
     &           id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), 
     &           id%INFO(1), id%INFO(2),
     &           id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
     &           id%KEEP(127), id%KEEP(469), id%KEEP(10), 
     &           id%KEEP(54), id%KEEP(142), 
     &           lpok, lp, gather_matrix_allocated)
             ENDIF
            ENDIF
        ENDIF
        CALL mpi_bcast( keep(142), 1, mpi_integer, master, 
     &                      id%COMM, ierr )
C     ============
C     III/ CLEANUP 
C     ============
C       Free LUMAT_REMAP is allocated
        CALL mumps_ab_free_lmat(lumat_remap)
        IF (allocated(mapcol)) DEALLOCATE(mapcol)
        IF (allocated(sizeofblocks)) DEALLOCATE(sizeofblocks)
        IF ( (keep(54).EQ.3) .AND. (keep(244).EQ.2).AND.
     &       (keep(487).NE.1) ) THEN
C           Cleanup the irn and jcn arrays filled up by the
C           cmumps_gather_matrix above. It might have been done
C           during grouping
            IF (gather_matrix_allocated) THEN
                IF (associated(id%IRN)) THEN
                  DEALLOCATE(id%IRN)
                  NULLIFY(id%IRN)
                ENDIF
                IF (associated(id%JCN)) THEN
                  DEALLOCATE(id%JCN)
                  NULLIFY(id%JCN)
                ENDIF
                gather_matrix_allocated= .false.
            ENDIF
        END IF
        IF (prokg) THEN
          CALL mumps_secfin(timeg)
          WRITE(mpg,145) timeg
        END IF
C}    Grouping: KEEP(494) .NE. 0
      ENDIF
      IF (id%MYID.NE. master) THEN
        CALL mumps_realloc(id%FILS, id%N, id%INFO, lp, force=.true.,
     &     string='id%FILS (Analysis)', errcode=-7)
        IF(info(1).LT.0) GOTO 97
      ENDIF
C
      IF ((id%MYID.EQ.master) .AND.(keep(13).NE.0)) THEN
C{      ===========
C       Expand tree  
C       ===========
C       Current tree is relative to the analysis by block.
C       Expand the tree on the master if compression is effective
C       (in all cases, grouping done or not)
          IF (nblk.LT.id%N.OR.(.NOT.blkvar_allocated)) THEN
C         even if NBLK.EQ.N BLKVAR provided by user might hold
C         a permutation of the variables and this expand_tree_steps 
C         should also be called
C           Expand FILSPTR, id%STEP into id%FILS, STEPPTR
C           and update arrays of size NSTEPS
            ALLOCATE(stepptr(id%N), lrgroupsptr(id%N), stat=ierr)
            IF (ierr.GT.0) THEN
             info(1)=-7
             info(2)=id%N
             GOTO 97
            ENDIF
            IF (nb_niv2.EQ.0) THEN
               idummy_array(1)   = -9999
               par2_nodesptr     => idummy_array(1:1)
               size_par2_nodesptr=1
            ELSE
               par2_nodesptr => par2_nodes(1:nb_niv2)
               size_par2_nodesptr=nb_niv2
            ENDIF
            CALL mumps_realloc(id%FILS, id%N, id%INFO, lp, 
     &           force=.true.,
     &           string='id%FILS (Analysis)', errcode=-7)
            IF(info(1).LT.0) GOTO 97
            CALL zmumps_expand_tree_steps (id%ICNTL,
     &        id%N, nblk, id%BLKPTR(1), id%BLKVAR(1), 
     &        filsptr(1), id%FILS(1), id%KEEP(28),
     &        id%STEP(1), stepptr(1),
     &        par2_nodesptr(1), size_par2_nodesptr,
     &        id%DAD_STEPS(1), id%FRERE_STEPS(1), 
     &        id%NA(1), id%LNA, id%LRGROUPS(1), lrgroupsptr(1), 
     &        id%KEEP(20), id%KEEP(38)
     &           ) 
            NULLIFY(par2_nodesptr)
            DEALLOCATE(id%STEP)
            id%STEP=>stepptr
            NULLIFY(stepptr)
            DEALLOCATE(id%LRGROUPS)
            id%LRGROUPS=>lrgroupsptr
            NULLIFY(lrgroupsptr)
            DEALLOCATE(filsptr)
            NULLIFY(filsptr)
          ELSE
           if (associated(id%FILS)) DEALLOCATE(id%FILS)
           id%FILS=>filsptr
           NULLIFY(filsptr)
          ENDIF
C}
      ENDIF
      IF ((id%N.EQ.nblk).AND.associated(filsptr)) THEN
C          id%FILS has not been initialized
           if (associated(id%FILS)) DEALLOCATE(id%FILS)
           id%FILS=>filsptr
           NULLIFY(filsptr)
      ENDIF
 97   CONTINUE
       CALL mumps_realloc(id%SYM_PERM, id%N, id%INFO, lp, 
     &     force=.true.,
     &     string='id%SYM_PERM (Analysis)', errcode=-7)
      CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
          IF ( info(1) < 0 ) GOTO 500
      IF (id%MYID.EQ.master) THEN
C     =================================================================
C     Reorder the tree using a variant of Liu's algorithm. Note that
C     REORDER_TREE MUST always be called since it sorts NA (the list of
C     leaves) in a valid order in the sense of a depth-first traversal.
C     =================================================================
               CALL zmumps_reorder_tree(id%N, id%FRERE_STEPS(1),
     &              id%STEP(1),id%FILS(1), id%NA(1), id%LNA,
     &              id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), 
     &              id%KEEP(28), .true., id%KEEP(28), id%KEEP(70),
     &              id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215),
     &              id%KEEP(234), id%KEEP(55), id%KEEP(199),
     &              id%PROCNODE_STEPS(1),id%NSLAVES,peak,id%KEEP(90)
     &              )
            IF(id%KEEP(261).EQ.1)THEN
               CALL mumps_sort_step(id%N, id%FRERE_STEPS(1),
     &              id%STEP(1),id%FILS(1), id%NA(1), id%LNA,
     &              id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), 
     &              id%KEEP(28), .true., id%KEEP(28), id%INFO(1),
     &              id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES
     &              )
            ENDIF
C     Compute and export some global information on the tree needed by
C     dynamic schedulers during the factorization. The type of
C     information depends on the selected strategy.
         IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR.
     &              (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0)
     &              .AND.(id%KEEP(47).GE.2)))THEN
            is_build_load_mem_called=.true.
            IF ((id%KEEP(47) .EQ. 4).OR.
     &           (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN
               IF(id%NSLAVES.GT.1) THEN
C                 NBSA is the total number of subtrees  and
C                 is an upperbound of the local number of
C                 subtrees
                  size_temp_mem = id%NBSA
               ELSE
C                 Only one processor, NA(2) is the number of leaves
                  size_temp_mem = id%NA(2)
               ENDIF
            ELSE
               size_temp_mem = 1
            ENDIF
            IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN
               size_depth_first=id%KEEP(28)
            ELSE
               size_depth_first=1
            ENDIF
            allocate(temp_mem(size_temp_mem,id%NSLAVES),stat=allocok) 
            IF (allocok .NE.0) THEN
               info(1)= -7
               info(2)= size_temp_mem*id%NSLAVES
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'TEMP_MEM'
               END IF
               GOTO 80 !! FIXME propagate error
            END IF
            allocate(temp_leaf(size_temp_mem,id%NSLAVES),
     &           stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'TEMP_LEAF'
               END IF
               info(1)= -7
               info(2)= size_temp_mem*id%NSLAVES
               GOTO 80 !! FIXME propagate error
            end if
            allocate(temp_size(size_temp_mem,id%NSLAVES),
     &           stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'TEMP_SIZE'
               END IF
               info(1)= -7
               info(2)= size_temp_mem*id%NSLAVES
               GOTO 80
            end if
            allocate(temp_root(size_temp_mem,id%NSLAVES),
     &           stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'TEMP_ROOT'
               END IF
               info(1)= -7
               info(2)= size_temp_mem*id%NSLAVES
               GOTO 80
            end if
            allocate(depth_first(size_depth_first),stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'DEPTH_FIRST'
               END IF
               info(1)= -7
               info(2)= size_depth_first
               GOTO 80
            end if
            ALLOCATE(depth_first_seq(size_depth_first),stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'DEPTH_FIRST_SEQ'
               END IF
               info(1)= -7
               info(2)= size_depth_first
               GOTO 80
            end if
            ALLOCATE(sbtr_id(size_depth_first),stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'SBTR_ID'
               END IF
               info(1)= -7
               info(2)= size_depth_first
               GOTO 80
            end if
            IF(id%KEEP(76).EQ.5)THEN
C     We reuse the same variable as before
               size_cost_trav=id%KEEP(28)
            ELSE
               size_cost_trav=1
            ENDIF
            allocate(cost_trav_tmp(size_cost_trav),stat=allocok) 
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'COST_TRAV_TMP'
               END IF
               info(1)= -7
               info(2)= size_cost_trav
               GOTO 80
            END IF
            IF(id%KEEP(76).EQ.5)THEN
               IF(id%KEEP(70).EQ.0)THEN
                  id%KEEP(70)=5
               ENDIF
               IF(id%KEEP(70).EQ.1)THEN
                  id%KEEP(70)=6
               ENDIF
            ENDIF
            IF(id%KEEP(76).EQ.4)THEN
               IF(id%KEEP(70).EQ.0)THEN
                  id%KEEP(70)=3
               ENDIF
               IF(id%KEEP(70).EQ.1)THEN
                  id%KEEP(70)=4
               ENDIF
            ENDIF
            CALL zmumps_build_load_mem_info(id%N, id%FRERE_STEPS(1),
     &           id%STEP(1),id%FILS(1), id%NA(1), id%LNA,
     &           id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1),
     &           id%KEEP(28), .true., id%KEEP(28), id%KEEP(70),
     &           id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47),
     &           id%KEEP(81),id%KEEP(76),id%KEEP(215),
     &           id%KEEP(234), id%KEEP(55), id%KEEP(199),
     &           id%PROCNODE_STEPS(1),temp_mem,id%NSLAVES,
     &           size_temp_mem, peak,id%KEEP(90),size_depth_first,
     &           size_cost_trav,depth_first(1),depth_first_seq(1),
     &           cost_trav_tmp(1),
     &           temp_leaf,temp_size,temp_root,sbtr_id(1)
     &              )
         END IF
      ENDIF
      IF (id%MYID.EQ.master) THEN
         CALL zmumps_sort_perm(id%N, id%NA(1), id%LNA,
     &        id%NE_STEPS(1), id%SYM_PERM(1),
     &        id%FILS(1), id%DAD_STEPS(1),
     &        id%STEP(1), id%KEEP(28), 
     &        id%KEEP(60), id%KEEP(20), id%KEEP(38),
     &        id%INFO(1) )
      ENDIF
C     Root principal variable
C     for scalapack (KEEP(38)) or special serial root (KEEP(20))
C     might have been updated
C     since root variables might have been permuted
C     and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph
C     It should thus be redistributed to all procs
      IF ( keep(494).NE.0 .OR. keep(13).NE.0 ) THEN
C       Value of KEEP(20) and KEEP(38) on master is always correct
C       + non-zero status is identical on all procs since 110 first
C       KEEP entries have been broadcasted
        IF (keep(38) .NE. 0) THEN
          CALL mpi_bcast( id%KEEP(38), 1, mpi_integer, master,
     &      id%COMM, ierr )
        ENDIF
        IF (keep(20) .NE. 0) THEN
          CALL mpi_bcast( id%KEEP(20), 1, mpi_integer, master,
     &      id%COMM, ierr )
        ENDIF
      ENDIF
 80   CONTINUE
C     Broadcast errors
      CALL mumps_propinfo( icntl(1), info(1),
     &     id%COMM, id%MYID )
      IF ( info(1).LT.0 ) GOTO 500
C     ---------------------------------------------------
C     Broadcast information computed on the master to
C     the slaves.
C     The matrix itself with numerical values and
C     integer data for the arrowhead/element description 
C     will be received at the beginning of FACTO.
C     ---------------------------------------------------
      CALL mpi_bcast( id%FILS(1), id%N, mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%NA(1), id%LNA, mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%STEP(1), id%N, mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%PROCNODE_STEPS(1), id%KEEP(28), mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%DAD_STEPS(1), id%KEEP(28), mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%FRERE_STEPS(1), id%KEEP(28), mpi_integer,
     &     master, id%COMM, ierr)
      CALL mpi_bcast( id%NE_STEPS(1), id%KEEP(28), mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%ND_STEPS(1), id%KEEP(28), mpi_integer,
     &     master, id%COMM, ierr )
      CALL mpi_bcast( id%SYM_PERM(1), id%N, mpi_integer,
     &     master, id%COMM, ierr )
      IF(keep(494).NE.0) THEN
            CALL mpi_bcast( id%LRGROUPS(1), id%N, mpi_integer,
     &           master, id%COMM, ierr )
      END IF
      IF (keep(55) .EQ. 0) THEN
C     Assembled matrix format. Fill up the id%PTRAR array
C     Broadcast id%SYM_PERM needed to fill up id%PTRAR
C     At the end of ANA_N_DIST, id%PTRAR is already on every processor
C     because it is computed in a distributed way.
C     No need to broadcast it again
         CALL zmumps_ana_n_dist(id, id%PTRAR)
         IF(id%MYID .EQ. master) THEN
C           -----------------------------------
C           For distributed structure on entry,
C           we can now deallocate the complete
C           structure IRN / JCN.
C           -----------------------------------
            IF ( (keep(244) .EQ. 1) .AND. (keep(54) .EQ. 3) ) THEN
C               IRN and JCN might have already been deallocated
                IF (gather_matrix_allocated) THEN
                    IF (associated(id%IRN)) THEN
                      DEALLOCATE(id%IRN)
                      NULLIFY(id%IRN)
                    ENDIF
                    IF (associated(id%JCN)) THEN
                      DEALLOCATE(id%JCN)
                      NULLIFY(id%JCN)
                    ENDIF
                    gather_matrix_allocated= .false.
                ENDIF
            END IF
         END IF
      ENDIF
C     
C     Store size of the stack memory for each
C     of the sequential subtree.
      IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN
         IF(associated(id%DEPTH_FIRST)) THEN
            DEALLOCATE(id%DEPTH_FIRST)
         ENDIF
         allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok)
         IF (allocok .ne.0) then
            info(1)= -7
            info(2)= id%KEEP(28)
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%DEPTH_FIRST'
            END IF
            GOTO 87
         END IF
         IF(associated(id%DEPTH_FIRST_SEQ)) THEN
            DEALLOCATE(id%DEPTH_FIRST_SEQ)
         ENDIF
         ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok)
         IF (allocok .ne.0) then
            info(1)= -7
            info(2)= id%KEEP(28)
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
            END IF
            GOTO 87
         END IF
         IF(associated(id%SBTR_ID)) THEN
            DEALLOCATE(id%SBTR_ID)
         ENDIF
         ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok)
         IF (allocok .ne.0) then
            info(1)= -7
            info(2)= id%KEEP(28)
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
            END IF
            GOTO 87
         END IF
         IF(id%MYID.EQ.master)THEN
            id%DEPTH_FIRST(1:id%KEEP(28))=depth_first(1:id%KEEP(28))
            id%DEPTH_FIRST_SEQ(1:id%KEEP(28))=
     &           depth_first_seq(1:id%KEEP(28))
            id%SBTR_ID(1:keep(28))=sbtr_id(1:keep(28))
         ENDIF
         CALL mpi_bcast( id%DEPTH_FIRST(1), id%KEEP(28), mpi_integer,
     &           master, id%COMM, ierr )         
         CALL mpi_bcast( id%DEPTH_FIRST_SEQ(1), id%KEEP(28),
     &           mpi_integer,master, id%COMM, ierr )  
         CALL mpi_bcast( id%SBTR_ID(1), id%KEEP(28),
     &           mpi_integer,master, id%COMM, ierr )  
      ELSE
         IF(associated(id%DEPTH_FIRST)) THEN
            DEALLOCATE(id%DEPTH_FIRST)
         ENDIF
         allocate(id%DEPTH_FIRST(1),stat=allocok)
         IF (allocok .ne.0) then
            info(1)= -7
            info(2)= 1
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%DEPTH_FIRST'
            END IF
            GOTO 87
         END IF
         IF(associated(id%DEPTH_FIRST_SEQ)) THEN
            DEALLOCATE(id%DEPTH_FIRST_SEQ)
         ENDIF
         ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok)
         IF (allocok .ne.0) then
            info(1)= -7
            info(2)= 1
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
            END IF
            GOTO 87
         END IF
         IF(associated(id%SBTR_ID)) THEN
            DEALLOCATE(id%SBTR_ID)
         ENDIF
         ALLOCATE(id%SBTR_ID(1),stat=allocok)
         IF (allocok .ne.0) then
            info(1)= -7
            info(2)= 1
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
            END IF
            GOTO 87
         END IF
         id%SBTR_ID(1)=0
         id%DEPTH_FIRST(1)=0
         id%DEPTH_FIRST_SEQ(1)=0
      ENDIF
      IF(id%KEEP(76).EQ.5)THEN
         IF(associated(id%COST_TRAV)) THEN
            DEALLOCATE(id%COST_TRAV)
         ENDIF
         allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok)
         IF (allocok .ne.0) then
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%COST_TRAV'
            END IF
            info(1)= -7
            info(2)= id%KEEP(28)
            GOTO 87
         END IF
         IF(id%MYID.EQ.master)THEN
            id%COST_TRAV(1:id%KEEP(28))=
     &      dble(cost_trav_tmp(1:id%KEEP(28)))
         ENDIF
         CALL mpi_bcast( id%COST_TRAV(1), id%KEEP(28),
     &        mpi_double_precision,master, id%COMM, ierr )         
      ELSE
         IF(associated(id%COST_TRAV)) THEN
            DEALLOCATE(id%COST_TRAV)
         ENDIF
         allocate(id%COST_TRAV(1),stat=allocok)
         IF (allocok .ne.0) then
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%COST_TRAV(1)'
            END IF
            info(1)= -7
            info(2)= 1
            GOTO 87
         END IF
         id%COST_TRAV(1)=0.0d0
      ENDIF
      IF (id%KEEP(47) .EQ. 4 .OR.
     &     ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN
         IF(id%MYID .EQ. master)THEN
            DO k=1,id%NSLAVES
               DO j=1,size_temp_mem
                  IF(temp_mem(j,k) < 0.0d0) GOTO 666 
               ENDDO
 666           CONTINUE
               j=j-1
               IF (id%KEEP(46) == 1) THEN
                  idest = k - 1
               ELSE
                  idest = k
               ENDIF
               IF (idest .NE. master) THEN
                  CALL mpi_send(j,1,mpi_integer,idest,0,
     &                 id%COMM,ierr)
                  CALL mpi_send(temp_mem(1,k),j,mpi_double_precision,
     &                 idest, 0, id%COMM,ierr)
                  CALL mpi_send(temp_leaf(1,k),j,mpi_integer,
     &                 idest, 0, id%COMM,ierr)
                  CALL mpi_send(temp_size(1,k),j,mpi_integer,
     &                 idest, 0, id%COMM,ierr)
                  CALL mpi_send(temp_root(1,k),j,mpi_integer,
     &                 idest, 0, id%COMM,ierr)             
               ELSE
                  IF(associated(id%MEM_SUBTREE)) THEN
                     DEALLOCATE(id%MEM_SUBTREE)
                  ENDIF
                  allocate(id%MEM_SUBTREE(j),stat=allocok)
                  IF (allocok .ne.0) then
                     IF ( lpok ) THEN
                        WRITE(lp, 150) 'id%MEM_SUBTREE'
                     END IF
                     info(1)= -7
                     info(2)= j
                     GOTO 87
                  END IF
                  id%NBSA_LOCAL = j
                  id%MEM_SUBTREE(1:j)=temp_mem(1:j,1)
                  IF(associated(id%MY_ROOT_SBTR)) THEN
                     DEALLOCATE(id%MY_ROOT_SBTR)
                  ENDIF
                  allocate(id%MY_ROOT_SBTR(j),stat=allocok)
                  IF (allocok .ne.0) then
                     IF ( lpok ) THEN
                        WRITE(lp, 150) 'id%MY_ROOT_SBTR'
                     END IF
                     info(1)= -7
                     info(2)= j
                     GOTO 87
                  END IF
                  id%MY_ROOT_SBTR(1:j)=temp_root(1:j,1)
                  IF(associated(id%MY_FIRST_LEAF)) THEN
                     DEALLOCATE(id%MY_FIRST_LEAF)
                  ENDIF
                  allocate(id%MY_FIRST_LEAF(j),stat=allocok)
                  IF (allocok .ne.0) then
                     IF ( lpok ) THEN
                        WRITE(lp, 150) 'id%MY_FIRST_LEAF'
                     END IF
                     info(1)= -7
                     info(2)= j
                     GOTO 87
                  END IF
                  id%MY_FIRST_LEAF(1:j)=temp_leaf(1:j,1)
                  IF(associated(id%MY_NB_LEAF)) THEN
                     DEALLOCATE(id%MY_NB_LEAF)
                  ENDIF
                  allocate(id%MY_NB_LEAF(j),stat=allocok)
                  IF (allocok .ne.0) then
                     IF ( lpok ) THEN
                        WRITE(lp, 150) 'id%MY_NB_LEAF'
                     END IF
                     info(1)= -7
                     info(2)= j
                     GOTO 87
                  END IF
                  id%MY_NB_LEAF(1:j)=temp_size(1:j,1)
               ENDIF
            ENDDO
         ELSE
            CALL mpi_recv(id%NBSA_LOCAL,1,mpi_integer,
     &           master,0,id%COMM,status, ierr)
            IF(associated(id%MEM_SUBTREE)) THEN
               DEALLOCATE(id%MEM_SUBTREE)
            ENDIF
            allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok)
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'id%MEM_SUBTREE'
               END IF
               info(1)= -7
               info(2)= id%NBSA_LOCAL
               GOTO 87
            END IF
            IF(associated(id%MY_ROOT_SBTR)) THEN
               DEALLOCATE(id%MY_ROOT_SBTR)
            ENDIF
            allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok)
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'id%MY_ROOT_SBTR'
               END IF
               info(1)= -7
               info(2)= id%NBSA_LOCAL
               GOTO 87
            END IF
            IF(associated(id%MY_FIRST_LEAF)) THEN
               DEALLOCATE(id%MY_FIRST_LEAF)
            ENDIF
            allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok)
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'MY_FIRST_LEAF'
               END IF
               info(1)= -7
               info(2)= id%NBSA_LOCAL
               GOTO 87
            END IF
            IF(associated(id%MY_NB_LEAF)) THEN
               DEALLOCATE(id%MY_NB_LEAF)
            ENDIF
            allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok)
            IF (allocok .ne.0) then
               IF ( lpok ) THEN
                  WRITE(lp, 150) 'MY_NB_LEAF'
               END IF
               info(1)= -7
               info(2)= id%NBSA_LOCAL
               GOTO 87
            END IF
            CALL mpi_recv(id%MEM_SUBTREE(1),id%NBSA_LOCAL,
     &           mpi_double_precision,master,0,
     &           id%COMM,status,ierr)
            CALL mpi_recv(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL,
     &           mpi_integer,master,0,
     &           id%COMM,status,ierr)
            CALL mpi_recv(id%MY_NB_LEAF(1),id%NBSA_LOCAL,
     &           mpi_integer,master,0,
     &           id%COMM,status,ierr)
            CALL mpi_recv(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL,
     &           mpi_integer,master,0,
     &           id%COMM,status,ierr)
         ENDIF
      ELSE
         id%NBSA_LOCAL = -999999
         IF(associated(id%MEM_SUBTREE)) THEN
            DEALLOCATE(id%MEM_SUBTREE)
         ENDIF
         allocate(id%MEM_SUBTREE(1),stat=allocok)
         IF (allocok .ne.0) then
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%MEM_SUBTREE(1)'
            END IF
            info(1)= -7
            info(2)= 1
            GOTO 87
         END IF
         IF(associated(id%MY_ROOT_SBTR)) THEN
            DEALLOCATE(id%MY_ROOT_SBTR)
         ENDIF
         allocate(id%MY_ROOT_SBTR(1),stat=allocok)
         IF (allocok .ne.0) then
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%MY_ROOT_SBTR(1)'
            END IF
            info(1)= -7
            info(2)= 1
            GOTO 87
         END IF
         IF(associated(id%MY_FIRST_LEAF)) THEN
            DEALLOCATE(id%MY_FIRST_LEAF)
         ENDIF
         allocate(id%MY_FIRST_LEAF(1),stat=allocok)
         IF (allocok .ne.0) then
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%MY_FIRST_LEAF(1)'
            END IF
            info(1)= -7
            info(2)= 1
            GOTO 87
         END IF
         IF(associated(id%MY_NB_LEAF)) THEN
            DEALLOCATE(id%MY_NB_LEAF)
         ENDIF
         allocate(id%MY_NB_LEAF(1),stat=allocok)
         IF (allocok .ne.0) then
            IF ( lpok ) THEN
               WRITE(lp, 150) 'id%MY_NB_LEAF(1)'
            END IF
            INFO(1)= -7
            INFO(2)= 1
            GOTO 87
         END IF
      ENDIF
.EQ.      IF(id%MYIDMASTER)THEN
         IF(IS_BUILD_LOAD_MEM_CALLED)THEN 
            DEALLOCATE(TEMP_MEM)
            DEALLOCATE(TEMP_SIZE)
            DEALLOCATE(TEMP_ROOT)
            DEALLOCATE(TEMP_LEAF)
            DEALLOCATE(COST_TRAV_TMP)
            DEALLOCATE(DEPTH_FIRST)
            DEALLOCATE(DEPTH_FIRST_SEQ)
            DEALLOCATE(SBTR_ID)
         ENDIF
      ENDIF
 87   CONTINUE
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &     id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
C     
      NB_NIV2 = KEEP(56)        ! KEEP(1:110) was broadcast earlier
C     NB_NIV2 is now available on all processors.
.GT.      IF (  NB_NIV20  ) THEN
C        Allocate arrays on slaves
.ne.         if (id%MYIDMASTER) then
            IF (associated(id%CANDIDATES)) THEN
               DEALLOCATE(id%CANDIDATES)
            ENDIF
            allocate(PAR2_NODES(NB_NIV2),
     &           id%CANDIDATES(id%NSLAVES+1,NB_NIV2),
     &           STAT=allocok)
.ne.            IF (allocok 0) then
               INFO(1)= -7
               INFO(2)= NB_NIV2*(id%NSLAVES+1)
               IF ( LPOK ) THEN
                  WRITE(LP, 150) 'par2_nodes/id%CANDIDATES'
               END IF
            end if
         end if
         CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &        id%COMM, id%MYID )
.LT.         IF ( INFO(1)0 ) GOTO 500
         CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2,
     &        MPI_INTEGER, MASTER, id%COMM, IERR )
.NE.         IF (KEEP(24) 0 ) THEN
            CALL MPI_BCAST(id%CANDIDATES(1,1),
     &           (NB_NIV2*(id%NSLAVES+1)),
     &           MPI_INTEGER, MASTER, id%COMM, IERR )
         ENDIF
      ENDIF
      IF ( associated(id%ISTEP_TO_INIV2)) THEN
         DEALLOCATE(id%ISTEP_TO_INIV2)
         NULLIFY(id%ISTEP_TO_INIV2)
      ENDIF
      IF ( associated(id%I_AM_CAND)) THEN
         DEALLOCATE(id%I_AM_CAND)
         NULLIFY(id%I_AM_CAND)
      ENDIF
.EQ.      IF (NB_NIV20) THEN 
C     allocate dummy arrays
C     ISTEP_TO_INIV2 will never be used 
C     Add a parameter SIZE_ISTEP_TO_INIV2 and make
C     it always available in a keep(71)
         id%KEEP(71) = 1
      ELSE
         id%KEEP(71) = id%KEEP(28)
      ENDIF
      allocate(id%ISTEP_TO_INIV2(id%KEEP(71)),
     &     id%I_AM_CAND(max(NB_NIV2,1)),
     &     stat=allocok)
.gt.      IF (allocok 0) THEN
         IF ( LPOK ) THEN
            WRITE(LP, 150) 'id%ISTEP_TO_INIV2'
            WRITE(LP, 150) 'id%TAB_POS_IN_PERE'
         END IF
         INFO(1)= -7
.EQ.         IF (NB_NIV20) THEN
            INFO(2)= 2
         ELSE
            INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2)
         END IF
         GOTO 321
      ENDIF
.GT.      IF ( NB_NIV2 0 ) THEN
C   If BLR grouping was performed then PAR2_NODES(INIV2) 
C   might then point to a non principal variable
C   for which STEP might be negative
C
         id%ISTEP_TO_INIV2 = -9999
         DO INIV2 = 1, NB_NIV2
            INN = PAR2_NODES(INIV2)
            id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2
         END DO 
         CALL ZMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79),
     &        NB_NIV2, id%MYID_NODES,
     &        id%CANDIDATES(1,1), id%I_AM_CAND(1) )
      ENDIF
      IF ( I_AM_SLAVE ) THEN
         IF (associated(id%FUTURE_NIV2)) THEN
            DEALLOCATE(id%FUTURE_NIV2)
            NULLIFY(id%FUTURE_NIV2)
         ENDIF
         allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok)
.gt.         IF (allocok 0) THEN
            IF ( LPOK ) THEN
               WRITE(LP, 150) 'future_niv2'
            END IF
            INFO(1)= -7
            INFO(2)= id%NSLAVES
            GOTO 321
         ENDIF
         id%FUTURE_NIV2=0
         DO INIV2 = 1, NB_NIV2
            IDEST = MUMPS_PROCNODE(
     &           id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))),
     &           id%KEEP(199))
            id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1
         ENDDO
C     Allocate id%TAB_POS_IN_PERE, 
C     TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2)
C     where NB_NIV2 is the number of type 2 nodes in the tree.
         IF ( associated(id%TAB_POS_IN_PERE)) THEN
            DEALLOCATE(id%TAB_POS_IN_PERE)
            NULLIFY(id%TAB_POS_IN_PERE)
         ENDIF
         allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)),
     &        stat=allocok)
.gt.         IF (allocok 0) THEN
            IF ( LPOK ) THEN
               WRITE(LP, 150) 'id%ISTEP_TO_INIV2'
               WRITE(LP, 150) 'id%TAB_POS_IN_PERE'
            END IF
            INFO(1)= -7
.EQ.            IF (NB_NIV20) THEN
               INFO(2)= 2
            ELSE
               INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2)
            END IF
            GOTO 321
         ENDIF
      END IF
C     deallocate PAR2_NODES  that was computed
C     on master and broadcasted on all slaves
.GT.      IF (NB_NIV20) DEALLOCATE (PAR2_NODES)
 321  CONTINUE
C     ----------------
C     Check for errors
C     ----------------
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &     id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
C
.NE.      IF ( KEEP(38)  0 ) THEN
C     -------------------------
C     Initialize root structure
C     -------------------------
         CALL ZMUMPS_INIT_ROOT_ANA( id%MYID,
     &        id%NSLAVES, id%N, id%root,
     &        id%COMM_NODES, KEEP( 38 ), id%FILS(1),
     &        id%KEEP(50), id%KEEP(46),
     &        id%KEEP(51)
     &        , id%KEEP(60), id%NPROW, id%NPCOL, id%MBLOCK, id%NBLOCK
     &        )
      ELSE
         id%root%yes = .FALSE.
      END IF
.NE..and.      IF ( KEEP(38)  0  I_AM_SLAVE ) THEN
C     -----------------------------------------------
C     Check if at least one processor belongs to the
C     root. In the case where all of them have MYROW
C     equal to -1, this could be a problem due to the
C     BLACS. (mpxlf90_r and IBM BLACS).
C     -----------------------------------------------
         CALL MPI_ALLREDUCE(id%root%MYROW, MYROW_CHECK, 1,
     &        MPI_INTEGER, MPI_MAX, id%COMM_NODES, IERR)
.eq.         IF ( MYROW_CHECK  -1) THEN
            INFO(1) = -25
            INFO(2) = 0
         END IF
.LT..OR.         IF ( id%root%MYROW  -1 
.LT.     &        id%root%MYCOL  -1 ) THEN
            INFO(1) = -25
            INFO(2) = 0
         END IF
.AND.         IF ( LPOK  INFO(1) == -25 ) THEN
            WRITE(LP, '(a)')
     &           'problem with your version of the blacs.'
            WRITE(LP, '(a)') 'try using a blacs version from netlib.'
         ENDIF
      END IF
C     ----------------
C     Check for errors
C     ----------------
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &     id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
      IF ( I_AM_SLAVE ) THEN
C{
C     
C     
.EQ.         IF (KEEP(55)  0) THEN
            CALL ZMUMPS_ANA_DIST_ARROWHEADS( id%MYID,
     &           id%NSLAVES, id%N, id%PROCNODE_STEPS(1),
     &           id%STEP(1), id%PTRAR(1),
     &           id%PTRAR(id%N +1),
     &           id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1),
     &           KEEP(1),KEEP8(1), ICNTL(1), id )
         ELSE
            CALL ZMUMPS_ANA_DIST_ELEMENTS( id%MYID,
     &           id%NSLAVES, id%N, id%PROCNODE_STEPS(1),
     &           id%STEP(1),
     &           id%PTRAR(1),
     &           id%PTRAR(id%NELT+2 ),
     &           id%NELT, 
     &           id%FRTPTR(1), id%FRTELT(1),
     &           KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) )
         ENDIF
C}
      ENDIF
C     -----------------------------------------
C     Perform some local analysis on the slaves
C     to estimate the size of the working space
C     for factorization
C     -----------------------------------------
      IF ( I_AM_SLAVE ) THEN
C{
         locI_AM_CAND => id%I_AM_CAND
         locMYID_NODES = id%MYID_NODES
         locMYID       = id%MYID
C           ===================================================
C           Precompute estimates of local_m,local_n
C           (number of rows/columns mapped on each processor)
C           in case of parallel root node.
C           and allocate CANDIDATES
C           ===================================================
C     
            IF ( id%root%yes ) THEN
              LOCAL_M = numroc( id%ND_STEPS(id%STEP(KEEP(38))),
     &              id%root%MBLOCK, id%root%MYROW, 0,
     &              id%root%NPROW )
              LOCAL_M = max(1, LOCAL_M)
              LOCAL_N = numroc( id%ND_STEPS(id%STEP(KEEP(38))),
     &              id%root%NBLOCK, id%root%MYCOL, 0,
     &              id%root%NPCOL )
            ELSE
              LOCAL_M = 0
              LOCAL_N = 0
            END IF
.EQ..OR..EQ.            IF  ( KEEP(60)  2  KEEP(60)  3 ) THEN
C           Return minimum nb rows/cols to user
               id%SCHUR_MLOC=LOCAL_M
               id%SCHUR_NLOC=LOCAL_N
C           Also store them in root structure for convenience
               id%root%SCHUR_MLOC=LOCAL_M
               id%root%SCHUR_NLOC=LOCAL_N
            ENDIF
.NOT.            IF (  associated(id%CANDIDATES)) THEN
               ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok)
.gt.               IF (allocok 0) THEN
                     IF ( LPOK ) THEN
                        WRITE(LP, 150) 'candidates'
                     END IF
                     INFO(1)= -7
                     INFO(2)= id%NSLAVES+1
               ENDIF
            ENDIF
C}
      ENDIF
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &             id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
.GT.      IF (KEEP(400)  0 ) THEN ! L0 activated
C{
          IF ( I_AM_SLAVE ) THEN
C{
C            =================================================
C            Build L0_OMP layer and compute memory estimations
C            under L0_OMP and data needed to estimate memory
C            above L0_OMP 
C            =================================================
C
             CALL MUMPS_ANA_L0_OMP(
     &       KEEP(400), id%N, KEEP(28),
     &       KEEP(50), id%NSLAVES, id%DAD_STEPS, id%FRERE_STEPS, 
     &       id%FILS, id%NE_STEPS, id%ND_STEPS, id%STEP, 
     &       id%PROCNODE_STEPS, KEEP, KEEP8, locMYID_NODES, 
     &       id%NA, id%LNA, "ZMUMPS"(1:1),
     &       id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP,
     &       id%LPOOL_A_L0_OMP, id%IPOOL_A_L0_OMP,
     &       id%L_VIRT_L0_OMP,id%VIRT_L0_OMP, id%VIRT_L0_OMP_MAPPING,
     &       id%L_PHYS_L0_OMP,id%PHYS_L0_OMP, id%PERM_L0_OMP,
     &       id%PTR_LEAFS_L0_OMP, id%THREAD_LA, id%INFO, id%ICNTL)
.GE.             IF (id%INFO(1)  0) THEN
               ALLOCATE(
     &          id%I4_L0_OMP(NBSTATS_I4, KEEP(400)), 
     &          id%I8_L0_OMP(NBSTATS_I8, KEEP(400)), 
     &          TNSTK_afterL0(KEEP(28)),
     &          stat=allocok)
.gt.               IF (allocok 0) THEN
                 IF ( LPOK ) THEN
                     WRITE(LP, 150) 'l0_omp stats'
                 END IF
                 INFO(1)= -7
                 INFO(2)= NBSTATS_I4* KEEP(400) +
     &                    NBSTATS_I8* KEEP(400)*KEEP(10)
     &                   + KEEP(28)
               ENDIF
             ENDIF
C}
          ENDIF
          CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &             id%COMM, id%MYID )
.LT.          IF ( INFO(1)0 ) GOTO 500
          IF ( I_AM_SLAVE ) THEN
               CALL ZMUMPS_ANA_DISTM_UNDERL0OMP(
     &           id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP(1),
     &           id%L_VIRT_L0_OMP,
     &           id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1),
     &           id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1),
     &           id%PTR_LEAFS_L0_OMP(1),
     &           id%KEEP(1), id%N, id%NE_STEPS(1), id%STEP(1),
     &           id%FRERE_STEPS(1), id%FILS(1), id%DAD_STEPS(1), 
     &           id%ND_STEPS(1), 
     &           locMYID_NODES, id%PROCNODE_STEPS(1),
     &           id%I4_L0_OMP(1,1), NBSTATS_I4, 
     &           id%I8_L0_OMP(1,1), NBSTATS_I8, KEEP(400),
C                To be used to adjust outputs ABOVE_L0OMP
     &           SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB,
     &           TNSTK_afterL0, MAXFR_UNDER_L0, 
     &           MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, 
     &           ENTRIES_IN_FACTORS_UNDER_L0,
     &           ENTRIES_IN_FACTORS_MASTERS_LO,
     &           COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0,
C
     &           INFO(1), INFO(2)
     &           )
          ENDIF
C} else of L0 activated
      ELSE
C{
          IF ( I_AM_SLAVE ) THEN
              id%LPOOL_B_L0_OMP = 1
              id%LPOOL_A_L0_OMP = 1
              id%L_VIRT_L0_OMP = 1
              id%L_PHYS_L0_OMP = 1
              id%THREAD_LA = -1_8
              ALLOCATE ( id%VIRT_L0_OMP ( id%L_VIRT_L0_OMP ), 
     &              id%VIRT_L0_OMP_MAPPING ( id%L_VIRT_L0_OMP ), 
     &              id%PERM_L0_OMP ( id%L_PHYS_L0_OMP ),
     &              id%PTR_LEAFS_L0_OMP ( id%L_PHYS_L0_OMP + 1 ),
     &              id%IPOOL_B_L0_OMP ( id%LPOOL_B_L0_OMP ),
     &              id%IPOOL_A_L0_OMP ( id%LPOOL_A_L0_OMP ),
     &              id%PHYS_L0_OMP( id%L_PHYS_L0_OMP ),
     &              id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok)
.gt.              IF (allocok 0) THEN
                 IF ( LPOK ) THEN
                    WRITE(LP, 150) 'allocation error in multicore'
                 END IF
                 INFO(1)= -7
                 INFO(2)= id%L_VIRT_L0_OMP
     &                + id%L_PHYS_L0_OMP
     &                + id%L_PHYS_L0_OMP + 1
     &                + id%LPOOL_B_L0_OMP
     &                + id%LPOOL_A_L0_OMP
     &                + id%L_PHYS_L0_OMP + 1 + KEEP(10)
              ENDIF
          ENDIF
C}
      ENDIF
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &      id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
C     -- Allocate and initialise IPOOL with leaves 
C     -- on which stats are performed
      IF ( I_AM_SLAVE ) THEN
C{
.GT.          IF (KEEP(400)0) THEN
C{
.GT.              IF (id%NSLAVES 1)  THEN
C                FLAGGED_LEVAES will be used during
C                ZMUMPS_PREP_ANA_DISTM_ABOVEL0
                 ALLOCATE (FLAGGED_LEAVES(KEEP(28)),
     &                stat=allocok)
.gt.                 IF (allocok 0) THEN
                      IF ( LPOK ) THEN
                          WRITE(LP, 150) 'l0_omp flagged leaves'
                      END IF
                      INFO(1)= -7
                      INFO(2)= KEEP(28)
                 ENDIF
               ENDIF
C}
          ENDIF
C}
      ENDIF
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &      id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
      IF ( I_AM_SLAVE ) THEN
C{
.GT.          IF (KEEP(400)0) THEN
C{
.GT.              IF (id%NSLAVES 1)  THEN
                 ! LIPOOL_local can be 0
                 LIPOOL_local=
     &              id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP)
C                ---------------------------------------------
C                Pool information from other MPI proc neeeded
C                (union of IPOOL_A_L0_OMP of all MPI procs)
C                ---------------------------------------------
                 CALL ZMUMPS_PREP_ANA_DISTM_ABOVEL0(
     &               id%N, id%NSLAVES, id%COMM_NODES, id%MYID_NODES, 
     &               id%STEP(1), id%DAD_STEPS(1),id%ICNTL,LP,LPOK,
     &               id%INFO, 
     &               id%PHYS_L0_OMP(1), id%L_PHYS_L0_OMP, 
     &               id%IPOOL_A_L0_OMP(1), LIPOOL_local,
     &               id%KEEP, TNSTK_afterL0,
     &               FLAGGED_LEAVES
     &              )
C               
.LT.                 IF ( INFO(1)0 ) GOTO 75
C
                 LIPOOL= 0
                 DO ISTEP=1,KEEP(28)
C                 Non zero entries are leaf nodes
.GT.                  IF (FLAGGED_LEAVES(ISTEP)0) LIPOOL=LIPOOL+1
                 ENDDO
              ELSE
C                last entry in pool is its size
                 LIPOOL = id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP)
              ENDIF
C}
          ELSE
           LIPOOL = id%NA(1)
          ENDIF
C         LIPOOL is number of leaf nodes and can be 0 
C         (for ex AboveL0 with nbthreads is 1)
          ALLOCATE( IPOOL(max(LIPOOL,1)), 
     &                   stat=allocok)
.gt.          IF (allocok 0) THEN
                   IF ( LPOK ) THEN
                      WRITE(LP, 150) 'allocation ipool'
                   END IF
                   INFO(1)= -7
                   INFO(2)=  LIPOOL
          ENDIF
C}
      ENDIF
 75   CONTINUE
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &      id%COMM, id%MYID )
.LT.      IF ( INFO(1)0 ) GOTO 500
C
      IF ( I_AM_SLAVE ) THEN
C{
.GT.          IF (KEEP(400)  0 ) THEN ! L0 activated
C{
.GT.            IF (LIPOOL0) THEN
.GT.              IF (id%NSLAVES 1)  THEN
C               first leaf in postorder is at the top of the pool
                I =LIPOOL
                DO ISTEP=1, KEEP(28)
.GT.                 IF (FLAGGED_LEAVES(ISTEP)0)  THEN
C                  FLAGGED_LEAVES(ISTEP) hold inode
C                  that is a leaf of tree above L0_OMP
C                  Entries are stored in order with respect
C                   to STEP
                   IPOOL(I) = FLAGGED_LEAVES(ISTEP)
                   I=I-1
                 ENDIF
C                -- all leaves found and added
.EQ.                 IF (I0) CYCLE 
                ENDDO
                DEALLOCATE(FLAGGED_LEAVES)
              ELSE
                 DO I=1, LIPOOL
                  IPOOL(I) = id%IPOOL_A_L0_OMP(I)
                 ENDDO
              ENDIF
            ENDIF
C           
            ABOVE_L0    =.TRUE.
            NE_STEPSPTR => TNSTK_afterL0(1:KEEP(28))
C}
          ELSE
C            Initialize IPOOL with leaves of complete tree
             DO I=1, LIPOOL
              IPOOL(I) = id%NA(3+I-1)
             ENDDO
             ABOVE_L0                   =.FALSE.
             SIZECB_UNDER_L0            = 0_8
             SIZECB_UNDER_L0_IF_LRCB    = 0_8
             MAX_FRONT_SURFACE_LOCAL_L0 = 0_8
             MAX_SIZE_FACTOR_L0         = 0_8
             ENTRIES_IN_FACTORS_UNDER_L0= 0_8
             ENTRIES_IN_FACTORS_MASTERS_LO = 0_8
             MAXFR_UNDER_L0             = 0
             COST_SUBTREES_UNDER_L0     = 0.0D0
             OPSA_UNDER_L0              = 0.0D0
C
             NE_STEPSPTR => id%NE_STEPS
          ENDIF
           KEEP(139) = MAXFR_UNDER_L0
C
           CALL ZMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1),
     & id%FRERE_STEPS(1), id%FILS(1), IPOOL, LIPOOL, NE_STEPSPTR(1),
     & id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1),
     & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB,
     & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, 
     & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO,
     & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54),
     & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12),  KEEP8(14),  
     & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), 
     & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39),
     & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45),
     & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27),
     & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N,
     & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR,
     & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1),
     & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), 
     & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, 
     & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS,
     & id%root%yes, id%root%NPROW, id%root%NPCOL
     &           )
           IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL)
           NULLIFY(NE_STEPSPTR)
.GT.           IF (KEEP(400)  0) THEN ! L0 activated
C{
             DEALLOCATE (TNSTK_afterL0)
C            =============================================
C            Postprocess statistics with data below L0_OMP
C            =============================================
C            compute sums under L0
             SUM_NIRNEC     = 0
             SUM_NIRADU     = 0
             SUM_NIRADU_OOC = 0
             SUM_NIRNEC_OOC = 0
             DO I=1, KEEP(400)
                SUM_NIRADU = SUM_NIRADU        + id%I4_L0_OMP(1,I)
                SUM_NIRNEC = SUM_NIRNEC        + id%I4_L0_OMP(2,I)
                SUM_NIRADU_OOC = SUM_NIRADU_OOC+ id%I4_L0_OMP(3,I)
                SUM_NIRNEC_OOC = SUM_NIRNEC_OOC+ id%I4_L0_OMP(4,I)
             ENDDO
C            Update NIRADU above L0
             KEEP(26)  = KEEP(26)  + SUM_NIRADU
C            Update NIRADU_OOC above L0
             KEEP(224) = KEEP(224) + SUM_NIRADU_OOC
C            Update NIRNEC aboveL0= max(NIRNEC, NIRADU+SUM_NIRADU)
             KEEP(15) = max(KEEP(15),KEEP(26))
C            Update NIRNEC_OOC aboveL0= max(NIRNEC, 
C                                       NIRADU_OOC+SUM_NIRADU_OOC)
             KEEP(225) = max(KEEP(225),KEEP(224))
C            save SUM_NIRNEC underL0 to be used in ZMUMPS_MAX_MEM
             KEEP(137) = SUM_NIRNEC
C            save SUM_NIRNEC_OOC underL0 to be used in ZMUMPS_MAX_MEM
             KEEP(138) = SUM_NIRNEC_OOC
C 
             SUM_NIRNEC =  int( 
     &              (dble(SUM_NIRNEC)*dble(KEEP(34)))/dble(KEEP(35))
     &                     )
             SUM_NIRNEC_OOC =  int( 
     &              (dble(SUM_NIRNEC_OOC)*dble(KEEP(34)))/dble(KEEP(35))
     &                     )
C
C            Memory peaks to be updated to take
C            into account factors under L0_OMP
             MAX_NRLADU          = 0_8
             MIN_NRLADU          = id%I8_L0_OMP(1,1)
             SUM_NRLADU          = 0_8
             SUM_NRLNEC          = 0_8
             MIN_NRLNEC          = huge(MIN_NRLNEC)
             SUM_NRLNEC_ACTIVE   = 0_8
             SUM_NRLADU_if_LR_LU = 0_8
             SUM_NRLADULR_UD     = 0_8
             SUM_NRLADULR_WC     = 0_8
             DO I=1, KEEP(400)
               MIN_NRLADU = min(MIN_NRLADU, id%I8_L0_OMP(1,I))
               MAX_NRLADU = max(MAX_NRLADU, id%I8_L0_OMP(1,I))
               SUM_NRLADU = SUM_NRLADU + id%I8_L0_OMP(1,I)
               SUM_NRLNEC = SUM_NRLNEC + id%I8_L0_OMP(2,I)
               MIN_NRLNEC = min(MIN_NRLNEC, id%I8_L0_OMP(2,I))
               SUM_NRLNEC_ACTIVE = SUM_NRLNEC_ACTIVE +
     &                      id%I8_L0_OMP(3,I)
               SUM_NRLADU_if_LR_LU = SUM_NRLADU_if_LR_LU +
     &                      id%I8_L0_OMP(4,I)
               SUM_NRLADULR_UD = SUM_NRLADULR_UD  +
     &                      id%I8_L0_OMP(9,I)
               SUM_NRLADULR_WC = SUM_NRLADULR_WC  +
     &                      id%I8_L0_OMP(10,I)
             ENDDO
C            Save NRLADU above L0 (KEEP8(11)) in KEEP8(81)
C            and then update KEEP8(11) (NRLADU) taking into account 
C            factors above and under L0 layer
             KEEP8(81) = KEEP8(11) 
             KEEP8(11) = KEEP8(11) + SUM_NRLADU
C            Save SUM_NRLADU_if_LR_LU above L0 (KEEP8(32)) in KEEP8(82)
C            and then update KEEP8(32) (NRLADU_if_LR_LU) taking into account 
C            factors above and under L0 layer
             KEEP8(82) = KEEP8(32)
             KEEP8(32) = KEEP8(32) + SUM_NRLADU_if_LR_LU
C
C            Note that RECV buffer should have been added
C            to both PEAK_UNDER_L0 and PEAK_ABOVE_L0
             PEAK_UNDER_L0 = SUM_NRLNEC + MIN_NRLNEC + 
     &        int(
     &        (dble(id%N*KEEP(400))*dble(KEEP(34)))/dble(KEEP(35)),
     &               8)
C            Estimate send buffer size 
C            and convert it in nb of reals
C            (KEEP(43) and KEEP(44) not yet set)
C
C            Convert SUM_NIRNEC SUM_NIRNEC_OOC into nb of reals 
             PEAK_ABOVE_L0 =  KEEP8(53)+ SUM_NRLADU + 
     &            ! SEND buffer
     &              max ( int( 
     &              (dble(SBUF_SEND_FR)*dble(KEEP(34)))/dble(KEEP(35))
     &                     , 8), 100000_8 ) +
     &            ! MAXIS_above :
     &             int( 
     &              (dble(KEEP(15))*dble(KEEP(34)))/dble(KEEP(35)),
     &               8)
C      FIXME PEAK_ABOVE_L0 replaced PEAK_WITHOUT_L0
C            ===============================================
C            Update memory peaks:
C                 - adding factors computed underL0
C                 - sum of peaks underL0 taking into account
C                   received buffer preallocated
C            ===============================================
             KEEP8(53) = KEEP8(53)+ SUM_NRLADU
             KEEP8(40) = KEEP8(40)+
     &              SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD
             KEEP8(41) = KEEP8(41)+ SUM_NRLADULR_UD
             KEEP8(42) = KEEP8(42)+ SUM_NRLADULR_WC 
             KEEP8(43) = KEEP8(43)+
     &              SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD
             KEEP8(44) = KEEP8(44)+
     &              SUM_NRLADU_if_LR_LU + SUM_NRLADULR_WC
             KEEP8(45) = KEEP8(45)+ SUM_NRLADULR_UD
             KEEP8(46) = KEEP8(46)+ SUM_NRLADULR_WC
             KEEP8(51) = KEEP8(51)+ SUM_NRLADU
             KEEP8(52) = KEEP8(52)+  SUM_NRLADULR_UD
C}
           ELSE
C            SUM_NIRNEC under L0 OMP
             KEEP(137)=0
C            SUM_NIRNEC_OOC under L0 OMP
             KEEP(138)=0
           ENDIF
C           DKEEP(15) is used for dynamic load balancing only
C           it corresponds to the number of local operations
C           (in Millions)
            id%DKEEP(15)    = RINFO(1)/1000000.0
            IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND)
            id%MAX_SURF_MASTER = KEEP8(15)
C
            KEEP8(19)=MAX_SIZE_FACTOR_TMP
            KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10)
     &           * ( KEEP(15) / 100 + 1)
C     Relaxed value of size of IS is not needed internally;
C     we save it directly in INFO(19)
            INFO( 19 ) = KEEP(225) + 3* max(KEEP(12),10)
     &           * ( KEEP(225) / 100 + 1)
C     =================================
C     Size of S (relaxed with ICNTL(14)
C     ===========================
C     size of S relaxed (FR, IC)
C     ===========================
            KEEP8(13)  = KEEP8(12) + int(KEEP(12),8) *
     &           ( KEEP8(12) / 100_8 + 1_8 )
C     size of S relaxed (FR or LR LU, OOC)
            KEEP8(17)  = KEEP8(14) + int(KEEP(12),8) *
     &           ( KEEP8(14) /100_8 +1_8)
C      size of S relaxed (LR LU, IC)
            K8_33relaxed  = KEEP8(33) + int(KEEP(12),8) *
     &           ( KEEP8(33) /100_8 +1_8)
C     size of S relaxed (LR LU+CB, OOC)
            K8_34relaxed  = KEEP8(34) + int(KEEP(12),8) *
     &           ( KEEP8(34) /100_8 +1_8)
C     size of S relaxed (LR LU+CB, OOC)
            K8_35relaxed  = KEEP8(35) + int(KEEP(12),8) *
     &           ( KEEP8(35) /100_8 +1_8)
C     size of S relaxed (LR CB, IC)
            K8_50relaxed  = KEEP8(50) + int(KEEP(12),8) *
     &           ( KEEP8(50) /100_8 +1_8)
C     KEEP8( 22 ) is the OLD maximum size of receive buffer 
C     that includes CB related communications.
C     KEEP( 43 ) : min size for send buffer
C     KEEP( 44 ) : min size for receive buffer
C     KEEP(43-44) kept for allocating buffers during
C                 factorization phase
         CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX,
     &                            id%COMM_NODES )
C     We do a max with KEEP(27)=maxfront because for small
C     buffers, we need at least one row of cb to be sent/
C     received.
         SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27))
         SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27))
         SBUF_REC_FR  = max(SBUF_REC_FR ,KEEP(27))
         SBUF_REC_LR  = max(SBUF_REC_LR ,KEEP(27))
         CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, 
     &        MPI_INTEGER, MPI_MAX,
     &        id%COMM_NODES, IERR)
         CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, 
     &        MPI_INTEGER, MPI_MAX,
     &        id%COMM_NODES, IERR)
         IF (KEEP(48)==5) THEN
           KEEP(43)  = KEEP(44)
           KEEP(379) = KEEP(380)
         ELSE
           KEEP(43)=SBUF_SEND_FR
           KEEP(379)=SBUF_SEND_LR
         ENDIF
C     
         UPDATE_BUFFER = .TRUE.
C
         MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8)
         MIN_BUF_SIZE8 = min(MIN_BUF_SIZE8,int(huge(I4),8))
         MIN_BUF_SIZE  = int( MIN_BUF_SIZE8 )
         IF (UPDATE_BUFFER) THEN
C          Send buffer 
           KEEP(43)  = max(KEEP(43), MIN_BUF_SIZE)
           KEEP(379) = max(KEEP(379), MIN_BUF_SIZE)
         ENDIF 
.NE..OR.         IF ( (KEEP(38)0)  UPDATE_BUFFER) THEN
C          Received buffer need be the same on all procs because of 
C          scalapack root 
           KEEP(380) = max(KEEP(380), MIN_BUF_SIZE)
           KEEP(44)  = max(KEEP(44), MIN_BUF_SIZE)
         ENDIF
            IF ( PROK ) THEN
               WRITE(MP,'(a,i16) ') 
     &              ' estimated INTEGER space for factors         :',
     &              KEEP(26)
               WRITE(MP,'(A,I16) ') 
     &              ' INFO(3), est. complex space to store factors:',
     &              KEEP8(11)
               WRITE(MP,'(A,I16) ') 
     &              ' Estimated number of entries in factors      :',
     &              KEEP8(9)
               WRITE(MP,'(A,I16) ') 
     &              ' Current value of space relaxation parameter :',
     &              KEEP(12)
               WRITE(MP,'(A,I16) ') 
     &              ' Estimated size of IS (In Core factorization):',
     &              KEEP(29)
               WRITE(MP,'(A,I16) ') 
     &              ' Estimated size of S  (In Core factorization):',
     &              KEEP8(13)
               WRITE(MP,'(A,I16) ') 
     &              ' Estimated size of S  (OOC factorization)    :',
     &              KEEP8(17)
            END IF
C}
      ELSE
C     ---------------------
C     Master is not working
C     ---------------------
         ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8
         KEEP8(13) = 0_8
         KEEP(29) = 0
         KEEP8(17)= 0_8
         INFO(19) = 0
         KEEP8(11) = 0_8
         KEEP8(81) = 0_8
         KEEP8(82) = 0_8
         KEEP(26) = 0
         KEEP(27) = 0
         RINFO(1) = 0.0D0
         K8_33relaxed = 0_8
         K8_34relaxed = 0_8
         K8_35relaxed = 0_8
         K8_50relaxed = 0_8
.GT.         IF (KEEP(400) 0) THEN
             SUM_NIRNEC     = 0
             SUM_NIRADU     = 0
             SUM_NIRADU_OOC = 0
             SUM_NIRNEC_OOC = 0
             MAX_NRLADU          = 0_8
             MIN_NRLADU          = 0_8
             SUM_NRLADU          = 0_8
             SUM_NRLNEC          = 0_8
             SUM_NRLNEC_ACTIVE   = 0_8
             SUM_NRLADU_if_LR_LU = 0_8
             SUM_NRLADULR_UD     = 0_8
             SUM_NRLADULR_WC     = 0_8
         ENDIF
      END IF
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &     id%COMM, id%MYID )
.LT.      IF ( INFO(1)  0 ) GOTO 500
C     --------------------------------------
C     KEEP8( 26 ) : Real arrowhead size
C     KEEP8( 27 ) : Integer arrowhead size
C     INFO(3)/KEEP8( 11 ) : Estimated real space needed for factors
C     INFO(4)/KEEP( 26 )  : Estimated integer space needed for factors
C     INFO(5)/KEEP( 27 )  : Estimated max front size
C     KEEP8(109)          : Estimated number of entries in factor
C                         (based on ENTRIES_IN_FACTORS_LOC_MASTERS computed 
C                          during ZMUMPS_ANA_DISTM, where we assume 
C                          that each master of a node computes
C                          the complete factor size.
C     --------------------------------------
C     note that summing ENTRIES_IN_FACTORS_LOC_MASTERS or 
C     ENTRIES_IN_FACTORS_LOC_MASTERS should lead to the same result
      CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, 
     &     KEEP8(109), MPI_SUM, id%COMM)
      CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119),
     &     MPI_MAX, id%COMM)
      CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1,
     &     MPI_INTEGER, MPI_MAX,
     &     id%COMM, IERR)
      CALL MPI_ALLREDUCE( KEEP(26), KEEP(126), 1,
     &     MPI_INTEGER, MPI_SUM,
     &     id%COMM, IERR)
C     NRLADU related: KEEP8(11) holds factors above and under L0
      CALL MUMPS_REDUCEI8( KEEP8(11),
     &   KEEP8(111), MPI_SUM,
     &   MASTER, id%COMM )
      CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) )
C     NRLADU_if_LR_LU related: KEEP8(32) holds factors above 
C                                        and under L0
C     convert it in Megabytes
      RINFO(5) = dble(KEEP8(32)
     &               *int(KEEP(35),8))/1D6
      CALL MUMPS_REDUCEI8( KEEP8(32),
     &                   ITMP8, MPI_SUM,
     &                   MASTER, id%COMM )
C     in Megabytes
.EQ.      IF (id%MYIDMASTER) THEN
       RINFOG(15) = dble(ITMP8*int(KEEP(35),8))/1D6
      ENDIF
C     --------------
C     Flops estimate
C     --------------
      CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1,
     &     MPI_DOUBLE_PRECISION, MPI_SUM,
     &     id%COMM, IERR)
C
      CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) )
      INFO ( 4 ) = KEEP(  26 )
      INFO ( 5 ) = KEEP(  27 )
      INFO ( 7 ) = KEEP(  29 )
      CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) )
      CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) )
      CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) )
C
      CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) )
      CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) )
      CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) )
      CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) )
      INFOG( 4 ) = KEEP( 126 )
      INFOG( 5 ) = KEEP( 127 )
      CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) )
      CALL ZMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1),
     &     INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1),
     &     id%SIZE_SCHUR )
C     --------------------------
C     COMPUTE MEMORY ESTIMATIONS
      IF (PROK) WRITE( MP, 112 )
.AND..NE.      IF (PROKG  (MPGMP)) WRITE( MPG, 112 )
C     --------------------------
C     =========================
C     IN-CORE MEMORY STATISTICS
C     =========================
C     Per compute node factor real space for factors informtation
      SUM_KEEP811_THIS_NODE=0_8
      CALL MPI_REDUCE( KEEP8(11), SUM_KEEP811_THIS_NODE, 1,
     &                 MPI_INTEGER8,
     &                 MPI_SUM, 0, id%KEEP(411), IERR )
      CALL MPI_REDUCE( SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE,
     &                 1, MPI_INTEGER8, MPI_MAX, 0, id%COMM, IERR )
.AND.      IF (PROKG  PRINT_NODEINFO) THEN
        WRITE(MPG,'(A,I12)')
     &  '    Max. estimated space for factors per compute node       :',
     &  MAX_SUM_KEEP811_THIS_NODE ! * KEEP(35)/1000000_8
      ENDIF
C
         OOC_STRAT = KEEP(201)
         BLR_STRAT = 0  ! no BLR compression
.NE.         IF (KEEP(201)  -1) OOC_STRAT=0 ! We want in-core statistics
         PERLU_ON = .FALSE.     ! switch off PERLU to compute KEEP8(2)
         CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, 
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .FALSE. ! UNDER_L0_OMP
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &        )
.GT.            IF (KEEP(400)  0 ) THEN ! L0 activated
              CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, 
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .TRUE. ! UNDER_L0_OMP
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &        )
              TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) 
              TOTAL_BYTES  = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
            ENDIF
         KEEP8(2) = TOTAL_BYTES    
C
C
         PERLU_ON  = .TRUE.
         CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, 
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .FALSE. ! UNDER_L0_OMP 
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &        )
.GT.         IF (KEEP(400)  0 ) THEN ! L0 activated
           CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &          id%MYID, id%N, id%NELT, id%NA(1), id%LNA, 
     &          id%KEEP8(28),
     &          id%KEEP8(30),
     &          id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
     &          OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, 
     &          IDUMMY, BDUMMY, .FALSE., 
     &          .TRUE. ! UNDER_L0_OMP 
     &          , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &          size(id%I8_L0_OMP,2) 
     &        )
           TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) 
           TOTAL_BYTES  = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
         ENDIF
         IF ( PROK ) THEN
            WRITE(MP,'(A,I12) ')
     & ' Estimated space in MBytes for IC factorization   (INFO(15)):',
     &           TOTAL_MBYTES
         END IF
         id%INFO(15) = TOTAL_MBYTES
C     
C     Centralize memory statistics on the host
C     
C     INFOG(16) = after analysis, est. mem size in Mbytes for facto,
C     for the processor using largest memory
C     INFOG(17) = after analysis, est. mem size in Mbytes for facto,
C     sum over all processors
C     INFOG(18/19) = idem at facto.
C     
      CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM,
     &     id%INFO(15), id%INFOG(16), IRANK )
      IF ( PROKG ) THEN
       IF (PRINT_MAXAVG) THEN
         WRITE( MPG,'(A,I12) ')
     & '    Maximum estim. space in Mbytes, IC facto.    (INFOG(16)):',
     &        id%INFOG(16)
       ENDIF
       WRITE(MPG,'(A,I12) ')
     & '    Total space in MBytes, IC factorization      (INFOG(17)):'
     &        ,id%INFOG(17)
      END IF
C     Per compute node memory information, IC factorization
      SUM_INFO15_THIS_NODE=0
      CALL MPI_REDUCE( INFO(15), SUM_INFO15_THIS_NODE, 1, MPI_INTEGER,
     &                 MPI_SUM, 0, id%KEEP(411), IERR )
      CALL MPI_REDUCE( SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE,
     &                 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR )
.AND.      IF ( PROKG  PRINT_NODEINFO ) THEN
        WRITE(MPG,'(A,I12)')
     &  '    Max. estim. space per compute node, in MBytes, IC fact  :',
     &  MAX_SUM_INFO15_THIS_NODE
      ENDIF
C
C        =========================================
C        NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS
C        (except when OOC_STRAT is equal to -1 in
C        which case IC and OOC statistics are
C        identical)
C        =========================================
         OOC_STRAT = KEEP(201)
         BLR_STRAT = 0  ! no BLR compression
#if defined(OLD_OOC_NOPANEL)
.NE.         IF (OOC_STRAT  -1) OOC_STRAT=2
#else
.NE.         IF (OOC_STRAT  -1) OOC_STRAT=1
#endif
         PERLU_ON = .FALSE.     ! PERLU NOT taken into account
C        Used to compute KEEP8(3) (minimum number of bytes for OOC)
         CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, 
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .FALSE. ! UNDER_L0_OMP 
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &         )
.GT.         IF (KEEP(400)  0 ) THEN ! L0 activated
            CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0, 
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .TRUE. ! UNDER_L0_OMP 
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &        )
            TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) 
            TOTAL_BYTES  = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
         ENDIF
         KEEP8(3) = TOTAL_BYTES
C
         PERLU_ON  = .TRUE.     ! PERLU taken into account
         CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES,
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .FALSE. ! UNDER_L0_OMP 
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &         )
.GT.         IF (KEEP(400)  0 ) THEN ! L0 activated
           CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
     &        id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30),
     &        id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
     &        OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0,
     &        IDUMMY, BDUMMY, .FALSE., 
     &        .TRUE. ! UNDER_L0_OMP 
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &        )
           TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0) 
           TOTAL_BYTES  = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
         ENDIF
         id%INFO(17) = TOTAL_MBYTES
C
      CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM,
     &     id%INFO(17), id%INFOG(26), IRANK )
      IF ( PROKG  ) THEN
       IF (PRINT_MAXAVG) THEN
         WRITE( MPG,'(A,I12) ')
     & '    Maximum estim. space in Mbytes, OOC facto.   (INFOG(26)):',
     &        id%INFOG(26)
       ENDIF
       WRITE(MPG,'(A,I12) ')
     & '    Total space in MBytes,  OOC factorization    (INFOG(27)):'
     &        ,id%INFOG(27)
      END IF
      SUM_INFO17_THIS_NODE=0
      CALL MPI_REDUCE( INFO(17), SUM_INFO17_THIS_NODE, 1, MPI_INTEGER,
     &                 MPI_SUM, 0, id%KEEP(411), IERR )
      CALL MPI_REDUCE( SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE,
     &                 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR )
.AND.      IF (PROKG  PRINT_NODEINFO) THEN
        WRITE(MPG,'(A,I12)')
     &  '    Max. estim. space per compute node, in MBytes, OOC fact :',
     &  MAX_SUM_INFO17_THIS_NODE
      ENDIF
.NE.      IF (KEEP(494)0) THEN
C        =========================================
C        NOW COMPUTE BLR statistics 
C        =========================================
         SUM_OF_PEAKS = .TRUE.
         CALL  ZMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, 
     &        KEEP(1), KEEP8(1),
     &        id%MYID, id%COMM, 
     &        id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
     &        id%KEEP8(30), id%NSLAVES,
     &        id%INFO, id%INFOG, PROK, MP, PROKG, MPG 
     &        , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
     &        size(id%I8_L0_OMP,2) 
     &        )
C
      END IF
C     -------------------------
C     Define a specific mapping
C     for the user
C     -------------------------
.AND..eq.      IF ( id%MYID. eq. MASTER  KEEP(54)  1 ) THEN
         IF (associated( id%MAPPING)) THEN
            DEALLOCATE( id%MAPPING)
         ENDIF
         allocate( id%MAPPING(id%KEEP8(28)), stat=allocok)
.GT.         IF ( allocok  0 ) THEN
            INFO(1) = -7
            CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2))
            IF ( LPOK ) THEN
               WRITE(LP, 150) 'id%MAPPING'
            END IF
            GOTO 92
         END IF
         allocate(IWtemp( id%N ), stat=allocok)
.GT.         IF ( allocok  0 ) THEN
            INFO(1)=-7
            INFO(2)=id%N
            IF ( LPOK ) THEN
               WRITE(LP, 150) 'IWtemp(N)'
            END IF
            GOTO 92
         END IF
.EQ.         IF ( id%KEEP8(28)  0_8 ) THEN
           IRN_PTR => IDUMMY_ARRAY
           JCN_PTR => IDUMMY_ARRAY
         ELSE
           IRN_PTR => id%IRN
           JCN_PTR => id%JCN
         ENDIF
         CALL ZMUMPS_BUILD_MAPPING(
     &        id%N, id%MAPPING(1), id%KEEP8(28),
     &        IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1),
     &        id%STEP(1),
     &        id%NSLAVES, id%SYM_PERM(1),
     &        id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1),
     &        id%root%MBLOCK, id%root%NBLOCK,
     &        id%root%NPROW, id%root%NPCOL )
         DEALLOCATE( IWtemp )
 92      CONTINUE
      END IF
      CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
     &     id%COMM, id%MYID )
.LT.      IF ( INFO(1)  0 ) GOTO 500
C 
  500 CONTINUE
C     Deallocate allocated working space
      IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE)
      IF (allocated(XNODEL)) DEALLOCATE(XNODEL)
      IF (allocated(NODEL)) DEALLOCATE(NODEL)
      IF (allocated(IPOOL)) DEALLOCATE(IPOOL)
      IF (allocated(TNSTK_afterL0)) DEALLOCATE(TNSTK_afterL0)
      IF (allocated(FLAGGED_LEAVES)) DEALLOCATE(FLAGGED_LEAVES)
      IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS)
      IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK)
      CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK)
      CALL MUMPS_AB_FREE_LMAT(LUMAT)
      CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP)
      CALL MUMPS_AB_FREE_GCOMP(GCOMP)
      CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST)
.LT.      IF (INFO(1)  0) THEN
C       Free l0omp data for factorization only
C       in case of error during analysis
        IF (associated(id%IPOOL_B_L0_OMP)) THEN
          DEALLOCATE(id%IPOOL_B_L0_OMP)
          NULLIFY(id%IPOOL_B_L0_OMP)
        ENDIF
        IF (associated(id%IPOOL_A_L0_OMP)) THEN
          DEALLOCATE(id%IPOOL_A_L0_OMP)
          NULLIFY(id%IPOOL_A_L0_OMP)
        ENDIF
        IF (associated(id%VIRT_L0_OMP)) THEN
          DEALLOCATE(id%VIRT_L0_OMP)
          NULLIFY(id%VIRT_L0_OMP)
        ENDIF
        IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN
          DEALLOCATE(id%VIRT_L0_OMP_MAPPING)
          NULLIFY(id%VIRT_L0_OMP_MAPPING)
        ENDIF
        IF (associated(id%PERM_L0_OMP)) THEN
          DEALLOCATE(id%PERM_L0_OMP)
          NULLIFY(id%PERM_L0_OMP)
        ENDIF
        IF (associated(id%PTR_LEAFS_L0_OMP)) THEN
          DEALLOCATE(id%PTR_LEAFS_L0_OMP)
          NULLIFY(id%PTR_LEAFS_L0_OMP)
        ENDIF
      ENDIF
C     Standard deallocations (error or not)
      IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR)
      IF (associated(FREREPTR)) DEALLOCATE(FREREPTR)
      IF (associated(FILSPTR)) DEALLOCATE(FILSPTR)
.AND.      IF (associated(id%BLKPTR)BLKPTR_ALLOCATED) THEN
        DEALLOCATE(id%BLKPTR)
        nullify(id%BLKPTR)
      ENDIF
.AND.      IF (associated(id%BLKVAR)BLKVAR_ALLOCATED) THEN
        DEALLOCATE(id%BLKVAR)
        nullify(id%BLKVAR)
      ENDIF
      KEEP8(26)=max(1_8,KEEP8(26))
      KEEP8(27)=max(1_8,KEEP8(27))
      RETURN
 110  FORMAT(/' ****** ANALYSIS STEP ********'/)
 112  FORMAT(/' MEMORY ESTIMATIONS ... '/
     &   ' Estimations with standard Full-Rank (FR) factorization:')
 145  FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING    =',F12.4)
 150  FORMAT(
     & /' ** failure during zmumps_ana_driver, dynamic allocation of',
     &     A30)
      END SUBROUTINE ZMUMPS_ANA_DRIVER
      SUBROUTINE ZMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE)
!$    USE OMP_LIB, ONLY : omp_get_max_threads
C     This subroutine decodes the control parameters,
C     stores them in the KEEP array, and performs a
C     consistency check on the KEEP array.
      USE ZMUMPS_STRUC_DEF
      IMPLICIT NONE
      TYPE(ZMUMPS_STRUC)  :: id
      LOGICAL :: I_AM_SLAVE
C     internal variables
      INTEGER   :: LP, MP, MPG, I
      INTEGER   :: MASTER
      LOGICAL   :: PROK, PROKG, LPOK
      PARAMETER( MASTER = 0 )
C
      LP  = id%ICNTL( 1 )
      MP  = id%ICNTL( 2 )
      MPG = id%ICNTL( 3 )
C     LP     : errors
C     MP     : INFO
.GT..AND..GE.      LPOK  = ((LP0)(id%ICNTL(4)1))
.GT..AND..GE.      PROK  = (( MP   0 )(id%ICNTL(4)2))
.GT..and..eq.      PROKG = ( MPG  0  id%MYID  MASTER )
.AND..GE.      PROKG = (PROKG(id%ICNTL(4)2))
C     Re-intialize few KEEPs entries corresponding
C     to stat that are incremented such
C     the number of split nodes:
      id%KEEP(61)=0
.eq.      IF (id%MYIDMASTER) THEN
        id%KEEP(400) = 0
.GT.        IF (id%KEEP(401)  0) THEN
!$        id%KEEP(400)=omp_get_max_threads()
.EQ.          IF ( id%KEEP(400)  0 ) THEN
C           Compilation without OMP!
            id%INFO(1)=-58
            id%INFO(2)=0
            IF (LPOK) WRITE(LP,'(a)')
     &      " FAILURE DETECTED IN ANALYSIS: KEEP(401) requires OpenMP"
            RETURN
          ELSE
            IF ( PROKG ) THEN
              WRITE(MPG, '(a,i5,a)')
     &       'keep(401) config at analysis:', id%KEEP(400),
     &       ' threads expected for multithreaded tree parallelism'
            END IF
.EQ.            IF (id%KEEP(400)1) THEN
                id%KEEP(400) = 0
            ENDIF 
          ENDIF
        ENDIF
        id%KEEP(256) = id%ICNTL(7) ! copy ordering option
        id%KEEP(252) = id%ICNTL(32)
.OR.        IF (id%KEEP(252) < 0  id%KEEP(252) > 1 ) THEN
          id%KEEP(252) = 0
        ENDIF
C       Which factors to store
        id%KEEP(251) = id%ICNTL(31)
.OR.        IF (id%KEEP(251) < 0  id%KEEP(251) > 2 ) THEN
          id%KEEP(251)=0
        ENDIF
C       For unsymmetric matrices, if forward solve 
C       performed during facto,
C       no reason to store L factors at all. Reset
C       KEEP(251) accordingly... except if the user
C       tells that no solve is needed.
.EQ..AND..EQ.        IF (id%KEEP(50)  0  id%KEEP(252)1) THEN
.NE.          IF (id%KEEP(251)  1) id%KEEP(251) = 2
        ENDIF
C       Symmetric case, even if no backward needed,
C       store all factors
.NE..AND..EQ.        IF (id%KEEP(50) 0  id%KEEP(251)  2) THEN
          id%KEEP(251) = 0
        ENDIF
C       Case of solve not needed:
.EQ.        IF (id%KEEP(251)  1) THEN
          id%KEEP(201) = -1
C         In that case, id%ICNTL(22) will
C         be ignored in future phases
        ELSE
C         Reset id%KEEP(201) -- typically for the case
C         of a previous analysis with KEEP(201)=-1
          id%KEEP(201) = 0
        ENDIF
.EQ.        IF (id%KEEP(252)1) THEN
          id%KEEP(253) = id%NRHS
.LE.          IF (id%KEEP(253)  0) THEN
            id%INFO(1)=-42
            id%INFO(2)=id%NRHS
            RETURN
          ENDIF
        ELSE
          id%KEEP(253) = 0
        ENDIF
      ENDIF
.NE..AND.      IF ( (id%KEEP(24)0) 
.eq.     &     id%NSLAVES1 ) THEN
         id%KEEP(24) = 0
      END IF
.EQ..AND.      IF ( (id%KEEP(24)0) 
.GT.     &     id%NSLAVES1 ) THEN
         id%KEEP(24) = 8
      ENDIF
.NE..AND..NE..AND.      IF ( (id%KEEP(24)0)   (id%KEEP(24)1)  
.NE..AND..NE..AND.     &     (id%KEEP(24)8)   (id%KEEP(24)10) 
.NE..AND..NE..AND.     &     (id%KEEP(24)12)  (id%KEEP(24)14) 
.NE..AND..NE.     &     (id%KEEP(24)16)  (id%KEEP(24)18)) THEN
         id%KEEP(24) = 8
      END IF
C****************************************************
C     
C     The master is doing most of the work
C     
C     NOTE:  Treatment of the errors on the master=
C     Go to the next SPMD part of the code in which
C     the first statement must be a call to PROPINFO
C     
C****************************************************
C     =========================================
C     Check (raise error or modify) some input
C     parameters or KEEP values on the master.
C     =========================================
      id%KEEP8(21) = int(id%KEEP(85),8)
.EQ.      IF ( id%MYID  MASTER ) THEN
C     -- OOC/Incore strategy 
.NE.         IF (id%KEEP(201)-1) THEN
           id%KEEP(201)=id%ICNTL(22)
.GT.           IF (id%KEEP(201)  0) THEN
#if defined(OLD_OOC_NOPANEL)
             id%KEEP(201)=2
#else
             id%KEEP(201)=1
#endif
           ENDIF
         ENDIF
C        ----------------------------
C        Save id%ICNTL(18) (distributed
C        matrix on entry) in id%KEEP(54)
C        ----------------------------
         id%KEEP(54) = id%ICNTL(18)
.LT..or..GT.         IF ( id%KEEP(54)  0  id%KEEP(54)3 ) THEN
            IF ( PROKG ) THEN
               WRITE(MPG, *) ' out-of-range value for id%ICNTL(18).'
               WRITE(MPG, *) ' used 0 ie matrix not distributed'
            END IF
            id%KEEP(54) = 0
         END IF
.EQ.         IF ( id%KEEP(54)  1 ) THEN
            IF ( PROKG ) THEN
               WRITE(MPG, *) ' option id%ICNTL(18)=1 is obsolete.'
               WRITE(MPG, *) ' we recommend not to use it.'
               WRITE(MPG, *) ' it will disappear in a future release'
            END IF
         END IF
C     -----------------------------------------
C     Save id%ICNTL(5) (matrix format) in id%KEEP(55)
C     -----------------------------------------
         id%KEEP(55) = id%ICNTL(5)
.LT..OR..GT.         IF ( id%KEEP(55)  0  id%KEEP(55)  1 ) THEN
            IF ( PROKG ) THEN
               WRITE(MPG, *) ' out-of-range value for id%icntl(5).'
               WRITE(MPG, *) ' used 0 ie matrix is assembled'
            END IF
            id%KEEP(55) = 0
         END IF
         id%KEEP(60) = id%ICNTL(19)
.LE.         IF ( id%KEEP( 60 )  0 ) id%KEEP( 60 ) = 0
.GT.         IF ( id%KEEP( 60 )  3 ) id%KEEP( 60 ) = 0
.NE..AND.         IF (id%KEEP(60)  0  id%SIZE_SCHUR == 0 ) THEN
            IF (PROKG) THEN
              WRITE(MPG,'(a)')
     &        ' ** schur option ignored because size_schur=0'
            ENDIF
            id%KEEP(60)=0
         END IF
C        ---------------------------------------
C        Save SIZE_SCHUR in a KEEP, for possible
C        check at factorization and solve phases
C        ---------------------------------------
.NE.         IF ( id%KEEP(60) 0 ) THEN
            id%KEEP(116) = id%SIZE_SCHUR
.LT..OR..GE.            IF (id%SIZE_SCHUR  0  id%SIZE_SCHUR  id%N) THEN
              id%INFO(1)=-49
              id%INFO(2)=id%SIZE_SCHUR
              RETURN
            ENDIF
C           List of Schur variables provided by user.
.NOT.            IF (  associated( id%LISTVAR_SCHUR ) ) THEN
               id%INFO(1) = -22
               id%INFO(2) = 8
               RETURN
            ELSE IF (size(id%LISTVAR_SCHUR)<id%SIZE_SCHUR) THEN
               id%INFO(1) = -22
               id%INFO(2) = 8
               RETURN
            END IF
         ENDIF
.EQ..AND..NE.         IF (id%KEEP(60)  3  id%KEEP(50)0) THEN
.AND..AND.            IF (id%MBLOCK > 0  id%NBLOCK > 0 
.AND.     &           id%NPROW > 0  id%NPCOL > 0 ) THEN
.LE.               IF (id%NPROW *id%NPCOL  id%NSLAVES) THEN
C     We will eventually have to "symmetrize the
C     Schur complement. For that NBLOCK and MBLOCK
C     must be equal.
.NE.                  IF (id%MBLOCK  id%NBLOCK ) THEN
                     id%INFO(1)=-31
                     id%INFO(2)=id%MBLOCK - id%NBLOCK
                     RETURN
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
C     Check the ordering strategy and compatibility with
C     other control parameters
         id%KEEP(244) = id%ICNTL(28)
         id%KEEP(245) = id%ICNTL(29)
#if ! defined(parmetis) && ! defined(parmetis3)        
.EQ..AND..EQ.         IF ((id%KEEP(244)  2)  (id%KEEP(245)  2)) THEN
            id%INFO(1)  = -38
            IF ( LPOK ) THEN
               WRITE(LP,'("ParMETIS not available.")')
            END IF
            RETURN
         END IF
#endif
#if ! defined(ptscotch)         
.EQ..AND..EQ.         IF ((id%KEEP(244)  2)  (id%KEEP(245)  1)) THEN
            id%INFO(1)  = -38
            IF ( LPOK ) THEN
               WRITE(LP,'("pt-scotch not available.")')
            END IF
            RETURN
         END IF
#endif
C        Analysis strategy is set to automatic in case of out-of-range values.
.GT..OR.         IF((id%KEEP(244)  2) 
.LT.     &        (id%KEEP(244)  0)) id%KEEP(244)=0
.EQ.         IF(id%KEEP(244)  0) THEN ! Automatic
C           One could check for availability of parallel ordering
C           tools, or for possible options incompatible with //
C           analysis to decide (e.g. avoid returning an error if
C           // analysis not compatible with some option but user
C           lets MUMPS decide to choose sequential or paralllel
C           analysis)
C           Current strategy for automatic is sequential analysis
            id%KEEP(244) = 1
.EQ.         ELSE IF (id%KEEP(244)  2) THEN
.NE.            IF(id%KEEP(55)  0) THEN
               id%INFO(1)  = -39
               IF (LPOK) THEN
               WRITE(LP,
     &              '("incompatible values for icntl(5), icntl(28)")')
               WRITE(LP,
     &              '("parallel analysis is not possible if the")')
               WRITE(LP,
     &              '("matrix is not assembled")')
               ENDIF
               RETURN
.NE.            ELSE IF(id%KEEP(60)  0) THEN
               id%INFO(1)  = -39
               IF (LPOK) THEN
               WRITE(LP,
     &              '("incompatible values for icntl(19), icntl(28)")')
               WRITE(LP,
     &              '("parallel analysis is not possible if schur")')
               WRITE(LP,
     &              '("complement must be returned")')
               ENDIF
               RETURN
            END IF
C     In the case where there are too few processes to do
C     the parallel analysis we simply revert to sequential version
.LT.            IF(id%NSLAVES  2) THEN
               id%KEEP(244) = 1
               IF(PROKG) WRITE(MPG,
     &              '("too few processes.
     & reverting to sequential analysis")',advance='no')
.EQ.               IF(id%KEEP(245)  1) THEN
C                 Scotch necessarily available because pt-scotch
C                 is, otherwise an error would have occurred
                  IF(PROKG) WRITE(MPG, '(" with scotch.")')
                  id%KEEP(256) = 3
.EQ.               ELSE IF(id%KEEP(245)  2) THEN
C                 Metis necessarily available because parmetis
C                 is, otherwise an error would have occurred
                  IF(PROKG) WRITE(MPG, '(" with metis.")')
                  id%KEEP(256) = 5
               ELSE
                  IF(PROKG) WRITE(MPG, '(".")')
                  id%KEEP(256) = 7
               END IF
            END IF
C     In the case where there the input matrix is too small to do
C     the parallel analysis we simply revert to sequential version
.LE.            IF(id%N  50) THEN
               id%KEEP(244) = 1
               IF(PROKG) WRITE(MPG,
     &            '("input matrix is too small for the parallel
     & analysis. reverting to sequential analysis")',advance='no')
.EQ.               IF(id%KEEP(245)  1) THEN
                  IF(PROKG) WRITE(MPG, '(" with scotch.")')
                  id%KEEP(256) = 3
.EQ.               ELSE IF(id%KEEP(245)  2) THEN
                  IF(PROKG) WRITE(MPG, '(" with metis.")')
                  id%KEEP(256) = 5
               ELSE
                  IF(PROKG) WRITE(MPG, '(".")')
                  id%KEEP(256) = 7
               END IF
            END IF
         END IF
         id%INFOG(32) = id%KEEP(244)
.EQ..AND.         IF ( (id%KEEP(244)  1) 
.EQ.     &        (id%KEEP(256)  1) ) THEN
C     ordering given, PERM_IN must be of size N
.NOT.            IF (  associated( id%PERM_IN ) ) THEN
               id%INFO(1) = -22
               id%INFO(2) = 3
               RETURN
            ELSE IF ( size( id%PERM_IN ) < id%N ) THEN
               id%INFO(1) = -22
               id%INFO(2) = 3
               RETURN
            END IF
         ENDIF
C     Check KEEP(9-10) for level 2
.LE.         IF (id%KEEP(9)  1 ) id%KEEP(9) = 500
.GT.         IF ( id%KEEP8(21)  0_8 ) THEN 
.LE..OR.            IF ((id%KEEP8(21)1_8) 
.GT.     &          (id%KEEP8(21)int(id%KEEP(9),8)))
     &         id%KEEP8(21) = int(min(id%KEEP(9),100),8)
         ENDIF
C     
         IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345
C     
.LT..OR..GT.         IF ( (id%KEEP(48)0)  (id%KEEP(48)5) ) THEN
            id%KEEP(48)=5
         ENDIF
C     Schur 
C     Given ordering must be compatible with Schur variables.
.NE..AND..EQ.         IF ( (id%KEEP(60)  0)  (id%KEEP(256)  1) ) THEN
            DO I = 1, id%SIZE_SCHUR
               IF (id%PERM_IN(id%LISTVAR_SCHUR(I))
.EQ.     &               id%N-id%SIZE_SCHUR+I)
     &              CYCLE
C              -------------------------------
C              Problem with PERM_IN: -22/3
C              Above constrained explained in
C              doc of PERM_IN in user guide.
C              -------------------------------
               id%INFO(1) = -4
               id%INFO(2) = id%LISTVAR_SCHUR(I)
               RETURN
               IF (PROKG) THEN
                  WRITE(MPG,'(A)')
     & ' ** Ignoring user-ordering, because incompatible with Schur.'
                  WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.'
               END IF
               EXIT
            ENDDO
         END IF
C     
C     Note that schur is not compatible with
C     
C     1/Max-trans DONE
C     2/Null space
C     3/Ordering given DONE
C     4/Scaling
C     5/Iterative Refinement
C     6/Error analysis
C     7/Parallel Analysis
C     
C     Graph modification prior to ordering (id%ICNTL(12) option)
C     id%KEEP (95) will hold the eventually modified value of id%ICNTL(12)
C     
         id%KEEP(95) = id%ICNTL(12)
C        reset to usual ordering (KEEP(95)=1)
C          - when matrix is not general symmetric 
C          - for out-of-range values
.NE.         IF (id%KEEP(50)2) id%KEEP(95) = 1
.GT..OR..LT.         IF ((id%KEEP(95)3)(id%KEEP(95)0)) id%KEEP(95) = 1
C     MAX-TRANS
C     
C     id%KEEP (23) will hold the eventually modified value of id%ICNTL(6)
C     (maximum transversal if >= 1)
C     
         id%KEEP(23) = id%ICNTL(6)
C     
C     
C     --------------------------------------------
C     Avoid max-trans unsymmetric permutation in case of
C     matrix is symmetric with SYM=1 or 
C     ordering is given,
C     or matrix is in element form, or Schur is asked
C     or initial matrix is distributed
C     --------------------------------------------
.LT..OR..GT.         IF (id%KEEP(23)0id%KEEP(23)7) id%KEEP(23) = 0
C        still forbid max trans for SYM=1 case
.EQ.         IF ( id%KEEP(50)  1 ) THEN
.NE.            IF (id%KEEP(23)  0) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A)')
     & ' ** Max-trans not needed with SYM=1 factorization'
               END IF
               id%KEEP(23) = 0
            ENDIF
.GT.            IF (id%KEEP(95)  1) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A)')
     & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization'
               END IF
            ENDIF
            id%KEEP(95) = 1
         END IF
C     
.GT.         IF  (id%KEEP(60)  0) THEN
.NE.            IF (id%KEEP(23)  0) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A)')
     &                 ' ** Max-trans not allowed because of Schur'
               END IF
               id%KEEP(23) = 0
            ENDIF
.EQ.            IF (id%KEEP(52)-2) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A)')
     & ' ** Scaling during analysis not allowed because of Schur'
               ENDIF
               id%KEEP(52) = 0
            ENDIF
C     also forbid compressed/constrained ordering...
.GT.            IF (id%KEEP(95)  1) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A)')
     & ' ** ICNTL(12) option not allowed because of Schur'
               END IF
            ENDIF
            id%KEEP(95) = 1
         END IF
.NE..AND..EQ.         IF ( (id%KEEP(23)  0)  (id%KEEP(256)1)) THEN
            id%KEEP(23) = 0
            IF (PROKG) THEN
               WRITE(MPG,'(A,A)')
     &          ' ** Maximum transversal (ICNTL(6)) not allowed ',
     &         'because ordering is given'
            END IF
         END IF
.EQ.         IF ( id%KEEP(256)  1 ) THEN
.AND.            IF (id%KEEP(95) > 1  PROKG) THEN
               WRITE(MPG,'(A)')
     &      ' ** ICNTL(12) option incompatible with given ordering'
            END IF
            id%KEEP(95) = 1
         END IF
.NE.         IF (id%KEEP(54)  0) THEN
.NE.            IF( id%KEEP(23)  0 ) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A,A)')
     &            ' ** Maximum transversal (ICNTL(6)) not allowed ',
     &            'because matrix is distributed'
               END IF
               id%KEEP(23) = 0
            ENDIF
.EQ.            IF (id%KEEP(52)-2) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A,A)')
     &            ' ** Scaling (ICNTL(8)) during analysis not ', 
     &            'allowed because matrix is distributed)'
               ENDIF
            ENDIF
            id%KEEP(52) = 0
.GT..AND..GT.            IF (id%KEEP(95)  1  MPG0) THEN
               WRITE(MPG,'(A,A)')
     &         ' ** ICNTL(12) option not allowed because matrix is ', 
     &         'distributed'
            ENDIF
            id%KEEP(95) = 1
         END IF
.NE.         IF ( id%KEEP(55)  0 ) THEN
.NE.            IF( id%KEEP(23)  0 ) THEN
               IF (PROKG) THEN
                  WRITE(MPG,'(A,A)')
     &            ' ** Maximum transversal (ICNTL(6)) not allowed ',
     &            'for matrices in elemental format'
               END IF
               id%KEEP(23) = 0
            ENDIF
.AND..EQ.            IF (PROKG  id%KEEP(52)-2) THEN
               WRITE(MPG,'(A)')
     &            ' ** Scaling (ICNTL(8)) not allowed ',
     &            'for matrices in elemental format'
            ENDIF
            id%KEEP(52) = 0
            id%KEEP(95) = 1
         ENDIF
C     In the case where parallel analysis is done, column permutation
C     is not allowed
.EQ.         IF(id%KEEP(244)  2) THEN
.EQ.            IF(id%KEEP(23)  7) THEN
C     Automatic hoice: set it to 0
               id%KEEP(23) = 0
.GT.            ELSE IF (id%KEEP(23)  0) THEN
               id%INFO(1)  = -39
               id%KEEP(23) = 0
               IF (LPOK) THEN
               WRITE(LP,
     &              '("incompatible values for icntl(6), icntl(28)")')
               WRITE(LP,
     &              '("maximum transversal not allowed
     &                 in parallel analysis")')
               ENDIF
               RETURN
            END IF
         END IF
C     --------------------------------------------
C     Avoid distributed entry for element matrix.
C     --------------------------------------------
.NE..AND..NE.         IF ( id%KEEP(54)  0  id%KEEP(55)  0 ) THEN
            id%KEEP(54) = 0
            IF (PROKG) THEN
               WRITE(MPG,'(A)')
     & ' ** Distributed entry not available for element matrix'
            END IF
         ENDIF
C     ----------------------------------
C     Choice of symbolic analysis option
C     ----------------------------------
.NE..and..NE.         IF (id%ICNTL(58)1  id%ICNTL(58)2
.and..NE..and..NE.     &     id%ICNTL(58)3   id%ICNTL(58)4 ) THEN
C        out of range values leads to symbolic based on SYMBQAMD
            id%KEEP(106)=1
         ELSE
            id%KEEP(106)=id%ICNTL(58)
.GE.            IF (id%KEEP(106)4) THEN
C            option not available 
             id%KEEP(106)=1
            ENDIF
         ENDIF
C     modify input parameters to avoid incompatible
C     input data between ordering, scaling and maxtrans
C     note that if id%ICNTL(12)/id%KEEP(95) = 0 then
C     the automatic choice will be done in ANA_O
.EQ.         IF(id%KEEP(50)  2) THEN
C     LDLT case
.NOT.            IF(  associated(id%A) ) THEN
C     constraint ordering can be computed only if values are
C     given to analysis
.EQ.               IF(id%KEEP(95)  3) THEN
                  id%KEEP(95) = 2
               ENDIF
            ENDIF
.EQ..AND..NE.            IF(id%KEEP(95)  3  id%KEEP(256)  2) THEN
C     if constraint and ordering is not AMF then use compress
               IF (PROK) WRITE(MP,*)
     &              'WARNING: ZMUMPS_ANA_O constrained ordering not ', 
     &              'available with selected ordering'
               id%KEEP(95) = 2
            ENDIF 
.EQ.            IF(id%KEEP(95)  3) THEN
C     if constraint ordering required then we need to compute scaling
C     and max trans
C     NOTE that if we enter this condition then
C     id%A is associated because of the test above:
C     (IF( .NOT. associated(id%A) ) THEN)
               id%KEEP(23) = 5
               id%KEEP(52) = -2
.EQ..AND.            ELSE IF(id%KEEP(95)  2  
.EQ..OR..EQ.     &              (id%KEEP(23)  0  id%KEEP(23)  7) ) THEN
C     compressed ordering requires max trans but not necessary scaling
               IF( associated(id%A) ) THEN
                  id%KEEP(23) = 5
               ELSE
C     we can do compressed ordering without
C     information on the numerical values:
C     a maximum transversal already provides
C     information on the location of off-diagonal
C     nonzeros which can be candidates for 2x2
C     pivots
                  id%KEEP(23) = 1
               ENDIF
.EQ.            ELSE IF(id%KEEP(95)  1) THEN
               id%KEEP(23) = 0
.EQ..AND..EQ.            ELSE IF(id%KEEP(95)  0  id%KEEP(23)  0) THEN
C     if max trans desactivated then the automatic choice for type of ord
C     is set to 1, which means that we will use usual ordering
C     (no constraints or compression)
               id%KEEP(95) = 1
            ENDIF
         ELSE
            id%KEEP(95) = 1
         ENDIF
C     --------------------------------
C     Save ICNTL(56) (QR) in KEEP(53)
C     Will be broadcasted to all other
C     nodes in routine ZMUMPS_BDCAST
C     --------------------------------
         id%KEEP(53)=0
.EQ.         IF(id%KEEP(86)1)THEN
C     Force the exchange of both the memory and flops information during 
C     the factorization
.LT.            IF(id%KEEP(47)2) id%KEEP(47)=2
         ENDIF
.EQ.         IF(id%KEEP(48)5)THEN
.EQ.            IF(id%KEEP(50)0)THEN
               id%KEEP(87)=50
               id%KEEP(88)=50
            ELSE
               id%KEEP(87)=70
               id%KEEP(88)=70
            ENDIF
         ENDIF
.EQ..AND..GT.         IF((id%NSLAVES1)(id%KEEP(76)3))THEN
            id%KEEP(76)=2
         ENDIF
.GT.         IF(id%KEEP(81)0)THEN
.LT.            IF(id%KEEP(47)2) id%KEEP(47)=2
         ENDIF
C
C        -- Save Block Low Rank input parameter 
         id%KEEP(494) = id%ICNTL(35)
.EQ.         IF (id%KEEP(494)1) THEN
C        -- Automatic BLR option setting
           id%KEEP(494)= 2
         ENDIF
.EQ.         IF ( id%KEEP(494)4) id%KEEP(494)=0
.LT..OR..GT.         IF ((id%KEEP(494)0)(id%KEEP(494)4)) THEN
C          Out of range values treated as 0
           id%KEEP(494) = 0
         ENDIF
.NE.         IF(id%KEEP(494)0) THEN
C        test BLR incompatibilities
C
          id%KEEP(464) = id%ICNTL(38)
.LT..OR..GT.          IF (id%KEEP(464)0(id%KEEP(464)1000)) THEN
C          Out of range values treated as 0
           id%KEEP(464) = 0
          ENDIF
          id%KEEP(465) = id%ICNTL(39)
.LT..OR..GT.          IF (id%KEEP(465)0(id%KEEP(465)1000)) THEN
C          Out of range values treated as 0
           id%KEEP(465) = 0
          ENDIF
C         LR is incompatible with elemental matrices, forbid it at analysis
.NE.          IF (id%KEEP(55)0) THEN
            IF (LPOK) WRITE(LP,*)
     &           " *** blr feature currently incompatible "
     &           ,"with elemental matrices"
C           BLR for elt entry might be developed in the future
            id%INFO(1)=-800
            id%INFO(2)=5
            RETURN
          ENDIF
C
C         LR incompatible with forward in facto 
.NE.          IF (id%KEEP(252)0) THEN
            IF (LPOK) WRITE(LP,*)
     &        " *** blr feature currently incompatible"
     &       ," with forward during factorization"
             id%INFO(1) = -43
             id%INFO(2) = 35
             RETURN
          ENDIF
C
         ENDIF
C
.NE.         IF(id%KEEP(494)0) THEN
C         id%KEEP(469)=0,1,2,3,4
.GT..OR..LT.          IF ((id%KEEP(469)4)(id%KEEP(469)0)) THEN
               id%KEEP(469)=0
          ENDIF
C         Not implemented yet               
.EQ.          IF (id%KEEP(469)4) id%KEEP(469)=0
C         id%KEEP(471)=-1,0,1
.LT..AND..GT.          IF ((id%KEEP(471)-1)(id%KEEP(471)1)) THEN
               id%KEEP(471)=-1
          ENDIF
C         id%KEEP(472)=0 or 1
.NE..AND..NE.          IF ((id%KEEP(472)0)(id%KEEP(472)1)) THEN
               id%KEEP(472)=1
          ENDIF
C         id%KEEP(475)=0,1,2,3
.GT..OR..LT.          IF ((id%KEEP(475)3)(id%KEEP(475)0)) THEN
               id%KEEP(475)=0
          ENDIF
C         id%KEEP(482)=0,1,2,3
.GT..OR..LT.          IF ((id%KEEP(482)3)(id%KEEP(482)0)) THEN
               id%KEEP(482)=0
          ENDIF
.LT.          IF((id%KEEP(487)0)) THEN
             id%KEEP(487)= 2 ! default value
          ENDIF
C         id%KEEP(488)>0
.LE.          IF((id%KEEP(488)0)) THEN
              id%KEEP(488)=  8*id%KEEP(6) 
          ENDIF
C         id%KEEP(490)>0
.LE.          IF((id%KEEP(490)0)) THEN
             id%KEEP(490) = 128
          ENDIF
C         KEEP(491)>0
.LE.          IF((id%KEEP(491)0)) THEN
            id%KEEP(491) = 1000
          ENDIF
         ENDIF
C 
      id%KEEP(13) = 0
C     Analysis by Blocks
      id%KEEP(13) = id%ICNTL(15)
.GT.      IF (id%KEEP(13)1) THEN
CV0   out-of range values
        id%KEEP(13) = 0
      ENDIF
.LT.      IF (id%KEEP(13)0) THEN
.NE.        IF (mod(id%N,-id%KEEP(13)) 0) THEN
          IF ( LPOK ) THEN
             WRITE(LP,'(A,I8)') 
     &       " icntl(15)=", id%ICNTL(15), 
     &       " is incompatible with n=", id%N
          ENDIF
          id%INFO(1) = -57
          id%INFO(2) = 1
        ENDIF
        IF (associated(id%BLKPTR)) THEN
          IF ( LPOK ) THEN
             WRITE(LP,'(A,I8)') 
     &       " icntl(15)=", id%ICNTL(15), 
     &       " is incompatible with blkptr provided by user"
          ENDIF
          id%INFO(1) = -57
          id%INFO(2) = 4
        ENDIF
      ENDIF
.EQ..AND.      IF (  (id%KEEP(13)0)            
.NOT..AND.     &      ( associated(id%BLKPTR)) 
.NOT.     &      ( associated(id%BLKVAR))
     &   )
     &  THEN
.EQ..AND..NE.       IF ((id%KEEP(54)3)(id%KEEP(244)2)) THEN
          id%KEEP(13)=-1
       ENDIF
      ENDIF
.EQ..AND.      IF ( (id%KEEP(13)0           ) 
.NOT..AND.     &      ( associated(id%BLKPTR)) 
.NOT..AND.     &      ( associated(id%BLKVAR)) 
.NE.     &      (id%KEEP(244)2)
     &   )
     &  THEN
C       unsymmetic assembled matrices with or without BLR,
C       also in case of centralized matrix (if
C       matrix is distributed, then KEEP(13) has
C       been set to -1 in the block above)
.EQ..AND..EQ.        IF (id%KEEP(50)0 id%KEEP(55)0) THEN
C         Respect decision taken for Maxtrans
C         since it will be switch off 
C         if one activates the analysis by block
.LE..OR..GT.          IF ( (id%KEEP(23)0)  (id%KEEP(23)7)
     &       ) THEN
             id%KEEP(13)=-1
          ENDIF
        ENDIF
      ENDIF
.EQ..AND.      IF ( (id%KEEP(13)0)  
.NE.     &     (id%KEEP(55)0) 
     &   ) THEN
.AND..NE.         IF (PROKG(id%KEEP(13)-1)) WRITE(MPG,'(A,A)')
     &           " ** analysis by block is incompatible ",
     &           "with elemental matrices"
C           switch off analysis by block
            id%KEEP(13)= 0
      ENDIF
.NE..AND.      IF ( (id%KEEP(13)0) 
.NE..AND..NE.     &     (id%KEEP(106)1) (id%KEEP(106)2)
     &   ) THEN
.AND..NE.         IF (PROKG(id%KEEP(13)-1)) WRITE(MPG,'(A,A,I4)')
     &      " ** analysis by block not compatible ",
     &      "with symbolic factorization option  ", 
     &           id%KEEP(106)
C           switch off analysis by block
            id%KEEP(13)= 0
      ENDIF
.NE..AND.      IF ( (id%KEEP(13)0) 
.EQ.     &     (id%KEEP(244)2) 
     &   ) THEN
.AND..NE.         IF (PROKG(id%KEEP(13)-1)) WRITE(MPG,'(A,A)')
     &           " ** analysis by block is incompatible ",
     &           "with parallel ordering "
C           switch off analysis by block
            id%KEEP(13)= 0
      ENDIF
.NE..AND.      IF ( (id%KEEP(13)0) 
.NE.     &     (id%KEEP(60)0) 
     &   ) THEN
.AND..NE.         IF (PROKG(id%KEEP(13)-1)) WRITE(MPG,'(A,A)')
     &           " ** analysis by block is incompatible ",
     &           "with schur "
C           switch off analysis by block
            id%KEEP(13)= 0
      ENDIF
.NE.      IF (id%KEEP(13)0) THEN
C      Maximum transversal not compatible with analysis by block
.NE.       IF (id%KEEP(23)0) THEN
C        in case of automatic choice (id%KEEP(27).EQ.7)
C        do not print message
.AND..NE.         IF (PROKGid%KEEP(23)7) WRITE(MPG,'(A,A)')
     &      " ** maximum transversal(icntl(6)) ",
     &      "not compatible with analysis by block"
C        switch off max transversal
         id%KEEP(23)= 0
       ENDIF
C      - compression for LDLT
.NE.       IF (id%KEEP(95)1) THEN
C        in case of automatic choice (id%KEEP(95).EQ.0)
C        do not print message
.AND..NE.         IF (PROKGid%KEEP(95)0) WRITE(MPG,'(A,A)')
     &      " ** icntl(12) not compatible with ",
     &      " analysis by block"
C        switch off 2x2 preprocessing for symmetric matrices
         id%KEEP(95) = 1 
       ENDIF
      ENDIF
C
C     end id%MYID.EQ.MASTER 
      END IF 
      RETURN
      END SUBROUTINE ZMUMPS_ANA_CHECK_KEEP
      SUBROUTINE ZMUMPS_GATHER_MATRIX(id)
C     This subroutine gathers a distributed matrix
C     on the host node 
      USE ZMUMPS_STRUC_DEF
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INTEGER IERR, MASTER
      PARAMETER( MASTER = 0 )
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      TYPE(ZMUMPS_STRUC)  :: id
C     local variables
      INTEGER, ALLOCATABLE :: REQPTR(:,:)
      INTEGER(8), ALLOCATABLE :: MATPTR(:)
      INTEGER(8), ALLOCATABLE :: MATPTR_cp(:)
      INTEGER(8)           :: IBEG8, IEND8
      INTEGER              :: INDX
      INTEGER              :: LP, MP, MPG, I, K
      INTEGER(8)           :: I8
      LOGICAL              :: PROK, PROKG
C     
C     messages are split into blocks of size BLOCKSIZE
C               (smaller than IOVFLO (=2^31-1))
C     on all processors
      INTEGER(4)           :: IOVFLO
      INTEGER              :: BLOCKSIZE 
      INTEGER              :: MAX_NBBLOCK_loc, NBBLOCK_loc
      INTEGER              :: SIZE_SENT, NRECV
      LOGICAL              :: OMP_FLAG, I_AM_SLAVE
      INTEGER(8)           :: NZ_loc8
C     for validation only:
      INTEGER              :: NB_BLOCKS, NB_BLOCK_SENT
      LP  = id%ICNTL( 1 )
      MP  = id%ICNTL( 2 )
      MPG = id%ICNTL( 3 )
C     LP     : errors
C     MP     : INFO
.GT..AND..GE.      PROK  = (( MP   0 )(id%ICNTL(4)2))
.GT..and..eq.      PROKG = ( MPG  0  id%MYID  MASTER )
.AND..GE.      PROKG = (PROKG(id%ICNTL(4)2))
.ne..OR.      I_AM_SLAVE = ( id%MYID  MASTER  
.eq..AND.     &     ( id%MYID  MASTER 
.eq.     &     id%KEEP(46)  1 ) )
C     iovflo = huge(INTEGER, kind=4)
      IOVFLO = huge(IOVFLO)  
C     we do not want too large messages
      BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8))
.EQ..AND..EQ.      IF ( id%KEEP(46)  0  id%MYID  MASTER ) THEN
C     host-node mode: master has no entries.
         id%KEEP8(29) = 0_8
      END IF
.eq.      IF ( id%MYID  MASTER ) THEN
C     -----------------------------------
C     Allocate small arrays for pointers
C     into arrays IRN/JCN
C     -----------------------------------
         ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR )
.GT.         IF ( IERR  0 ) THEN
            id%INFO(1) = -7
            id%INFO(2) =  id%NPROCS
.GT.            IF ( LP  0 ) THEN
               WRITE(LP, 150) ' array MATPTR'
            END IF
            GOTO 13
         END IF
         ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR )
.GT.         IF ( IERR  0 ) THEN
            id%INFO(1) = -7
            id%INFO(2) =  id%NPROCS
.GT.            IF ( LP  0 ) THEN
               WRITE(LP, 150) ' array MATPTR'
            END IF
            GOTO 13
         END IF
C     -----------------------------------
C     Allocate a small array for requests
C     -----------------------------------
         ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR )         
.GT.         IF ( IERR  0 ) THEN
            id%INFO(1) = -7
            id%INFO(2) = 2 * (id%NPROCS-1)
.GT.            IF ( LP  0 ) THEN
               WRITE(LP, 150) 'array REQPTR'
            END IF
            GOTO 13
         END IF
C     --------------------
C     Allocate now IRN/JCN
C     --------------------
         ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR )
.GT.         IF ( IERR  0 ) THEN
            id%INFO(1) = -7
            CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2))
.GT.            IF ( LP  0 ) THEN
               WRITE(LP, 150) 'array IRN'
            END IF
            GOTO 13
         END IF
         ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR )
.GT.         IF ( IERR  0 ) THEN
            id%INFO(1) = -7
            CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2))
.GT.            IF ( LP  0 ) THEN
               WRITE(LP, 150) 'array JCN'
            END IF
            GOTO 13
         END IF
      END IF
 13   CONTINUE
C     Propagate errors
      CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
     &     id%COMM, id%MYID )
      IF ( id%INFO(1) < 0 ) RETURN
C     -------------------------------------
C     Get numbers of non-zeros for everyone
C     and count total and maximum 
C     nb of blocks of size BLOCKSIZE
C     that slaves will sent
C     -------------------------------------
.EQ.      IF ( id%MYID  MASTER ) THEN
C        each block will correspond to 2 messages (IRN_LOC,JCN_LOC)
         NB_BLOCK_SENT = 0
         MAX_NBBLOCK_loc  = 0
         DO I = 1, id%NPROCS - 1
            CALL MPI_RECV( MATPTR( I+1 ), 1, 
     &           MPI_INTEGER8, I,
     &           COLLECT_NZ, id%COMM, STATUS, IERR )
            NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE))
            MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc)
            NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc
         END DO
.eq.         IF ( id%KEEP(46)  0 ) THEN
            MATPTR( 1 ) = 1_8
         ELSE
            NZ_loc8=id%KEEP8(29)
            MATPTR( 1 ) = NZ_loc8 + 1_8
         END IF
C     --------------
C     Build pointers
C     --------------
         DO I = 2, id%NPROCS
            MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 )
         END DO
      ELSE
         NZ_loc8=id%KEEP8(29)
         CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER,
     &        COLLECT_NZ, id%COMM, IERR )
      END IF
.eq.      IF ( id%MYID  MASTER  ) THEN
C     -----------------------------------------------
C     Bottleneck is here master; use synchronous send
C     for slaves, but asynchronous receives on master
C     Then while master receives indices do the local
C     copies for better overlap. 
C     (If master has other things to do, he could try
C     to do them here.)
C     ------------------------------------
C       copy pointers to position in IRN/JCN 
        MATPTR_cp = MATPTR
.NE.        IF ( id%KEEP8(29)  0_8 ) THEN
.GE.            OMP_FLAG = ( id%KEEP8(29)50000_8 )
!$OMP PARALLEL DO PRIVATE(I8)
!$OMP&         IF(OMP_FLAG)
            DO I8=1,id%KEEP8(29)
               id%IRN(I8) = id%IRN_loc(I8)
               id%JCN(I8) = id%JCN_loc(I8)
            ENDDO
!$OMP END PARALLEL DO
        ENDIF
C
C     Compute position for each block to be received
C     and store it.
        NB_BLOCKS = 0
C       at least one slave will send MAX_NBBLOCK_loc 
C       couple of messages (IRN_loc/JCN_loc)
        DO K = 1, MAX_NBBLOCK_loc
C        Post irecv for all messages from proc I 
C        that have been sent
         NRECV = 0
         DO I = 1, id%NPROCS - 1
C           Check if message was sent
            IBEG8     = MATPTR_cp( I )
.LT.            IF ( IBEG8  MATPTR(I+1))  THEN
C             Count number of request in NRECV
              NRECV = NRECV + 2
              IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, 
     &                    MATPTR(I+1)-1_8)
C             update pointer for receiving messages
C             from proc I in MATPTR_cp:
              MATPTR_cp( I ) = IEND8 + 1_8
              SIZE_SENT   = int(IEND8 -  IBEG8 + 1_8)
              NB_BLOCKS   = NB_BLOCKS + 1
C
              CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER,
     &           I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR )
C
              CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER,
     &           I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR )
            ELSE
             REQPTR( I,1 ) = MPI_REQUEST_NULL
             REQPTR( I,2 ) = MPI_REQUEST_NULL
            ENDIF
         END DO
C        Wait set of messages corresponding to current block
C        ( we dont exploit the fact that 
C            messages are not overtaking 
C            (if sent by one source to the same destination)  )
C
C        Loop on only non MPI_REQUEST_NULL requests
         DO I = 1, NRECV
             CALL MPI_WAITANY
     &           ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, 
     &           STATUS, IERR )
         ENDDO
C
C       process next block
      END DO
        DEALLOCATE( REQPTR )
        DEALLOCATE( MATPTR )
        DEALLOCATE( MATPTR_cp )
C     end of reception by master
      ELSE
C     -----------------------------
C     Send only if size is not zero
C     -----------------------------
.NE.         IF ( id%KEEP8(29)  0_8 ) THEN
           NZ_loc8=id%KEEP8(29) 
C          send by blocks of size BLOCKSIZE
           DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8)
            SIZE_SENT = BLOCKSIZE
.LT.            IF (NZ_loc8-I8+1_8int(BLOCKSIZE,8)) THEN
              SIZE_SENT = int(NZ_loc8-I8+1_8)
            ENDIF
            CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT,
     &           MPI_INTEGER, MASTER,
     &           COLLECT_IRN, id%COMM, IERR )
            CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT,
     &           MPI_INTEGER, MASTER,
     &           COLLECT_JCN, id%COMM, IERR )
           END DO
         END IF
      END IF
      RETURN
 150  FORMAT(
     &/' ** FAILURE DURING ZMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF',
     &     A30)
      END SUBROUTINE ZMUMPS_GATHER_MATRIX
      SUBROUTINE ZMUMPS_DUMP_PROBLEM(id)
      USE ZMUMPS_STRUC_DEF
      IMPLICIT NONE
C
C     Purpose:
C     =======
C
C     If id%WRITE_PROBLEM has been set by the user,
C     possibly on all processors in case of distributed
C     matrix, open a file and dumps the matrix and/or
C     the right hand side. In case the last characters
C     of id.WRITE_PROBLEM are "bin" (uppercase letters
C     are also accepted), then the matrix is written
C     in binary stream format (a C routine is called to
C     avoid depending on the access='stream' mode that
C     is only available since Fortran 2003). In that case,
C     a small header file is also written.
C     Otherwise, this subroutine calls
C     ZMUMPS_DUMP_MATRIX (to write the matrix in
C     matrix-market format) and ZMUMPS_DUMP_RHS.
C     The routine should be called on all MPI processes.
C
C     Examples:
C     1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix
C       mymatrix.txt contains the matrix in matrix-market format
C     2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix
C       mymatrix.txt<i> contains the portion of the matrix
C       on process <i>, in matrix-market format
C     3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix
C       mymatrix.bin contains the matrix in binary format
C       mymatrix.header contains a short description in text format,
C                       with the first line identical to the one of
C                       a matrix-market format
C     4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix
C       mymatrix.bin<i> contains the portion of the matrix
C                       on process <i>, in binary format
C
C       mymatrix.header contains a short description in text format,
C          with the first line identical to matrix-market format
C
C     If a centralized, dense, RHS is available, it is also written,
C     either in matrix-market or binary format (if WRITE_PROBLEM
C     has a .bin extension). In that case the filename for the RHS
C     is WRITE_PROBLEM//".rhs". If written in binary form, information
C     on the RHS is also provided in the header file.
C
      INCLUDE 'mpif.h'
C
C     Arguments
C     =========
C
      TYPE(ZMUMPS_STRUC)  :: id
C
C     Local variables
C     ===============
C
      INTEGER              :: MASTER, IERR, I
      INTEGER              :: IUNIT
      LOGICAL              :: IS_ELEMENTAL
      LOGICAL              :: IS_DISTRIBUTED
      LOGICAL              :: NAME_INITIALIZED
      INTEGER              :: DO_WRITE, DO_WRITE_CHECK
      CHARACTER(LEN=20)    :: IDSTR
      LOGICAL              :: I_AM_SLAVE, I_AM_MASTER
      INTEGER              :: L
      LOGICAL              :: BINARY_FORMAT, DUMP_RHS,
     &                        DUMP_BLKPTR, DUMP_BLKVAR
      INTEGER              :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB
      COMPLEX(kind=8), TARGET                :: A_DUMMY(1)
      INTEGER, TARGET                :: IRN_DUMMY(1), JCN_DUMMY(1)
      INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED
      COMPLEX(kind=8), POINTER, DIMENSION(:) :: A_PASSED
      PARAMETER( MASTER = 0 )
.NE..OR.      I_AM_SLAVE = ( id%MYID  MASTER  
.EQ..AND.     &     ( id%MYID  MASTER 
.EQ.     &     id%KEEP(46)  1 ) )
.EQ.      I_AM_MASTER = (id%MYIDMASTER)
      NAME_INITIALIZED = id%WRITE_PROBLEM(1:20)
.NE.     &      "name_not_initialized"
      BINARY_FORMAT = .FALSE.
      L=len_trim(id%WRITE_PROBLEM)
.GT.      IF (L4) THEN
.EQ..AND.        IF ( id%WRITE_PROBLEM(L-3:L-3)  '.' 
.EQ..OR.     &       ( id%WRITE_PROBLEM(L-2:L-2)  'b' 
.EQ..AND.     &         id%WRITE_PROBLEM(L-2:L-2)  'B' ) 
.EQ..OR.     &       ( id%WRITE_PROBLEM(L-1:L-1)  'i' 
.EQ..AND.     &         id%WRITE_PROBLEM(L-1:L-1)  'I' ) 
.EQ..OR.     &       ( id%WRITE_PROBLEM(L:L)  'n' 
.EQ.     &         id%WRITE_PROBLEM(L:L)  'N' ) ) THEN
          BINARY_FORMAT = .TRUE.
        ENDIF
      ENDIF
C     Check if RHS should also be dumped
.EQ..AND.      DUMP_RHS = id%MYIDMASTER 
.AND.     &     associated(id%RHS)  NAME_INITIALIZED
.AND..GE.      DUMP_RHS = DUMP_RHS  id%NRHS  1
.AND..GE.      DUMP_RHS = DUMP_RHS  id%N  1
.AND..EQ.      DUMP_RHS = DUMP_RHS  id%ICNTL(20)  0
C     Check if BLKPTR and/or BLKVAR should also be dumped
      DUMP_BLKPTR = .FALSE.
      DUMP_BLKVAR = .FALSE.
.EQ..AND.      IF ( id%MYIDMASTER  NAME_INITIALIZED ) THEN
.EQ.        IF ( id%ICNTL(15)  1
.AND..GT.     &       id%NBLK  0 ) THEN
          IF (associated(id%BLKPTR)) THEN
            DUMP_BLKPTR = .TRUE.
            IF (associated(id%BLKVAR)) THEN
C           Dump also BLKVAR, except if allocated by MUMPS
            DUMP_BLKVAR = .TRUE.
            ENDIF
          ENDIF
.LT.        ELSE IF ( id%ICNTL(15)  0 ) THEN
          IF (associated(id%BLKVAR)) THEN
C           Dump also BLKVAR, except if allocated by MUMPS
            DUMP_BLKVAR = .TRUE.
          ENDIF
        ENDIF
      ENDIF
C     Remark: if id%KEEP(54) = 1 or 2, the structure
C     is centralized at analysis. Since ZMUMPS_DUMP_PROBLEM
C     is called at analysis phase, we define IS_DISTRIBUTED
C     as below, which implies that the structure of the problem
C     is distributed in IRN_loc/JCN_loc at analysis.
.EQ.      IS_DISTRIBUTED = (id%KEEP(54)  3)
.NE.      IS_ELEMENTAL   = (id%KEEP(55)  0)
      IF (NAME_INITIALIZED) THEN
.OR.        IF (I_AM_MASTER  IS_DISTRIBUTED) THEN
C         Try to find a free Fortran unit
          CALL MUMPS_FIND_UNIT(IUNIT)
.EQ.          IF ( IUNIT  -1 ) THEN
            id%INFO(1) = -79
            id%INFO(2) = 1
          ENDIF
        ENDIF
      ENDIF
      CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
     &     id%COMM, id%MYID )
.LT.      IF (id%INFO(1)  0) GOTO 500
.AND..NOT.      IF (I_AM_MASTER   IS_DISTRIBUTED) THEN
C        ====================
C        Matrix is assembled
C        and centralized
C        ====================
        IF (NAME_INITIALIZED) THEN
          IF ( BINARY_FORMAT ) THEN
.EQ.            IF (id%KEEP8(28)  0_8) THEN
C             Special case of empty matrix
              A_PASSED   => A_DUMMY
              IRN_PASSED => IRN_DUMMY
              JCN_PASSED => JCN_DUMMY
              IS_A_PROVIDED = 1
            ELSE IF (associated(id%A)) THEN
              A_PASSED=>id%A
              IRN_PASSED => id%IRN
              JCN_PASSED => id%JCN
              IS_A_PROVIDED = 1
            ELSE
              A_PASSED => A_DUMMY
              IRN_PASSED => id%IRN
              JCN_PASSED => id%JCN
              IS_A_PROVIDED = 0
            ENDIF
            OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' )
            CALL ZMUMPS_DUMP_HEADER( IUNIT, id%N,
     &      IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED,
     &      id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS,
     &      DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) )
            CLOSE( IUNIT )
            CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28),
     &      id%KEEP(35),
     &      IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1),
     &      IS_A_PROVIDED,
     &      trim(id%WRITE_PROBLEM)//char(0) )
          ELSE
            OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM))
            CALL ZMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER,
     &         IS_DISTRIBUTED,  ! = .FALSE., centralized
     &         IS_ELEMENTAL,    ! Elemental or not
     &         .FALSE.)
            CLOSE(IUNIT)
          ENDIF
        ENDIF
      ELSE IF ( IS_DISTRIBUTED ) THEN
C        =====================
C        Matrix is distributed
C        =====================
.NOT.         IF ( NAME_INITIALIZED
.OR..NOT.     &          I_AM_SLAVE )THEN
            DO_WRITE = 0
         ELSE
            DO_WRITE = 1
         ENDIF
         CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1,
     &        MPI_INTEGER, MPI_SUM, id%COMM, IERR)
C        -----------------------------------------
C        If yes, each processor writes its share
C        of the matrix in a file in matrix market
C        format (otherwise nothing written). We
C        append the process id to the filename.
C        Safer in case all filenames are the
C        same if all processors share the same
C        file system.
C        -----------------------------------------
.EQ..AND.         IF (DO_WRITE_CHECKid%NSLAVES  I_AM_SLAVE) THEN
            WRITE(IDSTR,'(I9)') id%MYID_NODES
            IF (BINARY_FORMAT) THEN
.EQ.              IF (id%KEEP8(29)  0_8) THEN
C               Special case of empty matrix
                A_PASSED   => A_DUMMY
                IRN_PASSED => IRN_DUMMY
                JCN_PASSED => JCN_DUMMY
C               (consider that A is provided when NNZ_loc=0)
                IS_A_PROVIDED = 1
              ELSE IF (associated(id%A_loc)) THEN
                A_PASSED=>id%A_loc
                IRN_PASSED => id%IRN_loc
                JCN_PASSED => id%JCN_loc
                IS_A_PROVIDED = 1
              ELSE
                A_PASSED => A_DUMMY
                IRN_PASSED => id%IRN_loc
                JCN_PASSED => id%JCN_loc
                IS_A_PROVIDED = 0
              ENDIF
              CALL MPI_ALLREDUCE( IS_A_PROVIDED,
     &             IS_A_PROVIDED_GLOB, 1,
     &             MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR )
C             IS_A_PROVIDED_GLOB = 1 => dump numerical values
C             IS_A_PROVIDED_GLOB = 0 => some processes did not provide
C                                   numerical values, dump only pattern,
C                                   and indicate this in the header
.EQ.              IF ( id%MYID_NODES0) THEN
C               Print header on first MPI worker (only one global header
C               file in case of distributed matrix), replacing the .bin
C               extension by a .header extension
                OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' )
                CALL ZMUMPS_DUMP_HEADER( IUNIT, id%N,
     &          IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED,
     &          id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS,
     &          DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) )
                CLOSE( IUNIT )
              ENDIF
              CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29),
     &        id%KEEP(35),
     &        IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1),
     &        IS_A_PROVIDED_GLOB,
     &        trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) )
            ELSE
              OPEN(IUNIT,
     &             FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR)))
              CALL ZMUMPS_DUMP_MATRIX(id,
     &           IUNIT, I_AM_SLAVE, I_AM_MASTER,
     &           IS_DISTRIBUTED,           ! =.TRUE., distributed
     &           IS_ELEMENTAL,             ! Elemental or not
     &           .FALSE.)
              CLOSE(IUNIT)
            ENDIF
         ENDIF
C     ELSE ...
C     Nothing written in other cases.
      ENDIF
C     ===============
C     Right-hand side
C     ===============
      IF ( DUMP_RHS ) THEN
        IF (BINARY_FORMAT) THEN
C         dump RHS in binary format
          CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1),
     &    id%KEEP(35),
     &    trim(id%WRITE_PROBLEM)//'.rhs'//char(0) )
        ELSE
C         dump RHS in matrix-market format
          OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs")
          CALL ZMUMPS_DUMP_RHS(IUNIT, id)
          CLOSE(IUNIT)
        ENDIF
      ENDIF
      IF ( DUMP_BLKPTR ) THEN
          IF (BINARY_FORMAT) THEN
!           suppress trailing '.bin' and use '.blkptr'
            OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' )
          ELSE
!           just append '.blkptr'
            OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr")
          ENDIF
          WRITE(IUNIT,'(I9)') id%NBLK
          DO I=1,id%NBLK+1
            WRITE(IUNIT,'(I9)') id%BLKPTR(I)
          ENDDO
          CLOSE(IUNIT)
      ENDIF
      IF ( DUMP_BLKVAR ) THEN
          IF (BINARY_FORMAT) THEN
!           suppress trailing '.bin' and use '.blkvar'
            OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' )
          ELSE
!           just append '.blkvar'
            OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar")
          ENDIF
          DO I=1,id%N
            WRITE(IUNIT,'(I9)') id%BLKVAR(I)
          ENDDO
          CLOSE(IUNIT)
      ENDIF
 500  CONTINUE
      RETURN
      END SUBROUTINE ZMUMPS_DUMP_PROBLEM
      SUBROUTINE ZMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB,
     &  SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS,
     &  DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 )
C
C  Purpose:
C  =======
C
C  Write a small header file, similar to matrix-market headers,
C  to accompany a matrix written in binary format.
C
      INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES
      INTEGER(8), INTENT(IN) :: NNZTOT
      LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS
      INTEGER, INTENT(IN) :: NRHS
      LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR
      INTEGER, INTENT(IN) :: NBLK
      INTEGER, INTENT(IN) :: ICNTL15
C
C  Local declarations:
C  ==================
C
      CHARACTER (LEN=10)   :: SYMM
      CHARACTER (LEN=8)    :: ARITH
C     1/ write a line identical to first line of matrix-market header
.EQ.      IF ( IS_A_PROVIDED_GLOB  1 ) THEN
          ARITH='complex'
      ELSE
        ARITH='pattern'
      ENDIF
.eq.      IF (SYM  0) THEN
        SYMM="general"
      ELSE
        SYMM="symmetric"
      END IF
      WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ',
     &           trim(ARITH)," ",trim(SYMM)
C     2/ indicate if matrix is distributed or centralized,
C     then describe binary file content and format
      IF ( IS_DISTRIBUTED ) THEN
        WRITE(IUNIT,FMT='(A,I5,A)')
     &  '% Matrix is distributed (MPI ranks=',NSLAVES,')'
      ELSE
        WRITE(IUNIT,FMT='(A)')
     &  '% Matrix is centralized'
      ENDIF
      WRITE(IUNIT,FMT='(A)')
     &    '% Unformatted stream IO (no record boundaries):'
.EQ.      IF (ARITH(1:7)'pattern') THEN
        IF (IS_DISTRIBUTED) THEN
          WRITE(IUNIT,'(A)')
     &    '%    N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)'
        ELSE
          WRITE(IUNIT,'(A)')
     &    '%    N,NNZ,IRN(1:NNZ),JCN(1:NNZ)'
        ENDIF
        WRITE(IUNIT,'(A)') '%    (numerical values not provided)'
      ELSE
        IF (IS_DISTRIBUTED) THEN
          WRITE(IUNIT,'(A)')
     &    '%    N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'//
     &    'A_loc(1:NNZ_loc)'
        ELSE
          WRITE(IUNIT,'(A)') '%    N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)'
        ENDIF
        WRITE(IUNIT,'(A)') '%    Double complex storage'
      ENDIF
      IF ( IS_DISTRIBUTED ) THEN
        WRITE(IUNIT,'(A,/,A)')
     &  '%    N,IRN_loc(i),JCN_loc(i): 32 bits',
     &  '%    NNZ_loc: 64 bits'
      ELSE
        WRITE(IUNIT,'(A,/,A)')
     &  '%    N,IRN(i),JCN(i): 32 bits',
     &  '%    NNZ: 64 bits'
      ENDIF
      WRITE(IUNIT,FMT='(A,I12)') '% Matrix order: N=',N
      WRITE(IUNIT,FMT='(A,I12)') '% Matrix nonzeros: NNZ=',NNZTOT
      IF (DUMP_RHS) THEN
        WRITE(IUNIT,FMT='(A)') '%'
        WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)')
     &  '% A RHS was also written to disk by columns in binary form.',
     &  '%    Size: N rows x NRHS columns with N=',N,'  NRHS=',NRHS
        WRITE(IUNIT,FMT='(A,I12,A)')
     &  '%    Total:',int(N,8)*int(NRHS,8),' scalar values.'
        WRITE(IUNIT,'(A)') '%    Double complex storage'
      ENDIF
      IF (DUMP_BLKPTR) THEN
        WRITE(IUNIT,FMT='(A)') '%'
        WRITE(IUNIT,'(A,I9,A)') '% Matrix has a block format with',
     &                          NBLK,' blocks'
        WRITE(IUNIT,'(A)')
     &  '% File <matrix>.blkptr contains NBLK and BLKPTR(1:NBLK+1)'
.LT.      ELSE IF (ICNTL15  0) THEN
        WRITE(IUNIT,FMT='(A)') '%'
        WRITE(IUNIT,'(A,I9,A)')
     &  '% Matrix has a block format with ICNTL15=',ICNTL15
      ENDIF
      IF (DUMP_BLKVAR) THEN
          WRITE(IUNIT,'(A)')
     &    '% File <matrix>.blkvar contains BLKVAR (N integers)'
.NE.      ELSE IF (ICNTL15  0) THEN
          WRITE(IUNIT,'(A)')
     &    '% (BLKVAR considered to be identity is not written)' 
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_DUMP_HEADER
      SUBROUTINE ZMUMPS_DUMP_MATRIX
     & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER,
     &  IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY )
      USE ZMUMPS_STRUC_DEF
      IMPLICIT NONE
C
C  Purpose:
C  =======
C     This subroutine dumps a routine in matrix-market format
C     if the matrix is assembled, and in "MUMPS" format (see
C     example in the MUMPS users'guide, if the matrix is
C     centralized and elemental).
C     The routine can be called on all processors. In case of
C     distributed assembled matrix, each processor writes its
C     share as a matrix market file on IUNIT (IUNIT may have
C     different values on different processors).
C
C
C
C  Arguments (input parameters)
C  ============================
C
C     IUNIT: should be set to the Fortran unit where
C            data should be written.
C     I_AM_SLAVE: .TRUE. except on a non working master
C     IS_DISTRIBUTED: .TRUE. if matrix is distributed,
C                     i.e., if IRN_loc/JCN_loc are provided.
C     IS_ELEMENTAL  : .TRUE. if matrix is elemental
C     id            : main MUMPS structure
C
      LOGICAL, intent(in) :: I_AM_SLAVE,
     &                       I_AM_MASTER,
     &                       IS_DISTRIBUTED,
     &                       IS_ELEMENTAL,
     &                       PATTERN_ONLY
      INTEGER, intent(in) :: IUNIT
      TYPE(ZMUMPS_STRUC), intent(in)  :: id
C
C  Local variables:
C  ===============
C
      CHARACTER (LEN=10)   :: SYMM
      CHARACTER (LEN=8)    :: ARITH
      INTEGER(8)           :: I8, NNZ_i
C
C  Executable statements:
C  =====================
.AND..NOT..AND.      IF (I_AM_MASTER   IS_DISTRIBUTED 
.NOT.     &      IS_ELEMENTAL) THEN
C        ==================
C        CENTRALIZED MATRIX
C        ==================
.EQ.         IF (id%KEEP8(28)  0_8) THEN
           CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i)
         ELSE
           NNZ_i=id%KEEP8(28)
         ENDIF
.AND..NOT.         IF ((associated(id%A))(PATTERN_ONLY)) THEN
C     Write header line:
               ARITH='complex'
         ELSE
            ARITH='pattern '
         ENDIF
.eq.         IF (id%KEEP(50)  0) THEN
            SYMM="general"
         ELSE
            SYMM="symmetric"
         END IF
         WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ',
     &           trim(ARITH)," ",trim(SYMM)
         WRITE(IUNIT,*) id%N, id%N, NNZ_i
.AND..NOT.         IF ((associated(id%A))(PATTERN_ONLY)) THEN
            DO I8=1_8,NNZ_i
.NE..AND..LT.               IF (id%KEEP(50)0  id%IRN(I8)id%JCN(I8)) THEN
C              permute upper diag entry
                     WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8),
     &                    dble(id%A(I8)), aimag(id%A(I8))
               ELSE
                     WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), 
     &                    dble(id%A(I8)), aimag(id%A(I8))
               ENDIF
            ENDDO
         ELSE
C           pattern only
            DO I8=1_8,id%KEEP8(28)
.NE..AND..LT.               IF (id%KEEP(50)0  id%IRN(I8)id%JCN(I8)) THEN
C                 permute upper diag entry
                  WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8)
               ELSE
                     WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8)
               ENDIF
            ENDDO
         ENDIF
.AND.      ELSE IF ( IS_DISTRIBUTED  I_AM_SLAVE ) THEN
C        ==================
C        DISTRIBUTED MATRIX
C        ==================
.EQ.         IF (id%KEEP8(29)  0_8) THEN
           CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i)
         ELSE
           NNZ_i=id%KEEP8(29)
         ENDIF
.AND..NOT.         IF ((associated(id%A_loc))(PATTERN_ONLY)) THEN
               ARITH='complex'
         ELSE
               ARITH='pattern '
         ENDIF
.eq.         IF (id%KEEP(50)  0) THEN
            SYMM="general"
         ELSE
            SYMM="symmetric"
         END IF
         WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ',
     &           trim(ARITH)," ",trim(SYMM)
         WRITE(IUNIT,*) id%N, id%N, NNZ_i
.AND..NOT.         IF ((associated(id%A_loc))(PATTERN_ONLY)) THEN
            DO I8=1_8,NNZ_i
.NE..AND.               IF (id%KEEP(50)0 
.LT.     &             id%IRN_loc(I8)id%JCN_loc(I8)) THEN
                     WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8),
     &                    dble(id%A_loc(I8)), aimag(id%A_loc(I8))
               ELSE
                     WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8),
     &                    dble(id%A_loc(I8)), aimag(id%A_loc(I8))
               ENDIF
            ENDDO
         ELSE
            DO I8=1_8,NNZ_i
.NE..AND.               IF (id%KEEP(50)0  
.LT.     &            id%IRN_loc(I8)id%JCN_loc(I8)) THEN
C                 permute upper diag entry
                  WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8)
               ELSE
                  WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8)
               ENDIF
            ENDDO
         ENDIF
.AND.      ELSE IF (IS_ELEMENTAL  I_AM_MASTER) THEN
C        ==================
C        ELEMENTAL MATRIX
C        ==================         
         WRITE(IUNIT,*) id%N," :: n"
         WRITE(IUNIT,*) id%NELT," :: nelt"
         WRITE(IUNIT,*) size(id%ELTVAR)," :: neltvar"
         WRITE(IUNIT,*) size(id%A_ELT)," :: neltvl"
         WRITE(IUNIT,*) id%ELTPTR(:)," ::eltptr"
         WRITE(IUNIT,*) id%ELTVAR(:)," ::eltvar"
.NOT.         IF(PATTERN_ONLY) THEN
            WRITE(IUNIT,*) id%A_ELT(:)         
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_DUMP_MATRIX
      SUBROUTINE ZMUMPS_DUMP_RHS(IUNIT, id)
C
C  Purpose:
C  =======
C     Dumps a dense, centralized,
C     right-hand side in matrix market format on unit
C     IUNIT. Should be called on the host only.
C
      USE ZMUMPS_STRUC_DEF
      IMPLICIT NONE
C  Arguments
C  =========
      TYPE(ZMUMPS_STRUC), intent(in)  :: id
      INTEGER, intent(in)             :: IUNIT
C
C  Local variables
C  ===============
C
      CHARACTER (LEN=8)    :: ARITH
      INTEGER              :: I, J
      INTEGER(8)           :: LD_RHS8, K8
C
C  Executable statements
C  =====================
C
      IF (associated(id%RHS)) THEN
               ARITH='complex'
        WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ',
     &           trim(ARITH),
     &           ' general'
        WRITE(IUNIT,*) id%N, id%NRHS
.EQ.        IF ( id%NRHS  1 ) THEN
           LD_RHS8 = int(id%N,8)
        ELSE
           LD_RHS8 = int(id%LRHS,8)
        ENDIF
        DO J = 1, id%NRHS
           DO I = 1, id%N
              K8=int(J-1,8)*LD_RHS8+int(I,8)
                 WRITE(IUNIT,*) dble(id%RHS(K8)), aimag(id%RHS(K8))
        ENDDO
        ENDDO
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_DUMP_RHS
      SUBROUTINE ZMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, 
     &     NB_NIV2, MYID_NODES,
     &     CANDIDATES, I_AM_CAND )
      IMPLICIT NONE
C
C     Purpose:
C     =======
C     Given  a list of candidate processors per node,
C     returns an array of booleans telling whether the
C     processor is candidate or not for a given node.
C
C     K79 holds splitting strategy (KEEP(79)). If K79>1 then
C     TPYE4,5,6 nodes might have been introduced and 
C     in this case "hidden" slaves should be taken 
C     into account to enable dynamic redistribution 
C     of the hidden slaves while climbing the chain of 
C     split nodes. The master of the first node in the 
C     chain requires a special treatment and is thus here
C     not considered as a slave. 
C     
      INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79
      INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 )
      LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 )
      INTEGER I, INIV2, NCAND
.GT.      IF (K790) THEN
C      Because of potential restarting the number of
C      candidates that will be used to distribute 
C      arrowheads have to include all possible candidates.
       DO INIV2=1, NB_NIV2
         I_AM_CAND(INIV2)=.FALSE.
         NCAND = CANDIDATES(NSLAVES+1,INIV2)
C        check if some hidden slaves are there
C        Note that if hidden candidates exists (type 5 or 6 nodes) then
C        in position CANDIDATES (NCAND+1,INIV2) must be the master 
C        of the first node in the chain (type 4) that we skip here because
C        a special treatment (it has to be "considered as a master" for all 
C        nodes in the list) is needed.
         DO I=1, NSLAVES
.LT.            IF (CANDIDATES(I,INIV2)0) EXIT ! end of extra slaves
.EQ.            IF (INCAND+1) CYCLE 
!     skip master of associated TYPE 4 node 
.EQ.            IF (CANDIDATES(I,INIV2)MYID_NODES) THEN
               I_AM_CAND(INIV2)=.TRUE.
               EXIT
            ENDIF
         ENDDO
       END DO
      ELSE
       DO INIV2=1, NB_NIV2
         I_AM_CAND(INIV2)=.FALSE.
         NCAND = CANDIDATES(NSLAVES+1,INIV2)
         DO I=1, NCAND
.EQ.            IF (CANDIDATES(I,INIV2)MYID_NODES) THEN
               I_AM_CAND(INIV2)=.TRUE.
               EXIT
            ENDIF
         ENDDO
       END DO
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_BUILD_I_AM_CAND
      SUBROUTINE ZMUMPS_FREE_ONENTRY_ANA_DRIVER (id)
C     Purpose:
C     =======
C     When the analysis step is called twice
C     free arrays that might have been computed
C     during previous analysis step (to be passed to 
C     the factorization phase) 
C 
      USE ZMUMPS_STRUC_DEF
      TYPE (ZMUMPS_STRUC), TARGET :: id
C
      IF (associated(id%STEP)) THEN
         DEALLOCATE(id%STEP)
         NULLIFY   (id%STEP)
      ENDIF
      IF (associated(id%NE_STEPS)) THEN 
         DEALLOCATE(id%NE_STEPS)
         NULLIFY   (id%NE_STEPS)
      ENDIF
      IF (associated(id%ND_STEPS)) THEN 
         DEALLOCATE(id%ND_STEPS)
         NULLIFY   (id%ND_STEPS)
      ENDIF
      IF (associated(id%FRERE_STEPS)) THEN 
         DEALLOCATE(id%FRERE_STEPS)
         NULLIFY   (id%FRERE_STEPS)
      ENDIF
      IF (associated(id%DAD_STEPS)) THEN 
         DEALLOCATE(id%DAD_STEPS)
         NULLIFY   (id%DAD_STEPS)
      ENDIF
      IF (associated(id%PTRAR)) THEN 
         DEALLOCATE(id%PTRAR)
         NULLIFY   (id%PTRAR)
      ENDIF
      IF (associated(id%UNS_PERM)) THEN 
         DEALLOCATE(id%UNS_PERM)
         NULLIFY   (id%UNS_PERM)
      ENDIF
      IF (associated(id%LRGROUPS)) THEN 
         DEALLOCATE(id%LRGROUPS)
         NULLIFY   (id%UNS_PERM)
      ENDIF
      IF (associated(id%FILS)) THEN 
         DEALLOCATE(id%FILS)
         NULLIFY   (id%FILS)
      ENDIF
      IF (associated(id%FRTPTR)) THEN 
         DEALLOCATE(id%FRTPTR)
         NULLIFY   (id%FRTPTR)
      ENDIF
      IF (associated(id%PROCNODE_STEPS)) THEN 
         DEALLOCATE(id%PROCNODE_STEPS)
         NULLIFY   (id%PROCNODE_STEPS)
      ENDIF
      IF (associated(id%NA)) THEN 
         DEALLOCATE(id%NA)
         NULLIFY   (id%NA)
      ENDIF
      IF (associated(id%Step2node)) THEN 
         DEALLOCATE(id%Step2node)
         NULLIFY   (id%Step2node)
      ENDIF
      IF (associated(id%CANDIDATES)) THEN 
         DEALLOCATE(id%CANDIDATES)
         NULLIFY   (id%CANDIDATES)
      ENDIF
      IF (associated(id%ISTEP_TO_INIV2)) THEN 
         DEALLOCATE(id%ISTEP_TO_INIV2)
         NULLIFY   (id%ISTEP_TO_INIV2)
      ENDIF
      IF (associated(id%FUTURE_NIV2)) THEN 
         DEALLOCATE(id%FUTURE_NIV2)
         NULLIFY   (id%FUTURE_NIV2)
      ENDIF
      IF (associated(id%TAB_POS_IN_PERE)) THEN 
         DEALLOCATE(id%TAB_POS_IN_PERE)
         NULLIFY   (id%TAB_POS_IN_PERE)
      ENDIF
      IF (associated(id%I_AM_CAND)) THEN 
         DEALLOCATE(id%I_AM_CAND)
         NULLIFY   (id%I_AM_CAND)
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_FREE_ONENTRY_ANA_DRIVER