Context Navigation

parallel_lmdz.F90 @ 1891

Last change on this file since 1891 was 1860, checked in by Ehouarn Millour, 11 years ago
Implement in dyn3dpar the modifications that were made in the dyn3dmem dynamics (r1858-1859) about setting size of omp_chunk. EM
File size: 15.2 KB

Line
1	!
2	! $Id: parallel.F90 1810 2013-07-24 08:06:39Z emillour $
3	!
4	MODULE parallel_lmdz
5	USE mod_const_mpi
6	#ifdef CPP_IOIPSL
7	use IOIPSL, only: getin
8	#else
9	! if not using IOIPSL, we still need to use (a local version of) getin
10	use ioipsl_getincom, only: getin
11	#endif
12
13	LOGICAL,SAVE :: using_mpi=.TRUE.
14	LOGICAL,SAVE :: using_omp
15
16	integer, save :: mpi_size
17	integer, save :: mpi_rank
18	integer, save :: jj_begin
19	integer, save :: jj_end
20	integer, save :: jj_nb
21	integer, save :: ij_begin
22	integer, save :: ij_end
23	logical, save :: pole_nord
24	logical, save :: pole_sud
25
26	integer, allocatable, save, dimension(:) :: jj_begin_para
27	integer, allocatable, save, dimension(:) :: jj_end_para
28	integer, allocatable, save, dimension(:) :: jj_nb_para
29	integer, save :: OMP_CHUNK
30	integer, save :: omp_rank
31	integer, save :: omp_size
32	!$OMP THREADPRIVATE(omp_rank)
33
34	contains
35
36	subroutine init_parallel
37	USE vampir
38	implicit none
39	#ifdef CPP_MPI
40	include 'mpif.h'
41	#endif
42	#include "dimensions.h"
43	#include "paramet.h"
44	#include "iniprint.h"
45
46	integer :: ierr
47	integer :: i,j
48	integer :: type_size
49	integer, dimension(3) :: blocklen,type
50	integer :: comp_id
51	character(len=4) :: num
52	character(len=20) :: filename
53
54	#ifdef CPP_OMP
55	INTEGER :: OMP_GET_NUM_THREADS
56	EXTERNAL OMP_GET_NUM_THREADS
57	INTEGER :: OMP_GET_THREAD_NUM
58	EXTERNAL OMP_GET_THREAD_NUM
59	#endif
60
61	#ifdef CPP_MPI
62	using_mpi=.TRUE.
63	#else
64	using_mpi=.FALSE.
65	#endif
66
67
68	#ifdef CPP_OMP
69	using_OMP=.TRUE.
70	#else
71	using_OMP=.FALSE.
72	#endif
73
74	call InitVampir
75
76	IF (using_mpi) THEN
77	#ifdef CPP_MPI
78	call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
79	call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
80	#endif
81	ELSE
82	mpi_size=1
83	mpi_rank=0
84	ENDIF
85
86
87	! Open text output file with mpi_rank in suffix of file name
88	IF (lunout /= 5 .and. lunout /= 6) THEN
89	WRITE(num,'(I4.4)') mpi_rank
90	filename='lmdz.out_'//num
91	IF (mpi_rank .NE. 0) THEN
92	OPEN(UNIT=lunout,FILE=TRIM(filename),ACTION='write', &
93	STATUS='unknown',FORM='formatted',IOSTAT=ierr)
94	ENDIF
95	ENDIF
96
97
98	allocate(jj_begin_para(0:mpi_size-1))
99	allocate(jj_end_para(0:mpi_size-1))
100	allocate(jj_nb_para(0:mpi_size-1))
101
102	do i=0,mpi_size-1
103	jj_nb_para(i)=(jjm+1)/mpi_size
104	if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
105
106	if (jj_nb_para(i) <= 2 ) then
107
108	write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
109	write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
110
111	#ifdef CPP_MPI
112	IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
113	#endif
114	endif
115
116	enddo
117
118	! jj_nb_para(0)=11
119	! jj_nb_para(1)=25
120	! jj_nb_para(2)=25
121	! jj_nb_para(3)=12
122
123	j=1
124
125	do i=0,mpi_size-1
126
127	jj_begin_para(i)=j
128	jj_end_para(i)=j+jj_Nb_para(i)-1
129	j=j+jj_Nb_para(i)
130
131	enddo
132
133	jj_begin = jj_begin_para(mpi_rank)
134	jj_end = jj_end_para(mpi_rank)
135	jj_nb = jj_nb_para(mpi_rank)
136
137	ij_begin=(jj_begin-1)*iip1+1
138	ij_end=jj_end*iip1
139
140	if (mpi_rank.eq.0) then
141	pole_nord=.TRUE.
142	else
143	pole_nord=.FALSE.
144	endif
145
146	if (mpi_rank.eq.mpi_size-1) then
147	pole_sud=.TRUE.
148	else
149	pole_sud=.FALSE.
150	endif
151
152	write(lunout,*)"init_parallel: jj_begin",jj_begin
153	write(lunout,*)"init_parallel: jj_end",jj_end
154	write(lunout,*)"init_parallel: ij_begin",ij_begin
155	write(lunout,*)"init_parallel: ij_end",ij_end
156
157	!$OMP PARALLEL
158
159	#ifdef CPP_OMP
160	!$OMP MASTER
161	omp_size=OMP_GET_NUM_THREADS()
162	!$OMP END MASTER
163	!$OMP BARRIER
164	omp_rank=OMP_GET_THREAD_NUM()
165
166	!Config Key = omp_chunk
167	!Config Desc = taille des blocs openmp
168	!Config Def = 1
169	!Config Help = defini la taille des packets d'it�ration openmp
170	!Config distribue a chaque tache lors de l'entree dans une
171	!Config boucle parallelisee
172
173	!$OMP MASTER
174	omp_chunk=(llm+1)/omp_size
175	IF (MOD(llm+1,omp_size)/=0) omp_chunk=omp_chunk+1
176	CALL getin('omp_chunk',omp_chunk)
177	!$OMP END MASTER
178	!$OMP BARRIER
179	#else
180	omp_size=1
181	omp_rank=0
182	#endif
183	!$OMP END PARALLEL
184
185	end subroutine init_parallel
186
187
188	subroutine SetDistrib(jj_Nb_New)
189	implicit none
190
191	#include "dimensions.h"
192	#include "paramet.h"
193
194	INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New
195	INTEGER :: i
196
197	jj_Nb_Para=jj_Nb_New
198
199	jj_begin_para(0)=1
200	jj_end_para(0)=jj_Nb_Para(0)
201
202	do i=1,mpi_size-1
203
204	jj_begin_para(i)=jj_end_para(i-1)+1
205	jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1
206
207	enddo
208
209	jj_begin = jj_begin_para(mpi_rank)
210	jj_end = jj_end_para(mpi_rank)
211	jj_nb = jj_nb_para(mpi_rank)
212
213	ij_begin=(jj_begin-1)*iip1+1
214	ij_end=jj_end*iip1
215
216	end subroutine SetDistrib
217
218
219
220
221	subroutine Finalize_parallel
222	#ifdef CPP_XIOS
223	! ug Pour les sorties XIOS
224	USE wxios
225	#endif
226	#ifdef CPP_COUPLE
227	use mod_prism_proto
228	! Ehouarn: surface_data module is in 'phylmd' ...
229	use surface_data, only : type_ocean
230	implicit none
231	#else
232	implicit none
233	! without the surface_data module, we declare (and set) a dummy 'type_ocean'
234	character(len=6),parameter :: type_ocean="dummy"
235	#endif
236	! #endif of #ifdef CPP_EARTH
237
238	include "dimensions.h"
239	include "paramet.h"
240	#ifdef CPP_MPI
241	include 'mpif.h'
242	#endif
243
244	integer :: ierr
245	integer :: i
246
247	if (allocated(jj_begin_para)) deallocate(jj_begin_para)
248	if (allocated(jj_end_para)) deallocate(jj_end_para)
249	if (allocated(jj_nb_para)) deallocate(jj_nb_para)
250
251	if (type_ocean == 'couple') then
252	#ifdef CPP_COUPLE
253	call prism_terminate_proto(ierr)
254	IF (ierr .ne. PRISM_Ok) THEN
255	call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
256	endif
257	#endif
258	else
259	#ifdef CPP_XIOS
260	!Fermeture propre de XIOS
261	CALL wxios_close()
262	#endif
263	#ifdef CPP_MPI
264	IF (using_mpi) call MPI_FINALIZE(ierr)
265	#endif
266	end if
267
268	end subroutine Finalize_parallel
269
270	subroutine Pack_Data(Field,ij,ll,row,Buffer)
271	implicit none
272
273	#include "dimensions.h"
274	#include "paramet.h"
275
276	integer, intent(in) :: ij,ll,row
277	real,dimension(ij,ll),intent(in) ::Field
278	real,dimension(lliip1row), intent(out) :: Buffer
279
280	integer :: Pos
281	integer :: i,l
282
283	Pos=0
284	do l=1,ll
285	do i=1,row*iip1
286	Pos=Pos+1
287	Buffer(Pos)=Field(i,l)
288	enddo
289	enddo
290
291	end subroutine Pack_data
292
293	subroutine Unpack_Data(Field,ij,ll,row,Buffer)
294	implicit none
295
296	#include "dimensions.h"
297	#include "paramet.h"
298
299	integer, intent(in) :: ij,ll,row
300	real,dimension(ij,ll),intent(out) ::Field
301	real,dimension(lliip1row), intent(in) :: Buffer
302
303	integer :: Pos
304	integer :: i,l
305
306	Pos=0
307
308	do l=1,ll
309	do i=1,row*iip1
310	Pos=Pos+1
311	Field(i,l)=Buffer(Pos)
312	enddo
313	enddo
314
315	end subroutine UnPack_data
316
317
318	SUBROUTINE barrier
319	IMPLICIT NONE
320	#ifdef CPP_MPI
321	INCLUDE 'mpif.h'
322	#endif
323	INTEGER :: ierr
324
325	!$OMP CRITICAL (MPI)
326	#ifdef CPP_MPI
327	IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
328	#endif
329	!$OMP END CRITICAL (MPI)
330
331	END SUBROUTINE barrier
332
333
334	subroutine exchange_hallo(Field,ij,ll,up,down)
335	USE Vampir
336	implicit none
337	#include "dimensions.h"
338	#include "paramet.h"
339	#ifdef CPP_MPI
340	include 'mpif.h'
341	#endif
342	INTEGER :: ij,ll
343	REAL, dimension(ij,ll) :: Field
344	INTEGER :: up,down
345
346	INTEGER :: ierr
347	LOGICAL :: SendUp,SendDown
348	LOGICAL :: RecvUp,RecvDown
349	INTEGER, DIMENSION(4) :: Request
350	#ifdef CPP_MPI
351	INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
352	#else
353	INTEGER, DIMENSION(1,4) :: Status
354	#endif
355	INTEGER :: NbRequest
356	REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
357	REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
358	INTEGER :: Buffer_size
359
360	IF (using_mpi) THEN
361
362	CALL barrier
363
364	call VTb(VThallo)
365
366	SendUp=.TRUE.
367	SendDown=.TRUE.
368	RecvUp=.TRUE.
369	RecvDown=.TRUE.
370
371	IF (pole_nord) THEN
372	SendUp=.FALSE.
373	RecvUp=.FALSE.
374	ENDIF
375
376	IF (pole_sud) THEN
377	SendDown=.FALSE.
378	RecvDown=.FALSE.
379	ENDIF
380
381	if (up.eq.0) then
382	SendDown=.FALSE.
383	RecvUp=.FALSE.
384	endif
385
386	if (down.eq.0) then
387	SendUp=.FALSE.
388	RecvDown=.FALSE.
389	endif
390
391	NbRequest=0
392
393	IF (SendUp) THEN
394	NbRequest=NbRequest+1
395	buffer_size=downiip1ll
396	allocate(Buffer_Send_up(Buffer_size))
397	call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
398	!$OMP CRITICAL (MPI)
399	#ifdef CPP_MPI
400	call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, &
401	COMM_LMDZ,Request(NbRequest),ierr)
402	#endif
403	!$OMP END CRITICAL (MPI)
404	ENDIF
405
406	IF (SendDown) THEN
407	NbRequest=NbRequest+1
408
409	buffer_size=upiip1ll
410	allocate(Buffer_Send_down(Buffer_size))
411	call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
412
413	!$OMP CRITICAL (MPI)
414	#ifdef CPP_MPI
415	call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, &
416	COMM_LMDZ,Request(NbRequest),ierr)
417	#endif
418	!$OMP END CRITICAL (MPI)
419	ENDIF
420
421
422	IF (RecvUp) THEN
423	NbRequest=NbRequest+1
424	buffer_size=upiip1ll
425	allocate(Buffer_recv_up(Buffer_size))
426
427	!$OMP CRITICAL (MPI)
428	#ifdef CPP_MPI
429	call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, &
430	COMM_LMDZ,Request(NbRequest),ierr)
431	#endif
432	!$OMP END CRITICAL (MPI)
433
434
435	ENDIF
436
437	IF (RecvDown) THEN
438	NbRequest=NbRequest+1
439	buffer_size=downiip1ll
440	allocate(Buffer_recv_down(Buffer_size))
441
442	!$OMP CRITICAL (MPI)
443	#ifdef CPP_MPI
444	call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, &
445	COMM_LMDZ,Request(NbRequest),ierr)
446	#endif
447	!$OMP END CRITICAL (MPI)
448
449	ENDIF
450
451	#ifdef CPP_MPI
452	if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
453	#endif
454	IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
455	IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)
456
457	call VTe(VThallo)
458	call barrier
459
460	ENDIF ! using_mpi
461
462	RETURN
463
464	end subroutine exchange_Hallo
465
466
467	subroutine Gather_Field(Field,ij,ll,rank)
468	implicit none
469	#include "dimensions.h"
470	#include "paramet.h"
471	#include "iniprint.h"
472	#ifdef CPP_MPI
473	include 'mpif.h'
474	#endif
475	INTEGER :: ij,ll,rank
476	REAL, dimension(ij,ll) :: Field
477	REAL, dimension(:),allocatable :: Buffer_send
478	REAL, dimension(:),allocatable :: Buffer_Recv
479	INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
480	INTEGER :: ierr
481	INTEGER ::i
482
483	IF (using_mpi) THEN
484
485	if (ij==ip1jmp1) then
486	allocate(Buffer_send(iip1ll(jj_end-jj_begin+1)))
487	call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
488	else if (ij==ip1jm) then
489	allocate(Buffer_send(iip1ll(min(jj_end,jjm)-jj_begin+1)))
490	call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
491	else
492	write(lunout,*)ij
493	stop 'erreur dans Gather_Field'
494	endif
495
496	if (MPI_Rank==rank) then
497	allocate(Buffer_Recv(ij*ll))
498
499	!CDIR NOVECTOR
500	do i=0,MPI_Size-1
501
502	if (ij==ip1jmp1) then
503	Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)lliip1
504	else if (ij==ip1jm) then
505	Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)lliip1
506	else
507	stop 'erreur dans Gather_Field'
508	endif
509
510	if (i==0) then
511	displ(i)=0
512	else
513	displ(i)=displ(i-1)+Recv_count(i-1)
514	endif
515
516	enddo
517
518	else
519	! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
520	! below) about Buffer_Recv() being not allocated.
521	! So make a dummy allocation.
522	allocate(Buffer_Recv(1))
523	endif ! of if (MPI_Rank==rank)
524
525	!$OMP CRITICAL (MPI)
526	#ifdef CPP_MPI
527	call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, &
528	Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
529	#endif
530	!$OMP END CRITICAL (MPI)
531
532	if (MPI_Rank==rank) then
533
534	if (ij==ip1jmp1) then
535	do i=0,MPI_Size-1
536	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
537	jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
538	enddo
539	else if (ij==ip1jm) then
540	do i=0,MPI_Size-1
541	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
542	min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
543	enddo
544	endif
545	endif
546	ENDIF ! using_mpi
547
548	end subroutine Gather_Field
549
550
551	subroutine AllGather_Field(Field,ij,ll)
552	implicit none
553	#include "dimensions.h"
554	#include "paramet.h"
555	#ifdef CPP_MPI
556	include 'mpif.h'
557	#endif
558	INTEGER :: ij,ll
559	REAL, dimension(ij,ll) :: Field
560	INTEGER :: ierr
561
562	IF (using_mpi) THEN
563	call Gather_Field(Field,ij,ll,0)
564	!$OMP CRITICAL (MPI)
565	#ifdef CPP_MPI
566	call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
567	#endif
568	!$OMP END CRITICAL (MPI)
569	ENDIF
570
571	end subroutine AllGather_Field
572
573	subroutine Broadcast_Field(Field,ij,ll,rank)
574	implicit none
575	#include "dimensions.h"
576	#include "paramet.h"
577	#ifdef CPP_MPI
578	include 'mpif.h'
579	#endif
580	INTEGER :: ij,ll
581	REAL, dimension(ij,ll) :: Field
582	INTEGER :: rank
583	INTEGER :: ierr
584
585	IF (using_mpi) THEN
586
587	!$OMP CRITICAL (MPI)
588	#ifdef CPP_MPI
589	call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
590	#endif
591	!$OMP END CRITICAL (MPI)
592
593	ENDIF
594	end subroutine Broadcast_Field
595
596
597	! Subroutine verif_hallo(Field,ij,ll,up,down)
598	! implicit none
599	!#include "dimensions.h"
600	!#include "paramet.h"
601	! include 'mpif.h'
602	!
603	! INTEGER :: ij,ll
604	! REAL, dimension(ij,ll) :: Field
605	! INTEGER :: up,down
606	!
607	! REAL,dimension(ij,ll): NewField
608	!
609	! NewField=0
610	!
611	! ijb=ij_begin
612	! ije=ij_end
613	! if (pole_nord)
614	! NewField(ij_be
615
616	end MODULE parallel_lmdz

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format