Context Navigation

parallel_lmdz.F90 @ 4263

Last change on this file since 4263 was 3995, checked in by Ehouarn Millour, 3 years ago
Nudging: fixed some indexes in parallel about process domain boundaries and updated the serial nudging routine so that it matches the parallel one (they had diverged at some point). Also added an "is_master" logical in the parallel_lmdz module to ease decreasing the number of messages written to standard output. EM
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: 19.9 KB

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

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

Download in other formats:

Original Format