Context Navigation

mod_hallo.F90 @ 2397

Last change on this file since 2397 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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: 44.9 KB

Rev	Line
[1632]	1	module mod_Hallo
[1823]	2	USE parallel_lmdz
[1632]	3	implicit none
	4	logical,save :: use_mpi_alloc
	5	integer, parameter :: MaxProc=512
[1847]	6	integer, parameter :: DefaultMaxBufferSize=10241024100
	7	integer, SAVE :: MaxBufferSize=0
[1632]	8	integer, parameter :: ListSize=1000
	9
	10	integer,save :: MaxBufferSize_Used
	11	!$OMP THREADPRIVATE( MaxBufferSize_Used)
	12
	13	real,save,pointer,dimension(:) :: Buffer
	14	!$OMP THREADPRIVATE(Buffer)
	15
	16	integer,save,dimension(Listsize) :: Buffer_Pos
	17	integer,save :: Index_Pos
	18	!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
	19
	20	type Hallo
	21	real, dimension(:,:),pointer :: Field
	22	integer :: offset
	23	integer :: size
	24	integer :: NbLevel
	25	integer :: Stride
	26	end type Hallo
	27
	28	type request_SR
	29	integer :: NbRequest=0
[1847]	30	integer :: NbRequestMax=0
[1632]	31	integer :: BufferSize
	32	integer :: Pos
	33	integer :: Index
[1847]	34	type(Hallo), POINTER :: Hallo(:)
[1632]	35	integer :: MSG_Request
	36	end type request_SR
	37
	38	type request
	39	type(request_SR),dimension(0:MaxProc-1) :: RequestSend
	40	type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
	41	integer :: tag=1
	42	end type request
	43
	44	TYPE(distrib),SAVE :: distrib_gather
	45
	46
	47	INTERFACE Register_SwapField_u
	48	MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u
	49	END INTERFACE Register_SwapField_u
	50
	51	INTERFACE Register_SwapField_v
	52	MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v
	53	END INTERFACE Register_SwapField_v
	54
	55	INTERFACE Register_SwapField2d_u
	56	MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d
	57	END INTERFACE Register_SwapField2d_u
	58
	59	INTERFACE Register_SwapField2d_v
	60	MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d
	61	END INTERFACE Register_SwapField2d_v
	62
	63	contains
	64
	65	subroutine Init_mod_hallo
[1810]	66	USE dimensions_mod
[1847]	67	USE IOIPSL
[1632]	68	implicit none
	69	integer :: jj_nb_gather(0:mpi_size-1)
	70
	71	Index_Pos=1
	72	Buffer_Pos(Index_Pos)=1
	73	MaxBufferSize_Used=0
[1847]	74	!$OMP MASTER
	75	MaxBufferSize=DefaultMaxBufferSize
	76	CALL getin("mpi_buffer_size",MaxBufferSize)
	77	!$OMP END MASTER
	78	!$OMP BARRIER
	79
[1632]	80	IF (use_mpi_alloc .AND. using_mpi) THEN
	81	CALL create_global_mpi_buffer
	82	ELSE
	83	CALL create_standard_mpi_buffer
	84	ENDIF
	85
[1803]	86	!$OMP MASTER
[1632]	87	jj_nb_gather(:)=0
	88	jj_nb_gather(0)=jjp1
	89
	90	CALL create_distrib(jj_nb_gather,distrib_gather)
[1803]	91	!$OMP END MASTER
	92	!$OMP BARRIER
[1847]	93
[1632]	94	end subroutine init_mod_hallo
	95
	96	SUBROUTINE create_standard_mpi_buffer
	97	IMPLICIT NONE
	98
	99	ALLOCATE(Buffer(MaxBufferSize))
	100
	101	END SUBROUTINE create_standard_mpi_buffer
	102
	103	SUBROUTINE create_global_mpi_buffer
	104	IMPLICIT NONE
	105	#ifdef CPP_MPI
	106	INCLUDE 'mpif.h'
	107	#endif
	108	POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
	109	REAL :: MPI_Buffer
	110	#ifdef CPP_MPI
	111	INTEGER(KIND=MPI_ADDRESS_KIND) :: BS
	112	#else
	113	INTEGER(KIND=8) :: BS
	114	#endif
	115	INTEGER :: i,ierr
	116
	117	! Allocation du buffer MPI
	118	Bs=8*MaxBufferSize
	119	!$OMP CRITICAL (MPI)
	120	#ifdef CPP_MPI
	121	CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
	122	#endif
	123	!$OMP END CRITICAL (MPI)
	124	DO i=1,MaxBufferSize
	125	MPI_Buffer(i)=i
	126	ENDDO
	127
	128	CALL Associate_buffer(MPI_Buffer)
	129
	130	CONTAINS
	131
	132	SUBROUTINE Associate_buffer(MPI_Buffer)
	133	IMPLICIT NONE
	134	REAL,DIMENSION(:),target :: MPI_Buffer
	135
	136	Buffer=>MPI_Buffer
	137
	138	END SUBROUTINE Associate_buffer
	139
	140	END SUBROUTINE create_global_mpi_buffer
	141
	142
	143	subroutine allocate_buffer(Size,Index,Pos)
	144	implicit none
	145	integer :: Size
	146	integer :: Index
	147	integer :: Pos
	148
	149	if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size
	150	if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
	151	print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
	152	stop
	153	endif
	154
	155	if (Index_pos>=ListSize) then
	156	print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
	157	stop
	158	endif
	159
	160	Pos=Buffer_Pos(Index_Pos)
	161	Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
	162	Index_Pos=Index_Pos+1
	163	Index=Index_Pos
	164
	165	end subroutine allocate_buffer
	166
	167	subroutine deallocate_buffer(Index)
	168	implicit none
	169	integer :: Index
	170
	171	Buffer_Pos(Index)=-1
	172
	173	do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
	174	Index_Pos=Index_Pos-1
	175	end do
	176
	177	end subroutine deallocate_buffer
	178
	179	subroutine SetTag(a_request,tag)
	180	implicit none
	181	type(request):: a_request
	182	integer :: tag
	183
	184	a_request%tag=tag
	185	end subroutine SetTag
	186
	187
[1847]	188	subroutine New_Hallo(Field,Stride,NbLevel,offset,size,Ptr_request)
[1632]	189	integer :: Stride
	190	integer :: NbLevel
	191	integer :: size
	192	integer :: offset
	193	real, dimension(Stride,NbLevel),target :: Field
