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

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

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

Download in other formats: