Context Navigation

parallel_lmdz.F90 @ 5202

Last change on this file since 5202 was 4848, checked in by Laurent Fairhead, 8 months ago
Modifications needed for XIOS3
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.7 KB

Rev	Line
[1823]	1	!
	2	! $Id$
	3	!
	4	MODULE parallel_lmdz
	5	USE mod_const_mpi
[4600]	6	USE lmdz_mpi, ONLY : using_mpi
[1858]	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
[1823]	13	INTEGER,PARAMETER :: halo_max=3
	14
[3995]	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
[4600]	90	USE lmdz_mpi
[1823]	91	implicit none
[4593]	92	INCLUDE "dimensions.h"
	93	INCLUDE "paramet.h"
	94	INCLUDE "iniprint.h"
[1823]	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
[2771]	147	if (jj_nb_para(i) <= 1 ) then
[1823]	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)
[4600]	153
[1823]	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
[1859]	218	!$OMP BARRIER
[1858]	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
[1859]	227
	228	!$OMP MASTER
[1858]	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)
[1859]	232	!$OMP END MASTER
	233	!$OMP BARRIER
[1823]	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
[3995]	241	IF ((mpi_rank==0).and.(omp_rank==0)) THEN
	242	is_master=.true.
	243	ELSE
	244	is_master=.false.
	245	ENDIF
	246
[1823]	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
[4600]	385	USE lmdz_mpi
[1856]	386	! ug Pour les sorties XIOS
[4619]	387	USE wxios
	388
[1823]	389	#ifdef CPP_COUPLE
[1965]	390	! Use of Oasis-MCT coupler
	391	#if defined CPP_OMCT
	392	use mod_prism
	393	#else
[1823]	394	use mod_prism_proto
[1965]	395	#endif
[1823]	396	! Ehouarn: surface_data module is in 'phylmd' ...
	397	use surface_data, only : type_ocean
	398	implicit none
	399	#else
	400	implicit none
	401	! without the surface_data module, we declare (and set) a dummy 'type_ocean'
	402	character(len=6),parameter :: type_ocean="dummy"
	403	#endif
	404	! #endif of #ifdef CPP_EARTH
	405
	406	include "dimensions.h"
	407	include "paramet.h"
	408
	409	integer :: ierr
	410	integer :: i
	411
	412	if (allocated(jj_begin_para)) deallocate(jj_begin_para)
	413	if (allocated(jj_end_para)) deallocate(jj_end_para)
	414	if (allocated(jj_nb_para)) deallocate(jj_nb_para)
	415
	416	if (type_ocean == 'couple') then
[4848]	417	#ifdef CPP_COUPLE
[4619]	418	IF (using_xios) THEN
	419	!Fermeture propre de XIOS
	420	CALL wxios_close()
[4848]	421	CALL prism_terminate_proto(ierr)
	422	IF (ierr .ne. PRISM_Ok) THEN
	423	CALL abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
	424	ENDIF
[4619]	425	ELSE
	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
[4848]	430	ENDIF
	431	#else
	432	call abort_gcm('Finalize_parallel','type_ocean = couple but CPP_COUPLE not defined',1)
[1823]	433	#endif
	434	else
[4619]	435	IF (using_xios) THEN
	436	!Fermeture propre de XIOS
	437	CALL wxios_close()
	438	ENDIF
	439	IF (using_mpi) call MPI_FINALIZE(ierr)
[1823]	440	end if
	441
	442	end subroutine Finalize_parallel
	443
	444	subroutine Pack_Data(Field,ij,ll,row,Buffer)
	445	implicit none
	446
[4593]	447	INCLUDE "dimensions.h"
	448	INCLUDE "paramet.h"
[1823]	449
	450	integer, intent(in) :: ij,ll,row
	451	real,dimension(ij,ll),intent(in) ::Field
	452	real,dimension(lliip1row), intent(out) :: Buffer
	453
	454	integer :: Pos
	455	integer :: i,l
	456
	457	Pos=0
	458	do l=1,ll
	459	do i=1,row*iip1
	460	Pos=Pos+1
	461	Buffer(Pos)=Field(i,l)
	462	enddo
	463	enddo
	464
	465	end subroutine Pack_data
	466
	467	subroutine Unpack_Data(Field,ij,ll,row,Buffer)
	468	implicit none
	469
[4593]	470	INCLUDE "dimensions.h"
	471	INCLUDE "paramet.h"