[1847]	194	type(request_SR),pointer :: Ptr_request
	195	type(Hallo),POINTER :: NewHallos(:),HalloSwitch(:), NewHallo
[1632]	196
[1847]	197	Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
	198	IF(Ptr_Request%NbRequestMax==0) THEN
	199	Ptr_Request%NbRequestMax=10
	200	ALLOCATE(Ptr_Request%Hallo(Ptr_Request%NbRequestMax))
	201	ELSE IF ( Ptr_Request%NbRequest > Ptr_Request%NbRequestMax) THEN
	202	Ptr_Request%NbRequestMax=INT(Ptr_Request%NbRequestMax*1.2)
	203	ALLOCATE(NewHallos(Ptr_Request%NbRequestMax))
	204	NewHallos(1:Ptr_Request%NbRequest-1)=Ptr_Request%hallo(1:Ptr_Request%NbRequest-1)
	205	HalloSwitch=>Ptr_Request%hallo
	206	Ptr_Request%hallo=>NewHallos
	207	DEALLOCATE(HalloSwitch)
	208	ENDIF
	209
	210	NewHallo=>Ptr_Request%hallo(Ptr_Request%NbRequest)
	211
[1632]	212	NewHallo%Field=>Field
	213	NewHallo%Stride=Stride
	214	NewHallo%NbLevel=NbLevel
	215	NewHallo%size=size
	216	NewHallo%offset=offset
	217
[1847]	218	end subroutine New_Hallo
[1632]	219
	220	subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
[1810]	221	USE dimensions_mod
[1632]	222	implicit none
	223
	224
	225	INTEGER :: ij,ll,offset,size,target
	226	REAL, dimension(ij,ll) :: Field
	227	type(request),target :: a_request
	228	type(request_SR),pointer :: Ptr_request
	229
	230	Ptr_Request=>a_request%RequestSend(target)
[1847]	231
	232	call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
[1632]	233
	234	end subroutine Register_SendField
	235
	236	subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
[1810]	237	USE dimensions_mod
[1632]	238	implicit none
	239
	240
	241	INTEGER :: ij,ll,offset,size,target
	242	REAL, dimension(ij,ll) :: Field
	243	type(request),target :: a_request
	244	type(request_SR),pointer :: Ptr_request
	245
	246	Ptr_Request=>a_request%RequestRecv(target)
	247
[1847]	248	call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
[1632]	249
	250
	251	end subroutine Register_RecvField
	252
	253	subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
[1810]	254	USE dimensions_mod
[1632]	255	implicit none
	256
	257
	258	INTEGER :: ij,ll
	259	REAL, dimension(ij,ll) :: FieldS
	260	REAL, dimension(ij,ll) :: FieldR
	261	type(request) :: a_request
	262	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	263	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	264
	265	integer ::i,jje,jjb
	266
	267	jj_begin_New(0)=1
	268	jj_End_New(0)=jj_Nb_New(0)
	269	do i=1,MPI_Size-1
	270	jj_begin_New(i)=jj_end_New(i-1)+1
	271	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	272	enddo
	273
	274	do i=0,MPI_Size-1
	275	if (i /= MPI_Rank) then
	276	jjb=max(jj_begin_new(i),jj_begin)
	277	jje=min(jj_end_new(i),jj_end)
	278
	279	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	280
	281	if (jje >= jjb) then
	282	call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
	283	endif
	284
	285	jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
	286	jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
	287
	288	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	289
	290	if (jje >= jjb) then
	291	call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
	292	endif
	293
	294	endif
	295	enddo
	296
	297	end subroutine Register_SwapField
	298
	299
	300
	301	subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
[1810]	302	USE dimensions_mod
[1632]	303
	304	implicit none
	305
	306	INTEGER :: ij,ll,Up,Down
	307	REAL, dimension(ij,ll) :: FieldS
	308	REAL, dimension(ij,ll) :: FieldR
	309	type(request) :: a_request
	310	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	311	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	312
	313	integer ::i,jje,jjb
	314
	315	jj_begin_New(0)=1
	316	jj_End_New(0)=jj_Nb_New(0)
	317	do i=1,MPI_Size-1
	318	jj_begin_New(i)=jj_end_New(i-1)+1
	319	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	320	enddo
	321
	322	do i=0,MPI_Size-1
	323	jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
	324	jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
	325	enddo
	326
	327	do i=0,MPI_Size-1
	328	if (i /= MPI_Rank) then
	329	jjb=max(jj_begin_new(i),jj_begin)
	330	jje=min(jj_end_new(i),jj_end)
	331
	332	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	333
	334	if (jje >= jjb) then
	335	call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
	336	endif
	337
	338	jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
	339	jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
	340
	341	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	342
	343	if (jje >= jjb) then
	344	call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
	345	endif
	346
	347	endif
	348	enddo
	349
	350	end subroutine Register_SwapFieldHallo
	351
	352
	353
	354	SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	355	USE parallel_lmdz
[1810]	356	USE dimensions_mod
[1632]	357	IMPLICIT NONE
	358
	359	REAL, DIMENSION(:),INTENT(IN) :: FieldS
	360	REAL, DIMENSION(:),INTENT(OUT) :: FieldR
	361	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	362	TYPE(distrib),INTENT(IN) :: new_dist
	363	INTEGER,OPTIONAL,INTENT(IN) :: up
	364	INTEGER,OPTIONAL,INTENT(IN) :: down
	365	TYPE(request),INTENT(INOUT) :: a_request
	366
	367	INTEGER :: halo_up
	368	INTEGER :: halo_down
	369
	370
	371	halo_up=0
	372	halo_down=0
	373	IF (PRESENT(up)) halo_up=up
	374	IF (PRESENT(down)) halo_down=down
	375
	376	IF (PRESENT(old_dist)) THEN
	377	CALL Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
	378	ELSE
	379	CALL Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
	380	ENDIF
	381
	382	END SUBROUTINE Register_SwapField1d_u
	383
	384
	385	SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	386	USE parallel_lmdz
