Context Navigation

modmpp.F90 @ 6258

Last change on this file since 6258 was 6258, checked in by timgraham, 8 years ago

First inclusion of Laurent Debreu's modified code for vertical refinement.
Still a lot of outstanding issues:
1) conv preprocessor fails for limrhg.F90 at the moment (for now I've run without ice model)
2) conv preprocessor fails for STO code - removed this code from testing for now
3) conv preprocessor fails for cpl_oasis.F90 - can work round this by modifying code but the preprocessor should be fixed to deal with this.

After that code compiles and can be run for horizontal grid refinement. Not yet working for vertical refinement.

File size: 27.5 KB

Line
1	!
2	! $Id: modmpp.F 779 2007-12-22 17:04:17Z rblod $
3	!
4	! AGRIF (Adaptive Grid Refinement In Fortran)
5	!
6	! Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
7	! Christophe Vouland (Christophe.Vouland@imag.fr)
8	!
9	! This program is free software; you can redistribute it and/or modify
10	! it under the terms of the GNU General Public License as published by
11	! the Free Software Foundation; either version 2 of the License, or
12	! (at your option) any later version.
13	!
14	! This program is distributed in the hope that it will be useful,
15	! but WITHOUT ANY WARRANTY; without even the implied warranty of
16	! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17	! GNU General Public License for more details.
18	!
19	! You should have received a copy of the GNU General Public License
20	! along with this program; if not, write to the Free Software
21	! Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
22	!
23	!
24	module Agrif_Mpp
25	!
26	use Agrif_Arrays
27	use Agrif_Grids
28	!
29	implicit none
30	!
31	interface
32	subroutine Agrif_get_proc_info ( imin, imax, jmin, jmax )
33	integer, intent(out) :: imin, imax
34	integer, intent(out) :: jmin, jmax
35	end subroutine Agrif_get_proc_info
36	end interface
37	!
38	integer, private :: Agrif_MPI_prec
39	!
40	private :: Agrif_get_proc_info
41	!
42	contains
43	!
44	#if defined AGRIF_MPI
45	!===================================================================================================
46	! subroutine Agrif_MPI_Init
47	!---------------------------------------------------------------------------------------------------
48	subroutine Agrif_MPI_Init ( comm )
49	!---------------------------------------------------------------------------------------------------
50	integer, optional, intent(in) :: comm !< MPI communicator to be attached to the root grid.
51	!
52	include 'mpif.h'
53	integer :: code, ierr
54	logical :: mpi_was_called
55	integer :: current_mpi_prec
56	!
57	call MPI_INITIALIZED( mpi_was_called, code )
58	if( code /= MPI_SUCCESS ) then
59	write(,) ': Error in routine mpi_initialized'
60	call MPI_ABORT( MPI_COMM_WORLD, code, ierr )
61	endif
62	if( .not. mpi_was_called ) then
63	write(,) '### AGRIF Error : you should call Agrif_MPI_Init after MPI_Init.'
64	stop
65	endif
66
67	current_mpi_prec = KIND(1.0)
68	if (current_mpi_prec == 4) then
69	Agrif_MPI_prec = MPI_REAL4
70	else
71	Agrif_MPI_prec = MPI_REAL8
72	endif
73	!
74	if ( present(comm) ) then
75	call Agrif_MPI_switch_comm(comm)
76	else
77	call Agrif_MPI_switch_comm(MPI_COMM_WORLD)
78	endif
79	!
80	Agrif_Mygrid % communicator = Agrif_mpi_comm
81	!
82	if ( Agrif_Parallel_sisters ) then
83	call Agrif_Init_ProcList( Agrif_Mygrid % proc_def_list, Agrif_Nbprocs )
84	call Agrif_pl_copy( Agrif_Mygrid % proc_def_list, Agrif_Mygrid % required_proc_list )
85	endif
86	!---------------------------------------------------------------------------------------------------
87	end subroutine Agrif_MPI_Init
88	!===================================================================================================
89	!
90	!===================================================================================================
91	subroutine Agrif_MPI_switch_comm ( comm )
92	!---------------------------------------------------------------------------------------------------
93	integer, intent(in) :: comm !< MPI communicator you want to switch to.
94	!
95	include 'mpif.h'
96	integer :: code
97	logical :: mpi_was_called
98	!
99	call MPI_INITIALIZED( mpi_was_called, code )
100	if ( .not. mpi_was_called ) return
101	!
102	call MPI_COMM_SIZE(comm, Agrif_Nbprocs, code)
103	call MPI_COMM_RANK(comm, Agrif_ProcRank, code)
104	Agrif_mpi_comm = comm
105	!---------------------------------------------------------------------------------------------------
106	end subroutine Agrif_MPI_switch_comm
107	!===================================================================================================
108	!
109	!===================================================================================================
110	function Agrif_MPI_get_grid_comm ( ) result ( comm )
111	!---------------------------------------------------------------------------------------------------
112	integer :: comm
113	comm = Agrif_Curgrid % communicator
114	!---------------------------------------------------------------------------------------------------
115	end function Agrif_MPI_get_grid_comm
116	!===================================================================================================
117	!
118	!===================================================================================================
119	subroutine Agrif_MPI_set_grid_comm ( comm )
120	!---------------------------------------------------------------------------------------------------
121	integer, intent(in) :: comm
122	Agrif_Curgrid % communicator = comm
123	!---------------------------------------------------------------------------------------------------
124	end subroutine Agrif_MPI_set_grid_comm
125	!===================================================================================================
126	!
127	!===================================================================================================
128	subroutine Agrif_Init_ProcList ( proclist, nbprocs )
129	!---------------------------------------------------------------------------------------------------
130	type(Agrif_Proc_List), intent(inout) :: proclist
131	integer, intent(in) :: nbprocs
132	!
133	include 'mpif.h'
134	type(Agrif_Proc), pointer :: new_proc
135	integer :: p, ierr
136	integer :: imin, imax, jmin, jmax
137	integer, dimension(5) :: local_proc_grid_info
138	integer, dimension(5,nbprocs) :: all_procs_grid_info
139	!
140	call Agrif_get_proc_info(imin, imax, jmin, jmax)
141	!
142	local_proc_grid_info(:) = (/Agrif_Procrank, imin, jmin, imax, jmax/)
143	!
144	call MPI_ALLGATHER(local_proc_grid_info, 5, MPI_INTEGER, &
145	all_procs_grid_info, 5, MPI_INTEGER, Agrif_mpi_comm, ierr)
146	!
147	do p = 1,nbprocs
148	!
149	allocate(new_proc)
150	new_proc % pn = all_procs_grid_info(1,p)
151	new_proc % imin(1) = all_procs_grid_info(2,p)
152	new_proc % imin(2) = all_procs_grid_info(3,p)
153	new_proc % imax(1) = all_procs_grid_info(4,p)
154	new_proc % imax(2) = all_procs_grid_info(5,p)
155	call Agrif_pl_append( proclist, new_proc )
156	!
157	enddo
158	!
159	!---------------------------------------------------------------------------------------------------
160	end subroutine Agrif_Init_ProcList
161	!===================================================================================================
162	!
163	!===================================================================================================
164	! subroutine Get_External_Data_first
165	!---------------------------------------------------------------------------------------------------
166	subroutine Get_External_Data_first ( pttruetab, cetruetab, pttruetabwhole, cetruetabwhole, &
167	nbdim, memberoutall, coords, sendtoproc, recvfromproc, &
168	imin, imax, imin_recv, imax_recv, bornesmin, bornesmax )
169	!---------------------------------------------------------------------------------------------------
170	include 'mpif.h'
171	!
172	integer, intent(in) :: nbdim
173	integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: pttruetab, cetruetab
174	integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: pttruetabwhole,cetruetabwhole
175	logical, dimension(0:Agrif_Nbprocs-1), intent(in) :: memberoutall
176	integer, dimension(nbdim), intent(in) :: coords
177	logical, dimension(0:Agrif_Nbprocs-1), intent(out) :: sendtoproc
178	logical, dimension(0:Agrif_Nbprocs-1), intent(out) :: recvfromproc
179	integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin,imax
180	integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin_recv,imax_recv
181	integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: bornesmin, bornesmax
182	!
183	integer :: imintmp, imaxtmp, i, j, k, i1
184	integer :: imin1,imax1
185	logical :: tochange,tochangebis
186	integer, dimension(nbdim,0:Agrif_NbProcs-1) :: pttruetab2,cetruetab2
187	!
188	! pttruetab2 and cetruetab2 are modified arrays in order to always
189	! send the most inner points
190	!
191	pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
192	cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
193	!
194	do k = 0,Agrif_Nbprocs-1
195	do i = 1,nbdim
196	tochangebis = .TRUE.
197	DO i1 = 1,nbdim
198	IF (i /= i1) THEN
199	IF ( (pttruetab(i1,Agrif_Procrank) /= pttruetab(i1,k)) .OR. &
200	(cetruetab(i1,Agrif_Procrank) /= cetruetab(i1,k))) THEN
201	tochangebis = .FALSE.
202	EXIT
203	ENDIF
204	ENDIF
205	ENDDO
206	IF (tochangebis) THEN
207	imin1 = max(pttruetab(i,Agrif_Procrank), pttruetab(i,k))
208	imax1 = min(cetruetab(i,Agrif_Procrank), cetruetab(i,k))
209	! Always send the most interior points
210
211	tochange = .false.
212	IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN
213	DO j=imin1,imax1
214	IF ((bornesmax(i,k)-j) > (j-bornesmin(i,Agrif_Procrank))) THEN
215	imintmp = j+1
216	tochange = .TRUE.
217	ELSE
218	EXIT
219	ENDIF
220	ENDDO
221	ENDIF
222
223	if (tochange) then
224	pttruetab2(i,Agrif_Procrank) = imintmp
225	endif
226
227	tochange = .FALSE.
228	imaxtmp=0
229	IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN
230	DO j=imax1,imin1,-1
231	IF ((j-bornesmin(i,k)) > (bornesmax(i,Agrif_Procrank)-j)) THEN
232	imaxtmp = j-1
233	tochange = .TRUE.
234	ELSE
235	EXIT
236	ENDIF
237	ENDDO
238	ENDIF
239
240	if (tochange) then
241	cetruetab2(i,Agrif_Procrank) = imaxtmp
242	endif
243	ENDIF
244	enddo
245	enddo
246
247	do k = 0,Agrif_NbProcs-1
248	!
249	sendtoproc(k) = .true.
250	!
251	IF ( .not. memberoutall(k) ) THEN
252	sendtoproc(k) = .false.
253	ELSE
254	!CDIR SHORTLOOP
255	do i = 1,nbdim
256	imin(i,k) = max(pttruetab2(i,Agrif_Procrank), pttruetabwhole(i,k))
257	imax(i,k) = min(cetruetab2(i,Agrif_Procrank), cetruetabwhole(i,k))
258	!
259	if ( (imin(i,k) > imax(i,k)) .and. (coords(i) /= 0) ) then
260	sendtoproc(k) = .false.
261	endif
262	enddo
263	ENDIF
264	enddo
265	!
266	call Exchangesamelevel_first(sendtoproc,nbdim,imin,imax,recvfromproc,imin_recv,imax_recv)
267	!---------------------------------------------------------------------------------------------------
268	end subroutine Get_External_Data_first
269	!===================================================================================================
270	!
271	!===================================================================================================
272	! subroutine ExchangeSameLevel_first
273	!---------------------------------------------------------------------------------------------------
274	subroutine ExchangeSameLevel_first ( sendtoproc, nbdim, imin, imax, recvfromproc, &
275	imin_recv, imax_recv )
276	!---------------------------------------------------------------------------------------------------
277	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: sendtoproc
278	INTEGER, intent(in) :: nbdim
279	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imin
280	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imax
281	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(out) :: recvfromproc
282	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(out) :: imin_recv
283	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(out) :: imax_recv
284	!
285	include 'mpif.h'
286	INTEGER :: k
287	INTEGER :: etiquette = 100
288	INTEGER :: code
289	LOGICAL :: res
290	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: statut
291	INTEGER, DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp
292
293	do k = 0,Agrif_ProcRank-1
294	!
295	call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,code)
296	!
297	if (sendtoproc(k)) then
298	iminmax_temp(:,1,k) = imin(:,k)
299	iminmax_temp(:,2,k) = imax(:,k)
300	call MPI_SEND(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette,Agrif_mpi_comm,code)
301	endif
302	!
303	enddo
304	!
305	! Reception from others processors of the necessary part of the parent grid
306	do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
307	!
308	call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,statut,code)
309	recvfromproc(k) = res
310	!
311	if (recvfromproc(k)) then
312	call MPI_RECV(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, &
313	Agrif_mpi_comm,statut,code)
314	imin_recv(:,k) = iminmax_temp(:,1,k)
315	imax_recv(:,k) = iminmax_temp(:,2,k)
316	endif
317	!
318	enddo
319
320	! Reception from others processors of the necessary part of the parent grid
321	do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
322	!
323	call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,code)
324	!
325	if (sendtoproc(k)) then
326	!
327	iminmax_temp(:,1,k) = imin(:,k)
328	iminmax_temp(:,2,k) = imax(:,k)
329
330	call MPI_SEND(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, &
331	Agrif_mpi_comm,code)
332	endif
333	!
334	enddo
335	!
336	!
337	! Reception from others processors of the necessary part of the parent grid
338	do k = Agrif_ProcRank-1,0,-1
339	!
340	call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,statut,code)
341	recvfromproc(k) = res
342	!
343	if (recvfromproc(k)) then
344	!
345	call MPI_RECV(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, &
346	Agrif_mpi_comm,statut,code)
347
348	imin_recv(:,k) = iminmax_temp(:,1,k)
349	imax_recv(:,k) = iminmax_temp(:,2,k)
350	endif
351	!
352	enddo
353	!---------------------------------------------------------------------------------------------------
354	end subroutine ExchangeSamelevel_first
355	!===================================================================================================
356	!
357	!===================================================================================================
358	! subroutine ExchangeSameLevel
359	!---------------------------------------------------------------------------------------------------
360	subroutine ExchangeSameLevel ( sendtoproc, recvfromproc, nbdim, &
361	pttruetabwhole, cetruetabwhole, &
362	imin, imax, imin_recv, imax_recv, &
363	memberout, tempC, tempCextend )
364	!---------------------------------------------------------------------------------------------------
365	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: sendtoproc
366	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1), intent(in) :: recvfromproc
367	INTEGER, intent(in) :: nbdim
368	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: pttruetabwhole
369	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: cetruetabwhole
370	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imin, imax
371	INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in) :: imin_recv, imax_recv
372	LOGICAL, intent(in) :: memberout
373	TYPE(Agrif_Variable), pointer, intent(inout) :: tempC, tempCextend
374	!
375	include 'mpif.h'
376	INTEGER :: i,k
377	INTEGER :: etiquette = 100
378	INTEGER :: code, datasize
379	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: statut
380	TYPE(Agrif_Variable), pointer, SAVE :: temprecv
381	!
382	IF (memberout) THEN
383	call Agrif_array_allocate(tempCextend, pttruetabwhole(:,Agrif_ProcRank), &
384	cetruetabwhole(:,Agrif_ProcRank),nbdim)
385	call Agrif_var_set_array_tozero(tempCextend,nbdim)
386	ENDIF
387	!
388	IF (sendtoproc(Agrif_ProcRank)) THEN
389	call Agrif_var_copy_array(tempCextend,imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), &
390	tempC, imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), &
391	nbdim)
392	ENDIF
393	!
394	do k = 0,Agrif_ProcRank-1
395	!
396	if (sendtoproc(k)) then
397	!
398	datasize = 1
399	!
400	!CDIR SHORTLOOP
401	do i = 1,nbdim
402	datasize = datasize * (imax(i,k)-imin(i,k)+1)
403	enddo
404	!
405	SELECT CASE(nbdim)
406	CASE(1)
407	call MPI_SEND(tempC%array1(imin(1,k):imax(1,k)), &
408	datasize,Agrif_MPI_prec,k,etiquette, &
409	Agrif_mpi_comm,code)
410	CASE(2)
411	call MPI_SEND(tempC%array2(imin(1,k):imax(1,k), &
412	imin(2,k):imax(2,k)), &
413	datasize,Agrif_MPI_prec,k,etiquette, &
414	Agrif_mpi_comm,code)
415	CASE(3)
416	call Agrif_Send_3Darray(tempC%array3,lbound(tempC%array3),imin(:,k),imax(:,k),k)
417	CASE(4)
418	call MPI_SEND(tempC%array4(imin(1,k):imax(1,k), &
419	imin(2,k):imax(2,k), &
420	imin(3,k):imax(3,k), &
421	imin(4,k):imax(4,k)), &
422	datasize,Agrif_MPI_prec,k,etiquette, &
423	Agrif_mpi_comm,code)
424	CASE(5)
425	call MPI_SEND(tempC%array5(imin(1,k):imax(1,k), &
426	imin(2,k):imax(2,k), &
427	imin(3,k):imax(3,k), &
428	imin(4,k):imax(4,k), &
429	imin(5,k):imax(5,k)), &
430	datasize,Agrif_MPI_prec,k,etiquette, &
431	Agrif_mpi_comm,code)
432	CASE(6)
433	call MPI_SEND(tempC%array6(imin(1,k):imax(1,k), &
434	imin(2,k):imax(2,k), &
435	imin(3,k):imax(3,k), &
436	imin(4,k):imax(4,k), &
437	imin(5,k):imax(5,k), &
438	imin(6,k):imax(6,k)), &
439	datasize,Agrif_MPI_prec,k,etiquette, &
440	Agrif_mpi_comm,code)
441	END SELECT
442	!
443	endif
444	enddo
445	!
446	! Reception from others processors of the necessary part of the parent grid
447	do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
448	!
449	if (recvfromproc(k)) then
450	!
451	datasize = 1
452	!
453	!CDIR SHORTLOOP
454	do i = 1,nbdim
455	datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
456	enddo
457
458	if (.not.associated(temprecv)) allocate(temprecv)
459	call Agrif_array_allocate(temprecv,imin_recv(:,k),imax_recv(:,k),nbdim)
460
461	SELECT CASE(nbdim)
462	CASE(1)
463	call MPI_RECV(temprecv%array1,datasize,Agrif_MPI_prec,k,etiquette, &
464	Agrif_mpi_comm,statut,code)
465	CASE(2)
466	call MPI_RECV(temprecv%array2,datasize,Agrif_MPI_prec,k,etiquette, &
467	Agrif_mpi_comm,statut,code)
468	CASE(3)
469	call MPI_RECV(temprecv%array3,datasize,Agrif_MPI_prec,k,etiquette, &
470	Agrif_mpi_comm,statut,code)
471	CASE(4)
472	call MPI_RECV(temprecv%array4,datasize,Agrif_MPI_prec,k,etiquette, &
473	Agrif_mpi_comm,statut,code)
474	CASE(5)
475	call MPI_RECV(temprecv%array5,datasize,Agrif_MPI_prec,k,etiquette, &
476	Agrif_mpi_comm,statut,code)
477	CASE(6)
478	call MPI_RECV(temprecv%array6,datasize,Agrif_MPI_prec,k,etiquette, &
479	Agrif_mpi_comm,statut,code)
480	END SELECT
481
482	call Agrif_var_replace_value(tempCextend,temprecv,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
483	call Agrif_array_deallocate(temprecv,nbdim)
484	!
485	endif
486	enddo
487
488	! Reception from others processors of the necessary part of the parent grid
489	do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
490	!
491	if (sendtoproc(k)) then
492	!
493	SELECT CASE(nbdim)
494	CASE(1)
495	datasize=SIZE(tempC%array1(imin(1,k):imax(1,k)))
496	call MPI_SEND(tempC%array1(imin(1,k):imax(1,k)), &
497	datasize,Agrif_MPI_prec,k,etiquette, &
498	Agrif_mpi_comm,code)
499	CASE(2)
500	datasize=SIZE(tempC%array2(imin(1,k):imax(1,k), &
501	imin(2,k):imax(2,k)))
502	call MPI_SEND(tempC%array2(imin(1,k):imax(1,k), &
503	imin(2,k):imax(2,k)), &
504	datasize,Agrif_MPI_prec,k,etiquette, &
505	Agrif_mpi_comm,code)
506	CASE(3)
507	datasize=SIZE(tempC%array3(imin(1,k):imax(1,k), &
508	imin(2,k):imax(2,k), &
509	imin(3,k):imax(3,k)))
510	call MPI_SEND(tempC%array3(imin(1,k):imax(1,k), &
511	imin(2,k):imax(2,k), &
512	imin(3,k):imax(3,k)), &
513	datasize,Agrif_MPI_prec,k,etiquette, &
514	Agrif_mpi_comm,code)
515	CASE(4)
516	datasize=SIZE(tempC%array4(imin(1,k):imax(1,k), &
517	imin(2,k):imax(2,k), &
518	imin(3,k):imax(3,k), &
519	imin(4,k):imax(4,k)))
520	call MPI_SEND(tempC%array4(imin(1,k):imax(1,k), &
521	imin(2,k):imax(2,k), &
522	imin(3,k):imax(3,k), &
523	imin(4,k):imax(4,k)), &
524	datasize,Agrif_MPI_prec,k,etiquette, &
525	Agrif_mpi_comm,code)
526	CASE(5)
527	datasize=SIZE(tempC%array5(imin(1,k):imax(1,k), &
528	imin(2,k):imax(2,k), &
529	imin(3,k):imax(3,k), &
530	imin(4,k):imax(4,k), &
531	imin(5,k):imax(5,k)))
532	call MPI_SEND(tempC%array5(imin(1,k):imax(1,k), &
533	imin(2,k):imax(2,k), &
534	imin(3,k):imax(3,k), &
535	imin(4,k):imax(4,k), &
536	imin(5,k):imax(5,k)), &
537	datasize,Agrif_MPI_prec,k,etiquette, &
538	Agrif_mpi_comm,code)
539	CASE(6)
540	datasize=SIZE(tempC%array6(imin(1,k):imax(1,k), &
541	imin(2,k):imax(2,k), &
542	imin(3,k):imax(3,k), &
543	imin(4,k):imax(4,k), &
544	imin(5,k):imax(5,k), &
545	imin(6,k):imax(6,k)))
546	call MPI_SEND(tempC%array6(imin(1,k):imax(1,k), &
547	imin(2,k):imax(2,k), &
548	imin(3,k):imax(3,k), &
549	imin(4,k):imax(4,k), &
550	imin(5,k):imax(5,k), &
551	imin(6,k):imax(6,k)), &
552	datasize,Agrif_MPI_prec,k,etiquette, &
553	Agrif_mpi_comm,code)
554	END SELECT
555	!
556	endif
557	!
558	enddo
559	!
560	! Reception from others processors of the necessary part of the parent grid
561	do k = Agrif_ProcRank-1,0,-1
562	!
563	if (recvfromproc(k)) then
564	!
565	if (.not.associated(temprecv)) allocate(temprecv)
566	call Agrif_array_allocate(temprecv,imin_recv(:,k),imax_recv(:,k),nbdim)
567
568	SELECT CASE(nbdim)
569	CASE(1)
570	datasize=SIZE(temprecv%array1)
571	call MPI_RECV(temprecv%array1,datasize,Agrif_MPI_prec,k,etiquette,&
572	Agrif_mpi_comm,statut,code)
573	CASE(2)
574	datasize=SIZE(temprecv%array2)
575	call MPI_RECV(temprecv%array2,datasize,Agrif_MPI_prec,k,etiquette,&
576	Agrif_mpi_comm,statut,code)
577	CASE(3)
578	datasize=SIZE(temprecv%array3)
579	call MPI_RECV(temprecv%array3,datasize,Agrif_MPI_prec,k,etiquette,&
580	Agrif_mpi_comm,statut,code)
581	CASE(4)
582	datasize=SIZE(temprecv%array4)
583	call MPI_RECV(temprecv%array4,datasize,Agrif_MPI_prec,k,etiquette,&
584	Agrif_mpi_comm,statut,code)
585	CASE(5)
586	datasize=SIZE(temprecv%array5)
587	call MPI_RECV(temprecv%array5,datasize,Agrif_MPI_prec,k,etiquette,&
588	Agrif_mpi_comm,statut,code)
589	CASE(6)
590	datasize=SIZE(temprecv%array6)
591	call MPI_RECV(temprecv%array6,datasize,Agrif_MPI_prec,k,etiquette,&
592	Agrif_mpi_comm,statut,code)
593	END SELECT
594
595	call Agrif_var_replace_value(tempCextend,temprecv,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
596	call Agrif_array_deallocate(temprecv,nbdim)
597	!
598	endif
599	!
600	enddo
601	!---------------------------------------------------------------------------------------------------
602	end subroutine ExchangeSamelevel
603	!===================================================================================================
604	!
605	!===================================================================================================
606	! subroutine Agrif_Send_3Darray
607	!---------------------------------------------------------------------------------------------------
608	subroutine Agrif_Send_3Darray ( tab3D, bounds, imin, imax, k )
609	!---------------------------------------------------------------------------------------------------
610	integer, dimension(3), intent(in) :: bounds
611	real, dimension(bounds(1):,bounds(2):,bounds(3):), target, intent(in) :: tab3D
612	integer, dimension(3), intent(in) :: imin, imax
613	integer, intent(in) :: k
614	!
615	integer :: etiquette = 100
616	integer :: datasize, code
617	include 'mpif.h'
618
619	datasize = SIZE(tab3D(imin(1):imax(1), &
620	imin(2):imax(2), &
621	imin(3):imax(3)))
622
623	call MPI_SEND( tab3D( imin(1):imax(1), &
624	imin(2):imax(2), &
625	imin(3):imax(3)), &
626	datasize,Agrif_MPI_prec,k,etiquette,Agrif_mpi_comm,code)
627	!---------------------------------------------------------------------------------------------------
628	end subroutine Agrif_Send_3Darray
629	!===================================================================================================
630	!
631	#else
632	subroutine dummy_Agrif_Mpp ()
633	end subroutine dummy_Agrif_Mpp
634	#endif
635	!
636	end Module Agrif_Mpp

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmpp.F90 @ 6258

Download in other formats: