csol_distrhs.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
      SUBROUTINE cmumps_scatter_dist_rhs(
     &           NSLAVES, N,
     &           MYID_NODES, COMM_NODES,
     &           NRHS_COL, NRHS_loc, LRHS_loc,
     &           MAP_RHS_loc,
     &           IRHS_loc, RHS_loc, RHS_loc_size,
     &           RHSCOMP, LD_RHSCOMP,
     &           POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP,
     &           LSCAL, scaling_data_dr,
     &           LP, LPOK, KEEP, NB_BYTES_LOC, INFO )
      USE cmumps_struc_def
!$    USE OMP_LIB
      IMPLICIT NONE
      INTEGER, INTENT(IN)    :: NSLAVES, N, MYID_NODES
      INTEGER, INTENT(IN)    :: NRHS_loc, LRHS_loc
      INTEGER, INTENT(IN)    :: NRHS_COL
      INTEGER, INTENT(IN)    :: COMM_NODES
      INTEGER, INTENT(IN)    :: MAP_RHS_loc(max(1,NRHS_loc))
      INTEGER, INTENT(IN)    :: IRHS_loc(NRHS_loc)
      INTEGER(8), INTENT(IN) :: RHS_loc_size
      COMPLEX, INTENT(IN)    :: RHS_loc(RHS_loc_size)
      INTEGER, INTENT(IN)    :: NB_FS_IN_RHSCOMP, LD_RHSCOMP
      INTEGER, INTENT(IN)    :: POSINRHSCOMP_FWD(N)
      COMPLEX, INTENT(OUT)   :: RHSCOMP(LD_RHSCOMP, NRHS_COL)
      INTEGER                :: KEEP(500)
      LOGICAL, INTENT(IN)    :: LSCAL
      type scaling_data_t
        sequence
        REAL, dimension(:), pointer :: SCALING
        REAL, dimension(:), pointer :: SCALING_LOC
      end type scaling_data_t
      type(scaling_data_t), INTENT(IN) :: scaling_data_dr
      LOGICAL, INTENT(IN)    :: LPOK
      INTEGER, INTENT(IN)    :: LP      
      INTEGER, INTENT(INOUT) :: INFO(2) 
      INTEGER(8), INTENT(OUT):: NB_BYTES_LOC
      include 'mpif.h'
      INTEGER :: IERR_MPI
      LOGICAL :: OMP_FLAG
!$    INTEGER :: CHUNK, NOMP
!$    INTEGER(8) :: CHUNK8
      INTEGER :: allocok
      INTEGER :: MAXRECORDS
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND 
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND 
      COMPLEX, ALLOCATABLE, DIMENSION(:,:)   :: BUFR
      INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI 
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted
      INTEGER :: Iloc  
      INTEGER :: Iloc_sorted 
      INTEGER :: IREQ  
      INTEGER :: IMAP, IPROC_MAX 
      INTEGER :: IFS   
      INTEGER :: MAX_ACTIVE_SENDS
      INTEGER :: NB_ACTIVE_SENDS
      INTEGER :: NB_FS_TOUCHED
      INTEGER :: NBROWSTORECV                
      COMPLEX, PARAMETER :: ZERO = (0.0e0, 0.0e0)