[1810]	387	USE dimensions_mod
[1632]	388	IMPLICIT NONE
	389
	390	REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
	391	REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
	392	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	393	TYPE(distrib),INTENT(IN) :: new_dist
	394	INTEGER,OPTIONAL,INTENT(IN) :: up
	395	INTEGER,OPTIONAL,INTENT(IN) :: down
	396	TYPE(request),INTENT(INOUT) :: a_request
	397
	398	INTEGER :: halo_up
	399	INTEGER :: halo_down
	400	INTEGER :: ll
	401
	402
	403	halo_up=0
	404	halo_down=0
	405	IF (PRESENT(up)) halo_up=up
	406	IF (PRESENT(down)) halo_down=down
	407
	408	ll=size(FieldS,2)
	409
	410	IF (PRESENT(old_dist)) THEN
	411	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	412	ELSE
	413	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	414	ENDIF
	415
	416	END SUBROUTINE Register_SwapField2d_u1d
	417
	418
	419	SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	420	USE parallel_lmdz
[1810]	421	USE dimensions_mod
[1632]	422	IMPLICIT NONE
	423
	424	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
	425	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
	426	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	427	TYPE(distrib),INTENT(IN) :: new_dist
	428	INTEGER,OPTIONAL,INTENT(IN) :: up
	429	INTEGER,OPTIONAL,INTENT(IN) :: down
	430	TYPE(request),INTENT(INOUT) :: a_request
	431
	432	INTEGER :: halo_up
	433	INTEGER :: halo_down
	434	INTEGER :: ll
	435
	436
	437	halo_up=0
	438	halo_down=0
	439	IF (PRESENT(up)) halo_up=up
	440	IF (PRESENT(down)) halo_down=down
	441
	442	ll=size(FieldS,2)*size(FieldS,3)
	443
	444	IF (PRESENT(old_dist)) THEN
	445	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	446	ELSE
	447	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	448	ENDIF
	449
	450	END SUBROUTINE Register_SwapField3d_u
	451
	452
	453
	454	SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	455	USE parallel_lmdz
[1810]	456	USE dimensions_mod
[1632]	457
	458	IMPLICIT NONE
	459
	460	REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
	461	REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
	462	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	463	TYPE(distrib),OPTIONAL,INTENT(IN) :: new_dist !LF
	464	INTEGER,OPTIONAL,INTENT(IN) :: up
	465	INTEGER,OPTIONAL,INTENT(IN) :: down
	466	TYPE(request),INTENT(INOUT) :: a_request
	467
	468	INTEGER :: halo_up
	469	INTEGER :: halo_down
	470
	471
	472	halo_up=0
	473	halo_down=0
	474	IF (PRESENT(up)) halo_up=up
	475	IF (PRESENT(down)) halo_down=down
	476
	477	IF (PRESENT(old_dist)) THEN
	478	CALL Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
	479	ELSE
	480	CALL Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
	481	ENDIF
	482
	483	END SUBROUTINE Register_SwapField1d_u2d
	484
	485
	486	SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	487	USE parallel_lmdz
[1810]	488	USE dimensions_mod
[1632]	489
	490	IMPLICIT NONE
	491
	492	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
	493	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
	494	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	495	TYPE(distrib),INTENT(IN) :: new_dist
	496	INTEGER,OPTIONAL,INTENT(IN) :: up
	497	INTEGER,OPTIONAL,INTENT(IN) :: down
	498	TYPE(request),INTENT(INOUT) :: a_request
	499
	500	INTEGER :: halo_up
	501	INTEGER :: halo_down
	502	INTEGER :: ll
	503
	504
	505	halo_up=0
	506	halo_down=0
	507	IF (PRESENT(up)) halo_up=up
	508	IF (PRESENT(down)) halo_down=down
	509
	510	ll=size(FieldS,3)
	511
	512	IF (PRESENT(old_dist)) THEN
	513	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	514	ELSE
	515	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	516	ENDIF
	517
	518	END SUBROUTINE Register_SwapField2d_u2d
	519
	520
	521	SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	522	USE parallel_lmdz
[1810]	523	USE dimensions_mod
[1632]	524	IMPLICIT NONE
	525
	526	REAL, DIMENSION(:,:,:,:),INTENT(IN) :: FieldS
	527	REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: FieldR
	528	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	529	TYPE(distrib),INTENT(IN) :: new_dist
	530	INTEGER,OPTIONAL,INTENT(IN) :: up
	531	INTEGER,OPTIONAL,INTENT(IN) :: down
	532	TYPE(request),INTENT(INOUT) :: a_request
	533
	534	INTEGER :: halo_up
	535	INTEGER :: halo_down
	536	INTEGER :: ll
	537
	538
	539	halo_up=0
	540	halo_down=0
	541	IF (PRESENT(up)) halo_up=up
	542	IF (PRESENT(down)) halo_down=down
	543
	544	ll=size(FieldS,3)*size(FieldS,4)
	545
	546	IF (PRESENT(old_dist)) THEN
	547	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	548	ELSE
	549	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	550	ENDIF
	551
	552	END SUBROUTINE Register_SwapField3d_u2d
	553
	554
	555
	556
	557
	558
	559
	560	SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	561	USE parallel_lmdz
[1810]	562	USE dimensions_mod
[1632]	563	IMPLICIT NONE
	564
	565	REAL, DIMENSION(:),INTENT(IN) :: FieldS
	566	REAL, DIMENSION(:),INTENT(OUT) :: FieldR
	567	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	568	TYPE(distrib),INTENT(IN) :: new_dist
	569	INTEGER,OPTIONAL,INTENT(IN) :: up
	570	INTEGER,OPTIONAL,INTENT(IN) :: down
	571	TYPE(request),INTENT(INOUT) :: a_request
	572
	573	INTEGER :: halo_up
	574	INTEGER :: halo_down
	575
	576
	577	halo_up=0
	578	halo_down=0
	579	IF (PRESENT(up)) halo_up=up
	580	IF (PRESENT(down)) halo_down=down
	581
	582	IF (PRESENT(old_dist)) THEN
	583	CALL Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
	584	ELSE
	585	CALL Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
	586	ENDIF
	587
	588	END SUBROUTINE Register_SwapField1d_v
	589
	590
	591	SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	592	USE parallel_lmdz
[1810]	593	USE dimensions_mod
[1632]	594	IMPLICIT NONE
	595
	596	REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
	597	REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
	598	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	599	TYPE(distrib),INTENT(IN) :: new_dist
	600	INTEGER,OPTIONAL,INTENT(IN) :: up
	601	INTEGER,OPTIONAL,INTENT(IN) :: down
	602	TYPE(request),INTENT(INOUT) :: a_request
	603
	604	INTEGER :: halo_up
	605	INTEGER :: halo_down
	606	INTEGER :: ll
	607
	608
	609	halo_up=0
	610	halo_down=0
	611	IF (PRESENT(up)) halo_up=up
	612	IF (PRESENT(down)) halo_down=down
	613
	614	ll=size(FieldS,2)
	615
	616	IF (PRESENT(old_dist)) THEN
	617	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	618	ELSE
	619	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	620	ENDIF
	621
	622	END SUBROUTINE Register_SwapField2d_v1d
	623
	624
	625	SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	626	USE parallel_lmdz
[1810]	627	USE dimensions_mod
[1632]	628	IMPLICIT NONE
	629
	630	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
	631	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
	632	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	633	TYPE(distrib),INTENT(IN) :: new_dist
	634	INTEGER,OPTIONAL,INTENT(IN) :: up
	635	INTEGER,OPTIONAL,INTENT(IN) :: down
	636	TYPE(request),INTENT(INOUT) :: a_request
	637
	638	INTEGER :: halo_up
	639	INTEGER :: halo_down
	640	INTEGER :: ll
	641
	642
	643	halo_up=0
	644	halo_down=0
	645	IF (PRESENT(up)) halo_up=up
	646	IF (PRESENT(down)) halo_down=down
	647
	648	ll=size(FieldS,2)*size(FieldS,3)
	649
	650	IF (PRESENT(old_dist)) THEN
	651	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	652	ELSE
	653	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	654	ENDIF
	655
	656	END SUBROUTINE Register_SwapField3d_v
	657
	658
	659
	660
	661	SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	662	USE parallel_lmdz
[1810]	663	USE dimensions_mod
[1632]	664	IMPLICIT NONE
	665
	666	REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
	667	REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
	668	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	669	TYPE(distrib),OPTIONAL,INTENT(IN) :: new_dist !LF
	670	INTEGER,OPTIONAL,INTENT(IN) :: up
	671	INTEGER,OPTIONAL,INTENT(IN) :: down
	672	TYPE(request),INTENT(INOUT) :: a_request
	673
	674	INTEGER :: halo_up
	675	INTEGER :: halo_down
	676
	677
	678	halo_up=0
	679	halo_down=0
	680	IF (PRESENT(up)) halo_up=up
	681	IF (PRESENT(down)) halo_down=down
	682
	683	IF (PRESENT(old_dist)) THEN
	684	CALL Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
	685	ELSE
	686	CALL Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
	687	ENDIF
	688
	689	END SUBROUTINE Register_SwapField1d_v2d
	690
	691
	692	SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	693	USE parallel_lmdz
[1810]	694	USE dimensions_mod
[1632]	695	IMPLICIT NONE
	696
	697	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
	698	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
	699	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	700	TYPE(distrib),INTENT(IN) :: new_dist
	701	INTEGER,OPTIONAL,INTENT(IN) :: up
	702	INTEGER,OPTIONAL,INTENT(IN) :: down
	703	TYPE(request),INTENT(INOUT) :: a_request
	704
	705	INTEGER :: halo_up
	706	INTEGER :: halo_down
	707	INTEGER :: ll
	708
	709
	710	halo_up=0
	711	halo_down=0
	712	IF (PRESENT(up)) halo_up=up
	713	IF (PRESENT(down)) halo_down=down
	714
	715	ll=size(FieldS,3)
	716
	717	IF (PRESENT(old_dist)) THEN
	718	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	719	ELSE
	720	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	721	ENDIF
	722
	723	END SUBROUTINE Register_SwapField2d_v2d
	724
	725
	726	SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
[1823]	727	USE parallel_lmdz
[1810]	728	USE dimensions_mod
[1632]	729	IMPLICIT NONE
	730
	731	REAL, DIMENSION(:,:,:,:),INTENT(IN) :: FieldS
	732	REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: FieldR
	733	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
	734	TYPE(distrib),INTENT(IN) :: new_dist
	735	INTEGER,OPTIONAL,INTENT(IN) :: up
	736	INTEGER,OPTIONAL,INTENT(IN) :: down
	737	TYPE(request),INTENT(INOUT) :: a_request
	738
	739	INTEGER :: halo_up
	740	INTEGER :: halo_down
	741	INTEGER :: ll
	742
	743
	744	halo_up=0
	745	halo_down=0
	746	IF (PRESENT(up)) halo_up=up
	747	IF (PRESENT(down)) halo_down=down
	748
	749	ll=size(FieldS,3)*size(FieldS,4)
	750
	751	IF (PRESENT(old_dist)) THEN
	752	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
	753	ELSE
	754	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
	755	ENDIF
	756
	757	END SUBROUTINE Register_SwapField3d_v2d
	758
	759
	760
	761	SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
[1823]	762	USE parallel_lmdz
[1810]	763	USE dimensions_mod
[1632]	764	IMPLICIT NONE
	765
	766	INTEGER :: ll,Up,Down
	767	TYPE(distrib) :: old_dist
	768	TYPE(distrib) :: new_dist
	769	REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
	770	REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
	771	TYPE(request) :: a_request
	772	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
	773	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	774
	775	INTEGER ::i,l,jje,jjb,ijb,ije
	776
	777	DO i=0,MPI_Size-1
	778	jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
	779	jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
	780	ENDDO
	781
	782	DO i=0,MPI_Size-1
	783	IF (i /= MPI_Rank) THEN
	784	jjb=max(jj_begin_new(i),old_dist%jj_begin)
	785	jje=min(jj_end_new(i),old_dist%jj_end)
	786
	787	IF (jje >= jjb) THEN
	788	CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request)
	789	ENDIF
	790
	791	jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
	792	jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
	793
	794	IF (jje >= jjb) THEN
	795	CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request)
	796	ENDIF
	797	ELSE
	798	jjb=max(jj_begin_new(i),old_dist%jj_begin)
	799	jje=min(jj_end_new(i),old_dist%jj_end)
	800	ijb=(jjb-1)*iip1+1
	801	ije=jje*iip1
	802	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	803	DO l=1,ll
[1803]	804	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
[1632]	805	ENDDO
	806	!$OMP END DO NOWAIT
	807	ENDIF
	808	ENDDO
	809
	810	END SUBROUTINE Register_SwapField_gen_u
	811
	812
	813
	814	SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
