source: codes/icosagcm/trunk/src/mpipara.F90 @ 352

Last change on this file since 352 was 266, checked in by ymipsl, 10 years ago

Synchronize trunk and Saturn branch.
Merge modification from Saturn branch to trunk

YM
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  LOGICAL,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.