Context Navigation

parallel_lmdz.F90 @ 1856

Last change on this file since 1856 was 1852, checked in by Ehouarn Millour, 12 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

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
	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
[1852]	201	#ifdef CPP_XIOS
	202	! ug Pour les sorties XIOS
	203	USE wxios
	204	#endif
[1823]	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
[1852]	238	#ifdef CPP_XIOS
	239	!Fermeture propre de XIOS
	240	CALL wxios_close()
	241	#endif
[1823]	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