Context Navigation

parallel_lmdz.F90 @ 5410

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

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

Download in other formats:

Original Format