Context Navigation

parallel.F90 @ 66

Last change on this file since 66 was 66, checked in by emillour, 14 years ago

EM: Mise a niveau par rapport a la version terrestre (LMDZ5V2.0-dev, rev 1487)

Mise a jour des scripts (terrestres) 'makegcm' et 'create_make_gcm'
Ajout du script 'makelmdz' (version "amelioree", en Bash, de makegcm)
Mise a jour des routines dans phylmd (sauf regr_lat_time_climoz_m.F)

disvert (dans dyn3d et dyn3dpar): passage au Fortran 90
parallel.F90 (dyn3dpar): correction bug
etat0_netcdf.F90 (dyn3d et dyn3dpar) : mise a jour mineure
ce0l.F90 (dyn3dpar) : correction bug
abort_gcm.F (dyn3dpar) : correction bug
ugeostr.F90 (dyn3d et dyn3dpar) : passage au Fortran 90
fluxstokenc_p.F (dyn3dpar) : correction bug
iniacademic.F90 (dyn3d et dyn3dpar) : passage au Fortran 90
friction_p.F (dyn3dpar) : correction bug
infotrac.F90 (dyn3d et dyn3dpar) : correction bug mineur sur lecture traceurs
caladvtrac.F (dyn3d) : modifications cosmetiques

File size: 13.7 KB

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

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

Download in other formats:

Original Format