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

Last change on this file since 1200 was 1200, checked in by rblod, 12 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!
4C     AGRIF (Adaptive Grid Refinement In Fortran)
5C
6C     Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
7C                        Christophe Vouland (Christophe.Vouland@imag.fr)   
8C
9C     This program is free software; you can redistribute it and/or modify
10C     it under the terms of the GNU General Public License as published by
11C     the Free Software Foundation; either version 2 of the License, or
12C     (at your option) any later version.
13C
14C     This program is distributed in the hope that it will be useful,
15C     but WITHOUT ANY WARRANTY; without even the implied warranty of
16C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17C     GNU General Public License for more details.
18C
19C     You should have received a copy of the GNU General Public License
20C     along with this program; if not, write to the Free Software
21C     Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
22C
23C
24C
25CCC   Module Agrif_Interpolation
26C
27      Module Agrif_Interpolation
28C
29CCC   Description:
30CCC   Module to initialize a fine grid from its parent grid, by using a space 
31CCC   interpolation
32C
33C     Modules used:
34C 
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
42C     
43      IMPLICIT NONE
44      logical,  private:: precomputedone(7) = .FALSE.
45C
46      CONTAINS
47C     Define procedures contained in this module       
48C
49C
50C
51C     **************************************************************************
52CCC   Subroutine Agrif_Interp_1d
53C     **************************************************************************
54C 
55      Subroutine Agrif_Interp_1d(TypeInterp,parent,child,tab,
56     &    torestore,nbdim,procname)           
57C
58CCC   Description:
59CCC   Subroutine to calculate the boundary conditions of a fine grid for a 1D
60C        grid variable.
61C
62C     Declarations:
63C     
64     
65C
66C     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
80C
81C
82      allocate(childtemp % var) 
83C     
84C     Pointer on the root variable
85      childtemp % var % root_var => child % var %root_var
86C     
87C     Number of dimensions of the grid variable
88      childtemp % var % nbdim = nbdim
89C
90C     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           
96C     
97      if (torestore) then
98C 
99          childtemp % var % array1 = child % var % array1
100C         
101          childtemp % var % restore1D => child % var % restore1D
102C     
103        else
104C       
105          Nullify(childtemp % var % restore1D)
106C     
107      endif     
108C 
109C     Index indicating (in the Agrif_Interp1D procedure) if a space
110C        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           
115C     
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     
124C     
125      deallocate(childtemp % var)
126C
127C       
128      End Subroutine Agrif_Interp_1D
129C
130C
131C
132C     **************************************************************************
133CCC   Subroutine Agrif_Interp_2d
134C     **************************************************************************
135C 
136      Subroutine Agrif_Interp_2d(TypeInterp,parent,child,tab,
137     &                           torestore,nbdim,procname)           
138C
139CCC   Description:
140CCC   Subroutine to calculate the boundary conditions of a fine grid for a 2D
141C        grid variable.
142C
143C     Declarations:
144C     
145     
146C
147C     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
162C
163C
164      allocate(childtemp % var) 
165C     
166C     Pointer on the root variable
167      childtemp % var % root_var => child % var %root_var
168C     
169C     Number of dimensions of the grid variable
170      childtemp % var % nbdim = nbdim
171C
172C     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     
178C
179      if (torestore) then     
180C 
181          childtemp % var % array2 = child % var % array2         
182C 
183          childtemp % var % restore2D => child % var % restore2D       
184C     
185        else
186C       
187          Nullify(childtemp % var % restore2D)
188C     
189      endif       
190C 
191C     Index indicating (in the Agrif_Interp2D procedure) if a space
192C        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         
197C     
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     
207C     
208      deallocate(childtemp % var)
209C
210C       
211      End Subroutine Agrif_Interp_2D
212C
213C
214C
215C     **************************************************************************
216CCC   Subroutine Agrif_Interp_3d
217C     **************************************************************************
218C 
219      Subroutine Agrif_Interp_3d(TypeInterp,parent,child,tab,
220     &   torestore,nbdim,procname)           
221C
222CCC   Description:
223CCC   Subroutine to calculate the boundary conditions of a fine grid for a 3D
224C        grid variable.
225C
226C     Declarations:
227C     
228     
229C
230C     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
246C
247C
248      allocate(childtemp % var) 
249C
250C     Pointer on the root variable
251      childtemp % var % root_var => child % var %root_var
252C     
253C     Number of dimensions of the grid variable
254      childtemp % var % nbdim = nbdim 
255C     
256C     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       
261C     
262      if (torestore) then
263C     
264          childtemp % var % array3 = child % var % array3
265C
266          childtemp % var % restore3D => child % var % restore3D
267C     
268        else
269C       
270          Nullify(childtemp % var % restore3D)
271C     
272      endif
273C 
274C     Index indicating (in the Agrif_Interp3D procedure) if a space
275C        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         
280C     
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     
292C     
293      deallocate(childtemp % var)
294C
295C       
296      End Subroutine Agrif_Interp_3D               
297C
298C
299C
300C     **************************************************************************
301CCC   Subroutine Agrif_Interp_4d
302C     **************************************************************************
303C 
304      Subroutine Agrif_Interp_4d(TypeInterp,parent,child,tab,
305     &   torestore,nbdim,procname)           
306C
307CCC   Description:
308CCC   Subroutine to calculate the boundary conditions of a fine grid for a 4D
309C        grid variable.
310C
311C     Declarations:
312C     
313     
314C
315C     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
332C
333C
334      allocate(childtemp % var) 
335C
336C     Pointer on the root variable
337      childtemp % var % root_var => child % var %root_var
338C     
339C     Number of dimensions of the grid variable
340      childtemp % var % nbdim = nbdim 
341C     
342C     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           
348C 
349      if (torestore) then
350C 
351          childtemp % var % array4 = child % var % array4
352C
353          childtemp % var % restore4D => child % var % restore4D
354C     
355        else
356C       
357          Nullify(childtemp % var % restore4D)
358C     
359      endif       
360C 
361C     Index indicating (in the Agrif_Interp4D procedure) if a space
362C        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           
367C     
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
378C     
379      deallocate(childtemp % var)
380C
381C       
382      End Subroutine Agrif_Interp_4D
383C
384C
385C
386C     **************************************************************************
387CCC   Subroutine Agrif_Interp_5d
388C     **************************************************************************
389C 
390      Subroutine Agrif_Interp_5d(TypeInterp,parent,child,tab,
391     &   torestore,nbdim,procname)           
392C
393CCC   Description:
394CCC   Subroutine to calculate the boundary conditions of a fine grid for a 5D
395C        grid variable.
396C
397C     Declarations:
398C     
399     
400C
401C     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
419C
420C
421      allocate(childtemp % var) 
422C
423C     Pointer on the root variable
424      childtemp % var % root_var => child % var %root_var
425C     
426C     Number of dimensions of the grid variable
427      childtemp % var % nbdim = nbdim 
428C     
429C     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           
435C     
436      if (torestore) then
437C 
438          childtemp % var % array5 = child % var % array5
439C
440          childtemp % var % restore5D => child % var % restore5D
441C     
442        else
443C       
444          Nullify(childtemp % var % restore5D)
445C     
446      endif       
447C 
448C     Index indicating (in the Agrif_Interp5D procedure) if a space
449C        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         
454C     
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
465C     
466      deallocate(childtemp % var)
467C
468C       
469      End Subroutine Agrif_Interp_5D
470C
471C
472C
473C     **************************************************************************
474CCC   Subroutine Agrif_Interp_6d
475C     **************************************************************************
476C 
477      Subroutine Agrif_Interp_6d(TypeInterp,parent,child,tab,
478     &  torestore,nbdim,procname)           
479C
480CCC   Description:
481CCC   Subroutine to calculate the boundary conditions of a fine grid for a 6D
482C        grid variable.
483C
484C     Declarations:
485C     
486     
487C
488C     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
507C
508C
509      allocate(childtemp % var) 
510C
511C     Pointer on the root variable
512      childtemp % var % root_var => child % var %root_var
513C     
514C     Number of dimensions of the grid variable
515      childtemp % var % nbdim = nbdim 
516C     
517C     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           
523C     
524      if (torestore) then
525C 
526          childtemp % var % array6 = child % var % array6
527C
528          childtemp % var % restore6D => child % var % restore6D
529C     
530        else
531C       
532          Nullify(childtemp % var % restore6D)
533C     
534      endif       
535C 
536C     Index indicating (in the Agrif_Interp6D procedure) if a space
537C        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           
543C     
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
554C     
555      child % var % list_interp => childtemp % var %list_interp
556      deallocate(childtemp % var)
557C
558C       
559      End Subroutine Agrif_Interp_6D
560C
561C
562C
563C     **************************************************************************
564C     Subroutine Agrif_InterpVariable   
565C     **************************************************************************
566C   
567      Subroutine Agrif_InterpVariable(TYPEinterp,parent,child,torestore,
568     &            procname)
569C
570CCC   Description:
571CCC   Subroutine to set some arguments of subroutine Agrif_InterpnD, n being the
572CCC   DIMENSION of the grid variable.
573C
574CC    Declarations:
575C     
576c     
577C     
578C
579C     Scalar argument
580      INTEGER,DIMENSION(6) :: TYPEinterp! TYPE of interpolation
581                                        !    (linear,spline,...)
582C     Data TYPE arguments                                   
583      TYPE(AGRIF_PVariable) :: parent   ! Variable on the parent grid
584      TYPE(AGRIF_PVariable) :: child    ! Variable on the child grid
585C
586C     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   
590C
591C     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
602C
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)
609C
610C
611C     Call to a procedure of interpolation against the number of dimensions of 
612C     the grid variable
613C
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
633C
634      Return
635C
636C
637      End subroutine Agrif_InterpVariable       
638C
639C
640C     **************************************************************************
641C     Subroutine Agrif_InterpnD 
642C     **************************************************************************
643C 
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)
649C
650C     Description:
651C     Subroutine to interpolate a nD grid variable from its parent grid,
652C     by using a space interpolation. 
653C
654C     Declarations:
655C
656     
657C
658#ifdef AGRIF_MPI
659C
660#include "mpif.h"
661C
662#endif
663C
664C     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
697C
698C     Local pointers
699      TYPE(AGRIF_PVARIABLE),SAVE      :: tempP,tempPextend  ! Temporary parent grid variable
700      TYPE(AGRIF_PVARIABLE),SAVE      :: tempC      ! Temporary child grid variable
701C
702C     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     
716C
717#ifdef AGRIF_MPI
718C
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
728C
729#endif     
730C     
731
732C   
733C     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     
758C
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()
784C
785      Call Agrif_Childbounds(nbdim,
786     &                       lowerbound,upperbound,
787     &                       indminglob,indmaxglob,
788     &                       indminglob2,indmaxglob2,member)
789
790C
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
832C
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(:)
893C
894C
895      Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,
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   
943C
944C
945      IF (memberin) THEN
946      IF (.not.associated(tempC%var)) allocate(tempC%var)
947C
948
949      Call Agrif_nbdim_allocation(tempC%var,pttruetab,cetruetab,nbdim)
950
951C
952C
953C     Special values on the parent grid
954      if (Agrif_UseSpecialValue) then
955C
956          noraftab(1:nbdim) =
957     &         child % var % root_var % interptab(1:nbdim) .EQ. 'N'
958C
959          IF (.not.associated(parentvalues%var))
960     &            Allocate(parentvalues%var)
961C
962          Call Agrif_nbdim_allocation
963     &               (parentvalues%var,indmin,indmax,nbdim)
964          Call Agrif_nbdim_Full_VarEQvar
965     &               (parentvalues%var,tempPextend%var,nbdim)
966C
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)
972C
973          Call Agrif_nbdim_deallocation(parentvalues%var,nbdim)
974C          Deallocate(parentvalues%var)
975C
976C
977      endif     
978
979C
980C
981C     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
1031C 
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
1048ccccccccccccccc       memberout = .TRUE.
1049#endif
1050
1051
1052C
1053C
1054C     Special values on the child grid 
1055      if (Agrif_UseSpecialValueFineGrid) then
1056C
1057
1058          Call GiveAgrif_SpecialValueToTab_mpi(child%var,tempC%var,
1059     &                 childarray,
1060     &                 pttruetab,cetruetab,
1061     &                 Agrif_SpecialValueFineGrid,nbdim)
1062
1063C       
1064      endif
1065     
1066      endif
1067
1068C
1069      if (torestore) then
1070C
1071#ifdef AGRIF_MPI
1072C
1073        SELECT CASE (nbdim)
1074        CASE (1)
1075             do i = pttruetab(1),cetruetab(1)         
1076ChildarrayAModifier                if (restore%var%restore1D(i) == 0) 
1077ChildarrayAModifier     &                child%var%array1(childarray(i,1,2)
1078ChildarrayAModifier     &                                 ) = 
1079ChildarrayAModifier     &                tempC%var%array1(i)
1080             enddo
1081        CASE (2)
1082             do i = pttruetab(1),cetruetab(1)
1083             do j = pttruetab(2),cetruetab(2)
1084ChildarrayAModifier                   if (restore%var%restore2D(i,j) == 0) 
1085ChildarrayAModifier     &                child%var%array2(childarray(i,1,2),
1086ChildarrayAModifier     &                                 childarray(j,2,2)) = 
1087ChildarrayAModifier     &                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)
1094ChildarrayAModifier                      if (restore%var%restore3D(i,j,k) == 0) 
1095ChildarrayAModifier     &                child%var%array3(childarray(i,1,2),
1096ChildarrayAModifier     &                                 childarray(j,2,2),
1097ChildarrayAModifier     &                                 childarray(k,3,2)) = 
1098ChildarrayAModifier     &                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)
1107ChildarrayAModifier                         if (restore%var%restore4D(i,j,k,l) == 0) 
1108ChildarrayAModifier     &                      child%var%array4(childarray(i,1,2),
1109ChildarrayAModifier     &                                       childarray(j,2,2),
1110ChildarrayAModifier     &                                       childarray(k,3,2),
1111ChildarrayAModifier     &                                       childarray(l,4,2)) = 
1112ChildarrayAModifier     &                      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)
1123ChildarrayAModifier              if (restore%var%restore5D(i,j,k,l,m) == 0) 
1124ChildarrayAModifier     &                child%var%array5(childarray(i,1,2),
1125ChildarrayAModifier     &                                 childarray(j,2,2),
1126ChildarrayAModifier     &                                 childarray(k,3,2),
1127ChildarrayAModifier     &                                 childarray(l,4,2),
1128ChildarrayAModifier     &                                 childarray(m,5,2)) = 
1129ChildarrayAModifier     &                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)
1142ChildarrayAModifier              if (restore%var%restore6D(i,j,k,l,m,n) == 0) 
1143ChildarrayAModifier     &                child%var%array6(childarray(i,1,2),
1144ChildarrayAModifier     &                                 childarray(j,2,2),
1145ChildarrayAModifier     &                                 childarray(k,3,2),
1146ChildarrayAModifier     &                                 childarray(l,4,2),
1147ChildarrayAModifier     &                                 childarray(m,5,2),
1148ChildarrayAModifier     &                                 childarray(n,6,2)) = 
1149ChildarrayAModifier     &                tempC%var%array6(i,j,k,l,m,n)
1150             enddo
1151             enddo
1152             enddo
1153             enddo
1154             enddo
1155             enddo
1156        END SELECT
1157C
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
1227C
1228#endif
1229C       
1230        else
1231C
1232C
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
1285C
1286C       
1287      endif
1288
1289        Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
1290C        deallocate(tempPextend%var)
1291
1292      Call Agrif_nbdim_deallocation(tempC%var,nbdim)
1293     
1294C      Deallocate(tempC % var)
1295      ELSE
1296     
1297C      deallocate(tempPextend%var)
1298
1299      ENDIF
1300C
1301C             
1302C     Deallocations
1303#ifdef AGRIF_MPI       
1304      IF (member) THEN
1305      Call Agrif_nbdim_deallocation(tempP%var,nbdim)
1306C      Deallocate(tempP % var)
1307      endif
1308#endif
1309C
1310C
1311     
1312C
1313C
1314      End Subroutine Agrif_InterpnD 
1315C
1316C
1317C
1318C                 
1319C
1320C     **************************************************************************
1321CCC   Subroutine Agrif_Parentbounds
1322C     **************************************************************************
1323C
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)
1330C
1331CCC   Description:
1332CCC   Subroutine calculating the bounds of the parent grid for the interpolation
1333CCC   of the child grid     
1334C
1335C
1336C     Declarations:
1337C
1338C
1339C     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
1350C
1351C     Local variables
1352      INTEGER :: i
1353      REAL,DIMENSION(nbdim) :: dim_newmin,dim_newmax     
1354C
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         
1359C     
1360        indmin(i) = pttab_Parent(i) + 
1361     &         agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i))
1362C
1363        indmax(i) = pttab_Parent(i) + 
1364     &                agrif_ceiling((dim_newmax(i)-
1365     &                s_Parent(i))/ds_Parent(i))
1366     
1367C
1368C
1369C       Necessary for the Quadratic interpolation
1370C 
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
1387C       
1388       ENDDO 
1389C
1390        s_Parent_temp = s_Parent + (indmin - pttab_Parent) * ds_Parent
1391C     
1392        s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child
1393C
1394C
1395      Return
1396C
1397C
1398      End Subroutine Agrif_Parentbounds
1399C
1400C
1401C
1402C     **************************************************************************
1403CCC   Subroutine Agrif_Interp_1D_Recursive 
1404C     **************************************************************************
1405C
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)     
1410C
1411CCC   Description:
1412CCC   Subroutine for the interpolation of a 1D grid variable. 
1413CCC   It calls Agrif_InterpBase. 
1414C
1415C     Declarations:
1416C
1417     
1418C
1419C     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
1430C
1431C
1432C     Commentaire perso : nbdim vaut toujours 1 ici. 
1433C
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               
1444C               
1445      Return
1446C
1447C
1448      End Subroutine Agrif_Interp_1D_recursive
1449C
1450C
1451C     
1452C     **************************************************************************
1453CCC   Subroutine Agrif_Interp_2D_Recursive 
1454C     **************************************************************************
1455C
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)
1463C
1464CCC   Description:
1465CCC   Subroutine for the interpolation of a 2D grid variable. 
1466CCC   It calls Agrif_Interp_1D_recursive and Agrif_InterpBase.   
1467C
1468C     Declarations:
1469C
1470     
1471C     
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
1486C
1487C     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
1499C
1500C
1501C
1502C
1503C     Commentaire perso : nbdim vaut toujours 2 ici.
1504C
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)
1534C       
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)
1543C       
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)
1579C
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
1589C       
1590      enddo
1591      ENDIF
1592     
1593      tabout = TRANSPOSE(tabout_trsp)
1594C
1595      Return
1596C
1597C
1598      End Subroutine Agrif_Interp_2D_recursive
1599C
1600C
1601C     
1602C     **************************************************************************
1603CCC   Subroutine Agrif_Interp_3D_Recursive 
1604C     **************************************************************************
1605C
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)
1610C
1611CCC   Description:
1612CCC   Subroutine for the interpolation of a 3D grid variable. 
1613CCC   It calls Agrif_Interp_2D_recursive and Agrif_InterpBase.   
1614C
1615C     Declarations:
1616C
1617     
1618C     
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
1631C
1632C     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
1638C
1639C
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)
1675C       
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)
1685C       
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     
1708C
1709      do j=pttab_child(nbdim-1),petab_child(nbdim-1) 
1710C       
1711        do i=pttab_child(nbdim-2),petab_child(nbdim-2)
1712C
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)
1720C
1721        enddo 
1722C       
1723      enddo
1724      ENDIF
1725C
1726      Return
1727C       
1728C
1729      End Subroutine Agrif_Interp_3D_recursive
1730C
1731C
1732C
1733C     **************************************************************************
1734CCC   Subroutine Agrif_Interp_4D_Recursive 
1735C     **************************************************************************
1736C
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)
1741C
1742CCC   Description:
1743CCC   Subroutine for the interpolation of a 4D grid variable. 
1744CCC   It calls Agrif_Interp_3D_recursive and Agrif_InterpBase.   
1745C
1746C     Declarations:
1747C
1748     
1749C     
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
1764C
1765C     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
1772C
1773C
1774      do l = indmin(nbdim),indmax(nbdim)
1775C       
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)
1787C       
1788      enddo
1789C
1790      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1791     
1792      do k = pttab_child(nbdim-1),petab_child(nbdim-1)
1793C
1794        do j = pttab_child(nbdim-2),petab_child(nbdim-2) 
1795C       
1796          do i = pttab_child(nbdim-3),petab_child(nbdim-3)
1797C
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)
1805C
1806          enddo
1807C
1808        enddo 
1809C       
1810      enddo
1811C
1812      Return
1813C
1814C       
1815      End Subroutine Agrif_Interp_4D_recursive
1816C
1817C
1818C
1819C     **************************************************************************
1820CCC   Subroutine Agrif_Interp_5D_Recursive 
1821C     **************************************************************************
1822C
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)
1827C
1828CCC   Description:
1829CCC   Subroutine for the interpolation of a 5D grid variable. 
1830CCC   It calls Agrif_Interp_4D_recursive and Agrif_InterpBase.   
1831C
1832C     Declarations:
1833C
1834     
1835C     
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
1852C
1853C     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
1861C
1862C
1863      do m = indmin(nbdim),indmax(nbdim)
1864C       
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)
1878C       
1879      enddo
1880     
1881      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1882C
1883      do l = pttab_child(nbdim-1),petab_child(nbdim-1) 
1884C
1885        do k = pttab_child(nbdim-2),petab_child(nbdim-2)
1886C
1887          do j = pttab_child(nbdim-3),petab_child(nbdim-3) 
1888C       
1889            do i = pttab_child(nbdim-4),petab_child(nbdim-4)
1890C
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)
1899C
1900            enddo
1901C
1902          enddo
1903C
1904        enddo 
1905C       
1906      enddo
1907C
1908C
1909      Return
1910C
1911C       
1912      End Subroutine Agrif_Interp_5D_recursive
1913C
1914C
1915C
1916C     **************************************************************************
1917CCC   Subroutine Agrif_Interp_6D_Recursive 
1918C     **************************************************************************
1919C
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)
1924C
1925CCC   Description:
1926CCC   Subroutine for the interpolation of a 6D grid variable. 
1927CCC   It calls Agrif_Interp_4D_recursive and Agrif_InterpBase.   
1928C
1929C     Declarations:
1930C
1931     
1932C     
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
1951C
1952C     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
1961C
1962C       
1963C
1964      do n = indmin(nbdim),indmax(nbdim)
1965C       
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)
1981C       
1982      enddo
1983     
1984      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1985C
1986      do m = pttab_child(nbdim-1),petab_child(nbdim-1) 
1987      do l = pttab_child(nbdim-2),petab_child(nbdim-2) 
1988C
1989        do k = pttab_child(nbdim-3),petab_child(nbdim-3)
1990C
1991          do j = pttab_child(nbdim-4),petab_child(nbdim-4) 
1992C       
1993            do i = pttab_child(nbdim-5),petab_child(nbdim-5)
1994C
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)
2003C
2004            enddo
2005C
2006          enddo
2007C
2008        enddo 
2009C       
2010      enddo
2011      enddo
2012C               
2013C
2014      Return
2015C
2016C       
2017      End Subroutine Agrif_Interp_6D_recursive
2018C
2019C
2020C
2021C     **************************************************************************
2022CCC   Subroutine Agrif_InterpBase 
2023C     **************************************************************************
2024C 
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)   
2030C
2031CCC   Description:
2032CCC   Subroutine calling the interpolation method chosen by the user (linear, 
2033CCC   lagrange or spline). 
2034C
2035C     Declarations:
2036C
2037     
2038C
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
2046C 
2047C
2048       IF ((indmin == indmax).AND.(pttab_child == petab_child)) THEN
2049         childtab(pttab_child) = parenttab(indmin)
2050       ELSEIF (TYPEinterp .EQ. AGRIF_LINEAR) then   
2051C
2052C         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)
2058C         
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)
2065C
2066
2067        elseif (TYPEinterp .EQ. AGRIF_LAGRANGE) then
2068C         
2069C         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)
2074C           
2075        elseif (TYPEinterp .EQ. AGRIF_ENO) then
2076C         
2077C         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)
2082C       
2083        elseif (TYPEinterp .EQ. AGRIF_WENO) then
2084C         
2085C         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)
2090C           
2091        Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERV) then
2092C         
2093C         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)   
2099C             
2100        Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERVLIM) then
2101C         
2102C         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)         
2108C             
2109        elseif (TYPEinterp .EQ. AGRIF_CONSTANT) then
2110C         
2111          Call constant1D
2112     &         (parenttab,childtab,
2113     &         indmax-indmin+1,petab_child-pttab_child+1,
2114     &         s_parent,s_child,ds_parent,ds_child)
2115C             
2116      endif
2117C
2118C     
2119      End Subroutine Agrif_InterpBase 
2120C
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
2130C         
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
2155C
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
2224C
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.