RFLU_ModMPI.F90

Go to the documentation of this file.

! *********************************************************************
! * Rocstar Simulation Suite                                          *
! * Copyright@2015, Illinois Rocstar LLC. All rights reserved.        *
! *                                                                   *
! * Illinois Rocstar LLC                                              *
! * Champaign, IL                                                     *
! * www.illinoisrocstar.com                                           *
! * sales@illinoisrocstar.com                                         *
! *                                                                   *
! * License: See LICENSE file in top level of distribution package or *
! * http://opensource.org/licenses/NCSA                               *
! *********************************************************************
! *********************************************************************
! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,   *
! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES   *
! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND          *
! * NONINFRINGEMENT.  IN NO EVENT SHALL THE CONTRIBUTORS OR           *
! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER       *
! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,   *
! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE    *
! * USE OR OTHER DEALINGS WITH THE SOFTWARE.                          *
! *********************************************************************
! ******************************************************************************
!
! Purpose: Suite of routines for MPI interaction.
!
! Description: None.
!
! Notes: None. 
!
! ******************************************************************************
!
! $Id: RFLU_ModMPI.F90,v 1.17 2008/12/06 08:44:22 mtcampbe Exp $
!
! Copyright: (c) 2005 by the University of Illinois
!
! ******************************************************************************

MODULE rflu_modmpi

  USE modglobal, ONLY: t_global
  USE moddatatypes
  USE modparameters
  USE moderror
  USE moddatastruct, ONLY: t_region
  USE modgrid, ONLY: t_grid
  USE modmixture, ONLY: t_mixt_input
  USE modborder, ONLY: t_border,t_border_data
  USE modmpi

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: rflu_mpi_clearrequestwrapper, &
            rflu_mpi_copywrapper, & 
            rflu_mpi_createbufferipclsend, &        
            rflu_mpi_createbufferswrapper, &    
            rflu_mpi_destroybufferipclsend, &           
            rflu_mpi_destroybufferswrapper, &        
            rflu_mpi_isendwrapper, & 
            rflu_mpi_recreatebufferipclsend, &
            rflu_mpi_recvwrapper, & 
            rflu_mpi_settagswrapper
    
! ******************************************************************************
! Declarations and definitions
! ******************************************************************************  
      
  CHARACTER(CHRLEN) :: & 
    RCSIdentString = '$RCSfile: RFLU_ModMPI.F90,v $ $Revision: 1.17 $' 
                      
! ******************************************************************************
! Routines
! ******************************************************************************

  CONTAINS






! ******************************************************************************
!
! Purpose: Clearing send requests.
!
! Description: None.
!
! Input:
!   global      Pointer to global data
!   request     Request (to be cleared)
!
! Output: 
!   request     Request (cleared)
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_clearrequest(global,request)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    INTEGER, INTENT(INOUT) :: request
    TYPE(t_global), POINTER :: global  
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag
    INTEGER :: status(mpi_status_size)          
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_ClearRequest',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    CALL mpi_wait(request,status,errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_mpi_output,__line__)
    END IF ! global%error

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_clearrequest









! ******************************************************************************
!
! Purpose: Wrapper for clearing send requests.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_clearrequestwrapper(pRegion)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), POINTER :: pregion
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder
    TYPE(t_border), POINTER :: pborder 
    TYPE(t_global), POINTER :: global  
    TYPE(t_grid), POINTER :: pgrid             
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_ClearRequestWrapper',&
  'RFLU_ModMPI.F90')

#ifdef ROCPROF 
    CALL fprofiler_begins("RFLU::ClearRequestWrapper")
#endif

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid
    
! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO iborder = 1,pgrid%nBorders
      pborder => pgrid%borders(iborder)
    
! ==============================================================================
!     Clear request if not on same process
! ==============================================================================    
    
      IF ( pborder%iProc /= global%myProcid ) THEN 
        IF ( pborder%nCellsSend > 0 ) THEN 

! ------------------------------------------------------------------------------
!         Mixture
! ------------------------------------------------------------------------------      

          CALL rflu_mpi_clearrequest(global,pborder%mixt%sendRequest)

