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

Last change on this file since 667 was 667, checked in by dubos, 6 years ago

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