zfac_process_message.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      RECURSIVE SUBROUTINE zmumps_traiter_message(
     &    COMM_LOAD, ASS_IRECV,
     &    MSGSOU, MSGTAG, MSGLEN,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM,
     &    PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &               , LRGROUPS
     &    )
      USE zmumps_load
      USE zmumps_struc_def, ONLY : zmumps_root_struc
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (zmumps_root_struc) :: root
      INTEGER msgsou, msgtag, msglen
      INTEGER lbufr, LBUFR_BYTES
      INTEGER bufr( lbufr )
      INTEGER keep(500), icntl( 60 )
      INTEGER(8) keep8(150)
      DOUBLE PRECISION    dkeep(230)
      INTEGER(8) :: posfac, iptrlu, lrlu, lrlus, la
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      INTEGER, intent(in) :: lrgroups(n)
      COMPLEX(kind=8) a( la )
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER ptrist(keep(28)), ptlust(keep(28))
      INTEGER step(n), pimaster(keep(28))
      INTEGER comp
      INTEGER nstk_s(keep(28)), procnode_steps( keep(28) )
      INTEGER perm(n)
      INTEGER iflag, ierror, comm
      INTEGER lpool, leaf
      INTEGER ipool( lpool )
      INTEGER comm_load, ass_irecv
      INTEGER myid, slavef, nbfin
      DOUBLE PRECISION OPASSW, opeliw
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1), frtelt( nelt )
      INTEGER itloc( N+keep(253) ), fils( n ), dad(keep(28))
      COMPLEX(kind=8) :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( keep(28) )
      INTEGER istep_to_iniv2(keep(71)),
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER intarr( keep8(27) )
      COMPLEX(kind=8) dblarr( keep8(26) )
      INTEGER iniv2, ishift, ibeg
      INTEGER ishift_hdr
      INTEGER mumps_procnode, mumps_typenode
      EXTERNAL mumps_procnode, mumps_typenode
      LOGICAL flag
      INTEGER mp, LP
      INTEGER tmp( 2 )
      INTEGER nbrecu, position, inode, ison, iroot
      INTEGER nslaves_pere, nfront_pere, nass_pere,
     &     lmap, fpere, nelim,
     &     hdmaplig,nfs4father,
     &     tot_root_size, tot_cont_to_recv
      DOUBLE PRECISION flop1
      CHARACTER(LEN=35) :: subname
      include 'mumps_tags.h'
      include 'mpif.h'
      INTEGER :: ierr
      INTEGER :: status(mpi_status_size)
      mp = icntl(2)
      lp = icntl(1)
      subname="??????"
      CALL zmumps_load_recv_msgs(comm_load)
      IF ( msgtag .EQ. racine ) THEN
          position = 0
          CALL mpi_unpack( bufr, lbufr_bytes, position, nbrecu,
     &     1, mpi_integer, comm, ierr)
          nbrecu = bufr( 1 )
          nbfin =  nbfin - nbrecu
      ELSEIF ( msgtag .EQ. noeud ) THEN
          CALL zmumps_process_node( myid, keep, keep8, dkeep,
     &    bufr, lbufr, lbufr_bytes,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, slavef, procnode_steps, dad,
     &    ptrist, ptrast,
     &    step, pimaster, pamaster,
     &    nstk_s, comp, fpere, flag, iflag, ierror, comm,
     &    itloc, rhs_mumps )
          subname="zmumps_process_node"
.LT.          IF ( IFLAG  0 ) GO TO 500
          IF ( FLAG ) THEN
            CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL,
     &           PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76),
     &           KEEP(80), KEEP(47), STEP, FPERE )
.GE.            IF (KEEP(47)  3) THEN
               CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL(
     &              IPOOL, LPOOL,
     &              PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
     &              MYID, STEP, N, ND, FILS )
            ENDIF
            CALL MUMPS_ESTIM_FLOPS( FPERE, N,
     &           PROCNODE_STEPS,KEEP(199),
     &           ND, FILS, FRERE, STEP, PIMASTER,
     &           KEEP(28), KEEP(50), KEEP(253), FLOP1,
     &           IW, LIW, KEEP(IXSZ) )
.NE.            IF (FPEREKEEP(20))
     &        CALL ZMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8)
          ENDIF
