Context Navigation

parallel_lmdz.F90 @ 5213

Last change on this file since 5213 was 5207, checked in by Laurent Fairhead, 43 hours ago
Another correction to previous commit
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory
File size: 20.0 KB

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

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

Download in other formats:

Original Format