Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

parallel_lmdz.F90

Last change on this file was 3852, checked in by jmauxion, 6 weeks ago

Mars PCM:
Improve the omp_chunk computation to fix a MPI request error arising for some combinations of llm/omp_size:

Make sure that the omp_chunk is not too large so that the last thread do nothing.
Check and raise a warning if the chunk is so small that the loop distribution require a second cycle over the threads (which is not optimum).

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

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

Download in other formats:

Original Format