!$    NOMP = OMP_GET_MAX_THREADS()
      nb_bytes_loc = 0_8
      ALLOCATE( nbrowstosend(nslaves),
     &          nextrowtosend(nslaves),
     &          irhs_loc_sorted(nrhs_loc),
     &          stat=allocok )
      IF (allocok > 0) THEN
        info(1) = -13
        info(2) = nslaves+nslaves+nrhs_loc
      ENDIF
      nb_bytes_loc = int(2*nslaves+nrhs_loc,8)*keep(34)
      CALL mpi_allreduce( mpi_in_place, allocok, 1,
     &                    mpi_integer, mpi_sum,
     &                    comm_nodes, ierr_mpi )
      IF (allocok .GT. 0) RETURN
      nbrowstosend(1:nslaves) = 0
      DO iloc = 1, nrhs_loc
        IF (irhs_loc(iloc) .GE. 1 .AND.
     &      irhs_loc(iloc) .LE. n) THEN
          imap = map_rhs_loc(iloc)
          nbrowstosend(imap+1) = nbrowstosend(imap+1)+1
        ENDIF
      ENDDO
      nextrowtosend(1)=1 
      DO imap=1, nslaves-1
        nextrowtosend(imap+1)=nextrowtosend(imap)+nbrowstosend(imap)
      ENDDO
      nbrowstosend=0
      DO iloc = 1, nrhs_loc
        IF (irhs_loc(iloc) .GE. 1 .AND.
     &      irhs_loc(iloc) .LE. n) THEN
          imap = map_rhs_loc(iloc)
          iloc_sorted = nextrowtosend(imap+1)+nbrowstosend(imap+1)
          irhs_loc_sorted(iloc_sorted) = iloc
          nbrowstosend(imap+1)=nbrowstosend(imap+1)+1
        ENDIF
      ENDDO
      CALL cmumps_dr_build_nbrowstorecv()
      max_active_sends = min(10, nslaves)
      IF (keep(72) .EQ.1 ) THEN
        maxrecords = 15
      ELSE
        maxrecords = min(200000,2000000/nrhs_col)
        maxrecords = min(maxrecords,
     &                50000000 / max_active_sends / nrhs_col)
        maxrecords = max(maxrecords, 50)
      ENDIF
      ALLOCATE(bufr(maxrecords*nrhs_col,
     &                        max_active_sends),   
     &         mpi_reqi(max_active_sends),         
     &         mpi_reqr(max_active_sends),         
     &         is_send_active(max_active_sends),
     &         bufreci(maxrecords),                
     &         bufrecr(maxrecords*nrhs_col),       
     &         touched(nb_fs_in_rhscomp),          
     &         stat=allocok)
      IF (allocok .GT. 0) THEN
        IF (lp .GT. 0) WRITE(lp, '(A)')
     &    'error: allocation problem in cmumps_scatter_dist_rhs'
        INFO(1)=-13
        INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+
     &          3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL)
     &          + NB_FS_IN_RHSCOMP
      ENDIF
      NB_BYTES_LOC=NB_BYTES_LOC +
     &  KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) +
     &  KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSCOMP,8)) +
     &  KEEP(35) * (
     &      int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8)
     &      + int(MAXRECORDS,8) * int(NRHS_COL,8) )
      CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1,
     &                    MPI_INTEGER, MPI_SUM,
     &                    COMM_NODES, IERR_MPI )
.NE.      IF (allocok  0) RETURN
      NB_ACTIVE_SENDS = 0
      DO IREQ = 1, MAX_ACTIVE_SENDS
        IS_SEND_ACTIVE(IREQ) = .FALSE.
      ENDDO
      NB_FS_TOUCHED = 0
      DO IFS = 1, NB_FS_IN_RHSCOMP
        TOUCHED(IFS) = .FALSE.
      ENDDO
      IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1
.NE.      DO WHILE (NBROWSTOSEND(IPROC_MAX+1)  0)
.EQ.        IF (IPROC_MAX  MYID_NODES) THEN
          CALL CMUMPS_DR_ASSEMBLE_LOCAL()
        ELSE
          CALL CMUMPS_DR_TRY_SEND(IPROC_MAX)
        ENDIF
        CALL CMUMPS_DR_TRY_RECV()
        CALL CMUMPS_DR_TRY_FREE_SEND()
        IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1
      ENDDO
.NE.      DO WHILE ( NBROWSTORECV  0)
        CALL CMUMPS_DR_TRY_RECV()
        CALL CMUMPS_DR_TRY_FREE_SEND()
      ENDDO