[1823]	472
	473	integer, intent(in) :: ij,ll,row
	474	real,dimension(ij,ll),intent(out) ::Field
	475	real,dimension(lliip1row), intent(in) :: Buffer
	476
	477	integer :: Pos
	478	integer :: i,l
	479
	480	Pos=0
	481
	482	do l=1,ll
	483	do i=1,row*iip1
	484	Pos=Pos+1
	485	Field(i,l)=Buffer(Pos)
	486	enddo
	487	enddo
	488
	489	end subroutine UnPack_data
	490
	491
	492	SUBROUTINE barrier
[4600]	493	USE lmdz_mpi
[1823]	494	IMPLICIT NONE
	495	INTEGER :: ierr
	496
	497	!$OMP CRITICAL (MPI)
	498	IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
	499	!$OMP END CRITICAL (MPI)
	500
	501	END SUBROUTINE barrier
	502
	503
	504	subroutine exchange_hallo(Field,ij,ll,up,down)
[4600]	505	USE lmdz_mpi
[1823]	506	USE Vampir
	507	implicit none
[4593]	508	INCLUDE "dimensions.h"
	509	INCLUDE "paramet.h"
[1823]	510	INTEGER :: ij,ll
	511	REAL, dimension(ij,ll) :: Field
	512	INTEGER :: up,down
	513
	514	INTEGER :: ierr
	515	LOGICAL :: SendUp,SendDown
	516	LOGICAL :: RecvUp,RecvDown
	517	INTEGER, DIMENSION(4) :: Request
	518	INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
[4600]	519
[1823]	520	INTEGER :: NbRequest
	521	REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
	522	REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
	523	INTEGER :: Buffer_size
	524
	525	IF (using_mpi) THEN
	526
	527	CALL barrier
	528
	529	call VTb(VThallo)
	530
	531	SendUp=.TRUE.
	532	SendDown=.TRUE.
	533	RecvUp=.TRUE.
	534	RecvDown=.TRUE.
	535
	536	IF (pole_nord) THEN
	537	SendUp=.FALSE.
	538	RecvUp=.FALSE.
	539	ENDIF
	540
	541	IF (pole_sud) THEN
	542	SendDown=.FALSE.
	543	RecvDown=.FALSE.
	544	ENDIF
	545
	546	if (up.eq.0) then
	547	SendDown=.FALSE.
	548	RecvUp=.FALSE.
	549	endif
	550
	551	if (down.eq.0) then
	552	SendUp=.FALSE.
	553	RecvDown=.FALSE.
	554	endif
	555
	556	NbRequest=0
	557
	558	IF (SendUp) THEN
	559	NbRequest=NbRequest+1
	560	buffer_size=downiip1ll
	561	allocate(Buffer_Send_up(Buffer_size))
	562	call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
	563	!$OMP CRITICAL (MPI)
[2620]	564	call MPI_ISEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, &
[1823]	565	COMM_LMDZ,Request(NbRequest),ierr)
	566	!$OMP END CRITICAL (MPI)
	567	ENDIF
	568
	569	IF (SendDown) THEN
	570	NbRequest=NbRequest+1
	571
	572	buffer_size=upiip1ll
	573	allocate(Buffer_Send_down(Buffer_size))
	574	call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
	575
	576	!$OMP CRITICAL (MPI)
[2621]	577	call MPI_ISEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, &
[1823]	578	COMM_LMDZ,Request(NbRequest),ierr)
	579	!$OMP END CRITICAL (MPI)
	580	ENDIF
	581
	582
	583	IF (RecvUp) THEN
	584	NbRequest=NbRequest+1
	585	buffer_size=upiip1ll
	586	allocate(Buffer_recv_up(Buffer_size))
	587
	588	!$OMP CRITICAL (MPI)
	589	call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, &
	590	COMM_LMDZ,Request(NbRequest),ierr)
	591	!$OMP END CRITICAL (MPI)
	592
	593
	594	ENDIF
	595
	596	IF (RecvDown) THEN
	597	NbRequest=NbRequest+1
	598	buffer_size=downiip1ll
	599	allocate(Buffer_recv_down(Buffer_size))
	600
	601	!$OMP CRITICAL (MPI)
	602	call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, &
	603	COMM_LMDZ,Request(NbRequest),ierr)
	604	!$OMP END CRITICAL (MPI)
	605
	606	ENDIF
	607
	608	if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
	609	IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
	610	IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)
	611
	612	call VTe(VThallo)
	613	call barrier
	614
	615	ENDIF ! using_mpi
	616
	617	RETURN
	618
	619	end subroutine exchange_Hallo
	620
	621
	622	subroutine Gather_Field(Field,ij,ll,rank)
[4600]	623	USE lmdz_mpi
[1823]	624	implicit none
[4593]	625	INCLUDE "dimensions.h"
	626	INCLUDE "paramet.h"
	627	INCLUDE "iniprint.h"