[1823]	815	USE parallel_lmdz
[1810]	816	USE dimensions_mod
[1632]	817	IMPLICIT NONE
	818
	819	INTEGER :: ll,Up,Down
	820	TYPE(distrib) :: old_dist
	821	TYPE(distrib) :: new_dist
	822	REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
	823	REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
	824	TYPE(request) :: a_request
	825	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
	826	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	827
	828	INTEGER ::i,l,jje,jjb,ijb,ije
	829
	830	DO i=0,MPI_Size-1
	831	jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
	832	jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
	833	ENDDO
	834
	835	DO i=0,MPI_Size-1
	836	IF (i /= MPI_Rank) THEN
	837	jjb=max(jj_begin_new(i),old_dist%jj_begin)
	838	jje=min(jj_end_new(i),old_dist%jj_end)
	839
	840	IF (jje==jjp1) jje=jjm
	841
	842	IF (jje >= jjb) THEN
	843	CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request)
	844	ENDIF
	845
	846	jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
	847	jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
	848
	849	IF (jje==jjp1) jje=jjm
	850
	851	IF (jje >= jjb) THEN
	852	CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request)
	853	ENDIF
	854	ELSE
	855	jjb=max(jj_begin_new(i),old_dist%jj_begin)
	856	jje=min(jj_end_new(i),old_dist%jj_end)
	857	IF (jje==jjp1) jje=jjm
	858	ijb=(jjb-1)*iip1+1
	859	ije=jje*iip1
	860	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	861	DO l=1,ll
	862	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
	863	ENDDO
	864	!$OMP END DO NOWAIT
	865	ENDIF
	866	ENDDO
	867
	868	END SUBROUTINE Register_SwapField_gen_v
	869
	870
	871
	872
	873
	874	subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
[1810]	875	USE dimensions_mod
[1632]	876	implicit none
	877
	878	#ifdef CPP_MPI
	879	include 'mpif.h'
	880	#endif
	881	INTEGER :: ij,ll
	882	REAL, dimension(ij,ll) :: Field
	883	INTEGER :: Sup,Sdown,rup,rdown
	884	type(request) :: a_request
	885	type(Hallo),pointer :: PtrHallo
	886	LOGICAL :: SendUp,SendDown
	887	LOGICAL :: RecvUp,RecvDown
	888
	889
	890	SendUp=.TRUE.
	891	SendDown=.TRUE.
	892	RecvUp=.TRUE.
	893	RecvDown=.TRUE.
	894
	895	IF (pole_nord) THEN
	896	SendUp=.FALSE.
	897	RecvUp=.FALSE.
	898	ENDIF
	899
	900	IF (pole_sud) THEN
	901	SendDown=.FALSE.
	902	RecvDown=.FALSE.
	903	ENDIF
	904
	905	if (Sup.eq.0) then
	906	SendUp=.FALSE.
	907	endif
	908
	909	if (Sdown.eq.0) then
	910	SendDown=.FALSE.
	911	endif
	912
	913	if (Rup.eq.0) then
	914	RecvUp=.FALSE.
	915	endif
	916
	917	if (Rdown.eq.0) then
	918	RecvDown=.FALSE.
	919	endif
	920
	921	IF (SendUp) THEN
	922	call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
	923	ENDIF
	924
	925	IF (SendDown) THEN
	926	call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
	927	ENDIF
	928
	929
	930	IF (RecvUp) THEN
	931	call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
	932	ENDIF
	933
	934	IF (RecvDown) THEN
	935	call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
	936	ENDIF
	937
	938	end subroutine Register_Hallo
	939
	940
	941	subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
[1810]	942	USE dimensions_mod
[1632]	943	implicit none
	944	#ifdef CPP_MPI
	945	include 'mpif.h'
	946	#endif
	947	INTEGER :: ll
	948	REAL, dimension(ijb_u:ije_u,ll) :: Field
	949	INTEGER :: Sup,Sdown,rup,rdown
	950	type(request) :: a_request
	951	type(Hallo),pointer :: PtrHallo
	952	LOGICAL :: SendUp,SendDown
	953	LOGICAL :: RecvUp,RecvDown
	954
	955
	956	SendUp=.TRUE.
	957	SendDown=.TRUE.
	958	RecvUp=.TRUE.
	959	RecvDown=.TRUE.
	960
	961	IF (pole_nord) THEN
	962	SendUp=.FALSE.
	963	RecvUp=.FALSE.
	964	ENDIF
	965
	966	IF (pole_sud) THEN
	967	SendDown=.FALSE.
	968	RecvDown=.FALSE.
	969	ENDIF
	970
	971	if (Sup.eq.0) then
	972	SendUp=.FALSE.
	973	endif
	974
	975	if (Sdown.eq.0) then
	976	SendDown=.FALSE.
	977	endif
	978
	979	if (Rup.eq.0) then
	980	RecvUp=.FALSE.
	981	endif
	982
	983	if (Rdown.eq.0) then
	984	RecvDown=.FALSE.
	985	endif
	986
	987	IF (SendUp) THEN
	988	call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
	989	ENDIF
	990
	991	IF (SendDown) THEN
	992	call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
	993	ENDIF
	994
	995
	996	IF (RecvUp) THEN
	997	call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
	998	ENDIF
	999
	1000	IF (RecvDown) THEN
	1001	call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
	1002	ENDIF
	1003
	1004	end subroutine Register_Hallo_u
	1005
	1006	subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
[1810]	1007	USE dimensions_mod
[1632]	1008	implicit none
	1009	#ifdef CPP_MPI
	1010	include 'mpif.h'
	1011	#endif
	1012	INTEGER :: ll
	1013	REAL, dimension(ijb_v:ije_v,ll) :: Field
	1014	INTEGER :: Sup,Sdown,rup,rdown
	1015	type(request) :: a_request
	1016	type(Hallo),pointer :: PtrHallo
	1017	LOGICAL :: SendUp,SendDown
	1018	LOGICAL :: RecvUp,RecvDown
	1019
	1020
	1021	SendUp=.TRUE.
	1022	SendDown=.TRUE.
	1023	RecvUp=.TRUE.
	1024	RecvDown=.TRUE.
	1025
	1026	IF (pole_nord) THEN
	1027	SendUp=.FALSE.
	1028	RecvUp=.FALSE.
	1029	ENDIF
	1030
	1031	IF (pole_sud) THEN
	1032	SendDown=.FALSE.
	1033	RecvDown=.FALSE.
	1034	ENDIF
	1035
	1036	if (Sup.eq.0) then
	1037	SendUp=.FALSE.
	1038	endif
	1039
	1040	if (Sdown.eq.0) then
	1041	SendDown=.FALSE.
	1042	endif
	1043
	1044	if (Rup.eq.0) then
	1045	RecvUp=.FALSE.
	1046	endif
	1047
	1048	if (Rdown.eq.0) then
	1049	RecvDown=.FALSE.
	1050	endif
	1051
	1052	IF (SendUp) THEN
	1053	call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
	1054	ENDIF
	1055
	1056	IF (SendDown) THEN
	1057	call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
	1058	ENDIF
	1059
	1060
	1061	IF (RecvUp) THEN
	1062	call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
	1063	ENDIF
	1064
	1065	IF (RecvDown) THEN
	1066	call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
	1067	ENDIF
	1068
	1069	end subroutine Register_Hallo_v
	1070
	1071	subroutine SendRequest(a_Request)