.NE.      DO WHILE (NB_ACTIVE_SENDS  0)
        CALL CMUMPS_DR_TRY_FREE_SEND()
      ENDDO
      CALL CMUMPS_DR_EMPTY_ROWS()
      RETURN
      CONTAINS
        SUBROUTINE CMUMPS_DR_BUILD_NBROWSTORECV()
        INTEGER :: IPROC
        DO IPROC = 0, NSLAVES-1
          CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV,
     &                   1, MPI_INTEGER,
     &                   MPI_SUM, IPROC, COMM_NODES, IERR_MPI )
        ENDDO
        END SUBROUTINE CMUMPS_DR_BUILD_NBROWSTORECV
        SUBROUTINE CMUMPS_DR_TRY_RECV()
        IMPLICIT NONE
        INCLUDE 'mumps_tags.h'
        INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU
        INTEGER :: NBRECORDS
        LOGICAL :: FLAG
        CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES,
     &                   FLAG, MPI_STATUS, IERR_MPI )
        IF (FLAG) THEN
          MSGSOU = MPI_STATUS( MPI_SOURCE )
          CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER,
     &                       NBRECORDS, IERR_MPI)
          CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER,
     &                  MSGSOU, DistRhsI,
     &                  COMM_NODES, MPI_STATUS, IERR_MPI)
          CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL,
     &                  MPI_COMPLEX,
     &                  MSGSOU, DistRhsR,
     &                  COMM_NODES, MPI_STATUS, IERR_MPI)
          CALL CMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS,
     &                                        BUFRECI, BUFRECR)
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_DR_TRY_RECV
        SUBROUTINE CMUMPS_DR_ASSEMBLE_FROM_BUFREC
     &             (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG)
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: NBRECORDS
        INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) 
        COMPLEX, INTENT(IN) :: BUFRECR_ARG(NBRECORDS,
     &                                     NRHS_COL)
        INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED
        IFIRSTNOTTOUCHED = NBRECORDS+1
        ILASTNOTTOUCHED  = 0
        DO I = 1, NBRECORDS
.LE.          IF (BUFRECI(I)  0) THEN
            WRITE(*,*) "Internal error 1 in CMUMPS_DR_TRY_RECV",
     &      I, BUFRECI(I), BUFRECI(1)
            CALL MUMPS_ABORT()
          ENDIF
          IRHSCOMP=POSINRHSCOMP_FWD(BUFRECI(I))
          BUFRECI_ARG(I)=IRHSCOMP
.NOT.          IF (  TOUCHED(IRHSCOMP) ) THEN
            IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I)
            ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I)
          ENDIF
        ENDDO
        OMP_FLAG = .FALSE.
.GE..AND.!$      OMP_FLAG = ( NRHS_COLKEEP(362) 
.GE.!$   &               NRHS_COL*NBRECORDS  KEEP(363)/2)
        IF (OMP_FLAG) THEN
!$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG)
        DO K = 1, NRHS_COL
          DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED
            IRHSCOMP=BUFRECI_ARG(I)
.NOT.            IF ( TOUCHED(IRHSCOMP)) THEN
              RHSCOMP(IRHSCOMP,K)=ZERO
            ENDIF
          ENDDO
          DO I = 1, NBRECORDS
            IRHSCOMP=BUFRECI_ARG(I)
            RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K) +
     &                            BUFRECR_ARG(I,K)
          ENDDO
        ENDDO
!$OMP END PARALLEL DO
        ELSE
        DO K = 1, NRHS_COL
          DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED
            IRHSCOMP=BUFRECI_ARG(I)
.NOT.            IF ( TOUCHED(IRHSCOMP)) THEN
              RHSCOMP(IRHSCOMP,K)=ZERO
            ENDIF
          ENDDO
          DO I = 1, NBRECORDS
            IRHSCOMP=BUFRECI_ARG(I)
            RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K) +
     &                            BUFRECR_ARG(I,K)
          ENDDO
        ENDDO
        ENDIF
        DO I = 1, NBRECORDS
          IRHSCOMP = BUFRECI_ARG(I)
.NOT.          IF ( TOUCHED(IRHSCOMP)) THEN
            NB_FS_TOUCHED = NB_FS_TOUCHED + 1
            TOUCHED(IRHSCOMP) = .TRUE.
          ENDIF
        ENDDO
        NBROWSTORECV = NBROWSTORECV - NBRECORDS
        RETURN
        END SUBROUTINE CMUMPS_DR_ASSEMBLE_FROM_BUFREC
        SUBROUTINE CMUMPS_DR_ASSEMBLE_LOCAL()
        INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED
        INTEGER :: Iloc       
        INTEGER :: Iglob      
        INTEGER :: IRHSCOMP   
        INTEGER(8) :: ISHIFT
.EQ.        IF ( NBROWSTOSEND(MYID_NODES+1)  0) THEN
          WRITE(*,*) "Internal error in CMUMPS_DR_ASSEMBLE_LOCAL"
          CALL MUMPS_ABORT()
        ENDIF
        NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1))
        IFIRSTNOTTOUCHED=NBRECORDS+1
        DO I = 1, NBRECORDS
          IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc(
     &               IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1)))
.NOT.          IF ( TOUCHED(IRHSCOMP)) THEN
            IFIRSTNOTTOUCHED=I
            EXIT
          ENDIF
        ENDDO
        IF (LSCAL) THEN
