C
C  This file is part of MUMPS 4.8.3, built on Wed Sep 24 17:11:30 UTC 2008
C
C
C  This version of MUMPS is provided to you free of charge. It is public
C  domain, based on public domain software developed during the Esprit IV
C  European project PARASOL (1996-1999) by CERFACS, ENSEEIHT-IRIT and RAL.
C  Since this first public domain version in 1999, the developments are
C  supported by the following institutions: CERFACS, ENSEEIHT-IRIT, and
C  INRIA.
C
C  Main contributors are Patrick Amestoy, Iain Duff, Abdou Guermouche,
C  Jacko Koster, Jean-Yves L'Excellent, and Stephane Pralet.
C
C  Up-to-date copies of the MUMPS package can be obtained
C  from the Web pages:
C  http://mumps.enseeiht.fr/  or  http://graal.ens-lyon.fr/MUMPS
C
C
C   THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
C   EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
C
C
C  User documentation of any code that uses this software can
C  include this complete notice. You can acknowledge (using
C  references [1], [2], and [3]) the contribution of this package
C  in any scientific publication dependent upon the use of the
C  package. You shall use reasonable endeavours to notify
C  the authors of the package of this publication.
C
C   [1] P. R. Amestoy, I. S. Duff and  J.-Y. L'Excellent,
C   Multifrontal parallel distributed symmetric and unsymmetric solvers,
C   in Comput. Methods in Appl. Mech. Eng., 184,  501-520 (2000).
C
C   [2] P. R. Amestoy, I. S. Duff, J. Koster and  J.-Y. L'Excellent,
C   A fully asynchronous multifrontal solver using distributed dynamic
C   scheduling, SIAM Journal of Matrix Analysis and Applications,
C   Vol 23, No 1, pp 15-41 (2001).
C
C   [3] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and
C   S. Pralet, Hybrid scheduling for the parallel solution of linear
C   systems. Parallel Computing Vol 32 (2), pp 136-156 (2006).
C
      SUBROUTINE CMUMPS_246(MYID, N, STEP, FRERE, FILS,
     *     NA, LNA, NE, DAD, ND, PROCNODE, SLAVEF,
     *     NRLADU, NIRADU, NIRNEC, NRLNEC,
     *     NRLNEC_ACTIVE, 
     *     NIRADU_OOC, NIRNEC_OOC,
     *     MAXFR, OPSA,
     *     KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD,
     *     SBUF_SEND, SBUF_REC, OPS_SUBTREE, NSTEPS,
     *     I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, CANDIDATES, 
     *     IFLAG, IERROR
     *     ,MAX_FRONT_SURFACE_LOCAL
     *     ,MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC,
     *     ENTRIES_IN_FACTORS_TOT
     *     )
      IMPLICIT NONE
      INTEGER  MYID, N, LNA, IFLAG, IERROR
      INTEGER  NIRADU, NIRNEC
      INTEGER*8 NRLADU, NRLNEC, NRLNEC_ACTIVE
      INTEGER*8 NRLADU_CURRENT, NRLADU_ROOT_3
      INTEGER NIRADU_OOC, NIRNEC_OOC
      INTEGER MAXFR, NSTEPS
      INTEGER*8 MAX_FRONT_SURFACE_LOCAL
      INTEGER STEP(N)
      INTEGER FRERE(NSTEPS), FILS(N), NA(LNA), NE(NSTEPS),
     *        ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS)
      INTEGER  SLAVEF, KEEP(500), LOCAL_M, LOCAL_N
      INTEGER*8 KEEP8(150)
      INTEGER*8 ENTRIES_IN_FACTORS_LOC, ENTRIES_IN_FACTORS_TOT
      INTEGER  SBUF_SEND, SBUF_REC
      INTEGER*8 SBUF_RECOLD
      INTEGER  NMB_PAR2
      INTEGER  ISTEP_TO_INIV2( KEEP(71) )
      LOGICAL  I_AM_CAND(NMB_PAR2)
      INTEGER  CANDIDATES( SLAVEF+1, NMB_PAR2 )
      INTEGER  PHASE
      PARAMETER (PHASE=0)
      REAL OPSA
      DOUBLE PRECISION OPSA_LOC 
      INTEGER*8 MAX_SIZE_FACTOR
      REAL OPS_SUBTREE
      DOUBLE PRECISION OPS_SBTR_LOC 
      INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, IPOOL, LSTKI 
      INTEGER*8, ALLOCATABLE, DIMENSION(:) :: LSTKR
      INTEGER*8 SBUFS_CB, SBUFR_CB
      INTEGER SBUFR, SBUFS
      INTEGER BLOCKING_RHS
      INTEGER I,ITOP,NELIM,NFR
      INTEGER*8 ISTKR, LSTK
      INTEGER ISTKI,  STKI, ISTKI_OOC
      INTEGER K,NSTK, IFATH
      INTEGER INODE, LEAF, NBLEAF, NBROOT, IN
      INTEGER LEVEL, MAXITEMPCB
      INTEGER*8 CURRENT_ACTIVE_MEM, MAXTEMPCB
      LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR
      INTEGER LEVELF, NCB, SIZECBI
      INTEGER*8 NCB8
      INTEGER*8 NFR8, NELIM8
      INTEGER*8 SIZECB, SIZECBINFR, SIZECB_SLAVE
      INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC
      INTEGER EXTRA_PERM_INFO_OOC
      INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED,
     *         NELIMF, NFRF, NCBF,
     *         NSLAVESF, NBROWMAXF, LKJIB,
     *         LKJIBT, NBR, NBCOLFAC,
     *         NBROWAVG
      INTEGER*8 LEV3MAXREC, CBMAXR, CBMAXS
      INTEGER LWK_RR, LIWK_RR
      INTEGER IROOT, SIZE_ROOT
      INTEGER ALLOCOK
      INTEGER PANEL_SIZE
      LOGICAL ROOT_OWNER, COMPRESSCB
      DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE
      INTEGER*8 ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART
      INCLUDE 'mumps_headers.h'
      INTEGER WHAT
      INTEGER*8 IDUMMY8
      INTRINSIC min, int, real
      INTEGER CMUMPS_OOC_GET_PANEL_SIZE
      EXTERNAL CMUMPS_OOC_GET_PANEL_SIZE
      INTEGER MUMPS_275, MUMPS_330
      LOGICAL MUMPS_170
      INTEGER MUMPS_52
      EXTERNAL MUMPS_503, MUMPS_52
      EXTERNAL MUMPS_275, MUMPS_330, 
     *         MUMPS_170
      logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON
      integer :: istat, IFSON, LEVELSON
      IF (KEEP(50).eq.2) THEN
        EXTRA_PERM_INFO_OOC = 1
      ELSE IF (KEEP(50).eq.0) THEN
        EXTRA_PERM_INFO_OOC = 2
      ELSE
        EXTRA_PERM_INFO_OOC = 0
      ENDIF
      COMPRESSCB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 )
      MAX_FRONT_SURFACE_LOCAL=0_8
      MAX_SIZE_FACTOR=0_8
      ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), IPOOL(NSTEPS),
     *          LSTKI(NSTEPS) , stat=ALLOCOK)
      if (ALLOCOK .GT. 0) THEN
        IFLAG  =-7
        IERROR = 4*NSTEPS
        RETURN
      endif
      LKJIB = max(KEEP(5),KEEP(6))
      TNSTK = NE
      LEAF = NA(1)+1
      IPOOL(1:LEAF-1) = NA(3:3+LEAF-2)
      NBROOT = NA(2)
#if defined(OLD_OOC_NOPANEL)
      XSIZE_OOC=XSIZE_OOC_NOPANEL
#else
      IF (KEEP(50).EQ.0) THEN
              XSIZE_OOC=XSIZE_OOC_UNSYM
      ELSE
              XSIZE_OOC=XSIZE_OOC_SYM
      ENDIF
