sfac_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 smumps_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 smumps_load
      USE smumps_struc_def, ONLY : smumps_root_struc
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (smumps_root_struc) :: root
      INTEGER msgsou, msgtag, msglen
      INTEGER lbufr, LBUFR_BYTES
      INTEGER bufr( lbufr )
      INTEGER keep(500), icntl( 60 )
      INTEGER(8) keep8(150)
      REAL    dkeep(230)
      INTEGER(8) :: posfac, iptrlu, lrlu, lrlus, la
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      INTEGER, intent(in) :: lrgroups(n)
      REAL 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))
      REAL :: 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) )
      REAL 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 smumps_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 smumps_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="SMUMPS_PROCESS_NODE"
          IF ( iflag .LT. 0 ) GO TO 500
          IF ( flag ) THEN
            CALL smumps_insert_pool_n(n, ipool, lpool,
     &           procnode_steps, slavef, keep(199), keep(28), keep(76),
     &           keep(80), keep(47), step, fpere )
            IF (keep(47) .GE. 3) THEN
               CALL smumps_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) )
            IF (fpere.NE.keep(20))
     &        CALL smumps_load_update(1,.false.,flop1,keep,keep8)
          ENDIF
      ELSEIF ( msgtag .EQ. end_niv2_ldlt ) THEN
          inode = bufr( 1 )
          CALL smumps_insert_pool_n(n, ipool, lpool,
     &         procnode_steps, slavef, keep(199),
     &         keep(28), keep(76), keep(80), keep(47),
     &         step, -inode )
          IF (keep(47) .GE. 3) THEN
             CALL smumps_load_pool_upd_new_pool(
     &            ipool, lpool,
     &            procnode_steps, keep,keep8, slavef, comm_load,
     &            myid, step, n, nd, fils )
          ENDIF
      ELSEIF ( msgtag .EQ. terreur ) THEN
          iflag  = -001
          ierror = msgsou
          GOTO 100
      ELSEIF ( msgtag .EQ. maitre_desc_bande ) THEN
        CALL smumps_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="SMUMPS_PROCESS_DESC_BANDE"
        IF ( iflag .LT. 0 ) GO to 500
      ELSEIF ( msgtag .EQ. maitre2           ) THEN
        CALL smumps_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="SMUMPS_PROCESS_MASTER2"
        IF ( iflag .LT. 0 ) GO to 500
      ELSEIF ( msgtag .EQ. bloc_facto  .OR.
     &         msgtag .EQ. bloc_facto_relay ) THEN
        CALL smumps_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
     &     )
      ELSEIF ( msgtag .EQ. bloc_facto_sym_slave    ) THEN
        CALL smumps_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
     &     )
      ELSEIF ( msgtag .EQ. bloc_facto_sym    ) THEN
        CALL smumps_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
     & )
      ELSEIF ( msgtag .EQ. contrib_type2    ) THEN
        CALL smumps_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
     &       )
        IF ( iflag .LT. 0 ) GO TO 100
      ELSEIF ( msgtag .EQ. 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 )
         IF ( nslaves_pere.NE.0 ) 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 smumps_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
     &    )
         IF ( iflag .LT. 0 ) GO TO 100
      ELSE IF ( msgtag .EQ. root_cont_static ) THEN
        CALL smumps_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="SMUMPS_PROCESS_CONTRIB_TYPE3"
        IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. root_non_elim_cb ) THEN
        iroot  = keep( 38 )
        msgsou = mumps_procnode( procnode_steps(step(iroot)), 
     &           keep(199) )
        IF ( ptlust( step(iroot)) .EQ. 0 ) THEN
          keep(266)=keep(266)-1
          CALL mpi_recv( tmp, 2 * keep(34), mpi_packed,
     &                   msgsou, root_2slave,
     &                   comm, status, ierr )
          CALL smumps_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="SMUMPS_PROCESS_ROOT2SLAVE"
          IF ( iflag .LT. 0 ) GOTO 500
        END IF
        CALL smumps_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="SMUMPS_PROCESS_CONTRIB_TYPE3"
        IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. root_2son ) THEN
         ison  = bufr( 1 )
         nelim = bufr( 2 )
         CALL smumps_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 smumps_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 smumps_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 smumps_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="SMUMPS_PROCESS_RTNELIND"
         IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. update_load ) THEN
         WRITE(*,*) "Internal error 3 in SMUMPS_TRAITER_MESSAGE"
         CALL mumps_abort()
      ELSE IF ( msgtag .EQ. tag_dummy   ) THEN
      ELSE
         IF ( lp > 0 )
     &     WRITE(lp,*) myid,
     &': Internal error, routine SMUMPS_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
.EQ.        IF (IFLAG-8) THEN
         WRITE(LP,*) 'failure in INTEGER allocation during ',SUBNAME
        ENDIF
.EQ.        IF (IFLAG-13) THEN
         WRITE(LP,*) 'failure in dynamic allocation during ',SUBNAME
        ENDIF
      ENDIF
      CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE SMUMPS_TRAITER_MESSAGE
      RECURSIVE SUBROUTINE SMUMPS_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 SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      TYPE (SMUMPS_ROOT_STRUC) :: root
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER KEEP(500), ICNTL(60)
      INTEGER(8) KEEP8(150)
      REAL       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 )
      REAL 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) )
      REAL :: 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) )
      REAL 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 )