.GE..AND.!$        OMP_FLAG = (NRHS_COLKEEP(362) 
.GE.!$   &                NRHS_COL*NBRECORDS  KEEP(363)/2)
!$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob)
!$OMP&  FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG)
          DO K = 1, NRHS_COL
            ISHIFT = (K-1) * LRHS_loc
            DO I = IFIRSTNOTTOUCHED, NBRECORDS
              IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc(
     &               IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1)))
.NOT.               IF ( TOUCHED(IRHSCOMP)) THEN
                 RHSCOMP(IRHSCOMP,K)=ZERO
               ENDIF
            ENDDO
            DO I = 1, NBRECORDS
              Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1)
              Iglob = IRHS_loc(Iloc)
              IRHSCOMP = POSINRHSCOMP_FWD(Iglob)
              RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+
     &                              RHS_loc(Iloc+ISHIFT)*
     &                        scaling_data_dr%SCALING_LOC(Iloc)
            ENDDO
          ENDDO
!$OMP END PARALLEL DO
        ELSE
.GE..AND.!$        OMP_FLAG = (NRHS_COLKEEP(362) 
.GE.!$   &                NRHS_COL*NBRECORDS  KEEP(363)/2)
!$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob)
!$OMP&  FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG)
          DO K = 1, NRHS_COL
            ISHIFT = (K-1) * LRHS_loc
            DO I = IFIRSTNOTTOUCHED, NBRECORDS
              IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc(
     &               IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1)))
.NOT.               IF ( TOUCHED(IRHSCOMP)) THEN
                 RHSCOMP(IRHSCOMP,K)=ZERO
               ENDIF
            ENDDO
            DO I = 1, NBRECORDS
              Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1)
              Iglob = IRHS_loc(Iloc)
              IRHSCOMP = POSINRHSCOMP_FWD(Iglob)
              RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+
     &                              RHS_loc(Iloc+ISHIFT)
            ENDDO
          ENDDO
!$OMP END PARALLEL DO
        ENDIF
        DO I = 1, NBRECORDS
          IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc(
     &               IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1)))
.NOT.          IF ( TOUCHED(IRHSCOMP)) THEN
            NB_FS_TOUCHED = NB_FS_TOUCHED + 1
            TOUCHED(IRHSCOMP) = .TRUE.
          ENDIF
        ENDDO
        NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+
     &                              NBRECORDS
        NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)-
     &                             NBRECORDS
        NBROWSTORECV = NBROWSTORECV - NBRECORDS
        RETURN
        END SUBROUTINE CMUMPS_DR_ASSEMBLE_LOCAL
        SUBROUTINE CMUMPS_DR_GET_NEW_BUF( IBUF )
        INTEGER, INTENT(OUT) :: IBUF
        INTEGER :: I
        IBUF = -1
.NE.        IF (NB_ACTIVE_SENDS  MAX_ACTIVE_SENDS) THEN
          DO I=1, MAX_ACTIVE_SENDS
.NOT.            IF ( IS_SEND_ACTIVE(I)) THEN
              IBUF = I
              EXIT
            ENDIF
          ENDDO
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_DR_GET_NEW_BUF
        SUBROUTINE CMUMPS_DR_TRY_FREE_SEND()
        INTEGER :: MPI_STATUS(MPI_STATUS_SIZE)
        INTEGER :: I
        LOGICAL :: FLAG
.GT.        IF (NB_ACTIVE_SENDS  0) THEN
          DO I=1, MAX_ACTIVE_SENDS
            IF (IS_SEND_ACTIVE(I)) THEN
              CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI )
              IF (FLAG) THEN
                 CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI)
                 NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1
                 IS_SEND_ACTIVE(I)=.FALSE.
.EQ.                 IF (NB_ACTIVE_SENDS  0) THEN
                   RETURN
                 ENDIF
              ENDIF
            ENDIF
          ENDDO
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_DR_TRY_FREE_SEND
        SUBROUTINE CMUMPS_DR_TRY_SEND(IPROC_ARG)
        IMPLICIT NONE
        INTEGER, INTENT(IN)    :: IPROC_ARG
        INCLUDE 'mumps_tags.h'
        INTEGER :: NBRECORDS, IBUF, I, K
        INTEGER(8) :: IPOSRHS 
        INTEGER    :: IPOSBUF 
.EQ.        IF (IPROC_ARG  MYID_NODES) THEN
          WRITE(*,*) "Internal error 1 in CMUMPS_DR_TRY_SEND"
          CALL MUMPS_ABORT()
        ENDIF
.EQ.        IF (NBROWSTOSEND(IPROC_ARG+1)  0) THEN
          WRITE(*,*) "Internal error 2 in CMUMPS_DR_TRY_SEND"
          CALL MUMPS_ABORT()
        ENDIF
        CALL CMUMPS_DR_GET_NEW_BUF(IBUF)
.GT.        IF (IBUF  0) THEN
          NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1))
!$        OMP_FLAG = .FALSE.
!$        CHUNK = NRHS_COL*NBRECORDS
.GE.!$        IF (CHUNK  KEEP(363)) THEN
!$          OMP_FLAG = .TRUE.
!$          CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2)
!$        ENDIF
          IF (LSCAL) THEN
!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK)
!$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG)
            DO K=1, NRHS_COL
              DO I = 1, NBRECORDS
                IPOSBUF = (K-1)*NBRECORDS
                IPOSRHS = int(K-1,8)*int(LRHS_loc,8)
                Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1)
                BUFR( IPOSBUF + I, IBUF )
     &                = RHS_loc( IPOSRHS + Iloc ) *
     &                  scaling_data_dr%SCALING_LOC(Iloc)
              ENDDO
            ENDDO
!$OMP END PARALLEL DO
          ELSE
!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK)
!$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG)
            DO K=1, NRHS_COL
              DO I = 1, NBRECORDS
                IPOSBUF = (K-1)*NBRECORDS
                IPOSRHS = int(K-1,8)*int(LRHS_loc,8)
                Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1)
                BUFR( IPOSBUF + I, IBUF )
     &              = RHS_loc( IPOSRHS + Iloc )
              ENDDO
            ENDDO
!$OMP END PARALLEL DO
          ENDIF
          DO I = 1, NBRECORDS
            Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1)
            IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1)
     &           = IRHS_loc(Iloc)
          ENDDO
          CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)),
     &                    NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI,
     &                    COMM_NODES, MPI_REQI(IBUF), IERR_MPI )
          CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL,
     &                    MPI_COMPLEX,
     &                    IPROC_ARG, DistRhsR,
     &                    COMM_NODES, MPI_REQR(IBUF), IERR_MPI )
          NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+
     &                               NBRECORDS
          NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS
          NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1
          IS_SEND_ACTIVE(IBUF)=.TRUE.
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_DR_TRY_SEND
        SUBROUTINE CMUMPS_DR_EMPTY_ROWS()
        INTEGER :: K, IFS
.NE.        IF ( NB_FS_TOUCHED  NB_FS_IN_RHSCOMP ) THEN
.GE..AND.!$        OMP_FLAG = (NRHS_COL  KEEP(362)) 
!$   &    (NRHS_COL*NB_FS_IN_RHSCOMP >  KEEP(363)/2)
!$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG)
          DO K = 1, NRHS_COL
            DO IFS = 1, NB_FS_IN_RHSCOMP
.NOT.              IF (  TOUCHED(IFS) ) THEN
                RHSCOMP( IFS, K) = ZERO
              ENDIF
            ENDDO
            DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP
              RHSCOMP (IFS, K) = ZERO
            ENDDO
          ENDDO
!$OMP END PARALLEL DO
        ELSE
!$        OMP_FLAG = .FALSE.
!$        CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8)
!$        CHUNK8 = max(CHUNK8,1_8)
.GE.!$        IF (CHUNK8  int(KEEP(363),8)) THEN
!$          OMP_FLAG = .TRUE.
!$          CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8))
!$        ENDIF
!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8)
!$OMP&  IF (OMP_FLAG)
          DO K = 1, NRHS_COL
            DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP
             RHSCOMP (IFS, K) = ZERO
            ENDDO
          ENDDO
