source: codes/icosagcm/trunk/src/mpipara.F90 @ 216

MODULE mpipara

  INTEGER,SAVE :: mpi_rank
  INTEGER,SAVE :: mpi_size
  INTEGER,SAVE :: mpi_threading_mode
  
  INTEGER,SAVE :: comm_icosa
  INTEGER,SAVE :: ierr
  LOGICAL,SAVE :: using_mpi
  LOGICAL,SAVE :: is_mpi_root
  
  INTERFACE allocate_mpi_buffer
    MODULE PROCEDURE allocate_mpi_buffer_r2, allocate_mpi_buffer_r3,allocate_mpi_buffer_r4
  END INTERFACE allocate_mpi_buffer

  INTERFACE free_mpi_buffer
    MODULE PROCEDURE free_mpi_buffer_r2, free_mpi_buffer_r3, free_mpi_buffer_r4
  END INTERFACE free_mpi_buffer

  PRIVATE :: getin

CONTAINS

  SUBROUTINE getin(name,value) ! Copied from getin.f90 to avoid circular dependency
  USE ioipsl, ONLY : getin_=>getin
  USE transfert_omp_mod
  USE omp_para
  IMPLICIT NONE
    CHARACTER(LEN=*) :: name
    CHARACTER(LEN=*) :: value

!$OMP MASTER    
    CALL getin_(name,value)
    IF(is_mpi_root) PRINT *,'GETIN ',TRIM(name),' = ', TRIM(value)
!$OMP END MASTER
    IF (omp_in_parallel()) CALL bcast_omp(value)
  END SUBROUTINE getin

  SUBROUTINE init_mpipara
  USE mpi_mod
#ifdef CPP_USING_XIOS
  USE xios
#endif
  IMPLICIT NONE
    CHARACTER(LEN=256) :: required_mode_str
    INTEGER :: required_mode

    using_mpi=.FALSE.
#ifdef CPP_USING_MPI
    using_mpi=.TRUE. 
#endif 
    
    IF (using_mpi) THEN
    
      required_mode_str='multiple'
      CALL getin('mpi_threading_mode',required_mode_str)
      
      SELECT CASE(TRIM(required_mode_str))
        CASE ('single')
          required_mode=MPI_THREAD_SINGLE
        CASE ('funneled')
          required_mode=MPI_THREAD_FUNNELED
        CASE ('serialized')
          required_mode=MPI_THREAD_SERIALIZED
        CASE ('multiple')
          required_mode=MPI_THREAD_MULTIPLE
        CASE DEFAULT
          PRINT*,'Bad selector for variable mpi_threading_mode  : <', TRIM(required_mode_str),  &
                 '>  => options are <single>, <funneled>, <serialized>, <multiple>'
          STOP
      END SELECT
      

      IF (required_mode==MPI_THREAD_SINGLE)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD required'
      IF (required_mode==MPI_THREAD_FUNNELED)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_FUNNELED required'
      IF (required_mode==MPI_THREAD_SERIALIZED) PRINT*,'MPI_INIT_THREAD : MPI_THREAD_SERIALIZED required'
      IF (required_mode==MPI_THREAD_MULTIPLE)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_MULTIPLE required'

      
      CALL MPI_INIT_THREAD(MPI_THREAD_MULTIPLE,mpi_threading_mode,ierr)
      
      IF (mpi_threading_mode==MPI_THREAD_SINGLE)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD provided'
      IF (mpi_threading_mode==MPI_THREAD_FUNNELED)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_FUNNELED provided'
      IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) PRINT*,'MPI_INIT_THREAD : MPI_THREAD_SERIALIZED provided'
      IF (mpi_threading_mode==MPI_THREAD_MULTIPLE)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_MULTIPLE provided'

      IF (mpi_threading_mode > required_mode) mpi_threading_mode=required_mode

      IF (mpi_threading_mode==MPI_THREAD_SINGLE) THEN
         PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD used : Warning : openMP is not garanted to work'
      ENDIF
      IF (mpi_threading_mode==MPI_THREAD_FUNNELED)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_FUNNELED used'
      IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) PRINT*,'MPI_INIT_THREAD : MPI_THREAD_SERIALIZED used'
      IF (mpi_threading_mode==MPI_THREAD_MULTIPLE)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_MULTIPLE used'
          
#ifdef CPP_USING_XIOS
      CALL xios_initialize("icosagcm",return_comm=comm_icosa)
#else
     comm_icosa=MPI_COMM_WORLD
