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 @ 779

Last change on this file since 779 was 779, checked in by rblod, 16 years ago
Agrif improvment for vectorization, see ticket #41
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 91.8 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	INTEGER :: code
1104	INTEGER :: i,j,k
1105	INTEGER,DIMENSION(nbdim,4) :: tab3
1106	INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4
1107	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t
1108	LOGICAL :: find_list_update
1109	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
1110	LOGICAL, DIMENSION(1) :: memberin1
1111	C
1112	#endif
1113	C
1114
1115	C
1116	C local lbound and ubound of the child array
1117
1118	Call Agrif_nbdim_Get_bound_dimension(child%var,
1119	& lowerbound,upperbound,nbdim)
1120
1121	C here pttab and petab corresponds to the (global) indices of the points needed
1122	C in the update
1123	C pttruetab and cetruetab contains only indices that are present
1124	C on the local processor
1125
1126	Call Agrif_Childbounds(nbdim,
1127	& lowerbound,upperbound,
1128	& pttab,petab,
1129	& pttruetab,cetruetab,memberin)
1130
1131	Call Agrif_Prtbounds(nbdim,indminglob,indmaxglob,s_Parent_temp,
1132	& s_Child_temp,s_Child,ds_Child,
1133	& s_Parent,ds_Parent,
1134	& pttab,petab,pttab_Child,
1135	& pttab_Parent,
1136	& posvartab_Child,TypeUpdate,loctab_Child
1137	#ifdef AGRIF_MPI
1138	& ,pttruetabwhole,cetruetabwhole
1139	#endif
1140	& )
1141
1142	#ifdef AGRIF_MPI
1143	IF (memberin) THEN
1144	Call Agrif_GlobtoLocInd2(childarray,
1145	& lowerbound,upperbound,
1146	& pttruetab,cetruetab,
1147	& nbdim,Agrif_Procrank,
1148	& member)
1149
1150	ENDIF
1151
1152
1153	Call Agrif_Prtbounds(nbdim,indmin,indmax,s_Parent_temp,
1154	& s_Child_temp,s_Child,ds_Child,
1155	& s_Parent,ds_Parent,
1156	& pttruetab,cetruetab,pttab_Child,
1157	& pttab_Parent,
1158	& posvartab_Child,TypeUpdate,loctab_Child
1159	& ,pttruetabwhole,cetruetabwhole
1160	& )
1161
1162	#else
1163	indmin = indminglob
1164	indmax = indmaxglob
1165	pttruetabwhole = pttruetab
1166	cetruetabwhole = cetruetab
1167	childarray(:,1,2) = pttruetab
1168	childarray(:,2,2) = cetruetab
1169	#endif
1170
1171	IF (present(procname)) THEN
1172	IF (.Not.present(nb)) THEN
1173	nbin=0
1174	ndirin=0
1175	ELSE
1176	nbin = nb
1177	ndirin = ndir
1178	ENDIF
1179	ENDIF
1180
1181	IF (memberin) THEN
1182	IF (.not.associated(tempC%var)) allocate(tempC%var)
1183
1184	C
1185	Call Agrif_nbdim_allocation(tempC%var,
1186	& pttruetab,cetruetab,nbdim)
1187
1188	Call Agrif_nbdim_Full_VarEQreal(tempC%var,0.,nbdim)
1189
1190
1191
1192	IF (present(procname)) THEN
1193	SELECT CASE (nbdim)
1194	CASE(1)
1195	CALL procname(tempC%var%array1,
1196	& childarray(1,1,2),childarray(1,2,2),
1197	& .TRUE.,nbin,ndirin)
1198	CASE(2)
1199	CALL procname(tempC%var%array2,
1200	& childarray(1,1,2),childarray(1,2,2),
1201	& childarray(2,1,2),childarray(2,2,2),
1202	& .TRUE.,nbin,ndirin)
1203	CASE(3)
1204	CALL procname(tempC%var%array3,
1205	& childarray(1,1,2),childarray(1,2,2),
1206	& childarray(2,1,2),childarray(2,2,2),
1207	& childarray(3,1,2),childarray(3,2,2),
1208	& .TRUE.,nbin,ndirin)
1209	CASE(4)
1210	CALL procname(tempC%var%array4,
1211	& childarray(1,1,2),childarray(1,2,2),
1212	& childarray(2,1,2),childarray(2,2,2),
1213	& childarray(3,1,2),childarray(3,2,2),
1214	& childarray(4,1,2),childarray(4,2,2),
1215	& .TRUE.,nbin,ndirin)
1216	CASE(5)
1217	CALL procname(tempC%var%array5,
1218	& childarray(1,1,2),childarray(1,2,2),
1219	& childarray(2,1,2),childarray(2,2,2),
1220	& childarray(3,1,2),childarray(3,2,2),
1221	& childarray(4,1,2),childarray(4,2,2),
1222	& childarray(5,1,2),childarray(5,2,2),
1223	& .TRUE.,nbin,ndirin)
1224	CASE(6)
1225	CALL procname(tempC%var%array6,
1226	& childarray(1,1,2),childarray(1,2,2),
1227	& childarray(2,1,2),childarray(2,2,2),
1228	& childarray(3,1,2),childarray(3,2,2),
1229	& childarray(4,1,2),childarray(4,2,2),
1230	& childarray(5,1,2),childarray(5,2,2),
1231	& childarray(6,1,2),childarray(6,2,2),
1232	& .TRUE.,nbin,ndirin)
1233	END SELECT
1234	ELSE
1235	Call Agrif_nbdim_VarEQvar(tempC%var,pttruetab,cetruetab,
1236	& child%var,childarray(:,1,2),childarray(:,2,2),
1237	& nbdim)
1238	ENDIF
1239
1240	ENDIF
1241
1242
1243
1244	C
1245	C
1246	#ifdef AGRIF_MPI
1247	C
1248	C tab2 contains the necessary limits of the parent grid for each processor
1249
1250	IF (Associated(child%var%list_update)) THEN
1251	Call Agrif_Find_list_update(child%var%list_update,pttab,petab,
1252	& pttab_Child,pttab_Parent,nbdim,
1253	& find_list_update,tab4t,tab5t,memberinall,memberinall2)
1254	ELSE
1255	find_list_update = .FALSE.
1256	ENDIF
1257
1258	if (.not.find_list_update) then
1259	tab3(:,1) = pttruetab(:)
1260	tab3(:,2) = cetruetab(:)
1261	tab3(:,3) = pttruetabwhole(:)
1262	tab3(:,4) = cetruetabwhole(:)
1263	C
1264	C
1265	Call MPI_ALLGATHER(tab3,4nbdim,MPI_INTEGER,tab4,4nbdim,
1266	& MPI_INTEGER,MPI_COMM_WORLD,code)
1267
1268	IF (.not.associated(tempCextend%var)) Allocate(tempCextend%var)
1269	DO k=0,Agrif_Nbprocs-1
1270	do j=1,4
1271	do i=1,nbdim
1272	tab4t(i,k,j) = tab4(i,j,k)
1273	enddo
1274	enddo
1275	enddo
1276
1277	memberin1(1) = memberin
1278	CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
1279	& 1,MPI_LOGICAL,MPI_COMM_WORLD,code)
1280
1281	endif
1282
1283	Call Get_External_Data(tempC,tempCextend,tab4t(:,:,1),
1284	& tab4t(:,:,2),
1285	& tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin,
1286	& memberinall)
1287
1288	#else
1289	tempCextend%var => tempC%var
1290	#endif
1291
1292	C
1293	C
1294	C Update of the parent grid (tempP) from the child grid (tempC)
1295
1296
1297	IF (memberin) THEN
1298
1299	IF (.not.associated(tempP%var)) allocate(tempP%var)
1300	Call Agrif_nbdim_allocation(tempP%var,
1301	& indmin,indmax,nbdim)
1302
1303	if ( nbdim .EQ. 1 ) then
1304	tempP%var%array1 = 0.
1305	Call Agrif_Update_1D_recursive(TypeUpdate,
1306	& tempP%var%array1,tempCextend%var%array1,
1307	& indmin,indmax,
1308	& pttruetabwhole,cetruetabwhole,
1309	& s_Child_temp,s_Parent_temp,
1310	& ds_Child,ds_Parent,nbdim)
1311	endif
1312	if ( nbdim .EQ. 2 ) then
1313	Call Agrif_Update_2D_recursive(TypeUpdate,
1314	& tempP%var%array2,tempCextend%var%array2,
1315	& indmin,indmax,
1316	& pttruetabwhole,cetruetabwhole,
1317	& s_Child_temp,s_Parent_temp,
1318	& ds_Child,ds_Parent,nbdim)
1319	endif
1320
1321	if ( nbdim .EQ. 3 ) then
1322	Call Agrif_Update_3D_recursive(TypeUpdate,
1323	& tempP%var%array3,tempCextend%var%array3,
1324	& indmin,indmax,
1325	& pttruetabwhole,cetruetabwhole,
1326	& s_Child_temp,s_Parent_temp,
1327	& ds_Child,ds_Parent,nbdim)
1328	endif
1329	if ( nbdim .EQ. 4 ) then
1330	Call Agrif_Update_4D_recursive(TypeUpdate,
1331	& tempP%var%array4,tempCextend%var%array4,
1332	& indmin,indmax,
1333	& pttruetabwhole,cetruetabwhole,
1334	& s_Child_temp,s_Parent_temp,
1335	& ds_Child,ds_Parent,nbdim)
1336	endif
1337	if ( nbdim .EQ. 5 ) then
1338	Call Agrif_Update_5D_recursive(TypeUpdate,
1339	& tempP%var%array5,tempCextend%var%array5,
1340	& indmin,indmax,
1341	& pttruetabwhole,cetruetabwhole,
1342	& s_Child_temp,s_Parent_temp,
1343	& ds_Child,ds_Parent,nbdim)
1344	endif
1345	if ( nbdim .EQ. 6 ) then
1346	Call Agrif_Update_6D_recursive(TypeUpdate,
1347	& tempP%var%array6,tempCextend%var%array6,
1348	& indmin,indmax,
1349	& pttruetabwhole,cetruetabwhole,
1350	& s_Child_temp,s_Parent_temp,
1351	& ds_Child,ds_Parent,nbdim)
1352	endif
1353
1354	Call Agrif_nbdim_deallocation(tempCextend%var,nbdim)
1355	C Deallocate(tempCextend%var)
1356
1357	ENDIF
1358
1359	#ifdef AGRIF_MPI
1360	Call Agrif_nbdim_Get_bound_dimension(parent%var,
1361	& lowerbound,upperbound,nbdim)
1362
1363	Call Agrif_ChildGrid_to_ParentGrid()
1364	C
1365	Call Agrif_Childbounds(nbdim,
1366	& lowerbound,upperbound,
1367	& indminglob,indmaxglob,
1368	& indminglob2,indmaxglob2,member)
1369	C
1370	IF (member) THEN
1371	Call Agrif_GlobtoLocInd2(parentarray,
1372	& lowerbound,upperbound,
1373	& indminglob2,indmaxglob2,
1374	& nbdim,Agrif_Procrank,
1375	& member)
1376	ENDIF
1377
1378	Call Agrif_ParentGrid_to_ChildGrid()
1379
1380	if (.not.find_list_update) then
1381	tab3(:,1) = indmin(:)
1382	tab3(:,2) = indmax(:)
1383	tab3(:,3) = indminglob2(:)
1384	tab3(:,4) = indmaxglob2(:)
1385	C
1386	Call MPI_ALLGATHER(tab3,4nbdim,MPI_INTEGER,tab4,4nbdim,
1387	& MPI_INTEGER,MPI_COMM_WORLD,code)
1388
1389	IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
1390	DO k=0,Agrif_Nbprocs-1
1391	do j=1,4
1392	do i=1,nbdim
1393	tab5t(i,k,j) = tab4(i,j,k)
1394	enddo
1395	enddo
1396	enddo
1397
1398	memberin1(1) = member
1399	CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2,
1400	& 1,MPI_LOGICAL,MPI_COMM_WORLD,code)
1401
1402	Call Agrif_Addto_list_update(child%var%list_update,pttab,petab,
1403	& pttab_Child,pttab_Parent,nbdim
1404	& ,tab4t,tab5t,memberinall,memberinall2)
1405
1406	endif
1407
1408	Call Get_External_Data(tempP,tempPextend,tab5t(:,:,1),
1409	& tab5t(:,:,2),
1410	& tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member,
1411	& memberinall2)
1412
1413	#else
1414	tempPextend%var => tempP%var
1415	parentarray(:,1,1) = indmin
1416	parentarray(:,2,1) = indmax
1417	parentarray(:,1,2) = indmin
1418	parentarray(:,2,2) = indmax
1419	member = .TRUE.
1420	#endif
1421
1422	C
1423	C
1424	C
1425	C Special values on the child grid
1426	if (Agrif_UseSpecialValueFineGrid) then
1427	C
1428	ccc noraftab(1:nbdim) =
1429	ccc & child % var % root_var % interptab(1:nbdim) .EQ. 'N'
1430	C
1431	#ifdef AGRIF_MPI
1432	C
1433	c Allocate(childvalues% var)
1434	C
1435	c Call Agrif_nbdim_allocation(childvalues%var,
1436	c & pttruetab,cetruetab,nbdim)
1437	c Call Agrif_nbdim_Full_VarEQvar(childvalues% var,
1438	c & tempC% var,
1439	c & nbdim)
1440	c Call Agrif_CheckMasknD(tempC,childvalues,
1441	c & pttruetab(1:nbdim),cetruetab(1:nbdim),
1442	c & pttruetab(1:nbdim),cetruetab(1:nbdim),
1443	c & noraftab(1:nbdim),nbdim)
1444	c Call Agrif_nbdim_deallocation(childvalues% var,nbdim)
1445	c Deallocate(childvalues % var)
1446	C
1447	#else
1448	C
1449	c Call Agrif_nbdim_Get_bound_dimension(child%var,
1450	c & lowerbound,upperbound,nbdim)
1451	c Call Agrif_CheckMasknD(tempC,child,
1452	c & pttruetab(1:nbdim),cetruetab(1:nbdim),
1453	c & lowerbound,
1454	c & upperbound,
1455	c & noraftab(1:nbdim),nbdim)
1456	C
1457	#endif
1458	C
1459	endif
1460
1461
1462	C
1463	C
1464	C
1465	C
1466	C Special values on the parent grid
1467	if (Agrif_UseSpecialValue) then
1468	C
1469	#ifdef AGRIF_MPI
1470	C
1471	c Call GiveAgrif_SpecialValueToTab_mpi(parent%var,tempP%var,
1472	c & parentarray,
1473	c & indmin,indmax,
1474	c & Agrif_SpecialValue,nbdim)
1475	C
1476	C
1477	#else
1478	C
1479	c Call GiveAgrif_SpecialValueToTab(parent%var,tempP%var,
1480	c & indmin,indmax,
1481	c & Agrif_SpecialValue,nbdim)
1482	C
1483	#endif
1484	C
1485	C
1486	endif
1487	C
1488	C
1489	IF (member) THEN
1490
1491	IF (present(procname)) THEN
1492	CALL Agrif_ChildGrid_to_ParentGrid()
1493	SELECT CASE(nbdim)
1494	CASE(1)
1495	CALL procname(
1496	& tempPextend%var%array1(
1497	& parentarray(1,1,1):parentarray(1,2,1)),
1498	& parentarray(1,1,2),parentarray(1,2,2),
1499	& .FALSE.,nbin,ndirin
1500	& )
1501	CASE(2)
1502	CALL procname(
1503	& tempPextend%var%array2(
1504	& parentarray(1,1,1):parentarray(1,2,1),
1505	& parentarray(2,1,1):parentarray(2,2,1)),
1506	& parentarray(1,1,2),parentarray(1,2,2),
1507	& parentarray(2,1,2),parentarray(2,2,2),
1508	& .FALSE.,nbin,ndirin
1509	& )
1510	CASE(3)
1511	CALL procname(
1512	& tempPextend%var%array3(
1513	& parentarray(1,1,1):parentarray(1,2,1),
1514	& parentarray(2,1,1):parentarray(2,2,1),
1515	& parentarray(3,1,1):parentarray(3,2,1)),
1516	& parentarray(1,1,2),parentarray(1,2,2),
1517	& parentarray(2,1,2),parentarray(2,2,2),
1518	& parentarray(3,1,2),parentarray(3,2,2),
1519	& .FALSE.,nbin,ndirin
1520	& )
1521	CASE(4)
1522	CALL procname(
1523	& tempPextend%var%array4(
1524	& parentarray(1,1,1):parentarray(1,2,1),
1525	& parentarray(2,1,1):parentarray(2,2,1),
1526	& parentarray(3,1,1):parentarray(3,2,1),
1527	& parentarray(4,1,1):parentarray(4,2,1)),
1528	& parentarray(1,1,2),parentarray(1,2,2),
1529	& parentarray(2,1,2),parentarray(2,2,2),
1530	& parentarray(3,1,2),parentarray(3,2,2),
1531	& parentarray(4,1,2),parentarray(4,2,2),
1532	& .FALSE.,nbin,ndirin
1533	& )
1534	CASE(5)
1535	CALL procname(
1536	& tempPextend%var%array5(
1537	& parentarray(1,1,1):parentarray(1,2,1),
1538	& parentarray(2,1,1):parentarray(2,2,1),
1539	& parentarray(3,1,1):parentarray(3,2,1),
1540	& parentarray(4,1,1):parentarray(4,2,1),
1541	& parentarray(5,1,1):parentarray(5,2,1)),
1542	& parentarray(1,1,2),parentarray(1,2,2),
1543	& parentarray(2,1,2),parentarray(2,2,2),
1544	& parentarray(3,1,2),parentarray(3,2,2),
1545	& parentarray(4,1,2),parentarray(4,2,2),
1546	& parentarray(5,1,2),parentarray(5,2,2),
1547	& .FALSE.,nbin,ndirin
1548	& )
1549	CASE(6)
1550	CALL procname(
1551	& tempPextend%var%array6(
1552	& parentarray(1,1,1):parentarray(1,2,1),
1553	& parentarray(2,1,1):parentarray(2,2,1),
1554	& parentarray(3,1,1):parentarray(3,2,1),
1555	& parentarray(4,1,1):parentarray(4,2,1),
1556	& parentarray(5,1,1):parentarray(5,2,1),
1557	& parentarray(6,1,1):parentarray(6,2,1)),
1558	& parentarray(1,1,2),parentarray(1,2,2),
1559	& parentarray(2,1,2),parentarray(2,2,2),
1560	& parentarray(3,1,2),parentarray(3,2,2),
1561	& parentarray(4,1,2),parentarray(4,2,2),
1562	& parentarray(5,1,2),parentarray(5,2,2),
1563	& parentarray(6,1,2),parentarray(6,2,2),
1564	& .FALSE.,nbin,ndirin
1565	& )
1566	END SELECT
1567	CALL Agrif_ParentGrid_to_ChildGrid()
1568	ELSE
1569	SELECT CASE(nbdim)
1570	CASE(1)
1571	parent%var%array1(parentarray(1,1,2):parentarray(1,2,2)) =
1572	& tempPextend%var%array1(
1573	& parentarray(1,1,1):parentarray(1,2,1))
1574	CASE(2)
1575	parent%var%array2(parentarray(1,1,2):parentarray(1,2,2),
1576	& parentarray(2,1,2):parentarray(2,2,2)) =
1577	& tempPextend%var%array2(
1578	& parentarray(1,1,1):parentarray(1,2,1),
1579	& parentarray(2,1,1):parentarray(2,2,1))
1580	CASE(3)
1581	parent%var%array3(parentarray(1,1,2):parentarray(1,2,2),
1582	& parentarray(2,1,2):parentarray(2,2,2),
1583	& parentarray(3,1,2):parentarray(3,2,2)) =
1584	& tempPextend%var%array3(
1585	& parentarray(1,1,1):parentarray(1,2,1),
1586	& parentarray(2,1,1):parentarray(2,2,1),
1587	& parentarray(3,1,1):parentarray(3,2,1))
1588	CASE(4)
1589	parent%var%array4(parentarray(1,1,2):parentarray(1,2,2),
1590	& parentarray(2,1,2):parentarray(2,2,2),
1591	& parentarray(3,1,2):parentarray(3,2,2),
1592	& parentarray(4,1,2):parentarray(4,2,2)) =
1593	& tempPextend%var%array4(
1594	& parentarray(1,1,1):parentarray(1,2,1),
1595	& parentarray(2,1,1):parentarray(2,2,1),
1596	& parentarray(3,1,1):parentarray(3,2,1),
1597	& parentarray(4,1,1):parentarray(4,2,1))
1598	CASE(5)
1599	parent%var%array5(parentarray(1,1,2):parentarray(1,2,2),
1600	& parentarray(2,1,2):parentarray(2,2,2),
1601	& parentarray(3,1,2):parentarray(3,2,2),
1602	& parentarray(4,1,2):parentarray(4,2,2),
1603	& parentarray(5,1,2):parentarray(5,2,2)) =
1604	& tempPextend%var%array5(
1605	& parentarray(1,1,1):parentarray(1,2,1),
1606	& parentarray(2,1,1):parentarray(2,2,1),
1607	& parentarray(3,1,1):parentarray(3,2,1),
1608	& parentarray(4,1,1):parentarray(4,2,1),
1609	& parentarray(5,1,1):parentarray(5,2,1))
1610	CASE(6)
1611	parent%var%array6(parentarray(1,1,2):parentarray(1,2,2),
1612	& parentarray(2,1,2):parentarray(2,2,2),
1613	& parentarray(3,1,2):parentarray(3,2,2),
1614	& parentarray(4,1,2):parentarray(4,2,2),
1615	& parentarray(5,1,2):parentarray(5,2,2),
1616	& parentarray(6,1,2):parentarray(6,2,2)) =
1617	& tempPextend%var%array6(
1618	& parentarray(1,1,1):parentarray(1,2,1),
1619	& parentarray(2,1,1):parentarray(2,2,1),
1620	& parentarray(3,1,1):parentarray(3,2,1),
1621	& parentarray(4,1,1):parentarray(4,2,1),
1622	& parentarray(5,1,1):parentarray(5,2,1),
1623	& parentarray(6,1,1):parentarray(6,2,1))
1624	END SELECT
1625	ENDIF
1626
1627	Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
1628	ENDIF
1629	C
1630	C
1631	C Deallocations
1632
1633	IF (memberin) THEN
1634	#ifdef AGRIF_MPI
1635	Call Agrif_nbdim_deallocation(tempP%var,nbdim)
1636	Call Agrif_nbdim_deallocation(tempC%var,nbdim)
1637	! Deallocate(tempC % var)
1638	#endif
1639	! Deallocate(tempP % var)
1640	ENDIF
1641	#ifdef AGRIF_MPI
1642	! Deallocate(tempPextend%var)
1643	! IF (.Not.memberin) Deallocate(tempCextend%var)
1644	#endif
1645
1646	C
1647	C
1648	End Subroutine Agrif_UpdatenD
1649	C
1650	C
1651	C **************************************************************************
1652	CCC Subroutine Agrif_Prtbounds
1653	C **************************************************************************
1654	C
1655	Subroutine Agrif_Prtbounds(nbdim,indmin,indmax,s_Parent_temp,
1656	& s_Child_temp,s_Child,ds_Child,
1657	& s_Parent,ds_Parent,
1658	& pttruetab,cetruetab,pttab_Child,
1659	& pttab_Parent,
1660	& posvartab_child,TypeUpdate,
1661	& loctab_Child
1662	#ifdef AGRIF_MPI
1663	& ,pttruetabwhole,cetruetabwhole
1664	#endif
1665	& )
1666	C
1667	CCC Description:
1668	CCC Subroutine calculating the bounds of the parent grid to be updated
1669	CCC by the child grid
1670	C
1671	C
1672	C Declarations:
1673	C
1674
1675	C
1676	#ifdef AGRIF_MPI
1677	cccccccccccccccccccccccccc#include "mpif.h"
1678	#endif
1679	C
1680	C Arguments
1681	INTEGER :: nbdim
1682	INTEGER,DIMENSION(nbdim) :: indmin,indmax
1683	REAL,DIMENSION(nbdim) :: s_Parent_temp,s_child_temp
1684	REAL,DIMENSION(nbdim) :: s_Child,ds_child
1685	REAL,DIMENSION(nbdim) :: s_Parent,ds_Parent
1686	INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
1687	INTEGER,DIMENSION(nbdim) :: posvartab_child,TypeUpdate
1688	INTEGER,DIMENSION(nbdim) :: loctab_Child
1689	INTEGER,DIMENSION(nbdim) :: pttab_Child,pttab_Parent
1690	C
1691	C Local variables
1692	INTEGER :: i
1693	REAL,DIMENSION(nbdim) :: dim_newmin,dim_newmax
1694	#ifdef AGRIF_MPI
1695	INTEGER,DIMENSION(nbdim) :: pttruetabwhole,cetruetabwhole
1696	REAL :: positionmin,positionmax
1697	INTEGER :: imin,imax
1698	#endif
1699	C
1700	C
1701	do i = 1,nbdim
1702	C
1703	dim_newmin(i) = s_Child(i) + (pttruetab(i) -
1704	& pttab_Child(i)) * ds_Child(i)
1705	C
1706	dim_newmax(i) = s_Child(i) + (cetruetab(i) -
1707	& pttab_Child(i)) * ds_Child(i)
1708	C
1709	indmin(i) = pttab_Parent(i) +
1710	& agrif_ceiling((dim_newmin(i)-s_Parent(i))/ds_Parent(i))
1711	C
1712	indmax(i) = pttab_Parent(i) +
1713	& agrif_int((dim_newmax(i)-s_Parent(i))/ds_Parent(i))
1714	C
1715	#ifdef AGRIF_MPI
1716	positionmin = s_Parent(i) + (indmin(i)-
1717	& pttab_Parent(i))*ds_Parent(i)
1718	IF (loctab_Child(i) .NE. -3) THEN
1719	IF (posvartab_child(i) == 1) THEN
1720	IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
1721	positionmin = positionmin - ds_Parent(i)/2.
1722	ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1723	positionmin = positionmin - (ds_Parent(i)-ds_Child(i))
1724	ENDIF
1725	ELSE
1726	positionmin = positionmin - ds_Parent(i)/2.
1727	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1728	positionmin = positionmin - ds_Child(i)
1729	ENDIF
1730	ENDIF
1731	ENDIF
1732	imin = pttab_Child(i) +
1733	& agrif_ceiling((positionmin-s_Child(i))/ds_Child(i))
1734
1735	positionmin = s_Child(i) + (imin -
1736	& pttab_Child(i)) * ds_Child(i)
1737
1738	pttruetabwhole(i) = imin
1739
1740	positionmax = s_Parent(i) + (indmax(i)-
1741	& pttab_Parent(i))*ds_Parent(i)
1742	IF (loctab_Child(i) .NE. -3) THEN
1743	IF (posvartab_child(i) == 1) THEN
1744	IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
1745	positionmax = positionmax + ds_Parent(i)/2.
1746	ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1747	positionmax = positionmax + (ds_Parent(i)-ds_Child(i))
1748	ENDIF
1749	ELSE
1750	positionmax = positionmax + ds_Parent(i)/2.
1751	IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
1752	positionmax = positionmax + ds_Child(i)
1753	ENDIF
1754	ENDIF
1755	ENDIF
1756	imax = pttab_Child(i) +
1757	& agrif_int((positionmax-s_Child(i))/ds_Child(i))
1758
1759	positionmax = s_Child(i) + (imax -
1760	& pttab_Child(i)) * ds_Child(i)
1761
1762	cetruetabwhole(i) = imax
1763
1764	#endif
1765	C
1766	s_Parent_temp(i) = s_Parent(i) +
1767	& (indmin(i) - pttab_Parent(i)) *
1768	& ds_Parent(i)
1769	C
1770	s_Child_temp(i) = dim_newmin(i)
1771
1772	#ifdef AGRIF_MPI
1773	s_Child_temp(i) = positionmin
1774	#endif
1775	C
1776	enddo
1777	C
1778	Return
1779	C
1780	C
1781	End Subroutine Agrif_Prtbounds
1782	C
1783	C
1784	C
1785	C
1786
1787	C
1788	C
1789	C
1790	C **************************************************************************
1791	CCC Subroutine Agrif_Update_2D_Recursive
1792	C **************************************************************************
1793	C
1794	Subroutine Agrif_Update_2D_recursive(TypeUpdate,tempP,tempC,
1795	& indmin,indmax,
1796	& pttab_child,petab_child,
1797	& s_child,s_parent,
1798	& ds_child,ds_parent,nbdim)
1799	C
1800	CCC Description:
1801	CCC Subroutine to update a 2D grid variable on the parent grid.
1802	CCC It calls Agrif_Update_1D_Recursive and Agrif_UpdateBase.
1803	C
1804	CC Method:
1805	C
1806	C Declarations:
1807	C
1808
1809	C
1810	INTEGER :: nbdim
1811	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
1812	INTEGER, DIMENSION(nbdim) :: indmin,indmax
1813	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1814	REAL, DIMENSION(nbdim) :: s_child,s_parent
1815	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
1816	REAL, DIMENSION(indmin(1):indmax(1),
1817	& indmin(2):indmax(2)) :: tempP
1818	C REAL, DIMENSION(pttab_child(1):petab_child(1),
1819	C & pttab_child(2):petab_child(2)) :: tempC
1820
1821	REAL, DIMENSION(:,:) :: tempC
1822	C
1823	C Local variables
1824	REAL, DIMENSION(indmin(1):indmax(1),
1825	& pttab_child(2):petab_child(2)) :: tabtemp
1826	REAL, DIMENSION(indmin(2):indmax(2),
1827	& indmin(1):indmax(1)) :: tempP_trsp
1828	REAL, DIMENSION(pttab_child(2):petab_child(2),
1829	& indmin(1):indmax(1)) :: tabtemp_trsp
1830	INTEGER :: i,j
1831	INTEGER :: coeffraf,locind_child_left
1832	C
1833	tabtemp = 0.
1834
1835
1836	coeffraf = nint ( ds_parent(1) / ds_child(1) )
1837	IF((TypeUpdate(1) == AGRIF_Update_average)
1838	& .AND. (coeffraf /= 1 ))THEN
1839	!---CDIR NEXPAND
1840	IF(.NOT. precomputedone(1) ) Call average1Dprecompute2D
1841	& (petab_child(2)-pttab_child(2)+1,
1842	& indmax(1)-indmin(1)+1,
1843	& petab_child(1)-pttab_child(1)+1,
1844	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1845	!---CDIR NEXPAND
1846	Call average1Daftercompute
1847	& ( tabtemp, tempC,
1848	& size(tabtemp), size(tempC),
1849	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1850
1851	ELSEIF((TypeUpdate(1) == AGRIF_Update_copy)
1852	& .AND. (coeffraf /= 1 ))THEN
1853	!---CDIR NEXPAND
1854	IF(.NOT. precomputedone(1) ) Call copy1Dprecompute2D
1855	& (petab_child(2)-pttab_child(2)+1,
1856	& indmax(1)-indmin(1)+1,
1857	& petab_child(1)-pttab_child(1)+1,
1858	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1859	!---CDIR NEXPAND
1860	Call copy1Daftercompute
1861	& ( tabtemp, tempC,
1862	& size(tabtemp), size(tempC),
1863	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1864
1865	ELSE
1866	do j = pttab_child(nbdim),petab_child(nbdim)
1867	C
1868	!---CDIR NEXPAND
1869	Call Agrif_Update_1D_recursive(TypeUpdate(1:nbdim-1),
1870	& tabtemp(:,j),
1871	& tempC(:,j-pttab_child(nbdim)+1),
1872	& indmin(1:nbdim-1),indmax(1:nbdim-1),
1873	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1874	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
1875	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1876	C
1877	enddo
1878	ENDIF
1879	tabtemp_trsp = TRANSPOSE(tabtemp)
1880	coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1881
1882	!---CDIR NEXPAND
1883	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
1884	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
1885	C
1886
1887	tempP_trsp = 0.
1888
1889	IF((TypeUpdate(2) == AGRIF_Update_average)
1890	& .AND. (coeffraf /= 1 ))THEN
1891	!---CDIR NEXPAND
1892	IF(.NOT. precomputedone(2) ) Call average1Dprecompute2D
1893	& ( indmax(1)-indmin(1)+1,
1894	& indmax(2)-indmin(2)+1,
1895	& petab_child(2)-pttab_child(2)+1,
1896	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1897	!---CDIR NEXPAND
1898	Call average1Daftercompute
1899	& ( tempP_trsp, tabtemp_trsp,
1900	& size(tempP_trsp), size(tabtemp_trsp),
1901	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1902
1903	ELSEIF((TypeUpdate(2) == AGRIF_Update_copy)
1904	& .AND. (coeffraf /= 1 ))THEN
1905	!---CDIR NEXPAND
1906	IF(.NOT. precomputedone(2) ) Call copy1Dprecompute2D
1907	& ( indmax(1)-indmin(1)+1,
1908	& indmax(2)-indmin(2)+1,
1909	& petab_child(2)-pttab_child(2)+1,
1910	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1911	!---CDIR NEXPAND
1912	Call copy1Daftercompute
1913	& ( tempP_trsp, tabtemp_trsp,
1914	& size(tempP_trsp), size(tabtemp_trsp),
1915	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1916
1917	ELSE
1918
1919	do i = indmin(1),indmax(1)
1920	C
1921	!---CDIR NEXPAND
1922	Call Agrif_UpdateBase(TypeUpdate(2),
1923	& tempP_trsp(indmin(nbdim):indmax(nbdim),i),
1924	& tabtemp_trsp(pttab_child(nbdim):petab_child(nbdim),i),
1925	& indmin(nbdim),indmax(nbdim),
1926	& pttab_child(nbdim),petab_child(nbdim),
1927	& s_parent(nbdim),s_child(nbdim),
1928	& ds_parent(nbdim),ds_child(nbdim),
1929	& coeffraf,locind_child_left)
1930	C
1931	enddo
1932
1933	ENDIF
1934
1935	tempP = TRANSPOSE(tempP_trsp)
1936	C
1937	Return
1938	C
1939	C
1940	End Subroutine Agrif_Update_2D_recursive
1941	C
1942	C
1943	C
1944	C **************************************************************************
1945	CCC Subroutine Agrif_Update_3D_Recursive
1946	C **************************************************************************
1947	C
1948	Subroutine Agrif_Update_3D_recursive(TypeUpdate,tempP,tempC,
1949	& indmin,indmax,
1950	& pttab_child,petab_child,
1951	& s_child,s_parent,
1952	& ds_child,ds_parent,nbdim)
1953	C
1954	CCC Description:
1955	CCC Subroutine to update a 3D grid variable on the parent grid.
1956	CCC It calls Agrif_Update_2D_Recursive and Agrif_UpdateBase.
1957	C
1958	CC Method:
1959	C
1960	C Declarations:
1961	C
1962
1963	C
1964	INTEGER :: nbdim
1965	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
1966	INTEGER, DIMENSION(nbdim) :: indmin,indmax
1967	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1968	REAL, DIMENSION(nbdim) :: s_child,s_parent
1969	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
1970	REAL, DIMENSION(indmin(1):indmax(1),
1971	& indmin(2):indmax(2),
1972	& indmin(3):indmax(3)) :: tempP
1973	REAL, DIMENSION(pttab_child(1):petab_child(1),
1974	& pttab_child(2):petab_child(2),
1975	& pttab_child(3):petab_child(3)) :: tempC
1976	C
1977	C Local variables
1978	REAL, DIMENSION(indmin(1):indmax(1),
1979	& indmin(2):indmax(2),
1980	& pttab_child(3):petab_child(3)) :: tabtemp
1981	INTEGER :: i,j,k
1982	INTEGER :: coeffraf,locind_child_left
1983	INTEGER :: kdeb
1984	C
1985	C
1986	coeffraf = nint ( ds_parent(1) / ds_child(1) )
1987	IF((TypeUpdate(1) == AGRIF_Update_average)
1988	& .AND. (coeffraf /= 1 ))THEN
1989	!---CDIR NEXPAND
1990	Call average1Dprecompute2D
1991	& (petab_child(2)-pttab_child(2)+1,
1992	& indmax(1)-indmin(1)+1,
1993	& petab_child(1)-pttab_child(1)+1,
1994	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1995	precomputedone(1) = .TRUE.
1996	ELSEIF((TypeUpdate(1) == AGRIF_Update_copy)
1997	& .AND. (coeffraf /= 1 ))THEN
1998	!---CDIR NEXPAND
1999	Call copy1Dprecompute2D
2000	& (petab_child(2)-pttab_child(2)+1,
2001	& indmax(1)-indmin(1)+1,
2002	& petab_child(1)-pttab_child(1)+1,
2003	& s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
2004	precomputedone(1) = .TRUE.
2005	ENDIF
2006
2007	coeffraf = nint ( ds_parent(2) / ds_child(2) )
2008	IF((TypeUpdate(2) == AGRIF_Update_average)
2009	& .AND. (coeffraf /= 1 ))THEN
2010	!---CDIR NEXPAND
2011	Call average1Dprecompute2D
2012	& ( indmax(1)-indmin(1)+1,
2013	& indmax(2)-indmin(2)+1,
2014	& petab_child(2)-pttab_child(2)+1,
2015	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
2016	precomputedone(2) = .TRUE.
2017	ELSEIF((TypeUpdate(2) == AGRIF_Update_copy)
2018	& .AND. (coeffraf /= 1 ))THEN
2019	!---CDIR NEXPAND
2020	Call copy1Dprecompute2D
2021	& ( indmax(1)-indmin(1)+1,
2022	& indmax(2)-indmin(2)+1,
2023	& petab_child(2)-pttab_child(2)+1,
2024	& s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
2025	precomputedone(2) = .TRUE.
2026	ENDIF
2027
2028
2029	do k = pttab_child(nbdim),petab_child(nbdim)
2030	C
2031	Call Agrif_Update_2D_recursive(TypeUpdate(1:nbdim-1),
2032	& tabtemp(:,:,k),
2033	& tempC(:,:,k),
2034	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2035	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2036	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2037	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2038	C
2039	enddo
2040	C
2041	precomputedone(1) = .FALSE.
2042	precomputedone(2) = .FALSE.
2043	coeffraf = nint ( ds_parent(3) / ds_child(3) )
2044
2045	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2046	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2047
2048	IF (coeffraf == 1) THEN
2049
2050	kdeb = pttab_child(3)+locind_child_left-2
2051	do k=indmin(3),indmax(3)
2052	kdeb = kdeb + 1
2053	do j = indmin(2),indmax(2)
2054	do i = indmin(1),indmax(1)
2055	tempP(i,j,k) = tabtemp(i,j,kdeb)
2056	enddo
2057	enddo
2058	enddo
2059
2060	ELSE
2061	tempP = 0.
2062	C
2063	do j = indmin(2),indmax(2)
2064	C
2065	do i = indmin(1),indmax(1)
2066	C
2067	Call Agrif_UpdateBase(TypeUpdate(3),
2068	& tempP(i,j,:),
2069	& tabtemp(i,j,:),
2070	& indmin(nbdim),indmax(nbdim),
2071	& pttab_child(nbdim),petab_child(nbdim),
2072	& s_parent(nbdim),s_child(nbdim),
2073	& ds_parent(nbdim),ds_child(nbdim),
2074	& coeffraf,locind_child_left)
2075	C
2076	enddo
2077	C
2078	enddo
2079	ENDIF
2080	C
2081	Return
2082	C
2083	C
2084	End Subroutine Agrif_Update_3D_recursive
2085	C
2086	C
2087	C
2088	C **************************************************************************
2089	CCC Subroutine Agrif_Update_4D_Recursive
2090	C **************************************************************************
2091	C
2092	Subroutine Agrif_Update_4D_recursive(TypeUpdate,tempP,tempC,
2093	& indmin,indmax,
2094	& pttab_child,petab_child,
2095	& s_child,s_parent,
2096	& ds_child,ds_parent,nbdim)
2097	C
2098	CCC Description:
2099	CCC Subroutine to update a 4D grid variable on the parent grid.
2100	CCC It calls Agrif_Update_3D_Recursive and Agrif_UpdateBase.
2101	C
2102	CC Method:
2103	C
2104	C Declarations:
2105	C
2106
2107	C
2108	INTEGER :: nbdim
2109	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2110	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2111	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2112	REAL, DIMENSION(nbdim) :: s_child,s_parent
2113	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2114	REAL, DIMENSION(indmin(1):indmax(1),
2115	& indmin(2):indmax(2),
2116	& indmin(3):indmax(3),
2117	& indmin(4):indmax(4)) :: tempP
2118	REAL, DIMENSION(pttab_child(1):petab_child(1),
2119	& pttab_child(2):petab_child(2),
2120	& pttab_child(3):petab_child(3),
2121	& pttab_child(4):petab_child(4)) :: tempC
2122	C
2123	C Local variables
2124	REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp
2125	INTEGER :: i,j,k,l
2126	INTEGER :: coeffraf,locind_child_left
2127	C
2128	C
2129	Allocate(tabtemp(indmin(1):indmax(1),
2130	& indmin(2):indmax(2),
2131	& indmin(3):indmax(3),
2132	& pttab_child(4):petab_child(4)))
2133	C
2134	do l = pttab_child(nbdim),petab_child(nbdim)
2135	C
2136	Call Agrif_Update_3D_recursive(TypeUpdate(1:nbdim-1),
2137	& tabtemp(indmin(nbdim-3):indmax(nbdim-3),
2138	& indmin(nbdim-2):indmax(nbdim-2),
2139	& indmin(nbdim-1):indmax(nbdim-1),l),
2140	& tempC(pttab_child(nbdim-3):petab_child(nbdim-3),
2141	& pttab_child(nbdim-2):petab_child(nbdim-2),
2142	& pttab_child(nbdim-1):petab_child(nbdim-1),l),
2143	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2144	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2145	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2146	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2147	C
2148	enddo
2149
2150	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2151	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2152	C
2153	tempP = 0.
2154
2155	do k = indmin(3),indmax(3)
2156	C
2157	do j = indmin(2),indmax(2)
2158	C
2159	do i = indmin(1),indmax(1)
2160	C
2161	Call Agrif_UpdateBase(TypeUpdate(4),
2162	& tempP(i,j,k,indmin(nbdim):indmax(nbdim)),
2163	& tabtemp(i,j,k,pttab_child(nbdim):petab_child(nbdim)),
2164	& indmin(nbdim),indmax(nbdim),
2165	& pttab_child(nbdim),petab_child(nbdim),
2166	& s_parent(nbdim),s_child(nbdim),
2167	& ds_parent(nbdim),ds_child(nbdim),
2168	& coeffraf,locind_child_left)
2169	C
2170	enddo
2171	C
2172	enddo
2173	C
2174	enddo
2175	C
2176	Deallocate(tabtemp)
2177	C
2178	Return
2179	C
2180	C
2181	End Subroutine Agrif_Update_4D_recursive
2182	C
2183	C
2184	C
2185	C **************************************************************************
2186	CCC Subroutine Agrif_Update_5D_Recursive
2187	C **************************************************************************
2188	C
2189	Subroutine Agrif_Update_5D_recursive(TypeUpdate,tempP,tempC,
2190	& indmin,indmax,
2191	& pttab_child,petab_child,
2192	& s_child,s_parent,
2193	& ds_child,ds_parent,nbdim)
2194	C
2195	CCC Description:
2196	CCC Subroutine to update a 5D grid variable on the parent grid.
2197	CCC It calls Agrif_Update_4D_Recursive and Agrif_UpdateBase.
2198	C
2199	CC Method:
2200	C
2201	C Declarations:
2202	C
2203
2204	C
2205	INTEGER :: nbdim
2206	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2207	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2208	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2209	REAL, DIMENSION(nbdim) :: s_child,s_parent
2210	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2211	REAL, DIMENSION(indmin(1):indmax(1),
2212	& indmin(2):indmax(2),
2213	& indmin(3):indmax(3),
2214	& indmin(4):indmax(4),
2215	& indmin(5):indmax(5)) :: tempP
2216	REAL, DIMENSION(pttab_child(1):petab_child(1),
2217	& pttab_child(2):petab_child(2),
2218	& pttab_child(3):petab_child(3),
2219	& pttab_child(4):petab_child(4),
2220	& pttab_child(5):petab_child(5)) :: tempC
2221	C
2222	C Local variables
2223	REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp
2224	INTEGER :: i,j,k,l,m
2225	INTEGER :: coeffraf,locind_child_left
2226	C
2227	C
2228	Allocate(tabtemp(indmin(1):indmax(1),
2229	& indmin(2):indmax(2),
2230	& indmin(3):indmax(3),
2231	& indmin(4):indmax(4),
2232	& pttab_child(5):petab_child(5)))
2233	C
2234	do m = pttab_child(nbdim),petab_child(nbdim)
2235	C
2236	Call Agrif_Update_4D_recursive(TypeUpdate(1:nbdim-1),
2237	& tabtemp(indmin(nbdim-4):indmax(nbdim-4),
2238	& indmin(nbdim-3):indmax(nbdim-3),
2239	& indmin(nbdim-2):indmax(nbdim-2),
2240	& indmin(nbdim-1):indmax(nbdim-1),m),
2241	& tempC(pttab_child(nbdim-4):petab_child(nbdim-4),
2242	& pttab_child(nbdim-3):petab_child(nbdim-3),
2243	& pttab_child(nbdim-2):petab_child(nbdim-2),
2244	& pttab_child(nbdim-1):petab_child(nbdim-1),m),
2245	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2246	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2247	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2248	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2249	C
2250	enddo
2251
2252	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2253	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2254	tempP = 0.
2255	C
2256	do l = indmin(4),indmax(4)
2257	C
2258	do k = indmin(3),indmax(3)
2259	C
2260	do j = indmin(2),indmax(2)
2261	C
2262	do i = indmin(1),indmax(1)
2263	C
2264	Call Agrif_UpdateBase(TypeUpdate(5),
2265	& tempP(i,j,k,l,indmin(nbdim):indmax(nbdim)),
2266	& tabtemp(i,j,k,l,
2267	& pttab_child(nbdim):petab_child(nbdim)),
2268	& indmin(nbdim),indmax(nbdim),
2269	& pttab_child(nbdim),petab_child(nbdim),
2270	& s_parent(nbdim),s_child(nbdim),
2271	& ds_parent(nbdim),ds_child(nbdim),
2272	& coeffraf,locind_child_left)
2273	C
2274	enddo
2275	C
2276	enddo
2277	C
2278	enddo
2279	C
2280	enddo
2281	C
2282	Deallocate(tabtemp)
2283	C
2284	Return
2285	C
2286	C
2287	End Subroutine Agrif_Update_5D_recursive
2288	C
2289	C
2290	C
2291	C
2292	C **************************************************************************
2293	CCC Subroutine Agrif_Update_6D_Recursive
2294	C **************************************************************************
2295	C
2296	Subroutine Agrif_Update_6D_recursive(TypeUpdate,tempP,tempC,
2297	& indmin,indmax,
2298	& pttab_child,petab_child,
2299	& s_child,s_parent,
2300	& ds_child,ds_parent,nbdim)
2301	C
2302	CCC Description:
2303	CCC Subroutine to update a 6D grid variable on the parent grid.
2304	CCC It calls Agrif_Update_5D_Recursive and Agrif_UpdateBase.
2305	C
2306	CC Method:
2307	C
2308	C Declarations:
2309	C
2310
2311	C
2312	INTEGER :: nbdim
2313	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2314	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2315	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2316	REAL, DIMENSION(nbdim) :: s_child,s_parent
2317	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2318	REAL, DIMENSION(indmin(1):indmax(1),
2319	& indmin(2):indmax(2),
2320	& indmin(3):indmax(3),
2321	& indmin(4):indmax(4),
2322	& indmin(5):indmax(5),
2323	& indmin(6):indmax(6)) :: tempP
2324	REAL, DIMENSION(pttab_child(1):petab_child(1),
2325	& pttab_child(2):petab_child(2),
2326	& pttab_child(3):petab_child(3),
2327	& pttab_child(4):petab_child(4),
2328	& pttab_child(5):petab_child(5),
2329	& pttab_child(6):petab_child(6)) :: tempC
2330	C
2331	C Local variables
2332	REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp
2333	INTEGER :: i,j,k,l,m,n
2334	INTEGER :: coeffraf,locind_child_left
2335	C
2336	C
2337	Allocate(tabtemp(indmin(1):indmax(1),
2338	& indmin(2):indmax(2),
2339	& indmin(3):indmax(3),
2340	& indmin(4):indmax(4),
2341	& indmin(5):indmax(5),
2342	& pttab_child(6):petab_child(6)))
2343	C
2344	do n = pttab_child(nbdim),petab_child(nbdim)
2345	C
2346	Call Agrif_Update_5D_recursive(TypeUpdate(1:nbdim-1),
2347	& tabtemp(indmin(nbdim-5):indmax(nbdim-5),
2348	& indmin(nbdim-4):indmax(nbdim-4),
2349	& indmin(nbdim-3):indmax(nbdim-3),
2350	& indmin(nbdim-2):indmax(nbdim-2),
2351	& indmin(nbdim-1):indmax(nbdim-1),n),
2352	& tempC(pttab_child(nbdim-5):petab_child(nbdim-5),
2353	& pttab_child(nbdim-4):petab_child(nbdim-4),
2354	& pttab_child(nbdim-3):petab_child(nbdim-3),
2355	& pttab_child(nbdim-2):petab_child(nbdim-2),
2356	& pttab_child(nbdim-1):petab_child(nbdim-1),n),
2357	& indmin(1:nbdim-1),indmax(1:nbdim-1),
2358	& pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
2359	& s_child(1:nbdim-1),s_parent(1:nbdim-1),
2360	& ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
2361	C
2362	enddo
2363
2364	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2365	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2366	C
2367	tempP = 0.
2368
2369	do m = indmin(5),indmax(5)
2370	do l = indmin(4),indmax(4)
2371	C
2372	do k = indmin(3),indmax(3)
2373	C
2374	do j = indmin(2),indmax(2)
2375	C
2376	do i = indmin(1),indmax(1)
2377	C
2378	Call Agrif_UpdateBase(TypeUpdate(6),
2379	& tempP(i,j,k,l,m,indmin(nbdim):indmax(nbdim)),
2380	& tabtemp(i,j,k,l,m,
2381	& pttab_child(nbdim):petab_child(nbdim)),
2382	& indmin(nbdim),indmax(nbdim),
2383	& pttab_child(nbdim),petab_child(nbdim),
2384	& s_parent(nbdim),s_child(nbdim),
2385	& ds_parent(nbdim),ds_child(nbdim),
2386	& coeffraf,locind_child_left)
2387	C
2388	enddo
2389	C
2390	enddo
2391	C
2392	enddo
2393	C
2394	enddo
2395	enddo
2396	C
2397	Deallocate(tabtemp)
2398	C
2399	Return
2400	C
2401	C
2402	End Subroutine Agrif_Update_6D_recursive
2403	C
2404	C
2405	C
2406	C **************************************************************************
2407	CCC Subroutine Agrif_UpdateBase
2408	C **************************************************************************
2409	C
2410	Subroutine Agrif_UpdateBase(TypeUpdate,
2411	& parenttab,childtab,
2412	& indmin,indmax,pttab_child,petab_child,
2413	& s_parent,s_child,ds_parent,ds_child,
2414	& coeffraf,locind_child_left)
2415	C
2416	CCC Description:
2417	CCC Subroutine calling the updating method chosen by the user (copy, average
2418	CCC or full-weighting).
2419	C
2420	CC Method:
2421	C
2422	C Declarations:
2423	C
2424
2425	C
2426	INTEGER :: TypeUpdate
2427	INTEGER :: indmin,indmax
2428	INTEGER :: pttab_child,petab_child
2429	REAL,DIMENSION(indmin:indmax) :: parenttab
2430	REAL,DIMENSION(pttab_child:petab_child) :: childtab
2431	REAL :: s_parent,s_child
2432	REAL :: ds_parent,ds_child
2433	INTEGER :: coeffraf,locind_child_left
2434	C
2435	C
2436	if (TypeUpdate == AGRIF_Update_copy) then
2437	C
2438	Call agrif_copy1D
2439	& (parenttab,childtab,
2440	& indmax-indmin+1,petab_child-pttab_child+1,
2441	& s_parent,s_child,ds_parent,ds_child)
2442	C
2443	elseif (TypeUpdate == AGRIF_Update_average) then
2444	C
2445	Call average1D
2446	& (parenttab,childtab,
2447	& indmax-indmin+1,petab_child-pttab_child+1,
2448	& s_parent,s_child,ds_parent,ds_child)
2449	C
2450	elseif (TypeUpdate == AGRIF_Update_full_weighting) then
2451	C
2452	Call full_weighting1D
2453	& (parenttab,childtab,
2454	& indmax-indmin+1,petab_child-pttab_child+1,
2455	& s_parent,s_child,ds_parent,ds_child,
2456	& coeffraf,locind_child_left)
2457	C
2458	endif
2459	C
2460	Return
2461	C
2462	C
2463	End Subroutine Agrif_UpdateBase
2464	C
2465	C
2466
2467	Subroutine Agrif_Compute_nbdim_update(s_parent,s_child,
2468	& ds_parent,ds_child,coeffraf,locind_child_left)
2469	real :: s_parent,s_child,ds_parent,ds_child
2470	integer :: coeffraf,locind_child_left
2471
2472	coeffraf = nint(ds_parent/ds_child)
2473	locind_child_left = 1 + agrif_int((s_parent-s_child)/ds_child)
2474
2475	End Subroutine Agrif_Compute_nbdim_update
2476
2477	#if defined AGRIF_MPI
2478	Subroutine Agrif_Find_list_update(list_update,pttab,petab,
2479	& pttab_Child,pttab_Parent,nbdim,
2480	& find_list_update,tab4t,tab5t,memberinall,memberinall2)
2481	TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
2482	INTEGER :: nbdim
2483	INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
2484	LOGICAL :: find_list_update
2485	Type(Agrif_List_Interp_loc), Pointer :: parcours
2486	INTEGER :: i
2487	C
2488	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t
2489	LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall,memberinall2
2490
2491	find_list_update = .FALSE.
2492
2493	parcours => list_update
2494
2495	Find_loop : Do While (associated(parcours))
2496	Do i=1,nbdim
2497	IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
2498	& (petab(i) /= parcours%interp_loc%petab(i)).OR.
2499	& (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
2500	& (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
2501	& THEN
2502	parcours=>parcours%suiv
2503	Cycle Find_loop
2504	ENDIF
2505	EndDo
2506
2507	tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:4)
2508	memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
2509
2510	tab5t = parcours%interp_loc%tab5t(1:nbdim,0:Agrif_Nbprocs-1,1:4)
2511	memberinall2 =
2512	& parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1)
2513
2514	find_list_update = .TRUE.
2515	Exit Find_loop
2516	End Do Find_loop
2517
2518	End Subroutine Agrif_Find_list_update
2519
2520	Subroutine Agrif_AddTo_list_update(list_update,pttab,petab,
2521	& pttab_Child,pttab_Parent,nbdim
2522	& ,tab4t,tab5t,memberinall,memberinall2)
2523
2524	TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
2525	INTEGER :: nbdim
2526	INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
2527	INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t
2528	LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
2529
2530	Type(Agrif_List_Interp_loc), Pointer :: parcours
2531
2532	Allocate(parcours)
2533	Allocate(parcours%interp_loc)
2534
2535	parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
2536	parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
2537	parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
2538	parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
2539	Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,4))
2540	Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
2541
2542	Allocate(parcours%interp_loc%tab5t(nbdim,0:Agrif_Nbprocs-1,4))
2543	Allocate(parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1))
2544
2545	parcours%interp_loc%tab4t=tab4t
2546	parcours%interp_loc%memberinall=memberinall
2547
2548	parcours%interp_loc%tab5t=tab5t
2549	parcours%interp_loc%memberinall2=memberinall2
2550
2551	parcours%suiv => list_update
2552
2553	list_update => parcours
2554
2555	End Subroutine Agrif_Addto_list_update
2556	#endif
2557
2558
2559	C **************************************************************************
2560	CCC Subroutine Agrif_Update_1D_Recursive
2561	C **************************************************************************
2562	C
2563	Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC,
2564	& indmin,indmax,
2565	& pttab_child,petab_child,
2566	& s_child,s_parent,
2567	& ds_child,ds_parent,nbdim)
2568	C
2569	CCC Description:
2570	CCC Subroutine to update a 1D grid variable on the parent grid.
2571	C
2572	CC Method:
2573	C
2574	C Declarations:
2575	C
2576
2577	C
2578	C Arguments
2579	INTEGER :: nbdim
2580	INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
2581	INTEGER, DIMENSION(nbdim) :: indmin,indmax
2582	INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
2583	REAL, DIMENSION(nbdim) :: s_child,s_parent
2584	REAL, DIMENSION(nbdim) :: ds_child,ds_parent
2585	REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tempP
2586	REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC
2587	INTEGER :: coeffraf,locind_child_left
2588	C
2589	C
2590	Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
2591	& ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
2592
2593	Call Agrif_UpdateBase(TypeUpdate(1),
2594	& tempP(indmin(nbdim):indmax(nbdim)),
2595	& tempC(pttab_child(nbdim):petab_child(nbdim)),
2596	& indmin(nbdim),indmax(nbdim),
2597	& pttab_child(nbdim),petab_child(nbdim),
2598	& s_parent(nbdim),s_child(nbdim),
2599	& ds_parent(nbdim),ds_child(nbdim),
2600	& coeffraf,locind_child_left)
2601
2602	C
2603	Return
2604	C
2605	C
2606	End Subroutine Agrif_Update_1D_recursive
2607
2608	End Module Agrif_Update

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

Download in other formats: