Changeset 186 for codes/icosagcm/trunk/src/mpipara.F90

Timestamp:

01/09/14 09:56:11 (10 years ago)

Author:

ymipsl

Message:

Add new openMP parallelism based on distribution of domains on threads. There is no more limitation of number of threads by MPI process.

YM

File:

• codes/icosagcm/trunk/src/mpipara.F90 (modified) (6 diffs)

codes/icosagcm/trunk/src/mpipara.F90

@@ -3 +3 @@
   INTEGER,SAVE :: mpi_rank
   INTEGER,SAVE :: mpi_size
+  INTEGER,SAVE :: mpi_threading_mode
   
   INTEGER,SAVE :: comm_icosa
@@ -13 +14 @@
   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
+
 CONTAINS
 
   SUBROUTINE init_mpipara
   USE mpi_mod
+  USE getin_mod
 #ifdef CPP_USING_XIOS
   USE xios
 #endif
   IMPLICIT NONE
+    CHARACTER(LEN=256) :: required_mode_str
+    INTEGER :: required_mode
 
     using_mpi=.FALSE.
@@ -28 +36 @@
     
     IF (using_mpi) THEN
-      CALL MPI_INIT(ierr)
-
+    
+      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)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD used'
+      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)
@@ -79 +125 @@
     CALL C_F_POINTER(base_ptr, buffer, (/ length /))
 
-   END SUBROUTINE allocate_mpi_buffer_r2
+  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)
@@ -100 +157 @@
     CALL C_F_POINTER(base_ptr, buffer, (/ length,dim3 /))
     
-   END SUBROUTINE allocate_mpi_buffer_r3
+  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)
@@ -123 +191 @@
     
    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