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

Last change on this file since 533 was 533, checked in by dubos, 7 years ago

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