[1810]	1072	USE dimensions_mod
[1632]	1073	implicit none
	1074
	1075	#ifdef CPP_MPI
	1076	include 'mpif.h'
	1077	#endif
	1078
	1079	type(request),target :: a_request
	1080	type(request_SR),pointer :: Req
	1081	type(Hallo),pointer :: PtrHallo
	1082	integer :: SizeBuffer
	1083	integer :: i,rank,l,ij,Pos,ierr
	1084	integer :: offset
	1085	real,dimension(:,:),pointer :: Field
	1086	integer :: Nb
	1087
	1088	do rank=0,MPI_SIZE-1
	1089
	1090	Req=>a_Request%RequestSend(rank)
	1091
	1092	SizeBuffer=0
	1093	do i=1,Req%NbRequest
	1094	PtrHallo=>Req%Hallo(i)
	1095	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1096	DO l=1,PtrHallo%NbLevel
	1097	SizeBuffer=SizeBuffer+PtrHallo%size*iip1
	1098	ENDDO
	1099	!$OMP ENDDO NOWAIT
	1100	enddo
	1101
	1102	Req%BufferSize=SizeBuffer
	1103	if (Req%NbRequest>0) then
	1104
	1105	call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
	1106
	1107	Pos=Req%Pos
	1108	do i=1,Req%NbRequest
	1109	PtrHallo=>Req%Hallo(i)
	1110	offset=(PtrHallo%offset-1)*iip1+1
	1111	Nb=iip1*PtrHallo%size-1
	1112	Field=>PtrHallo%Field
	1113
	1114	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1115	do l=1,PtrHallo%NbLevel
	1116	!cdir NODEP
	1117	do ij=0,Nb
	1118	Buffer(Pos+ij)=Field(Offset+ij,l)
	1119	enddo
	1120
	1121	Pos=Pos+Nb+1
	1122	enddo
	1123	!$OMP END DO NOWAIT
	1124	enddo
	1125
	1126	if (SizeBuffer>0) then
	1127	!$OMP CRITICAL (MPI)
	1128
	1129	#ifdef CPP_MPI
	1130	call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, &
	1131	COMM_LMDZ,Req%MSG_Request,ierr)
	1132	#endif
	1133	IF (.NOT.using_mpi) THEN
	1134	PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
	1135	STOP
	1136	ENDIF
	1137	! PRINT *,"-------------------------------------------------------------------"
	1138	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
	1139	! PRINT ,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000omp_rank
	1140	! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
	1141	! PRINT *,"-------------------------------------------------------------------"
	1142	!$OMP END CRITICAL (MPI)
	1143	endif
	1144	endif
	1145	enddo
	1146
	1147
	1148	do rank=0,MPI_SIZE-1
	1149
	1150	Req=>a_Request%RequestRecv(rank)
	1151	SizeBuffer=0
	1152
	1153	do i=1,Req%NbRequest
	1154	PtrHallo=>Req%Hallo(i)
	1155
	1156	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1157	DO l=1,PtrHallo%NbLevel
	1158	SizeBuffer=SizeBuffer+PtrHallo%size*iip1
	1159	ENDDO
	1160	!$OMP ENDDO NOWAIT
	1161	enddo
	1162
	1163	Req%BufferSize=SizeBuffer
	1164
	1165	if (Req%NbRequest>0) then
	1166	call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
	1167
	1168	if (SizeBuffer>0) then
	1169
	1170	!$OMP CRITICAL (MPI)
	1171
	1172	#ifdef CPP_MPI
	1173	call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, &
	1174	COMM_LMDZ,Req%MSG_Request,ierr)
	1175	#endif
	1176	IF (.NOT.using_mpi) THEN
	1177	PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
	1178	STOP
	1179	ENDIF
	1180
	1181	! PRINT *,"-------------------------------------------------------------------"
	1182	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
	1183	! PRINT ,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000omp_rank
	1184	! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
	1185	! PRINT *,"-------------------------------------------------------------------"
	1186
	1187	!$OMP END CRITICAL (MPI)
	1188	endif
	1189	endif
	1190
	1191	enddo
	1192
	1193	end subroutine SendRequest
	1194
	1195	subroutine WaitRequest(a_Request)