! ------------------------------------------------------------------------------
!         Physical modules
! ------------------------------------------------------------------------------      

#ifdef SPEC
          IF ( global%specUsed .EQV. .true. ) THEN 
            CALL rflu_mpi_clearrequest(global,pborder%spec%sendRequest)   
          END IF ! global%specUsed
#endif  
        END IF ! pBorder%nCellsSend
      END IF ! pBorder
    END DO ! iBorder

! ******************************************************************************
!   End
! ******************************************************************************

#ifdef ROCPROF 
    CALL fprofiler_ends("RFLU::ClearRequestWrapper")
#endif

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_clearrequestwrapper






! ******************************************************************************
!
! Purpose: Copy cell data.
!
! Description: None.
!
! Input:
!   global      Pointer to global data
!   pBorder     Pointer to border
!   cellData    Array with cell data
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_copycelldata(global,pBorder,pBorder2,cellData,cellData2)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: celldata
    REAL(RFREAL), DIMENSION(:,:), INTENT(OUT) :: celldata2    
    TYPE(t_border), POINTER :: pborder,pborder2
    TYPE(t_global), POINTER :: global         
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,icg,icg2,icl,ivar,nvars        
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_CopyCellData',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set variables
! ******************************************************************************

    nvars = SIZE(celldata,1)
    
    IF ( nvars /= SIZE(celldata2,1) ) THEN 
      CALL errorstop(global,err_datadim_mismatch,__line__)
    END IF ! nVars 
    
! ******************************************************************************
!   Copy data 
! ******************************************************************************

    DO icl = 1,pborder%nCellsSend
      icg  = pborder%icgSend(icl)
      icg2 = pborder2%icgRecv(icl)

      DO ivar = 1,nvars
        celldata2(ivar,icg2) = celldata(ivar,icg) 
      END DO ! iVar      
    END DO ! icl
        
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_copycelldata









! ******************************************************************************
!
! Purpose: Wrapper for copying data.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_copywrapper(regions)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), DIMENSION(:), POINTER :: regions
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder,iborder2,ireg,ireg2
    TYPE(t_border), POINTER :: pborder,pborder2 
    TYPE(t_global), POINTER :: global 
    TYPE(t_grid), POINTER :: pgrid     
    TYPE(t_region), POINTER :: pregion,pregion2
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => regions(0)%global

    CALL registerfunction(global,'RFLU_MPI_CopyWrapper',&
  'RFLU_ModMPI.F90')

#ifdef ROCPROF 
    CALL fprofiler_begins("RFLU::CopyWrapper")
#endif

! ******************************************************************************
!   Set pointers
! ******************************************************************************
    
! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO ireg = 1,global%nRegionsLocal
      pregion => regions(ireg)
      pgrid   => pregion%grid      

      DO iborder = 1,pgrid%nBorders
        pborder => pgrid%borders(iborder)

! ==============================================================================
!       Copy data if on same process
! ==============================================================================    

        IF ( pborder%iProc == global%myProcid ) THEN
          ireg2    = pborder%iRegionLocal
          iborder2 = pborder%iBorder

          pregion2 => regions(ireg2)     
          pborder2 => pregion2%grid%borders(iborder2) 

! ------------------------------------------------------------------------------
!         Check dimensions
! ------------------------------------------------------------------------------

          IF ( pborder%nCellsSend /= pborder2%nCellsRecv ) THEN 
            CALL errorstop(global,err_bufferdim_mismatch,__line__)
          END IF ! pBorder
          
! ------------------------------------------------------------------------------
!         Mixture
! ------------------------------------------------------------------------------      
      
          CALL rflu_mpi_copycelldata(global,pborder,pborder2, & 
                                     pregion%mixt%cv,pregion2%mixt%cv)      
                                     
! ------------------------------------------------------------------------------
!         Physical modules
! ------------------------------------------------------------------------------      

#ifdef SPEC
          IF ( global%specUsed .EQV. .true. ) THEN 
            CALL rflu_mpi_copycelldata(global,pborder,pborder2, & 
                                       pregion%spec%cv,pregion2%spec%cv)     
          END IF ! global%specUsed
