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 vendors/AGRIF/current/AGRIF_FILES – NEMO

source: vendors/AGRIF/current/AGRIF_FILES/modinterp.F @ 1901

Last change on this file since 1901 was 1901, checked in by flavoni, 14 years ago

importing AGRIF vendor

File size: 80.7 KB
Line 
1!
2! $Id: modinterp.F 1793 2010-01-06 19:20:12Z rblod $
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_AGRIF,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_AGRIF,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.