source: codes/icosagcm/trunk/src/parallel/transfert_mpi_collectives.f90 @ 963

Last change on this file since 963 was 963, checked in by adurocher, 5 years ago

Merge 'mpi_rewrite' into trunk
File size: 10.6 KB
Line 
1MODULE transfert_mpi_collectives_mod
2IMPLICIT NONE
3
4  INTERFACE bcast_mpi
5    MODULE PROCEDURE bcast_mpi_c,                                                     &
6                     bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
7                     bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
8                     bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
9  END INTERFACE
10
11CONTAINS
12
13  SUBROUTINE gather_field(field_loc,field_glo)
14  USE field_mod
15  USE domain_mod
16  USE mpi_mod
17  USE mpipara
18  IMPLICIT NONE
19    TYPE(t_field),POINTER :: field_loc(:)
20    TYPE(t_field),POINTER :: field_glo(:)
21    INTEGER, ALLOCATABLE :: mpi_req(:)
22    INTEGER, ALLOCATABLE :: status(:,:)
23    INTEGER :: ireq,nreq
24    INTEGER :: ind_glo,ind_loc
25
26    IF (.NOT. using_mpi) THEN
27
28      DO ind_loc=1,ndomain
29        IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d
30        IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d
31        IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d
32      ENDDO
33
34    ELSE
35
36      nreq=ndomain
37      IF (mpi_rank==0) nreq=nreq+ndomain_glo
38      ALLOCATE(mpi_req(nreq))
39      ALLOCATE(status(MPI_STATUS_SIZE,nreq))
40
41
42      ireq=0
43      IF (mpi_rank==0) THEN
44        DO ind_glo=1,ndomain_glo
45          ireq=ireq+1
46
47          IF (field_glo(ind_glo)%ndim==2) THEN
48            CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   &
49                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
50
51          ELSE IF (field_glo(ind_glo)%ndim==3) THEN
52            CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   &
53                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
54
55          ELSE IF (field_glo(ind_glo)%ndim==4) THEN
56            CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   &
57                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
58          ENDIF
59
60        ENDDO
61      ENDIF
62
63      DO ind_loc=1,ndomain
64        ireq=ireq+1
65
66        IF (field_loc(ind_loc)%ndim==2) THEN
67          CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   &
68                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
69        ELSE IF (field_loc(ind_loc)%ndim==3) THEN
70          CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   &
71                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
72        ELSE IF (field_loc(ind_loc)%ndim==4) THEN
73          CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   &
74                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
75        ENDIF
76
77      ENDDO
78
79      CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
80
81    ENDIF
82
83  END SUBROUTINE gather_field
84
85  SUBROUTINE bcast_field(field_glo)
86  USE field_mod
87  USE domain_mod
88  USE mpi_mod
89  USE mpipara
90  IMPLICIT NONE
91    TYPE(t_field),POINTER :: field_glo(:)
92    INTEGER :: ind_glo
93
94    IF (.NOT. using_mpi) THEN
95
96! nothing to do
97
98    ELSE
99
100      DO ind_glo=1,ndomain_glo
101
102          IF (field_glo(ind_glo)%ndim==2) THEN
103            CALL MPI_BCAST(field_glo(ind_glo)%rval2d, size(field_glo(ind_glo)%rval2d) , MPI_REAL8, 0, comm_icosa, ierr)
104          ELSE IF (field_glo(ind_glo)%ndim==3) THEN
105            CALL MPI_BCAST(field_glo(ind_glo)%rval3d, size(field_glo(ind_glo)%rval3d) , MPI_REAL8, 0, comm_icosa, ierr)
106          ELSE IF (field_glo(ind_glo)%ndim==4) THEN
107            CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr)
108          ENDIF
109
110        ENDDO
111      ENDIF
112
113  END SUBROUTINE bcast_field
114
115  SUBROUTINE scatter_field(field_glo,field_loc)
116  USE field_mod
117  USE domain_mod
118  USE mpi_mod
119  USE mpipara
120  IMPLICIT NONE
121    TYPE(t_field),POINTER :: field_glo(:)
122    TYPE(t_field),POINTER :: field_loc(:)
123    INTEGER, ALLOCATABLE :: mpi_req(:)
124    INTEGER, ALLOCATABLE :: status(:,:)
125    INTEGER :: ireq,nreq
126    INTEGER :: ind_glo,ind_loc
127
128    IF (.NOT. using_mpi) THEN
129
130      DO ind_loc=1,ndomain
131        IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d
132        IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d
133        IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d
134      ENDDO
135
136    ELSE
137
138      nreq=ndomain
139      IF (mpi_rank==0) nreq=nreq+ndomain_glo
140      ALLOCATE(mpi_req(nreq))
141      ALLOCATE(status(MPI_STATUS_SIZE,nreq))
142
143
144      ireq=0
145      IF (mpi_rank==0) THEN
146        DO ind_glo=1,ndomain_glo
147          ireq=ireq+1
148
149          IF (field_glo(ind_glo)%ndim==2) THEN
150            CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   &
151                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
152
153          ELSE IF (field_glo(ind_glo)%ndim==3) THEN
154            CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   &
155                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
156
157          ELSE IF (field_glo(ind_glo)%ndim==4) THEN
158            CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   &
159                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
160          ENDIF
161
162        ENDDO
163      ENDIF
164
165      DO ind_loc=1,ndomain
166        ireq=ireq+1
167
168        IF (field_loc(ind_loc)%ndim==2) THEN
169          CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   &
170                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
171        ELSE IF (field_loc(ind_loc)%ndim==3) THEN
172          CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   &
173                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
174        ELSE IF (field_loc(ind_loc)%ndim==4) THEN
175          CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   &
176                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
177        ENDIF
178
179      ENDDO
180
181      CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
182
183    ENDIF
184
185  END SUBROUTINE scatter_field
186
187!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
188!! Definition des Broadcast --> 4D   !!
189!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
190
191!! -- Les chaine de charactï¿œre -- !!
192
193  SUBROUTINE bcast_mpi_c(var1)
194  IMPLICIT NONE
195    CHARACTER(LEN=*),INTENT(INOUT) :: Var1
196
197    CALL bcast_mpi_cgen(Var1,len(Var1))
198
199  END SUBROUTINE bcast_mpi_c
200
201!! -- Les entiers -- !!
202
203  SUBROUTINE bcast_mpi_i(var)
204  USE mpipara
205  IMPLICIT NONE
206    INTEGER,INTENT(INOUT) :: Var
207
208    INTEGER               :: var_tmp(1)
209
210    IF (is_mpi_master) var_tmp(1)=var
211    CALL bcast_mpi_igen(Var_tmp,1)
212    var=var_tmp(1)
213
214  END SUBROUTINE bcast_mpi_i
215
216  SUBROUTINE bcast_mpi_i1(var)
217  IMPLICIT NONE
218    INTEGER,INTENT(INOUT) :: Var(:)
219
220    CALL bcast_mpi_igen(Var,size(Var))
221
222  END SUBROUTINE bcast_mpi_i1
223
224  SUBROUTINE bcast_mpi_i2(var)
225  IMPLICIT NONE
226    INTEGER,INTENT(INOUT) :: Var(:,:)
227
228    CALL bcast_mpi_igen(Var,size(Var))
229
230  END SUBROUTINE bcast_mpi_i2
231
232  SUBROUTINE bcast_mpi_i3(var)
233  IMPLICIT NONE
234    INTEGER,INTENT(INOUT) :: Var(:,:,:)
235
236    CALL bcast_mpi_igen(Var,size(Var))
237
238  END SUBROUTINE bcast_mpi_i3
239
240  SUBROUTINE bcast_mpi_i4(var)
241  IMPLICIT NONE
242    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
243
244    CALL bcast_mpi_igen(Var,size(Var))
245
246  END SUBROUTINE bcast_mpi_i4
247
248
249!! -- Les reels -- !!
250
251  SUBROUTINE bcast_mpi_r(var)
252  USE mpipara
253  IMPLICIT NONE
254    REAL,INTENT(INOUT) :: Var
255    REAL               :: var_tmp(1)
256
257    IF (is_mpi_master) var_tmp(1)=var
258    CALL bcast_mpi_rgen(Var_tmp,1)
259    var=var_tmp(1)
260
261  END SUBROUTINE bcast_mpi_r
262
263  SUBROUTINE bcast_mpi_r1(var)
264  IMPLICIT NONE
265    REAL,INTENT(INOUT) :: Var(:)
266
267    CALL bcast_mpi_rgen(Var,size(Var))
268
269  END SUBROUTINE bcast_mpi_r1
270
271  SUBROUTINE bcast_mpi_r2(var)
272  IMPLICIT NONE
273    REAL,INTENT(INOUT) :: Var(:,:)
274
275    CALL bcast_mpi_rgen(Var,size(Var))
276
277  END SUBROUTINE bcast_mpi_r2
278
279  SUBROUTINE bcast_mpi_r3(var)
280  IMPLICIT NONE
281    REAL,INTENT(INOUT) :: Var(:,:,:)
282
283    CALL bcast_mpi_rgen(Var,size(Var))
284
285  END SUBROUTINE bcast_mpi_r3
286
287  SUBROUTINE bcast_mpi_r4(var)
288  IMPLICIT NONE
289    REAL,INTENT(INOUT) :: Var(:,:,:,:)
290
291    CALL bcast_mpi_rgen(Var,size(Var))
292
293  END SUBROUTINE bcast_mpi_r4
294
295!! -- Les booleans -- !!
296
297  SUBROUTINE bcast_mpi_l(var)
298  USE mpipara
299  IMPLICIT NONE
300    LOGICAL,INTENT(INOUT) :: Var
301    LOGICAL               :: var_tmp(1)
302
303    IF (is_mpi_master) var_tmp(1)=var
304    CALL bcast_mpi_lgen(Var_tmp,1)
305    var=var_tmp(1)
306
307  END SUBROUTINE bcast_mpi_l
308
309  SUBROUTINE bcast_mpi_l1(var)
310  IMPLICIT NONE
311    LOGICAL,INTENT(INOUT) :: Var(:)
312
313    CALL bcast_mpi_lgen(Var,size(Var))
314
315  END SUBROUTINE bcast_mpi_l1
316
317  SUBROUTINE bcast_mpi_l2(var)
318  IMPLICIT NONE
319    LOGICAL,INTENT(INOUT) :: Var(:,:)
320
321    CALL bcast_mpi_lgen(Var,size(Var))
322
323  END SUBROUTINE bcast_mpi_l2
324
325  SUBROUTINE bcast_mpi_l3(var)
326  IMPLICIT NONE
327    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
328
329    CALL bcast_mpi_lgen(Var,size(Var))
330
331  END SUBROUTINE bcast_mpi_l3
332
333  SUBROUTINE bcast_mpi_l4(var)
334  IMPLICIT NONE
335    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
336
337    CALL bcast_mpi_lgen(Var,size(Var))
338
339  END SUBROUTINE bcast_mpi_l4
340
341!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
342!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
343!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
344
345  SUBROUTINE bcast_mpi_cgen(var,nb)
346    USE mpi_mod
347    USE mpipara
348    IMPLICIT NONE
349
350    CHARACTER(LEN=*),INTENT(INOUT) :: Var
351    INTEGER,INTENT(IN) :: nb
352
353    IF (.NOT. using_mpi) RETURN
354
355    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr)
356
357  END SUBROUTINE bcast_mpi_cgen
358
359
360
361  SUBROUTINE bcast_mpi_igen(var,nb)
362    USE mpi_mod
363    USE mpipara
364    IMPLICIT NONE
365    INTEGER,INTENT(IN) :: nb
366    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
367
368    IF (.NOT. using_mpi) RETURN
369
370    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr)
371
372  END SUBROUTINE bcast_mpi_igen
373
374
375
376
377  SUBROUTINE bcast_mpi_rgen(var,nb)
378    USE mpi_mod
379    USE mpipara
380    IMPLICIT NONE
381    INTEGER,INTENT(IN) :: nb
382    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
383
384    IF (.NOT. using_mpi) RETURN
385
386    CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr)
387
388  END SUBROUTINE bcast_mpi_rgen
389
390
391
392
393  SUBROUTINE bcast_mpi_lgen(var,nb)
394    USE mpi_mod
395    USE mpipara
396    IMPLICIT NONE
397    INTEGER,INTENT(IN) :: nb
398    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
399
400    IF (.NOT. using_mpi) RETURN
401
402    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr)
403
404  END SUBROUTINE bcast_mpi_lgen
405
406
407END MODULE transfert_mpi_collectives_mod
408
409
410
411
412
Note: See TracBrowser for help on using the repository browser.