#endif           
                          
        END IF ! pBorder
      END DO ! iBorder
    END DO ! iReg

! ******************************************************************************
!   End
! ******************************************************************************

#ifdef ROCPROF 
    CALL fprofiler_ends("RFLU::CopyWrapper")
#endif

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_copywrapper








! ******************************************************************************
!
! Purpose: Create iPclSend buffers.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!   pBorder     Pointer to border (Optional)
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_createbufferipclsend(pRegion,pBorder)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_border), POINTER, OPTIONAL :: pborder
    TYPE(t_region), POINTER :: pregion 
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder,nvars
    TYPE(t_global), POINTER :: global
    TYPE(t_grid), POINTER :: pgrid     
    TYPE(t_border), POINTER :: pborder2
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_CreateBufferIPclSend',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid

! ******************************************************************************
!   Loop over borders when pBorder is not present
!    else allocate only for select pBorder
! ******************************************************************************

#ifdef PLAG
    IF ( present(pborder) ) THEN
      nvars = SIZE(pborder%iPclSend,1)

      ALLOCATE(pborder%iPclSend(nvars,pborder%nPclsSendMax),stat=errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN
        CALL errorstop(global,err_allocate,__line__,'pBorder%iPclSend')
      END IF ! global%error

    ELSE
      DO iborder = 1,pgrid%nBorders
        pborder2 => pgrid%borders(iborder)

        nvars = 2
        pborder2%nPclsSendMax = 1000

        ALLOCATE(pborder2%iPclSend(nvars,pborder2%nPclsSendMax),stat=errorflag)
        global%error = errorflag
        IF ( global%error /= err_none ) THEN
          CALL errorstop(global,err_allocate,__line__,'pBorder%iPclSend')
        END IF ! global%error
      END DO ! iBorder
    END IF ! PRESENT(pBorder)
#endif

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
      
  END SUBROUTINE rflu_mpi_createbufferipclsend








! ******************************************************************************
!
! Purpose: Create buffers.
!
! Description: None.
!
! Input:
!   global      Pointer to global data
!   pBorder     Pointer to border
!   borderData  Border data
!   nVars       Number of variables in borderData
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_createbuffers(global,pBorder,borderData,nVars)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    INTEGER, INTENT(IN) :: nvars
    TYPE(t_global), POINTER :: global
    TYPE(t_border), POINTER :: pborder 
    TYPE(t_border_data) :: borderdata
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag       
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_CreateBuffers',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Allocate memory
! ******************************************************************************
       
    ALLOCATE(borderdata%sendBuff(nvars,pborder%nCellsSend),stat=errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_allocate,__line__,'borderData%sendBuff')
    END IF ! global%error

    ALLOCATE(borderdata%recvBuff(nvars,pborder%nCellsRecv),stat=errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_allocate,__line__,'borderData%recvBuff')
    END IF ! global%error   

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
      
  END SUBROUTINE rflu_mpi_createbuffers







! ******************************************************************************
!
! Purpose: Wrapper for creating buffers.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_createbufferswrapper(pRegion)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), POINTER :: pregion
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder   
    TYPE(t_border), POINTER :: pborder        
    TYPE(t_global), POINTER :: global
    TYPE(t_grid), POINTER :: pgrid 
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_CreateBuffersWrapper',&
  'RFLU_ModMPI.F90')

    IF ( global%myProcid == masterproc .AND. &
         global%verbLevel >= verbose_high ) THEN
      WRITE(stdout,'(A,1X,A)') solver_name,'Creating buffers...'
    END IF ! global%verbLevel

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid

! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO iborder = 1,pgrid%nBorders
      pborder => pgrid%borders(iborder)

! ==============================================================================
!     Create buffers if not on same process
! ==============================================================================    
      
      IF ( pborder%iProc /= global%myProcid ) THEN
      
! ------------------------------------------------------------------------------
!       Mixture
! ------------------------------------------------------------------------------      
 
        CALL rflu_mpi_createbuffers(global,pborder,pborder%mixt, &
                                    pregion%mixtInput%nCv)

! ------------------------------------------------------------------------------
!       Physical modules
! ------------------------------------------------------------------------------      

#ifdef SPEC
        IF ( global%specUsed .EQV. .true. ) THEN 
          CALL rflu_mpi_createbuffers(global,pborder,pborder%spec, & 
                                      pregion%specInput%nSpecies)   

        END IF ! global%specUsed        
#endif                           
      END IF ! pBorder%iProc
    END DO ! iBorder
        
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)

    IF ( global%myProcid == masterproc .AND. &
         global%verbLevel >= verbose_high ) THEN
      WRITE(stdout,'(A,1X,A)') solver_name,'Creating buffers done.'
    END IF ! global%verbLevel
      
  END SUBROUTINE rflu_mpi_createbufferswrapper








! ******************************************************************************
!
! Purpose: Destroy iPclSend buffers.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!   pBorder     Pointer to border (optional)
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_destroybufferipclsend(pRegion,pBorder)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_border), POINTER, OPTIONAL :: pborder
    TYPE(t_region), POINTER :: pregion 
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder      
    TYPE(t_global), POINTER :: global
    TYPE(t_grid), POINTER :: pgrid     
    TYPE(t_border), POINTER :: pborder2
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_DestroyBufferIPclSend',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid

! ******************************************************************************
!   Loop over borders when pBorder is not present
!    else deallocate only for select pBorder
! ******************************************************************************

#ifdef PLAG
    IF ( present(pborder) ) THEN
      DEALLOCATE(pborder%iPclSend,stat=errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN
        CALL errorstop(global,err_deallocate,__line__,'pBorder%iPclSend')
      END IF ! global%error

    ELSE
      DO iborder = 1,pgrid%nBorders
        pborder2 => pgrid%borders(iborder)

        DEALLOCATE(pborder2%iPclSend,stat=errorflag)
        global%error = errorflag
        IF ( global%error /= err_none ) THEN
          CALL errorstop(global,err_deallocate,__line__,'pBorder%iPclSend')
        END IF ! global%error
      END DO ! iBorder
    END IF ! PRESENT(pBorder)
#endif

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
      
  END SUBROUTINE rflu_mpi_destroybufferipclsend








! ******************************************************************************
!
! Purpose: Destroy buffers.
!
! Description: None.
!
! Input:
!   global      Pointer to global data
!   pBorder     Pointer to border
!   borderData  Border data
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_destroybuffers(global,pBorder,borderData)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_global), POINTER :: global
    TYPE(t_border), POINTER :: pborder 
    TYPE(t_border_data) :: borderdata
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag       
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_DestroyBuffers',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Allocate memory
! ******************************************************************************
       
    DEALLOCATE(borderdata%sendBuff,stat=errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_deallocate,__line__,'borderData%sendBuff')
    END IF ! global%error

    DEALLOCATE(borderdata%recvBuff,stat=errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_deallocate,__line__,'borderData%recvBuff')
    END IF ! global%error   

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
      
  END SUBROUTINE rflu_mpi_destroybuffers







! ******************************************************************************
!
! Purpose: Wrapper for destroying buffers.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_destroybufferswrapper(pRegion)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), POINTER :: pregion
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder   
    TYPE(t_border), POINTER :: pborder        
    TYPE(t_global), POINTER :: global
    TYPE(t_grid), POINTER :: pgrid 
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_DestroyBuffersWrapper',&
  'RFLU_ModMPI.F90')

    IF ( global%myProcid == masterproc .AND. &
         global%verbLevel >= verbose_high ) THEN
      WRITE(stdout,'(A,1X,A)') solver_name,'Destroying buffers...'
    END IF ! global%verbLevel
    
! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid

! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO iborder = 1,pgrid%nBorders
      pborder => pgrid%borders(iborder)

! ==============================================================================
!     Create buffers if not on same process
! ==============================================================================    
      
      IF ( pborder%iProc /= global%myProcid ) THEN
      
! ------------------------------------------------------------------------------
!       Mixture
! ------------------------------------------------------------------------------      

        CALL rflu_mpi_destroybuffers(global,pborder,pborder%mixt)      

! ------------------------------------------------------------------------------
!       Physical modules
! ------------------------------------------------------------------------------      

#ifdef SPEC
        IF ( global%specUsed .EQV. .true. ) THEN 
          CALL rflu_mpi_destroybuffers(global,pborder,pborder%spec)   
        END IF ! global%specUsed        
#endif       
      END IF ! pBorder%iProc
    END DO ! iBorder
        
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)

    IF ( global%myProcid == masterproc .AND. &
         global%verbLevel >= verbose_high ) THEN
      WRITE(stdout,'(A,1X,A)') solver_name,'Destroying buffers done.'
    END IF ! global%verbLevel
      
  END SUBROUTINE rflu_mpi_destroybufferswrapper









! ******************************************************************************
!
! Purpose: Send cell data.
!
! Description: None.
!
! Input:
!   global              Pointer to global data
!   pBorder             Pointer to border
!   cellDataBuff        Buffer array
!   cellData            Data array
!   tag                 Tag
!
! Output: 
!   request             Request
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_isendcelldata(global,pBorder,cellDataBuff,cellData,tag, & 
                                    request)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    INTEGER, INTENT(IN) :: tag
    INTEGER, INTENT(OUT) :: request
    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: celldata
    REAL(RFREAL), DIMENSION(:,:), INTENT(OUT) :: celldatabuff
    TYPE(t_border), POINTER :: pborder
    TYPE(t_global), POINTER :: global         
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,icg,icl,ivar,nvars        
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_ISendCellData',&
  'RFLU_ModMPI.F90')
    
! ******************************************************************************
!   Set variables
! ******************************************************************************

    nvars = SIZE(celldata,1)

! ******************************************************************************
!   Pack data into buffer
! ******************************************************************************

    DO icl = 1,pborder%nCellsSend
      icg = pborder%icgSend(icl)

      DO ivar = 1,nvars
        celldatabuff(ivar,icl) = celldata(ivar,icg)
      END DO ! iVar      
    END DO ! icl

! ******************************************************************************
!   Send data  
! ******************************************************************************

    IF ( pborder%nCellsSend > 0 ) THEN 
      CALL mpi_isend(celldatabuff,pborder%nCellsSend*nvars,mpi_rfreal, & 
                     pborder%iProc,tag,global%mpiComm,request,errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_mpi_output,__line__)
      END IF ! global%error                                      
    END IF ! pBorder%nCellsSend

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_isendcelldata








! ******************************************************************************
!
! Purpose: Recreate iPclSend buffers.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!   pBorder     Pointer to border (Optional)
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_recreatebufferipclsend(pRegion,pBorder)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_border), POINTER, OPTIONAL :: pborder
    TYPE(t_region), POINTER :: pregion 
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,ipcl,ivar,npclssendmax,npclssendmaxold,nvars
    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ipclsendtemp     
    TYPE(t_global), POINTER :: global
    TYPE(t_grid), POINTER :: pgrid     
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_RecreateBufferIPclSend',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid

#ifdef PLAG
! ******************************************************************************
!   Set variables 
! ******************************************************************************

    nvars           = SIZE(pborder%iPclSend,1)
    npclssendmaxold = SIZE(pborder%iPclSend,2)

    pborder%nPclsSendMax = & 
      nint(1.20_rfreal*REAL(pborder%npclssend,kind=rfreal))

! ******************************************************************************
!   Allocate temporary array
! ******************************************************************************

    ALLOCATE(ipclsendtemp(nvars,pborder%nPclsSendMax),stat=errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_allocate,__line__,'iPclSendTemp')
    END IF ! global%error
    
! ******************************************************************************
!   Copy array
! ******************************************************************************
    
    DO ipcl = 1,npclssendmaxold
      DO ivar = 1,nvars
        ipclsendtemp(ivar,ipcl) = pborder%iPclSend(ivar,ipcl)
      END DO ! iVar
    END DO ! iPcl 

! ******************************************************************************
!   Deallocate iPclSend array
! ******************************************************************************      

    CALL rflu_mpi_destroybufferipclsend(pregion,pborder)