#endif
      CALL MPI_COMM_SIZE(comm_icosa,mpi_size,ierr)
      CALL MPI_COMM_RANK(comm_icosa,mpi_rank,ierr)
      PRINT *, 'MPI Process ', mpi_rank, '/', mpi_size
    ELSE
      comm_icosa=-1
      mpi_size=1
      mpi_rank=0
    ENDIF
    
    IF (mpi_rank==0) THEN 
      is_mpi_root=.TRUE.
    ELSE
      is_mpi_root=.FALSE.
    ENDIF
    
  END SUBROUTINE  init_mpipara

  SUBROUTINE finalize_mpipara
  USE mpi_mod
  IMPLICIT NONE
    
    IF (using_mpi) CALL MPI_FINALIZE(ierr)
    
   END SUBROUTINE  finalize_mpipara
   

  SUBROUTINE allocate_mpi_buffer_r2(buffer,length)
  USE ISO_C_BINDING
  USE mpi_mod
  USE prec
  IMPLICIT NONE
    REAL(rstd), POINTER :: buffer(:)
    INTEGER,INTENT(IN)  :: length

    TYPE(C_PTR)         :: base_ptr
    INTEGER(KIND=MPI_ADDRESS_KIND) :: size
    INTEGER :: real_size,ierr
    
    CALL MPI_TYPE_EXTENT(MPI_REAL8, real_size, ierr)
    size=length*real_size
    
    CALL MPI_ALLOC_MEM(size,MPI_INFO_NULL,base_ptr,ierr)
    CALL C_F_POINTER(base_ptr, buffer, (/ length /))

  END SUBROUTINE allocate_mpi_buffer_r2

  SUBROUTINE free_mpi_buffer_r2(buffer)
  USE ISO_C_BINDING
  USE mpi_mod
  USE prec
  IMPLICIT NONE
    REAL(rstd), POINTER :: buffer(:)

    CALL MPI_FREE_MEM(buffer,ierr)

   END SUBROUTINE free_mpi_buffer_r2

  SUBROUTINE allocate_mpi_buffer_r3(buffer,length,dim3)
  USE ISO_C_BINDING
  USE mpi_mod
  USE prec
    IMPLICIT NONE
    REAL(rstd), POINTER :: buffer(:,:)
    INTEGER,INTENT(IN)  :: length
    INTEGER,INTENT(IN)  :: dim3

    TYPE(C_PTR)         :: base_ptr
    INTEGER(KIND=MPI_ADDRESS_KIND) :: size
    INTEGER :: real_size,ierr
    
    CALL MPI_TYPE_EXTENT(MPI_REAL8, real_size, ierr)
    size=length*real_size*dim3
    
    CALL MPI_ALLOC_MEM(size,MPI_INFO_NULL,base_ptr,ierr)
    CALL C_F_POINTER(base_ptr, buffer, (/ length,dim3 /))
    
  END SUBROUTINE allocate_mpi_buffer_r3

  SUBROUTINE free_mpi_buffer_r3(buffer)
  USE ISO_C_BINDING
  USE mpi_mod
  USE prec
  IMPLICIT NONE
    REAL(rstd), POINTER :: buffer(:,:)

    CALL MPI_FREE_MEM(buffer,ierr)

  END SUBROUTINE free_mpi_buffer_r3

  SUBROUTINE allocate_mpi_buffer_r4(buffer,length,dim3,dim4)
  USE ISO_C_BINDING
  USE mpi_mod
  USE prec
  IMPLICIT NONE
    REAL(rstd), POINTER :: buffer(:,:,:)
    INTEGER,INTENT(IN)  :: length
    INTEGER,INTENT(IN)  :: dim3
    INTEGER,INTENT(IN)  :: dim4

    TYPE(C_PTR)         :: base_ptr
    INTEGER(KIND=MPI_ADDRESS_KIND) :: size
    INTEGER :: real_size,ierr
    
    CALL MPI_TYPE_EXTENT(MPI_REAL8, real_size, ierr)
    size=length*real_size*dim3*dim4
    
    CALL MPI_ALLOC_MEM(size,MPI_INFO_NULL,base_ptr,ierr)
    CALL C_F_POINTER(base_ptr, buffer, (/ length, dim3, dim4 /))
    
   END SUBROUTINE allocate_mpi_buffer_r4

  SUBROUTINE free_mpi_buffer_r4(buffer)
  USE ISO_C_BINDING
  USE mpi_mod
  USE prec
  IMPLICIT NONE
    REAL(rstd), POINTER :: buffer(:,:,:)

    CALL MPI_FREE_MEM(buffer,ierr)

  END SUBROUTINE free_mpi_buffer_r4
   
END MODULE mpipara