.EQ.      ELSEIF ( MSGTAG  END_NIV2_LDLT ) THEN
          INODE = BUFR( 1 )
          CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL,
     &         PROCNODE_STEPS, SLAVEF, KEEP(199),
     &         KEEP(28), KEEP(76), KEEP(80), KEEP(47),
     &         STEP, -INODE )
.GE.          IF (KEEP(47)  3) THEN
             CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL(
     &            IPOOL, LPOOL,
     &            PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
     &            MYID, STEP, N, ND, FILS )
          ENDIF
.EQ.      ELSEIF ( MSGTAG  TERREUR ) THEN
          IFLAG  = -001
          IERROR = MSGSOU
          GOTO 100
.EQ.      ELSEIF ( MSGTAG  MAITRE_DESC_BANDE ) THEN
        CALL ZMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR,
     &    LBUFR_BYTES, IWPOS,
     &    IWPOSCB,
     &    IPTRLU, LRLU, LRLUS, 
     &    N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &    PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
     &    KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, 
#if ! defined (NO_FDM_DESCBAND)
     &    -1,
#endif
     &    IFLAG, IERROR )
          SUBNAME="zmumps_process_desc_bande"
.LT.        IF ( IFLAG  0 ) GO to 500
.EQ.      ELSEIF ( MSGTAG  MAITRE2           ) THEN
        CALL ZMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES,
     &    PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB,
     &    IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA,
     &    PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM, COMM_LOAD,
     &    IPOOL, LPOOL, LEAF,
     &    KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS,
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE )
          SUBNAME="zmumps_process_master2"
.LT.        IF ( IFLAG  0 ) GO to 500
.EQ..OR.      ELSEIF ( MSGTAG  BLOC_FACTO  
.EQ.     &         MSGTAG  BLOC_FACTO_RELAY ) THEN
        CALL ZMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV,
     &   BUFR,  LBUFR, LBUFR_BYTES,
     &   PROCNODE_STEPS, MSGSOU,
     &   SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
     &   A, LA, PTRIST, PTRAST, NSTK_S, PERM,
     &   COMP, STEP, PIMASTER, PAMASTER, POSFAC,
     &   MYID, COMM , IFLAG, IERROR, NBFIN,
     &
     &    PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR,
     &    ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE  
     &               , LRGROUPS
     &     )
.EQ.      ELSEIF ( MSGTAG  BLOC_FACTO_SYM_SLAVE    ) THEN
        CALL ZMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV,
     &   BUFR, LBUFR,
     &   LBUFR_BYTES, PROCNODE_STEPS, MSGSOU,
     &   SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
     &   A, LA, PTRIST, PTRAST, NSTK_S, PERM,
     &   COMP, STEP, PIMASTER, PAMASTER, POSFAC,
     &   MYID, COMM, IFLAG, IERROR, NBFIN,
     &
     &    PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR,
     &    ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE  
     &               , LRGROUPS
     &     )
.EQ.      ELSEIF ( MSGTAG  BLOC_FACTO_SYM    ) THEN
        CALL ZMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV,
     &   BUFR, LBUFR,
     &   LBUFR_BYTES, PROCNODE_STEPS, MSGSOU,
     &   SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
     &   A, LA, PTRIST, PTRAST, NSTK_S, PERM,
     &   COMP, STEP, PIMASTER, PAMASTER, POSFAC,
     &   MYID, COMM, IFLAG, IERROR, NBFIN,
     &
     &    PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR,
     &    ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &        , LRGROUPS
     & )
.EQ.      ELSEIF ( MSGTAG  CONTRIB_TYPE2    ) THEN
        CALL ZMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV,
     &       MSGLEN, BUFR, LBUFR,
     &       LBUFR_BYTES, PROCNODE_STEPS,
     &       SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC,
     &       N, IW, LIW, A, LA, PTRIST,
     &       PTLUST, PTRFAC, PTRAST,
     &       STEP, PIMASTER, PAMASTER, PERM, COMP, root,
     &       OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD,
     &       PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, MYID, COMM,
     &       ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF,
     &       ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT,
     &       ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &               , LRGROUPS
     &       )