! ******************************************************************************
!   Reallocate iPclSend array
! ******************************************************************************      

    CALL rflu_mpi_createbufferipclsend(pregion,pborder)   

! ******************************************************************************
!   Copy array
! ******************************************************************************
    
    DO ipcl = 1,pborder%nPclsSend
      DO ivar = 1,nvars
        pborder%iPclSend(ivar,ipcl) = ipclsendtemp(ivar,ipcl)
      END DO ! iVar
    END DO ! iPcl     

! ******************************************************************************
!   Deallocate temporary array
! ******************************************************************************

    DEALLOCATE(ipclsendtemp,stat=errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_deallocate,__line__,'iPclSendTemp')
    END IF ! global%error
#endif

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
      
  END SUBROUTINE rflu_mpi_recreatebufferipclsend







! ******************************************************************************
!
! Purpose: Wrapper for sending data.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_isendwrapper(pRegion)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), POINTER :: pregion
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder
    TYPE(t_border), POINTER :: pborder 
    TYPE(t_global), POINTER :: global  
    TYPE(t_grid), POINTER :: pgrid             
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_ISendWrapper',&
  'RFLU_ModMPI.F90')

#ifdef ROCPROF 
    CALL fprofiler_begins("RFLU::ISendWrapper")
#endif

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid
    
! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO iborder = 1,pgrid%nBorders
      pborder => pgrid%borders(iborder)
    
! ==============================================================================
!     Send data if not on same process
! ==============================================================================    
    
      IF ( pborder%iProc /= global%myProcid ) THEN 
      
! ------------------------------------------------------------------------------
!       Mixture
! ------------------------------------------------------------------------------      

        CALL rflu_mpi_isendcelldata(global,pborder,pborder%mixt%sendBuff, & 
                                    pregion%mixt%cv,pborder%mixt%tag, &
                                    pborder%mixt%sendRequest)

! ------------------------------------------------------------------------------
!       Physical modules
! ------------------------------------------------------------------------------      

#ifdef SPEC
        IF ( global%specUsed .EQV. .true. ) THEN 
          CALL rflu_mpi_isendcelldata(global,pborder,pborder%spec%sendBuff, & 
                                      pregion%spec%cv,pborder%spec%tag, &
                                      pborder%spec%sendRequest)        
        END IF ! global%specUsed
#endif  
      END IF ! pBorder
    END DO ! iBorder

! ******************************************************************************
!   End
! ******************************************************************************

#ifdef ROCPROF 
    CALL fprofiler_ends("RFLU::ISendWrapper")
#endif

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_isendwrapper








! ******************************************************************************
!
! Purpose: Receive cell data.
!
! Description: None.
!
! Input:
!   global              Pointer to global data
!   pBorder             Pointer to border
!   cellDataBuff        Buffer array
!   cellData            Data array
!   tag                 Tag
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_recvcelldata(global,pBorder,cellDataBuff,cellData,tag)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    INTEGER, INTENT(IN) :: tag
    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: celldatabuff
    REAL(RFREAL), DIMENSION(:,:), INTENT(OUT) :: celldata
    TYPE(t_border), POINTER :: pborder
    TYPE(t_global), POINTER :: global         
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,icg,icl,ivar,nvars
    INTEGER :: status(mpi_status_size)        
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_RecvCellData',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set variables
! ******************************************************************************

    nvars = SIZE(celldata,1)
    
! ******************************************************************************
!   Recv data 
! ******************************************************************************

    IF ( pborder%nCellsRecv > 0 ) THEN 
      CALL mpi_recv(celldatabuff,pborder%nCellsRecv*nvars,mpi_rfreal, & 
                    pborder%iProc,tag,global%mpiComm,status,errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_mpi_output,__line__)
      END IF ! global%error  
    END IF ! pBorder%nCellsRecv

! ******************************************************************************
!   Unpack data from buffer
! ******************************************************************************

    DO icl = 1,pborder%nCellsRecv
      icg = pborder%icgRecv(icl)

      DO ivar = 1,nvars
        celldata(ivar,icg) = celldatabuff(ivar,icl) 
      END DO ! iVar      
    END DO ! icl
        
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_recvcelldata







