Context Navigation

parallel_lmdz.F90 @ 5282

Last change on this file since 5282 was 5282, checked in by abarral, 6 hours ago
Turn iniprint.h clesphys.h into modules Remove unused description.h
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: 21.7 KB

Line
1	!
2	! $Id$
3	!
4	MODULE parallel_lmdz
5	USE mod_const_mpi
6	USE lmdz_mpi, ONLY : using_mpi
7	use IOIPSL
8
9	INTEGER,PARAMETER :: halo_max=3
10
11	LOGICAL,SAVE :: using_omp ! .true. if using OpenMP
12	LOGICAL,SAVE :: is_master ! .true. if the core is both MPI & OpenMP master
13	!$OMP THREADPRIVATE(is_master)
14
15	integer, save :: mpi_size
16	integer, save :: mpi_rank
17	integer, save :: jj_begin
18	integer, save :: jj_end
19	integer, save :: jj_nb
20	integer, save :: ij_begin
21	integer, save :: ij_end
22	logical, save :: pole_nord
23	logical, save :: pole_sud
24
25	integer,save :: jjb_u
26	integer,save :: jje_u
27	integer,save :: jjnb_u
28	integer,save :: jjb_v
29	integer,save :: jje_v
30	integer,save :: jjnb_v
31
32	integer,save :: ijb_u
33	integer,save :: ije_u
34	integer,save :: ijnb_u
35
36	integer,save :: ijb_v
37	integer,save :: ije_v
38	integer,save :: ijnb_v
39
40
41	integer, allocatable, save, dimension(:) :: jj_begin_para
42	integer, allocatable, save, dimension(:) :: jj_end_para
43	integer, allocatable, save, dimension(:) :: jj_nb_para
44	integer, save :: OMP_CHUNK
45	integer, save :: omp_rank
46	integer, save :: omp_size
47	!$OMP THREADPRIVATE(omp_rank)
48
49	TYPE distrib
50	integer :: jj_begin
51	integer :: jj_end
52	integer :: jj_nb
53	integer :: ij_begin
54	integer :: ij_end
55
56	integer :: jjb_u
57	integer :: jje_u
58	integer :: jjnb_u
59	integer :: jjb_v
60	integer :: jje_v
61	integer :: jjnb_v
62
63	integer :: ijb_u
64	integer :: ije_u
65	integer :: ijnb_u
66
67	integer :: ijb_v
68	integer :: ije_v
69	integer :: ijnb_v
70
71
72	integer, pointer :: jj_begin_para(:) => NULL()
73	integer, pointer :: jj_end_para(:) => NULL()
74	integer, pointer :: jj_nb_para(:) => NULL()
75	END TYPE distrib
76
77	INTERFACE ASSIGNMENT (=)
78	MODULE PROCEDURE copy_distrib
79	END INTERFACE
80	TYPE(distrib),SAVE :: current_dist
81
82	contains
83
84	subroutine init_parallel
85	USE iniprint_mod_h
86	USE vampir
87	USE lmdz_mpi
88	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
89	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
90	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
91	implicit none
92
93
94
95	integer :: ierr
96	integer :: i,j
97	integer :: type_size
98	integer, dimension(3) :: blocklen,type
99	integer :: comp_id
100	character(len=4) :: num
101	character(len=20) :: filename
102
103	#ifdef CPP_OMP
104	INTEGER :: OMP_GET_NUM_THREADS
105	EXTERNAL OMP_GET_NUM_THREADS
106	INTEGER :: OMP_GET_THREAD_NUM
107	EXTERNAL OMP_GET_THREAD_NUM
108	#endif
109
110	#ifdef CPP_OMP
111	using_OMP=.TRUE.
112	#else
113	using_OMP=.FALSE.
114	#endif
115
116	call InitVampir
117
118	IF (using_mpi) THEN
119	call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
120	call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
121	ELSE
122	mpi_size=1
123	mpi_rank=0
124	ENDIF
125
126
127	! Open text output file with mpi_rank in suffix of file name
128	IF (lunout /= 5 .and. lunout /= 6) THEN
129	WRITE(num,'(I4.4)') mpi_rank
130	filename='lmdz.out_'//num
131	IF (mpi_rank .NE. 0) THEN
132	OPEN(UNIT=lunout,FILE=TRIM(filename),ACTION='write', &
133	STATUS='unknown',FORM='formatted',IOSTAT=ierr)
134	ENDIF
135	ENDIF
136
137
138	allocate(jj_begin_para(0:mpi_size-1))
139	allocate(jj_end_para(0:mpi_size-1))
140	allocate(jj_nb_para(0:mpi_size-1))
141
142	do i=0,mpi_size-1
143	jj_nb_para(i)=(jjm+1)/mpi_size
144	if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
145
146	if (jj_nb_para(i) <= 1 ) then
147
148	write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
149	write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
150
151	IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
152
153	endif
154
155	enddo
156
157	! jj_nb_para(0)=11
158	! jj_nb_para(1)=25
159	! jj_nb_para(2)=25
160	! jj_nb_para(3)=12
161
162	j=1
163
164	do i=0,mpi_size-1
165
166	jj_begin_para(i)=j
167	jj_end_para(i)=j+jj_Nb_para(i)-1
168	j=j+jj_Nb_para(i)
169
170	enddo
171
172	jj_begin = jj_begin_para(mpi_rank)
173	jj_end = jj_end_para(mpi_rank)
174	jj_nb = jj_nb_para(mpi_rank)
175
176	ij_begin=(jj_begin-1)*iip1+1
177	ij_end=jj_end*iip1
178
179	if (mpi_rank.eq.0) then
180	pole_nord=.TRUE.
181	else
182	pole_nord=.FALSE.
183	endif
184
185	if (mpi_rank.eq.mpi_size-1) then
186	pole_sud=.TRUE.
187	else
188	pole_sud=.FALSE.
189	endif
190
191	write(lunout,*)"init_parallel: jj_begin",jj_begin
192	write(lunout,*)"init_parallel: jj_end",jj_end
193	write(lunout,*)"init_parallel: ij_begin",ij_begin
194	write(lunout,*)"init_parallel: ij_end",ij_end
195	jjb_u=MAX(jj_begin-halo_max,1)
196	jje_u=MIN(jj_end+halo_max,jjp1)
197	jjnb_u=jje_u-jjb_u+1
198
199	jjb_v=MAX(jj_begin-halo_max,1)
200	jje_v=MIN(jj_end+halo_max,jjm)
201	jjnb_v=jje_v-jjb_v+1
202
203	ijb_u=MAX(ij_begin-halo_max*iip1,1)
204	ije_u=MIN(ij_end+halo_max*iip1,ip1jmp1)
205	ijnb_u=ije_u-ijb_u+1
206
207	ijb_v=MAX(ij_begin-halo_max*iip1,1)
208	ije_v=MIN(ij_end+halo_max*iip1,ip1jm)
209	ijnb_v=ije_v-ijb_v+1
210
211	!$OMP PARALLEL
212
213	#ifdef CPP_OMP
214	!$OMP MASTER
215	omp_size=OMP_GET_NUM_THREADS()
216	!$OMP END MASTER
217	!$OMP BARRIER
218	omp_rank=OMP_GET_THREAD_NUM()
219
220	!Config Key = omp_chunk
221	!Config Desc = taille des blocs openmp
222	!Config Def = 1
223	!Config Help = defini la taille des packets d'it�ration openmp
224	!Config distribue a chaque tache lors de l'entree dans une
225	!Config boucle parallelisee
226
227	!$OMP MASTER
228	omp_chunk=(llm+1)/omp_size
229	IF (MOD(llm+1,omp_size)/=0) omp_chunk=omp_chunk+1
230	CALL getin('omp_chunk',omp_chunk)
231	!$OMP END MASTER
232	!$OMP BARRIER
233	#else
234	omp_size=1
235	omp_rank=0
236	#endif
237	!$OMP END PARALLEL
238	CALL create_distrib(jj_nb_para,current_dist)
239
240	IF ((mpi_rank==0).and.(omp_rank==0)) THEN
241	is_master=.true.
242	ELSE
243	is_master=.false.
244	ENDIF
245
246	end subroutine init_parallel
247
248	SUBROUTINE create_distrib(jj_nb_new,d)
249	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
250	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
251	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
252	IMPLICIT NONE
253
254
255
256	INTEGER,INTENT(IN) :: jj_Nb_New(0:MPI_Size-1)
257	TYPE(distrib),INTENT(INOUT) :: d
258	INTEGER :: i
259
260	IF (.NOT. ASSOCIATED(d%jj_nb_para)) ALLOCATE(d%jj_nb_para(0:MPI_Size-1))
261	IF (.NOT. ASSOCIATED(d%jj_begin_para)) ALLOCATE(d%jj_begin_para(0:MPI_Size-1))
262	IF (.NOT. ASSOCIATED(d%jj_end_para)) ALLOCATE(d%jj_end_para(0:MPI_Size-1))
263
264	d%jj_Nb_Para=jj_Nb_New
265
266	d%jj_begin_para(0)=1
267	d%jj_end_para(0)=d%jj_Nb_Para(0)
268
269	do i=1,mpi_size-1
270
271	d%jj_begin_para(i)=d%jj_end_para(i-1)+1
272	d%jj_end_para(i)=d%jj_begin_para(i)+d%jj_Nb_para(i)-1
273
274	enddo
275
276	d%jj_begin = d%jj_begin_para(mpi_rank)
277	d%jj_end = d%jj_end_para(mpi_rank)
278	d%jj_nb = d%jj_nb_para(mpi_rank)
279
280	d%ij_begin=(d%jj_begin-1)*iip1+1
281	d%ij_end=d%jj_end*iip1
282
283	d%jjb_u=MAX(d%jj_begin-halo_max,1)
284	d%jje_u=MIN(d%jj_end+halo_max,jjp1)
285	d%jjnb_u=d%jje_u-d%jjb_u+1
286
287	d%jjb_v=MAX(d%jj_begin-halo_max,1)
288	d%jje_v=MIN(d%jj_end+halo_max,jjm)
289	d%jjnb_v=d%jje_v-d%jjb_v+1
290
291	d%ijb_u=MAX(d%ij_begin-halo_max*iip1,1)
292	d%ije_u=MIN(d%ij_end+halo_max*iip1,ip1jmp1)
293	d%ijnb_u=d%ije_u-d%ijb_u+1
294
295	d%ijb_v=MAX(d%ij_begin-halo_max*iip1,1)
296	d%ije_v=MIN(d%ij_end+halo_max*iip1,ip1jm)
297	d%ijnb_v=d%ije_v-d%ijb_v+1
298
299	END SUBROUTINE create_distrib
300
301
302	SUBROUTINE Set_Distrib(d)
303	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
304	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
305	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
306	IMPLICIT NONE
307
308
309
310	TYPE(distrib),INTENT(IN) :: d
311
312	jj_begin = d%jj_begin
313	jj_end = d%jj_end
314	jj_nb = d%jj_nb
315	ij_begin = d%ij_begin
316	ij_end = d%ij_end
317
318	jjb_u = d%jjb_u
319	jje_u = d%jje_u
320	jjnb_u = d%jjnb_u
321	jjb_v = d%jjb_v
322	jje_v = d%jje_v
323	jjnb_v = d%jjnb_v
324
325	ijb_u = d%ijb_u
326	ije_u = d%ije_u
327	ijnb_u = d%ijnb_u
328
329	ijb_v = d%ijb_v
330	ije_v = d%ije_v
331	ijnb_v = d%ijnb_v
332
333
334	jj_begin_para(:) = d%jj_begin_para(:)
335	jj_end_para(:) = d%jj_end_para(:)
336	jj_nb_para(:) = d%jj_nb_para(:)
337	current_dist=d
338
339	END SUBROUTINE Set_Distrib
340
341	SUBROUTINE copy_distrib(dist,new_dist)
342	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
343	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
344	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
345	IMPLICIT NONE
346
347
348
349	TYPE(distrib),INTENT(INOUT) :: dist
350	TYPE(distrib),INTENT(IN) :: new_dist
351
352	dist%jj_begin = new_dist%jj_begin
353	dist%jj_end = new_dist%jj_end
354	dist%jj_nb = new_dist%jj_nb
355	dist%ij_begin = new_dist%ij_begin
356	dist%ij_end = new_dist%ij_end
357
358	dist%jjb_u = new_dist%jjb_u
359	dist%jje_u = new_dist%jje_u
360	dist%jjnb_u = new_dist%jjnb_u
361	dist%jjb_v = new_dist%jjb_v
362	dist%jje_v = new_dist%jje_v
363	dist%jjnb_v = new_dist%jjnb_v
364
365	dist%ijb_u = new_dist%ijb_u
366	dist%ije_u = new_dist%ije_u
367	dist%ijnb_u = new_dist%ijnb_u
368
369	dist%ijb_v = new_dist%ijb_v
370	dist%ije_v = new_dist%ije_v
371	dist%ijnb_v = new_dist%ijnb_v
372
373
374	dist%jj_begin_para(:) = new_dist%jj_begin_para(:)
375	dist%jj_end_para(:) = new_dist%jj_end_para(:)
376	dist%jj_nb_para(:) = new_dist%jj_nb_para(:)
377
378	END SUBROUTINE copy_distrib
379
380
381	SUBROUTINE get_current_distrib(d)
382	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
383	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
384	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
385	IMPLICIT NONE
386
387
388
389	TYPE(distrib),INTENT(OUT) :: d
390
391	d=current_dist
392
393	END SUBROUTINE get_current_distrib
394
395	subroutine Finalize_parallel
396	USE lmdz_mpi
397	! ug Pour les sorties XIOS
398	USE wxios
399	USE control_mod, only : ok_dyn_xios
400	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
401	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
402	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
403
404	#ifdef CPP_COUPLE
405	! Use of Oasis-MCT coupler
406	#if defined CPP_OMCT
407	use mod_prism
408	#else
409	use mod_prism_proto
410	#endif
411	! Ehouarn: surface_data module is in 'phylmd' ...
412	use surface_data, only : type_ocean
413	implicit none
414	#else
415	implicit none
416	! without the surface_data module, we declare (and set) a dummy 'type_ocean'
417	character(len=6),parameter :: type_ocean="dummy"
418	#endif
419	! #endif of #ifdef CPP_EARTH
420	integer :: ierr
421	integer :: i
422
423	if (allocated(jj_begin_para)) deallocate(jj_begin_para)
424	if (allocated(jj_end_para)) deallocate(jj_end_para)
425	if (allocated(jj_nb_para)) deallocate(jj_nb_para)
426
427	if (type_ocean == 'couple') then
428	#ifdef CPP_COUPLE
429	IF (using_xios) THEN
430	!Fermeture propre de XIOS
431	! close xios dynamic context if is defined (call LMDZDYN)
432	IF (ok_dyn_xios) THEN
433	CALL xios_context_finalize()
434	ENDIF
435	CALL wxios_close()
436	CALL prism_terminate_proto(ierr)
437	IF (ierr .ne. PRISM_Ok) THEN
438	CALL abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
439	ENDIF
440	ELSE
441	call prism_terminate_proto(ierr)
442	IF (ierr .ne. PRISM_Ok) THEN
443	call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
444	endif
445	ENDIF
446	#else
447	call abort_gcm('Finalize_parallel','type_ocean = couple but CPP_COUPLE not defined',1)
448	#endif
449	else
450	IF (using_xios) THEN
451	!Fermeture propre de XIOS
452	IF (ok_dyn_xios) THEN
453	CALL xios_context_finalize()
454	ENDIF
455	CALL wxios_close()
456	ENDIF
457	IF (using_mpi) call MPI_FINALIZE(ierr)
458	end if
459
460	end subroutine Finalize_parallel
461
462	subroutine Pack_Data(Field,ij,ll,row,Buffer)
463	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
464	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
465	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
466	implicit none
467
468
469
470
471	integer, intent(in) :: ij,ll,row
472	real,dimension(ij,ll),intent(in) ::Field
473	real,dimension(lliip1row), intent(out) :: Buffer
474
475	integer :: Pos
476	integer :: i,l
477
478	Pos=0
479	do l=1,ll
480	do i=1,row*iip1
481	Pos=Pos+1
482	Buffer(Pos)=Field(i,l)
483	enddo
484	enddo
485
486	end subroutine Pack_data
487
488	subroutine Unpack_Data(Field,ij,ll,row,Buffer)
489	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
490	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
491	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
492	implicit none
493
494
495
496
497	integer, intent(in) :: ij,ll,row
498	real,dimension(ij,ll),intent(out) ::Field
499	real,dimension(lliip1row), intent(in) :: Buffer
500
501	integer :: Pos
502	integer :: i,l
503
504	Pos=0
505
506	do l=1,ll
507	do i=1,row*iip1
508	Pos=Pos+1
509	Field(i,l)=Buffer(Pos)
510	enddo
511	enddo
512
513	end subroutine UnPack_data
514
515
516	SUBROUTINE barrier
517	USE lmdz_mpi
518	IMPLICIT NONE
519	INTEGER :: ierr
520
521	!$OMP CRITICAL (MPI)
522	IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
523	!$OMP END CRITICAL (MPI)
524
525	END SUBROUTINE barrier
526
527
528	subroutine exchange_hallo(Field,ij,ll,up,down)
529	USE lmdz_mpi
530	USE Vampir
531	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
532	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
533	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
534	implicit none
535
536
537	INTEGER :: ij,ll
538	REAL, dimension(ij,ll) :: Field
539	INTEGER :: up,down
540
541	INTEGER :: ierr
542	LOGICAL :: SendUp,SendDown
543	LOGICAL :: RecvUp,RecvDown
544	INTEGER, DIMENSION(4) :: Request
545	INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
546
547	INTEGER :: NbRequest
548	REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
549	REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
550	INTEGER :: Buffer_size
551
552	IF (using_mpi) THEN
553
554	CALL barrier
555
556	call VTb(VThallo)
557
558	SendUp=.TRUE.
559	SendDown=.TRUE.
560	RecvUp=.TRUE.
561	RecvDown=.TRUE.
562
563	IF (pole_nord) THEN
564	SendUp=.FALSE.
565	RecvUp=.FALSE.
566	ENDIF
567
568	IF (pole_sud) THEN
569	SendDown=.FALSE.
570	RecvDown=.FALSE.
571	ENDIF
572
573	if (up.eq.0) then
574	SendDown=.FALSE.
575	RecvUp=.FALSE.
576	endif
577
578	if (down.eq.0) then
579	SendUp=.FALSE.
580	RecvDown=.FALSE.
581	endif
582
583	NbRequest=0
584
585	IF (SendUp) THEN
586	NbRequest=NbRequest+1
587	buffer_size=downiip1ll
588	allocate(Buffer_Send_up(Buffer_size))
589	call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
590	!$OMP CRITICAL (MPI)
591	call MPI_ISEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, &
592	COMM_LMDZ,Request(NbRequest),ierr)
593	!$OMP END CRITICAL (MPI)
594	ENDIF
595
596	IF (SendDown) THEN
597	NbRequest=NbRequest+1
598
599	buffer_size=upiip1ll
600	allocate(Buffer_Send_down(Buffer_size))
601	call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
602
603	!$OMP CRITICAL (MPI)
604	call MPI_ISEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, &
605	COMM_LMDZ,Request(NbRequest),ierr)
606	!$OMP END CRITICAL (MPI)
607	ENDIF
608
609
610	IF (RecvUp) THEN
611	NbRequest=NbRequest+1
612	buffer_size=upiip1ll
613	allocate(Buffer_recv_up(Buffer_size))
614
615	!$OMP CRITICAL (MPI)
616	call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, &
617	COMM_LMDZ,Request(NbRequest),ierr)
618	!$OMP END CRITICAL (MPI)
619
620
621	ENDIF
622
623	IF (RecvDown) THEN
624	NbRequest=NbRequest+1
625	buffer_size=downiip1ll
626	allocate(Buffer_recv_down(Buffer_size))
627
628	!$OMP CRITICAL (MPI)
629	call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, &
630	COMM_LMDZ,Request(NbRequest),ierr)
631	!$OMP END CRITICAL (MPI)
632
633	ENDIF
634
635	if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
636	IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
637	IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)
638
639	call VTe(VThallo)
640	call barrier
641
642	ENDIF ! using_mpi
643
644	RETURN
645
646	end subroutine exchange_Hallo
647
648
649	subroutine Gather_Field(Field,ij,ll,rank)
650	USE iniprint_mod_h
651	USE lmdz_mpi
652	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
653	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
654	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
655	implicit none
656
657
658	INTEGER :: ij,ll,rank
659	REAL, dimension(ij,ll) :: Field
660	REAL, dimension(:),allocatable :: Buffer_send
661	REAL, dimension(:),allocatable :: Buffer_Recv
662	INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
663	INTEGER :: ierr
664	INTEGER ::i
665
666	IF (using_mpi) THEN
667
668	if (ij==ip1jmp1) then
669	allocate(Buffer_send(iip1ll(jj_end-jj_begin+1)))
670	call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
671	else if (ij==ip1jm) then
672	allocate(Buffer_send(iip1ll(min(jj_end,jjm)-jj_begin+1)))
673	call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
674	else
675	write(lunout,*)ij
676	CALL abort_gcm("parallel_lmdz","erreur dans Gather_Field",1)
677	endif
678
679	if (MPI_Rank==rank) then
680	allocate(Buffer_Recv(ij*ll))
681
682	!CDIR NOVECTOR
683	do i=0,MPI_Size-1
684
685	if (ij==ip1jmp1) then
686	Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)lliip1
687	else if (ij==ip1jm) then
688	Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)lliip1
689	else
690	CALL abort_gcm("parallel_lmdz","erreur dans Gather_Field",1)
691	endif
692
693	if (i==0) then
694	displ(i)=0
695	else
696	displ(i)=displ(i-1)+Recv_count(i-1)
697	endif
698
699	enddo
700
701	else
702	! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
703	! below) about Buffer_Recv() being not allocated.
704	! So make a dummy allocation.
705	allocate(Buffer_Recv(1))
706	endif ! of if (MPI_Rank==rank)
707
708	!$OMP CRITICAL (MPI)
709	call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, &
710	Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
711	!$OMP END CRITICAL (MPI)
712
713	if (MPI_Rank==rank) then
714
715	if (ij==ip1jmp1) then
716	do i=0,MPI_Size-1
717	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
718	jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
719	enddo
720	else if (ij==ip1jm) then
721	do i=0,MPI_Size-1
722	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
723	min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
724	enddo
725	endif
726	endif
727	ENDIF ! using_mpi
728
729	end subroutine Gather_Field
730
731
732	subroutine AllGather_Field(Field,ij,ll)
733	USE lmdz_mpi
734	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
735	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
736	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
737	implicit none
738
739
740	INTEGER :: ij,ll
741	REAL, dimension(ij,ll) :: Field
742	INTEGER :: ierr
743
744	IF (using_mpi) THEN
745	call Gather_Field(Field,ij,ll,0)
746	!$OMP CRITICAL (MPI)
747	call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
748	!$OMP END CRITICAL (MPI)
749	ENDIF
750
751	end subroutine AllGather_Field
752
753	subroutine Broadcast_Field(Field,ij,ll,rank)
754	USE lmdz_mpi
755	USE dimensions_mod, ONLY: iim, jjm, llm, ndm
756	USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
757	ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
758	implicit none
759
760
761	INTEGER :: ij,ll
762	REAL, dimension(ij,ll) :: Field
763	INTEGER :: rank
764	INTEGER :: ierr
765
766	IF (using_mpi) THEN
767
768	!$OMP CRITICAL (MPI)
769	call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
770	!$OMP END CRITICAL (MPI)
771
772	ENDIF
773	end subroutine Broadcast_Field
774
775
776	! Subroutine verif_hallo(Field,ij,ll,up,down)
777	! USE lmdz_mpi
778	! USE dimensions_mod, ONLY: iim, jjm, llm, ndm
779	! USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
780	! ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
781	!implicit none
782	!
783	!
784	!
785	! INTEGER :: ij,ll
786	! REAL, dimension(ij,ll) :: Field
787	! INTEGER :: up,down
788	!
789	! REAL,dimension(ij,ll): NewField
790	!
791	! NewField=0
792	!
793	! ijb=ij_begin
794	! ije=ij_end
795	! if (pole_nord)
796	! NewField(ij_be
797
798	end MODULE parallel_lmdz

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

Download in other formats:

Original Format