.LT.        IF ( IFLAG  0 ) GO TO 100
.EQ.      ELSEIF ( MSGTAG  MAPLIG            ) THEN
         HDMAPLIG = 7
         INODE        = BUFR( 1 )
         ISON         = BUFR( 2 )
         NSLAVES_PERE = BUFR( 3 )
         NFRONT_PERE  = BUFR( 4 )
         NASS_PERE    = BUFR( 5 )
         LMAP         = BUFR( 6 )
         NFS4FATHER   = BUFR( 7 )
.NE.         IF ( NSLAVES_PERE0 ) THEN
            INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) )
            ISHIFT = NSLAVES_PERE+1
            TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) =
     &           BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE)
            TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE
         ELSE
            ISHIFT = 0
         ENDIF
         IBEG = HDMAPLIG+1+ISHIFT
         CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES,
     &    INODE, ISON, NSLAVES_PERE,
     &    BUFR(IBEG),
     &    NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP,
     &    BUFR(IBEG+NSLAVES_PERE),
     &    PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB,
     &    IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA,
     &    PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER,
     &    NSTK_S, COMP,
     &    IFLAG, IERROR, MYID, COMM, PERM,
     &    IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root,
     &    OPASSW, OPELIW,
     &    ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR,
     &    ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT,
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &               , LRGROUPS
     &    )
.LT.         IF ( IFLAG  0 ) GO TO 100
.EQ.      ELSE IF ( MSGTAG  ROOT_CONT_STATIC ) THEN
        CALL ZMUMPS_PROCESS_CONTRIB_TYPE3(
     &        BUFR, LBUFR, LBUFR_BYTES,
     &        root, N, IW, LIW, A, LA, 
     &        LRLU, IPTRLU, IWPOS, IWPOSCB,
     &        PTRIST, PTLUST, PTRFAC, PTRAST,
     &        STEP, PIMASTER, PAMASTER,
     &        COMP, LRLUS, IPOOL, LPOOL, LEAF,
     &        FILS, DAD, MYID,
     &        LPTRAR, NELT, FRTPTR, FRTELT,
     &        PTRAIW, PTRARW, INTARR, DBLARR,
     &        KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD,
     &        ITLOC, RHS_MUMPS,
     &        ND, PROCNODE_STEPS, SLAVEF, OPASSW)
        SUBNAME="zmumps_process_contrib_type3"
.LT.        IF ( IFLAG  0 ) GO TO 500
.EQ.      ELSE IF ( MSGTAG  ROOT_NON_ELIM_CB ) THEN
        IROOT  = KEEP( 38 )
        MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), 
     &           KEEP(199) )
.EQ.        IF ( PTLUST( STEP(IROOT))  0 ) THEN
          KEEP(266)=KEEP(266)-1
          CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED,
     &                   MSGSOU, ROOT_2SLAVE,
     &                   COMM, STATUS, IERR )
          CALL ZMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ),
     &    root,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM, COMM_LOAD,
     &    IPOOL, LPOOL, LEAF,
     &    NBFIN, MYID, SLAVEF,
     &
     &    OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &    PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND )
          SUBNAME="zmumps_process_root2slave"
