source: codes/icosagcm/trunk/src/parallel/mpipara.F90

Last change on this file was 1056, checked in by aclsce, 3 years ago

Added handling of the use of oasis coupler (to be used in ocean-atmopshere mode).
File size: 7.2 KB
Line 
1MODULE mpipara
2
3  INTEGER,SAVE :: mpi_rank
4  INTEGER,SAVE :: mpi_size
5  INTEGER,SAVE :: mpi_threading_mode
6 
7  INTEGER,SAVE :: comm_icosa
8  INTEGER,SAVE :: ierr
9  LOGICAL,SAVE :: using_mpi
10  LOGICAL,SAVE :: is_mpi_root
11  LOGICAL,SAVE :: is_mpi_master
12  CHARACTER(LEN=256),SAVE :: using_oasis
13  INTEGER,SAVE :: mpi_master
14 
15  INTEGER,SAVE :: id_mpi ! id for profiling
16
17   INTERFACE allocate_mpi_buffer
18    MODULE PROCEDURE allocate_mpi_buffer_r2, allocate_mpi_buffer_r3,allocate_mpi_buffer_r4
19  END INTERFACE allocate_mpi_buffer
20
21  INTERFACE free_mpi_buffer
22    MODULE PROCEDURE free_mpi_buffer_r2, free_mpi_buffer_r3, free_mpi_buffer_r4
23  END INTERFACE free_mpi_buffer
24
25  PRIVATE :: getin
26
27CONTAINS
28
29  SUBROUTINE getin(name,value) ! Copied from getin.f90 to avoid circular dependency
30  USE ioipsl, ONLY : getin_=>getin
31  USE transfert_omp_mod
32  USE omp_para
33  IMPLICIT NONE
34    CHARACTER(LEN=*) :: name
35    CHARACTER(LEN=*) :: value
36
37!$OMP MASTER   
38    CALL getin_(name,value)
39    IF(is_mpi_root) PRINT *,'GETIN ',TRIM(name),' = ', TRIM(value)
40!$OMP END MASTER
41    IF (omp_in_parallel()) CALL bcast_omp(value)
42  END SUBROUTINE getin
43
44  SUBROUTINE init_mpipara
45  USE mpi_mod
46#ifdef CPP_USING_XIOS
47  USE xios
48#endif
49  USE abort_mod
50  USE openacc_mod
51  IMPLICIT NONE
52    CHARACTER(LEN=256) :: required_mode_str
53    INTEGER :: required_mode
54
55    using_mpi=.FALSE.
56#ifdef CPP_USING_MPI
57    using_mpi=.TRUE. 
58#endif
59   
60    CALL set_openacc_device
61
62    IF (using_mpi) THEN
63   
64      using_oasis='n'
65      CALL getin('using_oasis',using_oasis)
66
67      IF (using_oasis == 'n') THEN
68
69      required_mode_str='funneled'
70      CALL getin('mpi_threading_mode',required_mode_str)
71     
72      SELECT CASE(TRIM(required_mode_str))
73        CASE ('single')
74          required_mode=MPI_THREAD_SINGLE
75        CASE ('funneled')
76          required_mode=MPI_THREAD_FUNNELED
77        CASE ('serialized')
78          required_mode=MPI_THREAD_SERIALIZED
79        CASE ('multiple')
80          required_mode=MPI_THREAD_MULTIPLE
81        CASE DEFAULT
82          PRINT*,'Bad selector for variable mpi_threading_mode  : <', TRIM(required_mode_str),  &
83                 '>  => options are <single>, <funneled>, <serialized>, <multiple>'
84          STOP
85      END SELECT
86     
87      IF (required_mode==MPI_THREAD_SERIALIZED .OR. required_mode==MPI_THREAD_MULTIPLE) THEN
88        CALL abort_acc("mpi_threading_mode /= 'single' .AND. mpi_threading_mode /= 'funneled'")
89      ENDIF
90
91      IF (required_mode==MPI_THREAD_SINGLE)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD required'
92      IF (required_mode==MPI_THREAD_FUNNELED)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_FUNNELED required'
93      IF (required_mode==MPI_THREAD_SERIALIZED) PRINT*,'MPI_INIT_THREAD : MPI_THREAD_SERIALIZED required'
94      IF (required_mode==MPI_THREAD_MULTIPLE)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_MULTIPLE required'
95
96      CALL MPI_INIT_THREAD(required_mode,mpi_threading_mode,ierr)
97     
98      IF (mpi_threading_mode==MPI_THREAD_SINGLE)     PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD provided'
99      IF (mpi_threading_mode==MPI_THREAD_FUNNELED)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_FUNNELED provided'
100      IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) PRINT*,'MPI_INIT_THREAD : MPI_THREAD_SERIALIZED provided'
101      IF (mpi_threading_mode==MPI_THREAD_MULTIPLE)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_MULTIPLE provided'
102
103      IF (mpi_threading_mode > required_mode) mpi_threading_mode=required_mode
104
105      IF (mpi_threading_mode==MPI_THREAD_SINGLE) THEN
106         PRINT*,'MPI_INIT_THREAD : MPI_SINGLE_THREAD used : Warning : openMP is not garanted to work'
107      ENDIF
108      IF (mpi_threading_mode==MPI_THREAD_FUNNELED)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_FUNNELED used'
109      IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) PRINT*,'MPI_INIT_THREAD : MPI_THREAD_SERIALIZED used'
110      IF (mpi_threading_mode==MPI_THREAD_MULTIPLE)   PRINT*,'MPI_INIT_THREAD : MPI_THREAD_MULTIPLE used'
111         
112      ENDIF
113
114#ifdef CPP_USING_XIOS
115      CALL xios_initialize("icosa",return_comm=comm_icosa)
116#else
117     comm_icosa=MPI_COMM_WORLD
118#endif
119      CALL MPI_COMM_SIZE(comm_icosa,mpi_size,ierr)
120      CALL MPI_COMM_RANK(comm_icosa,mpi_rank,ierr)
121      PRINT *, 'MPI Process ', mpi_rank, '/', mpi_size
122    ELSE
123      comm_icosa=-1
124      mpi_size=1
125      mpi_rank=0
126    ENDIF
127   
128    mpi_master=0
129    IF (mpi_rank==0) THEN
130      is_mpi_root=.TRUE.
131      is_mpi_master=.TRUE.
132    ELSE
133      is_mpi_root=.FALSE.
134      is_mpi_master=.FALSE.
135    ENDIF
136   
137
138    CALL set_openacc_device(mpi_size, mpi_rank)
139    PRINT *, 'GPU device ', openacc_device_id
140
141  END SUBROUTINE  init_mpipara
142
143  SUBROUTINE finalize_mpipara
144  USE mpi_mod
145#ifdef CPP_USING_XIOS
146  USE xios
147#endif
148  IMPLICIT NONE
149   
150#ifdef CPP_USING_XIOS
151      CALL xios_finalize
152#endif
153    IF (using_mpi) THEN
154      IF (using_oasis == 'n') CALL MPI_FINALIZE(ierr)
155    ENDIF
156   
157   END SUBROUTINE  finalize_mpipara
158   
159
160  SUBROUTINE allocate_mpi_buffer_r2(buffer,length)
161  USE ISO_C_BINDING
162  USE mpi_mod
163  USE prec
164  IMPLICIT NONE
165    REAL(rstd), POINTER :: buffer(:)
166    INTEGER,INTENT(IN)  :: length
167
168    TYPE(C_PTR)         :: base_ptr
169    INTEGER(KIND=MPI_ADDRESS_KIND) :: real_size,lb,size
170    INTEGER :: ierr
171   
172    CALL MPI_Type_get_extent(MPI_REAL8, lb, real_size, ierr)
173    size=length*real_size
174   
175    CALL MPI_ALLOC_MEM(size,MPI_INFO_NULL,base_ptr,ierr)
176    CALL C_F_POINTER(base_ptr, buffer, (/ length /))
177
178  END SUBROUTINE allocate_mpi_buffer_r2
179
180  SUBROUTINE free_mpi_buffer_r2(buffer)
181  USE ISO_C_BINDING
182  USE mpi_mod
183  USE prec
184  IMPLICIT NONE
185    REAL(rstd), POINTER :: buffer(:)
186
187    CALL MPI_FREE_MEM(buffer,ierr)
188
189   END SUBROUTINE free_mpi_buffer_r2
190
191  SUBROUTINE allocate_mpi_buffer_r3(buffer,length,dim3)
192  USE ISO_C_BINDING
193  USE mpi_mod
194  USE prec
195    IMPLICIT NONE
196    REAL(rstd), POINTER :: buffer(:,:)
197    INTEGER,INTENT(IN)  :: length
198    INTEGER,INTENT(IN)  :: dim3
199
200    TYPE(C_PTR)         :: base_ptr
201    INTEGER(KIND=MPI_ADDRESS_KIND) :: real_size,lb,size
202    INTEGER :: ierr
203   
204    CALL MPI_Type_get_extent(MPI_REAL8, lb, real_size, ierr)
205    size=length*real_size*dim3
206   
207    CALL MPI_ALLOC_MEM(size,MPI_INFO_NULL,base_ptr,ierr)
208    CALL C_F_POINTER(base_ptr, buffer, (/ length,dim3 /))
209   
210  END SUBROUTINE allocate_mpi_buffer_r3
211
212  SUBROUTINE free_mpi_buffer_r3(buffer)
213  USE ISO_C_BINDING
214  USE mpi_mod
215  USE prec
216  IMPLICIT NONE
217    REAL(rstd), POINTER :: buffer(:,:)
218
219    CALL MPI_FREE_MEM(buffer,ierr)
220
221  END SUBROUTINE free_mpi_buffer_r3
222
223  SUBROUTINE allocate_mpi_buffer_r4(buffer,length,dim3,dim4)
224  USE ISO_C_BINDING
225  USE mpi_mod
226  USE prec
227  IMPLICIT NONE
228    REAL(rstd), POINTER :: buffer(:,:,:)
229    INTEGER,INTENT(IN)  :: length
230    INTEGER,INTENT(IN)  :: dim3
231    INTEGER,INTENT(IN)  :: dim4
232
233    TYPE(C_PTR)         :: base_ptr
234    INTEGER(KIND=MPI_ADDRESS_KIND) :: real_size,lb,size
235    INTEGER :: ierr
236   
237    CALL MPI_Type_get_extent(MPI_REAL8, lb, real_size, ierr)
238    size=length*real_size*dim3*dim4
239   
240    CALL MPI_ALLOC_MEM(size,MPI_INFO_NULL,base_ptr,ierr)
241    CALL C_F_POINTER(base_ptr, buffer, (/ length, dim3, dim4 /))
242   
243   END SUBROUTINE allocate_mpi_buffer_r4
244
245  SUBROUTINE free_mpi_buffer_r4(buffer)
246  USE ISO_C_BINDING
247  USE mpi_mod
248  USE prec
249  IMPLICIT NONE
250    REAL(rstd), POINTER :: buffer(:,:,:)
251
252    CALL MPI_FREE_MEM(buffer,ierr)
253
254  END SUBROUTINE free_mpi_buffer_r4
255   
256   
257     
258END MODULE mpipara
Note: See TracBrowser for help on using the repository browser.