[1823]	628	INTEGER :: ij,ll,rank
	629	REAL, dimension(ij,ll) :: Field
	630	REAL, dimension(:),allocatable :: Buffer_send
	631	REAL, dimension(:),allocatable :: Buffer_Recv
	632	INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
	633	INTEGER :: ierr
	634	INTEGER ::i
	635
	636	IF (using_mpi) THEN
	637
	638	if (ij==ip1jmp1) then
	639	allocate(Buffer_send(iip1ll(jj_end-jj_begin+1)))
	640	call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
	641	else if (ij==ip1jm) then
	642	allocate(Buffer_send(iip1ll(min(jj_end,jjm)-jj_begin+1)))
	643	call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
	644	else
	645	write(lunout,*)ij
[4469]	646	CALL abort_gcm("parallel_lmdz","erreur dans Gather_Field",1)
[1823]	647	endif
	648
	649	if (MPI_Rank==rank) then
	650	allocate(Buffer_Recv(ij*ll))
	651
	652	!CDIR NOVECTOR
	653	do i=0,MPI_Size-1
	654
	655	if (ij==ip1jmp1) then
	656	Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)lliip1
	657	else if (ij==ip1jm) then
	658	Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)lliip1
	659	else
[4469]	660	CALL abort_gcm("parallel_lmdz","erreur dans Gather_Field",1)
[1823]	661	endif
	662
	663	if (i==0) then
	664	displ(i)=0
	665	else
	666	displ(i)=displ(i-1)+Recv_count(i-1)
	667	endif
	668
	669	enddo
	670
	671	else
	672	! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
	673	! below) about Buffer_Recv() being not allocated.
	674	! So make a dummy allocation.
	675	allocate(Buffer_Recv(1))
	676	endif ! of if (MPI_Rank==rank)
	677
	678	!$OMP CRITICAL (MPI)
	679	call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, &
	680	Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
	681	!$OMP END CRITICAL (MPI)
	682
	683	if (MPI_Rank==rank) then
	684
	685	if (ij==ip1jmp1) then
	686	do i=0,MPI_Size-1
	687	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
	688	jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
	689	enddo
	690	else if (ij==ip1jm) then
	691	do i=0,MPI_Size-1
	692	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
	693	min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
	694	enddo
	695	endif
	696	endif
	697	ENDIF ! using_mpi
	698
	699	end subroutine Gather_Field
	700
	701
	702	subroutine AllGather_Field(Field,ij,ll)
[4600]	703	USE lmdz_mpi
[1823]	704	implicit none
[4593]	705	INCLUDE "dimensions.h"
	706	INCLUDE "paramet.h"
[1823]	707	INTEGER :: ij,ll
	708	REAL, dimension(ij,ll) :: Field
	709	INTEGER :: ierr
	710
	711	IF (using_mpi) THEN
	712	call Gather_Field(Field,ij,ll,0)
	713	!$OMP CRITICAL (MPI)
	714	call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
	715	!$OMP END CRITICAL (MPI)
	716	ENDIF
	717
	718	end subroutine AllGather_Field
	719
	720	subroutine Broadcast_Field(Field,ij,ll,rank)
[4600]	721	USE lmdz_mpi
[1823]	722	implicit none
[4593]	723	INCLUDE "dimensions.h"
	724	INCLUDE "paramet.h"
[1823]	725	INTEGER :: ij,ll
	726	REAL, dimension(ij,ll) :: Field
	727	INTEGER :: rank
	728	INTEGER :: ierr
	729
	730	IF (using_mpi) THEN
	731
	732	!$OMP CRITICAL (MPI)
	733	call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
	734	!$OMP END CRITICAL (MPI)
	735
	736	ENDIF
	737	end subroutine Broadcast_Field
	738
	739
	740	! Subroutine verif_hallo(Field,ij,ll,up,down)
[4600]	741	! USE lmdz_mpi
[1823]	742	! implicit none
[4593]	743	! INCLUDE "dimensions.h"
	744	! INCLUDE "paramet.h"
[1823]	745	!
	746	! INTEGER :: ij,ll
	747	! REAL, dimension(ij,ll) :: Field
	748	! INTEGER :: up,down
	749	!
	750	! REAL,dimension(ij,ll): NewField
	751	!
	752	! NewField=0
	753	!
	754	! ijb=ij_begin
	755	! ije=ij_end
	756	! if (pole_nord)
	757	! NewField(ij_be
	758
	759	end MODULE parallel_lmdz

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

Download in other formats:

Original Format