#endif
      SIZEHEADER_OOC = XSIZE_OOC+6 
      SIZEHEADER = XSIZE_IC + 6  
      ISTKR      = 0_8
      ISTKI      = 0
      ISTKI_OOC  = 0
      OPSA_LOC   = dble(0.0E0)
      ENTRIES_IN_FACTORS_LOC = 0_8
      ENTRIES_IN_FACTORS_TOT = 0_8
      OPS_SBTR_LOC = dble(0.0E0)
      NRLADU     = 0_8
      NIRADU     = 0
      NIRADU_OOC = 0
      NRLADU_CURRENT = 0_8
      NRLADU_ROOT_3 = 0_8
      NRLNEC_ACTIVE = 0_8
      NRLNEC     = 0_8
      NIRNEC     = 0
      NIRNEC_OOC = 0
      MAXFR      = 0
      ITOP       = 0
      MAXTEMPCB  = 0_8
      MAXITEMPCB = 0
      SBUFS_CB   = 1_8
      SBUFS      = 1
      SBUFR_CB   = 1_8
      SBUFR      = 1
      IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN
        INODE  = KEEP(38)
        NRLADU_ROOT_3 = int(LOCAL_M,kind=8)*int(LOCAL_N,kind=8)
        NRLADU = NRLADU_ROOT_3
        NRLNEC_ACTIVE = NRLADU_CURRENT
        MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3)
        NRLNEC = NRLADU
        IF (MUMPS_275(STEP(INODE),PROCNODE,SLAVEF)
     *                                       .EQ. MYID) THEN
          NIRADU     = SIZEHEADER+2*ND(STEP(INODE))
          NIRADU_OOC = SIZEHEADER_OOC+2*ND(STEP(INODE))
        ELSE
          NIRADU     = SIZEHEADER
          NIRADU_OOC = SIZEHEADER_OOC
        ENDIF
        NIRNEC     = NIRADU
        NIRNEC_OOC = NIRADU_OOC
      ENDIF
      IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN
         FORCE_CAND=.FALSE.           
      ELSE
         FORCE_CAND=(mod(KEEP(24),2).eq.0)
      END IF
 90   CONTINUE
      IF (LEAF.NE.1) THEN
         LEAF = LEAF - 1
         INODE = IPOOL(LEAF)
      ELSE 
         WRITE(MYID+6,*) ' ERROR 1 in CMUMPS_246 '
         CALL MUMPS_ABORT()
      ENDIF
 95   CONTINUE 
      NFR    = ND(STEP(INODE))
      NFR8   = int(NFR,8)
      NSTK   = NE(STEP(INODE))
      NELIM = 0 
        IN = INODE
 100    NELIM = NELIM + 1 
      NELIM8=int(NELIM,8)
        IN = FILS(IN)
        IF (IN .GT. 0 ) GOTO 100
      IFSON = -IN
      IFATH = DAD(STEP(INODE))
      MASTER = MUMPS_275(STEP(INODE),PROCNODE,SLAVEF)
     *           .EQ. MYID
      LEVEL  = MUMPS_330(STEP(INODE),PROCNODE,SLAVEF)
      INSSARBR = MUMPS_170(STEP(INODE),
     $        PROCNODE,SLAVEF)
      UPDATE=.FALSE.
       if(.NOT.FORCE_CAND) then
         UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 )
       else
         if(MASTER.and.(LEVEL.ne.3)) then
            UPDATE = .TRUE.
         else if(LEVEL.eq.2) then
            if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN
              UPDATE = .TRUE.
            end if
         end if
       end if
      NCB      = NFR-NELIM
      NCB8     = int(NCB,8)
      SIZECBINFR = NCB8*NCB8
      IF (KEEP(50).EQ.0) THEN
        SIZECB = SIZECBINFR
      ELSE
        IFATH = DAD(STEP(INODE))
        IF ( IFATH.NE.KEEP(38) .AND. COMPRESSCB ) THEN
          SIZECB    = (NCB8*(NCB8+1_8))/2_8
        ELSE
          SIZECB    = SIZECBINFR
        ENDIF
      ENDIF
      SIZECBI      = 2* NCB  + SIZEHEADER
      IF (LEVEL.NE.2) THEN
        NSLAVES_LOC     = -99999999
        SIZECB_SLAVE = -99999997_8
        NBROWMAX        = NCB
      ELSE
        IF (KEEP(48) .EQ. 5) THEN
          WHAT = 5 
          IF (FORCE_CAND) THEN
            NSLAVES_LOC=CANDIDATES(SLAVEF+1,
     $                    ISTEP_TO_INIV2(STEP(INODE)))
          ELSE
            NSLAVES_LOC=SLAVEF-1
          ENDIF
          NSLAVES_PASSED=NSLAVES_LOC
        ELSE
          WHAT = 2 
          NSLAVES_PASSED=SLAVEF
          NSLAVES_LOC   =SLAVEF-1
        ENDIF
         CALL MUMPS_503(WHAT, KEEP,KEEP8,
     &     NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE)
      ENDIF
      IF (KEEP(60).GT.1) THEN
         IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN
          NIRADU     = NIRADU+SIZEHEADER+2*ND(STEP(INODE))
          NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+2*ND(STEP(INODE))
         ENDIF
      ENDIF
      IF (LEVEL.EQ.3) THEN
         IF ( 
     *     KEEP(60).LE.1
     *      ) THEN
           NRLNEC = max(NRLNEC,NRLADU+ISTKR+
     *                 int(LOCAL_M,8)*int(LOCAL_N,8))
           NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8)
           NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + 
     *                        NRLADU_CURRENT+ISTKR)
         ENDIF
         IF (MASTER) THEN 
            IF (NFR.GT.MAXFR) MAXFR = NFR
         ENDIF
      ENDIF
      IF(KEEP(86).EQ.1)THEN
         IF(MASTER.AND.(.NOT.MUMPS_170(STEP(INODE),
     $        PROCNODE,SLAVEF)))THEN
            IF(LEVEL.EQ.1)THEN
               MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL,
     $              NFR8*NFR8)
            ELSEIF(LEVEL.EQ.2)THEN
               IF(KEEP(50).EQ.0)THEN
                 MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL,
     $                 NFR8*NELIM8)
               ELSE
                 MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL,
     $                 NELIM8*NELIM8)
                 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN
                  MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL,
     $                  NELIM8*(NELIM8+1_8))
                 ENDIF
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      IF (LEVEL.EQ.2) THEN
        IF (MASTER) THEN
          IF (KEEP(50).EQ.0) THEN
             SBUFS = max(SBUFS, NFR*LKJIB+LKJIB+4)
          ELSE
             SBUFS = max(SBUFS, NELIM*LKJIB+NELIM+6)
          ENDIF
        ELSEIF (UPDATE) THEN
            if (KEEP(50).EQ.0) THEN
              SBUFR   = max(SBUFR, NFR*LKJIB+LKJIB+4)
            else
              SBUFR = max( SBUFR, NELIM*LKJIB+NELIM+6 )
              IF (KEEP(50).EQ.1) THEN
                LKJIBT  = LKJIB
              ELSE
                LKJIBT  = min( NELIM, LKJIB * 2 )
              ENDIF
              SBUFS = max(SBUFS,
     *                        LKJIBT*NBROWMAX+6)
              SBUFR = max( SBUFR, NBROWMAX*LKJIBT+6 )
            endif
        ENDIF
      ENDIF
      IF ( UPDATE ) THEN
          IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN
            NIRADU     = NIRADU + 2*NFR + SIZEHEADER
            NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC
            PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE(
     *      2*KEEP(226), NFR, KEEP(227), KEEP(50))
            NIRADU_OOC = NIRADU_OOC +
     *      EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1)
            IF (KEEP(50).EQ.0) THEN
             NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8)
             NRLADU = NRLADU + NRLADU_CURRENT
             MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT)
            ELSE
             NRLADU_CURRENT = int(NELIM,8)*int(NFR,8)
             NRLADU = NRLADU + NRLADU_CURRENT
             MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT)
            ENDIF
            SIZECBI        = 2* NCB  + 6 + 3
          ELSEIF (LEVEL.EQ.2) THEN
            IF (MASTER) THEN
              NIRADU     = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR 
              NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR 
              IF (KEEP(50).EQ.0) THEN
                NBCOLFAC=NFR
              ELSE
                NBCOLFAC=NELIM
              ENDIF
              PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE(
     *        2*KEEP(226), NBCOLFAC, KEEP(227), KEEP(50))
              NIRADU_OOC = NIRADU_OOC +
     *        EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1)
              NRLADU_CURRENT = int(NBCOLFAC,8)*int(NELIM,8)
              NRLADU = NRLADU + NRLADU_CURRENT
              MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT)
               SIZECB     = 0_8
               SIZECBINFR = 0_8
               SIZECBI    = NCB + 5 +  SLAVEF - 1
            ELSE
             SIZECB=SIZECB_SLAVE
             SIZECBINFR = SIZECB
             NIRADU       = NIRADU+4+NELIM+NBROWMAX
             NIRADU_OOC   = NIRADU_OOC+4+NELIM+NBROWMAX
             IF (KEEP(50).EQ.0) THEN
               NRLADU   = NRLADU + int(NELIM,8)*int(NBROWMAX,8)
             ELSE 
               NRLADU   = NRLADU + int(NELIM,8)*int(NCB/NSLAVES_LOC,8)
             ENDIF
             NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8)
             MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT)
             SIZECBI       = 4 + NBROWMAX + NCB
             IF (KEEP(50).NE.0) THEN 
                     SIZECBI=SIZECBI+NSLAVES_LOC+
     *                                  XTRA_SLAVES_SYM
             ELSE
                     SIZECBI=SIZECBI+NSLAVES_LOC+
     *                                  XTRA_SLAVES_UNSYM 
             ENDIF
            ENDIF
         ENDIF
         NIRNEC = max0(NIRNEC,
     *             NIRADU+ISTKI+SIZECBI+MAXITEMPCB)
         NIRNEC_OOC = max0(NIRNEC_OOC,
     *             NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB +
     *             (XSIZE_OOC-XSIZE_IC) )  
         CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR
         IF (NSTK .NE. 0 .AND. INSSARBR .AND.
     &     KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN
           CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP)
         ENDIF
         IF (KEEP(50).NE.0.AND.UPDATE.AND.LEVEL.EQ.1) THEN
             CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM +
     &              int(NELIM,8)*int(NCB,8)
         ENDIF
         IF (MASTER .AND.  KEEP(219).NE.0.AND.
     *       KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN
             CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8)
         ENDIF
         IF (SLAVEF.EQ.1) THEN
           NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM)
           NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+
     *             NRLADU_ROOT_3+CURRENT_ACTIVE_MEM)
         ELSE
           NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB)
           NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+
     *             NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB)
         ENDIF
         IF (NFR.GT.MAXFR) MAXFR = NFR
         IF (NSTK.GT.0) THEN
            DO 70 K=1,NSTK
               LSTK = LSTKR(ITOP)
               ISTKR = ISTKR - LSTK
               IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0
     &            .AND.KEEP(55).EQ.0) THEN
               ELSE
                 CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK
               ENDIF
               STKI = LSTKI( ITOP )
               ISTKI = ISTKI - STKI
               ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC)
               ITOP = ITOP - 1
               IF (ITOP.LT.0) THEN
                  write(*,*) MYID,
     *            ': ERROR 2 in CMUMPS_246. ITOP = ',ITOP
                  CALL MUMPS_ABORT()
               ENDIF
 70         CONTINUE
         ENDIF 
      ELSE IF (LEVEL.NE.3) THEN
         DO WHILE (IFSON.GT.0) 
            UPDATES=.FALSE.
            MASTERSON = MUMPS_275(STEP(IFSON),PROCNODE,SLAVEF)
     *                  .EQ.MYID
            LEVELSON  = MUMPS_330(STEP(IFSON),PROCNODE,SLAVEF)
            if(.NOT.FORCE_CAND) then
               UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. 
     *                   LEVELSON.EQ.2)
            else
               if(MASTERSON.and.(LEVELSON.ne.3)) then
                  UPDATES = .TRUE.
               else if(LEVELSON.eq.2) then
                  if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then
                    UPDATES = .TRUE.
                  end if
               end if
            end if
            IF (UPDATES) THEN
              LSTK = LSTKR(ITOP)
              ISTKR = ISTKR - LSTK
              STKI = LSTKI( ITOP )
              ISTKI = ISTKI - STKI
              ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC)
              ITOP = ITOP - 1
              IF (ITOP.LT.0) THEN
                write(*,*) MYID,
     *          ': ERROR 2 in CMUMPS_246. ITOP = ',ITOP
                CALL MUMPS_ABORT()
              ENDIF
            ENDIF
            IFSON = FRERE(STEP(IFSON)) 
         END DO
      ENDIF
      IF (
     *        ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) 
     *       .AND.
     *        ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) 
     *      )
     *THEN
            ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8)
            IF ( KEEP(50).EQ.0 ) THEN
              ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8)
            ELSE
              ENTRIES_NODE_UPPER_PART =
     *        (int(NELIM,8)*int(NELIM+1,8))/2_8
            ENDIF
            CALL MUMPS_511(NFR, NELIM, NELIM,KEEP(50),
     *           1,OPS_NODE)
            IF (LEVEL.EQ.2) THEN
              CALL MUMPS_511(NFR, NELIM, NELIM,KEEP(50),
     *           2,OPS_NODE_MASTER)
              OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER
            ENDIF
      ELSE
           OPS_NODE = 0.0D0
           ENTRIES_NODE_UPPER_PART = 0_8
           ENTRIES_NODE_LOWER_PART = 0_8
      ENDIF
      ENTRIES_IN_FACTORS_TOT = ENTRIES_IN_FACTORS_TOT +
     *                            ENTRIES_NODE_UPPER_PART +
     *                            ENTRIES_NODE_LOWER_PART
      IF (UPDATE.OR.LEVEL.EQ.3) THEN
         IF ( LEVEL .EQ. 3 ) THEN
            OPSA_LOC = OPSA_LOC + OPS_NODE / dble( SLAVEF )
            ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC +
     &                            ENTRIES_NODE_UPPER_PART /
     &                            int(SLAVEF,8)
            IF (MASTER)
     *      ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC +
     *                               mod(ENTRIES_NODE_UPPER_PART,
     *                                   int(SLAVEF,8))
         ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN
            OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER
            ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC +
     &                      ENTRIES_NODE_UPPER_PART +
     &                      mod(ENTRIES_NODE_LOWER_PART,
     &                          int(NSLAVES_LOC,8))
         ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN
            OPSA_LOC = OPSA_LOC + dble(OPS_NODE)
            ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC +
     &                               ENTRIES_NODE_UPPER_PART +
     &                               ENTRIES_NODE_LOWER_PART
         ELSE IF (UPDATE) THEN 
            OPSA_LOC = OPSA_LOC + 
     &            dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC)
            ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC
     &                 + ENTRIES_NODE_LOWER_PART / 
     &                 int(NSLAVES_LOC,8)
         ENDIF
         IF (MUMPS_170(STEP(INODE),
     *   PROCNODE, SLAVEF) .OR. NE(STEP(INODE))==0) THEN
           IF (LEVEL == 1) THEN
             OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE
           ELSE
             CALL MUMPS_511(NFR, NELIM, NELIM,KEEP(50),
     *           1,OPS_NODE)
             OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE
           ENDIF
         ENDIF
        ENDIF
      IF (IFATH .EQ. 0) THEN
         NBROOT = NBROOT - 1
         IF (NBROOT.EQ.0) GOTO 115
         GOTO 90
      ELSE
         NFRF = ND(STEP(IFATH))
         IF (DAD(STEP(IFATH)).EQ.0) THEN
           NELIMF = NFRF
         ELSE
           NELIMF = 0
           IN = IFATH
           DO WHILE (IN.GT.0)
              IN = FILS(IN)
              NELIMF = NELIMF+1
           ENDDO
         ENDIF
         NCBF = NFRF - NELIMF
         LEVELF = MUMPS_330(STEP(IFATH),PROCNODE,SLAVEF)
         MASTERF= MUMPS_275(STEP(IFATH),PROCNODE,SLAVEF).EQ.MYID
         UPDATEF= .FALSE.
         if(.NOT.FORCE_CAND) then
            UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2)
         else
            if(MASTERF.and.(LEVELF.ne.3)) then
               UPDATEF = .TRUE.
            else if (LEVELF.eq.2) then
               if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN
                 UPDATEF = .TRUE.
               end if
            end if
         end if
         CONCERNED  = UPDATEF .OR. UPDATE
         IF (LEVELF .NE. 2) THEN
           NBROWMAXF = -999999
         ELSE
           IF (KEEP(48) .EQ. 5) THEN
               WHAT = 4
               IF (FORCE_CAND) THEN
                 NSLAVES_LOC=CANDIDATES(SLAVEF+1,
     $               ISTEP_TO_INIV2(STEP(IFATH)))
               ELSE
                 NSLAVES_LOC=SLAVEF-1
               ENDIF
           ELSE
               WHAT = 1 
               NSLAVES_LOC=SLAVEF
           ENDIF
           CALL MUMPS_503( WHAT, KEEP, KEEP8,
     &     NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 )
         ENDIF
         IF(LEVEL.EQ.1.AND.UPDATE.AND.
     *      (UPDATEF.OR.LEVELF.EQ.2)
     *      .AND.LEVELF.NE.3) THEN
             IF ( INSSARBR .AND. KEEP(234).NE.0) THEN
               NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+
     *           NRLADU_ROOT_3+CURRENT_ACTIVE_MEM)
               NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM)
             ELSE
               NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+
     *           NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB)
               NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB)
             ENDIF
         ENDIF
         IF (UPDATE .AND. LEVEL.EQ.2 .AND. .NOT. MASTER) THEN
             NRLNEC =
     *         max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+NRLADU_CURRENT)
             NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,2_8*NRLADU_CURRENT+
     *         NRLADU_ROOT_3+CURRENT_ACTIVE_MEM)
         ENDIF
        IF (LEVELF.EQ.3) THEN
          IF (LEVEL.EQ.1) THEN
            LEV3MAXREC = int(min(NCB,LOCAL_M),8) *
     &                   int(min(NCB,LOCAL_N),8)
          ELSE
            LEV3MAXREC = min(SIZECB,
     &                 int(min(NBROWMAX,LOCAL_M),8)
     &                *int(min(NCB,LOCAL_N),8))
          ENDIF
          MAXTEMPCB  = max(MAXTEMPCB, LEV3MAXREC)
          MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER)
          SBUFR_CB   = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8))
          NIRNEC = max(NIRNEC,NIRADU+ISTKI+
     &    min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER)
          NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+
     &    min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER)
        ENDIF
        IF (CONCERNED) THEN
         IF (LEVELF.EQ.2) THEN
           IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN
             IF(MASTERF)THEN
                 NBR = min(NBROWMAXF,NBROWMAX)
             ELSE
                 NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX)
             ENDIF
             IF (KEEP(50).EQ.0) THEN
               CBMAXS = int(NBR,8)*int(NCB,8)
             ELSE
               CBMAXS = int(NBR,8)*int(NCB,8) -
     &                  (int(NBR,8)*int(NBR-1,8))/2_8
             ENDIF
           ELSE
              CBMAXS = 0_8
           END IF
           IF (MASTERF) THEN
             IF (LEVEL.EQ.1) THEN
                IF (.NOT.UPDATE) THEN
                  NBR = min(NELIMF, NCB)
                ELSE
                  NBR = 0
                ENDIF
             ELSE
                NBR = min(NELIMF, NBROWMAX)
             ENDIF
             IF (KEEP(50).EQ.0) THEN
                CBMAXR = int(NBR,8)*NCB8
             ELSE
                CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)-
     &                   (int(NBR,8)*int(NBR-1,8))/2_8
                CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8)
                CBMAXR = min(CBMAXR, SIZECB)
                IF ((LEVEL.EQ.1).AND.(.NOT. COMPRESSCB)) THEN
                  CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8)
                ENDIF
             ENDIF
           ELSE IF (UPDATEF) THEN
              NBR = min(NBROWMAXF,NBROWMAX)
              CBMAXR = int(NBR,8) * NCB8
              IF (KEEP(50).NE.0) THEN
                CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8
              ENDIF
           ELSE
              CBMAXR = 0_8
           ENDIF
         ELSEIF (LEVELF.EQ.3) THEN
           CBMAXR = LEV3MAXREC
           IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN
             CBMAXS = LEV3MAXREC
           ELSE
             CBMAXS = 0_8
           ENDIF
         ELSE
           IF (MASTERF) THEN
             CBMAXS = 0_8
             NBR = min(NFRF,NBROWMAX)
             IF ((LEVEL.EQ.1).AND.UPDATE) THEN
                NBR = 0
             ENDIF
             CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8)
             IF (LEVEL.EQ.2)
     *       CBMAXR = min(CBMAXR, SIZECB_SLAVE)
             IF ( KEEP(50).NE.0 )  THEN
              CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8)
             ELSE
              CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8))
             ENDIF
           ELSE
             CBMAXR = 0_8
             CBMAXS = SIZECB
           ENDIF
         ENDIF
         IF (UPDATE) THEN
           CBMAXS = min(CBMAXS, SIZECB)
           IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN
              SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8))
           ENDIF
         ENDIF
         STACKCB = .FALSE.
         IF (UPDATEF) THEN
          STACKCB = .TRUE.
          SIZECBI     = 2 * NFR + SIZEHEADER
          IF (LEVEL.EQ.1) THEN
             IF (KEEP(50).NE.0.AND.LEVELF.NE.3
     *           .AND.COMPRESSCB) THEN
                 SIZECB = (NCB8*(NCB8+1_8))/2_8
             ELSE
                 SIZECB = NCB8*NCB8
             ENDIF
             IF (MASTER) THEN
               SIZECBI     = 2+ XSIZE_IC
             ELSE IF (LEVELF.EQ.1) THEN
               SIZECB  = min(CBMAXR,SIZECB)
               SIZECBI    = 2 * NCB +  9 
               SBUFR_CB   = max(SBUFR_CB, int(SIZECBI,8)+SIZECB)
               SIZECBI    =  2 * NCB + SIZEHEADER     
             ELSE 
               SIZECBI    = 2 * NCB +  9 
               SBUFR_CB   = max(SBUFR_CB, 
     &                      min(SIZECB,CBMAXR) + int(SIZECBI,8))
               MAXTEMPCB  = max(MAXTEMPCB, min(SIZECB,CBMAXR)) 
               SIZECBI    =  2 * NCB + SIZEHEADER 
               MAXITEMPCB = max(MAXITEMPCB, SIZECBI)
               SIZECBI     = 0
               SIZECB      = 0_8
             ENDIF
          ELSE 
             SIZECB = SIZECB_SLAVE
             MAXTEMPCB  = max(MAXTEMPCB, min(CBMAXR,SIZECB) )
             MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER)
             IF (.NOT. 
     &        (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1))
     &          ) 
     &       SBUFR_CB = max(SBUFR_CB, 
     &            min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8))
             IF (MASTER) THEN
              SIZECBI     =  NCB + 5 +  SLAVEF - 1 + XSIZE_IC
              SIZECB  = 0_8
             ELSE IF (UPDATE) THEN
              SIZECBI      =  NFR + 6 + SLAVEF - 1 + XSIZE_IC
              IF (KEEP(50).EQ.0) THEN
                SIZECBI = SIZECBI + NBROWMAX + NFR + 
     &                    SIZEHEADER
              ELSE
                SIZECBI = SIZECBI + NBROWMAX + NFR +
     &                    SIZEHEADER+ NSLAVES_LOC
              ENDIF
             ELSE
              SIZECB      = 0_8
              SIZECBI     = 0
             ENDIF
          ENDIF
         ELSE
           IF (LEVELF.NE.3) THEN
               STACKCB     = .TRUE.
               SIZECB      = 0_8
               SIZECBI     = 0
               IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN
                  IF (COMPRESSCB) THEN 
                      SIZECB  = (NCB8*(NCB8+1_8))/2_8
                  ELSE
                      SIZECB  = NCB8*NCB8
                  ENDIF
                  SIZECBI     = 2 * NCB + SIZEHEADER
               ELSE IF (LEVEL.EQ.2) THEN
                 IF (MASTER) THEN
                   SIZECBI     =  NCB + 5 +  SLAVEF - 1 + XSIZE_IC
                 ELSE 
                   SIZECB  = SIZECB_SLAVE
                   SIZECBI = SIZECBI + NBROWMAX + NFR + SIZEHEADER
                 ENDIF 
               ENDIF
           ENDIF
         ENDIF
         IF (STACKCB) THEN
           IF (FRERE(STEP(INODE)).EQ.0) THEN
                  write(*,*) ' ERROR 3 in CMUMPS_246'
                  CALL MUMPS_ABORT()
           ENDIF
           ITOP = ITOP + 1
           IF ( ITOP .GT. NSTEPS ) THEN
             WRITE(*,*) 'ERROR 4 in CMUMPS_246 '
           ENDIF
           LSTKI(ITOP) = SIZECBI
           ISTKI=ISTKI + SIZECBI
           ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC)
           LSTKR(ITOP) = SIZECB
           ISTKR = ISTKR + LSTKR(ITOP)
           NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB)
           NIRNEC = max0(NIRNEC,NIRADU+ISTKI+MAXITEMPCB)
           NIRNEC_OOC = max0(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+
     &                  MAXITEMPCB + 
     &                    (XSIZE_OOC-XSIZE_IC) )  
         ENDIF 
        ENDIF 
         TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1
         IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN
            INODE = IFATH 
            GOTO 95
         ELSE
            GOTO 90
         ENDIF
      ENDIF 
 115  CONTINUE
      BLOCKING_RHS = KEEP(84)
      IF (KEEP(84).EQ.0) BLOCKING_RHS=1
      NRLNEC = max(NRLNEC, 
     &         NRLADU+int(4*KEEP(127)*abs(BLOCKING_RHS),8))
      IF (BLOCKING_RHS .LT. 0) THEN
        BLOCKING_RHS = - 2 * BLOCKING_RHS
      ENDIF
      NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+
     *                    int(4*KEEP(127)*BLOCKING_RHS,8))
      SBUF_RECOLD = max(int(SBUFR,8),SBUFR_CB)
      SBUF_RECOLD = max(SBUF_RECOLD,
     &        MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8
      SBUF_REC = max(SBUFR, int(min(100000_8,SBUFR_CB)))
      SBUF_REC = SBUF_REC   + 17
      SBUF_REC = SBUF_REC + 2 * KEEP(127) + SLAVEF - 1 + 7
      SBUF_SEND = max(SBUFS, int(min(100000_8,SBUFR_CB)))
      SBUF_SEND = SBUF_SEND + 17 
      IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN
         SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8)
         SBUF_REC = SBUF_REC+KEEP(108)+1
         SBUF_SEND = SBUF_SEND+KEEP(108)+1
      ENDIF
      IF (SLAVEF.EQ.1) THEN 
         SBUF_RECOLD = 1_8
         SBUF_REC = 1
         SBUF_SEND= 1
      ENDIF
      DEALLOCATE( LSTKR, TNSTK, IPOOL,
     *          LSTKI )
      OPS_SUBTREE = real(OPS_SBTR_LOC)
      OPSA        = real(OPSA_LOC)
      KEEP(66)    = int(OPSA_LOC/1000000.d0)
      RETURN
      END SUBROUTINE CMUMPS_246
      RECURSIVE SUBROUTINE 
     *    CMUMPS_271( COMM_LOAD, ASS_IRECV, 
     *    INODE, NELIM_ROOT, root, 
     *
     *    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     *    IWPOS, IWPOSCB, IPTRLU,
     *    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     *    PTLUST_S, PTRFAC,
     *    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     *    IFLAG, IERROR, COMM,
     *    NBPROCFILS,
     *    IPOOL, LPOOL, LEAF,
     *    NBFIN, MYID, SLAVEF,
     *
     *    OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *    INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE,
     *    LPTRAR, NELT, FRTPTR, FRTELT, 
     *    ISTEP_TO_INIV2, TAB_POS_IN_PERE  )
      IMPLICIT NONE
      INCLUDE 'cmumps_root.h'
      INCLUDE 'mpif.h'
      TYPE (CMUMPS_ROOT_STRUC) :: root
      INTEGER KEEP(500), ICNTL( 40 )
      INTEGER*8 KEEP8(150)
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER INODE, NELIM_ROOT
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER POSFAC,IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS
      INTEGER N, LIW, LA
      INTEGER IW( LIW )
      COMPLEX A( LA )
      INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), PTRFAC(KEEP(28)),
     *PTRAST(KEEP(28))
      INTEGER STEP(N), 
     * PIMASTER(KEEP(28)),
     *  PAMASTER(KEEP(28))
      INTEGER COMP
      INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) )
      INTEGER NBPROCFILS(KEEP(28))
      INTEGER IFLAG, IERROR, COMM
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER NELT, LPTRAR
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER MYID, SLAVEF, NBFIN
      DOUBLE PRECISION OPASSW, OPELIW
      INTEGER ITLOC( N ), FILS( N )
      INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR )
      INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) 
      INTEGER INTARR(max(1,KEEP(14)))
      COMPLEX DBLARR(max(1,KEEP(13)))
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     *        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      INCLUDE 'mumps_tags.h'
      INTEGER I, J, OPSFAC, APOS, LCONT, NCOL_TO_SEND, LDA
      INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES,
     *        H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, 
     *        LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, 
     *        POSELT, NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON,
     *        SHIFT_LIST_COL_SON, SHIFT_VAL_SON,LDAFS, IERR,
     *        STATUS( MPI_STATUS_SIZE ), ISON, PDEST_MASTER_ISON
      LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      INTEGER MSGSOU, MSGTAG
      LOGICAL INVERT, FLAG
      INCLUDE 'mumps_headers.h'
      INTEGER  MUMPS_275, MUMPS_330
      EXTERNAL MUMPS_275, MUMPS_330
      FPERE = KEEP(38)
      TYPE_SON = MUMPS_330(STEP(INODE),PROCNODE_STEPS,SLAVEF)
      IF ( MUMPS_275( STEP(INODE), PROCNODE_STEPS,
     *     SLAVEF ).EQ.MYID) THEN
       IOLDPS   = PTLUST_S(STEP(INODE))
       NFRONT   = IW(IOLDPS+KEEP(IXSZ))
       NPIV     = IW(IOLDPS+1+KEEP(IXSZ))
       NASS     = iabs(IW(IOLDPS + 2+KEEP(IXSZ)))
       NSLAVES  =  IW(IOLDPS+5+KEEP(IXSZ))
       H_INODE  = 6 + NSLAVES + KEEP(IXSZ)
       NELIM    = NASS - NPIV
       NBCOL = NFRONT - NPIV
       LIST_NELIM_ROW = IOLDPS + H_INODE + NPIV
       LIST_NELIM_COL = LIST_NELIM_ROW + NFRONT
           IF (NELIM.LE.0) THEN
            write(6,*) ' ERROR 1 in CMUMPS_271 ', NELIM
            write(6,*) MYID,':Process root2son: INODE=',INODE,
     * 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE))
     *  +5+KEEP(IXSZ))
            CALL MUMPS_ABORT()
           ENDIF
       NELIM_LOCAL = NELIM_ROOT
       DO I=1, NELIM
        root%RG2L_ROW(IW(LIST_NELIM_ROW)) = NELIM_LOCAL
        root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL
        NELIM_LOCAL = NELIM_LOCAL + 1
        LIST_NELIM_ROW = LIST_NELIM_ROW + 1
        LIST_NELIM_COL = LIST_NELIM_COL + 1
       ENDDO
       NBROW = NFRONT - NPIV
       NROW = NELIM
       IF ( KEEP( 50 ) .eq. 0 ) THEN
         NCOL = NFRONT - NPIV
       ELSE
         NCOL = NELIM
       END IF
       SHIFT_LIST_ROW_SON = H_INODE + NPIV
       SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV
       IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN
         LDAFS = NFRONT
       ELSE
         LDAFS = NASS
       END IF
       SHIFT_VAL_SON      = NPIV * LDAFS + NPIV
       CALL CMUMPS_80( COMM_LOAD,
     *   ASS_IRECV, 
     *   N, INODE, FPERE,
     *   PTLUST_S(1), PTRAST(1),
     *   root, NROW, NCOL, SHIFT_LIST_ROW_SON,
     *   SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS,
     *   ROOT_NON_ELIM_CB, MYID, COMM,
     *   BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     *   IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA,
     *   PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1),
     *   STEP, PIMASTER, PAMASTER,
     *   NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS,
     *   IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
     *   OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *   INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE,
     *   LPTRAR, NELT, FRTPTR, FRTELT, 
     *   ISTEP_TO_INIV2, TAB_POS_IN_PERE  )
       IF (IFLAG.LT.0 ) RETURN
       IF (TYPE_SON.EQ.1) THEN
        NROW = NFRONT - NASS
        NCOL = NELIM
        SHIFT_LIST_ROW_SON = H_INODE + NASS
        SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV
        SHIFT_VAL_SON      = NASS * NFRONT + NPIV
        IF ( KEEP( 50 ) .eq. 0 ) THEN
          INVERT = .FALSE.
        ELSE
          INVERT = .TRUE.
        END IF
        CALL CMUMPS_80( COMM_LOAD, ASS_IRECV,
     *    N, INODE, FPERE,
     *    PTLUST_S, PTRAST,
     *    root, NROW, NCOL, SHIFT_LIST_ROW_SON,
     *    SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT,
     *    ROOT_NON_ELIM_CB, MYID, COMM,
     *
     *    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     *    IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA,
     *    PTRIST, PTLUST_S, PTRFAC,
     *    PTRAST, STEP, PIMASTER, PAMASTER,
     *    NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS,
     *    IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
     *    OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *    INTARR, DBLARR, ICNTL, KEEP,KEEP8, INVERT, ND, FRERE,
     *    LPTRAR, NELT, FRTPTR, FRTELT, 
     *   ISTEP_TO_INIV2, TAB_POS_IN_PERE  )
        IF (IFLAG.LT.0 ) RETURN
       ENDIF
       IOLDPS = PTLUST_S(STEP(INODE))
       POSELT = PTRAST(STEP(INODE))
       IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE)
       PTRFAC(STEP(INODE))=POSELT
       IF ( TYPE_SON .eq. 1 ) THEN
         NBROW = NFRONT - NPIV
       ELSE
         NBROW = NELIM
       END IF
       IF ( TYPE_SON .eq. 1 .OR. KEEP(50).EQ.0) THEN
         LDA = NFRONT
       ELSE
         LDA = NPIV+NBROW
       ENDIF
       CALL CMUMPS_324(A(POSELT), LDA,
     *          NPIV, NBROW, KEEP(50))
       IW(IOLDPS + KEEP(IXSZ))     = NBCOL
       IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV
       IF (TYPE_SON.EQ.2) THEN
        IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS
       ELSE
        IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT
       ENDIF
       IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV
      CALL CMUMPS_93(0,MYID,N,IOLDPS,TYPE_SON,IW,LIW,
     *    A, LA, POSFAC, LRLU, LRLUS,
     *    IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR)
      IF(IERR.LT.0)THEN
         IFLAG=IERR
         IERROR=0
         RETURN
      ENDIF
      ELSE 
        ISON = INODE
        PDEST_MASTER_ISON = MUMPS_275(STEP(ISON),
     *      PROCNODE_STEPS,SLAVEF)
        DO WHILE (
     *     ( IW( PTRIST(STEP(ISON)) + 1  +KEEP(IXSZ)) .NE.
     *       IW( PTRIST(STEP(ISON)) + 3  +KEEP(IXSZ)) ) .OR.
     *     ( KEEP(50) .NE. 0 .AND.
     *       IW( PTRIST(STEP(ISON)) + 6  +KEEP(IXSZ)) .NE. 0 ) )
          IF ( KEEP(50).eq.0) THEN
            MSGSOU = PDEST_MASTER_ISON
            MSGTAG = BLOC_FACTO
          ELSE
            IF ( IW( PTRIST(STEP(ISON)) + 1  +KEEP(IXSZ)) .NE.
     *           IW( PTRIST(STEP(ISON)) + 3  +KEEP(IXSZ)) ) THEN
              MSGSOU = PDEST_MASTER_ISON
              MSGTAG = BLOC_FACTO_SYM
            ELSE
              MSGSOU = MPI_ANY_SOURCE
              MSGTAG = BLOC_FACTO_SYM_SLAVE
            END IF
          END IF
          BLOCKING  = .TRUE.
          SET_IRECV = .FALSE.
          MESSAGE_RECEIVED = .FALSE.
          CALL CMUMPS_329( COMM_LOAD, ASS_IRECV,
     *    BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
     *    MSGSOU, MSGTAG,
     *    STATUS,
     *    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     *    IWPOS, IWPOSCB, IPTRLU,
     *    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     *    PTLUST_S, PTRFAC,
     *    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     *    IFLAG, IERROR, COMM,
     *    NBPROCFILS,
     *    IPOOL, LPOOL, LEAF,
     *    NBFIN, MYID, SLAVEF,
     *
     *    root, OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *    INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, LPTRAR,
     *    NELT, FRTPTR, FRTELT,
     *    ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. )
          IF ( IFLAG .LT. 0 ) RETURN
        END DO
       IOLDPS = PTRIST(STEP(INODE))
       LCONT  = IW(IOLDPS+KEEP(IXSZ))
       NROW   = IW(IOLDPS+2+KEEP(IXSZ))
       NPIV   = IW(IOLDPS+3+KEEP(IXSZ))
       NASS   = IW(IOLDPS+4+KEEP(IXSZ))
       NELIM  = NASS-NPIV
       IF (NELIM.LE.0) THEN
         write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=',
     *   INODE,LCONT, NROW, NPIV, NASS, NELIM
         write(6,*) MYID,': IOLDPS=',IOLDPS
         write(6,*) MYID,': ERROR 2 in CMUMPS_271 '
         CALL MUMPS_ABORT()
       ENDIF
       NSLAVES= IW(IOLDPS+5+KEEP(IXSZ))
       H_INODE = 6 + NSLAVES + KEEP(IXSZ)
       LIST_NELIM_COL = IOLDPS + H_INODE + NROW + NPIV
       NELIM_LOCAL = NELIM_ROOT
       DO I = 1, NELIM
        root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL
        NELIM_LOCAL = NELIM_LOCAL + 1
        LIST_NELIM_COL = LIST_NELIM_COL + 1
       ENDDO
       SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ)
       SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV
       NCOL_TO_SEND       = NELIM
       IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR.
     *     IW(IOLDPS+XXS).EQ.S_ALL) THEN
         SHIFT_VAL_SON      = NPIV
         LDA                = LCONT + NPIV
       ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN
         SHIFT_VAL_SON=NROW*(LCONT+NPIV-NELIM)
         LDA         =NELIM
       ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN
         SHIFT_VAL_SON=0
         LDA = NELIM
       ELSE
         write(*,*) MYID,": internal error in CMUMPS_271",
     *   IW(IOLDPS+XXS), "INODE=",INODE
         CALL MUMPS_ABORT()
       ENDIF
       IF ( KEEP( 50 ) .eq. 0 ) THEN
         INVERT = .FALSE.
       ELSE
         INVERT = .TRUE.
       END IF
       CALL CMUMPS_80( COMM_LOAD, ASS_IRECV, 
     *    N, INODE, FPERE,
     *    PTRIST, PTRAST,
     *    root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON,
     *    SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA,
     *    ROOT_NON_ELIM_CB, MYID, COMM,
     *
     *    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     *    IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA,
     *    PTRIST, PTLUST_S, PTRFAC,
     *    PTRAST, STEP, PIMASTER, PAMASTER,
     *    NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS,
     *    IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
     *    OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *    INTARR, DBLARR, ICNTL, KEEP,KEEP8, INVERT, ND, FRERE,
     *    LPTRAR, NELT, FRTPTR, FRTELT, 
     *   ISTEP_TO_INIV2, TAB_POS_IN_PERE  )
        IF (IFLAG.LT.0 ) RETURN
       IF (KEEP(214).EQ.2) THEN
        CALL CMUMPS_314( N, INODE,
     *      PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA,
     *      LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP,
     *      IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, ITLOC,
     *      IFLAG, IERROR, SLAVEF, MYID, COMM, KEEP,KEEP8, TYPE_SON
     $      )
       ENDIF
        IF (IFLAG.LT.0) THEN
           CALL CMUMPS_44( MYID, SLAVEF, COMM )
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_271
      SUBROUTINE CMUMPS_221(NFRONT,NASS,N,INODE,IW,LIW,A,LA,
     *    INOPV,NOFFW,IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,
     *     DKEEP,PIVNUL_LIST,LPN_LIST,
     *
     *     PP_FIRST2SWAP_L, PP_LastPanelonDisk_L,
     *     PP_LastPIVRPTRFilled_L,
     *     PP_FIRST2SWAP_U, PP_LastPanelonDisk_U,
     *     PP_LastPIVRPTRFilled_U)
      IMPLICIT NONE
      INTEGER NFRONT,NASS,N,LA,LIW,INODE,IFLAG,INOPV,NOFFW
      COMPLEX A(LA) 
      REAL UU, SEUIL
      INTEGER IW(LIW) 
      INTEGER  IOLDPS, POSELT
      INTEGER KEEP(500)
      INTEGER*8 KEEP8(150)
      INTEGER LPN_LIST
      INTEGER PIVNUL_LIST(LPN_LIST)
      REAL    DKEEP(30)
      INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L,
     *        PP_LastPIVRPTRFilled_L,
     *        PP_FIRST2SWAP_U, PP_LastPanelonDisk_U,
     *        PP_LastPIVRPTRFilled_U
      INCLUDE 'mumps_headers.h'
      COMPLEX SWOP
      INTEGER APOS, XSIZE
      REAL AMROW
      REAL ZERO,RMAX,ONE
      INTEGER NPIV,NASSW,IPIV
      INTEGER NPIVP1,JMAX,J1,J3,JJ,J2,IDIAG,ISW,ISWPS1
      INTEGER ISWPS2,KSW
      INTEGER CMUMPS_IXAMAX
      INTRINSIC max
      DATA ZERO /0.0E0/
      DATA ONE /1.0E0/
      INTEGER TYPEF_L, I_PIVRPTR_L, I_PIVR_L, NBPANELS_L
      INTEGER TYPEF_U, I_PIVRPTR_U, I_PIVR_U, NBPANELS_U
      PARAMETER (TYPEF_L=1, TYPEF_U=2)
        XSIZE   = KEEP(IXSZ)
        NPIV    = IW(IOLDPS+1+XSIZE)
        NPIVP1  = NPIV + 1
        IF (KEEP(201).EQ.1) THEN
          CALL CMUMPS_667(TYPEF_L, NBPANELS_L, 
     *       I_PIVRPTR_L, I_PIVR_L, 
     *       IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE,
     *       IW, LIW)
          CALL CMUMPS_667(TYPEF_U, NBPANELS_U, 
     *       I_PIVRPTR_U, I_PIVR_U, 
     *       IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE,
     *       IW, LIW)
        ENDIF
        NASSW   = iabs(IW(IOLDPS+3+XSIZE))
        IF(INOPV .EQ. -1) THEN
           APOS = POSELT + NFRONT*(NPIVP1-1) + NPIV
           IDIAG = APOS
           IF(abs(A(APOS)).LT.SEUIL) THEN
              IF(real(A(APOS)) .GE. ZERO) THEN
                 A(APOS) = SEUIL
              ELSE
                 A(APOS) = -SEUIL
              ENDIF
              KEEP(98) = KEEP(98)+1
           ENDIF
           IF (KEEP(201).EQ.1) THEN
             CALL CMUMPS_680( IW(I_PIVRPTR_L), 
     *               NBPANELS_L,
     *               IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, 
     *               PP_LastPanelonDisk_L,
     *               PP_LastPIVRPTRFilled_L)
             CALL CMUMPS_680( IW(I_PIVRPTR_U), 
     *               NBPANELS_U,
     *               IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, 
     *               PP_LastPanelonDisk_U,
     *               PP_LastPIVRPTRFilled_U)
           ENDIF
           GO TO 420
        ENDIF
        INOPV   = 0
          DO 460 IPIV=NPIVP1,NASSW
            APOS = POSELT + NFRONT*(IPIV-1) + NPIV
            JMAX = 1
            IF (UU.GT.ZERO) GO TO 340
            IF (abs(A(APOS)).EQ.ZERO) GO TO 630
            GO TO 380
  340       AMROW = ZERO
            J1 = APOS
            J2 = APOS - NPIV + NASS - 1
             J3    = NASS -NPIV
             JMAX  = CMUMPS_IXAMAX(J3,A(J1),1)
             JJ    = JMAX + J1 - 1
             AMROW = abs(A(JJ))
            RMAX = AMROW
            J1 = J2 + 1
            J2 = APOS - NPIV + NFRONT - 1
            IF (J2.LT.J1) GO TO 370
            DO 360 JJ=J1,J2
              RMAX = max(abs(A(JJ)),RMAX)
  360       CONTINUE
  370       IDIAG = APOS + IPIV - NPIVP1
            IF (RMAX.LE.DKEEP(1)) THEN
               KEEP(109) = KEEP(109)+1
               ISW = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE+
     &                      IW(IOLDPS+5+XSIZE)+IPIV-NPIVP1
               PIVNUL_LIST(KEEP(109)) = IW(ISW)
               IF(DKEEP(2).GT.ZERO) THEN
                  IF(real(A(IDIAG)) .GE. ZERO) THEN
                     A(IDIAG) = DKEEP(2)
                  ELSE
                     A(IDIAG) = -DKEEP(2)
                  ENDIF
               ELSE
                 J1 = APOS
                 J2 = APOS - NPIV + NFRONT - 1
                 DO JJ=J1,J2
                   A(JJ)= cmplx(ZERO)
                 ENDDO
                 A(IDIAG) = cmplx(ONE)
               ENDIF
               JMAX = IPIV - NPIV
               GOTO 380   
            ENDIF
            IF (abs(A(IDIAG)).GT. max(UU*RMAX,SEUIL)) THEN
              JMAX = IPIV - NPIV
              GO TO 380
            ENDIF
            IF (AMROW.LE. max(UU*RMAX,SEUIL)) GO TO 460
            NOFFW = NOFFW + 1
  380       IF (IPIV.EQ.NPIVP1) GO TO 400
            J1 = POSELT + NPIV*NFRONT
            J2 = J1 + NFRONT - 1
            J3 = POSELT + (IPIV-1)*NFRONT
            DO 390 JJ=J1,J2
              SWOP = A(JJ)
              A(JJ) = A(J3)
              A(J3) = SWOP
              J3 = J3 + 1
  390       CONTINUE
            ISWPS1 = IOLDPS + 5 + NPIVP1 + XSIZE
            ISWPS2 = IOLDPS + 5 + IPIV + XSIZE
            ISW = IW(ISWPS1)
            IW(ISWPS1) = IW(ISWPS2)
            IW(ISWPS2) = ISW
  400       IF (JMAX.EQ.1) GO TO 420
            J1 = POSELT + NPIV
            J2 = POSELT + NPIV + JMAX - 1
            DO 410 KSW=1,NFRONT
              SWOP = A(J1)
              A(J1) = A(J2)
              A(J2) = SWOP
              J1 = J1 + NFRONT
              J2 = J2 + NFRONT
  410       CONTINUE
            ISWPS1 = IOLDPS + 5 + NFRONT + NPIV + 1 +XSIZE
            ISWPS2 = IOLDPS + 5 + NFRONT + NPIV + JMAX +XSIZE
            ISW = IW(ISWPS1)
            IW(ISWPS1) = IW(ISWPS2)
            IW(ISWPS2) = ISW
            GO TO 420
  460     CONTINUE
      IF (NASSW.EQ.NASS) THEN
       INOPV = 1
      ELSE
       INOPV = 2
      ENDIF
      GO TO 430
  630 CONTINUE
      IFLAG = -10
      WRITE(*,*) 'Detected a null pivot, INODE/NPIV=',INODE,NPIV
      GOTO 430
  420 CONTINUE
              IF (KEEP(201).EQ.1) THEN
                CALL CMUMPS_680( IW(I_PIVRPTR_L), 
     *               NBPANELS_L,
     *               IW(I_PIVR_L), NASS, NPIVP1, IPIV, 
     *               PP_LastPanelonDisk_L,
     *               PP_LastPIVRPTRFilled_L)
                CALL CMUMPS_680( IW(I_PIVRPTR_U), 
     *               NBPANELS_U,
     *               IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, 
     *               PP_LastPanelonDisk_U,
     *               PP_LastPIVRPTRFilled_U)
              ENDIF
 430  CONTINUE
      RETURN
      END SUBROUTINE CMUMPS_221
      SUBROUTINE CMUMPS_220(NFRONT,NASS,N,INODE,IW,LIW,A,LA,
     *   INOPV,NOFFW,IOLDPS,POSELT,UU,SEUIL,KEEP,
     *     PP_FIRST2SWAP_L, PP_LastPanelonDisk_L,
     *     PP_LastPIVRPTRFilled_L,
     *     PP_FIRST2SWAP_U, PP_LastPanelonDisk_U,
     *     PP_LastPIVRPTRFilled_U)
      IMPLICIT NONE
      INTEGER NFRONT,NASS,N,LIW,LA,INODE,INOPV
      INTEGER KEEP(500)
      REAL UU, SEUIL
      COMPLEX A(LA)
      INTEGER IW(LIW)
      REAL AMROW
      REAL ZERO,RMAX
      COMPLEX  SWOP
      INTEGER APOS, POSELT, IOLDPS
      INTEGER NOFFW,NPIV,IPIV
      INTEGER NPIVP1,JMAX,J1,J3,JJ,J2,IDIAG,ISW,ISWPS1
      INTEGER ISWPS2,KSW,XSIZE
      INTEGER TYPEF_L, I_PIVRPTR_L, I_PIVR_L, NBPANELS_L
      INTEGER TYPEF_U, I_PIVRPTR_U, I_PIVR_U, NBPANELS_U
      PARAMETER (TYPEF_L=1, TYPEF_U=2)
      INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L,
     *        PP_LastPIVRPTRFilled_L,
     *        PP_FIRST2SWAP_U, PP_LastPanelonDisk_U,
     *        PP_LastPIVRPTRFilled_U
      INTEGER CMUMPS_IXAMAX
      INCLUDE 'mumps_headers.h'
      INTRINSIC max
      DATA ZERO /0.0E0/
        INOPV   = 0
        XSIZE   = KEEP(IXSZ)
        NPIV    = IW(IOLDPS+1+XSIZE)
        NPIVP1  = NPIV + 1
        IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN
          CALL CMUMPS_667(TYPEF_L, NBPANELS_L, 
     *       I_PIVRPTR_L, I_PIVR_L, 
     *       IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)
     *              +KEEP(IXSZ),
     *       IW, LIW)
          CALL CMUMPS_667(TYPEF_U, NBPANELS_U, 
     *       I_PIVRPTR_U, I_PIVR_U, 
     *       IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE,
     *       IW, LIW)
        ENDIF
          DO 460 IPIV=NPIVP1,NASS
            APOS = POSELT + NFRONT*NPIV + (IPIV-1)
            JMAX = 1
            AMROW = ZERO
            J1 = APOS
            J3    = NASS -NPIV
            JMAX  = CMUMPS_IXAMAX(J3,A(J1),NFRONT)
            JJ    = J1 + (JMAX-1)*NFRONT
            AMROW = abs(A(JJ))
            RMAX = AMROW
            J1 = APOS +  (NASS-NPIV) * NFRONT
            J3 = NFRONT - NASS
            IF (J3.EQ.0) GOTO 370
            DO 360 JJ=1,J3
              RMAX = max(abs(A(J1)),RMAX)
              J1 = J1 + NFRONT
  360       CONTINUE
  370       IF (RMAX.EQ.ZERO) GO TO 460
            IDIAG = APOS + (IPIV - NPIVP1)*NFRONT
            IF (abs(A(IDIAG)).GE.max(UU*RMAX,SEUIL)) THEN
              JMAX = IPIV - NPIV
              GO TO 380
            ENDIF
            IF (AMROW.LT.max(UU*RMAX,SEUIL)) GO TO 460
            NOFFW = NOFFW + 1
  380       IF (IPIV.EQ.NPIVP1) GO TO 400
            J1 = POSELT + NPIV
            J3 = POSELT + (IPIV-1)
            DO 390 JJ= 1,NFRONT
              SWOP = A(J1)
              A(J1) = A(J3)
              A(J3) = SWOP
              J1 = J1 + NFRONT
              J3 = J3 + NFRONT
  390       CONTINUE
            ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE
            ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE
            ISW = IW(ISWPS1)
            IW(ISWPS1) = IW(ISWPS2)
            IW(ISWPS2) = ISW
  400       IF (JMAX.EQ.1) GO TO 420
            J1 = POSELT + NPIV*NFRONT
            J2 = POSELT + (NPIV + JMAX - 1)*NFRONT
            DO 410 KSW=1,NFRONT
              SWOP = A(J1)
              A(J1) = A(J2)
              A(J2) = SWOP
              J1 = J1 + 1
              J2 = J2 + 1
  410       CONTINUE
            ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE
            ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE
            ISW = IW(ISWPS1)
            IW(ISWPS1) = IW(ISWPS2)
            IW(ISWPS2) = ISW
            GO TO 420
  460     CONTINUE
       INOPV = 1
       GOTO 430
  420 CONTINUE
              IF (KEEP(201).EQ.1) THEN
                CALL CMUMPS_680( IW(I_PIVRPTR_L), 
     *               NBPANELS_L,
     *               IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX,
     *               PP_LastPanelonDisk_L,
     *               PP_LastPIVRPTRFilled_L)
                CALL CMUMPS_680( IW(I_PIVRPTR_U), 
     *               NBPANELS_U,
     *               IW(I_PIVR_U), NASS, NPIVP1, IPIV,
     *               PP_LastPanelonDisk_U,
     *               PP_LastPIVRPTRFilled_U)
              ENDIF
 430  CONTINUE
      RETURN
      END SUBROUTINE CMUMPS_220
      SUBROUTINE CMUMPS_225(IBEG_BLOCK,
     *     NFRONT,NASS,N,INODE,IW,LIW,A,LA,
     *     IOLDPS,POSELT,IFINB,LKJIB,LKJIT,XSIZE)
      IMPLICIT NONE
      INTEGER NFRONT,NASS,N,LA,LIW,INODE,IFINB,LKJIB,IBEG_BLOCK
      COMPLEX    A(LA)
      INTEGER IW(LIW)
      COMPLEX    VALPIV
      INTEGER APOS, UUPOS, IOLDPS, POSELT
      INTEGER LKJIT, XSIZE
      COMPLEX ONE, ALPHA
      INTEGER NPIV,JROW2
      INTEGER NEL2,NPIVP1,KROW,LPOS,NEL
      INCLUDE 'mumps_headers.h'
      PARAMETER(ONE=1.0E0, ALPHA=-1.0E0)
        NPIV   = IW(IOLDPS+1+XSIZE)
        NPIVP1 = NPIV + 1
        NEL    = NFRONT - NPIVP1
        IFINB  = 0
        IF (IW(IOLDPS+3+XSIZE).LE.0) THEN
          IF (NASS.LT.LKJIT) THEN
           IW(IOLDPS+3+XSIZE) = NASS
          ELSE
           IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB)
          ENDIF
        ENDIF
        JROW2 = IW(IOLDPS+3+XSIZE)
        NEL2   = JROW2 - NPIVP1
        IF (NEL2.EQ.0) THEN
         IF (JROW2.EQ.NASS) THEN
          IFINB        = -1
         ELSE
          IFINB        = 1
          IW(IOLDPS+3+XSIZE) = min0(JROW2+LKJIB,NASS)
          IBEG_BLOCK = NPIVP1+1
         ENDIF
        ELSE
         APOS   = POSELT + NPIV*(NFRONT + 1)
         VALPIV = ONE/A(APOS)
         LPOS   = APOS + NFRONT
         DO 541 KROW = 1,NEL2
             A(LPOS) = A(LPOS)*VALPIV
             LPOS    = LPOS + NFRONT
 541     CONTINUE
         LPOS   = APOS + NFRONT
         UUPOS  = APOS+1
         CALL CGERU(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT,
     *              A(LPOS+1),NFRONT)
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_225
      SUBROUTINE CMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA,IOLDPS,
     *          POSELT,XSIZE)
      IMPLICIT NONE
      INTEGER NFRONT,N,INODE,LA,LIW,XSIZE
      COMPLEX    A(LA)
      INTEGER IW(LIW)
      COMPLEX    ALPHA,VALPIV
      INTEGER APOS, POSELT, UUPOS
      INTEGER IOLDPS,NPIV,NEL
      INTEGER LPOS,JROW,IRWPOS
      INCLUDE 'mumps_headers.h'
      COMPLEX ONE
      DATA ONE /1.0E0/
        NPIV   = IW(IOLDPS+1+XSIZE)
        NEL    = NFRONT - NPIV - 1
        APOS   = POSELT + (NPIV)*NFRONT + NPIV
        IF (NEL.EQ.0) GO TO 650
        VALPIV = ONE/A(APOS)
        LPOS   = APOS + NFRONT
        DO 340 JROW = 1,NEL
            A(LPOS) = VALPIV*A(LPOS)
            LPOS    = LPOS + NFRONT
  340   CONTINUE
        LPOS   = APOS + NFRONT
        UUPOS  = APOS+1
        DO 440 JROW = 1,NEL
             IRWPOS  = LPOS + 1
             ALPHA   = -A(LPOS)
             CALL CAXPY(NEL,ALPHA,A(UUPOS),1,A(IRWPOS),1)
             LPOS    = LPOS + NFRONT
  440   CONTINUE
  650   RETURN
        END SUBROUTINE CMUMPS_229
      SUBROUTINE CMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA,
     *       IOLDPS,POSELT,IFINB,XSIZE)
      IMPLICIT NONE
      INCLUDE 'mumps_headers.h'
      INTEGER NFRONT,NASS,N,LA,LIW,INODE,IFINB
      COMPLEX    A(LA)
      INTEGER IW(LIW)
      COMPLEX    ALPHA,VALPIV
      INTEGER APOS, POSELT,UUPOS
      INTEGER IOLDPS,NPIV,KROW, XSIZE
      INTEGER NEL,LPOS,ICOL,NEL2,IRWPOS
      INTEGER NPIVP1
      COMPLEX ONE
      DATA ONE /1.0E0/
        NPIV   = IW(IOLDPS+1+XSIZE)
        NPIVP1 = NPIV + 1
        NEL    = NFRONT - NPIVP1
        NEL2   = NASS - NPIVP1
        IFINB  = 0
        IF (NPIVP1.EQ.NASS) IFINB = 1
        APOS   = POSELT + NPIV*(NFRONT + 1)
        VALPIV = ONE/A(APOS)
        LPOS   = APOS + NFRONT
        DO 541 KROW = 1,NEL
             A(LPOS) = A(LPOS)*VALPIV
             LPOS    = LPOS + NFRONT
 541    CONTINUE
        LPOS   = APOS + NFRONT
        UUPOS  = APOS+1
        DO 440 ICOL = 1,NEL
             IRWPOS  = LPOS + 1
             ALPHA   = -A(LPOS)
             CALL CAXPY(NEL2,ALPHA,A(UUPOS),1,A(IRWPOS),1)
             LPOS    = LPOS + NFRONT
  440   CONTINUE
        RETURN
        END SUBROUTINE CMUMPS_228
      SUBROUTINE CMUMPS_231(A,LA,NFRONT,
     *       NPIV,NASS,POSELT)
      IMPLICIT NONE
      INTEGER LA,POSELT
      COMPLEX    A(LA)
      INTEGER NFRONT, NPIV, NASS
      INTEGER NEL1,NEL11,LPOS2,LPOS1,LPOS
      COMPLEX ALPHA, ONE
      PARAMETER(ONE=1.0E0, ALPHA=-1.0E0)
        NEL1   = NFRONT - NASS
        NEL11  = NFRONT - NPIV
        LPOS2  = POSELT + NASS*NFRONT
        CALL CTRSM('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT,
     *              A(LPOS2),NFRONT)
        LPOS   = LPOS2 + NPIV
        LPOS1  = POSELT + NPIV
        CALL CGEMM('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1),
     *          NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT)
        RETURN
        END SUBROUTINE CMUMPS_231
      SUBROUTINE CMUMPS_642(A,LAFAC,NFRONT,
     &      NPIV,NASS, IW, LIWFAC,
     &      MonBloc, TYPEFile, MYID, KEEP8,
     &      STRAT, IFLAG_OOC,
     &      LNextPiv2beWritten, UNextPiv2beWritten)
      USE CMUMPS_OOC   
      IMPLICIT NONE
      INTEGER NFRONT, NPIV, NASS
      INTEGER  LAFAC, LIWFAC, TYPEFile, MYID, IFLAG_OOC,
     &      LNextPiv2beWritten, UNextPiv2beWritten, STRAT
      COMPLEX  A(LAFAC)
      INTEGER  IW(LIWFAC)
      INTEGER*8 KEEP8(150)
      TYPE(IO_BLOCK) :: MonBloc 
      INTEGER NEL1,NEL11,LPOS2,LPOS1,LPOS
      COMPLEX ALPHA, ONE
      PARAMETER(ONE=1.0E0, ALPHA=-1.0E0)
        NEL1   = NFRONT - NASS
        NEL11  = NFRONT - NPIV
        LPOS2  = 1 + NASS*NFRONT
        CALL CTRSM('L','L','N','N',NPIV,NEL1,ONE,A(1),NFRONT,
     *              A(LPOS2),NFRONT)
           CALL CMUMPS_688
     &          ( STRAT, TYPEFile, 
     &           A, LAFAC, MonBloc,
     &           LNextPiv2beWritten, UNextPiv2beWritten,
     &           IW, LIWFAC, 
     &           MYID, KEEP8(31), IFLAG_OOC )
        LPOS   = LPOS2 + NPIV
        LPOS1  = 1 + NPIV
        CALL CGEMM('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1),
     *          NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT)
        RETURN
        END SUBROUTINE CMUMPS_642
      SUBROUTINE CMUMPS_232(A,LA,NFRONT,NPIV,NASS,POSELT,LKJIB)
      INTEGER LA, NFRONT, NPIV, NASS, LKJIB
      COMPLEX    A(LA)
      INTEGER POSELT
      INTEGER POSELT_LOCAL
      INTEGER NEL1, NEL11, NPBEG, LPOS, LPOS1, LPOS2
      COMPLEX ALPHA, ONE
      PARAMETER(ONE=1.0E0, ALPHA=-1.0E0)
        POSELT_LOCAL = POSELT
        NEL1   = NASS - NPIV
        NPBEG  = NPIV - LKJIB + 1
        NEL11  = NFRONT - NPIV
        LPOS2  = POSELT_LOCAL + NPIV*NFRONT + NPBEG - 1
        POSELT_LOCAL = POSELT_LOCAL + (NPBEG-1)*NFRONT + NPBEG - 1
        CALL CTRSM('L','L','N','N',LKJIB,NEL1,ONE,A(POSELT_LOCAL),
     *               NFRONT,A(LPOS2),NFRONT)
        LPOS   = LPOS2 + LKJIB
        LPOS1  = POSELT_LOCAL + LKJIB
        CALL CGEMM('N','N',NEL11,NEL1,LKJIB,ALPHA,A(LPOS1),
     *       NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT)
        RETURN
        END SUBROUTINE CMUMPS_232
      SUBROUTINE CMUMPS_233(IBEG_BLOCK,
     *    NFRONT,NASS,N,INODE,IW,LIW,A,LA,
     *    IOLDPS,POSELT,LKJIB,LKJIT,XSIZE )
      IMPLICIT NONE
      INTEGER NFRONT, NASS,N,LA,LIW
      COMPLEX    A(LA)
      INTEGER IW(LIW) 
      INTEGER LKJIB, INODE, IBEG_BLOCK
      INTEGER POSELT
      INTEGER IOLDPS, NPIV, JROW2, NPBEG
      INTEGER NONEL, LKJIW, NEL1, NEL11
      INTEGER LBP, IPOS, KPOS, LPOS2, HF
      INTEGER LPOS1,LPOS,LBPT,I1,K1,II,ISWOP,LBP1
      INTEGER LKJIT, POSLOCAL, XSIZE
      INCLUDE 'mumps_headers.h'
      COMPLEX ALPHA, ONE
      PARAMETER(ONE=1.0E0, ALPHA=-1.0E0)
        NPIV   = IW(IOLDPS+1+XSIZE)
        JROW2  = iabs(IW(IOLDPS+3+XSIZE))
        NPBEG  = IBEG_BLOCK
        HF     = 6 + IW(IOLDPS+5+XSIZE) +XSIZE
        NONEL         = JROW2 - NPIV + 1
        IF ((NASS-NPIV).GE.LKJIT) THEN
         LKJIB       = LKJIB + NONEL
         IW(IOLDPS+3+XSIZE)= min0(NPIV+LKJIB,NASS)
        ELSE
          IW(IOLDPS+3+XSIZE) = NASS
        ENDIF
        IBEG_BLOCK = NPIV + 1
        NEL1   = NASS - JROW2
        LKJIW  = NPIV - NPBEG + 1
        NEL11  = NFRONT - NPIV
        IF ((NEL1.EQ.0).OR.(LKJIW.EQ.0)) GO TO 500
        LPOS2  = POSELT + JROW2*NFRONT + NPBEG - 1
         POSLOCAL = POSELT + (NPBEG-1)*NFRONT + NPBEG - 1
         CALL CTRSM('L','L','N','N',LKJIW,NEL1,ONE,
     *               A(POSLOCAL),NFRONT,
     *               A(LPOS2),NFRONT)
        LPOS   = LPOS2 + LKJIW
        LPOS1  = POSLOCAL + LKJIW
        CALL CGEMM('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1),
     *          NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT)
  500   LBP = JROW2 - NPIV
         LBPT  = LBP + LBP
        IF  ((NEL1.GE.LBPT).AND.(NEL1.GE.LKJIB)) THEN
         I1 = IOLDPS + HF + NPIV
         K1 = IOLDPS + HF + NASS - LBP
         DO 10 II=1,LBP
          ISWOP  = IW(I1)
          IW(I1) = IW(K1)
          IW(K1) = ISWOP
          I1     = I1 +1
          K1     = K1 + 1
  10     CONTINUE
         IPOS = POSELT + NPIV*NFRONT
         KPOS = POSELT + (NASS-LBP)*NFRONT
         LBP1 = LBP * NFRONT
         CALL CSWAP(LBP1,A(IPOS),1,A(KPOS),1)
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_233
      SUBROUTINE CMUMPS_236(A,LA,NPIVB,NFRONT,
     *                             NPIV,NASS,POSELT)
      IMPLICIT NONE
      INTEGER NPIVB,NASS,LA
      COMPLEX    A(LA)
      INTEGER APOS, POSELT
      INTEGER NFRONT, NPIV, NASSL
      INTEGER LPOS, LPOS1, LPOS2, NEL1, NEL11, NPIVE
      COMPLEX    ALPHA, ONE
      PARAMETER(ONE=1.0E0, ALPHA=-1.0E0)
        NEL1   = NFRONT - NASS
        NEL11  = NFRONT - NPIV
        NPIVE  = NPIV - NPIVB
        NASSL  = NASS - NPIVB
        APOS   = POSELT + NPIVB*NFRONT + NPIVB
        LPOS2  = APOS + NASSL
        CALL CTRSM('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT,
     *              A(LPOS2),NFRONT)
        LPOS   = LPOS2 + NFRONT*NPIVE
        LPOS1  = APOS + NFRONT*NPIVE
        CALL CGEMM('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2),
     *          NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT)
        RETURN
        END SUBROUTINE CMUMPS_236
       SUBROUTINE CMUMPS_217(N, NZ, NSCA, 
     *      ASPK, IRN, ICN, COLSCA, ROWSCA, S, MAXS, 
     *      ICNTL, INFO)
      INTEGER N, NZ, NSCA, MAXS
      INTEGER IRN(NZ), ICN(NZ)
      INTEGER ICNTL(40), INFO(40)
      COMPLEX    ASPK(NZ)
      REAL COLSCA(*), ROWSCA(*)
      COMPLEX    S(MAXS)
      INTEGER MPG,LP
      INTEGER ISPW1, IWNOR
      INTEGER I, K, ITOT
      LOGICAL PROK
      REAL ONE
      PARAMETER( ONE = 1.0E0 )
      LP      = ICNTL(1)
      MPG     = ICNTL(2)
      MPG    = ICNTL(3)
      PROK   = (MPG.GT.0)
      IF (PROK) WRITE(MPG,101)
 101    FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/)
        IF (NSCA.EQ.1) THEN
         IF (PROK)
     *    WRITE (MPG,*) ' DIAGONAL SCALING '
        ELSEIF (NSCA.EQ.2) THEN
         IF (PROK)
     *   WRITE (MPG,*) ' SCALING BASED ON (MC29)'
        ELSEIF (NSCA.EQ.3) THEN
         IF (PROK)
     *   WRITE (MPG,*) ' COLUMN SCALING'
        ELSEIF (NSCA.EQ.4) THEN
         IF (PROK)
     *   WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)'
        ELSEIF (NSCA.EQ.5) THEN
         IF (PROK)
     *   WRITE (MPG,*) ' MC29 FOLLOWED BY ROW &COL SCALING'
        ELSEIF (NSCA.EQ.6) THEN
         IF (PROK)
     *   WRITE (MPG,*) ' MC29 FOLLOWED BY COLUMN SCALING'
        ENDIF
        DO 10 I=1,N
            COLSCA(I) = ONE
            ROWSCA(I) = ONE
 10     CONTINUE
        IF ((NSCA.EQ.5).OR.
     &      (NSCA.EQ.6))                   THEN
          ITOT = 5*N + NZ 
          IF (ITOT.GT.MAXS) GOTO 400
          ISPW1 = MAXS - NZ + 1
          DO 15 K=1,NZ
           S(ISPW1+K-1) = ASPK(K)
  15      CONTINUE
        ELSE
          ISPW1 = MAXS + 1
          ITOT  = 5*N
          IF (ITOT.GT.MAXS) GOTO 400
        ENDIF
        IWNOR = ISPW1 - 5*N
          IF (NSCA.EQ.1) THEN
            CALL CMUMPS_238(N,NZ,ASPK,IRN,ICN,
     *        COLSCA,ROWSCA,MPG)
          ELSEIF (NSCA.EQ.2) THEN
            CALL CMUMPS_239(N,NZ,ASPK,IRN,ICN,
     *      ROWSCA,COLSCA,S(IWNOR),MPG,MPG,NSCA)
          ELSEIF (NSCA.EQ.3) THEN
            CALL CMUMPS_241(N,NZ,ASPK,IRN,ICN,S(IWNOR),COLSCA,
     *      MPG)
          ELSEIF (NSCA.EQ.4) THEN
            CALL CMUMPS_287(N,NZ,IRN,ICN,ASPK,
     *      S(IWNOR),S(IWNOR+N),COLSCA,ROWSCA,MPG)
          ELSEIF (NSCA.EQ.5) THEN
            CALL CMUMPS_239(N,NZ,S(ISPW1),IRN,ICN,
     *      ROWSCA,COLSCA,S(IWNOR),MPG,MPG,NSCA)
            CALL CMUMPS_241(N,NZ,S(ISPW1),IRN,ICN,S(IWNOR),
     *          COLSCA, MPG)
          ELSEIF (NSCA.EQ.6) THEN
            CALL CMUMPS_239(N,NZ,S(ISPW1),IRN,ICN,
     *      ROWSCA,COLSCA,S(IWNOR),MPG,MPG,NSCA)
            CALL CMUMPS_240(NSCA,N,NZ,IRN,ICN,S(ISPW1),
     *            S(IWNOR+N),ROWSCA,MPG)
            CALL CMUMPS_241(N,NZ,S(ISPW1),IRN,ICN,S(IWNOR),
     *          COLSCA, MPG)
          ENDIF
      GOTO 500
 400  INFO(1) = -5
      INFO(2) = ITOT-MAXS
      IF ((LP.GT.0).AND.(ICNTL(4).GE.1))
     * WRITE(LP,*) '*** ERROR: Not enough space to scale matrix'
 500  RETURN
      END SUBROUTINE CMUMPS_217
      SUBROUTINE CMUMPS_287(N,NZ,IRN,ICN,VAL,
     *    RNOR,CNOR,COLSCA,ROWSCA,MPRINT)
      INTEGER N, NZ
      COMPLEX    VAL(NZ),RNOR(N),CNOR(N)
      REAL    COLSCA(N),ROWSCA(N)
      REAL    CMIN,CMAX,RMIN,ARNOR,ACNOR
      INTEGER IRN(NZ), ICN(NZ)
      REAL    VDIAG
      INTEGER MPRINT
      INTEGER I,J,K
      REAL ZERO, ONE
      PARAMETER(ZERO=0.0E0, ONE=1.0E0)
      DO 50 J=1,N
       CNOR(J)   = cmplx(ZERO)
       RNOR(J)   = cmplx(ZERO)
  50  CONTINUE
      DO 100 K=1,NZ
          I = IRN(K)
          J = ICN(K)
          IF ((I.LE.0).OR.(I.GT.N).OR.
     *        (J.LE.0).OR.(J.GT.N)) GOTO 100
            VDIAG = abs(VAL(K))
            IF (VDIAG.GT.abs(CNOR(J))) THEN
              CNOR(J) =     VDIAG
            ENDIF
            IF (VDIAG.GT.abs(RNOR(I))) THEN
              RNOR(I) =     VDIAG
            ENDIF
 100   CONTINUE
      IF (MPRINT.GT.0) THEN
       CMIN = abs( CNOR(1) )
       CMAX = abs( CNOR(1) )
       RMIN = abs( RNOR(1) )
       DO 111 I=1,N
        ARNOR = abs(RNOR(I))
        ACNOR = abs(CNOR(I))
        IF (ACNOR.GT.CMAX) CMAX=ACNOR
        IF (ACNOR.LT.CMIN) CMIN=ACNOR
        IF (ARNOR.LT.RMIN) RMIN=ARNOR
 111   CONTINUE
       WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING'
       WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX
       WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN
       WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS   :',RMIN
      ENDIF
      DO 120 J=1,N
       IF (abs(CNOR(J)).LE.ZERO) THEN
         CNOR(J)   = cmplx(ONE)
       ELSE
         CNOR(J)   = cmplx(ONE)/CNOR(J)
       ENDIF
 120  CONTINUE
      DO 130 J=1,N
       IF (abs(RNOR(J)).LE.ZERO) THEN
         RNOR(J)   = cmplx(ONE)
       ELSE
         RNOR(J)   = cmplx(ONE)/RNOR(J)
       ENDIF
 130  CONTINUE
       DO 110 I=1,N
        ROWSCA(I) = ROWSCA(I) * real(RNOR(I))
        COLSCA(I) = COLSCA(I) * real(CNOR(I))
 110   CONTINUE
      IF (MPRINT.GT.0)
     *  WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL'
      RETURN
      END SUBROUTINE CMUMPS_287
      SUBROUTINE CMUMPS_239(N,NZ,VAL,ROWIND,COLIND,
     *       RNOR,CNOR,WNOR,MPRINT,MP,
     *       NSCA)
      INTEGER N, NZ
      COMPLEX    VAL(NZ)
      REAL WNOR(5*N)
      REAL RNOR(N),CNOR(N)
      INTEGER COLIND(NZ),ROWIND(NZ)
      INTEGER J,I,K
      INTEGER MPRINT,MP,NSCA
      INTEGER IFAIL9
      REAL ZERO, ONE
      PARAMETER( ZERO = 0.0E0, ONE = 1.0E0 )
      DO 15 I=1,N
       RNOR(I)   = ZERO
       CNOR(I)   = ZERO
  15  CONTINUE
      CALL CMUMPS_216(N,N,NZ,VAL,ROWIND,COLIND,
     *   RNOR,CNOR,WNOR, MP,IFAIL9)