! ******************************************************************************
!
! Purpose: Wrapper for receiving data.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_recvwrapper(pRegion)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), POINTER :: pregion
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: errorflag,iborder
    TYPE(t_border), POINTER :: pborder 
    TYPE(t_global), POINTER :: global 
    TYPE(t_grid), POINTER :: pgrid     
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_RecvWrapper',&
  'RFLU_ModMPI.F90')

#ifdef ROCPROF 
    CALL fprofiler_begins("RFLU::RecvWrapper")
#endif

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid
    
! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO iborder = 1,pgrid%nBorders
      pborder => pgrid%borders(iborder)

! ==============================================================================
!     Receive data if not on same process
! ==============================================================================    

      IF ( pborder%iProc /= global%myProcid ) THEN 

! ------------------------------------------------------------------------------
!       Mixture
! ------------------------------------------------------------------------------      

        CALL rflu_mpi_recvcelldata(global,pborder,pborder%mixt%recvBuff, & 
                                   pregion%mixt%cv,pborder%mixt%tag)      

! ------------------------------------------------------------------------------
!       Physical modules
! ------------------------------------------------------------------------------      

#ifdef SPEC
        IF ( global%specUsed .EQV. .true. ) THEN 
          CALL rflu_mpi_recvcelldata(global,pborder,pborder%spec%recvBuff, & 
                                     pregion%spec%cv,pborder%spec%tag)           
        END IF ! global%specUsed
#endif         
      END IF ! pBorder
    END DO ! iBorder

! ******************************************************************************
!   End
! ******************************************************************************

#ifdef ROCPROF 
    CALL fprofiler_ends("RFLU::RecvWrapper")
#endif

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_recvwrapper





! ******************************************************************************
!
! Purpose: Set tag.
!
! Description: None.
!
! Input:
!   global      Pointer to global data
!   iReg1       Index of first region
!   iReg2       Index of second region
!   iMsg        Index of message
!   tagMax      Maximum allowed value of tag
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  INTEGER FUNCTION rflu_mpi_settag(global,iReg1,iReg2,iMsg,tagMax)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    INTEGER, INTENT(IN) :: imsg,ireg1,ireg2,tagmax
    TYPE(t_global), POINTER :: global 
       
! ==============================================================================
!   Local variables
! ==============================================================================

    INTEGER :: iregmax,iregmin  
    
! ******************************************************************************
!   Start
! ******************************************************************************

    CALL registerfunction(global,'RFLU_MPI_SetTag',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set tag
! ******************************************************************************

    iregmax = max(ireg1,ireg2)
    iregmin = min(ireg1,ireg2)

    rflu_mpi_settag = iregmin + (iregmax-1)*global%nRegions &
                    + (iregmax-1)*(imsg-1)*global%nRegions*global%nRegions 

    IF ( rflu_mpi_settag > tagmax ) THEN 
      CALL errorstop(global,err_mpi_tagmax,__line__)
    END IF ! RFLU_MPI_SetTag

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
  
  END FUNCTION rflu_mpi_settag










! ******************************************************************************
!
! Purpose: Wrapper for setting tags.
!
! Description: None.
!
! Input:
!   pRegion     Pointer to region
!
! Output: None.
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_mpi_settagswrapper(pRegion)

    IMPLICIT NONE
  
! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************  
  
! ==============================================================================
!   Arguments
! ==============================================================================

    TYPE(t_region), POINTER :: pregion
       
! ==============================================================================
!   Local variables
! ==============================================================================

    LOGICAL :: dummylogical
    INTEGER :: errorflag,iborder,imsg,tagmax
    TYPE(t_border), POINTER :: pborder 
    TYPE(t_global), POINTER :: global  
    TYPE(t_grid), POINTER :: pgrid             
  
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_MPI_SetTagsWrapper',&
  'RFLU_ModMPI.F90')

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid

