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

Last change on this file was 1035, checked in by dubos, 4 years ago

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