.GT.      IF ( MSGLEN  LBUFR_BYTES ) THEN
        IFLAG  = -20
        IERROR = MSGLEN
         WRITE(*,*) ' reception buf too small, msgtag/len=',
     &                MSGTAG,MSGLEN
        CALL SMUMPS_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 SMUMPS_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 SMUMPS_RECV_AND_TREAT
      RECURSIVE SUBROUTINE SMUMPS_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 SMUMPS_LOAD
      USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      TYPE (SMUMPS_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)
      REAL       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 )
      REAL 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) )
      REAL :: 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) )
      REAL 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 SMUMPS_LOAD_RECV_MSGS(COMM_LOAD)
.NOT.      IF (  STACK_RIGHT_AUTHORIZED ) THEN
          RETURN
      ENDIF
      RECURS = RECURS + 1
      LP = ICNTL(1)
.LT.      IF (ICNTL(4)1) LP=-1
      IF ( MESSAGE_RECEIVED ) THEN
        MSGSOU_LOC = MPI_ANY_SOURCE
        MSGTAG_LOC = MPI_ANY_TAG
        GOTO 250
      ENDIF
.NE.      IF ( ASS_IRECV  MPI_REQUEST_NULL) THEN
.NE.        IF (KEEP(117)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.
.NE..OR.          IF ( ( (MSGSOUMPI_ANY_SOURCE) 
.NE.     &      (MSGTAGMPI_ANY_TAG) )  ) THEN
.NE.            IF ( MSGSOUMPI_ANY_SOURCE) THEN
.EQ.              RIGHT_MESS = MSGSOUSTATUS(MPI_SOURCE)
            ENDIF
.NE.            IF ( MSGTAGMPI_ANY_TAG) THEN
              RIGHT_MESS =
.EQ..AND.     &        ( (MSGTAGSTATUS(MPI_TAG))RIGHT_MESS )
            ENDIF
.NOT.            IF (RIGHT_MESS) THEN
              CALL MPI_PROBE(MSGSOU,MSGTAG,
     &           COMM, STATUS_BIS, IERR)
            ENDIF
          ENDIF
        ELSE 
          CALL MPI_TEST(ASS_IRECV,
     &             FLAG, STATUS, IERR)
        ENDIF
.LT.        IF (IERR0) THEN
          IFLAG = -20
.GT.          IF (LP0)
     &    write(LP,*) ' error return from mpi_test ',
     &     IFLAG, ' in smumps_try_recvtreat'
          CALL SMUMPS_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 )
.NOT.           IF (RIGHT_MESS) RECURS = RECURS + 10
          CALL SMUMPS_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
     &      )
.NOT.          IF (RIGHT_MESS) RECURS = RECURS - 10
.LT.          IF ( IFLAG  0 ) RETURN
.NOT.          IF (RIGHT_MESS) THEN
.NE.             IF (ASS_IRECV  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 SMUMPS_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
     &            )
.LT.                  IF ( IFLAG  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 SMUMPS_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
     &   )
.LT.          IF ( IFLAG  0 ) RETURN
        ENDIF
      ENDIF
 250  CONTINUE
      RECURS  = RECURS - 1
.EQ.      IF ( NBFIN  0 ) RETURN
.GT.      IF ( RECURS  3 ) RETURN
.EQ..AND..AND.      IF ( KEEP(36)1  SET_IRECV  
.EQ..AND.     &      (ASS_IRECVMPI_REQUEST_NULL) 
     &    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 SMUMPS_TRY_RECVTREAT
      SUBROUTINE SMUMPS_CANCEL_IRECV( INFO1,
     &    KEEP, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES,
     &    COMM,
     &    MYID, SLAVEF)
      USE SMUMPS_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
.EQ.      IF (SLAVEF  1) RETURN
.EQ.      IF (ASS_IRECVMPI_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 SMUMPS_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 SMUMPS_CANCEL_IRECV
      SUBROUTINE SMUMPS_CLEAN_PENDING(
     &    INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES,
     &    COMM_NODES, COMM_LOAD, SLAVEF,
     &    CLEAN_COMM_NODES, CLEAN_COMM_LOAD )
      USE SMUMPS_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
.EQ.      IF (SLAVEF1) RETURN
.NOT..AND..NOT.      IF ( CLEAN_COMM_NODES   CLEAN_COMM_LOAD) THEN
        RETURN
      ENDIF
      DO WHILE (.TRUE.) 
        FLAG = .TRUE.
        DO WHILE ( FLAG )
          FLAG = .FALSE.
          IF (CLEAN_COMM_NODES) THEN
.NOT.            IF (  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
.NOT.            IF (  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 )
.EQ.            IF (COMM_EFF  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 )
.LE.            IF (MSGLEN_LOC  LBUFR_BYTES) THEN
              CALL MPI_RECV( BUFR, LBUFR_BYTES,
     &             MPI_PACKED, MSGSOU_LOC,
     &             MSGTAG_LOC, COMM_EFF, STATUS, IERR )
            ENDIF
          ENDIF
        END DO
        CALL SMUMPS_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
.EQ..AND.          IF (TOTAL_SEND_MINUS_RECV266  0 
.EQ.     &        TOTAL_SEND_MINUS_RECV267  0) THEN
            EXIT
          ENDIF
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE SMUMPS_CLEAN_PENDING