!$OMP END PARALLEL DO
        ENDIF
        RETURN
        END SUBROUTINE CMUMPS_DR_EMPTY_ROWS
      END SUBROUTINE CMUMPS_SCATTER_DIST_RHS
      SUBROUTINE CMUMPS_SOL_INIT_IRHS_loc(id)
      USE CMUMPS_STRUC_DEF
      IMPLICIT NONE
        TYPE (CMUMPS_STRUC) :: id
        INTEGER, PARAMETER :: MASTER = 0
        INTEGER            :: ROW_OR_COL_INDICES 
        INTEGER            :: IERR_MPI
        LOGICAL            :: I_AM_SLAVE
        INTEGER, POINTER   :: idIRHS_loc(:)
        INTEGER, POINTER   :: UNS_PERM(:)
        INTEGER            :: UNS_PERM_TO_BE_DONE, I, allocok
        INTEGER, TARGET    :: IDUMMY(1)
        INCLUDE 'mpif.h'
        NULLIFY(uns_perm)
        IF (id%JOB .NE. 9) THEN
          WRITE(*,*) "Internal error 1 in CMUMPS_SOL_INIT_IRHS_loc"
          CALL mumps_abort()
        ENDIF
        i_am_slave = ( id%MYID .ne. master  .OR.
     &               ( id%MYID .eq. master .AND.
     &                 id%KEEP(46) .eq. 1 ) )
        IF (id%MYID .EQ. master) THEN
          IF (id%ICNTL(20).EQ.10) THEN
            row_or_col_indices = 0 
          ELSE IF (id%ICNTL(20).EQ.11) THEN
            row_or_col_indices = 1 
          ELSE 
            row_or_col_indices = 0 
          ENDIF
          IF (id%ICNTL(9) .NE. 1) THEN
            row_or_col_indices = 1 - row_or_col_indices
          ENDIF
          IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN
            uns_perm_to_be_done = 1
          ELSE
            uns_perm_to_be_done = 0
          ENDIF
        ENDIF
        CALL mpi_bcast(row_or_col_indices,1,mpi_integer,master,
     &               id%COMM,ierr_mpi)
        CALL mpi_bcast(uns_perm_to_be_done,1,mpi_integer,master,
     &               id%COMM,ierr_mpi)
        IF ( i_am_slave ) THEN
          IF (id%KEEP(89) .GT. 0) THEN
            IF (.NOT. associated(id%IRHS_loc)) THEN
              id%INFO(1)=-22
              id%INFO(2)=17
            ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN
              id%INFO(1)=-22
              id%INFO(2)=17
            ENDIF
          ENDIF
        ENDIF
        CALL mumps_propinfo( id%ICNTL(1),
     &                       id%INFO(1),
     &                       id%COMM, id%MYID )
        IF (id%INFO(1).LT.0) goto 500
        IF (i_am_slave) THEN
          IF (associated(id%IRHS_loc)) THEN
            IF (size(id%IRHS_loc) .GT. 0) THEN
              idirhs_loc => id%IRHS_loc
            ELSE
              idirhs_loc => idummy
            ENDIF
          ELSE
            idirhs_loc => idummy
          ENDIF
          CALL mumps_build_irhs_loc(id%MYID_NODES, id%NSLAVES, id%N,
     &    id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1),
     &    max(1, id%KEEP(32)),
     &    id%STEP(1), id%PROCNODE_STEPS(1), idirhs_loc(1),
     &    row_or_col_indices)
        ENDIF
        IF (uns_perm_to_be_done .EQ. 1) THEN
          IF (id%MYID.NE.master) THEN
            ALLOCATE(uns_perm(id%N),stat=allocok)
            IF (allocok > 0) THEN
                id%INFO(1)=-13
                id%INFO(2)=id%N
                GOTO 100
            ENDIF
          ENDIF
 100      CONTINUE
          CALL mumps_propinfo( id%ICNTL(1),
     &                         id%INFO(1),
     &                         id%COMM, id%MYID )
          IF (id%INFO(1) .LT. 0) GOTO 500
          IF ( id%MYID .EQ. master ) THEN
            uns_perm => id%UNS_PERM
          ENDIF
          CALL mpi_bcast(uns_perm(1),id%N,mpi_integer,master,
     &               id%COMM,ierr_mpi)
          IF (i_am_slave .AND. id%KEEP(89) .NE.0) THEN
            DO i=1, id%KEEP(89)
              id%IRHS_loc(i)=uns_perm(id%IRHS_loc(i))
            ENDDO
          ENDIF
        ENDIF
 500    CONTINUE
        IF (id%MYID.NE.master) THEN
           IF (associated(uns_perm)) DEALLOCATE(uns_perm)
        ENDIF
        NULLIFY(uns_perm)
        RETURN
      END SUBROUTINE cmumps_sol_init_irhs_loc