Context Navigation

parallel_lmdz.F90 @ 2100

Last change on this file since 2100 was 2054, checked in by acaubel, 11 years ago
Modifications to run LMDZ in coupled mode with both OASIS-MCT and XIOS.
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: 15.3 KB

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

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

Download in other formats:

Original Format