dfac_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 dmumps_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 dmumps_load
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (dmumps_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)
      DOUBLE PRECISION 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))
      DOUBLE PRECISION :: 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) )
      DOUBLE PRECISION 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 dmumps_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 dmumps_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="DMUMPS_PROCESS_NODE"
          IF ( iflag .LT. 0 ) GO TO 500
          IF ( flag ) THEN
            CALL dmumps_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 dmumps_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 dmumps_load_update(1,.false.,flop1,keep,keep8)
          ENDIF
      ELSEIF ( msgtag .EQ. end_niv2_ldlt ) THEN
          inode = bufr( 1 )
          CALL dmumps_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 dmumps_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 dmumps_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="DMUMPS_PROCESS_DESC_BANDE"
        IF ( iflag .LT. 0 ) GO to 500
      ELSEIF ( msgtag .EQ. maitre2           ) THEN
        CALL dmumps_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="DMUMPS_PROCESS_MASTER2"
        IF ( iflag .LT. 0 ) GO to 500
      ELSEIF ( msgtag .EQ. bloc_facto  .OR.
     &         msgtag .EQ. bloc_facto_relay ) THEN
        CALL dmumps_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 dmumps_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 dmumps_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 dmumps_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 dmumps_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 dmumps_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="DMUMPS_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 dmumps_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="DMUMPS_PROCESS_ROOT2SLAVE"
          IF ( iflag .LT. 0 ) GOTO 500
        END IF
        CALL dmumps_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="DMUMPS_PROCESS_CONTRIB_TYPE3"
        IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. root_2son ) THEN
         ison  = bufr( 1 )
         nelim = bufr( 2 )
         CALL dmumps_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 dmumps_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 dmumps_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 dmumps_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="DMUMPS_PROCESS_RTNELIND"
         IF ( iflag .LT. 0 ) GO TO 500
      ELSE IF ( msgtag .EQ. update_load ) THEN
         WRITE(*,*) "Internal error 3 in DMUMPS_TRAITER_MESSAGE"
         CALL mumps_abort()
      ELSE IF ( msgtag .EQ. tag_dummy   ) THEN
      ELSE
         IF ( lp > 0 )
     &     WRITE(lp,*) myid,
     &': Internal error, routine DMUMPS_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 dmumps_bdc_error( myid, slavef, comm, keep )
      RETURN
      END SUBROUTINE dmumps_traiter_message
      RECURSIVE SUBROUTINE dmumps_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 dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      TYPE (dmumps_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 )
      DOUBLE PRECISION 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) )
      DOUBLE PRECISION :: 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) )
      DOUBLE PRECISION 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 dmumps_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 dmumps_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 dmumps_recv_and_treat
      RECURSIVE SUBROUTINE dmumps_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 dmumps_load
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      include 'mumps_tags.h'
      TYPE (dmumps_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 )
      DOUBLE PRECISION 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) )
      DOUBLE PRECISION :: 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) )
      DOUBLE PRECISION 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 dmumps_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 DMUMPS_TRY_RECVTREAT'
          CALL dmumps_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 dmumps_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 dmumps_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 dmumps_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 dmumps_try_recvtreat
      SUBROUTINE dmumps_cancel_irecv( INFO1,
     &    KEEP, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES,
     &    COMM,
     &    MYID, SLAVEF)
      USE dmumps_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 dmumps_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 dmumps_cancel_irecv
      SUBROUTINE dmumps_clean_pending(
     &    INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES,
     &    COMM_NODES, COMM_LOAD, SLAVEF,
     &    CLEAN_COMM_NODES, CLEAN_COMM_LOAD )
      USE dmumps_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 dmumps_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 dmumps_clean_pending