[1810]	1196	USE dimensions_mod
[1632]	1197	implicit none
	1198
	1199	#ifdef CPP_MPI
	1200	include 'mpif.h'
	1201	#endif
	1202
	1203	type(request),target :: a_request
	1204	type(request_SR),pointer :: Req
	1205	type(Hallo),pointer :: PtrHallo
	1206	integer, dimension(2*mpi_size) :: TabRequest
	1207	#ifdef CPP_MPI
	1208	integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
	1209	#else
	1210	integer, dimension(1,2*mpi_size) :: TabStatus
	1211	#endif
	1212	integer :: NbRequest
	1213	integer :: i,rank,pos,ij,l,ierr
	1214	integer :: offset
	1215	integer :: Nb
	1216
	1217
	1218	NbRequest=0
	1219	do rank=0,MPI_SIZE-1
	1220	Req=>a_request%RequestSend(rank)
	1221	if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
	1222	NbRequest=NbRequest+1
	1223	TabRequest(NbRequest)=Req%MSG_Request
	1224	endif
	1225	enddo
	1226
	1227	do rank=0,MPI_SIZE-1
	1228	Req=>a_request%RequestRecv(rank)
	1229	if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
	1230	NbRequest=NbRequest+1
	1231	TabRequest(NbRequest)=Req%MSG_Request
	1232	endif
	1233	enddo
	1234
	1235	if (NbRequest>0) then
	1236	!$OMP CRITICAL (MPI)
	1237	! PRINT *,"-------------------------------------------------------------------"
	1238	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
	1239	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
	1240	#ifdef CPP_MPI
	1241	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
	1242	#endif
	1243	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
	1244	! PRINT *,"-------------------------------------------------------------------"
	1245	!$OMP END CRITICAL (MPI)
	1246	endif
	1247	do rank=0,MPI_Size-1
	1248	Req=>a_request%RequestRecv(rank)
	1249	if (Req%NbRequest>0) then
	1250	Pos=Req%Pos
	1251	do i=1,Req%NbRequest
	1252	PtrHallo=>Req%Hallo(i)
	1253	offset=(PtrHallo%offset-1)*iip1+1
	1254	Nb=iip1*PtrHallo%size-1
	1255
	1256	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1257	do l=1,PtrHallo%NbLevel
	1258	!cdir NODEP
	1259	do ij=0,Nb
	1260	PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
	1261	enddo
	1262
	1263	Pos=Pos+Nb+1
	1264	enddo
	1265	!$OMP ENDDO NOWAIT
	1266	enddo
	1267	endif
	1268	enddo
	1269
	1270	do rank=0,MPI_SIZE-1
	1271	Req=>a_request%RequestSend(rank)
	1272	if (Req%NbRequest>0) then
	1273	call deallocate_buffer(Req%Index)
	1274	Req%NbRequest=0
	1275	endif
	1276	enddo
	1277
	1278	do rank=0,MPI_SIZE-1
	1279	Req=>a_request%RequestRecv(rank)
	1280	if (Req%NbRequest>0) then
	1281	call deallocate_buffer(Req%Index)
	1282	Req%NbRequest=0
	1283	endif
	1284	enddo
	1285
	1286	a_request%tag=1
	1287	end subroutine WaitRequest
	1288
	1289	subroutine WaitSendRequest(a_Request)
[1810]	1290	USE dimensions_mod
[1632]	1291	implicit none
	1292
	1293	#ifdef CPP_MPI
	1294	include 'mpif.h'
	1295	#endif
	1296	type(request),target :: a_request
	1297	type(request_SR),pointer :: Req
	1298	type(Hallo),pointer :: PtrHallo
	1299	integer, dimension(mpi_size) :: TabRequest
	1300	#ifdef CPP_MPI
	1301	integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
	1302	#else
	1303	integer, dimension(1,mpi_size) :: TabStatus
	1304	#endif
	1305	integer :: NbRequest
	1306	integer :: i,rank,pos,ij,l,ierr
	1307	integer :: offset
	1308
	1309
	1310	NbRequest=0
	1311	do rank=0,MPI_SIZE-1
	1312	Req=>a_request%RequestSend(rank)
	1313	if (Req%NbRequest>0) then
	1314	NbRequest=NbRequest+1
	1315	TabRequest(NbRequest)=Req%MSG_Request
	1316	endif
	1317	enddo
	1318
	1319
	1320	if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
	1321	!$OMP CRITICAL (MPI)
	1322	! PRINT *,"-------------------------------------------------------------------"
	1323	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
	1324	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
	1325	#ifdef CPP_MPI
	1326	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
	1327	#endif
	1328	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
	1329	! PRINT *,"-------------------------------------------------------------------"
	1330
	1331	!$OMP END CRITICAL (MPI)
	1332	endif
	1333
	1334	do rank=0,MPI_SIZE-1
	1335	Req=>a_request%RequestSend(rank)
	1336	if (Req%NbRequest>0) then
	1337	call deallocate_buffer(Req%Index)
	1338	Req%NbRequest=0
	1339	endif
	1340	enddo
	1341
	1342	a_request%tag=1
	1343	end subroutine WaitSendRequest
	1344
	1345	subroutine WaitRecvRequest(a_Request)
[1810]	1346	USE dimensions_mod
[1632]	1347	implicit none
	1348
	1349	#ifdef CPP_MPI
	1350	include 'mpif.h'
	1351	#endif
	1352
	1353	type(request),target :: a_request
	1354	type(request_SR),pointer :: Req
	1355	type(Hallo),pointer :: PtrHallo
	1356	integer, dimension(mpi_size) :: TabRequest
	1357	#ifdef CPP_MPI
	1358	integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
	1359	#else
	1360	integer, dimension(1,mpi_size) :: TabStatus
	1361	#endif
	1362	integer :: NbRequest
	1363	integer :: i,rank,pos,ij,l,ierr
	1364	integer :: offset,Nb
	1365
	1366
	1367	NbRequest=0
	1368
	1369	do rank=0,MPI_SIZE-1
	1370	Req=>a_request%RequestRecv(rank)
	1371	if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
	1372	NbRequest=NbRequest+1
	1373	TabRequest(NbRequest)=Req%MSG_Request
	1374	endif
	1375	enddo
	1376
	1377
	1378	if (NbRequest>0) then
	1379	!$OMP CRITICAL (MPI)
	1380	! PRINT *,"-------------------------------------------------------------------"
	1381	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
	1382	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
	1383	#ifdef CPP_MPI
	1384	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
	1385	#endif
	1386	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
	1387	! PRINT *,"-------------------------------------------------------------------"
	1388	!$OMP END CRITICAL (MPI)
	1389	endif
	1390
	1391	do rank=0,MPI_Size-1
	1392	Req=>a_request%RequestRecv(rank)
	1393	if (Req%NbRequest>0) then
	1394	Pos=Req%Pos
	1395	do i=1,Req%NbRequest
	1396	PtrHallo=>Req%Hallo(i)
	1397	offset=(PtrHallo%offset-1)*iip1+1
	1398	Nb=iip1*PtrHallo%size-1
	1399	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1400	do l=1,PtrHallo%NbLevel
	1401	!cdir NODEP
	1402	do ij=0,Nb
	1403	PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
	1404	enddo
	1405	Pos=Pos+Nb+1
	1406	enddo
	1407	!$OMP END DO NOWAIT
	1408	enddo
	1409	endif
	1410	enddo
	1411
	1412
	1413	do rank=0,MPI_SIZE-1
	1414	Req=>a_request%RequestRecv(rank)
	1415	if (Req%NbRequest>0) then
	1416	call deallocate_buffer(Req%Index)
	1417	Req%NbRequest=0
	1418	endif
	1419	enddo
	1420
	1421	a_request%tag=1
	1422	end subroutine WaitRecvRequest
	1423
	1424
	1425
	1426	subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