! ******************************************************************************
!   Get maximum allowed value of tag. NOTE must always use MPI_COMM_WORLD - 
!   cannot use global%mpiComm because may be split off in GENx computations
!   and get zero tagMax as a result.
! ******************************************************************************

    CALL mpi_attr_get(mpi_comm_world,mpi_tag_ub,tagmax,dummylogical,errorflag)
    global%error = errorflag
    IF ( global%error /= err_none ) THEN 
      CALL errorstop(global,err_mpi_output,__line__)
    END IF ! global%error

! ******************************************************************************
!   Loop over borders
! ******************************************************************************

    DO iborder = 1,pgrid%nBorders
      pborder => pgrid%borders(iborder)
    
! ==============================================================================
!     Mixture
! ==============================================================================
            
      imsg = 1

      pborder%mixt%tag = rflu_mpi_settag(global,pregion%iRegionGlobal, & 
                                         pborder%iRegionGlobal,imsg,tagmax)

! ==============================================================================
!     Physical modules
! ==============================================================================

#ifdef SPEC
      imsg = imsg + 1

      pborder%spec%tag = rflu_mpi_settag(global,pregion%iRegionGlobal, & 
                                         pborder%iRegionGlobal,imsg,tagmax)            
#endif        

#ifdef PLAG
      imsg = imsg + 1

      pborder%plag%tagCount = rflu_mpi_settag(global,pregion%iRegionGlobal, & 
                                              pborder%iRegionGlobal,imsg,tagmax)            
      imsg = imsg + 1

      pborder%plag%tagInt = rflu_mpi_settag(global,pregion%iRegionGlobal, & 
                                            pborder%iRegionGlobal,imsg,tagmax)            
      imsg = imsg + 1

      pborder%plag%tag = rflu_mpi_settag(global,pregion%iRegionGlobal, & 
                                         pborder%iRegionGlobal,imsg,tagmax)            
#endif        
    END DO ! iBorder

! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)
  
  END SUBROUTINE rflu_mpi_settagswrapper









! ******************************************************************************
! End
! ******************************************************************************
  
END MODULE rflu_modmpi


! ******************************************************************************
!
! RCS Revision history:
!
! $Log: RFLU_ModMPI.F90,v $
! Revision 1.17  2008/12/06 08:44:22  mtcampbe
! Updated license.
!
! Revision 1.16  2008/11/19 22:17:33  mtcampbe
! Added Illinois Open Source License/Copyright
!
! Revision 1.15  2007/07/08 21:45:03  gzheng
! changed the PRESENT is used for PGI compiler
!
! Revision 1.14  2006/04/07 15:19:19  haselbac
! Removed tabs
!
! Revision 1.13  2006/02/09 03:37:44  haselbac
! Bug fix: Must always use MPI_COMM_WORLD to get max tag
!
! Revision 1.12  2005/12/14 21:50:32  haselbac
! Cosmetics
!
! Revision 1.11  2005/12/14 21:20:28  fnajjar
! Added subroutine and made changes for dynamic allocation of iPclsSend
!
! Revision 1.10  2005/12/13 23:30:53  haselbac
! Cosmetics
!
! Revision 1.9  2005/12/13 23:06:56  fnajjar
! Added defs of tag for PLAG
!
! Revision 1.8  2005/12/08 03:01:01  haselbac
! Major bug fix: spec tag was not set
!
! Revision 1.7  2005/12/03 19:48:23  haselbac
! Bug fix: Only clear request if have indeed sent message, cosmetics
!
! Revision 1.6  2005/09/19 18:40:37  haselbac
! Added IFs for border sizes before send and recv
!
! Revision 1.5  2005/07/08 15:01:29  haselbac
! Added profiling calls
!
! Revision 1.4  2005/05/26 22:01:01  haselbac
! Fixed two serious bugs: status is array in recv and wait
!
! Revision 1.3  2005/05/18 22:12:04  fnajjar
! ACH: Added routines to create and destroy iPclSend buffers
!
! Revision 1.2  2005/04/29 00:05:47  haselbac
! Added MPI_Wait routines
!
! Revision 1.1  2005/04/15 15:06:43  haselbac
! Initial revision
!
! ******************************************************************************