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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

modupdate.F in trunk/AGRIF/AGRIF_FILES – NEMO

Context Navigation

source: trunk/AGRIF/AGRIF_FILES/modupdate.F @ 898

Last change on this file since 898 was 898, checked in by rblod, 16 years ago
Correct some bugs in agrif optimization and add MPP optimization, see #42
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 94.5 KB

Line
1	!
2	! $Id$
3	!
4	C AGRIF (Adaptive Grid Refinement In Fortran)
5	C
6	C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
7	C Christophe Vouland (Christophe.Vouland@imag.fr)
8	C
9	C This program is free software; you can redistribute it and/or modify
10	C it under the terms of the GNU General Public License as published by
11	C the Free Software Foundation; either version 2 of the License, or
12	C (at your option) any later version.
13	C
14	C This program is distributed in the hope that it will be useful,
15	C but WITHOUT ANY WARRANTY; without even the implied warranty of
16	C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17	C GNU General Public License for more details.
18	C
19	C You should have received a copy of the GNU General Public License
20	C along with this program; if not, write to the Free Software
21	C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
22	C
23	C
24	C
25	CCC Module Agrif_Update
26	C
27	Module Agrif_Update
28	C
29	CCC Description:
30	CCC Module to update a parent grid from its child grids
31	C
32	C Modules used:
33	C
34	Use Agrif_Updatebasic
35	c Use Agrif_Boundary
36	Use Agrif_Arrays
37	Use Agrif_CurgridFunctions
38	Use Agrif_Mask
39	#ifdef AGRIF_MPI
40	Use Agrif_mpp
41	#endif
42	C
43	IMPLICIT NONE
44	logical, private :: precomputedone(7) = .FALSE.
45	C
46	CONTAINS
47	C Define procedures contained in this module
48	C
49	C
50	C
51	C **************************************************************************
52	CCC Subroutine Agrif_Update_1d
53	C **************************************************************************
54	C
55	Subroutine Agrif_Update_1d(TypeUpdate,parent,child,tab,deb,fin,
56	& procname)
57	C
58	CCC Description:
59	CCC Subroutine to update a 1D grid variable on the parent grid.
60	C
61	C Declarations:
62	C
63
64	C
65	C Arguments
66	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
67	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
68	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
69	TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
70	INTEGER :: deb,fin ! Positions where interpolations
71	! are done on the fine grid
72	External :: procname
73	Optional :: procname
74	REAL, DIMENSION(lbound(child%var%array1,1):
75	& ubound(child%var%array1,1)), Target :: tab ! Results
76	C
77	C
78	C Definition of a temporary AGRIF_PVariable data TYPE
79	allocate(childtemp % var)
80	C
81	C Pointer on the root variable
82	childtemp % var % root_var => child % var %root_var
83	C
84	C Number of dimensions of the grid variable
85	childtemp % var % nbdim = 1
86	C
87	C Values on the current grid used for the update
88	childtemp % var % array1 => tab
89
90	C childtemp % var % list_update => child%var%list_update
91
92	C
93
94	IF (present(procname)) THEN
95	CALL Agrif_UpdateVariable
96	& (TypeUpdate,parent,child,deb,fin,procname)
97	ELSE
98	CALL Agrif_UpdateVariable
99	& (TypeUpdate,parent,child,deb,fin)
100	ENDIF
101	C
102	C child % var % list_update => childtemp%var%list_update
103
104	deallocate(childtemp % var)
105	C
106	C
107	End Subroutine Agrif_Update_1D
108	C
109	C
110	C
111	C **************************************************************************
112	CCC Subroutine Agrif_Update_2d
113	C **************************************************************************
114	C
115
116	Subroutine Agrif_Update_2d(TypeUpdate,parent,child,tab,deb,fin,
117	& procname)
118	C
119	CCC Description:
120	CCC Subroutine to update a 2D grid variable on the parent grid.
121	C
122	C Declarations:
123	C
124
125	C
126	C Arguments
127	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
128	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
129	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
130	TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
131	INTEGER :: deb,fin ! Positions where interpolations
132	! are done on the fine grid
133
134	External :: procname
135	Optional :: procname
136
137	REAL, DIMENSION(
138	& lbound(child%var%array2,1):ubound(child%var%array2,1),
139	& lbound(child%var%array2,2):ubound(child%var%array2,2)),
140	& Target :: tab ! Results
141	C
142	C
143	C Definition of a temporary AGRIF_PVariable data TYPE
144	allocate(childtemp % var)
145	C
146	C Pointer on the root variable
147	childtemp % var % root_var => child % var %root_var
148	C
149	C Number of dimensions of the grid variable
150	childtemp % var % nbdim = 2
151	C
152	C Values on the current grid used for the update
153	childtemp % var % array2 => tab
154
155	C childtemp % var % list_update => child%var%list_update
156	C
157	IF (present(procname)) THEN
158	CALL Agrif_UpdateVariable
159	& (TypeUpdate,parent,child,deb,fin,procname)
160	ELSE
161	CALL Agrif_UpdateVariable
162	& (TypeUpdate,parent,child,deb,fin)
163	ENDIF
164	C
165	C child % var % list_update => childtemp%var%list_update
166
167	deallocate(childtemp % var)
168	C
169	C
170	End Subroutine Agrif_Update_2D
171	C
172	C
173	C
174	C **************************************************************************
175	CCC Subroutine Agrif_Update_3d
176	C **************************************************************************
177	C
178	Subroutine Agrif_Update_3d(TypeUpdate,parent,child,tab,deb,fin,
179	& procname)
180	C
181	CCC Description:
182	CCC Subroutine to update a 3D grid variable on the parent grid.
183	C
184	C Declarations:
185	C
186
187	C
188	C Arguments
189	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
190	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
191	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
192	TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
193	INTEGER :: deb,fin ! Positions where interpolations
194	! are done on the fine grid
195	External :: procname
196	Optional :: procname
197
198	REAL, DIMENSION(
199	& lbound(child%var%array3,1):ubound(child%var%array3,1),
200	& lbound(child%var%array3,2):ubound(child%var%array3,2),
201	& lbound(child%var%array3,3):ubound(child%var%array3,3)),
202	& Target :: tab ! Results
203	C
204	C
205	C Definition of a temporary AGRIF_PVariable data TYPE
206	allocate(childtemp % var)
207	C
208	C Pointer on the root variable
209	childtemp % var % root_var => child % var %root_var
210	C
211	C Number of dimensions of the grid variable
212	childtemp % var % nbdim = 3
213	C
214	C Values on the current grid used for the update
215	childtemp % var % array3 => tab
216
217	C childtemp % var % list_update => child%var%list_update
218	C
219	IF (present(procname)) THEN
220	CALL Agrif_UpdateVariable
221	& (TypeUpdate,parent,child,deb,fin,procname)
222	ELSE
223	CALL Agrif_UpdateVariable
224	& (TypeUpdate,parent,child,deb,fin)
225	ENDIF
226	C
227	C child % var % list_update => childtemp%var%list_update
228
229	DEALLOCATE(childtemp % var)
230	C
231	C
232	End Subroutine Agrif_Update_3D
233	C
234	C
235	C
236	C **************************************************************************
237	CCC Subroutine Agrif_Update_4d
238	C **************************************************************************
239	C
240	Subroutine Agrif_Update_4d(TypeUpdate,parent,child,tab,deb,fin,
241	& procname)
242	C
243	CCC Description:
244	CCC Subroutine to update a 4D grid variable on the parent grid.
245	C
246	C Declarations:
247	C
248
249	C
250	C Arguments
251	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
252	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
253	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
254	TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
255	INTEGER :: deb,fin ! Positions where interpolations
256	! are done on the fine grid
257	External :: procname
258	Optional :: procname
259	REAL, DIMENSION(
260	& lbound(child%var%array4,1):ubound(child%var%array4,1),
261	& lbound(child%var%array4,2):ubound(child%var%array4,2),
262	& lbound(child%var%array4,3):ubound(child%var%array4,3),
263	& lbound(child%var%array4,4):ubound(child%var%array4,4)),
264	& Target :: tab ! Results
265	C
266	C
267	C Definition of a temporary AGRIF_PVariable data TYPE
268	allocate(childtemp % var)
269	C
270	C Pointer on the root variable
271	childtemp % var % root_var => child % var %root_var
272	C
273	C Number of dimensions of the grid variable
274	childtemp % var % nbdim = 4
275	C
276	C Values on the current grid used for the update
277	childtemp % var % array4 => tab
278
279	C childtemp % var % list_update => child%var%list_update
280
281	C
282	IF (present(procname)) THEN
283	CALL Agrif_UpdateVariable
284	& (TypeUpdate,parent,child,deb,fin,procname)
285	ELSE
286	CALL Agrif_UpdateVariable
287	& (TypeUpdate,parent,child,deb,fin)
288	ENDIF
289
290	C child % var % list_update => childtemp%var%list_update
291	C
292	deallocate(childtemp % var)
293	C
294	C
295	End Subroutine Agrif_Update_4D
296	C
297	C
298	C
299	C **************************************************************************
300	CCC Subroutine Agrif_Update_5d
301	C **************************************************************************
302	C
303	Subroutine Agrif_Update_5d(TypeUpdate,parent,child,tab,deb,fin,
304	& procname)
305	C
306	CCC Description:
307	CCC Subroutine to update a 5D grid variable on the parent grid.
308	C
309	C Declarations:
310	C
311
312	C
313	C Arguments
314	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
315	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
316	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
317	TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
318	INTEGER :: deb,fin ! Positions where interpolations
319	! are done on the fine grid
320	External :: procname
321	Optional :: procname
322
323	REAL, DIMENSION(
324	& lbound(child%var%array5,1):ubound(child%var%array5,1),
325	& lbound(child%var%array5,2):ubound(child%var%array5,2),
326	& lbound(child%var%array5,3):ubound(child%var%array5,3),
327	& lbound(child%var%array5,4):ubound(child%var%array5,4),
328	& lbound(child%var%array5,5):ubound(child%var%array5,5)),
329	& Target :: tab ! Results
330	C
331	C
332	C Definition of a temporary AGRIF_PVariable data TYPE
333	allocate(childtemp % var)
334	C
335	C Pointer on the root variable
336	childtemp % var % root_var => child % var %root_var
337	C
338	C Number of dimensions of the grid variable
339	childtemp % var % nbdim = 5
340	C
341	C Values on the current grid used for the update
342	childtemp % var % array5 => tab
343
344	C childtemp % var % list_update => child%var%list_update
345	C
346	IF (present(procname)) THEN
347	CALL Agrif_UpdateVariable
348	& (TypeUpdate,parent,child,deb,fin,procname)
349	ELSE
350	CALL Agrif_UpdateVariable
351	& (TypeUpdate,parent,child,deb,fin)
352	ENDIF
353
354	C child % var % list_update => childtemp%var%list_update
355
356	C
357	deallocate(childtemp % var)
358	C
359	C
360	End Subroutine Agrif_Update_5D
361	C
362	C
363	C
364	C
365	C **************************************************************************
366	CCC Subroutine Agrif_Update_6d
367	C **************************************************************************
368	C
369	Subroutine Agrif_Update_6d(TypeUpdate,parent,child,tab,deb,fin)
370	C
371	CCC Description:
372	CCC Subroutine to update a 6D grid variable on the parent grid.
373	C
374	C Declarations:
375	C
376
377	C
378	C Arguments
379	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
380	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
381	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
382	TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
383	INTEGER :: deb,fin ! Positions where interpolations
384	! are done on the fine grid
385	REAL, DIMENSION(
386	& lbound(child%var%array6,1):ubound(child%var%array6,1),
387	& lbound(child%var%array6,2):ubound(child%var%array6,2),
388	& lbound(child%var%array6,3):ubound(child%var%array6,3),
389	& lbound(child%var%array6,4):ubound(child%var%array6,4),
390	& lbound(child%var%array6,5):ubound(child%var%array6,5),
391	& lbound(child%var%array6,6):ubound(child%var%array6,6)),
392	& Target :: tab ! Results
393	C
394	C
395	C Definition of a temporary AGRIF_PVariable data TYPE
396	allocate(childtemp % var)
397	C
398	C Pointer on the root variable
399	childtemp % var % root_var => child % var %root_var
400	C
401	C Number of dimensions of the grid variable
402	childtemp % var % nbdim = 6
403	C
404	C Values on the current grid used for the update
405	childtemp % var % array6 => tab
406	C childtemp % var % list_update => child%var%list_update
407	C
408	Call Agrif_UpdateVariable
409	& (TypeUpdate,parent,child,deb,fin)
410
411	C child % var % list_update => childtemp%var%list_update
412
413	C
414	deallocate(childtemp % var)
415	C
416	C
417	End Subroutine Agrif_Update_6D
418	C
419	C
420	C
421	C **************************************************************************
422	C Subroutine Agrif_UpdateVariable
423	C **************************************************************************
424	C
425	Subroutine Agrif_UpdateVariable(TypeUpdate,parent,child,deb,fin,
426	& procname)
427	C
428	CCC Description:
429	CCC Subroutine to set arguments of Agrif_UpdatenD, n being the number of
430	C dimensions of the grid variable.
431	C
432	CC Declarations:
433	C
434	c
435	C
436	C Scalar argument
437	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
438	C Data TYPE arguments
439	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
440	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
441	INTEGER :: deb,fin ! Positions where boundary conditions
442	! are calculated
443	External :: procname
444	Optional :: procname
445
446	C
447	C Local scalars
448	INTEGER :: nbdim ! Number of dimensions of the current
449	! grid
450	INTEGER ,DIMENSION(6) :: pttab_child
451	INTEGER ,DIMENSION(6) :: petab_child
452	INTEGER ,DIMENSION(6) :: pttab_parent
453	REAL ,DIMENSION(6) :: s_child,s_parent
454	REAL ,DIMENSION(6) :: ds_child,ds_parent
455	INTEGER,DIMENSION(6) :: loctab_Child ! Indicates if the child
456	! grid has a common border with
457	! the root grid
458	TYPE(AGRIF_Variable), Pointer :: root ! Variable on the root grid
459	INTEGER,DIMENSION(6) :: posvartab_Child ! Position of the
460	! variable on the cell
461	INTEGER,DIMENSION(6) :: nbtab_Child ! Number of the cells
462	INTEGER :: n
463	LOGICAL :: wholeupdate
464	C
465	C
466
467	loctab_child(:) = 0
468	C
469	root => child % var % root_var
470	nbdim = root % nbdim
471	C
472	do n = 1,nbdim
473	posvartab_child(n) = root % posvar(n)
474	enddo
475	C
476
477	Call PreProcessToInterpOrUpdate(parent,child,
478	& petab_Child(1:nbdim),
479	& pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
480	& s_Child(1:nbdim),s_Parent(1:nbdim),
481	& ds_Child(1:nbdim),ds_Parent(1:nbdim),
482	& nbdim)
483	C
484	C
485	do n = 1,nbdim
486	C
487	Select case(root % interptab(n))
488	C
489	case('x') ! x DIMENSION
490	C
491	nbtab_Child(n) = Agrif_Curgrid % nb(1)
492	C
493	case('y') ! y DIMENSION
494	C
495	nbtab_Child(n) = Agrif_Curgrid % nb(2)
496	C
497	case('z') ! z DIMENSION
498	C
499	nbtab_Child(n) = Agrif_Curgrid % nb(3)
500	C
501	case('N') ! No space DIMENSION
502	C
503	select case (nbdim)
504	C
505	case(1)
506	nbtab_Child(n) = SIZE(child % var % array1,n) - 1
507	case(2)
508	nbtab_Child(n) = SIZE(child % var % array2,n) - 1
509	case(3)
510	nbtab_Child(n) = SIZE(child % var % array3,n) - 1
511	case(4)
512	nbtab_Child(n) = SIZE(child % var % array4,n) - 1
513	case(5)
514	nbtab_Child(n) = SIZE(child % var % array5,n) - 1
515	case(6)
516	nbtab_Child(n) = SIZE(child % var % array6,n) - 1
517	C
518	end select
519	C
520	C No interpolation but only a copy of the values of the grid variable
521	C
522	posvartab_child(n) = 1
523
524	loctab_child(n) = -3
525	C
526	End select
527	C
528	enddo
529
530	C Call to a procedure of update according to the number of dimensions of
531	C the grid variable
532
533	wholeupdate = .FALSE.
534
535	IF ((deb == -99) .AND. (deb == fin)) THEN
536	wholeupdate = .TRUE.
537	ENDIF
538
539	IF ((deb > fin)) THEN
540	wholeupdate = .TRUE.
541	ENDIF
542
543	IF (present(procname)) THEN
544
545	IF (wholeupdate) THEN
546
547	Call AGRIF_UpdateWhole
548	& (TypeUpdate,parent,child,deb,fin,
549	& pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
550	& nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
551	& loctab_Child(1:nbdim),
552	& s_Child(1:nbdim),s_Parent(1:nbdim),
553	& ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim,procname)
554	ELSE
555	Call AGRIF_UpdateBcnD
556	& (TypeUpdate,parent,child,deb,fin,
557	& pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
558	& nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
559	& loctab_Child(1:nbdim),
560	& s_Child(1:nbdim),s_Parent(1:nbdim),
561	& ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim,procname)
562	ENDIF
563	ELSE
564	IF (wholeupdate) THEN
565	Call AGRIF_UpdateWhole
566	& (TypeUpdate,parent,child,deb,fin,
567	& pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
568	& nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
569	& loctab_Child(1:nbdim),
570	& s_Child(1:nbdim),s_Parent(1:nbdim),
571	& ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim)
572	ELSE
573	Call AGRIF_UpdateBcnD
574	& (TypeUpdate,parent,child,deb,fin,
575	& pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
576	& nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
577	& loctab_Child(1:nbdim),
578	& s_Child(1:nbdim),s_Parent(1:nbdim),
579	& ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim)
580	ENDIF
581	ENDIF
582	C
583	Return
584	C
585	C
586	End subroutine Agrif_UpdateVariable
587	C
588	C **************************************************************************
589	CCC Subroutine Agrif_UpdateWhole
590	C **************************************************************************
591	C
592	Subroutine AGRIF_UpdateWhole(TypeUpdate,parent,child,deb,fin,
593	& pttab_child,pttab_Parent,
594	& nbtab_Child,posvartab_Child,
595	& loctab_Child,
596	& s_Child,s_Parent,
597	& ds_Child,ds_Parent,nbdim,procname)
598	C
599	CCC Description:
600	CCC Subroutine to calculate the boundary conditions for a nD grid variable on
601	CCC a fine grid by using a space and time interpolations; it is called by the
602	CCC Agrif_CorrectVariable procedure.
603	C
604	C
605	C Declarations:
606	C
607
608	C
609	#ifdef AGRIF_MPI
610	C
611	#include "mpif.h"
612	C
613	#endif
614	C
615	C Arguments
616	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or
617	! average)
618	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent
619	! grid
620	TYPE(AGRIF_PVariable) :: child ! Variable on the child
621	! grid
622	INTEGER :: deb, fin
623	INTEGER :: nbdim ! Number of dimensions of
624	! the grid variable
625	INTEGER,DIMENSION(nbdim) :: pttab_child ! Index of the first point
626	! inside the domain for
627	! the parent grid
628	! variable
629	INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first point
630	! inside the domain for
631	! the child grid
632	! variable
633	INTEGER,DIMENSION(nbdim) :: nbtab_Child ! Number of cells of the
634	! child grid
635	INTEGER,DIMENSION(nbdim) :: posvartab_Child ! Position of the grid
636	! variable (1 or 2)
637	INTEGER,DIMENSION(nbdim) :: loctab_Child ! Indicates if the child
638	! grid has a common
639	! border with the root
640	! grid
641	REAL ,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
642	! and child grids
643	REAL ,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the parent
644	! and child grids
645	External :: procname
646	Optional :: procname
647	C
648	C Local variables
649	INTEGER,DIMENSION(nbdim,2) :: lubglob
650	INTEGER :: i
651	INTEGER,DIMENSION(nbdim,2,2) :: indtab ! Arrays indicating the
652	! limits of the child
653	INTEGER,DIMENSION(nbdim,2,2) :: indtruetab ! grid variable where
654	! boundary conditions are
655	integer :: coeffraf
656	INTEGER :: debloc, finloc
657	C
658	#ifdef AGRIF_MPI
659	C
660	INTEGER,DIMENSION(nbdim) :: lb,ub
661	INTEGER,DIMENSION(nbdim,2) :: iminmaxg
662	INTEGER :: code
663	C
664	#endif
665	C
666	C
667	C indtab contains the limits for the fine grid points that will be used
668	C in the update scheme
669
670	DO i = 1, nbdim
671	coeffraf = nint(ds_Parent(i)/ds_Child(i))
672	debloc = 0
673	finloc = nbtab_Child(i)/coeffraf - 1
674
675	IF (posvartab_child(i) == 1) THEN
676	finloc = finloc - 1
677	ENDIF
678
679	IF (deb > fin) THEN
680	debloc = deb
681	finloc = finloc - deb
682	ENDIF
683
684	indtab(i,1,1) = pttab_child(i) + (debloc + 1) * coeffraf
685	indtab(i,1,2) = pttab_child(i) + (finloc + 1) * coeffraf
686
687	IF (posvartab_child(i) == 1) THEN
688	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
689	indtab(i,1,1) = indtab(i,1,1) - (coeffraf - 1)
690	indtab(i,1,2) = indtab(i,1,2) + (coeffraf - 1)
691	ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
692	indtab(i,1,1) = indtab(i,1,1) - coeffraf / 2
693	indtab(i,1,2) = indtab(i,1,2) + coeffraf / 2
694	ENDIF
695	ELSE
696	indtab(i,1,1) = indtab(i,1,1) - coeffraf
697	indtab(i,1,2) = indtab(i,1,2) - 1
698	IF ((TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting)
699	& .AND.(mod(coeffraf,2) == 1)) THEN
700	indtab(i,1,1) = indtab(i,1,1) - 1
701	indtab(i,1,2) = indtab(i,1,2) + 1
702	ENDIF
703	ENDIF
704	IF (loctab_child(i) == -3) THEN
705	indtab(i,1,1) = pttab_child(i)
706	C
707	if (posvartab_child(i) == 1) then
708	C
709	indtab(i,1,2) = pttab_child(i) + nbtab_child(i)
710	C
711	else
712	C
713	indtab(i,1,2) = pttab_child(i) + nbtab_child(i) - 1
714	ENDIF
715	ENDIF
716	ENDDO
717
718	C lubglob contains the global lbound and ubound of the child array
719	C lubglob(:,1) : global lbound for each dimension
720	C lubglob(:,2) : global lbound for each dimension
721
722	#if !defined AGRIF_MPI
723	Call Agrif_nbdim_Get_bound_dimension(child % var,lubglob(:,1),
724	& lubglob(:,2),nbdim)
725	C
726	#else
727	C
728	Call Agrif_nbdim_Get_bound_dimension(child % var,lb,ub,nbdim)
729	DO i = 1,nbdim
730	C
731	Call Agrif_Invloc(lb(i),Agrif_Procrank,i,iminmaxg(i,1))
732	Call Agrif_Invloc(ub(i),Agrif_Procrank,i,iminmaxg(i,2))
733	C
734	ENDDO
735	C
736	iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2)
737
738	CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN,
739	& MPI_COMM_WORLD,code)
740
741	lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)
742	C
743	#endif
744	C
745
746	indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1),
747	& lubglob(1:nbdim,1))
748	indtruetab(1:nbdim,1,2) = min(indtab(1:nbdim,1,2),
749	& lubglob(1:nbdim,2))
750
751	C
752	C
753
754	IF (present(procname)) THEN
755	Call Agrif_UpdatenD
756	& (TypeUpdate,parent,child,
757	& indtruetab(1:nbdim,1,1),indtruetab(1:nbdim,1,2),
758	& pttab_child(1:nbdim),pttab_Parent(1:nbdim),
759	& s_Child(1:nbdim),s_Parent(1:nbdim),
760	& ds_Child(1:nbdim),ds_Parent(1:nbdim),
761	& posvartab_child,loctab_Child,
762	& nbdim,procname)
763	ELSE
764	Call Agrif_UpdatenD
765	& (TypeUpdate,parent,child,
766	& indtruetab(1:nbdim,1,1),indtruetab(1:nbdim,1,2),
767	& pttab_child(1:nbdim),pttab_Parent(1:nbdim),
768	& s_Child(1:nbdim),s_Parent(1:nbdim),
769	& ds_Child(1:nbdim),ds_Parent(1:nbdim),
770	& posvartab_child,loctab_Child,
771	& nbdim)
772	ENDIF
773	C
774	C
775	C
776	End Subroutine Agrif_UpdateWhole
777	C
778	C **************************************************************************
779	CCC Subroutine Agrif_UpdateBcnd
780	C **************************************************************************
781	C
782	Subroutine AGRIF_UpdateBcnd(TypeUpdate,parent,child,deb,fin,
783	& pttab_child,pttab_Parent,
784	& nbtab_Child,posvartab_Child,
785	& loctab_Child,
786	& s_Child,s_Parent,
787	& ds_Child,ds_Parent,nbdim,procname)
788	C
789	CCC Description:
790	CCC Subroutine to calculate the boundary conditions for a nD grid variable on
791	CCC a fine grid by using a space and time interpolations; it is called by the
792	CCC Agrif_CorrectVariable procedure.
793	C
794	C
795	C Declarations:
796	C
797
798	C
799	#ifdef AGRIF_MPI
800	C
801	#include "mpif.h"
802	C
803	#endif
804	C
805	C Arguments
806	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update
807	! (copy or average)
808	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent
809	! grid
810	TYPE(AGRIF_PVariable) :: child ! Variable on the child
811	! grid
812	INTEGER :: deb,fin ! Positions where
813	! interpolations are done
814	INTEGER :: nbdim ! Number of dimensions of
815	! the grid variable
816	INTEGER,DIMENSION(nbdim) :: pttab_child ! Index of the first point
817	! inside the domain for
818	! the parent grid
819	! variable
820	INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first point
821	! inside the domain for
822	! the child grid variable
823	INTEGER,DIMENSION(nbdim) :: nbtab_Child ! Number of cells of the
824	! child grid
825	INTEGER,DIMENSION(nbdim) :: posvartab_Child ! Position of the grid
826	! variable (1 or 2)
827	INTEGER,DIMENSION(nbdim) :: loctab_Child ! Indicates if the child
828	! grid has a common
829	! border with the root
830	! grid
831	REAL ,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
832	! and child grids
833	REAL ,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the parent
834	! and child grids
835	External :: procname
836	Optional :: procname
837	C
838	C Local variables
839	INTEGER,DIMENSION(nbdim,2) :: lubglob
840	INTEGER :: i
841	INTEGER,DIMENSION(nbdim,2,2) :: indtab ! Arrays indicating the
842	! limits of the child
843	INTEGER,DIMENSION(nbdim,2,2) :: indtruetab ! grid variable where
844	! boundary conditions are
845	INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres ! calculated
846	INTEGER :: nb,ndir,n
847	integer :: coeffraf
848	C
849	#ifdef AGRIF_MPI
850	C
851	INTEGER,DIMENSION(nbdim) :: lb,ub
852	INTEGER,DIMENSION(nbdim,2) :: iminmaxg
853	INTEGER :: code
854	C
855	#endif
856	C
857	C
858
859	DO i = 1, nbdim
860	coeffraf = nint(ds_Parent(i)/ds_Child(i))
861	indtab(i,1,1) = pttab_child(i) + (deb + 1) * coeffraf
862	indtab(i,1,2) = pttab_child(i) + (fin + 1) * coeffraf
863
864	indtab(i,2,1) = pttab_child(i) + nbtab_child(i)
865	& - (fin + 1) * coeffraf
866	indtab(i,2,2) = pttab_child(i) + nbtab_child(i)
867	& - (deb + 1) * coeffraf
868
869	IF (posvartab_child(i) == 1) THEN
870	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
871	indtab(i,:,1) = indtab(i,:,1) - (coeffraf - 1)
872	indtab(i,:,2) = indtab(i,:,2) + (coeffraf - 1)
873	ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
874	indtab(i,:,1) = indtab(i,:,1) - coeffraf / 2
875	indtab(i,:,2) = indtab(i,:,2) + coeffraf / 2
876	ENDIF
877	ELSE
878	indtab(i,1,1) = indtab(i,1,1) - coeffraf
879	indtab(i,1,2) = indtab(i,1,2) - 1
880	indtab(i,2,2) = indtab(i,2,2) + coeffraf - 1
881	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
882	indtab(i,1,1) = indtab(i,1,1) - 1
883	indtab(i,1,2) = indtab(i,1,2) + 1
884	indtab(i,2,1) = indtab(i,2,1) - 1
885	indtab(i,2,2) = indtab(i,2,2) + 1
886	ENDIF
887	ENDIF
888	ENDDO
889
890	#if !defined AGRIF_MPI
891	Call Agrif_nbdim_Get_bound_dimension(child % var,lubglob(:,1),
892	& lubglob(:,2),nbdim)
893
894	C
895	#else
896	C
897	Call Agrif_nbdim_Get_bound_dimension(child % var,lb,ub,nbdim)
898	DO i = 1,nbdim
899	C
900	Call Agrif_Invloc(lb(i),Agrif_Procrank,i,iminmaxg(i,1))
901	Call Agrif_Invloc(ub(i),Agrif_Procrank,i,iminmaxg(i,2))
902	C
903	ENDDO
904	C
905	iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2)
906
907	CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN,
908	& MPI_COMM_WORLD,code)
909
910	lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)
911	C
912	#endif
913	C
914	indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1),
915	& lubglob(1:nbdim,1))
916	indtruetab(1:nbdim,1,2) = max(indtab(1:nbdim,1,2),
917	& lubglob(1:nbdim,1))
918	indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1),
919	& lubglob(1:nbdim,2))
920	indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2),
921	& lubglob(1:nbdim,2))
922
923	C
924	C
925	do nb = 1,nbdim
926	C
927	do ndir = 1,2
928	C
929	if (loctab_child(nb) /= -3) then
930	C
931	do n = 1,2
932	C
933	ptres(nb,n,ndir,nb) = indtruetab(nb,ndir,n)
934	C
935	enddo
936	C
937	do i = 1,nbdim
938	C
939	if (i .NE. nb) then
940	C
941	if (loctab_child(i) == -3) then
942	C
943	ptres(i,1,ndir,nb) = pttab_child(i)
944	C
945	else
946	C
947	ptres(i,1,ndir,nb) = indtruetab(i,1,1)
948	C
949	endif
950	C
951	if (loctab_child(i) == -3) then
952	C
953	if (posvartab_child(i) == 1) then
954	C
955	ptres(i,2,ndir,nb) = pttab_child(i)
956	& + nbtab_child(i)
957	C
958	else
959	C
960	ptres(i,2,ndir,nb) = pttab_child(i)
961	& + nbtab_child(i) - 1
962	C
963	endif
964	C
965	else
966	C
967	ptres(i,2,ndir,nb) = indtruetab(i,2,2)
968	C
969	endif
970	C
971	endif
972	C
973	enddo
974
975	C
976
977	endif
978
979	enddo
980	enddo
981	C
982
983	C
984
985	do nb = 1,nbdim
986	C
987	do ndir = 1,2
988	C
989	if (loctab_child(nb) /= -3) then
990	C
991	IF (present(procname)) THEN
992	Call Agrif_UpdatenD
993	& (TypeUpdate,parent,child,
994	& ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),
995	& pttab_child(1:nbdim),pttab_Parent(1:nbdim),
996	& s_Child(1:nbdim),s_Parent(1:nbdim),
997	& ds_Child(1:nbdim),ds_Parent(1:nbdim),
998	& posvartab_Child,loctab_Child,
999	& nbdim,procname,nb,ndir)
1000	ELSE
1001	Call Agrif_UpdatenD
1002	& (TypeUpdate,parent,child,
1003	& ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),
1004	& pttab_child(1:nbdim),pttab_Parent(1:nbdim),
1005	& s_Child(1:nbdim),s_Parent(1:nbdim),
1006	& ds_Child(1:nbdim),ds_Parent(1:nbdim),
1007	& posvartab_Child,loctab_Child,
1008	& nbdim)
1009	ENDIF
1010	C
1011	endif
1012
1013	C
1014	enddo
1015	C
1016	enddo
1017	C
1018	C
1019	C
1020	End Subroutine Agrif_UpdateBcnd
1021	C
1022	C **************************************************************************
1023	CCC Subroutine Agrif_UpdatenD
1024	C **************************************************************************
1025	C
1026	Subroutine Agrif_UpdatenD(TypeUpdate,parent,child,
1027	& pttab,petab,
1028	& pttab_Child,pttab_Parent,
1029	& s_Child,s_Parent,
1030	& ds_Child,ds_Parent,
1031	& posvartab_Child,loctab_Child,
1032	& nbdim,procname,nb,ndir)
1033	C
1034	C Description:
1035	C Subroutine to update a 2D grid variable on the parent grid of
1036	C the current grid.
1037	C
1038	C Declarations:
1039	C
1040
1041	C
1042	#ifdef AGRIF_MPI
1043	C
1044	#include "mpif.h"
1045	C
1046	#endif
1047	C
1048	C Arguments
1049	INTEGER :: nbdim
1050	INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update
1051	! (copy or average)
1052	TYPE(AGRIF_PVARIABLE) :: parent ! Variable of the parent
1053	! grid
1054	TYPE(AGRIF_PVARIABLE) :: child ! Variable of the child
1055	! grid
1056	INTEGER,DIMENSION(nbdim) :: pttab ! Index of the first
1057	! point inside the
1058	! domain
1059	INTEGER,DIMENSION(nbdim) :: petab ! Index of the first
1060	! point inside the
1061	! domain
1062	INTEGER,DIMENSION(nbdim) :: pttab_Child ! Index of the first
1063	! point inside the
1064	! domain for the child
1065	! grid variable
1066	INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first
1067	! point inside the
1068	! domain for the parent
1069	! grid variable
1070	REAL,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
1071	! and child grids
1072	REAL,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the
1073	! parent and child
1074	! grids
1075	External :: procname
1076	Optional :: procname
1077	Integer :: nb,ndir
1078	Optional :: nb,ndir
1079
1080	C
1081	C Local pointers
1082	TYPE(AGRIF_PVARIABLE), SAVE :: tempP ! Temporary parent grid variable
1083	TYPE(AGRIF_PVARIABLE), SAVE :: tempC ! Temporary child grid variable
1084	C
1085	C Local scalars
1086	INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
1087	INTEGER,DIMENSION(nbdim) :: posvartab_Child,loctab_Child
1088	INTEGER,DIMENSION(nbdim) :: indmin,indmax
1089	INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob
1090	REAL ,DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp
1091	cccccccc LOGICAL,DIMENSION(nbdim) :: noraftab
1092	INTEGER,DIMENSION(nbdim) :: lowerbound,upperbound
1093	LOGICAL :: memberin, member
1094	INTEGER,DIMENSION(nbdim) :: pttruetabwhole,cetruetabwhole
1095	INTEGER,DIMENSION(nbdim,2,2) :: childarray
1096	INTEGER,DIMENSION(nbdim,2,2) :: parentarray
1097	TYPE(AGRIF_PVARIABLE), SAVE :: tempCextend,tempPextend ! Temporary child
1098	INTEGER :: nbin, ndirin
1099	C
1100	#ifdef AGRIF_MPI
1101	C
1102	INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2
1103	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
1104	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2
1105	INTEGER :: code
1106	INTEGER :: i,j,k
1107	INTEGER,DIMENSION(nbdim,4) :: tab3
1108	INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4
1109	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
1110	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t
1111	LOGICAL :: find_list_update
1112	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
1113	LOGICAL, DIMENSION(1) :: memberin1
1114	C
1115	#endif
1116	C
1117
1118	C
1119	C local lbound and ubound of the child array
1120
1121	Call Agrif_nbdim_Get_bound_dimension(child%var,
1122	& lowerbound,upperbound,nbdim)
1123
1124	C here pttab and petab corresponds to the (global) indices of the points needed
1125	C in the update
1126	C pttruetab and cetruetab contains only indices that are present
1127	C on the local processor
1128
1129	Call Agrif_Childbounds(nbdim,
1130	& lowerbound,upperbound,
1131	& pttab,petab,
1132	& pttruetab,cetruetab,memberin)
1133
1134	Call Agrif_Prtbounds(nbdim,indminglob,indmaxglob,s_Parent_temp,
1135	& s_Child_temp,s_Child,ds_Child,
1136	& s_Parent,ds_Parent,
1137	& pttab,petab,pttab_Child,
1138	& pttab_Parent,
1139	& posvartab_Child,TypeUpdate,loctab_Child
1140	#ifdef AGRIF_MPI
1141	& ,pttruetabwhole,cetruetabwhole
1142	#endif
1143	& )
1144
1145	#ifdef AGRIF_MPI
1146	IF (memberin) THEN
1147	Call Agrif_GlobtoLocInd2(childarray,
1148	& lowerbound,upperbound,
1149	& pttruetab,cetruetab,
1150	& nbdim,Agrif_Procrank,
1151	& member)
1152
1153	ENDIF
1154
1155
1156	Call Agrif_Prtbounds(nbdim,indmin,indmax,s_Parent_temp,
1157	& s_Child_temp,s_Child,ds_Child,
1158	& s_Parent,ds_Parent,
1159	& pttruetab,cetruetab,pttab_Child,
1160	& pttab_Parent,
1161	& posvartab_Child,TypeUpdate,loctab_Child
1162	& ,pttruetabwhole,cetruetabwhole
1163	& )
1164
1165	#else
1166	indmin = indminglob
1167	indmax = indmaxglob
1168	pttruetabwhole = pttruetab
1169	cetruetabwhole = cetruetab
1170	childarray(:,1,2) = pttruetab
1171	childarray(:,2,2) = cetruetab
1172	#endif
1173
1174	IF (present(procname)) THEN
1175	IF (.Not.present(nb)) THEN
1176	nbin=0
1177	ndirin=0
1178	ELSE
1179	nbin = nb
1180	ndirin = ndir
1181	ENDIF
1182	ENDIF
1183
1184	IF (memberin) THEN
1185	IF (.not.associated(tempC%var)) allocate(tempC%var)
1186
1187	C
1188	Call Agrif_nbdim_allocation(tempC%var,
1189	& pttruetab,cetruetab,nbdim)
1190
1191	Call Agrif_nbdim_Full_VarEQreal(tempC%var,0.,nbdim)
1192
1193
1194
1195	IF (present(procname)) THEN
1196	SELECT CASE (nbdim)
1197	CASE(1)
1198	CALL procname(tempC%var%array1,
1199	& childarray(1,1,2),childarray(1,2,2),
1200	& .TRUE.,nbin,ndirin)
1201	CASE(2)
1202	CALL procname(tempC%var%array2,
1203	& childarray(1,1,2),childarray(1,2,2),
1204	& childarray(2,1,2),childarray(2,2,2),
1205	& .TRUE.,nbin,ndirin)
1206	CASE(3)
1207	CALL procname(tempC%var%array3,
1208	& childarray(1,1,2),childarray(1,2,2),
1209	& childarray(2,1,2),childarray(2,2,2),
1210	& childarray(3,1,2),childarray(3,2,2),
1211	& .TRUE.,nbin,ndirin)
1212	CASE(4)
1213	CALL procname(tempC%var%array4,
1214	& childarray(1,1,2),childarray(1,2,2),
1215	& childarray(2,1,2),childarray(2,2,2),
1216	& childarray(3,1,2),childarray(3,2,2),
1217	& childarray(4,1,2),childarray(4,2,2),
1218	& .TRUE.,nbin,ndirin)
1219	CASE(5)
1220	CALL procname(tempC%var%array5,
1221	& childarray(1,1,2),childarray(1,2,2),
1222	& childarray(2,1,2),childarray(2,2,2),
1223	& childarray(3,1,2),childarray(3,2,2),
1224	& childarray(4,1,2),childarray(4,2,2),
1225	& childarray(5,1,2),childarray(5,2,2),
1226	& .TRUE.,nbin,ndirin)
1227	CASE(6)
1228	CALL procname(tempC%var%array6,
1229	& childarray(1,1,2),childarray(1,2,2),
1230	& childarray(2,1,2),childarray(2,2,2),
1231	& childarray(3,1,2),childarray(3,2,2),
1232	& childarray(4,1,2),childarray(4,2,2),
1233	& childarray(5,1,2),childarray(5,2,2),
1234	& childarray(6,1,2),childarray(6,2,2),
1235	& .TRUE.,nbin,ndirin)
1236	END SELECT
1237	ELSE
1238	Call Agrif_nbdim_VarEQvar(tempC%var,pttruetab,cetruetab,
1239	& child%var,childarray(:,1,2),childarray(:,2,2),
1240	& nbdim)
1241	ENDIF
1242
1243	ENDIF
1244
1245
1246
1247	C
1248	C
1249	#ifdef AGRIF_MPI
1250	C
1251	C tab2 contains the necessary limits of the parent grid for each processor
1252
1253	IF (Associated(child%var%list_update)) THEN
1254	Call Agrif_Find_list_update(child%var%list_update,pttab,petab,
1255	& pttab_Child,pttab_Parent,nbdim,
1256	& find_list_update,tab4t,tab5t,memberinall,memberinall2,
1257	& sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
1258	ELSE
1259	find_list_update = .FALSE.
1260	ENDIF
1261
1262	if (.not.find_list_update) then
1263	tab3(:,1) = pttruetab(:)
1264	tab3(:,2) = cetruetab(:)
1265	tab3(:,3) = pttruetabwhole(:)
1266	tab3(:,4) = cetruetabwhole(:)
1267	C
1268	C
1269	Call MPI_ALLGATHER(tab3,4nbdim,MPI_INTEGER,tab4,4nbdim,
1270	& MPI_INTEGER,MPI_COMM_WORLD,code)
1271
1272	IF (.not.associated(tempCextend%var)) Allocate(tempCextend%var)
1273	DO k=0,Agrif_Nbprocs-1
1274	do j=1,4
1275	do i=1,nbdim
1276	tab4t(i,k,j) = tab4(i,j,k)
1277	enddo
1278	enddo
1279	enddo
1280
1281	memberin1(1) = memberin
1282	CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
1283	& 1,MPI_LOGICAL,MPI_COMM_WORLD,code)
1284
1285	Call Get_External_Data_first(tab4t(:,:,1),
1286	& tab4t(:,:,2),
1287	& tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin,
1288	& memberinall,sendtoproc1,recvfromproc1,tab4t(:,:,5),
1289	& tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8))
1290
1291	endif
1292
1293	Call ExchangeSameLevel2(sendtoproc1,recvfromproc1,nbdim,
1294	& tab4t(:,:,3),tab4t(:,:,4),tab4t(:,:,5),tab4t(:,:,6),
1295	& tab4t(:,:,7),tab4t(:,:,8),memberin,tempC,
1296	& tempCextend)
1297
1298	! Call Get_External_Data(tempC,tempCextend,tab4t(:,:,1),
1299	! & tab4t(:,:,2),
1300	! & tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin,
1301	! & memberinall)
1302
1303	#else
1304	tempCextend%var => tempC%var
1305	#endif
1306
1307	C
1308	C
1309	C Update of the parent grid (tempP) from the child grid (tempC)
1310
1311
1312	IF (memberin) THEN
1313
1314	IF (.not.associated(tempP%var)) allocate(tempP%var)
1315	Call Agrif_nbdim_allocation(tempP%var,
1316	& indmin,indmax,nbdim)
1317
1318	if ( nbdim .EQ. 1 ) then
1319	tempP%var%array1 = 0.
1320	Call Agrif_Update_1D_recursive(TypeUpdate,
1321	& tempP%var%array1,tempCextend%var%array1,
1322	& indmin,indmax,
1323	& pttruetabwhole,cetruetabwhole,
1324	& s_Child_temp,s_Parent_temp,
1325	& ds_Child,ds_Parent,nbdim)
1326	endif
1327	if ( nbdim .EQ. 2 ) then
1328	Call Agrif_Update_2D_recursive(TypeUpdate,
1329	& tempP%var%array2,tempCextend%var%array2,
1330	& indmin,indmax,
1331	& pttruetabwhole,cetruetabwhole,
1332	& s_Child_temp,s_Parent_temp,
1333	& ds_Child,ds_Parent,nbdim)
1334	endif
1335
1336	if ( nbdim .EQ. 3 ) then
1337	Call Agrif_Update_3D_recursive(TypeUpdate,
1338	& tempP%var%array3,tempCextend%var%array3,
1339	& indmin,indmax,
1340	& pttruetabwhole,cetruetabwhole,
1341	& s_Child_temp,s_Parent_temp,
1342	& ds_Child,ds_Parent,nbdim)
1343	endif
1344	if ( nbdim .EQ. 4 ) then
1345	Call Agrif_Update_4D_recursive(TypeUpdate,
1346	& tempP%var%array4,tempCextend%var%array4,
1347	& indmin,indmax,
1348	& pttruetabwhole,cetruetabwhole,
1349	& s_Child_temp,s_Parent_temp,
1350	& ds_Child,ds_Parent,nbdim)
1351	endif
1352	if ( nbdim .EQ. 5 ) then
1353	Call Agrif_Update_5D_recursive(TypeUpdate,
1354	& tempP%var%array5,tempCextend%var%array5,
1355	& indmin,indmax,
1356	& pttruetabwhole,cetruetabwhole,
1357	& s_Child_temp,s_Parent_temp,
1358	& ds_Child,ds_Parent,nbdim)
1359	endif
1360	if ( nbdim .EQ. 6 ) then
1361	Call Agrif_Update_6D_recursive(TypeUpdate,
1362	& tempP%var%array6,tempCextend%var%array6,
1363	& indmin,indmax,
1364	& pttruetabwhole,cetruetabwhole,
1365	& s_Child_temp,s_Parent_temp,
1366	& ds_Child,ds_Parent,nbdim)
1367	endif
1368
1369	Call Agrif_nbdim_deallocation(tempCextend%var,nbdim)
1370	C Deallocate(tempCextend%var)
1371
1372	ENDIF
1373
1374	#ifdef AGRIF_MPI
1375	Call Agrif_nbdim_Get_bound_dimension(parent%var,
1376	& lowerbound,upperbound,nbdim)
1377
1378	Call Agrif_ChildGrid_to_ParentGrid()
1379	C
1380	Call Agrif_Childbounds(nbdim,
1381	& lowerbound,upperbound,
1382	& indminglob,indmaxglob,
1383	& indminglob2,indmaxglob2,member)
1384	C
1385	IF (member) THEN
1386	Call Agrif_GlobtoLocInd2(parentarray,
1387	& lowerbound,upperbound,
1388	& indminglob2,indmaxglob2,
1389	& nbdim,Agrif_Procrank,
1390	& member)
1391	ENDIF
1392
1393	Call Agrif_ParentGrid_to_ChildGrid()
1394
1395	if (.not.find_list_update) then
1396	tab3(:,1) = indmin(:)
1397	tab3(:,2) = indmax(:)
1398	tab3(:,3) = indminglob2(:)
1399	tab3(:,4) = indmaxglob2(:)
1400	C
1401	Call MPI_ALLGATHER(tab3,4nbdim,MPI_INTEGER,tab4,4nbdim,
1402	& MPI_INTEGER,MPI_COMM_WORLD,code)
1403
1404	IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
1405	DO k=0,Agrif_Nbprocs-1
1406	do j=1,4
1407	do i=1,nbdim
1408	tab5t(i,k,j) = tab4(i,j,k)
1409	enddo
1410	enddo
1411	enddo
1412
1413	memberin1(1) = member
1414	CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2,
1415	& 1,MPI_LOGICAL,MPI_COMM_WORLD,code)
1416
1417	Call Get_External_Data_first(tab5t(:,:,1),
1418	& tab5t(:,:,2),
1419	& tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member,
1420	& memberinall2,sendtoproc2,recvfromproc2,tab5t(:,:,5),
1421	& tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8))
1422
1423	Call Agrif_Addto_list_update(child%var%list_update,pttab,petab,
1424	& pttab_Child,pttab_Parent,nbdim
1425	& ,tab4t,tab5t,memberinall,memberinall2,
1426	& sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
1427
1428	endif
1429
1430	c Call Get_External_Data(tempP,tempPextend,tab5t(:,:,1),
1431	c & tab5t(:,:,2),
1432	c & tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member,
1433	c & memberinall2)
1434
1435	Call ExchangeSameLevel2(sendtoproc2,recvfromproc2,nbdim,
1436	& tab5t(:,:,3),tab5t(:,:,4),tab5t(:,:,5),tab5t(:,:,6),
1437	& tab5t(:,:,7),tab5t(:,:,8),member,tempP,
1438	& tempPextend)
1439
1440	#else
1441	tempPextend%var => tempP%var
1442	parentarray(:,1,1) = indmin
1443	parentarray(:,2,1) = indmax
1444	parentarray(:,1,2) = indmin
1445	parentarray(:,2,2) = indmax
1446	member = .TRUE.
1447	#endif
1448
1449	C
1450	C
1451	C
1452	C Special values on the child grid
1453	if (Agrif_UseSpecialValueFineGrid) then
1454	C
1455	ccc noraftab(1:nbdim) =
1456	ccc & child % var % root_var % interptab(1:nbdim) .EQ. 'N'
1457	C
1458	#ifdef AGRIF_MPI
1459	C
1460	c Allocate(childvalues% var)
1461	C
1462	c Call Agrif_nbdim_allocation(childvalues%var,
1463	c & pttruetab,cetruetab,nbdim)
1464	c Call Agrif_nbdim_Full_VarEQvar(childvalues% var,
1465	c & tempC% var,
1466	c & nbdim)
1467	c Call Agrif_CheckMasknD(tempC,childvalues,
1468	c & pttruetab(1:nbdim),cetruetab(1:nbdim),
1469	c & pttruetab(1:nbdim),cetruetab(1:nbdim),
1470	c & noraftab(1:nbdim),nbdim)
1471	c Call Agrif_nbdim_deallocation(childvalues% var,nbdim)
1472	c Deallocate(childvalues % var)
1473	C
1474	#else
1475	C
1476	c Call Agrif_nbdim_Get_bound_dimension(child%var,
1477	c & lowerbound,upperbound,nbdim)
1478	c Call Agrif_CheckMasknD(tempC,child,
1479	c & pttruetab(1:nbdim),cetruetab(1:nbdim),
1480	c & lowerbound,
1481	c & upperbound,
1482	c & noraftab(1:nbdim),nbdim)
1483	C
1484	#endif
1485	C
1486	endif
1487
1488
1489	C
1490	C
1491	C
1492	C
1493	C Special values on the parent grid
1494	if (Agrif_UseSpecialValue) then
1495	C
1496	#ifdef AGRIF_MPI
1497	C
1498	c Call GiveAgrif_SpecialValueToTab_mpi(parent%var,tempP%var,
1499	c & parentarray,
1500	c & indmin,indmax,
1501	c & Agrif_SpecialValue,nbdim)
1502	C
1503	C
1504	#else
1505	C
1506	c Call GiveAgrif_SpecialValueToTab(parent%var,tempP%var,
1507	c & indmin,indmax,
1508	c & Agrif_SpecialValue,nbdim)
1509	C
1510	#endif
1511	C
1512	C
1513	endif
1514	C
1515	C
1516	IF (member) THEN
1517
1518	IF (present(procname)) THEN
1519	CALL Agrif_ChildGrid_to_ParentGrid()
1520	SELECT CASE(nbdim)
1521	CASE(1)
1522	CALL procname(
1523	& tempPextend%var%array1(
1524	& parentarray(1,1,1):parentarray(1,2,1)),
1525	& parentarray(1,1,2),parentarray(1,2,2),
1526	& .FALSE.,nbin,ndirin
1527	& )
1528	CASE(2)
1529	CALL procname(
1530	& tempPextend%var%array2(
1531	& parentarray(1,1,1):parentarray(1,2,1),
1532	& parentarray(2,1,1):parentarray(2,2,1)),
1533	& parentarray(1,1,2),parentarray(1,2,2),
1534	& parentarray(2,1,2),parentarray(2,2,2),
1535	& .FALSE.,nbin,ndirin
1536	& )
1537	CASE(3)
1538	CALL procname(
1539	& tempPextend%var%array3(
1540	& parentarray(1,1,1):parentarray(1,2,1),
1541	& parentarray(2,1,1):parentarray(2,2,1),
1542	& parentarray(3,1,1):parentarray(3,2,1)),
1543	& parentarray(1,1,2),parentarray(1,2,2),
1544	& parentarray(2,1,2),parentarray(2,2,2),
1545	& parentarray(3,1,2),parentarray(3,2,2),
1546	& .FALSE.,nbin,ndirin
1547	& )
1548	CASE(4)
1549	CALL procname(
1550	& tempPextend%var%array4(
1551	& parentarray(1,1,1):parentarray(1,2,1),
1552	& parentarray(2,1,1):parentarray(2,2,1),
1553	& parentarray(3,1,1):parentarray(3,2,1),
1554	& parentarray(4,1,1):parentarray(4,2,1)),
1555	& parentarray(1,1,2),parentarray(1,2,2),
1556	& parentarray(2,1,2),parentarray(2,2,2),
1557	& parentarray(3,1,2),parentarray(3,2,2),
1558	& parentarray(4,1,2),parentarray(4,2,2),
1559	& .FALSE.,nbin,ndirin
1560	& )
1561	CASE(5)
1562	CALL procname(
1563	& tempPextend%var%array5(
1564	& parentarray(1,1,1):parentarray(1,2,1),
1565	& parentarray(2,1,1):parentarray(2,2,1),
1566	& parentarray(3,1,1):parentarray(3,2,1),
1567	& parentarray(4,1,1):parentarray(4,2,1),
1568	& parentarray(5,1,1):parentarray(5,2,1)),
1569	& parentarray(1,1,2),parentarray(1,2,2),
1570	& parentarray(2,1,2),parentarray(2,2,2),
1571	& parentarray(3,1,2),parentarray(3,2,2),
1572	& parentarray(4,1,2),parentarray(4,2,2),
1573	& parentarray(5,1,2),parentarray(5,2,2),
1574	& .FALSE.,nbin,ndirin
1575	& )
1576	CASE(6)
1577	CALL procname(
1578	& tempPextend%var%array6(
1579	& parentarray(1,1,1):parentarray(1,2,1),
1580	& parentarray(2,1,1):parentarray(2,2,1),
1581	& parentarray(3,1,1):parentarray(3,2,1),
1582	& parentarray(4,1,1):parentarray(4,2,1),
1583	& parentarray(5,1,1):parentarray(5,2,1),
1584	& parentarray(6,1,1):parentarray(6,2,1)),
1585	& parentarray(1,1,2),parentarray(1,2,2),
1586	& parentarray(2,1,2),parentarray(2,2,2),
1587	& parentarray(3,1,2),parentarray(3,2,2),
1588	& parentarray(4,1,2),parentarray(4,2,2),
1589	& parentarray(5,1,2),parentarray(5,2,2),
1590	& parentarray(6,1,2),parentarray(6,2,2),
1591	& .FALSE.,nbin,ndirin
1592	& )
1593	END SELECT
1594	CALL Agrif_ParentGrid_to_ChildGrid()
1595	ELSE
1596	SELECT CASE(nbdim)
1597	CASE(1)
1598	parent%var%array1(parentarray(1,1,2):parentarray(1,2,2)) =
1599	& tempPextend%var%array1(
1600	& parentarray(1,1,1):parentarray(1,2,1))
1601	CASE(2)
1602	parent%var%array2(parentarray(1,1,2):parentarray(1,2,2),
1603	& parentarray(2,1,2):parentarray(2,2,2)) =
1604	& tempPextend%var%array2(
1605	& parentarray(1,1,1):parentarray(1,2,1),
1606	& parentarray(2,1,1):parentarray(2,2,1))
1607	CASE(3)
1608	parent%var%array3(parentarray(1,1,2):parentarray(1,2,2),
1609	& parentarray(2,1,2):parentarray(2,2,2),
1610	& parentarray(3,1,2):parentarray(3,2,2)) =
1611	& tempPextend%var%array3(
1612	& parentarray(1,1,1):parentarray(1,2,1),
1613	& parentarray(2,1,1):parentarray(2,2,1),
1614	& parentarray(3,1,1):parentarray(3,2,1))
1615	CASE(4)
1616	parent%var%array4(parentarray(1,1,2):parentarray(1,2,2),
1617	& parentarray(2,1,2):parentarray(2,2,2),
1618	& parentarray(3,1,2):parentarray(3,2,2),
1619	& parentarray(4,1,2):parentarray(4,2,2)) =
1620	& tempPextend%var%array4(
1621	& parentarray(1,1,1):parentarray(1,2,1),
1622	& parentarray(2,1,1):parentarray(2,2,1),
1623	& parentarray(3,1,1):parentarray(3,2,1),
1624	& parentarray(4,1,1):parentarray(4,2,1))
1625	CASE(5)
1626	parent%var%array5(parentarray(1,1,2):parentarray(1,2,2),
1627	& parentarray(2,1,2):parentarray(2,2,2),
1628	& parentarray(3,1,2):parentarray(3,2,2),
1629	& parentarray(4,1,2):parentarray(4,2,2),
1630	& parentarray(5,1,2):parentarray(5,2,2)) =
1631	& tempPextend%var%array5(
1632	& parentarray(1,1,1):parentarray(1,2,1),
1633	& parentarray(2,1,1):parentarray(2,2,1),
1634	& parentarray(3,1,1):parentarray(3,2,1),
1635	& parentarray(4,1,1):parentarray(4,2,1),
1636	& parentarray(5,1,1):parentarray(5,2,1))
1637	CASE(6)
1638	parent%var%array6(parentarray(1,1,2):parentarray(1,2,2),
1639	& parentarray(2,1,2):parentarray(2,2,2),
1640	& parentarray(3,1,2):parentarray(3,2,2),
1641	& parentarray(4,1,2):parentarray(4,2,2),
1642	& parentarray(5,1,2):parentarray(5,2,2),
1643	& parentarray(6,1,2):parentarray(6,2,2)) =
1644	& tempPextend%var%array6(
1645	& parentarray(1,1,1):parentarray(1,2,1),
1646	& parentarray(2,1,1):parentarray(2,2,1),
1647	& parentarray(3,1,1):parentarray(3,2,1),
1648	& parentarray(4,1,1):parentarray(4,2,1),
1649	& parentarray(5,1,1):parentarray(5,2,1),
1650	& parentarray(6,1,1):parentarray(6,2,1))
1651	END SELECT
1652	ENDIF
1653
1654	Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
1655	ENDIF
1656	C
1657	C
1658	C Deallocations
1659
1660	IF (memberin) THEN
1661	#ifdef AGRIF_MPI
1662	Call Agrif_nbdim_deallocation(tempP%var,nbdim)
1663	Call Agrif_nbdim_deallocation(tempC%var,nbdim)
1664	! Deallocate(tempC % var)
1665	#endif
1666	! Deallocate(tempP % var)
1667	ENDIF
1668	#ifdef AGRIF_MPI
1669	! Deallocate(tempPextend%var)
1670	! IF (.Not.memberin) Deallocate(tempCextend%var)
1671	#endif
1672
1673	C
1674	C
1675	End Subroutine Agrif_UpdatenD
1676	C
1677	C
1678	C **************************************************************************
1679	CCC Subroutine Agrif_Prtbounds
1680	C **************************************************************************
1681	C
1682	Subroutine Agrif_Prtbounds(nbdim,indmin,indmax,s_Parent_temp,
1683	& s_Child_temp,s_Child,ds_Child,
1684	& s_Parent,ds_Parent,
1685	& pttruetab,cetruetab,pttab_Child,
1686	& pttab_Parent,
1687	& posvartab_child,TypeUpdate,
1688	& loctab_Child
1689	#ifdef AGRIF_MPI
1690	& ,pttruetabwhole,cetruetabwhole
1691	#endif
1692	& )
1693	C
1694	CCC Description:
1695	CCC Subroutine calculating the bounds of the parent grid to be updated
1696	CCC by the child grid
1697	C
1698	C
1699	C Declarations:
1700	C
1701
1702	C
1703	#ifdef AGRIF_MPI
1704	cccccccccccccccccccccccccc#include "mpif.h"
1705	#endif
1706	C
1707	C Arguments
1708	INTEGER :: nbdim
1709	INTEGER,DIMENSION(nbdim) :: indmin,indmax
1710	REAL,DIMENSION(nbdim) :: s_Parent_temp,s_child_temp
1711	REAL,DIMENSION(nbdim) :: s_Child,ds_child
1712	REAL,DIMENSION(nbdim) :: s_Parent,ds_Parent
1713	INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
1714	INTEGER,DIMENSION(nbdim) :: posvartab_child,TypeUpdate
1715	INTEGER,DIMENSION(nbdim) :: loctab_Child
1716	INTEGER,DIMENSION(nbdim) :: pttab_Child,pttab_Parent
1717	C
1718	C Local variables
1719	INTEGER :: i
1720	REAL,DIMENSION(nbdim) :: dim_newmin,dim_newmax
1721	#ifdef AGRIF_MPI
1722	INTEGER,DIMENSION(nbdim) :: pttruetabwhole,cetruetabwhole
1723	REAL :: positionmin,positionmax
1724	INTEGER :: imin,imax
1725	#endif
1726	C
1727	C
1728	do i = 1,nbdim
1729	C
1730	dim_newmin(i) = s_Child(i) + (pttruetab(i) -
1731	& pttab_Child(i)) * ds_Child(i)
1732	C
1733	dim_newmax(i) = s_Child(i) + (cetruetab(i) -
1734	& pttab_Child(i)) * ds_Child(i)
1735	C
1736	indmin(i) = pttab_Parent(i) +
1737	& agrif_ceiling((dim_newmin(i)-s_Parent(i))/ds_Parent(i))
1738	C
1739	indmax(i) = pttab_Parent(i) +
1740	& agrif_int((dim_newmax(i)-s_Parent(i))/ds_Parent(i))
1741	C
1742	#ifdef AGRIF_MPI
1743	positionmin = s_Parent(i) + (indmin(i)-
1744	& pttab_Parent(i))*ds_Parent(i)
1745	IF (loctab_Child(i) .NE. -3) THEN
1746	IF (posvartab_child(i) == 1) THEN
1747	IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
1748	positionmin = positionmin - ds_Parent(i)/2.
1749	ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1750	positionmin = positionmin - (ds_Parent(i)-ds_Child(i))
1751	ENDIF
1752	ELSE
1753	positionmin = positionmin - ds_Parent(i)/2.
1754	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1755	positionmin = positionmin - ds_Child(i)
1756	ENDIF
1757	ENDIF
1758	ENDIF
1759	imin = pttab_Child(i) +
1760	& agrif_ceiling((positionmin-s_Child(i))/ds_Child(i))
1761
1762	positionmin = s_Child(i) + (imin -
1763	& pttab_Child(i)) * ds_Child(i)
1764
1765	pttruetabwhole(i) = imin
1766
1767	positionmax = s_Parent(i) + (indmax(i)-
1768	& pttab_Parent(i))*ds_Parent(i)
1769	IF (loctab_Child(i) .NE. -3) THEN
1770	IF (posvartab_child(i) == 1) THEN
1771	IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
1772	positionmax = positionmax + ds_Parent(i)/2.
1773	ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1774	positionmax = positionmax + (ds_Parent(i)-ds_Child(i))
1775	ENDIF
1776	ELSE
1777	positionmax = positionmax + ds_Parent(i)/2.
1778	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1779	positionmax = positionmax + ds_Child(i)
1780	ENDIF
1781	ENDIF
1782	ENDIF
1783	imax = pttab_Child(i) +
1784	& agrif_int((positionmax-s_Child(i))/ds_Child(i))
1785
1786	positionmax = s_Child(i) + (imax -
1787	& pttab_Child(i)) * ds_Child(i)
1788
1789	cetruetabwhole(i) = imax
1790
1791	#endif
1792	C
1793	s_Parent_temp(i) = s_Parent(i) +
1794	& (indmin(i) - pttab_Parent(i)) *
1795	& ds_Parent(i)
1796	C
1797	s_Child_temp(i) = dim_newmin(i)
1798
1799	#ifdef AGRIF_MPI
1800	s_Child_temp(i) = positionmin
1801	#endif
1802	C
1803	enddo
1804	C
1805	Return
1806	C
1807	C
1808	End Subroutine Agrif_Prtbounds
1809	C
1810	C
1811	C
1812	C
1813
1814	C
1815	C
1816	C
1817	C **************************************************************************
1818	CCC Subroutine Agrif_Update_2D_Recursive
1819	C **************************************************************************
1820	C
1821	Subroutine Agrif_Update_2D_recursive(TypeUpdate,tempP,tempC,
1822	& indmin,indmax,
1823	& pttab_child,petab_child,
1824	& s_child,s_parent,
1825	& ds_child,ds_parent,nbdim)
1826	C
1827	CCC Description:
1828	CCC Subroutine to update a 2D grid variable on the parent grid.
1829	CCC It calls Agrif_Update_1D_Recursive and Agrif_UpdateBase.
1830	C
1831	CC Method:
1832	C
1833	C Declarations:
1834	C
1835
1836	C
1837	INTEGER :: nbdim
1838	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
1839	INTEGER, DIMENSION(nbdim) :: indmin,indmax
1840	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1841	REAL, DIMENSION(nbdim) :: s_child,s_parent
1842	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
1843	REAL, DIMENSION(indmin(1):indmax(1),
1844	& indmin(2):indmax(2)) :: tempP
1845	C REAL, DIMENSION(pttab_child(1):petab_child(1),
1846	C & pttab_child(2):petab_child(2)) :: tempC
1847
1848	REAL, DIMENSION(:,:) :: tempC
1849	C
1850	C Local variables
1851	REAL, DIMENSION(indmin(1):indmax(1),
1852	& pttab_child(2):petab_child(2)) :: tabtemp
1853	REAL, DIMENSION(indmin(2):indmax(2),
1854	& indmin(1):indmax(1)) :: tempP_trsp
1855	REAL, DIMENSION(pttab_child(2):petab_child(2),
1856	& indmin(1):indmax(1)) :: tabtemp_trsp
1857	INTEGER :: i,j
1858	INTEGER :: coeffraf,locind_child_left
1859	C
1860	tabtemp = 0.
1861
1862
1863	coeffraf = nint ( ds_parent(1) / ds_child(1) )
1864	IF((TypeUpdate(1) == AGRIF_Update_average)
1865	& .AND. (coeffraf /= 1 ))THEN
1866	!---CDIR NEXPAND
1867	IF(.NOT. precomputedone(1) ) Call average1Dprecompute2D
1868	& (petab_child(2)-pttab_child(2)+1,
1869	& indmax(1)-indmin(1)+1,
1870	& petab_child(1)-pttab_child(1)+1,
1871	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1872	!---CDIR NEXPAND
1873	Call average1Daftercompute
1874	& ( tabtemp, tempC,
1875	& size(tabtemp), size(tempC),
1876	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1877
1878	ELSEIF((TypeUpdate(1) == AGRIF_Update_copy)
1879	& .AND. (coeffraf /= 1 ))THEN
1880	!---CDIR NEXPAND
1881	IF(.NOT. precomputedone(1) ) Call copy1Dprecompute2D
1882	& (petab_child(2)-pttab_child(2)+1,
1883	& indmax(1)-indmin(1)+1,
1884	& petab_child(1)-pttab_child(1)+1,
1885	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1886	!---CDIR NEXPAND
1887	Call copy1Daftercompute
1888	& ( tabtemp, tempC,
1889	& size(tabtemp), size(tempC),
1890	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1891
1892	ELSE
1893	do j = pttab_child(nbdim),petab_child(nbdim)
1894	C
1895	!---CDIR NEXPAND
1896	Call Agrif_Update_1D_recursive(TypeUpdate(1:nbdim-1),
1897	& tabtemp(:,j),
1898	& tempC(:,j-pttab_child(nbdim)+1),
1899	& indmin(1:nbdim-1),indmax(1:nbdim-1),
1900	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1901	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
1902	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1903	C
1904	enddo
1905	ENDIF
1906	tabtemp_trsp = TRANSPOSE(tabtemp)
1907	coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1908
1909	!---CDIR NEXPAND
1910	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
1911	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
1912	C
1913
1914	tempP_trsp = 0.
1915
1916	IF((TypeUpdate(2) == AGRIF_Update_average)
1917	& .AND. (coeffraf /= 1 ))THEN
1918	!---CDIR NEXPAND
1919	IF(.NOT. precomputedone(2) ) Call average1Dprecompute2D
1920	& ( indmax(1)-indmin(1)+1,
1921	& indmax(2)-indmin(2)+1,
1922	& petab_child(2)-pttab_child(2)+1,
1923	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1924	!---CDIR NEXPAND
1925	Call average1Daftercompute
1926	& ( tempP_trsp, tabtemp_trsp,
1927	& size(tempP_trsp), size(tabtemp_trsp),
1928	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1929
1930	ELSEIF((TypeUpdate(2) == AGRIF_Update_copy)
1931	& .AND. (coeffraf /= 1 ))THEN
1932	!---CDIR NEXPAND
1933	IF(.NOT. precomputedone(2) ) Call copy1Dprecompute2D
1934	& ( indmax(1)-indmin(1)+1,
1935	& indmax(2)-indmin(2)+1,
1936	& petab_child(2)-pttab_child(2)+1,
1937	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1938	!---CDIR NEXPAND
1939	Call copy1Daftercompute
1940	& ( tempP_trsp, tabtemp_trsp,
1941	& size(tempP_trsp), size(tabtemp_trsp),
1942	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1943
1944	ELSE
1945
1946	do i = indmin(1),indmax(1)
1947	C
1948	!---CDIR NEXPAND
1949	Call Agrif_UpdateBase(TypeUpdate(2),
1950	& tempP_trsp(indmin(nbdim):indmax(nbdim),i),
1951	& tabtemp_trsp(pttab_child(nbdim):petab_child(nbdim),i),
1952	& indmin(nbdim),indmax(nbdim),
1953	& pttab_child(nbdim),petab_child(nbdim),
1954	& s_parent(nbdim),s_child(nbdim),
1955	& ds_parent(nbdim),ds_child(nbdim),
1956	& coeffraf,locind_child_left)
1957	C
1958	enddo
1959
1960	ENDIF
1961
1962	tempP = TRANSPOSE(tempP_trsp)
1963	C
1964	Return
1965	C
1966	C
1967	End Subroutine Agrif_Update_2D_recursive
1968	C
1969	C
1970	C
1971	C **************************************************************************
1972	CCC Subroutine Agrif_Update_3D_Recursive
1973	C **************************************************************************
1974	C
1975	Subroutine Agrif_Update_3D_recursive(TypeUpdate,tempP,tempC,
1976	& indmin,indmax,
1977	& pttab_child,petab_child,
1978	& s_child,s_parent,
1979	& ds_child,ds_parent,nbdim)
1980	C
1981	CCC Description:
1982	CCC Subroutine to update a 3D grid variable on the parent grid.
1983	CCC It calls Agrif_Update_2D_Recursive and Agrif_UpdateBase.
1984	C
1985	CC Method:
1986	C
1987	C Declarations:
1988	C
1989
1990	C
1991	INTEGER :: nbdim
1992	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
1993	INTEGER, DIMENSION(nbdim) :: indmin,indmax
1994	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1995	REAL, DIMENSION(nbdim) :: s_child,s_parent
1996	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
1997	REAL, DIMENSION(indmin(1):indmax(1),
1998	& indmin(2):indmax(2),
1999	& indmin(3):indmax(3)) :: tempP
2000	REAL, DIMENSION(pttab_child(1):petab_child(1),
2001	& pttab_child(2):petab_child(2),
2002	& pttab_child(3):petab_child(3)) :: tempC
2003	C
2004	C Local variables
2005	REAL, DIMENSION(indmin(1):indmax(1),
2006	& indmin(2):indmax(2),
2007	& pttab_child(3):petab_child(3)) :: tabtemp
2008	INTEGER :: i,j,k
2009	INTEGER :: coeffraf,locind_child_left
2010	INTEGER :: kdeb
2011	C
2012	C
2013	coeffraf = nint ( ds_parent(1) / ds_child(1) )
2014	IF((TypeUpdate(1) == AGRIF_Update_average)
2015	& .AND. (coeffraf /= 1 ))THEN
2016	!---CDIR NEXPAND
2017	Call average1Dprecompute2D
2018	& (petab_child(2)-pttab_child(2)+1,
2019	& indmax(1)-indmin(1)+1,
2020	& petab_child(1)-pttab_child(1)+1,
2021	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
2022	precomputedone(1) = .TRUE.
2023	ELSEIF((TypeUpdate(1) == AGRIF_Update_copy)
2024	& .AND. (coeffraf /= 1 ))THEN
2025	!---CDIR NEXPAND
2026	Call copy1Dprecompute2D
2027	& (petab_child(2)-pttab_child(2)+1,
2028	& indmax(1)-indmin(1)+1,
2029	& petab_child(1)-pttab_child(1)+1,
2030	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
2031	precomputedone(1) = .TRUE.
2032	ENDIF
2033
2034	coeffraf = nint ( ds_parent(2) / ds_child(2) )
2035	IF((TypeUpdate(2) == AGRIF_Update_average)
2036	& .AND. (coeffraf /= 1 ))THEN
2037	!---CDIR NEXPAND
2038	Call average1Dprecompute2D
2039	& ( indmax(1)-indmin(1)+1,
2040	& indmax(2)-indmin(2)+1,
2041	& petab_child(2)-pttab_child(2)+1,
2042	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
2043	precomputedone(2) = .TRUE.
2044	ELSEIF((TypeUpdate(2) == AGRIF_Update_copy)
2045	& .AND. (coeffraf /= 1 ))THEN
2046	!---CDIR NEXPAND
2047	Call copy1Dprecompute2D
2048	& ( indmax(1)-indmin(1)+1,
2049	& indmax(2)-indmin(2)+1,
2050	& petab_child(2)-pttab_child(2)+1,
2051	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
2052	precomputedone(2) = .TRUE.
2053	ENDIF
2054
2055
2056	do k = pttab_child(nbdim),petab_child(nbdim)
2057	C
2058	Call Agrif_Update_2D_recursive(TypeUpdate(1:nbdim-1),
2059	& tabtemp(:,:,k),
2060	& tempC(:,:,k),
2061	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2062	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2063	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2064	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2065	C
2066	enddo
2067	C
2068	precomputedone(1) = .FALSE.
2069	precomputedone(2) = .FALSE.
2070	coeffraf = nint ( ds_parent(3) / ds_child(3) )
2071
2072	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2073	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2074
2075	IF (coeffraf == 1) THEN
2076
2077	kdeb = pttab_child(3)+locind_child_left-2
2078	do k=indmin(3),indmax(3)
2079	kdeb = kdeb + 1
2080	do j = indmin(2),indmax(2)
2081	do i = indmin(1),indmax(1)
2082	tempP(i,j,k) = tabtemp(i,j,kdeb)
2083	enddo
2084	enddo
2085	enddo
2086
2087	ELSE
2088	tempP = 0.
2089	C
2090	do j = indmin(2),indmax(2)
2091	C
2092	do i = indmin(1),indmax(1)
2093	C
2094	Call Agrif_UpdateBase(TypeUpdate(3),
2095	& tempP(i,j,:),
2096	& tabtemp(i,j,:),
2097	& indmin(nbdim),indmax(nbdim),
2098	& pttab_child(nbdim),petab_child(nbdim),
2099	& s_parent(nbdim),s_child(nbdim),
2100	& ds_parent(nbdim),ds_child(nbdim),
2101	& coeffraf,locind_child_left)
2102	C
2103	enddo
2104	C
2105	enddo
2106	ENDIF
2107	C
2108	Return
2109	C
2110	C
2111	End Subroutine Agrif_Update_3D_recursive
2112	C
2113	C
2114	C
2115	C **************************************************************************
2116	CCC Subroutine Agrif_Update_4D_Recursive
2117	C **************************************************************************
2118	C
2119	Subroutine Agrif_Update_4D_recursive(TypeUpdate,tempP,tempC,
2120	& indmin,indmax,
2121	& pttab_child,petab_child,
2122	& s_child,s_parent,
2123	& ds_child,ds_parent,nbdim)
2124	C
2125	CCC Description:
2126	CCC Subroutine to update a 4D grid variable on the parent grid.
2127	CCC It calls Agrif_Update_3D_Recursive and Agrif_UpdateBase.
2128	C
2129	CC Method:
2130	C
2131	C Declarations:
2132	C
2133
2134	C
2135	INTEGER :: nbdim
2136	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2137	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2138	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2139	REAL, DIMENSION(nbdim) :: s_child,s_parent
2140	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2141	REAL, DIMENSION(indmin(1):indmax(1),
2142	& indmin(2):indmax(2),
2143	& indmin(3):indmax(3),
2144	& indmin(4):indmax(4)) :: tempP
2145	REAL, DIMENSION(pttab_child(1):petab_child(1),
2146	& pttab_child(2):petab_child(2),
2147	& pttab_child(3):petab_child(3),
2148	& pttab_child(4):petab_child(4)) :: tempC
2149	C
2150	C Local variables
2151	REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp
2152	INTEGER :: i,j,k,l
2153	INTEGER :: coeffraf,locind_child_left
2154	C
2155	C
2156	Allocate(tabtemp(indmin(1):indmax(1),
2157	& indmin(2):indmax(2),
2158	& indmin(3):indmax(3),
2159	& pttab_child(4):petab_child(4)))
2160	C
2161	do l = pttab_child(nbdim),petab_child(nbdim)
2162	C
2163	Call Agrif_Update_3D_recursive(TypeUpdate(1:nbdim-1),
2164	& tabtemp(indmin(nbdim-3):indmax(nbdim-3),
2165	& indmin(nbdim-2):indmax(nbdim-2),
2166	& indmin(nbdim-1):indmax(nbdim-1),l),
2167	& tempC(pttab_child(nbdim-3):petab_child(nbdim-3),
2168	& pttab_child(nbdim-2):petab_child(nbdim-2),
2169	& pttab_child(nbdim-1):petab_child(nbdim-1),l),
2170	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2171	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2172	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2173	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2174	C
2175	enddo
2176
2177	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2178	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2179	C
2180	tempP = 0.
2181
2182	do k = indmin(3),indmax(3)
2183	C
2184	do j = indmin(2),indmax(2)
2185	C
2186	do i = indmin(1),indmax(1)
2187	C
2188	Call Agrif_UpdateBase(TypeUpdate(4),
2189	& tempP(i,j,k,indmin(nbdim):indmax(nbdim)),
2190	& tabtemp(i,j,k,pttab_child(nbdim):petab_child(nbdim)),
2191	& indmin(nbdim),indmax(nbdim),
2192	& pttab_child(nbdim),petab_child(nbdim),
2193	& s_parent(nbdim),s_child(nbdim),
2194	& ds_parent(nbdim),ds_child(nbdim),
2195	& coeffraf,locind_child_left)
2196	C
2197	enddo
2198	C
2199	enddo
2200	C
2201	enddo
2202	C
2203	Deallocate(tabtemp)
2204	C
2205	Return
2206	C
2207	C
2208	End Subroutine Agrif_Update_4D_recursive
2209	C
2210	C
2211	C
2212	C **************************************************************************
2213	CCC Subroutine Agrif_Update_5D_Recursive
2214	C **************************************************************************
2215	C
2216	Subroutine Agrif_Update_5D_recursive(TypeUpdate,tempP,tempC,
2217	& indmin,indmax,
2218	& pttab_child,petab_child,
2219	& s_child,s_parent,
2220	& ds_child,ds_parent,nbdim)
2221	C
2222	CCC Description:
2223	CCC Subroutine to update a 5D grid variable on the parent grid.
2224	CCC It calls Agrif_Update_4D_Recursive and Agrif_UpdateBase.
2225	C
2226	CC Method:
2227	C
2228	C Declarations:
2229	C
2230
2231	C
2232	INTEGER :: nbdim
2233	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2234	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2235	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2236	REAL, DIMENSION(nbdim) :: s_child,s_parent
2237	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2238	REAL, DIMENSION(indmin(1):indmax(1),
2239	& indmin(2):indmax(2),
2240	& indmin(3):indmax(3),
2241	& indmin(4):indmax(4),
2242	& indmin(5):indmax(5)) :: tempP
2243	REAL, DIMENSION(pttab_child(1):petab_child(1),
2244	& pttab_child(2):petab_child(2),
2245	& pttab_child(3):petab_child(3),
2246	& pttab_child(4):petab_child(4),
2247	& pttab_child(5):petab_child(5)) :: tempC
2248	C
2249	C Local variables
2250	REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp
2251	INTEGER :: i,j,k,l,m
2252	INTEGER :: coeffraf,locind_child_left
2253	C
2254	C
2255	Allocate(tabtemp(indmin(1):indmax(1),
2256	& indmin(2):indmax(2),
2257	& indmin(3):indmax(3),
2258	& indmin(4):indmax(4),
2259	& pttab_child(5):petab_child(5)))
2260	C
2261	do m = pttab_child(nbdim),petab_child(nbdim)
2262	C
2263	Call Agrif_Update_4D_recursive(TypeUpdate(1:nbdim-1),
2264	& tabtemp(indmin(nbdim-4):indmax(nbdim-4),
2265	& indmin(nbdim-3):indmax(nbdim-3),
2266	& indmin(nbdim-2):indmax(nbdim-2),
2267	& indmin(nbdim-1):indmax(nbdim-1),m),
2268	& tempC(pttab_child(nbdim-4):petab_child(nbdim-4),
2269	& pttab_child(nbdim-3):petab_child(nbdim-3),
2270	& pttab_child(nbdim-2):petab_child(nbdim-2),
2271	& pttab_child(nbdim-1):petab_child(nbdim-1),m),
2272	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2273	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2274	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2275	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2276	C
2277	enddo
2278
2279	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2280	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2281	tempP = 0.
2282	C
2283	do l = indmin(4),indmax(4)
2284	C
2285	do k = indmin(3),indmax(3)
2286	C
2287	do j = indmin(2),indmax(2)
2288	C
2289	do i = indmin(1),indmax(1)
2290	C
2291	Call Agrif_UpdateBase(TypeUpdate(5),
2292	& tempP(i,j,k,l,indmin(nbdim):indmax(nbdim)),
2293	& tabtemp(i,j,k,l,
2294	& pttab_child(nbdim):petab_child(nbdim)),
2295	& indmin(nbdim),indmax(nbdim),
2296	& pttab_child(nbdim),petab_child(nbdim),
2297	& s_parent(nbdim),s_child(nbdim),
2298	& ds_parent(nbdim),ds_child(nbdim),
2299	& coeffraf,locind_child_left)
2300	C
2301	enddo
2302	C
2303	enddo
2304	C
2305	enddo
2306	C
2307	enddo
2308	C
2309	Deallocate(tabtemp)
2310	C
2311	Return
2312	C
2313	C
2314	End Subroutine Agrif_Update_5D_recursive
2315	C
2316	C
2317	C
2318	C
2319	C **************************************************************************
2320	CCC Subroutine Agrif_Update_6D_Recursive
2321	C **************************************************************************
2322	C
2323	Subroutine Agrif_Update_6D_recursive(TypeUpdate,tempP,tempC,
2324	& indmin,indmax,
2325	& pttab_child,petab_child,
2326	& s_child,s_parent,
2327	& ds_child,ds_parent,nbdim)
2328	C
2329	CCC Description:
2330	CCC Subroutine to update a 6D grid variable on the parent grid.
2331	CCC It calls Agrif_Update_5D_Recursive and Agrif_UpdateBase.
2332	C
2333	CC Method:
2334	C
2335	C Declarations:
2336	C
2337
2338	C
2339	INTEGER :: nbdim
2340	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2341	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2342	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2343	REAL, DIMENSION(nbdim) :: s_child,s_parent
2344	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2345	REAL, DIMENSION(indmin(1):indmax(1),
2346	& indmin(2):indmax(2),
2347	& indmin(3):indmax(3),
2348	& indmin(4):indmax(4),
2349	& indmin(5):indmax(5),
2350	& indmin(6):indmax(6)) :: tempP
2351	REAL, DIMENSION(pttab_child(1):petab_child(1),
2352	& pttab_child(2):petab_child(2),
2353	& pttab_child(3):petab_child(3),
2354	& pttab_child(4):petab_child(4),
2355	& pttab_child(5):petab_child(5),
2356	& pttab_child(6):petab_child(6)) :: tempC
2357	C
2358	C Local variables
2359	REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp
2360	INTEGER :: i,j,k,l,m,n
2361	INTEGER :: coeffraf,locind_child_left
2362	C
2363	C
2364	Allocate(tabtemp(indmin(1):indmax(1),
2365	& indmin(2):indmax(2),
2366	& indmin(3):indmax(3),
2367	& indmin(4):indmax(4),
2368	& indmin(5):indmax(5),
2369	& pttab_child(6):petab_child(6)))
2370	C
2371	do n = pttab_child(nbdim),petab_child(nbdim)
2372	C
2373	Call Agrif_Update_5D_recursive(TypeUpdate(1:nbdim-1),
2374	& tabtemp(indmin(nbdim-5):indmax(nbdim-5),
2375	& indmin(nbdim-4):indmax(nbdim-4),
2376	& indmin(nbdim-3):indmax(nbdim-3),
2377	& indmin(nbdim-2):indmax(nbdim-2),
2378	& indmin(nbdim-1):indmax(nbdim-1),n),
2379	& tempC(pttab_child(nbdim-5):petab_child(nbdim-5),
2380	& pttab_child(nbdim-4):petab_child(nbdim-4),
2381	& pttab_child(nbdim-3):petab_child(nbdim-3),
2382	& pttab_child(nbdim-2):petab_child(nbdim-2),
2383	& pttab_child(nbdim-1):petab_child(nbdim-1),n),
2384	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2385	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2386	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2387	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2388	C
2389	enddo
2390
2391	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2392	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2393	C
2394	tempP = 0.
2395
2396	do m = indmin(5),indmax(5)
2397	do l = indmin(4),indmax(4)
2398	C
2399	do k = indmin(3),indmax(3)
2400	C
2401	do j = indmin(2),indmax(2)
2402	C
2403	do i = indmin(1),indmax(1)
2404	C
2405	Call Agrif_UpdateBase(TypeUpdate(6),
2406	& tempP(i,j,k,l,m,indmin(nbdim):indmax(nbdim)),
2407	& tabtemp(i,j,k,l,m,
2408	& pttab_child(nbdim):petab_child(nbdim)),
2409	& indmin(nbdim),indmax(nbdim),
2410	& pttab_child(nbdim),petab_child(nbdim),
2411	& s_parent(nbdim),s_child(nbdim),
2412	& ds_parent(nbdim),ds_child(nbdim),
2413	& coeffraf,locind_child_left)
2414	C
2415	enddo
2416	C
2417	enddo
2418	C
2419	enddo
2420	C
2421	enddo
2422	enddo
2423	C
2424	Deallocate(tabtemp)
2425	C
2426	Return
2427	C
2428	C
2429	End Subroutine Agrif_Update_6D_recursive
2430	C
2431	C
2432	C
2433	C **************************************************************************
2434	CCC Subroutine Agrif_UpdateBase
2435	C **************************************************************************
2436	C
2437	Subroutine Agrif_UpdateBase(TypeUpdate,
2438	& parenttab,childtab,
2439	& indmin,indmax,pttab_child,petab_child,
2440	& s_parent,s_child,ds_parent,ds_child,
2441	& coeffraf,locind_child_left)
2442	C
2443	CCC Description:
2444	CCC Subroutine calling the updating method chosen by the user (copy, average
2445	CCC or full-weighting).
2446	C
2447	CC Method:
2448	C
2449	C Declarations:
2450	C
2451
2452	C
2453	INTEGER :: TypeUpdate
2454	INTEGER :: indmin,indmax
2455	INTEGER :: pttab_child,petab_child
2456	REAL,DIMENSION(indmin:indmax) :: parenttab
2457	REAL,DIMENSION(pttab_child:petab_child) :: childtab
2458	REAL :: s_parent,s_child
2459	REAL :: ds_parent,ds_child
2460	INTEGER :: coeffraf,locind_child_left
2461	C
2462	C
2463	if (TypeUpdate == AGRIF_Update_copy) then
2464	C
2465	Call agrif_copy1D
2466	& (parenttab,childtab,
2467	& indmax-indmin+1,petab_child-pttab_child+1,
2468	& s_parent,s_child,ds_parent,ds_child)
2469	C
2470	elseif (TypeUpdate == AGRIF_Update_average) then
2471	C
2472	Call average1D
2473	& (parenttab,childtab,
2474	& indmax-indmin+1,petab_child-pttab_child+1,
2475	& s_parent,s_child,ds_parent,ds_child)
2476	C
2477	elseif (TypeUpdate == AGRIF_Update_full_weighting) then
2478	C
2479	Call full_weighting1D
2480	& (parenttab,childtab,
2481	& indmax-indmin+1,petab_child-pttab_child+1,
2482	& s_parent,s_child,ds_parent,ds_child,
2483	& coeffraf,locind_child_left)
2484	C
2485	endif
2486	C
2487	Return
2488	C
2489	C
2490	End Subroutine Agrif_UpdateBase
2491	C
2492	C
2493
2494	Subroutine Agrif_Compute_nbdim_update(s_parent,s_child,
2495	& ds_parent,ds_child,coeffraf,locind_child_left)
2496	real :: s_parent,s_child,ds_parent,ds_child
2497	integer :: coeffraf,locind_child_left
2498
2499	coeffraf = nint(ds_parent/ds_child)
2500	locind_child_left = 1 + agrif_int((s_parent-s_child)/ds_child)
2501
2502	End Subroutine Agrif_Compute_nbdim_update
2503
2504	#if defined AGRIF_MPI
2505	Subroutine Agrif_Find_list_update(list_update,pttab,petab,
2506	& pttab_Child,pttab_Parent,nbdim,
2507	& find_list_update,tab4t,tab5t,memberinall,memberinall2,
2508	& sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
2509	TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
2510	INTEGER :: nbdim
2511	INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
2512	LOGICAL :: find_list_update
2513	Type(Agrif_List_Interp_loc), Pointer :: parcours
2514	INTEGER :: i
2515	C
2516	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
2517	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t
2518	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall,memberinall2
2519	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
2520	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2
2521
2522	find_list_update = .FALSE.
2523
2524	parcours => list_update
2525
2526	Find_loop : Do While (associated(parcours))
2527	Do i=1,nbdim
2528	IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
2529	& (petab(i) /= parcours%interp_loc%petab(i)).OR.
2530	& (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
2531	& (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
2532	& THEN
2533	parcours=>parcours%suiv
2534	Cycle Find_loop
2535	ENDIF
2536	EndDo
2537
2538	tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:8)
2539	memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
2540
2541	tab5t = parcours%interp_loc%tab5t(1:nbdim,0:Agrif_Nbprocs-1,1:8)
2542	memberinall2 =
2543	& parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1)
2544	sendtoproc1 =
2545	& parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1)
2546	recvfromproc1 =
2547	& parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1)
2548	sendtoproc2 =
2549	& parcours%interp_loc%sendtoproc2(0:Agrif_Nbprocs-1)
2550	recvfromproc2 =
2551	& parcours%interp_loc%recvfromproc2(0:Agrif_Nbprocs-1)
2552
2553	find_list_update = .TRUE.
2554	Exit Find_loop
2555	End Do Find_loop
2556
2557	End Subroutine Agrif_Find_list_update
2558
2559	Subroutine Agrif_AddTo_list_update(list_update,pttab,petab,
2560	& pttab_Child,pttab_Parent,nbdim
2561	& ,tab4t,tab5t,memberinall,memberinall2,
2562	& sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
2563
2564	TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
2565	INTEGER :: nbdim
2566	INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
2567	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
2568	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t
2569	LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
2570	LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1, recvfromproc1
2571	LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc2, recvfromproc2
2572
2573	Type(Agrif_List_Interp_loc), Pointer :: parcours
2574
2575	Allocate(parcours)
2576	Allocate(parcours%interp_loc)
2577
2578	parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
2579	parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
2580	parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
2581	parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
2582	Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,8))
2583	Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
2584
2585	Allocate(parcours%interp_loc%tab5t(nbdim,0:Agrif_Nbprocs-1,8))
2586	Allocate(parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1))
2587	Allocate(parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1))
2588	Allocate(parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1))
2589	Allocate(parcours%interp_loc%sendtoproc2(0:Agrif_Nbprocs-1))
2590	Allocate(parcours%interp_loc%recvfromproc2(0:Agrif_Nbprocs-1))
2591
2592	parcours%interp_loc%tab4t=tab4t
2593	parcours%interp_loc%memberinall=memberinall
2594
2595	parcours%interp_loc%tab5t=tab5t
2596	parcours%interp_loc%memberinall2=memberinall2
2597	parcours%interp_loc%sendtoproc1=sendtoproc1
2598	parcours%interp_loc%recvfromproc1=recvfromproc1
2599	parcours%interp_loc%sendtoproc2=sendtoproc2
2600	parcours%interp_loc%recvfromproc2=recvfromproc2
2601
2602	parcours%suiv => list_update
2603
2604	list_update => parcours
2605
2606	End Subroutine Agrif_Addto_list_update
2607	#endif
2608
2609
2610	C **************************************************************************
2611	CCC Subroutine Agrif_Update_1D_Recursive
2612	C **************************************************************************
2613	C
2614	Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC,
2615	& indmin,indmax,
2616	& pttab_child,petab_child,
2617	& s_child,s_parent,
2618	& ds_child,ds_parent,nbdim)
2619	C
2620	CCC Description:
2621	CCC Subroutine to update a 1D grid variable on the parent grid.
2622	C
2623	CC Method:
2624	C
2625	C Declarations:
2626	C
2627
2628	C
2629	C Arguments
2630	INTEGER :: nbdim
2631	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2632	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2633	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2634	REAL, DIMENSION(nbdim) :: s_child,s_parent
2635	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2636	REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tempP
2637	REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC
2638	INTEGER :: coeffraf,locind_child_left
2639	C
2640	C
2641	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2642	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2643
2644	Call Agrif_UpdateBase(TypeUpdate(1),
2645	& tempP(indmin(nbdim):indmax(nbdim)),
2646	& tempC(pttab_child(nbdim):petab_child(nbdim)),
2647	& indmin(nbdim),indmax(nbdim),
2648	& pttab_child(nbdim),petab_child(nbdim),
2649	& s_parent(nbdim),s_child(nbdim),
2650	& ds_parent(nbdim),ds_child(nbdim),
2651	& coeffraf,locind_child_left)
2652
2653	C
2654	Return
2655	C
2656	C
2657	End Subroutine Agrif_Update_1D_recursive
2658
2659	End Module Agrif_Update

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

Download in other formats: