Context Navigation

parallel_lmdz.F90 @ 1852

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

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

Download in other formats:

Original Format