[1810]	1427	USE dimensions_mod
[1632]	1428
	1429	implicit none
	1430
	1431	INTEGER :: ij,ll,l
	1432	REAL, dimension(ij,ll) :: FieldS
	1433	REAL, dimension(ij,ll) :: FieldR
	1434	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	1435	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	1436
	1437	integer ::i,jje,jjb,ijb,ije
	1438
	1439	jj_begin_New(0)=1
	1440	jj_End_New(0)=jj_Nb_New(0)
	1441	do i=1,MPI_Size-1
	1442	jj_begin_New(i)=jj_end_New(i-1)+1
	1443	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	1444	enddo
	1445
	1446	jjb=max(jj_begin,jj_begin_new(MPI_Rank))
	1447	jje=min(jj_end,jj_end_new(MPI_Rank))
	1448	if (ij==ip1jm) jje=min(jje,jjm)
	1449
	1450	if (jje >= jjb) then
	1451	ijb=(jjb-1)*iip1+1
	1452	ije=jje*iip1
	1453
	1454	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1455	do l=1,ll
	1456	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
	1457	enddo
	1458	!$OMP ENDDO NOWAIT
	1459	endif
	1460
	1461
	1462	end subroutine CopyField
	1463
	1464	subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
[1810]	1465	USE dimensions_mod
[1632]	1466
	1467	implicit none
	1468
	1469	INTEGER :: ij,ll,Up,Down
	1470	REAL, dimension(ij,ll) :: FieldS
	1471	REAL, dimension(ij,ll) :: FieldR
	1472	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	1473	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	1474
	1475	integer ::i,jje,jjb,ijb,ije,l
	1476
	1477
	1478	jj_begin_New(0)=1
	1479	jj_End_New(0)=jj_Nb_New(0)
	1480	do i=1,MPI_Size-1
	1481	jj_begin_New(i)=jj_end_New(i-1)+1
	1482	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	1483	enddo
	1484
	1485
	1486	jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
	1487	jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
	1488	if (ij==ip1jm) jje=min(jje,jjm)
	1489
	1490
	1491	if (jje >= jjb) then
	1492	ijb=(jjb-1)*iip1+1
	1493	ije=jje*iip1
	1494
	1495	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1496	do l=1,ll
	1497	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
	1498	enddo
	1499	!$OMP ENDDO NOWAIT
	1500
	1501	endif
	1502	end subroutine CopyFieldHallo
	1503
	1504	subroutine Gather_field_u(field_loc,field_glo,ll)
[1810]	1505	USE dimensions_mod
[1632]	1506	implicit none
	1507	integer :: ll
	1508	real :: field_loc(ijb_u:ije_u,ll)
	1509	real :: field_glo(ip1jmp1,ll)
	1510	type(request) :: request_gather
	1511	integer :: l
	1512
	1513
	1514	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1515	DO l=1,ll
	1516	field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
	1517	ENDDO
	1518
	1519	call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
	1520	call SendRequest(request_gather)
	1521	!$OMP BARRIER
	1522	call WaitRequest(request_gather)
	1523	!$OMP BARRIER
	1524
	1525	end subroutine Gather_field_u
	1526
	1527	subroutine Gather_field_v(field_loc,field_glo,ll)
[1810]	1528	USE dimensions_mod
[1632]	1529	implicit none
	1530	integer :: ll
	1531	real :: field_loc(ijb_v:ije_v,ll)
	1532	real :: field_glo(ip1jm,ll)
	1533	type(request) :: request_gather
	1534	integer :: ijb,ije
	1535	integer :: l
	1536
	1537
	1538	ijb=ij_begin
	1539	ije=ij_end
	1540	if (pole_sud) ije=ij_end-iip1
	1541
	1542	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1543	DO l=1,ll
	1544	field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
	1545	ENDDO
	1546
	1547	call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
	1548	call SendRequest(request_gather)
	1549	!$OMP BARRIER
	1550	call WaitRequest(request_gather)
	1551	!$OMP BARRIER
	1552
	1553	end subroutine Gather_field_v
	1554
	1555	subroutine Scatter_field_u(field_glo,field_loc,ll)
[1810]	1556	USE dimensions_mod
[1632]	1557	implicit none
	1558	integer :: ll
	1559	real :: field_glo(ip1jmp1,ll)
	1560	real :: field_loc(ijb_u:ije_u,ll)
	1561	type(request) :: request_gather
	1562	TYPE(distrib) :: distrib_swap
	1563	integer :: l
	1564
	1565	!$OMP BARRIER
	1566	!$OMP MASTER
	1567	call get_current_distrib(distrib_swap)
	1568	call set_Distrib(distrib_gather)
	1569	!$OMP END MASTER
	1570	!$OMP BARRIER
	1571
	1572	call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
	1573	call SendRequest(request_gather)
	1574	!$OMP BARRIER
	1575	call WaitRequest(request_gather)
	1576	!$OMP BARRIER
	1577	!$OMP MASTER
	1578	call set_Distrib(distrib_swap)
	1579	!$OMP END MASTER
	1580	!$OMP BARRIER
	1581
	1582	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1583	DO l=1,ll
	1584	field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
	1585	ENDDO
	1586
	1587	end subroutine Scatter_field_u
	1588
	1589	subroutine Scatter_field_v(field_glo,field_loc,ll)
[1810]	1590	USE dimensions_mod
[1632]	1591	implicit none
	1592	integer :: ll
	1593	real :: field_glo(ip1jmp1,ll)
	1594	real :: field_loc(ijb_v:ije_v,ll)
	1595	type(request) :: request_gather
	1596	TYPE(distrib) :: distrib_swap
	1597	integer :: ijb,ije,l
	1598
	1599
	1600	!$OMP BARRIER
	1601	!$OMP MASTER
	1602	call get_current_distrib(distrib_swap)
	1603	call set_Distrib(distrib_gather)
	1604	!$OMP END MASTER
	1605	!$OMP BARRIER
	1606	call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
	1607	call SendRequest(request_gather)
	1608	!$OMP BARRIER
	1609	call WaitRequest(request_gather)
	1610	!$OMP BARRIER
	1611	!$OMP MASTER
	1612	call set_Distrib(distrib_swap)
	1613	!$OMP END MASTER
	1614	!$OMP BARRIER
	1615	ijb=ij_begin
	1616	ije=ij_end
	1617	if (pole_sud) ije=ij_end-iip1
	1618
	1619	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1620	DO l=1,ll
	1621	field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
	1622	ENDDO
	1623
	1624	end subroutine Scatter_field_v
	1625
	1626	end module mod_Hallo
	1627

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

Download in other formats:

Original Format