*CVD$ NODEPCHK
*CVD$ VECTOR
*CVD$ CONCUR
      DO 30 I=1,N
       CNOR(I) = exp(CNOR(I))
       RNOR(I) = exp(RNOR(I))
  30  CONTINUE
      IF ((NSCA.EQ.5).OR.(NSCA.EQ.6)) THEN
        DO 100 K=1,NZ
          I   = ROWIND(K)
          J   = COLIND(K)
          IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 100
          VAL(K) = VAL(K) * CNOR(J) * RNOR(I)
 100    CONTINUE
      ENDIF
      IF (MPRINT.GT.0) 
     *   WRITE(MPRINT,*) ' END OF SCALING USING MC29'
      RETURN
      END SUBROUTINE CMUMPS_239
      SUBROUTINE CMUMPS_241(N,NZ,VAL,IRN,ICN,
     *       CNOR,COLSCA,MPRINT)
      INTEGER N,NZ
      COMPLEX VAL(NZ),CNOR(N)
      REAL COLSCA(N)
      INTEGER IRN(NZ), ICN(NZ)
      REAL VDIAG
      INTEGER MPRINT
      INTEGER I,J,K
      REAL ZERO, ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
      DO 10 J=1,N
       CNOR(J)   = cmplx(ZERO)
  10  CONTINUE
      DO 100 K=1,NZ
        I = IRN(K)
        J = ICN(K)
        IF ((I.LE.0).OR.(I.GT.N).OR.
     *      (J.LE.0).OR.(J.GT.N)) GOTO 100
        VDIAG = abs(VAL(K))
        IF (VDIAG.GT.abs(CNOR(J))) THEN
           CNOR(J) =     VDIAG
        ENDIF
 100  CONTINUE
      DO 110 J=1,N
       IF (abs(CNOR(J)).LE.ZERO) THEN
         CNOR(J)   = cmplx(ONE)
       ELSE
         CNOR(J)   = cmplx(ONE)/CNOR(J)
       ENDIF
 110  CONTINUE
       DO 215 I=1,N
        COLSCA(I) = COLSCA(I) * real(CNOR(I))
 215   CONTINUE
      IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING'
      RETURN
      END SUBROUTINE CMUMPS_241
      SUBROUTINE CMUMPS_238(N,NZ,VAL,IRN,ICN,
     *      COLSCA,ROWSCA,MPRINT)
      INTEGER   N, NZ
      COMPLEX  VAL(NZ)
      REAL ROWSCA(N),COLSCA(N)
      INTEGER   IRN(NZ),ICN(NZ)
      REAL      VDIAG
      INTEGER   MPRINT,I,J,K
      INTRINSIC sqrt
      REAL ZERO, ONE
      PARAMETER(ZERO=0.0E0, ONE=1.0E0)
      DO 10 I=1,N
       ROWSCA(I)   = ONE
  10  CONTINUE
      DO 100 K=1,NZ
          I = IRN(K)
          IF ((I.GT.N).OR.(I.LE.0)) GOTO 100
          J = ICN(K)
          IF (I.EQ.J) THEN
            VDIAG = abs(VAL(K))
            IF (VDIAG.GT.ZERO) THEN
              ROWSCA(J) = ONE/(sqrt(VDIAG))
            ENDIF
          ENDIF
 100   CONTINUE
       DO 110 I=1,N
        COLSCA(I) = ROWSCA(I)
 110   CONTINUE
      IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING'
      RETURN
      END SUBROUTINE CMUMPS_238
      SUBROUTINE CMUMPS_240(NSCA,N,NZ,IRN,ICN,VAL,
     *    RNOR,ROWSCA,MPRINT)
      INTEGER N, NZ, NSCA
      INTEGER IRN(NZ), ICN(NZ)
      COMPLEX VAL(NZ),RNOR(N)
      REAL ROWSCA(N)
      REAL VDIAG
      INTEGER MPRINT
      INTEGER I,J,K
      REAL ZERO,ONE
      PARAMETER (ZERO=0.0E0, ONE=1.0E0)
      DO 50 J=1,N
       RNOR(J)   = cmplx(ZERO)
  50  CONTINUE
      DO 100 K=1,NZ
          I = IRN(K)
          J = ICN(K)
          IF ((I.LE.0).OR.(I.GT.N).OR.
     *        (J.LE.0).OR.(J.GT.N)) GOTO 100
            VDIAG = abs(VAL(K))
            IF (VDIAG.GT.abs(RNOR(I))) THEN
              RNOR(I) =  VDIAG
            ENDIF
 100   CONTINUE
      DO 130 J=1,N
       IF (real(RNOR(J)).LE.real(ZERO)) THEN
         RNOR(J)   = cmplx(ONE)
       ELSE
         RNOR(J)   = cmplx(ONE)/RNOR(J)
       ENDIF
 130  CONTINUE
      DO 110 I=1,N
        ROWSCA(I) = ROWSCA(I)* real(RNOR(I))
 110  CONTINUE
      IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN
        DO 150 K=1,NZ
          I   = IRN(K)
          J   = ICN(K)
          IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150
          VAL(K) = VAL(K) * real(RNOR(I))
 150    CONTINUE
      ENDIF
      IF (MPRINT.GT.0)
     *  WRITE(MPRINT,'(A)') '  END OF ROW SCALING'
      RETURN
      END SUBROUTINE CMUMPS_240
      SUBROUTINE CMUMPS_216(M,N,NE,A,IRN,ICN,R,C,W,LP,IFAIL)
      INTEGER M,N,NE
      COMPLEX A(NE)
      INTEGER IRN(NE),ICN(NE)
      REAL    R(M),C(N)
      REAL W(M*2+N*3)
      INTEGER LP,IFAIL
      INTRINSIC LOG,ABS,MIN
      INTEGER MAXIT
      PARAMETER (MAXIT=100)
      COMPLEX ONE
      REAL SMIN,ZERO
      PARAMETER (ONE=1.0E0,SMIN=0.1E0,ZERO=0.0E0)
      INTEGER I,I1,I2,I3,I4,I5,ITER,J,K
      REAL E,E1,EM,Q,Q1,QM,S,S1,SM,U,V
      IFAIL = 0
      IF (M.LT.1 .OR. N.LT.1) THEN
         IFAIL = -1
         GO TO 220
      ELSE IF (NE.LE.0) THEN
         IFAIL = -2
         GO TO 220
      END IF
      I1 = 0
      I2 = M
      I3 = M + N
      I4 = M + N*2
      I5 = M + N*3
      DO 10 I = 1,M
         R(I) = ZERO
         W(I1+I) = ZERO
   10 CONTINUE
      DO 20 J = 1,N
         C(J) = ZERO
         W(I2+J) = ZERO
         W(I3+J) = ZERO
         W(I4+J) = ZERO
   20 CONTINUE
      DO 30 K = 1,NE
         U = abs(A(K))
         IF (U.EQ.ZERO) GO TO 30
         I = IRN(K)
         J = ICN(K)
         IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 30
         U = log(U)
         W(I1+I) = W(I1+I) + ONE
         W(I2+J) = W(I2+J) + ONE
         R(I) = R(I) + U
         W(I3+J) = W(I3+J) + U
   30 CONTINUE
      DO 40 I = 1,M
         IF (W(I1+I).EQ.ZERO) W(I1+I) = ONE
         R(I) = R(I)/W(I1+I)
         W(I5+I) = R(I)
   40 CONTINUE
      DO 50 J = 1,N
         IF (W(I2+J).EQ.ZERO) W(I2+J) = ONE
         W(I3+J) = W(I3+J)/W(I2+J)
   50 CONTINUE
      SM = SMIN*NE
      DO 60 K = 1,NE
         IF (abs(A(K)).EQ.ZERO) GO TO 60
         I = IRN(K)
         J = ICN(K)
         IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 60
         R(I) = R(I) - W(I3+J)/W(I1+I)
   60 CONTINUE
      E = ZERO
      Q = ONE
      S = ZERO
      DO 70 I = 1,M
         S = S + W(I1+I)*R(I)**2
   70 CONTINUE
      IF (abs(S).LE.abs(SM)) GO TO 160
      DO 150 ITER = 1,MAXIT
         DO 80 K = 1,NE
            IF (abs(A(K)).EQ.ZERO) GO TO 80
            J = ICN(K)
            I = IRN(K)
            IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 80
            C(J) = C(J) + R(I)
   80    CONTINUE
         S1 = S
         S = ZERO
         DO 90 J = 1,N
            V = -C(J)/Q
            C(J) = V/W(I2+J)
            S = S + V*C(J)
   90    CONTINUE
         E1 = E
         E = Q*S/S1
         Q = ONE - E
         IF (abs(S).LE.abs(SM)) E = ZERO
         DO 100 I = 1,M
            R(I) = R(I)*E*W(I1+I)
  100    CONTINUE
         IF (abs(S).LE.abs(SM)) GO TO 180
         EM = E*E1
         DO 110 K = 1,NE
            IF (abs(A(K)).EQ.ZERO) GO TO 110
            I = IRN(K)
            J = ICN(K)
            IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 110
            R(I) = R(I) + C(J)
  110    CONTINUE
         S1 = S
         S = ZERO
         DO 120 I = 1,M
            V = -R(I)/Q
            R(I) = V/W(I1+I)
            S = S + V*R(I)
  120    CONTINUE
         E1 = E
         E = Q*S/S1
         Q1 = Q
         Q = ONE - E
         IF (abs(S).LE.abs(SM)) Q = ONE
         QM = Q*Q1
         DO 130 J = 1,N
            W(I4+J) = (EM*W(I4+J)+C(J))/QM
            W(I3+J) = W(I3+J) + W(I4+J)
  130    CONTINUE
         IF (abs(S).LE.abs(SM)) GO TO 160
         DO 140 J = 1,N
            C(J) = C(J)*E*W(I2+J)
  140    CONTINUE
  150 CONTINUE
  160 DO 170 I = 1,M
         R(I) = R(I)*W(I1+I)
  170 CONTINUE
  180 DO 190 K = 1,NE
         IF (abs(A(K)).EQ.ZERO) GO TO 190
         I = IRN(K)
         J = ICN(K)
         IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 190
         R(I) = R(I) + W(I3+J)
  190 CONTINUE
      DO 200 I = 1,M
         R(I) = R(I)/W(I1+I) - W(I5+I)
  200 CONTINUE
      DO 210 J = 1,N
         C(J) = -W(I3+J)
  210 CONTINUE
      RETURN
  220 IF (LP.GT.0) WRITE (LP,'(/A/A,I3)')
     +    ' **** Error return from CMUMPS_216 ****',' IFAIL =',IFAIL
      END SUBROUTINE CMUMPS_216
      SUBROUTINE CMUMPS_27( id,  ANORMINF, LSCAL )
      USE CMUMPS_STRUC_DEF
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER MASTER, IERR
      PARAMETER( MASTER = 0 )
      TYPE(CMUMPS_STRUC), TARGET :: id
      REAL, INTENT(OUT) :: ANORMINF
      LOGICAL :: LSCAL
      INTEGER, DIMENSION (:), POINTER :: KEEP,INFO
      INTEGER*8, DIMENSION (:), POINTER :: KEEP8
      LOGICAL :: I_AM_SLAVE
      COMPLEX DUMMY(1)
      REAL ZERO
      PARAMETER( ZERO = 0.0E0)
      COMPLEX, ALLOCATABLE :: SUMR(:), SUMR_LOC(:)
      INTEGER :: allocok, MTYPE, I
      INFO =>id%INFO
      KEEP =>id%KEEP
      KEEP8 =>id%KEEP8
      I_AM_SLAVE = ( id%MYID .ne. MASTER  .OR.
     *             ( id%MYID .eq. MASTER .AND.
     *               KEEP(46) .eq. 1 ) )
      IF (id%MYID .EQ. MASTER) THEN
       ALLOCATE( SUMR( id%N ), stat =allocok )
       IF (allocok .GT.0 ) THEN
        id%INFO(1)=-13
        id%INFO(2)=id%N
        RETURN
       ENDIF
      ENDIF
      IF ( KEEP(54) .eq. 0 ) THEN
          IF (id%MYID .EQ. MASTER) THEN
            IF (KEEP(55).EQ.0) THEN
             IF (.NOT.LSCAL) THEN
              CALL CMUMPS_207(id%A(1),
     *          id%NZ, id%N,
     *          id%IRN(1), id%JCN(1),
     *          SUMR, KEEP,KEEP8 )
             ELSE
              CALL CMUMPS_289(id%A(1),
     *          id%NZ, id%N,
     *          id%IRN(1), id%JCN(1), 
     *          SUMR, KEEP, KEEP8,
     *          id%COLSCA(1))
             ENDIF
            ELSE
             MTYPE = 1
             IF (.NOT.LSCAL) THEN
              CALL CMUMPS_119(MTYPE, id%N,
     *           id%NELT, id%ELTPTR,
     *           id%LELTVAR, id%ELTVAR,
     *           id%NA_ELT, id%A_ELT(1),
     *           SUMR, KEEP,KEEP8 )
             ELSE
              CALL CMUMPS_135(MTYPE, id%N,
     *           id%NELT, id%ELTPTR(1),
     *           id%LELTVAR, id%ELTVAR(1),
     *           id%NA_ELT, id%A_ELT(1),
     *           SUMR, KEEP,KEEP8, id%COLSCA(1))
             ENDIF
            ENDIF
          ENDIF
      ELSE
          ALLOCATE( SUMR_LOC( id%N ), stat =allocok )
          IF (allocok .GT.0 ) THEN
             id%INFO(1)=-13
             id%INFO(2)=id%N
             RETURN
          ENDIF
          IF ( I_AM_SLAVE .and.
     *           id%NZ_loc .NE. 0 ) THEN
           IF (.NOT.LSCAL) THEN
              CALL CMUMPS_207(id%A_loc,
     *          id%NZ_loc, id%N,
     *          id%IRN_loc, id%JCN_loc, 
     *          SUMR_LOC, id%KEEP,id%KEEP8 )
           ELSE
              CALL CMUMPS_289(id%A_loc,
     *          id%NZ_loc, id%N,
     *          id%IRN_loc, id%JCN_loc, 
     *          SUMR_LOC, id%KEEP,id%KEEP8,
     *          id%COLSCA)
           ENDIF
          ELSE
           SUMR_LOC = cmplx(ZERO)
          ENDIF
          IF ( id%MYID .eq. MASTER ) THEN
              CALL MPI_REDUCE( SUMR_LOC, SUMR,
     *        id%N, MPI_COMPLEX,
     *        MPI_SUM,MASTER,id%COMM, IERR)
          ELSE
              CALL MPI_REDUCE( SUMR_LOC, DUMMY,
     *        id%N, MPI_COMPLEX,
     *        MPI_SUM,MASTER,id%COMM, IERR)
          END IF
        DEALLOCATE (SUMR_LOC)
      ENDIF
      IF ( id%MYID .eq. MASTER ) THEN
       ANORMINF = real(ZERO)
        IF (LSCAL) THEN
         DO I = 1, id%N
          ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), 
     &                  ANORMINF)
         ENDDO
        ELSE
         DO I = 1, id%N
          ANORMINF = max(abs(SUMR(I)), 
     &                  ANORMINF)
         ENDDO
        ENDIF
      ENDIF
      CALL MPI_BCAST(ANORMINF, 1,
     *              MPI_REAL, MASTER,
     *              id%COMM, IERR )
      IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR)
      RETURN
      END SUBROUTINE CMUMPS_27
      SUBROUTINE CMUMPS_693(IRN_loc, JCN_loc, A_loc, NZ_loc,
     &     M, N, NUMPROCS, MYID, COMM,
     &     RPARTVEC, CPARTVEC,
     &     RSNDRCVSZ, CSNDRCVSZ, REGISTRE,
     &     IWRK, IWRKSZ,
     &     INTSZ, RESZ, OP,
     &     ROWSCA, COLSCA, WRKRC, ISZWRKRC,
     &     SYM, NB1, NB2, NB3, EPS,
     &     ONENORMERR,INFNORMERR)
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER NZ_loc, M, N, IWRKSZ, OP
      INTEGER NUMPROCS, MYID, COMM
      INTEGER INTSZ, RESZ
      INTEGER IRN_loc(NZ_loc)
      INTEGER JCN_loc(NZ_loc)
      COMPLEX A_loc(NZ_loc)
      INTEGER RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS)
      INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS)
      INTEGER IWRK(IWRKSZ)
      INTEGER REGISTRE(12)
      REAL ROWSCA(M)
      REAL COLSCA(M)
      INTEGER ISZWRKRC
      REAL WRKRC(ISZWRKRC)
      REAL ONENORMERR,INFNORMERR
      INTEGER IRSNDRCVNUM, ORSNDRCVNUM
      INTEGER IRSNDRCVVOL, ORSNDRCVVOL
      INTEGER ICSNDRCVNUM, OCSNDRCVNUM
      INTEGER ICSNDRCVVOL, OCSNDRCVVOL
      INTEGER  INUMMYR, INUMMYC
      INTEGER IMYRPTR,IMYCPTR 
      INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA
      INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA
      INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA
      INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA
      INTEGER ISTATUS, REQUESTS, TMPWORK
      INTEGER ITDRPTR, ITDCPTR, ISRRPTR
      INTEGER OSRRPTR, ISRCPTR, OSRCPTR
      INTEGER SYM, NB1, NB2, NB3
      REAL EPS
      REAL RONE
      PARAMETER(RONE=1.0E0)
      EXTERNAL CMUMPS_694,CMUMPS_687, 
     &     CMUMPS_670
      INTEGER I
      IF(SYM.EQ.0) THEN
         CALL CMUMPS_694(IRN_loc, JCN_loc, A_loc, NZ_loc,
     &        M, N, NUMPROCS, MYID, COMM,
     &        RPARTVEC, CPARTVEC,
     &        RSNDRCVSZ, CSNDRCVSZ, REGISTRE,
     &        IWRK, IWRKSZ,
     &        INTSZ, RESZ, OP,
     &        ROWSCA, COLSCA, WRKRC, ISZWRKRC,
     &        NB1, NB2, NB3, EPS,
     &        ONENORMERR, INFNORMERR)  
      ELSE
         CALL CMUMPS_687(IRN_loc, JCN_loc, A_loc, NZ_loc,
     &        N, NUMPROCS, MYID, COMM,
     &        RPARTVEC, 
     &        RSNDRCVSZ, REGISTRE,
     &        IWRK, IWRKSZ,
     &        INTSZ, RESZ, OP,
     &        ROWSCA, WRKRC, ISZWRKRC,
     &        NB1, NB2, NB3, EPS,
     &        ONENORMERR, INFNORMERR)  
         DO I=1,N
            COLSCA(I) = ROWSCA(I)
         ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_693
      SUBROUTINE CMUMPS_694(IRN_loc, JCN_loc, A_loc, NZ_loc,
     &     M, N, NUMPROCS, MYID, COMM,
     &     RPARTVEC, CPARTVEC,
     &     RSNDRCVSZ, CSNDRCVSZ, REGISTRE,
     &     IWRK, IWRKSZ,
     &     INTSZ, RESZ, OP,
     &     ROWSCA, COLSCA, WRKRC, ISZWRKRC,
     &     NB1, NB2, NB3, EPS,
     &     ONENORMERR, INFNORMERR)    
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER NZ_loc, M, N, IWRKSZ, OP
      INTEGER NUMPROCS, MYID, COMM
      INTEGER INTSZ, RESZ
      INTEGER IRN_loc(NZ_loc)
      INTEGER JCN_loc(NZ_loc)
      COMPLEX A_loc(NZ_loc)
      INTEGER RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS)
      INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS)
      INTEGER IWRK(IWRKSZ)
      INTEGER REGISTRE(12)
      REAL ROWSCA(M)
      REAL COLSCA(M)
      INTEGER ISZWRKRC
      REAL WRKRC(ISZWRKRC)  
      REAL ONENORMERR,INFNORMERR
      INTEGER IRSNDRCVNUM, ORSNDRCVNUM
      INTEGER IRSNDRCVVOL, ORSNDRCVVOL
      INTEGER ICSNDRCVNUM, OCSNDRCVNUM
      INTEGER ICSNDRCVVOL, OCSNDRCVVOL
      INTEGER  INUMMYR, INUMMYC
      INTEGER IMYRPTR,IMYCPTR 
      INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA
      INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA
      INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA
      INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA
      INTEGER ISTATUS, REQUESTS, TMPWORK
      INTEGER ITDRPTR, ITDCPTR, ISRRPTR
      INTEGER OSRRPTR, ISRCPTR, OSRCPTR
      INTEGER NB1, NB2, NB3
      REAL EPS
      INTEGER ITER, NZIND, IR, IC, NUMCNVRG
      REAL ELM
      INTEGER TAG_COMM_COL
      PARAMETER(TAG_COMM_COL=100)
      INTEGER TAG_COMM_ROW
      PARAMETER(TAG_COMM_ROW=101)
      INTEGER TAG_ITERS
      PARAMETER(TAG_ITERS=102)
      EXTERNAL CMUMPS_654,
     &     CMUMPS_672, 
     &     CMUMPS_674,
     &     CMUMPS_662, 
     &     CMUMPS_CHKCONVGLO,
     &     CMUMPS_CHK1CONV,
     &     CMUMPS_660,
     &     CMUMPS_670,
     &     CMUMPS_671,
     &     CMUMPS_657,
     &     CMUMPS_656
      INTEGER CMUMPS_CHKCONVGLO 
      INTEGER CMUMPS_CHK1CONV
      REAL CMUMPS_ERRSCALOC
      REAL CMUMPS_ERRSCA1
      INTRINSIC abs
      REAL RONE, RZERO
      PARAMETER(RONE=1.0E0,RZERO=0.0E0)
      INTEGER RESZR, RESZC
      INTEGER INTSZR, INTSZC
      INTEGER MAXMN
      INTEGER I, IERROR
      REAL ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG
      REAL INFERRROW, INFERRCOL, INFERRL, INFERRG
      INFERRG = -RONE
      ONEERRG = -RONE
      MAXMN = M
      IF(MAXMN < N) MAXMN = N
      IF(OP == 1) THEN
         IF(NUMPROCS > 1) THEN
            CALL CMUMPS_654(MYID, NUMPROCS, COMM,
     &           IRN_loc, JCN_loc, NZ_loc,
     &           RPARTVEC, M,
     &           IWRK, IWRKSZ)
            CALL CMUMPS_654(MYID, NUMPROCS, COMM,
     &           JCN_loc, IRN_loc,  NZ_loc,
     &           CPARTVEC, N,
     &           IWRK, IWRKSZ)         
            CALL CMUMPS_672(MYID, NUMPROCS, M, RPARTVEC,
     &           NZ_loc, IRN_loc,IRSNDRCVNUM,IRSNDRCVVOL,
     &           ORSNDRCVNUM,ORSNDRCVVOL,
     &           IWRK,IWRKSZ, 
     &           RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM)
            CALL CMUMPS_672(MYID, NUMPROCS, N, CPARTVEC,
     &           NZ_loc, JCN_loc,ICSNDRCVNUM,ICSNDRCVVOL,
     &           OCSNDRCVNUM,OCSNDRCVVOL,
     &           IWRK,IWRKSZ, 
     &           CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM)         
            CALL CMUMPS_662(MYID, NUMPROCS, COMM,
     &           IRN_loc, JCN_loc, NZ_loc,
     &           RPARTVEC, CPARTVEC, M, N,
     &           INUMMYR,
     &           INUMMYC,     
     &           IWRK, IWRKSZ)
            INTSZR =  IRSNDRCVNUM + ORSNDRCVNUM + 
     &           IRSNDRCVVOL + ORSNDRCVVOL +
     &           2*(NUMPROCS+1) + INUMMYR
            INTSZC = ICSNDRCVNUM + OCSNDRCVNUM + 
     &           ICSNDRCVVOL + OCSNDRCVVOL +
     &           2*(NUMPROCS+1) + INUMMYC
            INTSZ = INTSZR + INTSZC + MAXMN + 
     &           (MPI_STATUS_SIZE +1) *  NUMPROCS
         ELSE
             IRSNDRCVNUM = 0
             ORSNDRCVNUM = 0
             IRSNDRCVVOL = 0 
             ORSNDRCVVOL = 0
             INUMMYR = 0
             ICSNDRCVNUM  = 0 
             OCSNDRCVNUM  = 0
             ICSNDRCVVOL = 0  
             OCSNDRCVVOL  = 0
             INUMMYC = 0
             INTSZ = 0
          ENDIF
          RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL
          RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL
          RESZ = RESZR  + RESZC  
          REGISTRE(1) = IRSNDRCVNUM 
          REGISTRE(2) = ORSNDRCVNUM
          REGISTRE(3) = IRSNDRCVVOL 
          REGISTRE(4) = ORSNDRCVVOL
          REGISTRE(5) = ICSNDRCVNUM 
          REGISTRE(6) = OCSNDRCVNUM
          REGISTRE(7) = ICSNDRCVVOL
          REGISTRE(8) = OCSNDRCVVOL
          REGISTRE(9) = INUMMYR
          REGISTRE(10) = INUMMYC
          REGISTRE(11) = INTSZ
          REGISTRE(12) = RESZ
       ELSE
          IRSNDRCVNUM = REGISTRE(1) 
          ORSNDRCVNUM = REGISTRE(2) 
          IRSNDRCVVOL = REGISTRE(3)
          ORSNDRCVVOL = REGISTRE(4) 
          ICSNDRCVNUM = REGISTRE(5) 
          OCSNDRCVNUM = REGISTRE(6) 
          ICSNDRCVVOL = REGISTRE(7) 
          OCSNDRCVVOL = REGISTRE(8) 
          INUMMYR = REGISTRE(9) 
          INUMMYC = REGISTRE(10)
          IF(NUMPROCS > 1) THEN
             CALL CMUMPS_660(MYID, NUMPROCS,COMM,    
     &            IRN_loc, JCN_loc, NZ_loc,
     &            RPARTVEC, CPARTVEC, M, N,
     &            IWRK(1), INUMMYR,
     &            IWRK(1+INUMMYR), INUMMYC,     
     &            IWRK(1+INUMMYR+INUMMYC), IWRKSZ-INUMMYR-INUMMYC )
             IMYRPTR = 1
             IMYCPTR = IMYRPTR + INUMMYR
             IRNGHBPRCS = IMYCPTR+ INUMMYC
             IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM
             IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1
             ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL
             ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM
             ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1
             ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL
             ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM
             ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1
             OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL
             OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM
             OCSNDRCVJA = OCSNDRCVIA +  NUMPROCS + 1
             REQUESTS = OCSNDRCVJA + OCSNDRCVVOL
             ISTATUS = REQUESTS + NUMPROCS
             TMPWORK = ISTATUS + MPI_STATUS_SIZE *  NUMPROCS
             CALL CMUMPS_674(MYID, NUMPROCS, M, RPARTVEC,
     &            NZ_loc, IRN_loc,
     &            IRSNDRCVNUM, IRSNDRCVVOL, 
     &            IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA),
     &            ORSNDRCVNUM, ORSNDRCVVOL, 
     &            IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA),
     &            RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS),
     &            IWRK(TMPWORK), 
     &            IWRK(ISTATUS), IWRK(REQUESTS),
     &            TAG_COMM_ROW, COMM)
             CALL CMUMPS_674(MYID, NUMPROCS, N, CPARTVEC,
     &            NZ_loc, JCN_loc,
     &            ICSNDRCVNUM, ICSNDRCVVOL, 
     &            IWRK(ICNGHBPRCS),
     &            IWRK(ICSNDRCVIA),
     &            IWRK(ICSNDRCVJA),
     &            OCSNDRCVNUM, OCSNDRCVVOL, 
     &            IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA),
     &            CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS),
     &            IWRK(TMPWORK), 
     &            IWRK(ISTATUS),  IWRK(REQUESTS),
     &            TAG_COMM_COL, COMM)
             CALL CMUMPS_670(ROWSCA, M, RZERO)
             CALL CMUMPS_670(COLSCA, N, RZERO)
             CALL CMUMPS_671(ROWSCA, M, 
     &            IWRK(IMYRPTR),INUMMYR, RONE)
             CALL CMUMPS_671(COLSCA, N, 
     &            IWRK(IMYCPTR),INUMMYC, RONE)   
          ELSE
             CALL CMUMPS_670(ROWSCA, M, RONE)
             CALL CMUMPS_670(COLSCA, N, RONE)            
          ENDIF
          ITDRPTR = 1
          ITDCPTR = ITDRPTR + M
          ISRRPTR = ITDCPTR + N
          OSRRPTR = ISRRPTR + IRSNDRCVVOL
          ISRCPTR = OSRRPTR + ORSNDRCVVOL
          OSRCPTR = ISRCPTR + ICSNDRCVVOL
          IF(NUMPROCS == 1)THEN
             OSRCPTR = OSRCPTR - 1
             ISRCPTR = ISRCPTR - 1
             OSRRPTR = OSRRPTR - 1
             ISRRPTR = ISRRPTR - 1
          ELSE
             IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1
             IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1
             IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1
             IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1
          ENDIF
          DO ITER=1,NB1+NB2+NB3
             IF(NUMPROCS > 1) THEN
                CALL CMUMPS_650(WRKRC(ITDRPTR),M,
     &               IWRK(IMYRPTR),INUMMYR)
                CALL CMUMPS_650(WRKRC(ITDCPTR),N,
     &               IWRK(IMYCPTR),INUMMYC)
             ELSE
                CALL CMUMPS_670(WRKRC(ITDRPTR),M, RZERO)
                CALL CMUMPS_670(WRKRC(ITDCPTR),N, RZERO)
             ENDIF
             IF(ITER.LE.NB1) THEN
                DO NZIND=1,NZ_loc
                   IR = IRN_loc(NZIND)
                   IC = JCN_loc(NZIND)
                   IF((IR.GE.1).AND.(IR.LE.M).AND.
     &                  (IC.GE.1).AND.(IC.LE.N)) THEN
                      ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC)
                      IF(WRKRC(ITDRPTR-1+IR)<ELM) THEN
                         WRKRC(ITDRPTR-1+IR)= ELM
                      ENDIF
                      IF(WRKRC(ITDCPTR-1+IC)<ELM) THEN
                         WRKRC(ITDCPTR-1+IC)= ELM
                      ENDIF
                   ENDIF
                ENDDO
                IF(NUMPROCS > 1) THEN
                   CALL CMUMPS_657(MYID, NUMPROCS,
     &                  WRKRC(ITDCPTR), N, TAG_ITERS+ITER, 
     &                  ICSNDRCVNUM,IWRK(ICNGHBPRCS),
     &                  ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), 
     &                  WRKRC(ISRCPTR),
     &                  OCSNDRCVNUM,IWRK(OCNGHBPRCS),
     &                  OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA),
     &                  WRKRC( OSRCPTR),
     &                  IWRK(ISTATUS),IWRK(REQUESTS),
     &                  COMM)
                  CALL CMUMPS_657(MYID, NUMPROCS,
     &                  WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, 
     &                  IRSNDRCVNUM,IWRK(IRNGHBPRCS),
     &                  IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 
     &                  WRKRC(ISRRPTR),
     &                  ORSNDRCVNUM,IWRK(ORNGHBPRCS),
     &                  ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA),
     &                  WRKRC( OSRRPTR),
     &                  IWRK(ISTATUS),IWRK(REQUESTS),
     &                  COMM)
               ENDIF
            ELSEIF(ITER.LE.NB1+NB2) THEN
               DO NZIND=1,NZ_loc
                  IR = IRN_loc(NZIND)
                  IC = JCN_loc(NZIND)
                  IF((IR.GE.1).AND.(IR.LE.M).AND.
     &                 (IC.GE.1).AND.(IC.LE.N)) THEN
                     ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC)
                     WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM
                     WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM
                  ENDIF
               ENDDO
               IF(NUMPROCS > 1) THEN
                  CALL CMUMPS_656(MYID, NUMPROCS,
     &                 WRKRC(ITDCPTR), N, TAG_ITERS+ITER, 
     &                 ICSNDRCVNUM, IWRK(ICNGHBPRCS),
     &                 ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), 
     &                 WRKRC(ISRCPTR),
     &                 OCSNDRCVNUM, IWRK(OCNGHBPRCS),
     &                 OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA),
     &                 WRKRC( OSRCPTR),
     &                 IWRK(ISTATUS), IWRK(REQUESTS),
     &                 COMM)
                  CALL CMUMPS_656(MYID, NUMPROCS,
     &                 WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, 
     &                 IRSNDRCVNUM, IWRK(IRNGHBPRCS),
     &                 IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 
     &                 WRKRC(ISRRPTR),
     &                 ORSNDRCVNUM, IWRK(ORNGHBPRCS),
     &                 ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA),
     &                 WRKRC( OSRRPTR),
     &                 IWRK(ISTATUS), IWRK(REQUESTS),
     &                 COMM)
               ENDIF
            ELSE
               DO NZIND=1,NZ_loc
                  IR = IRN_loc(NZIND)
                  IC = JCN_loc(NZIND)
                  IF((IR.GE.1).AND.(IR.LE.M).AND.
     &                 (IC.GE.1).AND.(IC.LE.N)) THEN
                     ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC)
                     IF(WRKRC(ITDRPTR-1+IR) < ELM) THEN
                        WRKRC(ITDRPTR-1+IR)= ELM
                     ENDIF
                     IF(WRKRC(ITDCPTR-1+IC) < ELM) THEN
                        WRKRC(ITDCPTR-1+IC)= ELM
                     ENDIF
                  ENDIF
               ENDDO
               IF(NUMPROCS > 1) THEN
                  CALL CMUMPS_657(MYID, NUMPROCS,
     &                 WRKRC(ITDCPTR), N, TAG_ITERS+ITER, 
     &                 ICSNDRCVNUM, IWRK(ICNGHBPRCS),
     &                 ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), 
     &                 WRKRC(ISRCPTR),
     &                 OCSNDRCVNUM, IWRK(OCNGHBPRCS),
     &                 OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA),
     &                 WRKRC( OSRCPTR),
     &                 IWRK(ISTATUS), IWRK(REQUESTS),
     &                 COMM)
                  CALL CMUMPS_657(MYID, NUMPROCS,
     &                 WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, 
     &                 IRSNDRCVNUM, IWRK(IRNGHBPRCS),
     &                 IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 
     &                 WRKRC(ISRRPTR),
     &                 ORSNDRCVNUM, IWRK(ORNGHBPRCS),
     &                 ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA),
     &                 WRKRC( OSRRPTR),
     &                 IWRK(ISTATUS), IWRK(REQUESTS),
     &                 COMM)                 
               ENDIF
            ENDIF
            IF(NUMPROCS > 1) THEN
               CALL CMUMPS_665(COLSCA,  WRKRC(ITDCPTR), N,
     &              IWRK(IMYCPTR),INUMMYC)
               CALL CMUMPS_665(ROWSCA,  WRKRC(ITDRPTR), M,
     &              IWRK(IMYRPTR),INUMMYR)
               IF((NB1 > 0.AND.ITER==NB1).OR.
     &              (NB3 > 0.AND.ITER == NB1+NB2+NB3)) THEN
                  INFERRROW = CMUMPS_ERRSCALOC(ROWSCA, 
     &                 WRKRC(ITDRPTR), M,
     &                 IWRK(IMYRPTR),INUMMYR)
                  INFERRCOL = CMUMPS_ERRSCALOC(COLSCA,  
     &                 WRKRC(ITDCPTR), N,
     &                 IWRK(IMYCPTR),INUMMYC)
                  IF(INFERRROW > INFERRCOL) THEN
                     INFERRL = INFERRROW
                  ELSE
                     INFERRL = INFERRCOL
                  ENDIF
                  CALL MPI_ALLREDUCE(INFERRL, INFERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)                  
               ENDIF
               IF(NB2 > 0.AND.ITER == NB1+NB2) THEN
                  ONEERRROW = CMUMPS_ERRSCALOC(ROWSCA, 
     &                 WRKRC(ITDRPTR), M,
     &                 IWRK(IMYRPTR),INUMMYR)
                  ONEERRCOL = CMUMPS_ERRSCALOC(COLSCA,  
     &                 WRKRC(ITDCPTR), N,
     &                 IWRK(IMYCPTR),INUMMYC)
                  IF(ONEERRROW > ONEERRCOL) THEN
                     ONEERRL = ONEERRROW
                  ELSE
                     ONEERRL = ONEERRCOL
                  ENDIF
                  CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)
               ENDIF
               IF(EPS .GT. RZERO) THEN
                  NUMCNVRG = CMUMPS_CHKCONVGLO(WRKRC(ITDRPTR), M, 
     &                 IWRK(IMYRPTR),INUMMYR,
     &                 WRKRC(ITDCPTR), N, 
     &                 IWRK(IMYCPTR),INUMMYC,
     &                 EPS, COMM)
               ENDIF
            ELSE
               CALL CMUMPS_666(COLSCA,  WRKRC(ITDCPTR), N)
               CALL CMUMPS_666(ROWSCA,  WRKRC(ITDRPTR), M)
               IF((NB1 > 0.AND.ITER==NB1).OR.
     &              (NB3 > 0.AND.ITER == NB1+NB2+NB3)) THEN
                  INFERRROW = CMUMPS_ERRSCA1(ROWSCA, 
     &                 WRKRC(ITDRPTR), M)
                  INFERRCOL = CMUMPS_ERRSCA1(COLSCA,  
     &                 WRKRC(ITDCPTR), N)
                  IF(INFERRROW > INFERRCOL) THEN
                     INFERRL = INFERRROW
                  ELSE
                     INFERRL = INFERRCOL
                  ENDIF
                  CALL MPI_ALLREDUCE(INFERRL, INFERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)                  
               ENDIF
               IF(NB2 > 0.AND.ITER == NB1+NB2) THEN
                  ONEERRROW = CMUMPS_ERRSCA1(ROWSCA, 
     &                 WRKRC(ITDRPTR), M)
                  ONEERRCOL = CMUMPS_ERRSCA1(COLSCA,  
     &                 WRKRC(ITDCPTR), N)                  
                  IF(ONEERRROW > ONEERRCOL) THEN
                     ONEERRL = ONEERRROW
                  ELSE
                     ONEERRL = ONEERRCOL
                  ENDIF
                  CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)
               ENDIF
               IF(EPS .GT. RZERO) THEN
                  NUMCNVRG =  CMUMPS_CHK1CONV(WRKRC(ITDCPTR),N,EPS) +
     &                 CMUMPS_CHK1CONV(WRKRC(ITDRPTR),M,EPS)
               ENDIF
            ENDIF               
            IF(EPS .GT. RZERO) THEN
               IF(NUMCNVRG == 2 * NUMPROCS) EXIT
            ENDIF
         ENDDO
         ONENORMERR = ONEERRG 
         INFNORMERR = INFERRG 
         IF(NUMPROCS > 1) THEN
            CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_REAL,
     &           MPI_MAX, 0, 
     &           COMM, IERROR)
            IF(MYID.EQ.0) THEN
               DO I=1, M
                  ROWSCA(I) = WRKRC(I)
               ENDDO
            ENDIF
            CALL MPI_REDUCE(COLSCA, WRKRC(1+M), N, MPI_REAL,
     &           MPI_MAX, 0, 
     &           COMM, IERROR)
            If(MYID.EQ.0) THEN
               DO I=1, N
                  COLSCA(I) = WRKRC(I+M)
               ENDDO
            ENDIF         
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_694
      SUBROUTINE CMUMPS_687(IRN_loc, JCN_loc, A_loc, NZ_loc,
     &     N, NUMPROCS, MYID, COMM,
     &     PARTVEC, 
     &     RSNDRCVSZ, 
     &     REGISTRE,
     &     IWRK, IWRKSZ,
     &     INTSZ, RESZ, OP,
     &     SCA, WRKRC, ISZWRKRC,
     &     NB1, NB2, NB3, EPS,
     &     ONENORMERR, INFNORMERR)    
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER NZ_loc, N, IWRKSZ, OP
      INTEGER NUMPROCS, MYID, COMM
      INTEGER INTSZ, RESZ
      INTEGER IRN_loc(NZ_loc)
      INTEGER JCN_loc(NZ_loc)
      COMPLEX A_loc(NZ_loc)
      INTEGER PARTVEC(N), RSNDRCVSZ(2*NUMPROCS)
      INTEGER IWRK(IWRKSZ)
      INTEGER REGISTRE(12)
      REAL SCA(N)
      INTEGER ISZWRKRC
      REAL WRKRC(ISZWRKRC)
      INTEGER IRSNDRCVNUM, ORSNDRCVNUM
      INTEGER IRSNDRCVVOL, ORSNDRCVVOL
      INTEGER  INUMMYR
      INTEGER IMYRPTR,IMYCPTR 
      INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA
      INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA
      INTEGER ISTATUS, REQUESTS, TMPWORK
      INTEGER ITDRPTR, ISRRPTR, OSRRPTR
      REAL ONENORMERR,INFNORMERR
      INTEGER NB1, NB2, NB3
      REAL EPS
      INTEGER ITER, NZIND, IR, IC, NUMCNVRG
      REAL ELM
      INTEGER TAG_COMM_COL
      PARAMETER(TAG_COMM_COL=100)
      INTEGER TAG_COMM_ROW
      PARAMETER(TAG_COMM_ROW=101)
      INTEGER TAG_ITERS
      PARAMETER(TAG_ITERS=102)
      EXTERNAL CMUMPS_655,
     &     CMUMPS_673, 
     &     CMUMPS_692,
     &     CMUMPS_663, 
     &     CMUMPS_CHKCONVGLOSYM,
     &     CMUMPS_CHK1CONV,
     &     CMUMPS_661,
     &     CMUMPS_657,
     &     CMUMPS_656,
     &     CMUMPS_670,
     &     CMUMPS_671
      INTEGER CMUMPS_CHKCONVGLOSYM 
      INTEGER CMUMPS_CHK1CONV
      REAL CMUMPS_ERRSCALOC
      REAL CMUMPS_ERRSCA1
      INTRINSIC abs
      REAL RONE, RZERO
      PARAMETER(RONE=1.0E0,RZERO=0.0E0)
      INTEGER RESZR, RESZC
      INTEGER INTSZR, INTSZC
      INTEGER MAXMN
      INTEGER I, IERROR
      REAL ONEERRL, ONEERRG
      REAL INFERRL, INFERRG
      INFERRG = -RONE
      ONEERRG = -RONE
      MAXMN = N
      IF(OP == 1) THEN
         IF(NUMPROCS > 1) THEN
            CALL CMUMPS_655(MYID, NUMPROCS, COMM,
     &           IRN_loc, JCN_loc, NZ_loc,
     &           PARTVEC, N,
     &           IWRK, IWRKSZ)
            CALL CMUMPS_673(MYID, NUMPROCS, N, PARTVEC,
     &           NZ_loc, IRN_loc,JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL,
     &           ORSNDRCVNUM, ORSNDRCVVOL,
     &           IWRK,IWRKSZ, 
     &           RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM)
            CALL CMUMPS_663(MYID, NUMPROCS, COMM,
     &           IRN_loc, JCN_loc, NZ_loc,
     &           PARTVEC, N,
     &           INUMMYR,
     &           IWRK, IWRKSZ)
            INTSZR =  IRSNDRCVNUM + ORSNDRCVNUM + 
     &           IRSNDRCVVOL + ORSNDRCVVOL +
     &           2*(NUMPROCS+1) + INUMMYR
            INTSZ = INTSZR + N + 
     &           (MPI_STATUS_SIZE +1) *  NUMPROCS
         ELSE
            IRSNDRCVNUM = 0
            ORSNDRCVNUM = 0
            IRSNDRCVVOL = 0 
            ORSNDRCVVOL = 0
            INUMMYR = 0
            INTSZ = 0
         ENDIF
         RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL
         REGISTRE(1) = IRSNDRCVNUM 
         REGISTRE(2) = ORSNDRCVNUM
         REGISTRE(3) = IRSNDRCVVOL 
         REGISTRE(4) = ORSNDRCVVOL
         REGISTRE(9) = INUMMYR
         REGISTRE(11) = INTSZ
         REGISTRE(12) = RESZ
      ELSE
         IRSNDRCVNUM = REGISTRE(1) 
         ORSNDRCVNUM = REGISTRE(2) 
         IRSNDRCVVOL = REGISTRE(3)
         ORSNDRCVVOL = REGISTRE(4) 
         INUMMYR = REGISTRE(9) 
          IF(NUMPROCS > 1) THEN
             CALL CMUMPS_661(MYID, NUMPROCS,COMM,    
     &            IRN_loc, JCN_loc, NZ_loc,
     &            PARTVEC, N,
     &            IWRK(1), INUMMYR,
     &            IWRK(1+INUMMYR), IWRKSZ-INUMMYR)
             IMYRPTR = 1
             IMYCPTR = IMYRPTR + INUMMYR
             IRNGHBPRCS = IMYCPTR 
             IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM
             IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1
             ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL
             ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM
             ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1
             REQUESTS = ORSNDRCVJA + ORSNDRCVVOL 
             ISTATUS = REQUESTS + NUMPROCS
             TMPWORK = ISTATUS + MPI_STATUS_SIZE *  NUMPROCS
             CALL CMUMPS_692(MYID, NUMPROCS, N, PARTVEC,
     &            NZ_loc, IRN_loc, JCN_loc,
     &            IRSNDRCVNUM, IRSNDRCVVOL, 
     &            IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA),
     &            ORSNDRCVNUM, ORSNDRCVVOL, 
     &            IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA),
     &            RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS),
     &            IWRK(TMPWORK), 
     &            IWRK(ISTATUS), IWRK(REQUESTS),
     &            TAG_COMM_ROW, COMM)
             CALL CMUMPS_670(SCA, N, RZERO)
             CALL CMUMPS_671(SCA, N, 
     &            IWRK(IMYRPTR),INUMMYR, RONE)
          ELSE
             CALL CMUMPS_670(SCA, N, RONE)
          ENDIF
          ITDRPTR = 1
          ISRRPTR = ITDRPTR + N
          OSRRPTR = ISRRPTR + IRSNDRCVVOL
          IF(NUMPROCS == 1)THEN
             OSRRPTR = OSRRPTR - 1
             ISRRPTR = ISRRPTR - 1
          ELSE
             IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1
             IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1
          ENDIF
          DO ITER=1,NB1+NB2+NB3
             IF(NUMPROCS > 1) THEN
                CALL CMUMPS_650(WRKRC(ITDRPTR),N,
     &               IWRK(IMYRPTR),INUMMYR)
             ELSE
                CALL CMUMPS_670(WRKRC(ITDRPTR),N, RZERO)
             ENDIF
             IF(ITER.LE.NB1) THEN
                DO NZIND=1,NZ_loc
                   IR = IRN_loc(NZIND)
                   IC = JCN_loc(NZIND)
                   IF((IR.GE.1).AND.(IR.LE.N).AND.
     &                  (IC.GE.1).AND.(IC.LE.N)) THEN
                      ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC)
                      IF(WRKRC(ITDRPTR-1+IR)<ELM) THEN
                         WRKRC(ITDRPTR-1+IR)= ELM
                      ENDIF
                      IF(WRKRC(ITDRPTR-1+IC)<ELM) THEN
                         WRKRC(ITDRPTR-1+IC)= ELM
                      ENDIF
                   ENDIF
                ENDDO
                IF(NUMPROCS > 1) THEN
                  CALL CMUMPS_657(MYID, NUMPROCS,
     &                  WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, 
     &                  IRSNDRCVNUM,IWRK(IRNGHBPRCS),
     &                  IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 
     &                  WRKRC(ISRRPTR),
     &                  ORSNDRCVNUM,IWRK(ORNGHBPRCS),
     &                  ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA),
     &                  WRKRC( OSRRPTR),
     &                  IWRK(ISTATUS),IWRK(REQUESTS),
     &                  COMM)
               ENDIF
            ELSEIF(ITER.LE.NB1+NB2) THEN
               DO NZIND=1,NZ_loc
                  IR = IRN_loc(NZIND)
                  IC = JCN_loc(NZIND)
                  IF((IR.GE.1).AND.(IR.LE.N).AND.
     &                 (IC.GE.1).AND.(IC.LE.N)) THEN
                     ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC)
                     WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM
                     WRKRC(ITDRPTR-1+IC) = WRKRC(ITDRPTR-1+IC) + ELM
                  ENDIF
               ENDDO
               IF(NUMPROCS > 1) THEN
                  CALL CMUMPS_656(MYID, NUMPROCS,
     &                 WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, 
     &                 IRSNDRCVNUM, IWRK(IRNGHBPRCS),
     &                 IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 
     &                 WRKRC(ISRRPTR),
     &                 ORSNDRCVNUM, IWRK(ORNGHBPRCS),
     &                 ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA),
     &                 WRKRC( OSRRPTR),
     &                 IWRK(ISTATUS), IWRK(REQUESTS),
     &                 COMM)
               ENDIF
            ELSE
               DO NZIND=1,NZ_loc
                  IR = IRN_loc(NZIND)
                  IC = JCN_loc(NZIND)
                  IF((IR.GE.1).AND.(IR.LE.N).AND.
     &                 (IC.GE.1).AND.(IC.LE.N)) THEN
                     ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC)
                     IF(WRKRC(ITDRPTR-1+IR) < ELM) THEN
                        WRKRC(ITDRPTR-1+IR)= ELM
                     ENDIF
                     IF(WRKRC(ITDRPTR-1+IC) < ELM) THEN
                        WRKRC(ITDRPTR-1+IC)= ELM
                     ENDIF
                  ENDIF
               ENDDO
               IF(NUMPROCS > 1) THEN
                  CALL CMUMPS_657(MYID, NUMPROCS,
     &                 WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, 
     &                 IRSNDRCVNUM, IWRK(IRNGHBPRCS),
     &                 IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), 
     &                 WRKRC(ISRRPTR),
     &                 ORSNDRCVNUM, IWRK(ORNGHBPRCS),
     &                 ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA),
     &                 WRKRC( OSRRPTR),
     &                 IWRK(ISTATUS), IWRK(REQUESTS),
     &                 COMM)
               ENDIF
            ENDIF
            IF(NUMPROCS > 1) THEN
               CALL CMUMPS_665(SCA,  WRKRC(ITDRPTR), N,
     &              IWRK(IMYRPTR),INUMMYR)
               IF((NB1 > 0.AND.ITER==NB1).OR.
     &              (NB3 > 0.AND.ITER == NB1+NB2+NB3)) THEN
                  INFERRL = CMUMPS_ERRSCALOC(SCA,  
     &                 WRKRC(ITDRPTR), N,
     &                 IWRK(IMYRPTR),INUMMYR)                  
                  CALL MPI_ALLREDUCE(INFERRL, INFERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)                  
               ENDIF
               IF(NB2 > 0.AND.ITER == NB1+NB2) THEN
                  ONEERRL = CMUMPS_ERRSCALOC(SCA,  
     &                 WRKRC(ITDRPTR), N,
     &                 IWRK(IMYRPTR),INUMMYR) 
                  CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)
               ENDIF
               IF(EPS .GT. RZERO) THEN
                  NUMCNVRG = CMUMPS_CHKCONVGLOSYM(WRKRC(ITDRPTR), N, 
     &                 IWRK(IMYRPTR),INUMMYR,
     &                 EPS, COMM)
               ENDIF
            ELSE
               CALL CMUMPS_666(SCA,  WRKRC(ITDRPTR), N)
               IF((NB1 > 0.AND.ITER==NB1).OR.
     &              (NB3 > 0.AND.ITER == NB1+NB2+NB3)) THEN
                  INFERRL = CMUMPS_ERRSCA1(SCA, 
     &                 WRKRC(ITDRPTR), N)
                  CALL MPI_ALLREDUCE(INFERRL, INFERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)                  
               ENDIF
               IF(NB2 > 0.AND.ITER == NB1+NB2) THEN
                  ONEERRL = CMUMPS_ERRSCA1(SCA, 
     &                 WRKRC(ITDRPTR), N)
                  CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, 
     &                 1, MPI_REAL,
     &                 MPI_MAX, COMM, IERROR)
               ENDIF
               IF(EPS .GT. RZERO) THEN
                  NUMCNVRG = 2*CMUMPS_CHK1CONV(WRKRC(ITDRPTR),N,EPS)
               ENDIF
            ENDIF               
            IF(EPS .GT. RZERO) THEN
               IF(NUMCNVRG == 2 * NUMPROCS) EXIT
            ENDIF
         ENDDO
         ONENORMERR = ONEERRG 
         INFNORMERR = INFERRG 
         IF(NUMPROCS > 1) THEN
            CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_REAL,
     &           MPI_MAX, 0, 
     &           COMM, IERROR)
            IF(MYID.EQ.0) THEN
               DO I=1, N
                  SCA(I) = WRKRC(I)
               ENDDO
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_687
      SUBROUTINE CMUMPS_654(MYID, NUMPROCS, COMM,
     & IRN_loc, JCN_loc, NZ_loc,
     & IPARTVEC, ISZ,
     & IWRK, IWSZ)
      IMPLICIT NONE
      EXTERNAL CMUMPS_703
      INTEGER MYID, NUMPROCS, COMM
      INTEGER NZ_loc, ISZ, IWSZ
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER IPARTVEC(ISZ)
      INTEGER IWRK(IWSZ)
      INCLUDE 'mpif.h'
      INTEGER I
      INTEGER OP, IERROR
      INTEGER IDIST, IR, IC
      IF(NUMPROCS.NE.1) THEN
         CALL MPI_OP_CREATE(CMUMPS_703, .TRUE., OP, IERROR)
         CALL CMUMPS_668(IWRK, 4*ISZ, ISZ)
         DO I=1,NZ_loc
            IR = IRN_loc(I)
            IC = JCN_loc(I)
            IF((IR.GE.1).AND.(IR.LE.ISZ)) THEN
               IDIST = IR-IC
               IF(IDIST < 0) IDIST = -IDIST 
               IF(IDIST < IWRK(2*IR-1)) THEN
                  IWRK(2*IR-1) = IDIST
                  IWRK(2*IR) = MYID
               ENDIF
            ENDIF
         ENDDO
         CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ,
     &        MPI_2INTEGER, OP, COMM, IERROR)      
         DO I=1,ISZ
            IPARTVEC(I) = IWRK(2*i+2*ISZ)
         ENDDO
         CALL MPI_OP_FREE(OP, IERROR)
      ELSE
         DO I=1,ISZ
            IPARTVEC(I) = 0
         ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_654
      SUBROUTINE CMUMPS_662(MYID, NUMPROCS, COMM,
     &     IRN_loc, JCN_loc, NZ_loc,
     &     ROWPARTVEC, COLPARTVEC, M, N,
     &     INUMMYR,
     &     INUMMYC,     
     &     IWRK, IWSZ)
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, M, N
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER ROWPARTVEC(M)
      INTEGER COLPARTVEC(N)
      INTEGER INUMMYR, INUMMYC
      INTEGER IWSZ
      INTEGER IWRK(IWSZ)
      INTEGER COMM
      INTEGER I, IR, IC
      INUMMYR = 0
      INUMMYC = 0
      DO I=1,M
         IWRK(I) = 0
         IF(ROWPARTVEC(I).EQ.MYID) THEN
            IWRK(I)=1
            INUMMYR = INUMMYR + 1
         ENDIF
      ENDDO
      DO I=1,NZ_loc
         IR = IRN_loc(I)
         IF((IR.GE.1).AND.(IR.LE.M)) THEN
            IF(IWRK(IR) .EQ. 0) THEN
               IWRK(IR)= 1
               INUMMYR = INUMMYR + 1
            ENDIF
         ENDIF
      ENDDO
      DO I=1,N
         IWRK(I) = 0
         IF(COLPARTVEC(I).EQ.MYID) THEN
            IWRK(I)= 1
            INUMMYC = INUMMYC + 1
         ENDIF
      ENDDO
      DO I=1,NZ_loc
         IC = JCN_loc(I)
         IF((IC.GE.1).AND.(IC.LE.N)) THEN
            IF(IWRK(IC) .EQ. 0) THEN
               IWRK(IC)= 1
               INUMMYC = INUMMYC + 1
            ENDIF
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_662
      SUBROUTINE CMUMPS_660(MYID, NUMPROCS,COMM,    
     &     IRN_loc, JCN_loc, NZ_loc,
     &     ROWPARTVEC, COLPARTVEC, M, N,
     &     MYROWINDICES, INUMMYR,
     &     MYCOLINDICES, INUMMYC,     
     &     IWRK, IWSZ  )
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, M, N
      INTEGER INUMMYR, INUMMYC, IWSZ
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER ROWPARTVEC(M)
      INTEGER COLPARTVEC(N)
      INTEGER MYROWINDICES(INUMMYR)
      INTEGER MYCOLINDICES(INUMMYC)
      INTEGER IWRK(IWSZ)
      INTEGER COMM
      INTEGER I, IR, IC, ITMP, MAXMN
      MAXMN = M
      IF(N > MAXMN) MAXMN = N
      DO I=1,M
         IWRK(I) = 0
         IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1
      ENDDO
      DO I=1,NZ_loc
         IR = IRN_loc(I)
         IF((IR.GE.1).AND.(IR.LE.M)) THEN
            IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1
         ENDIF
      ENDDO
      ITMP = 1
      DO I=1,M
         IF(IWRK(I).EQ.1) THEN
            MYROWINDICES(ITMP) = I
            ITMP  = ITMP + 1
         ENDIF
      ENDDO
      DO I=1,N
         IWRK(I) = 0
         IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1
      ENDDO
      DO I=1,NZ_loc
         IC = JCN_loc(I)
         IF((IC.GE.1).AND.(IC.LE.N)) THEN
            IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1
         ENDIF
      ENDDO
      ITMP = 1
      DO I=1,N
         IF(IWRK(I).EQ.1) THEN
            MYCOLINDICES(ITMP) = I
            ITMP  = ITMP + 1
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_660
      INTEGER FUNCTION CMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS)
      IMPLICIT NONE
      INTEGER DSZ, INDXSZ
      REAL D(DSZ)
      INTEGER INDX(INDXSZ)
      REAL EPS
      INTEGER I, IID
      REAL RONE
      PARAMETER(RONE=1.0E0)
      CMUMPS_CHK1LOC = 1
      DO I=1, INDXSZ
         IID = INDX(I)
         IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND.
     &        ((RONE-EPS).LE.D(IID)) )) THEN
            CMUMPS_CHK1LOC = 0         
         ENDIF
      ENDDO
      RETURN
      END FUNCTION CMUMPS_CHK1LOC
      INTEGER FUNCTION CMUMPS_CHK1CONV(D, DSZ, EPS)
      IMPLICIT NONE
      INTEGER DSZ
      REAL D(DSZ)
      REAL EPS
      INTEGER I
      REAL RONE
      PARAMETER(RONE=1.0E0)
      CMUMPS_CHK1CONV = 1
      DO I=1, DSZ
         IF (.NOT.( (D(I).LE.(RONE+EPS)).AND.
     &        ((RONE-EPS).LE.D(I)) )) THEN
            CMUMPS_CHK1CONV = 0         
         ENDIF
      ENDDO
      RETURN
      END FUNCTION CMUMPS_CHK1CONV
      INTEGER FUNCTION CMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ,
     &     DC, N, INDXC, INDXCSZ, EPS, COMM)
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER M, N, INDXRSZ, INDXCSZ
      REAL DR(M), DC(N)
      INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ)
      REAL EPS
      INTEGER COMM
      EXTERNAL CMUMPS_CHK1LOC
      INTEGER  CMUMPS_CHK1LOC
      INTEGER GLORES, MYRESR, MYRESC, MYRES
      INTEGER IERR
      MYRESR =  CMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS)
      MYRESC =  CMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS)
      MYRES = MYRESR + MYRESC
      CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER,
     &     MPI_SUM, COMM, IERR)
      CMUMPS_CHKCONVGLO = GLORES
      RETURN
      END FUNCTION CMUMPS_CHKCONVGLO
      REAL FUNCTION CMUMPS_ERRSCALOC(D, TMPD, DSZ,
     &     INDX, INDXSZ)
      IMPLICIT NONE 
      INTEGER DSZ, INDXSZ
      REAL D(DSZ)
      REAL TMPD(DSZ)
      INTEGER INDX(INDXSZ)
      REAL RONE
      PARAMETER(RONE=1.0E0)
      INTEGER I, IIND
      REAL ERRMAX
      INTRINSIC abs
      ERRMAX = -RONE
      DO I=1,INDXSZ
         IIND = INDX(I)
         IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN
            ERRMAX = abs(RONE-TMPD(IIND))
         ENDIF
      ENDDO           
      CMUMPS_ERRSCALOC = ERRMAX
      RETURN
      END FUNCTION CMUMPS_ERRSCALOC
      REAL FUNCTION CMUMPS_ERRSCA1(D, TMPD, DSZ)
      IMPLICIT NONE 
      INTEGER DSZ
      REAL D(DSZ)
      REAL TMPD(DSZ)
      REAL RONE
      PARAMETER(RONE=1.0E0)
      INTEGER I, IIND
      REAL ERRMAX1
      INTRINSIC abs
      ERRMAX1 = -RONE
      DO I=1,DSZ
         IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN
            ERRMAX1 = abs(RONE-TMPD(I))
         ENDIF
      ENDDO
      CMUMPS_ERRSCA1 = ERRMAX1
      RETURN
      END FUNCTION CMUMPS_ERRSCA1
      SUBROUTINE CMUMPS_665(D,  TMPD, DSZ,
     &        INDX, INDXSZ)
      IMPLICIT NONE
      INTEGER DSZ, INDXSZ
      REAL D(DSZ)
      REAL TMPD(DSZ)
      INTEGER INDX(INDXSZ)
      INTRINSIC sqrt
      INTEGER I, IIND
      DO I=1,INDXSZ
         IIND = INDX(I)
         D(IIND) = D(IIND)/sqrt(TMPD(IIND))
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_665
      SUBROUTINE CMUMPS_666(D,  TMPD, DSZ)
      IMPLICIT NONE
      INTEGER DSZ
      REAL D(DSZ)
      REAL TMPD(DSZ)
      INTRINSIC sqrt
      INTEGER I
      DO I=1,DSZ
         D(I) = D(I)/sqrt(TMPD(I))
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_666
      SUBROUTINE CMUMPS_671(D, DSZ, INDX, INDXSZ, VAL)
      IMPLICIT NONE
      INTEGER DSZ, INDXSZ
      REAL D(DSZ)
      INTEGER INDX(INDXSZ)
      REAL VAL
      INTEGER I, IIND
      DO I=1,INDXSZ
         IIND = INDX(I)
         D(IIND) = VAL
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_671
      SUBROUTINE CMUMPS_702(D, DSZ, INDX, INDXSZ)
      IMPLICIT NONE
      INTEGER DSZ, INDXSZ
      REAL D(DSZ)
      INTEGER INDX(INDXSZ)
      INTEGER I, IIND
      DO I=1,INDXSZ
         IIND  = INDX(I)
         D(IIND) = 1.0E0/D(IIND)
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_702
      SUBROUTINE CMUMPS_670(D, DSZ, VAL)
      IMPLICIT NONE
      INTEGER DSZ
      REAL D(DSZ)
      REAL VAL
      INTEGER I
      DO I=1,DSZ
         D(I) = VAL
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_670
      SUBROUTINE CMUMPS_650(TMPD, TMPSZ, INDX, INDXSZ)
      IMPLICIT NONE
      INTEGER TMPSZ,INDXSZ 
      REAL TMPD(TMPSZ)
      INTEGER INDX(INDXSZ)
      INTEGER I
      REAL DZERO
      PARAMETER(DZERO=0.0E0)
      DO I=1,INDXSZ
         TMPD(INDX(I)) = DZERO
      ENDDO      
      RETURN
      END SUBROUTINE CMUMPS_650
      SUBROUTINE CMUMPS_703(INV, INOUTV, LEN, DTYPE)
      IMPLICIT NONE
      INTEGER LEN
      INTEGER INV(2*LEN) 
      INTEGER INOUTV(2*LEN)
      INTEGER DTYPE
      INTEGER I
      INTEGER DIN, DINOUT, PIN, PINOUT
      DO I=1,2*LEN-1,2
         DIN = INV(I)
         PIN = INV(I+1)
         DINOUT = INOUTV(I)
         PINOUT = INOUTV(I+1)
         IF ((DINOUT > DIN).OR.((DINOUT == DIN).AND.(PIN<PINOUT))) THEN
            INOUTV(I) = DIN
            INOUTV(I+1) = PIN
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_703
      SUBROUTINE CMUMPS_668(IW, IWSZ, IVAL)
      IMPLICIT NONE
      INTEGER IWSZ
      INTEGER IW(IWSZ)
      INTEGER IVAL
      INTEGER I
      DO I=1,IWSZ
         IW(I)=IVAL
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_668
      SUBROUTINE CMUMPS_704(MYID, NUMPROCS,
     & IRN_loc, JCN_loc, NZ_loc,
     & ROWPARTVEC, COLPARTVEC, M, N,
     & MYROWINDICES, INUMMYR,
     & MYCOLINDICES, INUMMYC,     
     & IWRKROW, IWRKCOL, IWSZR, IWSZC, COMM    )
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, M, N
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER ROWPARTVEC(M)
      INTEGER COLPARTVEC(N)
      INTEGER MYROWINDICES(M)
      INTEGER MYCOLINDICES(N)
      INTEGER INUMMYR, INUMMYC
      INTEGER IWSZR, IWSZC
      INTEGER IWRKROW(IWSZR)
      INTEGER IWRKCOL(IWSZC)
      INTEGER COMM
      INTEGER I, IR, IC, ITMP
      INUMMYR = 0
      INUMMYC = 0
      DO I=1,M
         IWRKROW(I) = 0
         IF(ROWPARTVEC(I).EQ.MYID) THEN
            IWRKROW(I)=1
            INUMMYR = INUMMYR + 1
         ENDIF
      ENDDO
      DO I=1,NZ_loc
         IR = IRN_loc(I)
         IF((IR.GE.1).AND.(IR.LE.M)) THEN
            IF(IWRKROW(IR) .EQ. 0) THEN
               IWRKROW(IR)= 1
               INUMMYR = INUMMYR + 1
            ENDIF
         ENDIF
      ENDDO
      ITMP = 1
      DO I=1,M
         IF(IWRKROW(I).EQ.1) THEN
            MYROWINDICES(ITMP) = I
            ITMP  = ITMP + 1
         ENDIF
      ENDDO
      DO I=1,N
         IWRKCOL(I) = 0
         IF(COLPARTVEC(I).EQ.MYID) THEN
            IWRKCOL(I)= 1
            INUMMYC = INUMMYC + 1
         ENDIF
      ENDDO
      DO I=1,NZ_loc
         IC = JCN_loc(I)
         IF((IC.GE.1).AND.(IC.LE.N)) THEN
            IF(IWRKCOL(IC) .EQ. 0) THEN
               IWRKCOL(IC)= 1
               INUMMYC = INUMMYC + 1
            ENDIF
         ENDIF
      ENDDO
      ITMP = 1
      DO I=1,N
         IF(IWRKCOL(I).EQ.1) THEN
            MYCOLINDICES(ITMP) = I
            ITMP  = ITMP + 1
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_704
      SUBROUTINE CMUMPS_672(MYID, NUMPROCS, ISZ, IPARTVEC,
     & NZ_loc, INDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL,
     & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM)
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ
      INTEGER ISNDRCVNUM, ISNDRCVVOL
      INTEGER OSNDRCVNUM, OSNDRCVVOL
      INTEGER COMM
      INTEGER INDX(NZ_loc)
      INTEGER IPARTVEC(ISZ)
      INTEGER IWRK(IWRKSZ)
      INTEGER SNDSZ(NUMPROCS)
      INTEGER RCVSZ(NUMPROCS)
      INCLUDE 'mpif.h'
      INTEGER I
      INTEGER IIND, PIND
      INTEGER IERROR
      DO I=1,NUMPROCS
         SNDSZ(I) = 0
         RCVSZ(I) = 0
      ENDDO
      DO I=1,IWRKSZ
         IWRK(I) = 0
      ENDDO
      DO I=1,NZ_loc
         IIND = INDX(I)
         IF((IIND.GE.1).AND.(IIND.LE.ISZ))THEN
            PIND = IPARTVEC(IIND)
            IF(PIND .NE. MYID) THEN
               IF(IWRK(IIND).EQ.0) THEN
                  IWRK(IIND) = 1
                  SNDSZ(PIND+1) = SNDSZ(PIND+1)+1
               ENDIF
            ENDIF
         ENDIF
      ENDDO
      CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER,
     & RCVSZ, 1, MPI_INTEGER, COMM, IERROR)
      ISNDRCVNUM = 0 
      ISNDRCVVOL = 0
      OSNDRCVNUM = 0
      OSNDRCVVOL = 0
      DO I=1, NUMPROCS
         IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1
         OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I)
         IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1
         ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I)
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_672
      SUBROUTINE CMUMPS_674(MYID, NUMPROCS, ISZ, IPARTVEC,
     &     NZ_loc, INDX,
     &     ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA,
     &     OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA,
     &     SNDSZ, RCVSZ, IWRK, 
     &     ISTATUS, REQUESTS,
     &     ITAGCOMM, COMM )
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL
      INTEGER INDX(NZ_loc)
      INTEGER IPARTVEC(ISZ)
      INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM)
      INTEGER ISNDRCVIA(NUMPROCS+1)
      INTEGER ISNDRCVJA(ISNDVOL)
      INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM)
      INTEGER OSNDRCVIA(NUMPROCS+1)
      INTEGER OSNDRCVJA(OSNDVOL)
      INTEGER SNDSZ(NUMPROCS)
      INTEGER RCVSZ(NUMPROCS)
      INTEGER IWRK(ISZ)
      INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM)
      INTEGER REQUESTS(ISNDRCVNUM)
      INTEGER ITAGCOMM, COMM
      INTEGER I, IIND, IPID, OFFS, IWHERETO, POFFS, ITMP, IERROR
      DO I=1,ISZ
         IWRK(I) = 0
      ENDDO
      OFFS = 1
      POFFS = 1
      DO I=1,NUMPROCS
         OSNDRCVIA(I) = OFFS + SNDSZ(I)
         IF(SNDSZ(I) > 0) THEN
            ONGHBPRCS(POFFS)=I
            POFFS = POFFS + 1
         ENDIF         
         OFFS  = OFFS +  SNDSZ(I)
      ENDDO
      OSNDRCVIA(NUMPROCS+1) = OFFS
      DO I=1,NZ_loc
         IIND=INDX(I)
         IF((IIND.GE.1).AND.(IIND.LE.ISZ)) THEN
            IPID=IPARTVEC(IIND)
            IF(IPID.NE.MYID) THEN
               IF(IWRK(IIND).EQ.0) THEN
                  IWHERETO = OSNDRCVIA(IPID+1)-1
                  OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1
                  OSNDRCVJA(IWHERETO) = IIND
                  IWRK(IIND) = 1
               ENDIF
            ENDIF
         ENDIF
      ENDDO
      CALL MPI_BARRIER(COMM,IERROR)
      OFFS = 1
      POFFS = 1
      ISNDRCVIA(1) = 1
      DO I=2,NUMPROCS+1
         ISNDRCVIA(I) = OFFS + RCVSZ(I-1)
         IF(RCVSZ(I-1) > 0) THEN
            INGHBPRCS(POFFS)=I-1
            POFFS = POFFS + 1
         ENDIF         
         OFFS  = OFFS +  RCVSZ(I-1)
      ENDDO
      CALL MPI_BARRIER(COMM,IERROR)      
      DO I=1, ISNDRCVNUM
         IPID = INGHBPRCS(I)
         OFFS = ISNDRCVIA(IPID)
         ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID)
         CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1,
     &     ITAGCOMM, COMM, REQUESTS(I),IERROR)   
      ENDDO
      DO I=1,OSNDRCVNUM
         IPID = ONGHBPRCS(I)
         OFFS = OSNDRCVIA(IPID)
         ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID)
         CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1,
     &        ITAGCOMM, COMM,IERROR)
      ENDDO
      IF(ISNDRCVNUM > 0) THEN
         CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR)
      ENDIF
      CALL MPI_BARRIER(COMM,IERROR)
      RETURN
      END SUBROUTINE CMUMPS_674
      SUBROUTINE CMUMPS_657(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, 
     &     ISNDRCVNUM, INGHBPRCS,
     &     ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA,
     &     OSNDRCVNUM, ONGHBPRCS,
     &     OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA,
     &     ISTATUS, REQUESTS,
     &     COMM)
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM
      INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL
      REAL TMPD(IDSZ)
      INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM)
      INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL)
      REAL ISNDRCVA(ISNDRCVVOL)
      INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL)
      REAL OSNDRCVA(OSNDRCVVOL)
      INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM))
      INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM))
      INTEGER COMM, IERROR
      INTEGER I, PID, OFFS, SZ, J, JS, JE, IID
      DO I=1,ISNDRCVNUM
         PID = INGHBPRCS(I)
         OFFS = ISNDRCVIA(PID)
         SZ = ISNDRCVIA(PID+1) -  ISNDRCVIA(PID) 
         CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, 
     &        MPI_REAL, PID-1, 
     &        ITAGCOMM,COMM,REQUESTS(I), IERROR)
      ENDDO
      DO I=1,OSNDRCVNUM
         PID = ONGHBPRCS(I)
         OFFS = OSNDRCVIA(PID)
         SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 
         JS = OSNDRCVIA(PID) 
         JE =  OSNDRCVIA(PID+1) - 1
         DO J=JS, JE
            IID = OSNDRCVJA(J)
            OSNDRCVA(j) = TMPD(IID)
         ENDDO
         CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1,
     &        ITAGCOMM, COMM, IERROR)
      ENDDO
      IF(ISNDRCVNUM > 0) THEN
         CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR)
      ENDIF
      DO I=1,ISNDRCVNUM
         PID = INGHBPRCS(I)
         JS = ISNDRCVIA(PID)
         JE = ISNDRCVIA(PID+1)-1
         DO J=JS,JE
            IID = ISNDRCVJA(J)
            IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J)
         ENDDO
      ENDDO
      DO I=1,OSNDRCVNUM
         PID = ONGHBPRCS(I)
         OFFS = OSNDRCVIA(PID)
         SZ = OSNDRCVIA(PID+1) -  OSNDRCVIA(PID) 
         CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, 
     &        MPI_REAL, PID-1, 
     &        ITAGCOMM+1,COMM,REQUESTS(I), IERROR)
      ENDDO
      DO I=1,ISNDRCVNUM
         PID = INGHBPRCS(I)
         OFFS = ISNDRCVIA(PID)
         SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID)
         JS = ISNDRCVIA(PID)
         JE = ISNDRCVIA(PID+1) -1
         DO J=JS, JE
            IID = ISNDRCVJA(J)
            ISNDRCVA(J) = TMPD(IID)
         ENDDO
         CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1,
     &        ITAGCOMM+1, COMM, IERROR)
      ENDDO
      IF(OSNDRCVNUM > 0) THEN
         CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR)
      ENDIF
      DO I=1,OSNDRCVNUM
         PID = ONGHBPRCS(I)
         JS = OSNDRCVIA(PID) 
         JE = OSNDRCVIA(PID+1) - 1
         DO J=JS,JE
            IID = OSNDRCVJA(J)
            TMPD(IID)=OSNDRCVA(J)
         ENDDO
      ENDDO
      RETURN
      END  SUBROUTINE CMUMPS_657
      SUBROUTINE CMUMPS_656(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, 
     &     ISNDRCVNUM, INGHBPRCS,
     &     ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA,
     &     OSNDRCVNUM, ONGHBPRCS,
     &     OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA,
     &     ISTATUS, REQUESTS,
     &     COMM)
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM
      INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL
      REAL TMPD(IDSZ)
      INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM)
      INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL)
      REAL ISNDRCVA(ISNDRCVVOL)
      INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL)
      REAL OSNDRCVA(OSNDRCVVOL)
      INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM))
      INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM))
      INTEGER COMM, IERROR
      INTEGER I, PID, OFFS, SZ, J, JS, JE, IID
      DO I=1,ISNDRCVNUM
         PID = INGHBPRCS(I)
         OFFS = ISNDRCVIA(PID)
         SZ = ISNDRCVIA(PID+1) -  ISNDRCVIA(PID) 
         CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, 
     &        MPI_REAL, PID-1, 
     &        ITAGCOMM,COMM,REQUESTS(I), IERROR)
      ENDDO
      DO I=1,OSNDRCVNUM
         PID = ONGHBPRCS(I)
         OFFS = OSNDRCVIA(PID)
         SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) 
         JS = OSNDRCVIA(PID) 
         JE =  OSNDRCVIA(PID+1) - 1
         DO J=JS, JE
            IID = OSNDRCVJA(J)
            OSNDRCVA(j) = TMPD(IID)
         ENDDO
         CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1,
     &        ITAGCOMM, COMM, IERROR)
      ENDDO
      IF(ISNDRCVNUM > 0) THEN
         CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR)
      ENDIF
      DO I=1,ISNDRCVNUM
         PID = INGHBPRCS(I)
         JS = ISNDRCVIA(PID)
         JE = ISNDRCVIA(PID+1)-1
         DO J=JS,JE
            IID = ISNDRCVJA(J)
            TMPD(IID)  = TMPD(IID)+ ISNDRCVA(J)
         ENDDO
      ENDDO
      DO I=1,OSNDRCVNUM
         PID = ONGHBPRCS(I)
         OFFS = OSNDRCVIA(PID)
         SZ = OSNDRCVIA(PID+1) -  OSNDRCVIA(PID) 
         CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, 
     &        MPI_REAL, PID-1, 
     &        ITAGCOMM+1,COMM,REQUESTS(I), IERROR)
      ENDDO
      DO I=1,ISNDRCVNUM
         PID = INGHBPRCS(I)
         OFFS = ISNDRCVIA(PID)
         SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID)
         JS = ISNDRCVIA(PID)
         JE = ISNDRCVIA(PID+1) -1
         DO J=JS, JE
            IID = ISNDRCVJA(J)
            ISNDRCVA(J) = TMPD(IID)
         ENDDO
         CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1,
     &        ITAGCOMM+1, COMM, IERROR)
      ENDDO
      IF(OSNDRCVNUM > 0) THEN
         CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR)
      ENDIF
      DO I=1,OSNDRCVNUM
         PID = ONGHBPRCS(I)
         JS = OSNDRCVIA(PID) 
         JE = OSNDRCVIA(PID+1) - 1
         DO J=JS,JE
            IID = OSNDRCVJA(J)
            TMPD(IID)=OSNDRCVA(J)
         ENDDO
      ENDDO
      RETURN
      END  SUBROUTINE CMUMPS_656
      SUBROUTINE CMUMPS_655(MYID, NUMPROCS, COMM,
     & IRN_loc, JCN_loc, NZ_loc,
     & IPARTVEC, ISZ,
     & IWRK, IWSZ)
      IMPLICIT NONE
      EXTERNAL CMUMPS_703
      INTEGER MYID, NUMPROCS, COMM
      INTEGER NZ_loc, ISZ, IWSZ
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER IPARTVEC(ISZ)
      INTEGER IWRK(IWSZ)
      INCLUDE 'mpif.h'
      INTEGER I
      INTEGER OP, IERROR
      INTEGER IDIST, IR, IC
      IF(NUMPROCS.NE.1) THEN
         CALL MPI_OP_CREATE(CMUMPS_703, .TRUE., OP, IERROR)
         CALL CMUMPS_668(IWRK, 4*ISZ, ISZ)
         DO I=1,NZ_loc
            IR = IRN_loc(I)
            IC = JCN_loc(I)
            IF((IR.GE.1).AND.(IR.LE.ISZ).AND.
     &           (IC.GE.1).AND.(IC.LE.ISZ)) THEN
               IDIST = IR-IC
               IF(IDIST < 0) IDIST = -IDIST 
               IF(IDIST < IWRK(2*IR-1)) THEN
                  IWRK(2*IR-1) = IDIST
                  IWRK(2*IR) = MYID
               ENDIF
               IF(IDIST < IWRK(2*IC-1)) THEN
                  IWRK(2*IC-1) = IDIST
                  IWRK(2*IC) = MYID               
               ENDIF
            ENDIF
         ENDDO
         CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ,
     &        MPI_2INTEGER, OP, COMM, IERROR)      
         DO I=1,ISZ
            IPARTVEC(I) = IWRK(2*i+2*ISZ)
         ENDDO
         CALL MPI_OP_FREE(OP, IERROR)
      ELSE
         DO I=1,ISZ
            IPARTVEC(I) = 0
         ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_655
      SUBROUTINE CMUMPS_673(MYID, NUMPROCS, ISZ, IPARTVEC,
     & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL,
     & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM)
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ
      INTEGER ISNDRCVNUM, ISNDRCVVOL
      INTEGER OSNDRCVNUM, OSNDRCVVOL
      INTEGER COMM
      INTEGER INDX(NZ_loc), OINDX(NZ_loc)
      INTEGER IPARTVEC(ISZ)
      INTEGER IWRK(IWRKSZ)
      INTEGER SNDSZ(NUMPROCS)
      INTEGER RCVSZ(NUMPROCS)
      INCLUDE 'mpif.h'
      INTEGER I
      INTEGER IIND, IIND2, PIND
      INTEGER IERROR
      DO I=1,NUMPROCS
         SNDSZ(I) = 0
         RCVSZ(I) = 0
      ENDDO
      DO I=1,IWRKSZ
         IWRK(I) = 0
      ENDDO
      DO I=1,NZ_loc
         IIND = INDX(I)
         IIND2 = OINDX(I)
         IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1)
     &        .AND.(IIND2.LE.ISZ)) THEN
            PIND = IPARTVEC(IIND)
            IF(PIND .NE. MYID) THEN
               IF(IWRK(IIND).EQ.0) THEN
                  IWRK(IIND) = 1
                  SNDSZ(PIND+1) = SNDSZ(PIND+1)+1
               ENDIF
            ENDIF
            IIND = OINDX(I)
            PIND = IPARTVEC(IIND)
            IF(PIND .NE. MYID) THEN
               IF(IWRK(IIND).EQ.0) THEN
                  IWRK(IIND) = 1
                  SNDSZ(PIND+1) = SNDSZ(PIND+1)+1
               ENDIF
            ENDIF
         ENDIF
      ENDDO
      CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER,
     &     RCVSZ, 1, MPI_INTEGER, COMM, IERROR)
      ISNDRCVNUM = 0 
      ISNDRCVVOL = 0
      OSNDRCVNUM = 0
      OSNDRCVVOL = 0
      DO I=1, NUMPROCS
         IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1
         OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I)
         IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1
         ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I)
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_673
      SUBROUTINE CMUMPS_663(MYID, NUMPROCS, COMM,
     &     IRN_loc, JCN_loc, NZ_loc,
     &     PARTVEC, N,
     &     INUMMYR,
     &     IWRK, IWSZ)
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, N
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER PARTVEC(N)
      INTEGER INUMMYR
      INTEGER IWSZ
      INTEGER IWRK(IWSZ)
      INTEGER COMM
      INTEGER I, IR, IC
      INUMMYR = 0
      DO I=1,N
         IWRK(I) = 0
         IF(PARTVEC(I).EQ.MYID) THEN
            IWRK(I)=1
            INUMMYR = INUMMYR + 1
         ENDIF
      ENDDO
      DO I=1,NZ_loc
         IR = IRN_loc(I)
         IF((IR.GE.1).AND.(IR.LE.N)) THEN
            IF(IWRK(IR) .EQ. 0) THEN
               IWRK(IR)= 1
               INUMMYR = INUMMYR + 1
            ENDIF
         ENDIF
         IC = JCN_loc(I)
         IF((IC.GE.1).AND.(IC.LE.N)) THEN
            IF(IWRK(IC).EQ.0) THEN
               IWRK(IC)= 1
               INUMMYR = INUMMYR + 1
            ENDIF
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_663
      INTEGER FUNCTION CMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ,
     &     EPS, COMM)
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER N, INDXRSZ
      REAL D(N)
      INTEGER INDXR(INDXRSZ)
      REAL EPS
      INTEGER COMM
      EXTERNAL CMUMPS_CHK1LOC
      INTEGER  CMUMPS_CHK1LOC
      INTEGER GLORES, MYRESR, MYRESC, MYRES
      INTEGER IERR
      MYRESR =  CMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS)
      MYRES = 2*MYRESR 
      CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER,
     &     MPI_SUM, COMM, IERR)
      CMUMPS_CHKCONVGLOSYM = GLORES
      RETURN
      END FUNCTION CMUMPS_CHKCONVGLOSYM
      SUBROUTINE CMUMPS_661(MYID, NUMPROCS,COMM,    
     &     IRN_loc, JCN_loc, NZ_loc,
     &     PARTVEC, N,
     &     MYROWINDICES, INUMMYR,
     &     IWRK, IWSZ  )
      IMPLICIT NONE
      INTEGER MYID, NUMPROCS, NZ_loc, N
      INTEGER INUMMYR, IWSZ
      INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
      INTEGER PARTVEC(N)
      INTEGER MYROWINDICES(INUMMYR)
      INTEGER IWRK(IWSZ)
      INTEGER COMM
      INTEGER I, IR, IC, ITMP, MAXMN
      MAXMN = N
      DO I=1,N
         IWRK(I) = 0
         IF(PARTVEC(I).EQ.MYID) IWRK(I)=1
      ENDDO
      DO I=1,NZ_loc
         IR = IRN_loc(I)
         IF((IR.GE.1).AND.(IR.LE.N)) THEN
            IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1
         ENDIF
         IC = JCN_loc(I)
         IF((IC.GE.1).AND.(IC.LE.N)) THEN
            IF(IWRK(IC) .EQ.0) IWRK(IC)=1
         ENDIF
      ENDDO
      ITMP = 1
      DO I=1,N
         IF(IWRK(I).EQ.1) THEN
            MYROWINDICES(ITMP) = I
            ITMP  = ITMP + 1
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_661
      SUBROUTINE CMUMPS_692(MYID, NUMPROCS, ISZ, IPARTVEC,
     & NZ_loc, INDX, OINDX,
     & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA,
     & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA,
     & SNDSZ, RCVSZ, IWRK, 
     & ISTATUS, REQUESTS,
     &  ITAGCOMM, COMM )
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL
      INTEGER INDX(NZ_loc), OINDX(NZ_loc)
      INTEGER IPARTVEC(ISZ)
      INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM)
      INTEGER ISNDRCVIA(NUMPROCS+1)
      INTEGER ISNDRCVJA(ISNDVOL)
      INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM)
      INTEGER OSNDRCVIA(NUMPROCS+1)
      INTEGER OSNDRCVJA(OSNDVOL)
      INTEGER SNDSZ(NUMPROCS)
      INTEGER RCVSZ(NUMPROCS)
      INTEGER IWRK(ISZ)
      INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM)
      INTEGER REQUESTS(ISNDRCVNUM)
      INTEGER ITAGCOMM, COMM
      INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR
      DO I=1,ISZ
         IWRK(I) = 0
      ENDDO
      OFFS = 1
      POFFS = 1
      DO I=1,NUMPROCS
         OSNDRCVIA(I) = OFFS + SNDSZ(I)
         IF(SNDSZ(I) > 0) THEN
            ONGHBPRCS(POFFS)=I
            POFFS = POFFS + 1
         ENDIF         
         OFFS  = OFFS +  SNDSZ(I)
      ENDDO
      OSNDRCVIA(NUMPROCS+1) = OFFS
      DO I=1,NZ_loc
         IIND=INDX(I)
         IIND2 = OINDX(I)
         IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1)
     &        .AND.(IIND2.LE.ISZ)) THEN            
            IPID=IPARTVEC(IIND)
            IF(IPID.NE.MYID) THEN
               IF(IWRK(IIND).EQ.0) THEN
                  IWHERETO = OSNDRCVIA(IPID+1)-1
                  OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1
                  OSNDRCVJA(IWHERETO) = IIND
                  IWRK(IIND) = 1
               ENDIF
            ENDIF
            IIND = OINDX(I)
            IPID=IPARTVEC(IIND)
            IF(IPID.NE.MYID) THEN
               IF(IWRK(IIND).EQ.0) THEN
                  IWHERETO = OSNDRCVIA(IPID+1)-1
                  OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1
                  OSNDRCVJA(IWHERETO) = IIND
                  IWRK(IIND) = 1
               ENDIF
            ENDIF
         ENDIF
      ENDDO
      CALL MPI_BARRIER(COMM,IERROR)
      OFFS = 1
      POFFS = 1
      ISNDRCVIA(1) = 1
      DO I=2,NUMPROCS+1
         ISNDRCVIA(I) = OFFS + RCVSZ(I-1)
         IF(RCVSZ(I-1) > 0) THEN
            INGHBPRCS(POFFS)=I-1
            POFFS = POFFS + 1
         ENDIF         
         OFFS  = OFFS +  RCVSZ(I-1)
      ENDDO
      CALL MPI_BARRIER(COMM,IERROR)      
      DO I=1, ISNDRCVNUM
         IPID = INGHBPRCS(I)
         OFFS = ISNDRCVIA(IPID)
         ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID)
         CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1,
     &     ITAGCOMM, COMM, REQUESTS(I),IERROR)   
      ENDDO
      DO I=1,OSNDRCVNUM
         IPID = ONGHBPRCS(I)
         OFFS = OSNDRCVIA(IPID)
         ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID)
         CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1,
     &        ITAGCOMM, COMM,IERROR)
      ENDDO
      IF(ISNDRCVNUM > 0) THEN
         CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR)
      ENDIF
      CALL MPI_BARRIER(COMM,IERROR)
      RETURN
      END SUBROUTINE CMUMPS_692
      SUBROUTINE CMUMPS_628(IW,LREC,SIZE_FREE,XSIZE)
      INTEGER, intent(in) :: LREC, XSIZE
      INTEGER, intent(in) :: IW(LREC)
      INTEGER, intent(out):: SIZE_FREE
      INCLUDE 'mumps_headers.h'
      IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR.
     *    IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN
        SIZE_FREE=IW(1+XSIZE+2)*IW(1+XSIZE+3)
      ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR.
     *         IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN
        SIZE_FREE=IW(1+XSIZE+2)*(IW(1+XSIZE)+
     *            IW(1+XSIZE + 3) -
     *          ( IW(1+XSIZE + 4)
     *          - IW(1+XSIZE + 3) ) )
      ELSE
        SIZE_FREE=0
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_628
      SUBROUTINE CMUMPS_629
     *(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT)
      IMPLICIT NONE
      INCLUDE 'mumps_headers.h'
      INTEGER LIW,IXXP,ICURRENT,NEXT,RCURRENT,ISIZE2SHIFT
      INTEGER IW(LIW)
      ICURRENT=NEXT
      RCURRENT=RCURRENT-IW(ICURRENT+XXR)
      NEXT=IW(ICURRENT+XXP)
      IW(IXXP)=ICURRENT+ISIZE2SHIFT
      IXXP=ICURRENT+XXP
      RETURN
      END SUBROUTINE CMUMPS_629
      SUBROUTINE CMUMPS_630(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT)
      IMPLICIT NONE
      INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT
      INTEGER IW(LIW)
      INTEGER I
      IF (ISIZE2SHIFT.GT.0) THEN
        DO I=END2SHIFT,BEG2SHIFT,-1
          IW(I+ISIZE2SHIFT)=IW(I)
        ENDDO
      ELSE IF (ISIZE2SHIFT.LT.0) THEN
        DO I=BEG2SHIFT,END2SHIFT
          IW(I+ISIZE2SHIFT)=IW(I)
        ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_630
      SUBROUTINE CMUMPS_631(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT)
      IMPLICIT NONE
      INTEGER LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT
      COMPLEX A(LA)
      INTEGER I
      IF (RSIZE2SHIFT.GT.0) THEN
        DO I=END2SHIFT,BEG2SHIFT,-1
          A(I+RSIZE2SHIFT)=A(I)
        ENDDO
      ELSE IF (RSIZE2SHIFT.LT.0) THEN
        DO I=BEG2SHIFT,END2SHIFT
          A(I+RSIZE2SHIFT)=A(I)
        ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_631
      SUBROUTINE CMUMPS_94(N,KEEP28,IW,LIW,A,LA,
     *       LRLU,IPTRLU,IWPOS,
     *       IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, ITLOC,
     *       KEEP216,LRLUS,XSIZE)
      IMPLICIT NONE
      INTEGER N,LIW,LA,LRLU,KEEP28,
     &        IPTRLU,IWPOS,IWPOSCB,KEEP216,XSIZE
      INTEGER, intent(IN):: LRLUS
      INTEGER IW(LIW),PTRIST(KEEP28),PTRAST(KEEP28),
     &        STEP(N),
     * PIMASTER(KEEP28),
     * PAMASTER(KEEP28), ITLOC(N)
      COMPLEX A(LA)
      INCLUDE 'mumps_headers.h' 
      INTEGER ICURRENT, NEXT, RCURRENT, STATE_NEXT
      INTEGER ISIZE2SHIFT, RSIZE2SHIFT
      INTEGER IBEGCONTIG, RBEGCONTIG
      INTEGER INODE
      INTEGER FREE_IN_REC
      INTEGER IXXP
      ISIZE2SHIFT=0
      RSIZE2SHIFT=0
      ICURRENT  = LIW-XSIZE+1
      RCURRENT = LA+1
      IBEGCONTIG = -999999 
      RBEGCONTIG = -999999 
      NEXT = IW(ICURRENT+XXP)
      IF (NEXT.EQ.TOP_OF_STACK) RETURN
      STATE_NEXT = IW(NEXT+XXS)
      IXXP = ICURRENT+XXP
  10     CONTINUE
         IF ( STATE_NEXT .NE. S_FREE .AND.
     *        (KEEP216.EQ.3.OR.
     *         (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND.
     *          STATE_NEXT .NE. S_NOLCBCONTIG .AND.
     *          STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND.
     *          STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN
            CALL CMUMPS_629(IW,LIW,
     *           IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT)
            IF (IBEGCONTIG < 0) THEN
              IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1
            ENDIF
            IF (RBEGCONTIG < 0) THEN
              RBEGCONTIG=RCURRENT+IW(ICURRENT+XXR)-1
            ENDIF
            INODE=IW(ICURRENT+XXN)
            IF (RSIZE2SHIFT .NE. 0) THEN
                IF (PTRAST(STEP(INODE)).EQ.RCURRENT)
     *            PTRAST(STEP(INODE))=
     *            PTRAST(STEP(INODE))+RSIZE2SHIFT
                IF (PAMASTER(STEP(INODE)).EQ.RCURRENT)
     *            PAMASTER(STEP(INODE))=
     *            PAMASTER(STEP(INODE))+RSIZE2SHIFT
            ENDIF
            IF (ISIZE2SHIFT .NE. 0) THEN
                IF (PTRIST(STEP(INODE)).EQ.ICURRENT)
     *            PTRIST(STEP(INODE))=
     *            PTRIST(STEP(INODE))+ISIZE2SHIFT
                IF (PIMASTER(STEP(INODE)).EQ.ICURRENT)
     *            PIMASTER(STEP(INODE))=
     *            PIMASTER(STEP(INODE))+ISIZE2SHIFT
            ENDIF
            IF (NEXT .NE. TOP_OF_STACK) THEN
              STATE_NEXT=IW(NEXT+XXS)
              GOTO 10
            ENDIF
         ENDIF
  20     CONTINUE
         IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN
           CALL CMUMPS_630(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT)
           IF (IXXP .LE.IBEGCONTIG) THEN
           IXXP=IXXP+ISIZE2SHIFT
           ENDIF
         ENDIF
         IBEGCONTIG=-9999
  25     CONTINUE
         IF (RBEGCONTIG .GT.0 .AND. RSIZE2SHIFT .NE. 0) THEN
           CALL CMUMPS_631(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT)
         ENDIF
         RBEGCONTIG=-99999
  30     CONTINUE
         IF (NEXT.EQ. TOP_OF_STACK) GOTO 100
         IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR.
     *       STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR.
     *       STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR.
     *       STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN
           IF ( KEEP216.eq.3) THEN
             WRITE(*,*) "Internal error 2 in CMUMPS_94"
           ENDIF
           IF (RBEGCONTIG > 0) GOTO 25
           CALL CMUMPS_629
     *       (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT)
           IF (IBEGCONTIG < 0 ) THEN
             IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1
           ENDIF
           CALL CMUMPS_628(IW(ICURRENT),
     *                              LIW-ICURRENT+1,
     *                              FREE_IN_REC,
     *                              XSIZE)
           IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN
             CALL CMUMPS_627(A,LA,RCURRENT,
     *            IW(ICURRENT+XSIZE+2),
     *            IW(ICURRENT+XSIZE),
     *            IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0,
     *            IW(ICURRENT+XXS),RSIZE2SHIFT) 
           ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN
             CALL CMUMPS_627(A,LA,RCURRENT,
     *            IW(ICURRENT+XSIZE+2),
     *            IW(ICURRENT+XSIZE),
     *            IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3),
     *            IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), 
     *            IW(ICURRENT+XXS),RSIZE2SHIFT) 
           ELSE IF (RSIZE2SHIFT .GT.0) THEN
           CALL CMUMPS_631(A, LA, RCURRENT+FREE_IN_REC,
     *                       RCURRENT+IW(ICURRENT+XXR)-1,
     *                       RSIZE2SHIFT)
           ENDIF
           INODE=IW(ICURRENT+XXN)
           IF (ISIZE2SHIFT.NE.0) THEN
             PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT
           ENDIF
           PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+
     *                         FREE_IN_REC
           IW(ICURRENT+XXR)=IW(ICURRENT+XXR)-FREE_IN_REC
           IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR.
     *         STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN
             IW(ICURRENT+XXS)=S_NOLCLEANED
           ELSE
             IW(ICURRENT+XXS)=S_NOLCLEANED38
           ENDIF
           RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC
           RBEGCONTIG=-9999
           IF (NEXT.EQ.TOP_OF_STACK) THEN
             GOTO 20
           ELSE
             STATE_NEXT=IW(NEXT+XXS)
           ENDIF
           GOTO 30
         ENDIF
         IF (IBEGCONTIG.GT.0) THEN
           GOTO 20
         ENDIF
  40     CONTINUE
         IF (STATE_NEXT == S_FREE) THEN
            ICURRENT=NEXT
            RCURRENT=RCURRENT-IW(ICURRENT+XXR)
            ISIZE2SHIFT = ISIZE2SHIFT+IW(ICURRENT+XXI)
            RSIZE2SHIFT = RSIZE2SHIFT+IW(ICURRENT+XXR)
            NEXT=IW(ICURRENT+XXP)
            IF (NEXT.EQ.TOP_OF_STACK) THEN
              WRITE(*,*) "Internal error 1 in CMUMPS_94"
              CALL MUMPS_ABORT()
            ENDIF
            STATE_NEXT  = IW(NEXT+XXS)
            GOTO 40
         ENDIF
      GOTO 10
 100  CONTINUE
      IWPOSCB = IWPOSCB + ISIZE2SHIFT
      LRLU    = LRLU    + RSIZE2SHIFT
      IPTRLU  = IPTRLU  + RSIZE2SHIFT
      RETURN
      END SUBROUTINE CMUMPS_94
      SUBROUTINE CMUMPS_632(IREC, IW, LIW,
     *            ISIZEHOLE, RSIZEHOLE)
      IMPLICIT NONE
      INTEGER, intent(in) :: IREC, LIW
      INTEGER, intent(in) :: IW(LIW)
      INTEGER, intent(out):: ISIZEHOLE, RSIZEHOLE
      INTEGER IRECLOC
      INCLUDE 'mumps_headers.h'
      ISIZEHOLE=0
      RSIZEHOLE=0
      IRECLOC = IREC + IW( IREC+XXI )
 10   CONTINUE
      IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN
        ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI)
        RSIZEHOLE=RSIZEHOLE+IW(IRECLOC+XXR)
        IRECLOC=IRECLOC+IW(IRECLOC+XXI)
        GOTO 10
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_632
      SUBROUTINE CMUMPS_627(A, LA, RCURRENT,
     *           NROW, NCB, LD, NELIM, NODESTATE, ISHIFT)
      IMPLICIT NONE
      INCLUDE 'mumps_headers.h'
      INTEGER LD, NROW, NCB, NELIM, NODESTATE
      INTEGER ISHIFT, LA, RCURRENT
      COMPLEX A(LA)
      INTEGER I,J,IOLD,INEW
      LOGICAL NELIM_ROOT
      NELIM_ROOT=.TRUE.
      IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN
         NELIM_ROOT=.FALSE.
         IF (NELIM.NE.0)  THEN
           WRITE(*,*) "Internal error 1 IN CMUMPS_627"
           CALL MUMPS_ABORT()
         ENDIF
      ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN
           WRITE(*,*) "Internal error 2 in CMUMPS_627"
     *                ,NODESTATE
           CALL MUMPS_ABORT()
      ENDIF
      IF (ISHIFT .LT.0) THEN
        WRITE(*,*) "Internal error 3 in CMUMPS_627",ISHIFT
        CALL MUMPS_ABORT()
      ENDIF
      IF (NELIM_ROOT) THEN
        IOLD=RCURRENT+LD*NROW-1-NCB+NELIM
      ELSE
        IOLD = RCURRENT+LD*NROW-1
      ENDIF
      INEW = RCURRENT+LD*NROW+ISHIFT-1
      DO I = NROW, 1, -1
        IF (I.EQ.NROW .AND. ISHIFT.EQ.0.AND.
     *    .NOT. NELIM_ROOT) THEN
          IOLD=IOLD-LD
          INEW=INEW-NCB
          CYCLE
        ENDIF
        IF (NELIM_ROOT) THEN
          DO J=1,NELIM
            A( INEW ) = A( IOLD - J + 1)
            INEW = INEW - 1
          ENDDO
        ELSE
          DO J=1, NCB
            A( INEW ) = A( IOLD - J + 1)
            INEW = INEW - 1
          ENDDO
        ENDIF
        IOLD = IOLD - LD
      ENDDO
      IF (NELIM_ROOT) THEN
        NODESTATE=S_NOLCBCONTIG38
      ELSE
        NODESTATE=S_NOLCBCONTIG
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_627
      SUBROUTINE CMUMPS_700(BUFR,LBUFR,
     *     LBUFR_BYTES,
     *     root, N, IW, LIW, A, LA,
     *     NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB,
     *     PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER,
     *     COMP, LRLUS, IPOOL, LPOOL, LEAF,
     *     FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR,
     *     KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, ITLOC,
     *     ND,PROCNODE_STEPS,SLAVEF )
      USE CMUMPS_LOAD
      USE CMUMPS_OOC        
      IMPLICIT NONE
      INCLUDE 'cmumps_root.h'
      TYPE (CMUMPS_ROOT_STRUC ) :: root
      INTEGER KEEP( 500 )
      INTEGER*8 KEEP8(150)
      INTEGER LBUFR, LBUFR_BYTES, N, LIW, LA, LRLU, IPTRLU,
     *        IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG,
     *        IERROR, LRLUS
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LEAF )
      INTEGER PTRIST(KEEP(28)), PTRAST(KEEP(28))
      INTEGER PTLUST_S(KEEP(28)), PTRFAC(KEEP(28))
      INTEGER STEP(N), 
     * PIMASTER(KEEP(28)),
     *  PAMASTER(KEEP(28)), ITLOC( N )
      INTEGER BUFR( LBUFR_BYTES ), NBPROCFILS( KEEP(28) )
      INTEGER IW( LIW )
      INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF
      COMPLEX A( LA )
      INTEGER   MYID
      INTEGER FILS( N ), PTRAIW(N), PTRARW( N )
      INTEGER INTARR(max(1,KEEP(14)))
      COMPLEX DBLARR(max(1,KEEP(13)))
        INCLUDE 'mpif.h'
        INTEGER IERR
        INTEGER POSITION, LOCAL_M, LOCAL_N, POS_ROOT, LREQI, LREQA
        INTEGER NROW_SON, NCOL_SON, IROOT, ISON
        INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
        INCLUDE 'mumps_headers.h'
        POSITION = 0
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   ISON, 1, MPI_INTEGER, COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   NROW_SON, 1, MPI_INTEGER, COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   NCOL_SON, 1, MPI_INTEGER, COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   NBROWS_ALREADY_SENT, 1, MPI_INTEGER,
     *                   COMM, IERR )
        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   NBROWS_PACKET, 1, MPI_INTEGER,
     *                   COMM, IERR )
        IROOT = KEEP( 38 )
        IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR.
     *       PTLUST_S( STEP(IROOT)) .NE. 0 ) THEN
          IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW_SON .OR.
     *        NROW_SON*NCOL_SON .EQ. 0)THEN
            NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1
            IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN
              IF (KEEP(201).EQ.1) THEN 
                 CALL CMUMPS_681(IERR)
              ELSEIF (KEEP(201).EQ.2) THEN 
                 CALL CMUMPS_580(IERR)              
              ENDIF
              CALL CMUMPS_507( N, IPOOL, LPOOL,
     *             PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76),
     *             KEEP(80), KEEP(47),
     *             STEP, IROOT + N)
              IF (KEEP(47) .GE. 3) THEN
                 CALL CMUMPS_500(
     $                IPOOL, LPOOL, 
     *                PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
     *                MYID, STEP, N, ND, FILS )
              ENDIF
            ENDIF
          ENDIF
        ELSE
           IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW_SON
     *       .OR.
     *        NROW_SON*NCOL_SON .EQ. 0)THEN
             NBPROCFILS(STEP( IROOT ) ) = -1
           ENDIF
           IF (KEEP(60) == 0) THEN
            CALL CMUMPS_284( root, IROOT, N,
     *                     IW, LIW, A, LA,
     *                     FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR,
     *                     LRLU, IPTRLU,
     *                     IWPOS, IWPOSCB, PTRIST, PTRAST,
     *                     STEP, PIMASTER, PAMASTER, ITLOC,
     *                     COMP, LRLUS, IFLAG, KEEP,KEEP8, IERROR )
            IF ( IFLAG .LT. 0 ) RETURN
           ELSE
             PTRIST(STEP(IROOT)) = -55555
           ENDIF
        END IF
        LREQI = NBROWS_PACKET + NCOL_SON
        LREQA = NBROWS_PACKET * NCOL_SON
        IF ( (LREQA.NE.0) .AND.
     *       (PTRIST(STEP(IROOT)).LT.0).AND.
     *       KEEP(60)==0) THEN
         WRITE(*,*) ' Error in CMUMPS_700'
         CALL MUMPS_ABORT()
        ENDIF
        IF (LREQA.NE.0) THEN
          CALL CMUMPS_22(.FALSE.,0,.FALSE.,.FALSE.,
     *     MYID,N,KEEP,KEEP8,IW,LIW,A, LA,
     *     LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST,
     *     PTRAST, STEP, PIMASTER, PAMASTER, ITLOC,
     *     LREQI, LREQA, -1234, S_NOTFREE, .FALSE.,
     *     COMP, LRLUS, IFLAG, IERROR
     $          )
          IF ( IFLAG .LT. 0 ) RETURN
          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   IW( IWPOSCB + 1 ), LREQI,
     *                   MPI_INTEGER, COMM, IERR )
          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     *                   A( IPTRLU + 1 ), LREQA,
     *                   MPI_COMPLEX, COMM, IERR )
          IF (KEEP(60) .EQ.0) THEN
          IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN
               LOCAL_N  = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ)    )
               LOCAL_M  =  IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ))
               POS_ROOT = PAMASTER(STEP( IROOT ))
          ELSE
               LOCAL_N = IW( PTLUST_S(STEP( IROOT ) ) + 1 + KEEP(IXSZ))
               LOCAL_M = IW( PTLUST_S(STEP( IROOT ) ) + 2 + KEEP(IXSZ))
               POS_ROOT = PTRFAC(IW(PTLUST_S(STEP(IROOT))+4+
     *                    KEEP(IXSZ)))
          END IF
          CALL CMUMPS_38( NBROWS_PACKET, NCOL_SON,
     *                     IW( IWPOSCB + 1 ),
     *                     IW( IWPOSCB + NBROWS_PACKET + 1 ),
     *                     A( IPTRLU + 1 ),
     *                     A( POS_ROOT ), LOCAL_M, LOCAL_N )
          ELSE
          CALL CMUMPS_38( NBROWS_PACKET, NCOL_SON,
     *                     IW( IWPOSCB + 1 ),
     *                     IW( IWPOSCB + NBROWS_PACKET + 1 ),
     *                     A( IPTRLU + 1 ),
     *                     root%SCHUR_POINTER(1),
     *                     root%SCHUR_LLD , root%SCHUR_NLOC)
          ENDIF
          IWPOSCB = IWPOSCB + LREQI
          IPTRLU  = IPTRLU  + LREQA
          LRLU    = LRLU    + LREQA
          LRLUS   = LRLUS   + LREQA
          CALL CMUMPS_471(.FALSE.,.FALSE.,
     *                    LA-LRLUS,0,-LREQA,KEEP,KEEP8,LRLU)
        ENDIF
      RETURN
      END SUBROUTINE CMUMPS_700
      SUBROUTINE CMUMPS_224(NFRONT,NASS,IBEGKJI, LPIV, TIPIV,
     *    N,INODE,IW,LIW,A,LA,
     *    INOPV,NOFFW,IFLAG,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8,
     *     DKEEP,PIVNUL_LIST,LPN_LIST,
     *     PP_FIRST2SWAP_L, PP_LastPanelonDisk_L,
     *     PP_LastPIVRPTRFilled_L,
     *     PP_FIRST2SWAP_U, PP_LastPanelonDisk_U,
     *     PP_LastPIVRPTRFilled_U)
      IMPLICIT NONE
      INTEGER IBEGKJI, LPIV 
      INTEGER TIPIV(LPIV)
      INTEGER NFRONT,NASS,N,LA,LIW,INODE,IFLAG,INOPV,NOFFW
      COMPLEX A(LA) 
      REAL UU, SEUIL
      INTEGER IW(LIW) 
      INTEGER IOLDPS, POSELT
      INTEGER KEEP(500)
      INTEGER*8 KEEP8(150)
      INTEGER LPN_LIST
      INTEGER PIVNUL_LIST(LPN_LIST)
      REAL DKEEP(30)
      INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L,
     *        PP_LastPIVRPTRFilled_L,
     *        PP_FIRST2SWAP_U, PP_LastPanelonDisk_U,
     *        PP_LastPIVRPTRFilled_U
      COMPLEX SWOP
      INTEGER APOS,ILOC
      REAL ZERO, RMAX, AMROW, ONE
      INTEGER NPIV,NASSW,IPIV
      INTEGER NPIVP1,JMAX,J1,J3,JJ,J2,IDIAG,ISW,ISWPS1
      INTEGER ISWPS2,KSW, HF
      INCLUDE 'mumps_headers.h'
      INTEGER CMUMPS_IXAMAX
      INTRINSIC max
      DATA ZERO /0.0E0/
      DATA ONE /1.0E0/
      INTEGER TYPEF_L, I_PIVRPTR_L, I_PIVR_L, NBPANELS_L
      INTEGER TYPEF_U, I_PIVRPTR_U, I_PIVR_U, NBPANELS_U
      INTEGER XSIZE
      PARAMETER (TYPEF_L=1, TYPEF_U=2)
        XSIZE   = KEEP(IXSZ)
        NPIV    = IW(IOLDPS+1+XSIZE)
        HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE
        NPIVP1  = NPIV + 1
        IF (KEEP(201).EQ.1) THEN
          CALL CMUMPS_667(TYPEF_L, NBPANELS_L, 
     *       I_PIVRPTR_L, I_PIVR_L, 
     *       IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE,
     *       IW, LIW)
          CALL CMUMPS_667(TYPEF_U, NBPANELS_U, 
     *       I_PIVRPTR_U, I_PIVR_U, 
     *       IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE,
     *       IW, LIW)
        ENDIF
        ILOC    = NPIVP1 - IBEGKJI + 1
        TIPIV(ILOC) = ILOC
        NASSW   = iabs(IW(IOLDPS+3+XSIZE))
        IF(INOPV .EQ. -1) THEN
           APOS = POSELT + NFRONT*(NPIVP1-1) + NPIV
           IDIAG = APOS
           IF(abs(A(APOS)).LT.SEUIL) THEN
              IF(real(A(APOS)) .GE. ZERO) THEN
                 A(APOS) = SEUIL
              ELSE
                 A(APOS) = -SEUIL
              ENDIF
              KEEP(98) = KEEP(98)+1
           ENDIF
           IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN
             CALL CMUMPS_680( IW(I_PIVRPTR_L), 
     *               NBPANELS_L,
     *               IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, 
     *               PP_LastPanelonDisk_L,
     *               PP_LastPIVRPTRFilled_L)
             CALL CMUMPS_680( IW(I_PIVRPTR_U), 
     *               NBPANELS_U,
     *               IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, 
     *               PP_LastPanelonDisk_U,
     *               PP_LastPIVRPTRFilled_U)
           ENDIF
           GO TO 420
        ENDIF
        INOPV   = 0
          DO 460 IPIV=NPIVP1,NASSW
            APOS = POSELT + NFRONT*(IPIV-1) + NPIV
            JMAX = 1
            IF (UU.GT.ZERO) GO TO 340
            IF (A(APOS).EQ.ZERO) GO TO 630
            GO TO 380
  340       AMROW = ZERO
            J1 = APOS
            J2 = APOS - NPIV + NASS - 1
             J3    = NASS -NPIV
             JMAX  = CMUMPS_IXAMAX(J3,A(J1),1)
             JJ    = JMAX + J1 - 1
             AMROW = abs(A(JJ))
            RMAX = AMROW
            J1 = J2 + 1
            J2 = APOS - NPIV + NFRONT - 1
            IF (J2.LT.J1) GO TO 370
            DO 360 JJ=J1,J2
              RMAX = max(abs(A(JJ)),RMAX)
  360       CONTINUE
  370       IDIAG = APOS + IPIV - NPIVP1
            IF (RMAX.LE.DKEEP(1)) THEN
               KEEP(109) = KEEP(109)+1
               ISW = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ)+
     &                      IW(IOLDPS+5+KEEP(IXSZ))+IPIV-NPIVP1
               PIVNUL_LIST(KEEP(109)) = IW(ISW)
               IF(DKEEP(2).GT.ZERO) THEN
                  IF(real(A(IDIAG)) .GE. ZERO) THEN
                     A(IDIAG) = DKEEP(2)
                  ELSE
                     A(IDIAG) = -DKEEP(2)
                  ENDIF
               ELSE
                 J1 = APOS
                 J2 = APOS - NPIV + NFRONT - 1
                 DO JJ=J1,J2
                   A(JJ)= cmplx(ZERO)
                 ENDDO
                 A(IDIAG) = cmplx(ONE)
               ENDIF
               JMAX = IPIV - NPIV
               GOTO 380   
            ENDIF
            IF (abs(A(IDIAG)).GT.max(UU*RMAX,SEUIL)) THEN
               JMAX = IPIV - NPIV
               GO TO 380
            ENDIF
            IF (AMROW.LE.max(UU*RMAX,SEUIL)) GO TO 460
            NOFFW = NOFFW + 1
  380       IF (IPIV.EQ.NPIVP1) GO TO 400
            J1 = POSELT + NPIV*NFRONT
            J2 = J1 + NFRONT - 1
            J3 = POSELT + (IPIV-1)*NFRONT
            DO 390 JJ=J1,J2
              SWOP = A(JJ)
              A(JJ) = A(J3)
              A(J3) = SWOP
              J3 = J3 + 1
  390       CONTINUE
            ISWPS1 = IOLDPS + HF - 1 + NPIVP1
            ISWPS2 = IOLDPS + HF - 1 + IPIV
            ISW = IW(ISWPS1)
            IW(ISWPS1) = IW(ISWPS2)
            IW(ISWPS2) = ISW
  400       IF (JMAX.EQ.1) GO TO 420
            TIPIV(ILOC) = ILOC + JMAX - 1
            J1 = POSELT + NPIV
            J2 = POSELT + NPIV + JMAX - 1
            DO 410 KSW=1,NASS
              SWOP = A(J1)
              A(J1) = A(J2)
              A(J2) = SWOP
              J1 = J1 + NFRONT
              J2 = J2 + NFRONT
  410       CONTINUE
            ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1
            ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX
            ISW = IW(ISWPS1)
            IW(ISWPS1) = IW(ISWPS2)
            IW(ISWPS2) = ISW
            GO TO 420  
  460     CONTINUE
      IF (NASSW.EQ.NASS) THEN
       INOPV = 1
      ELSE
       INOPV = 2
      ENDIF
      GO TO 430
  630 CONTINUE
      IFLAG = -10
      WRITE(*,*) 'NIV2:Detected 0 pivot, INODE,NPIV=',INODE,NPIV
      GOTO 430
  420 CONTINUE
              IF (KEEP(201).EQ.1) THEN
                CALL CMUMPS_680( IW(I_PIVRPTR_L), 
     *               NBPANELS_L,
     *               IW(I_PIVR_L), NASS, NPIVP1, IPIV, 
     *               PP_LastPanelonDisk_L,
     *               PP_LastPIVRPTRFilled_L)
                CALL CMUMPS_680( IW(I_PIVRPTR_U), 
     *               NBPANELS_U,
     *               IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, 
     *               PP_LastPanelonDisk_U,
     *               PP_LastPIVRPTRFilled_U)
              ENDIF
  430 CONTINUE
      RETURN
      END SUBROUTINE CMUMPS_224
      SUBROUTINE  CMUMPS_294( COMM_LOAD, ASS_IRECV, 
     *             N, INODE, FPERE,
     *             IW, LIW, 
     *             IOLDPS, POSELT, A, LA, LDA_FS, 
     *             IBEGKJI, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC,
     *
     *             COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF,
     *             IFLAG, IERROR, IPOOL,LPOOL, 
     *             SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU,
     *             LRLUS, COMP,
     *             PTRIST, PTRAST, PTLUST_S, PTRFAC,
     *             STEP, PIMASTER, PAMASTER,
     *             NSTK_S,NBPROCFILS,PROCNODE_STEPS, root,
     *             OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *             INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE,
     *             LPTRAR, NELT, FRTPTR, FRTELT, 
     *             ISTEP_TO_INIV2, TAB_POS_IN_PERE )
      USE CMUMPS_COMM_BUFFER
      USE CMUMPS_LOAD
      IMPLICIT NONE
      INCLUDE 'cmumps_root.h'
      INCLUDE 'mpif.h'
      TYPE (CMUMPS_ROOT_STRUC) :: root
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER N, INODE, FPERE, LIW, IBEGKJI, IEND, LPIV, 
     *        IOLDPS, POSELT, LA, LDA_FS, NB_BLOC_FAC
      INTEGER IW(LIW), TIPIV(LPIV)
      LOGICAL LASTBL
      COMPLEX A(LA)
      INTEGER COMM, MYID, LBUFR, LBUFR_BYTES
      INTEGER NELT, LPTRAR
      INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 
      INTEGER KEEP(500)
      INTEGER*8 KEEP8(150)
      INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL,
     *        SLAVEF, ICNTL(40)
      INTEGER POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, 
     *        COMP
      INTEGER BUFR( LBUFR ), IPOOL(LPOOL),
     *        ITLOC(N), FILS(N),
     *        PTRARW(LPTRAR), PTRAIW(LPTRAR), 
     *        ND( KEEP(28) ), FRERE( KEEP(28) )
      INTEGER INTARR(max(1,KEEP(14)))
      INTEGER PTRIST(KEEP(28)), PTRAST(KEEP(28)), PTLUST_S(KEEP(28)),
     *        PTRFAC(KEEP(28)),
     *        STEP(N), 
     * PIMASTER(KEEP(28)),
     *  PAMASTER(KEEP(28)), NSTK_S(KEEP(28)),
     *        NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28))
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     *        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      DOUBLE PRECISION OPASSW, OPELIW
      COMPLEX DBLARR(max(1,KEEP(13)))
      EXTERNAL  CMUMPS_329
      INCLUDE 'mumps_headers.h'
      INTEGER NPIV, NCOL, APOS, PDEST, NSLAVES
      INTEGER IERR, IERR_MPI, LREQA, LREQI
      INTEGER STATUS( MPI_STATUS_SIZE )
      LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      DOUBLE PRECISION FLOP1,FLOP2
      NSLAVES= IW(IOLDPS+5+KEEP(IXSZ))
          IF (NSLAVES.EQ.0) THEN
           WRITE(6,*) ' ERROR 1 in CMUMPS_294 '
           CALL MUMPS_ABORT()
          ENDIF
      NPIV   = IEND - IBEGKJI + 1
      NCOL   = LDA_FS - IBEGKJI + 1
      APOS   = POSELT + LDA_FS*(IBEGKJI-1) + IBEGKJI - 1
      IF (IBEGKJI > 0) THEN
       CALL MUMPS_511( LDA_FS, IBEGKJI-1, LPIV,
     *                            KEEP(50),2,FLOP1)
      ELSE
        FLOP1=0
      ENDIF
      CALL MUMPS_511( LDA_FS, IEND, LPIV,
     *                           KEEP(50),2,FLOP2)
      FLOP2 = FLOP1 - FLOP2
      CALL CMUMPS_190(1, .FALSE., FLOP2, KEEP,KEEP8)
      IF ((NPIV.GT.0) .OR. 
     *    ((NPIV.EQ.0).AND.(LASTBL)) ) THEN
        PDEST  = IOLDPS + 6 + KEEP(IXSZ)
        IERR = -1
        IF ( NPIV .NE. 0 ) THEN
          NB_BLOC_FAC = NB_BLOC_FAC + 1
        END IF
        DO WHILE (IERR .EQ.-1)
          CALL CMUMPS_65( INODE, LDA_FS, NCOL, 
     *               NPIV, FPERE, LASTBL, TIPIV, A(APOS),
     *               IW(PDEST), NSLAVES, KEEP(50), NB_BLOC_FAC,
     *               COMM, IERR )
        IF (IERR.EQ.-1) THEN
           BLOCKING  = .FALSE.
           SET_IRECV = .TRUE.
           MESSAGE_RECEIVED = .FALSE.
           CALL CMUMPS_329( COMM_LOAD, ASS_IRECV, 
     *      BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
     *      MPI_ANY_SOURCE, MPI_ANY_TAG,
     *      STATUS, BUFR, LBUFR,
     *      LBUFR_BYTES,
     *      PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU,
     *      LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     *      PTLUST_S, PTRFAC,
     *      PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG,
     *      IERROR, COMM,
     *      NBPROCFILS,
     *      IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     *      root, OPASSW, OPELIW, ITLOC, FILS, PTRARW, PTRAIW,
     *      INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE,
     *      LPTRAR, NELT, FRTPTR, FRTELT, 
     *      ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. )
           IF (MESSAGE_RECEIVED) POSELT = PTRAST(STEP(INODE))
           IF ( IFLAG .LT. 0 ) GOTO 500
         ENDIF
        ENDDO
        IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN
          IF (IERR.EQ.-2) IFLAG = -17
          IF (IERR.EQ.-3) IFLAG = -20
          LREQA = NCOL*NPIV  
          LREQI = NPIV + 6 + 2*NSLAVES
          IERROR =  LREQI  * KEEP( 34 )+ LREQA * KEEP( 35 )
          GOTO 300
        ENDIF
      ENDIF
      GOTO 500
  300 CONTINUE
      CALL CMUMPS_44( MYID, SLAVEF, COMM )
 500  RETURN
      END SUBROUTINE  CMUMPS_294
      SUBROUTINE CMUMPS_273( ROOT, 
     *    INODE, NELIM, NSLAVES, ROW_LIST,
     *    COL_LIST, SLAVE_LIST, 
     *
     *    PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU,
     *    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     *    PTLUST_S, PTRFAC,
     *    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, ITLOC, COMP,
     *    IFLAG, IERROR, 
     *    IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8,
     *    COMM,COMM_LOAD,FILS,ND )
      USE CMUMPS_LOAD
      IMPLICIT NONE
      INCLUDE 'cmumps_root.h'
      TYPE (CMUMPS_ROOT_STRUC) :: ROOT
      INTEGER INODE, NELIM, NSLAVES 
      INTEGER KEEP( 500 )
      INTEGER*8 KEEP8(150)
      INTEGER ROW_LIST(*), COL_LIST(*), 
     *        SLAVE_LIST(*)
      INTEGER IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS
      INTEGER N, LIW, LA
      INTEGER IW( LIW )
      COMPLEX A( LA )
      INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)), PTRFAC(KEEP(28))
      INTEGER PTRAST(KEEP(28))
      INTEGER STEP(N), 
     * PIMASTER(KEEP(28)),
     *  PAMASTER(KEEP(28))
      INTEGER COMP
      INTEGER NSTK_S(KEEP(28)), ITLOC( N ), PROCNODE_STEPS( KEEP(28) )
      INTEGER IFLAG, IERROR
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER MYID, SLAVEF
      INTEGER COMM,COMM_LOAD,ND(KEEP(28)),FILS(N)
      INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL,
     *        NOINT, NOREAL
      INCLUDE 'mumps_headers.h'
      INCLUDE 'mumps_tags.h'
      INTEGER MUMPS_330
      EXTERNAL MUMPS_330
      IROOT        = KEEP(38)
      NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1
      KEEP(42) = KEEP(42) + NELIM
      TYPE_INODE= MUMPS_330(STEP(INODE), PROCNODE_STEPS, SLAVEF)
      IF (TYPE_INODE.EQ.1) THEN 
        IF (NELIM.EQ.0) THEN
         KEEP(41) = KEEP(41) + 1
        ELSE 
         KEEP(41) = KEEP(41) + 3
        ENDIF
      ELSE
        IF (NELIM.EQ.0) THEN
         KEEP(41) = KEEP(41) + NSLAVES
        ELSE 
         KEEP(41) = KEEP(41) + 2*NSLAVES + 1
        ENDIF
      ENDIF
      IF  (NELIM.EQ.0) THEN
        PIMASTER(STEP(INODE)) = 0 
      ELSE
       NOINT = 6 + NSLAVES + NELIM  + NELIM + KEEP(IXSZ)
       NOREAL= 0
       CALL CMUMPS_22(.FALSE.,0,.FALSE.,.FALSE.,
     *   MYID,N,KEEP,KEEP8,IW,LIW, A, LA,
     *   LRLU, IPTRLU,IWPOS,IWPOSCB,
     *   PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, ITLOC,
     *   NOINT, NOREAL, INODE, S_NOTFREE, .TRUE.,
     *   COMP, LRLUS, IFLAG, IERROR
     $      )
       IF ( IFLAG .LT. 0 ) THEN
         WRITE(*,*) ' Failure in int space allocation in CB area ',
     *    ' during assembly of root : CMUMPS_273',
     *    ' size required was :', NOINT,
     *    'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES
         RETURN
        ENDIF
        PIMASTER(STEP( INODE )) = IWPOSCB + 1
        PAMASTER(STEP( INODE )) = IPTRLU  + 1
        IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM
        IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM
        IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0
        IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0
        IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1
        IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES
        IF (NSLAVES.GT.0) THEN
         IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = 
     *                   SLAVE_LIST(1:NSLAVES)
        ENDIF
        DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ)
        IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM)
        DEB_COL = DEB_ROW + NELIM
        IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM)
      ENDIF
      IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN
          CALL CMUMPS_507(N, IPOOL, LPOOL, PROCNODE_STEPS,
     *         SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47),
     *         STEP, IROOT )
          IF (KEEP(47) .GE. 3) THEN
             CALL CMUMPS_500(
     $            IPOOL, LPOOL, 
     *            PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
     *            MYID, STEP, N, ND, FILS )
          ENDIF
      END IF
      RETURN
      END SUBROUTINE CMUMPS_273
      SUBROUTINE CMUMPS_534( N,FRERE, FILS,
     *     NA,NE,ND,PERM,SYM,INFO,LP,K47,K81,K215,K234,K55,
     *     PROCNODE,SLAVEF,PEAK
     $     )
      IMPLICIT NONE
      INTEGER N,PERM,SYM, LP, SIZE_MEM_SBTR
      INTEGER FRERE(N), FILS(N)
      INTEGER NA(N), NE(N), ND(N),K47,K81,K215,K234,K55
      INTEGER INFO(40)
      INTEGER SLAVEF,PROCNODE(N)
      REAL PEAK
      INTEGER NBROOT, NBLEAF, LNA, allocok, LEAF, I, NSTEPS,
     *        K47_LOC, K81_LOC
      INTEGER, ALLOCATABLE, DIMENSION (:) :: NEW_NA, STEP
      INTEGER TEMP_MEM(1),SBTR_WHICH_M
      INTEGER, ALLOCATABLE, DIMENSION (:,:) :: MEM_SUBTREE,MY_ROOT,
     $     MY_SIZE,MY_LEAF
      INTEGER, ALLOCATABLE, DIMENSION (:) ::      DEPTH_FIRST
      REAL, ALLOCATABLE, DIMENSION (:) :: COST_TRAV
      INTEGER DUMMY_DAD(1), DUMMY_DAD_LENGTH
      PARAMETER (DUMMY_DAD_LENGTH=1)
      LOGICAL USE_DAD
      PARAMETER (USE_DAD=.FALSE.)
      INCLUDE 'mumps_headers.h'
      IF (N.EQ.1) THEN
        NBROOT = 1
        NBLEAF = 1 
      ELSEIF (NA(N).LT.0) THEN
        NBLEAF = N
        NBROOT = N
      ELSEIF (NA(N-1).LT.0) THEN
        NBLEAF = N-1
        NBROOT = NA(N)
      ELSE
        NBLEAF = NA(N-1)
        NBROOT = NA(N)
      ENDIF
      LNA = NBROOT + NBLEAF + 2
      ALLOCATE (NEW_NA (LNA), STEP(N), stat=allocok)
      IF (allocok > 0 ) THEN
        INFO(1) = -7
        INFO(2) = LNA + N
        RETURN
      ENDIF
      NEW_NA(1)=NBLEAF
      NEW_NA(2)=NBROOT
      LEAF = 3
      IF ( N == 1 ) THEN
          NEW_NA(LEAF) = 1
          LEAF = LEAF + 1
      ELSE IF (NA(N) < 0) THEN
          NEW_NA(LEAF) = - NA(N)-1
          LEAF = LEAF + 1
          DO I = 1, NBLEAF - 1
            NEW_NA(LEAF) = NA(I)
            LEAF = LEAF + 1
          ENDDO
      ELSE IF (NA(N-1) < 0 ) THEN
          NEW_NA(LEAF) = - NA(N-1) - 1
          LEAF =LEAF + 1
          IF ( NBLEAF > 1 ) THEN
            DO I = 1, NBLEAF - 1
              NEW_NA(LEAF) = NA(I)
              LEAF = LEAF + 1
            ENDDO
          ENDIF
      ELSE
          DO I = 1, NBLEAF
            NEW_NA(LEAF) = NA(I)
            LEAF = LEAF + 1
          ENDDO
      END IF
      SIZE_MEM_SBTR=NEW_NA(2)
      ALLOCATE(MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF),stat=allocok) 
      IF (allocok .ne.0) THEN
         INFO(1)= -7
         INFO(2)= SIZE_MEM_SBTR*SLAVEF
         RETURN
      ENDIF
      ALLOCATE(MY_ROOT(SIZE_MEM_SBTR,SLAVEF),stat=allocok) 
      IF (allocok .ne.0) THEN
         INFO(1)= -7
         INFO(2)= SIZE_MEM_SBTR*SLAVEF
         RETURN
      ENDIF
      ALLOCATE(MY_LEAF(SIZE_MEM_SBTR,SLAVEF),stat=allocok) 
      IF (allocok .ne.0) THEN
         INFO(1)= -7
         INFO(2)= SIZE_MEM_SBTR*SLAVEF
         RETURN
      ENDIF
      ALLOCATE(MY_SIZE(SIZE_MEM_SBTR,SLAVEF),stat=allocok) 
      IF (allocok .ne.0) THEN
         INFO(1)= -7
         INFO(2)= SIZE_MEM_SBTR*SLAVEF
         RETURN
      ENDIF
      DO I = 1, N
        STEP(I)=I
        IF ( FRERE(I) .EQ. 0 ) THEN
          NEW_NA(LEAF) = I
          LEAF = LEAF + 1
        END IF
      END DO
      NSTEPS = N
      K47_LOC = 0
      K81_LOC = 0
      SBTR_WHICH_M=0
      ALLOCATE(DEPTH_FIRST(1),stat=allocok) 
      IF (allocok .ne.0) THEN
         INFO(1)= -7
         INFO(2)= 1
         RETURN
      ENDIF
      ALLOCATE(COST_TRAV(1),stat=allocok) 
      IF (allocok .ne.0) THEN
         INFO(1)= -7
         INFO(2)= 1
         RETURN
      ENDIF
      CALL CMUMPS_363(N,FRERE, STEP, FILS,
     *     NEW_NA,LNA,NE,ND,
     *     DUMMY_DAD, DUMMY_DAD_LENGTH, USE_DAD,
     *     NSTEPS,PERM,SYM,INFO,LP,K47_LOC,K81_LOC,0,K215,K234,K55,
     *     PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK,SBTR_WHICH_M
     $     ,1,1,DEPTH_FIRST,COST_TRAV,MY_LEAF,MY_SIZE,MY_ROOT
     *)
      NA(1:NBLEAF)=NEW_NA(3:2+NBLEAF)
      NA(N)=NBROOT
      IF (N.GT.1) THEN
       IF (NBLEAF.GT.N-2) THEN
        IF (NBLEAF.EQ.N-1) THEN
         NA(N-1) = -NA(N-1)-1
         NA(N)   = NBROOT
        ELSE
         NA(N) = -NA(N)-1
        ENDIF
       ELSE
        NA(N-1) = NBLEAF
        NA(N)   = NBROOT
       ENDIF
      ENDIF
      DEALLOCATE(MEM_SUBTREE)
      DEALLOCATE(NEW_NA,STEP)
      DEALLOCATE(DEPTH_FIRST,COST_TRAV)
      DEALLOCATE(MY_LEAF,MY_SIZE,MY_ROOT)
      RETURN
      END SUBROUTINE CMUMPS_534
      SUBROUTINE CMUMPS_363(N,FRERE, STEP, FILS,
     *     NA,LNA,NE,ND, DAD, LDAD, USE_DAD,
     *     NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,
     *     PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK
     $     ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV,
     $     DEPTH_FIRST_TRAV,COST_TRAV,MY_FIRST_LEAF,
     $     MY_NB_LEAF,MY_ROOT_SBTR
     $     )
      IMPLICIT NONE
      INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD
      INTEGER FRERE(NSTEPS), FILS(N), STEP(N)
      INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS)
      INTEGER K47,K81,K76,K215,K234,K55
      INTEGER DAD(LDAD)
      LOGICAL USE_DAD
      INTEGER INFO(40)
      INTEGER SLAVEF,PROCNODE(NSTEPS)
      INTEGER MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF),SBTR_WHICH_M
      INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF),
     $     MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF),
     $     MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF)
      EXTERNAL MUMPS_283,MUMPS_275
      LOGICAL MUMPS_283
      INTEGER MUMPS_275
      REAL PEAK
      INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST)
      INTEGER SIZE_COST_TRAV
      REAL COST_TRAV(SIZE_COST_TRAV)
      INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH
      INTEGER ITOP,IFATH,IN,LSTK,NSTK,INODE,K,I,allocok,LOCAL_PERM
      INTEGER*8 NCB
      INTEGER*8 NELIM,NFR
      INTEGER NFR4,NELIM4
      INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB
      INTEGER, DIMENSION (:), ALLOCATABLE :: ROOT,IPOOL,TNSTK
      INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP
      INTEGER*8, DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact
      INTEGER*8, DIMENSION (:), ALLOCATABLE :: TAB1,TAB2
      INTEGER, DIMENSION (:), POINTER :: TAB
      INTEGER J,x,y,z,dernier,fin,RANK_TRAV
      INTEGER cour,t,II,temporary
      INTEGER actuel,CB_current,CB_MAX,ROOT_OF_CUR_SBTR
      INTEGER*8, DIMENSION (:), ALLOCATABLE :: T1,T2
      INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT
      INTEGER*8 MEM_SIZE,FACT_SIZE,SUM,MEM_SEC_PERM,FACT_SIZE_T,
     $     MEM_SIZE_T,TOTAL_MEM_SIZE,TMP_TOTAL_MEM_SIZE,TMP_SUM,
     $     SIZECB, SIZECB_LASTSON
      INTEGER*8 TMP8
      LOGICAL   SBTR_M
      INTEGER INDICE(SLAVEF),ID,FIRST_LEAF,SIZE_SBTR
      EXTERNAL MUMPS_170,MUMPS_167
      LOGICAL MUMPS_170,MUMPS_167
      DOUBLE PRECISION COST_NODE
      INCLUDE 'mumps_headers.h'
      TOTAL_MEM_SIZE=0
      ROOT_OF_CUR_SBTR=0
      IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.
     $     (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR.
     $     (PERM.EQ.5).OR.(PERM.EQ.6))THEN
         LOCAL_PERM=0
      ENDIF
      IF (K47 == 4 .OR. ((K47.GE.2).AND.(K81.GE. 1))) THEN
        DO I=1,SLAVEF
          INDICE(I)=1
        ENDDO
        DO I=1,SLAVEF
          DO x=1,SIZE_MEM_SBTR
            MEM_SUBTREE(x,I)=-1
          ENDDO
        ENDDO
      ENDIF
      SBTR_M=((K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))
      MEM_SIZE=0
      FACT_SIZE=0
      IF ((PERM.GT.7).AND.
     * (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN
         WRITE(*,*) "Internal Error in CMUMPS_363",PERM
         CALL MUMPS_ABORT()
      END IF
      NBLEAF = NA(1)
      NBROOT = NA(2)
      IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN
      IF (SBTR_M.OR.(PERM.EQ.2))  THEN
         IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN
            ALLOCATE(M_TOTAL(NSTEPS), stat=allocok )
            IF (allocok > 0) THEN
               IF ( LP .GT. 0 )
     *              WRITE(LP,*)'Memory allocation error in
     $              CMUMPS_363'
               INFO(1)=-7
               INFO(2)=NSTEPS
               RETURN
            ENDIF
         ENDIF
      ENDIF
      ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS),
     *          TNSTK(NSTEPS), stat=allocok )
      IF (allocok > 0) THEN
        IF ( LP .GT. 0 )
     *    WRITE(LP,*)'Memory allocation error in CMUMPS_363'
        INFO(1)=-7
        INFO(2)=NSTEPS
        RETURN
      ENDIF
      II=0
      DO I=1,NSTEPS
         TNSTK(I) = NE(I)
         IF(NE(I).GE.II) II=NE(I)
      ENDDO
      SIZE_TAB=max(II,NBROOT)
      ALLOCATE(SON(II), TEMP(II),
     *         TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok )
      IF (allocok > 0) THEN
        IF ( LP .GT. 0 )
     *    WRITE(LP,*)'Memory allocation error in CMUMPS_363'
        INFO(1)=-7
        INFO(2)=NSTEPS
        RETURN
      ENDIF
      ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB),
     *         RESULT(SIZE_TAB),stat=allocok)
      IF (allocok > 0) THEN
        IF ( LP .GT. 0 )
     *    WRITE(LP,*)'Memory allocation error in CMUMPS_363'
        INFO(1)=-7
        INFO(2)=SIZE_TAB
        RETURN
      ENDIF
      IF(NBROOT.EQ.NBLEAF)THEN
        IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN
          WRITE(*,*)'Internal Error in reordertree:'
          WRITE(*,*)'  problem with perm parameter in reordertree'
          CALL MUMPS_ABORT()
        ENDIF
        DO I=1,NBROOT
          TAB1(I)=ND(STEP(NA(I+2+NBLEAF)))
          IPOOL(I)=NA(I+2+NBLEAF)
          M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I)
        ENDDO
        CALL CMUMPS_462(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4,
     &    RESULT,T1,T2)
        GOTO 789
      ENDIF
      IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN
         ALLOCATE(DEPTH(NSTEPS),stat=allocok)
         IF (allocok > 0) THEN
            IF ( LP .GT. 0 )
     *           WRITE(LP,*)'Memory allocation error in
     $           CMUMPS_363'
            INFO(1)=-7
            INFO(2)=NSTEPS
            RETURN
         ENDIF
         DEPTH=0
         NBROOT = NA(2)
         IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT)
         fin=NBROOT
         LEAF=NA(1)
 499     CONTINUE
         INODE=IPOOL(fin)
         IF(INODE.LT.0)THEN
            WRITE(*,*)'Internal Error in reordertree INODE < 0 !'
            CALL MUMPS_ABORT()
         ENDIF
         IN=INODE
 4602    IN = FILS(IN)
         IF (IN .GT. 0 ) THEN
            GOTO 4602
         ENDIF
         IN=-IN
         DO I=1,NE(STEP(INODE))
            SON(I)=IN
            IN=FRERE(STEP(IN))
         ENDDO
         DO I=1,NE(STEP(INODE))
            IPOOL(fin)=SON(I)
            DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1
            SON(I)=0
            fin=fin+1
         ENDDO
         IF(NE(STEP(INODE)).EQ.0)THEN
            LEAF=LEAF-1
         ELSE
            fin=fin-1
            GOTO 499
         ENDIF
         fin=fin-1
         IF(fin.EQ.0) GOTO 489
         GOTO 499
 489     CONTINUE
      ENDIF
      IF(K76.EQ.4)THEN
         RANK_TRAV=NSTEPS
         DEPTH_FIRST_TRAV=0
      ENDIF
      IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN
         COST_TRAV=0.0E0
         COST_NODE=0.0E0
      ENDIF        
      DO I=1,NSTEPS
         M(I)=0
         IF (SBTR_M.OR.(PERM.EQ.2))  THEN
            IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN
               M_TOTAL(I)=0
            ENDIF
         ENDIF
      ENDDO
      DO I=1,NSTEPS
         fact(I)=0
      ENDDO
      IPOOL(1:NBLEAF)=NA(3:2+NBLEAF)
      LEAF = NBLEAF + 1
 91   CONTINUE
        IF (LEAF.NE.1) THEN
           LEAF = LEAF -1
           INODE = IPOOL(LEAF)
        ENDIF
 96     CONTINUE
        NFR    = ND(STEP(INODE))
        NSTK   = NE(STEP(INODE))
        NELIM4 = 0
        IN = INODE
 101    NELIM4 = NELIM4 + 1
        IN = FILS(IN)
        IF (IN .GT. 0 ) GOTO 101
        NELIM=NELIM4
        IF(NE(STEP(INODE)).EQ.0) THEN
           M(STEP(INODE))=NFR*NFR
           IF (SBTR_M.OR.(PERM.EQ.2))  THEN
                 M_TOTAL(STEP(INODE))=NFR*NFR
           ENDIF
        ENDIF
        IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN
           IF(MUMPS_170(STEP(INODE),
     $PROCNODE,SLAVEF))THEN
              DEPTH(STEP(INODE))=0
           ENDIF
        ENDIF
        IF ( SYM .eq. 0 ) THEN
          fact(STEP(INODE))=fact(STEP(INODE))+
     &      (2*NFR*NELIM)-(NELIM*NELIM)
        ELSE
          fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM
        ENDIF
        IF (USE_DAD) THEN
          IFATH = DAD( STEP(INODE) )
        ELSE
          IN = INODE
 113      IN = FRERE(IN)
          IF (IN.GT.0) GO TO 113
          IFATH = -IN
        ENDIF
        IF (IFATH.EQ.0) THEN
           NBROOT = NBROOT - 1
           IF (NBROOT.EQ.0) GOTO 116
           GOTO 91
        ELSE
           fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE))
           IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN
              DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)),
     $             DEPTH(STEP(IFATH)))
           ENDIF
        ENDIF
        TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1
        IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN
           INODE = IFATH        
           IN=INODE
           dernier=IN
           I=1
 5700      IN = FILS(IN)
           IF (IN .GT. 0 ) THEN
             dernier=IN
             I=I+1
             GOTO 5700
           ENDIF
           NCB=ND(STEP(INODE))-I
           IN=-IN
           IF(PERM.NE.7)THEN
              DO I=1,NE(STEP(INODE))
                 SON(I)=IN
                 TEMP(I)=IN
                 IF(IN.GT.0) IN=FRERE(STEP(IN))
              ENDDO
           ELSE
              DO I=NE(STEP(INODE)),1,-1
                 SON(I)=IN
                 TEMP(I)=IN
                 IF(IN.GT.0) IN=FRERE(STEP(IN))
              ENDDO
           ENDIF
           IF(PERM.EQ.7) GOTO 213
           NFR = ND(STEP(INODE))
           DO II=1,NE(STEP(INODE))
             TAB1(II)=0
             TAB2(II)=0
             cour=SON(II)
             NELIM4=1
 151         cour=FILS(cour)
             IF(cour.GT.0) THEN
                NELIM4=NELIM4+1
                GOTO 151
             ENDIF
             NELIM=NELIM4
             IF((SYM.EQ.0).OR.(K215.NE.0)) THEN
                SIZECB=(ND(STEP(SON(II)))-NELIM)*
     $               (ND(STEP(SON(II)))-NELIM)
             ELSE
                SIZECB=(ND(STEP(SON(II)))-NELIM)*(ND(STEP(SON(II)))-
     $               NELIM+1)/2
             ENDIF
             IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN
                IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN
                   TMP8=NFR
                   TMP8=TMP8*TMP8
                   TAB1(II)=MAX(TMP8, M(STEP(SON(II)))) - SIZECB
                   TAB2(II)=SIZECB
                ELSE
                   TAB1(II)=M(STEP(SON(II)))- SIZECB
                   TAB2(II)=SIZECB
                ENDIF
             ENDIF
             IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN
                TAB1(II)=M(STEP(SON(II)))-SIZECB
                TAB1(II)=TAB1(II)-fact(STEP(SON(II)))
                TAB2(II)=SIZECB+fact(STEP(SON(II)))
             ENDIF
             IF(PERM.EQ.2)THEN
                IF (MUMPS_170(STEP(INODE),
     $               PROCNODE,SLAVEF))THEN
                   TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB
     $                  -fact(STEP(SON(II)))
                   TAB2(II)=SIZECB
                ELSE
                   TAB1(II)=M(STEP(SON(II)))-SIZECB
                   TAB2(II)=SIZECB             
                ENDIF
             ENDIF
             IF(PERM.EQ.3)THEN
                IF (MUMPS_170(STEP(INODE),
     $               PROCNODE,SLAVEF))THEN
                   TAB1(II)=M(STEP(SON(II)))-SIZECB
                   TAB2(II)=SIZECB               
                ELSE
                   TAB1(II)=DEPTH(STEP(SON(II)))
                   TAB2(II)=M(STEP(SON(II)))
                ENDIF
             ENDIF
             IF(PERM.EQ.4)THEN
                IF (MUMPS_170(STEP(INODE),
     $               PROCNODE,SLAVEF))THEN
                   TAB1(II)=M(STEP(SON(II)))-
     &                  SIZECB-fact(STEP(SON(II)))
                   TAB2(II)=SIZECB             
                ELSE
                   TAB1(II)=DEPTH(STEP(SON(II)))
                   TAB2(II)=M(STEP(SON(II)))
                ENDIF
             ENDIF
          ENDDO
          CALL CMUMPS_462(SON,NE(STEP(INODE)),TAB1,TAB2,
     $         LOCAL_PERM
     &           ,RESULT,T1,T2)
          IF(PERM.EQ.0) THEN
             DO II=1,NE(STEP(INODE))
               cour=TEMP(II)
               NELIM4=1
 153           cour=FILS(cour)
               IF(cour.GT.0) THEN
                  NELIM4=NELIM4+1
                  GOTO 153
               ENDIF
               NELIM=NELIM4
               IF((SYM.EQ.0).OR.(K215.NE.0))THEN
                  SIZECB=(ND(STEP(TEMP(II)))-NELIM)*
     $                 (ND(STEP(TEMP(II)))-NELIM)
               ELSE
                  SIZECB=(ND(STEP(TEMP(II)))-NELIM)*
     $                 (ND(STEP(TEMP(II)))-NELIM+1)/2
               ENDIF
               TAB1(II)=SIZECB
             ENDDO
             CALL CMUMPS_462(TEMP,NE(STEP(INODE)),TAB1,TAB2,3,
     &         RESULT,T1,T2)             
           ENDIF
           IF(PERM.EQ.1) THEN
              DO II=1,NE(STEP(INODE))
                cour=TEMP(II)
                NELIM4=1
 187            cour=FILS(cour)
                IF(cour.GT.0) THEN
                   NELIM4=NELIM4+1
                   GOTO 187
                ENDIF    
                NELIM=NELIM4   
                IF((SYM.EQ.0).OR.(K215.NE.0))THEN
                   SIZECB=(ND(STEP(TEMP(II)))-NELIM)*
     $                  (ND(STEP(TEMP(II)))-NELIM)
                ELSE
                   SIZECB=(ND(STEP(TEMP(II)))-NELIM)*
     $                  (ND(STEP(TEMP(II)))-NELIM+1)/2
                ENDIF
                TAB1(II)=SIZECB+fact(STEP(TEMP(II)))
             ENDDO
             CALL CMUMPS_462(TEMP,NE(STEP(INODE)),TAB1,TAB2,3,
     &         RESULT,T1,T2)
           ENDIF
 213       CONTINUE
           IFATH=INODE
           DO II=1,2
              SUM=0
              FACT_SIZE=0
              FACT_SIZE_T=0
              MEM_SIZE=0
              MEM_SIZE_T=0
              CB_MAX=0
              CB_current=0
              TMP_SUM=0
              IF(II.EQ.1) TAB=>SON 
              IF(II.EQ.2) TAB=>TEMP
              DO I=1,NE(STEP(INODE))
                 cour=TAB(I)
                 NELIM4=1
 149             cour=FILS(cour)
                 IF(cour.GT.0) THEN
                    NELIM4=NELIM4+1
                    GOTO 149
                 ENDIF    
                 NELIM=NELIM4   
                 NFR=ND(STEP(TAB(I)))
                 IF((SYM.EQ.0).OR.(K215.NE.0))THEN
                    SIZECB=(NFR-NELIM)*(NFR-NELIM)
                 ELSE
                    SIZECB=(NFR-NELIM)*(NFR-NELIM+1)/2
                 ENDIF
                 MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE))
                 IF (SBTR_M.OR.(PERM.EQ.2)) THEN
                       MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+
     $                      SUM+
     $                      FACT_SIZE_T))
                       FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I)))
                 ENDIF
                 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE,
     $                (M(STEP(TAB(I)))+SUM+FACT_SIZE))
                 TMP_SUM=TMP_SUM+fact(STEP(TAB(I)))
                 SUM=SUM+SIZECB
                 SIZECB_LASTSON = SIZECB
                 IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN
                    FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I)))
                 ENDIF
              ENDDO
              IF((SYM.EQ.0).OR.(K215.NE.0))THEN
                 SIZECB=NCB*NCB
              ELSE
                 SIZECB=NCB*(NCB+1)/2
              ENDIF
              IF (K234.NE.0 .AND. K55.EQ.0) THEN
                 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE,((ND(STEP(IFATH))
     $                *ND(STEP(IFATH)))+SUM-SIZECB_LASTSON+TMP_SUM))
              ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN
                 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE,((ND(STEP(IFATH))
     $                *ND(STEP(IFATH)))+SUM+TMP_SUM))
              ELSE
                 TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE,((ND(STEP(IFATH))
     $                *ND(STEP(IFATH)))+max(SUM,SIZECB)+TMP_SUM))
              ENDIF
              IF(II.EQ.1)THEN
                 TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE
              ENDIF
              IF((II.EQ.1).OR.(PERM.EQ.7)) THEN
                 IF (K234.NE.0 .AND. K55.EQ.0) THEN
                   M(STEP(IFATH))=max(MEM_SIZE,((ND(STEP(IFATH))
     $             *ND(STEP(IFATH)))+SUM-SIZECB_LASTSON+
     $             FACT_SIZE))
                 ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN
                   M(STEP(IFATH))=max(MEM_SIZE,((ND(STEP(IFATH))
     $             *ND(STEP(IFATH)))+SUM+FACT_SIZE))
                 ELSE
                   M(STEP(IFATH))=max(MEM_SIZE,((ND(STEP(IFATH))
     $             *ND(STEP(IFATH)))+max(SUM,SIZECB)+FACT_SIZE))
                 ENDIF
                 IF (SBTR_M.OR.(PERM.EQ.2))  THEN
                       M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T,
     $                      ((ND(STEP(IFATH))
     $                      *ND(STEP(IFATH)))+max(SUM,SIZECB)+
     $                      FACT_SIZE_T))
                 ENDIF
              ENDIF
              IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR.
     $             (PERM.EQ.5).OR.(PERM.EQ.6).OR.
     $             (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN
                 MEM_SEC_PERM=max(MEM_SIZE,((ND(STEP(IFATH))
     $             *ND(STEP(IFATH)))+max(SUM,SIZECB)+FACT_SIZE))
              ENDIF
              IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN
                 MEM_SEC_PERM=huge(MEM_SEC_PERM)
              ENDIF
           ENDDO
           IF(PERM.EQ.7) GOTO 96
           IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN
              TAB=>TEMP
           ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN
              WRITE(*,*)'Probleme dans reorder!!!!'
              CALL MUMPS_ABORT()
           ELSE 
              TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE
              TAB=>SON
           ENDIF
           DO I=NE(STEP(INODE)),1,-1
              IF(I.EQ.NE(STEP(INODE))) THEN
                 FILS(dernier)=-TAB(I)
                 dernier=TAB(I)
                 GOTO 222
              ENDIF
              IF(I.EQ.1) THEN
                 FRERE(STEP(dernier))=TAB(I)
                 FRERE(STEP(TAB(I)))=-INODE
                 GOTO 222
              ENDIF
              IF(I.GT.1) THEN
                 FRERE(STEP(dernier))=TAB(I)
                 dernier=TAB(I)
                 GOTO 222
              ENDIF
 222          CONTINUE
           ENDDO
           GOTO 96
        ELSE
           GOTO 91
        ENDIF
 116    CONTINUE
        NBROOT = NA(2)
        IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT)
        IF(PERM.EQ.7) GOTO 001
        IF (PERM.eq.1) THEN
          DO I=1,NBROOT
            TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF)))
            TAB1(I)=-TAB1(I)
          ENDDO
          CALL CMUMPS_462(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4,
     &      RESULT,T1,T2)
          IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT)
        ENDIF
 001    CONTINUE
        fin=NBROOT
        LEAF=NA(1)
        FIRST_LEAF=-9999
        SIZE_SBTR=0
 999    CONTINUE
        INODE=IPOOL(fin)
        IF(INODE.LT.0)THEN
           WRITE(*,*)'Internal Error in reordertree INODE < 0 !'
           CALL MUMPS_ABORT()
        ENDIF
        IF(SIZE_SBTR.NE.0)THEN 
           IF(.NOT.MUMPS_167(STEP(INODE),PROCNODE,SLAVEF))THEN
              IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN
                 IF((SLAVEF.NE.1))THEN
                    MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF
                    MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR
                    FIRST_LEAF=-9999
                    SIZE_SBTR=0
                 ENDIF
              ENDIF
           ENDIF
        ENDIF
        IF(MUMPS_283(STEP(INODE),PROCNODE,SLAVEF))THEN
           ROOT_OF_CUR_SBTR=INODE
        ENDIF
        IF (K76.EQ.4)THEN
           IF(SLAVEF.NE.1)THEN
              WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV
              IF(MUMPS_167(STEP(INODE),PROCNODE,SLAVEF))THEN
                 DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP(
     $                ROOT_OF_CUR_SBTR))
              ELSE
                 DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV
              ENDIF
              RANK_TRAV=RANK_TRAV-1
           ENDIF
        ENDIF
        IF (K76.EQ.5)THEN
           IF(SLAVEF.NE.1)THEN
              IF (USE_DAD) THEN
                IFATH=DAD(INODE)
              ELSE
                IN = INODE
 395            IN = FRERE(IN)
                IF (IN.GT.0) GO TO 395
                IFATH = -IN
              ENDIF
              NFR    = ND(STEP(INODE))
              NELIM4 = 0
              IN = INODE
 396          NELIM4 = NELIM4 + 1
              IN = FILS(IN)
              IF (IN .GT. 0 ) GOTO 396
              NELIM=NELIM4
              IF((SYM.EQ.0).OR.(K215.NE.0))THEN
                 SIZECB=(NFR-NELIM)*(NFR-NELIM)
              ELSE
                 SIZECB=(NFR-NELIM)*(NFR-NELIM+1)/2
              ENDIF
              NFR4=NFR
              CALL MUMPS_511(NFR4,NELIM4,NELIM4,
     *             SYM,1,COST_NODE)
              IF(IFATH.NE.0)THEN
                 IF(MUMPS_167(STEP(INODE),PROCNODE,SLAVEF))THEN
                    COST_TRAV(STEP(INODE))=COST_TRAV(STEP(
     $                   ROOT_OF_CUR_SBTR))
                 ELSE
                    COST_TRAV(STEP(INODE))=COST_NODE+
     $                   COST_TRAV(STEP(IFATH))+
     $                   (SIZECB*18)
                 ENDIF
              ELSE
                 COST_TRAV(STEP(INODE))=COST_NODE
              ENDIF
              IF(K76.EQ.5)THEN
                 WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE))
              ENDIF
           ENDIF
        ENDIF
        IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN
              IF((SLAVEF.NE.1).AND.
     $          MUMPS_283(STEP(INODE),PROCNODE,SLAVEF))THEN
                IF (NE(STEP(INODE)).NE.0) THEN
                   ID=MUMPS_275(STEP(INODE),PROCNODE,SLAVEF)
                   IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN
                      MEM_SUBTREE(INDICE(ID+1),ID+1)=
     $                     M_TOTAL(STEP(INODE))
                   ELSE
                      MEM_SUBTREE(INDICE(ID+1),ID+1)=M(STEP(INODE))
                   ENDIF
                   MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE
                  INDICE(ID+1)=INDICE(ID+1)+1
                ENDIF
              ENDIF
              IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN
                 ID=MUMPS_275(STEP(INODE),PROCNODE,SLAVEF)
                 IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN
                    MEM_SUBTREE(INDICE(ID+1),ID+1)=
     $                   M_TOTAL(STEP(INODE))
                 ELSE
                    MEM_SUBTREE(INDICE(ID+1),ID+1)=M(STEP(INODE))
                 ENDIF
                 INDICE(ID+1)=INDICE(ID+1)+1
              ENDIF
        ENDIF
        IN=INODE
 5602   IN = FILS(IN)
        IF (IN .GT. 0 ) THEN
           dernier=IN
           GOTO 5602
        ENDIF
        IN=-IN
        DO I=1,NE(STEP(INODE))
           TEMP(I)=IN
           IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN
              IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_170(
     $             STEP(INODE),PROCNODE,SLAVEF)))THEN
                 NFR    = ND(STEP(INODE))
                 NELIM4 = 0
                 II = TEMP(I)
 845             NELIM4 = NELIM4 + 1
                 II = FILS(II)
                 IF (II .GT. 0 ) GOTO 845
                 NELIM=NELIM4
                 NFR4 = NFR
                 CALL MUMPS_511(NFR4,NELIM4,NELIM4,
     *                SYM,1,COST_NODE)
                 TAB1(I)=COST_NODE+
     $                COST_TRAV(STEP(INODE))
                 TAB2(I)=0.0E0
              ELSE
                 SON(I)=IN
              ENDIF
           ELSE
              SON(I)=IN
           ENDIF
           IN=FRERE(STEP(IN))
        ENDDO
        IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN
           IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_170(
     $          STEP(INODE),PROCNODE,SLAVEF)))THEN
              CALL CMUMPS_462(TEMP,NE(STEP(INODE)),TAB1,TAB2,
     $             LOCAL_PERM
     &             ,RESULT,T1,T2)
              TAB=>TEMP
              DO I=NE(STEP(INODE)),1,-1
                 IF(I.EQ.NE(STEP(INODE))) THEN
                    FILS(dernier)=-TAB(I)
                    dernier=TAB(I)
                    GOTO 221
                 ENDIF
                 IF(I.EQ.1) THEN
                    FRERE(STEP(dernier))=TAB(I)
                    FRERE(STEP(TAB(I)))=-INODE
                    GOTO 221
                 ENDIF
                 IF(I.GT.1) THEN
                    FRERE(STEP(dernier))=TAB(I)
                    dernier=TAB(I)
                    GOTO 221
                 ENDIF
 221             CONTINUE
                 SON(NE(STEP(INODE))-I+1)=TAB(I)
              ENDDO
           ENDIF
        ENDIF
        DO I=1,NE(STEP(INODE))
           IPOOL(fin)=SON(I)
           SON(I)=0
           fin=fin+1
        ENDDO
        IF(NE(STEP(INODE)).EQ.0)THEN
           IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN
              IF(SLAVEF.NE.1)THEN
                 IF(MUMPS_167(STEP(INODE),PROCNODE,SLAVEF))THEN
                    IF(FIRST_LEAF.EQ.-9999)THEN
                       FIRST_LEAF=INODE
                    ENDIF
                    SIZE_SBTR=SIZE_SBTR+1
                 ENDIF
              ENDIF
           ENDIF
           IF(PERM.NE.7)THEN
              NA(LEAF+2)=INODE
           ENDIF
           LEAF=LEAF-1
        ELSE
           fin=fin-1
           GOTO 999
        ENDIF
        fin=fin-1
        IF(fin.EQ.0) THEN
           IF(SIZE_SBTR.NE.0)THEN 
              IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN
                 IF((SLAVEF.NE.1))THEN
                    MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF
                    MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR
                    FIRST_LEAF=-9999
                    SIZE_SBTR=0
                 ENDIF
              ENDIF
           ENDIF
           GOTO 789
        ENDIF
        GOTO 999
 789    CONTINUE
        NBROOT=NA(2)
        NBLEAF=NA(1)
        PEAK=0.0E0
        FACT_SIZE=0
        DO I=1,NBROOT
           PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I)))))
           FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I)))
        ENDDO
 5483   CONTINUE
        DEALLOCATE(IPOOL)
        DEALLOCATE(M)
        DEALLOCATE(fact)
        DEALLOCATE(TNSTK)
        DEALLOCATE(SON)
        DEALLOCATE(TAB2)
        DEALLOCATE(TAB1)
        DEALLOCATE(T1)
        DEALLOCATE(T2)
        DEALLOCATE(RESULT)
        DEALLOCATE(TEMP)
        IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN
           DEALLOCATE(DEPTH)
        ENDIF
        IF (SBTR_M.OR.(PERM.EQ.2))  THEN
           IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN
              DEALLOCATE(M_TOTAL)
           ENDIF
        ENDIF
      RETURN
      END SUBROUTINE CMUMPS_363
      RECURSIVE SUBROUTINE CMUMPS_462(TAB,DIM,TAB1,TAB2,PERM,
     &  RESULT,TEMP1,TEMP2)
      IMPLICIT NONE
      INTEGER DIM
      INTEGER*8 TAB1(DIM),TAB2(DIM)
      INTEGER*8 TEMP1(DIM),TEMP2(DIM)
      INTEGER TAB(DIM), PERM,RESULT(DIM)
      INTEGER I,J,K,C,I1,I2,COR1,COR2
      IF(DIM.EQ.1) THEN
        RESULT(1)=TAB(1)
        TEMP1(1)=TAB1(1)
        TEMP2(1)=TAB2(1)
        RETURN
      ENDIF
      I=DIM/2
      CALL CMUMPS_462(TAB(1),I,TAB1(1),TAB2(1),PERM,
     &  RESULT(1),TEMP1(1),TEMP2(1))
      CALL CMUMPS_462(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1),
     &  PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1))
      I1=1
      I2=I+1
      J=1
      DO WHILE ((I1.LE.I).AND.(I2.LE.DIM))
        IF((PERM.EQ.3))THEN
          IF(TEMP1(I1).LE.TEMP1(I2))THEN
            TAB(J)=RESULT(I1)
            TAB1(J)=TEMP1(I1)
            J=J+1
            I1=I1+1
          ELSE
            TAB(J)=RESULT(I2)
            TAB1(J)=TEMP1(I2)
            J=J+1
            I2=I2+1
          ENDIF
          GOTO 3
        ENDIF
        IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN
          IF (TEMP1(I1).GE.TEMP1(I2))THEN
            TAB(J)=RESULT(I1)
            TAB1(J)=TEMP1(I1)
            J=J+1
            I1=I1+1
          ELSE
            TAB(J)=RESULT(I2)
            TAB1(J)=TEMP1(I2)
            J=J+1
            I2=I2+1          
          ENDIF
          GOTO 3
        ENDIF
        IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN
          IF(TEMP1(I1).GT.TEMP1(I2))THEN
            TAB1(J)=TEMP1(I1)
            TAB2(J)=TEMP2(I1)
            TAB(J)=RESULT(I1)
            J=J+1
            I1=I1+1
            GOTO 3
          ENDIF
          IF(TEMP1(I1).LT.TEMP1(I2))THEN
            TAB1(J)=TEMP1(I2)
            TAB2(J)=TEMP2(I2)
            TAB(J)=RESULT(I2)
            J=J+1
            I2=I2+1
            GOTO 3
          ENDIF        
          IF((TEMP1(I1).EQ.TEMP1(I2)))THEN
            IF(TEMP2(I1).LE.TEMP2(I2))THEN
              TAB1(J)=TEMP1(I1)
              TAB2(J)=TEMP2(I1)
              TAB(J)=RESULT(I1)
              J=J+1
              I1=I1+1
            ELSE
              TAB1(J)=TEMP1(I2)
              TAB2(J)=TEMP2(I2)
              TAB(J)=RESULT(I2)
              J=J+1
              I2=I2+1
            ENDIF
          ENDIF
        ENDIF
  3   CONTINUE    
      ENDDO
      IF(I1.GT.I)THEN
        DO WHILE(I2.LE.DIM)
          TAB(J)=RESULT(I2)
          TAB1(J)=TEMP1(I2)
          TAB2(J)=TEMP2(I2)
          J=J+1
          I2=I2+1
        ENDDO
      ELSE
        IF(I2.GT.DIM)THEN
          DO WHILE(I1.LE.I)
            TAB1(J)=TEMP1(I1)
            TAB2(J)=TEMP2(I1)
            TAB(J)=RESULT(I1)
            J=J+1
            I1=I1+1
          ENDDO
        ENDIF
      ENDIF
      DO I=1,DIM
        TEMP1(I)=TAB1(I)
        TEMP2(I)=TAB2(I)
        RESULT(I)=TAB(I)
      ENDDO
      RETURN
      END SUBROUTINE CMUMPS_462