.LT.          IF ( IFLAG  0 ) GOTO 500
        END IF
        CALL ZMUMPS_PROCESS_CONTRIB_TYPE3(
     &       BUFR, LBUFR, LBUFR_BYTES,
     &       root, N, IW, LIW, A, LA, 
     &       LRLU, IPTRLU, IWPOS, IWPOSCB,
     &       PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER,
     &       COMP, LRLUS, IPOOL, LPOOL, LEAF,
     &       FILS, DAD, MYID,
     &       LPTRAR, NELT, FRTPTR, FRTELT,
     &       PTRAIW, PTRARW, INTARR, DBLARR,
     &       KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD,
     &       ITLOC, RHS_MUMPS,
     &       ND, PROCNODE_STEPS, SLAVEF, OPASSW )
          SUBNAME="zmumps_process_contrib_type3"
        IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. root_2son ) THEN
         ison  = bufr( 1 )
         nelim = bufr( 2 )
         CALL zmumps_process_root2son( comm_load, ass_irecv,
     &    ison, nelim, root,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr,dblarr,icntl,keep,keep8,dkeep,nd, frere,
     &    lptrar, nelt, frtptr, frtelt,
     &    istep_to_iniv2, tab_pos_in_pere 
     &               , lrgroups
     &     )
          IF ( iflag .LT. 0 ) GO TO 100
         IF ( myid.NE.mumps_procnode(procnode_steps(step(ison)), 
     &                               keep(199)) ) THEN
          IF (keep(50).EQ.0) THEN
            ishift_hdr = 6
          ELSE
            ishift_hdr = 8
          ENDIF
          IF (iw(ptrist(step(ison))+ishift_hdr+keep(ixsz)).EQ.
     &                                 s_rec_contstatic) THEN
             iw(ptrist(step(ison))+ishift_hdr+keep(ixsz)) =
     &                                        s_root2son_called
          ELSE
             CALL zmumps_free_band( n, ison, ptrist, ptrast,
     &       iw, liw, a, la, lrlu, lrlus, iwposcb,
     &       iptrlu, step, myid, keep, keep8,
     &       mumps_typenode(procnode_steps(step(ison)),keep(199))
     &       )
          ENDIF
         ENDIF
      ELSE IF ( msgtag .EQ. root_2slave ) THEN
          tot_root_size    = bufr( 1 )
          tot_cont_to_recv = bufr( 2 )
          CALL zmumps_process_root2slave( tot_root_size,
     &    tot_cont_to_recv, root,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm, comm_load,
     &    ipool, lpool, leaf,
     &    nbfin, myid, slavef,
     &
     &    opassw, opeliw, itloc, rhs_mumps, fils, dad,
     &    lptrar, nelt, frtptr, frtelt,
     &    ptrarw, ptraiw,
     &    intarr, dblarr, icntl, keep,keep8, dkeep, nd )
          IF ( iflag .LT. 0 ) GO TO 100
      ELSE IF ( msgtag .EQ. root_nelim_indices ) THEN
         ison         = bufr( 1 )
         nelim        = bufr( 2 )
         nslaves_pere = bufr( 3 )
         CALL zmumps_process_rtnelind( root,
     &    ison, nelim, nslaves_pere, bufr(4), bufr(4+bufr(2)),
     &    bufr(4+2*bufr(2)),
     &
     &    procnode_steps,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s,
     &    itloc, rhs_mumps, comp,
     &    iflag, ierror,
     &    ipool, lpool, leaf, myid, slavef,
     &    keep, keep8, dkeep,
     &    comm, comm_load, fils, dad, nd)
          subname="ZMUMPS_PROCESS_RTNELIND"
         IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. update_load ) THEN
         WRITE(*,*) "Internal error 3 in ZMUMPS_TRAITER_MESSAGE"
         CALL mumps_abort()
      ELSE IF ( msgtag .EQ. tag_dummy   ) THEN
      ELSE
         IF ( lp > 0 )
     &     WRITE(lp,*) myid,
     &': Internal error, routine ZMUMPS_TRAITER_MESSAGE.',msgtag
         iflag = -100
         ierror= msgtag
         GOTO 500
      ENDIF
 100  CONTINUE
      RETURN
 500  CONTINUE
      IF ( icntl(1) .GT. 0 .AND. icntl(4).GE.1 ) THEN
        lp=icntl(1)
        IF (iflag.EQ.-9) THEN
         WRITE(lp,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',subname
        ENDIF
        IF (iflag.EQ.-8) THEN
         WRITE(lp,*) 'FAILURE IN INTEGER ALLOCATION DURING ',subname
        ENDIF
        IF (iflag.EQ.-13) THEN
         WRITE(lp,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',subname
        ENDIF
      ENDIF
      CALL zmumps_bdc_error( myid, slavef, comm, keep )
      RETURN
      END SUBROUTINE zmumps_traiter_message
      RECURSIVE SUBROUTINE zmumps_recv_and_treat(
     &    COMM_LOAD, ASS_IRECV,
     &    STATUS,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM,
     &    PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT ,
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &               , LRGROUPS
     &    )
      USE zmumps_struc_def, ONLY : zmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      TYPE (zmumps_root_struc) :: root
      INTEGER :: status(mpi_status_size)
      INTEGER keep(500), icntl(60)
      INTEGER(8) keep8(150)
      DOUBLE PRECISION       dkeep(230)
      INTEGER comm_load, ass_irecv
      INTEGER lbufr, lbufr_bytes
      INTEGER bufr( lbufr )
      INTEGER(8) :: posfac, la, iptrlu, lrlu, lrlus
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      COMPLEX(kind=8) a( LA )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER ptrist( keep(28) ),
     &        ptlust( keep(28) )
      INTEGER step(n), pimaster(keep(28))
      INTEGER comp
      INTEGER nstk_s(keep(28)), procnode_steps( keep(28) )
      INTEGER perm(n)
      INTEGER iflag, ierror, comm
      INTEGER LPOOL, leaf
      INTEGER ipool( lpool )
      INTEGER myid, slavef, nbfin
      DOUBLE PRECISION opassw, opeliw
      INTEGER nelt, lptrar
      INTEGER frtptr( N+1 ), frtelt( nelt )
      INTEGER itloc( n+keep(253) ), fils( n ), dad( keep(28) )
      COMPLEX(kind=8) :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( keep(28) )
      INTEGER istep_to_iniv2(keep(71)),
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER intarr( keep8(27) )
      COMPLEX(kind=8) dblarr( keep8(26) )
      INTEGER msgsou, msgtag, msglen, ierr
      msgsou = status( mpi_source )
      msgtag = status( mpi_tag )
      CALL mpi_get_count( status, mpi_packed, msglen, ierr )
      IF ( msglen .GT. lbufr_bytes ) THEN
        iflag  = -20
        ierror = msglen
         WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=',
     &                msgtag,msglen
        CALL zmumps_bdc_error( myid, slavef, comm, keep )
        RETURN
       ENDIF
       keep(266)=keep(266)-1
       CALL mpi_recv( bufr, lbufr_bytes, mpi_packed, msgsou,
     &                 msgtag,
     &                 comm, status, ierr )
       CALL zmumps_traiter_message(
     &      comm_load, ass_irecv,
     &      msgsou, msgtag, msglen, bufr, lbufr,
     &      lbufr_bytes,
     &      procnode_steps, posfac,
     &      iwpos, iwposcb, iptrlu,
     &      lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &      ptlust, ptrfac,
     &      ptrast, step, pimaster, pamaster, nstk_s, comp, iflag,
     &      ierror, comm,
     &      perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &      root, opassw, opeliw, itloc, rhs_mumps,
     &      fils, dad, ptrarw, ptraiw,
     &      intarr, dblarr, icntl, keep,keep8,dkeep, nd, frere,
     &      lptrar, nelt, frtptr, frtelt,
     &
     &      istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &      )
      RETURN
      END SUBROUTINE zmumps_recv_and_treat
      RECURSIVE SUBROUTINE zmumps_try_recvtreat(
     &    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, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM, PERM,
     &    IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE,
     &    STACK_RIGHT_AUTHORIZED, LRGROUPS )
      USE zmumps_load
      USE zmumps_struc_def, ONLY : zmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      TYPE (zmumps_root_struc) :: root
      INTEGER :: status(mpi_status_size)
      LOGICAL, INTENT (IN)  :: blocking
      LOGICAL, INTENT (IN)  :: set_irecv
      LOGICAL, INTENT (INOUT) :: message_received
      INTEGER, INTENT (IN) :: msgsou, msgtag
      INTEGER keep(500), icntl(60)
      INTEGER(8) keep8(150)
      DOUBLE PRECISION       dkeep(230)
      INTEGER lbufr, lbufr_bytes
      INTEGER comm_load, ass_irecv
      INTEGER bufr( lbufr )
      INTEGER(8) :: la, posfac, iptrlu, lrlu, lrlus
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      COMPLEX(kind=8) a( la )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER ptrist( keep(28) ),
     &        ptlust(keep(28))
      INTEGER step(n),
     & pimaster(keep(28))
      INTEGER comp
      INTEGER nstk_s(keep(28)), procnode_steps( keep(28) )
      INTEGER perm(n)
      INTEGER iflag, ierror, comm
      INTEGER lpool, leaf
      INTEGER ipool( lpool )
      INTEGER myid, slavef, nbfin
      DOUBLE PRECISION opassw, opeliw
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER itloc( n + keep(253) ), fils( n ), dad( keep(28) )
      COMPLEX(kind=8) :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( KEEP(28) )
      INTEGER istep_to_iniv2(keep(71)),
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER intarr( keep8(27) )
      COMPLEX(kind=8) dblarr( keep8(26) )
      LOGICAL, intent(in) :: stack_right_authorized
       LOGICAL flag, right_mess, flagbis
       INTEGER lp, msgsou_loc, msgtag_loc, msglen_loc
       INTEGER ierr
       INTEGER :: status_bis(mpi_status_size)
       INTEGER, SAVE :: recurs = 0
      CALL zmumps_load_recv_msgs(comm_load)
      IF ( .NOT. stack_right_authorized ) THEN
          RETURN
      ENDIF
      recurs = recurs + 1
      lp = icntl(1)
      IF (icntl(4).LT.1) lp=-1
      IF ( message_received ) THEN
        msgsou_loc = mpi_any_source
        msgtag_loc = mpi_any_tag
        GOTO 250
      ENDIF
      IF ( ass_irecv .NE. mpi_request_null) THEN
        IF (keep(117).NE.0) THEN
         WRITE(*,*) "Problem of active IRECV with KEEP(117)=",keep(117)
         CALL mumps_abort()
        ENDIF
        right_mess = .true.
        IF (blocking) THEN
          CALL mpi_wait(ass_irecv,
     &                status, ierr)
          flag = .true.
          IF ( ( (msgsou.NE.mpi_any_source) .OR.
     &      (msgtag.NE.mpi_any_tag) )  ) THEN
            IF ( msgsou.NE.mpi_any_source) THEN
              right_mess = msgsou.EQ.status(mpi_source)
            ENDIF
            IF ( msgtag.NE.mpi_any_tag) THEN
              right_mess =
     &        ( (msgtag.EQ.status(mpi_tag)).AND.right_mess )
            ENDIF
            IF (.NOT.right_mess) THEN
              CALL mpi_probe(msgsou,msgtag,
     &           comm, status_bis, ierr)
            ENDIF
          ENDIF
        ELSE 
          CALL mpi_test(ass_irecv,
     &             flag, status, ierr)
        ENDIF
        IF (ierr.LT.0) THEN
          iflag = -20
          IF (lp.GT.0)
     &    write(lp,*) ' Error return from MPI_TEST ',
     &     iflag, ' in ZMUMPS_TRY_RECVTREAT'
          CALL zmumps_bdc_error( myid, slavef, comm, keep )
          RETURN
        ENDIF
        IF ( flag ) THEN
          keep(266)=keep(266)-1
          message_received = .true.
          msgsou_loc = status( mpi_source )
          msgtag_loc = status( mpi_tag )
          CALL mpi_get_count( status, mpi_packed, msglen_loc, ierr )
           IF (.NOT.right_mess) recurs = recurs + 10
          CALL zmumps_traiter_message( comm_load, ass_irecv,
     &      msgsou_loc, msgtag_loc, msglen_loc, bufr, lbufr,
     &      lbufr_bytes,
     &      procnode_steps, posfac,
     &      iwpos, iwposcb, iptrlu,
     &      lrlu, lrlus, n, iw, liw, a, la,
     &      ptrist, ptlust, ptrfac,
     &      ptrast, step, pimaster, pamaster, nstk_s, comp, iflag,
     &      ierror, comm,
     &      perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &      root, opassw, opeliw, itloc, rhs_mumps, fils, dad,
     &      ptrarw, ptraiw,
     &      intarr, dblarr, icntl, keep,keep8,dkeep, nd, frere,
     &      lptrar, nelt, frtptr, frtelt,
     &      istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &      )
          IF (.NOT.right_mess) recurs = recurs - 10
          IF ( iflag .LT. 0 ) RETURN
          IF (.NOT.right_mess) THEN
             IF (ass_irecv .NE. mpi_request_null) THEN
                CALL mumps_abort()
            ENDIF
            CALL mpi_iprobe(msgsou,msgtag,
     &           comm, flagbis, status, ierr)
            IF (flagbis) THEN
               msgsou_loc = status( mpi_source )
               msgtag_loc = status( mpi_tag )
               CALL zmumps_recv_and_treat( comm_load, ass_irecv,
     &            status, bufr, lbufr,
     &            lbufr_bytes,
     &            procnode_steps, posfac,
     &            iwpos, iwposcb, iptrlu,
     &            lrlu, lrlus, n, iw, liw, a, la,
     &            ptrist, ptlust, ptrfac,
     &            ptrast, step, pimaster, pamaster,
     &            nstk_s, comp, iflag,
     &            ierror, comm,
     &            perm, ipool, lpool,leaf,nbfin,myid,slavef,
     &
     &            root, opassw, opeliw, itloc, rhs_mumps,
     &            fils, dad, ptrarw, ptraiw,
     &            intarr, dblarr, icntl,
     &            keep,keep8, dkeep,nd, frere,
     &            lptrar, nelt, frtptr, frtelt,
     &            istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &            )
                  IF ( iflag .LT. 0 ) RETURN
            ENDIF
          ENDIF
       ENDIF
      ELSE
        IF (blocking) THEN
           CALL mpi_probe(msgsou,msgtag,
     &           comm, status, ierr)
           flag = .true.
        ELSE
           CALL mpi_iprobe( mpi_any_source, mpi_any_tag,
     &           comm, flag, status, ierr)
        ENDIF
        IF (flag) THEN
          msgsou_loc = status( mpi_source )
          msgtag_loc = status( mpi_tag )
          message_received = .true.
          CALL zmumps_recv_and_treat( comm_load, ass_irecv,
     &      status, bufr, lbufr,
     &      lbufr_bytes,
     &      procnode_steps, posfac,
     &      iwpos, iwposcb, iptrlu,
     &      lrlu, lrlus, n, iw, liw, a, la,
     &      ptrist, ptlust, ptrfac,
     &      ptrast, step, pimaster, pamaster, nstk_s, comp, iflag,
     &      ierror, comm,
     &      perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &      root, opassw, opeliw, itloc, rhs_mumps,
     &      fils, dad, ptrarw, ptraiw,
     &      intarr, dblarr, icntl, keep,keep8,dkeep, nd, frere,
     &      lptrar, nelt, frtptr, frtelt,
     &      istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &   )
          IF ( iflag .LT. 0 ) RETURN
        ENDIF
      ENDIF
 250  CONTINUE
      recurs  = recurs - 1
      IF ( nbfin .EQ. 0 ) RETURN
      IF ( recurs .GT. 3 ) RETURN
      IF ( keep(36).EQ.1 .AND. set_irecv  .AND.
     &      (ass_irecv.EQ.mpi_request_null) .AND.
     &    message_received ) THEN
       CALL mpi_irecv ( bufr(1),
     &      lbufr_bytes, mpi_packed, mpi_any_source,
     &      mpi_any_tag, comm,
     &      ass_irecv, ierr )
      ENDIF
      RETURN
      END SUBROUTINE zmumps_try_recvtreat
      SUBROUTINE zmumps_cancel_irecv( INFO1,
     &    KEEP, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES,
     &    COMM,
     &    MYID, SLAVEF)
      USE zmumps_buf
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER ASS_IRECV
      INTEGER BUFR( LBUFR )
      INTEGER COMM
      INTEGER MYID, SLAVEF, INFO1, DEST
      INTEGER, INTENT(INOUT) :: KEEP(500)
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      LOGICAL NO_ACTIVE_IRECV
      INTEGER IERR, DUMMY
      INTRINSIC mod
      IF (slavef .EQ. 1) RETURN
      IF (ass_irecv.EQ.mpi_request_null) THEN
        no_active_irecv=.true.
      ELSE
        CALL mpi_test(ass_irecv, no_active_irecv,
     &                status, ierr)
        IF (no_active_irecv) THEN
          keep(266) = keep(266) - 1
        ENDIF
      ENDIF
      CALL mpi_barrier(comm,ierr)
      dummy = 1
      dest = mod(myid+1, slavef)
      CALL zmumps_buf_send_1int
     &    (dummy, dest, tag_dummy, comm, keep, ierr)
      IF (no_active_irecv) THEN
        CALL mpi_recv( bufr, lbufr,
     &             mpi_integer, mpi_any_source,
     &             tag_dummy, comm, status, ierr )
      ELSE
        CALL mpi_wait(ass_irecv,
     &                status, ierr)
      ENDIF
      keep(266)=keep(266)-1
      RETURN
      END SUBROUTINE zmumps_cancel_irecv
      SUBROUTINE zmumps_clean_pending(
     &    INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES,
     &    COMM_NODES, COMM_LOAD, SLAVEF,
     &    CLEAN_COMM_NODES, CLEAN_COMM_LOAD )
      USE zmumps_buf
      IMPLICIT NONE
      INTEGER, INTENT(IN)    :: LBUFR, LBUFR_BYTES
      INTEGER, INTENT(OUT)   :: BUFR( LBUFR )
      INTEGER, INTENT(IN)    :: COMM_NODES, COMM_LOAD, SLAVEF, INFO1
      INTEGER, INTENT(INOUT) :: KEEP(500)
      LOGICAL, INTENT(IN)    :: CLEAN_COMM_LOAD, CLEAN_COMM_NODES
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      LOGICAL :: FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS
      INTEGER :: MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC
      INTEGER ::  COMM_EFF
      INTEGER :: IERR
      INTEGER :: IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS
      INTEGER :: TOTAL_SEND_MINUS_RECV266
      INTEGER :: TOTAL_SEND_MINUS_RECV267
      IF (slavef.EQ.1) RETURN
      IF (.NOT. clean_comm_nodes .AND. .NOT. clean_comm_load) THEN
        RETURN
      ENDIF
      DO WHILE (.true.) 
        flag = .true.
        DO WHILE ( flag )
          flag = .false.
          IF (clean_comm_nodes) THEN
            IF ( .NOT. flag ) THEN
              comm_eff = comm_nodes
              CALL mpi_iprobe(mpi_any_source,mpi_any_tag,
     &             comm_nodes, flag, status, ierr)
            END IF
          END IF
          IF (clean_comm_load) THEN
            IF ( .NOT. flag ) THEN
              comm_eff = comm_load
              CALL mpi_iprobe( mpi_any_source, mpi_any_tag,
     &             comm_load, flag, status, ierr)
            END IF
          END IF
          IF (flag) THEN
            msgsou_loc = status( mpi_source )
            msgtag_loc = status( mpi_tag )
            IF (comm_eff .EQ. comm_nodes) THEN
              keep(266) = keep(266) - 1
            ELSE
              keep(267) = keep(267) - 1
            ENDIF
            CALL mpi_get_count( status, mpi_packed, msglen_loc, ierr )
            IF (msglen_loc .LE. lbufr_bytes) THEN
              CALL mpi_recv( bufr, lbufr_bytes,
     &             mpi_packed, msgsou_loc,
     &             msgtag_loc, comm_eff, status, ierr )
            ENDIF
          ENDIF
        END DO
        CALL zmumps_buf_all_empty( clean_comm_nodes,
     &                             clean_comm_load,
     &                             buffers_empty )
        IF ( buffers_empty ) THEN
          ibuf_empty = 0
        ELSE
          ibuf_empty = 1
        ENDIF
        IF (clean_comm_nodes) THEN
          comm_eff = comm_nodes
        ELSE
          comm_eff = comm_load
        ENDIF
        CALL mpi_allreduce(ibuf_empty,
     &                     ibuf_empty_on_all_procs,
     &                     1, mpi_integer, mpi_max,
     &                     comm_eff, ierr)
        IF ( ibuf_empty_on_all_procs == 0) THEN
          buffers_empty_on_all_procs = .true.
        ELSE
          buffers_empty_on_all_procs = .false.
        ENDIF
        IF (buffers_empty_on_all_procs) THEN
          IF (clean_comm_nodes) THEN
            CALL mpi_allreduce(keep(266),
     &                     total_send_minus_recv266,
     &                     1, mpi_integer, mpi_sum,
     &                     comm_eff, ierr)
          ELSE
            total_send_minus_recv266 = 0
          ENDIF
          IF (clean_comm_load) THEN
            CALL mpi_allreduce(keep(267), 
     &                     total_send_minus_recv267,
     &                     1, mpi_integer, mpi_sum,
     &                     comm_eff, ierr)
          ELSE
             total_send_minus_recv267 = 0
          ENDIF
          IF (total_send_minus_recv266 .EQ. 0 .AND.
     &        total_send_minus_recv267 .EQ. 0) THEN
            EXIT
          ENDIF
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE zmumps_clean_pending