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.

modinterp.F in trunk/AGRIF/AGRIF_FILES – NEMO

Context Navigation

source: trunk/AGRIF/AGRIF_FILES/modinterp.F @ 1200

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

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

Download in other formats: