source: branches/2015/dev_r5021_UKMO1_CICE_coupling/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterp.F @ 5445

Last change on this file since 5445 was 5445, checked in by davestorkey, 5 years ago

Clear SVN keywords from 2015/dev_r5021_UKMO1_CICE_coupling branch.

File size: 80.7 KB
Line 
1!
2! $Id: modinterp.F 2731 2011-04-08 12:05:35Z 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 key_mpp_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 % parray1 => 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 % parray1 = 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 % parray2 => 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 % parray2 = 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 % parray3 => 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 % parray3 = 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 % parray4 => 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 % parray4 = 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 % parray5 => 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 % parray5 = 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 % parray6 => 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 % parray6 = 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 key_mpp_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 key_mpp_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 key_mpp_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 key_mpp_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 key_mpp_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      IF (present(procname)) THEN
839      Call Agrif_ChildGrid_to_ParentGrid()
840            SELECT CASE (nbdim)
841        CASE(1)
842          CALL procname(tempP%var%array1,
843     &                          parentarray(1,1,2),parentarray(1,2,2))
844        CASE(2)
845          CALL procname(tempP%var%array2,
846     &                          parentarray(1,1,2),parentarray(1,2,2),
847     &                          parentarray(2,1,2),parentarray(2,2,2))
848        CASE(3)
849          CALL procname(tempP%var%array3,
850     &                          parentarray(1,1,2),parentarray(1,2,2),
851     &                          parentarray(2,1,2),parentarray(2,2,2),
852     &                          parentarray(3,1,2),parentarray(3,2,2))
853        CASE(4)
854          CALL procname(tempP%var%array4,
855     &                          parentarray(1,1,2),parentarray(1,2,2),
856     &                          parentarray(2,1,2),parentarray(2,2,2),
857     &                          parentarray(3,1,2),parentarray(3,2,2),
858     &                          parentarray(4,1,2),parentarray(4,2,2))
859        CASE(5)
860          CALL procname(tempP%var%array5,
861     &                          parentarray(1,1,2),parentarray(1,2,2),
862     &                          parentarray(2,1,2),parentarray(2,2,2),
863     &                          parentarray(3,1,2),parentarray(3,2,2),
864     &                          parentarray(4,1,2),parentarray(4,2,2),
865     &                          parentarray(5,1,2),parentarray(5,2,2))
866        CASE(6)
867          CALL procname(tempP%var%array6,
868     &                          parentarray(1,1,2),parentarray(1,2,2),
869     &                          parentarray(2,1,2),parentarray(2,2,2),
870     &                          parentarray(3,1,2),parentarray(3,2,2),
871     &                          parentarray(4,1,2),parentarray(4,2,2),
872     &                          parentarray(5,1,2),parentarray(5,2,2),
873     &                          parentarray(6,1,2),parentarray(6,2,2))
874            END SELECT
875      Call Agrif_ParentGrid_to_ChildGrid()
876      ELSE
877
878      Call Agrif_nbdim_VarEQvar(tempP%var,
879     &        parentarray(:,1,1),parentarray(:,2,1),
880     &        parent%var,parentarray(:,1,2),parentarray(:,2,2),
881     &        nbdim)
882      ENDIF
883            endif
884
885#ifdef key_mpp_mpi
886      if (.not.find_list_interp) then
887      tab3(:,1) = indminglob2(:)
888      tab3(:,2) = indmaxglob2(:)
889      tab3(:,3) = indmin(:)
890      tab3(:,4) = indmax(:)
891C
892C
893      Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,
894     &                   MPI_INTEGER,MPI_COMM_AGRIF,code)
895
896      IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
897
898      DO k=0,Agrif_Nbprocs-1
899       do j=1,4
900         do i=1,nbdim
901         tab4t(i,k,j) = tab4(i,j,k)
902                enddo
903      enddo
904      enddo
905     
906      memberin1(1) = memberin
907      CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
908     &                  1,MPI_LOGICAL,MPI_COMM_AGRIF,code)
909
910       Call Get_External_Data_first(tab4t(:,:,1),
911     &            tab4t(:,:,2),
912     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin,
913     &            memberinall,sendtoproc1,recvfromproc1,tab4t(:,:,5),
914     & tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8))
915         
916      endif     
917           
918!      Call Get_External_Data(tempP,tempPextend,tab4t(:,:,1),
919!     &            tab4t(:,:,2),
920!     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin,
921!     &            memberinall)
922     
923      Call ExchangeSameLevel2(sendtoproc1,recvfromproc1,nbdim,
924     &            tab4t(:,:,3),tab4t(:,:,4),tab4t(:,:,5),tab4t(:,:,6),
925     &            tab4t(:,:,7),tab4t(:,:,8),memberin,tempP,
926     &            tempPextend)
927#else
928      tempPextend%var => tempP%var
929#endif
930
931      if (.not.find_list_interp) then
932      Call Agrif_Addto_list_interp(child%var%list_interp,pttab,petab,
933     &                          pttab_Child,pttab_Parent,indmin,indmax,
934     &   indminglob,indmaxglob,indminglob2,indmaxglob2,parentarray,
935     &   pttruetab,cetruetab,member,memberin,nbdim
936#if defined key_mpp_mpi
937     &   ,tab4t,memberinall,sendtoproc1,recvfromproc1
938#endif
939     &    )
940      endif   
941C
942C
943      IF (memberin) THEN
944      IF (.not.associated(tempC%var)) allocate(tempC%var)
945C
946
947      Call Agrif_nbdim_allocation(tempC%var,pttruetab,cetruetab,nbdim)
948
949C
950C
951C     Special values on the parent grid
952      if (Agrif_UseSpecialValue) then
953C
954          noraftab(1:nbdim) =
955     &         child % var % root_var % interptab(1:nbdim) .EQ. 'N'
956C
957          IF (.not.associated(parentvalues%var))
958     &            Allocate(parentvalues%var)
959C
960          Call Agrif_nbdim_allocation
961     &               (parentvalues%var,indmin,indmax,nbdim)
962          Call Agrif_nbdim_Full_VarEQvar
963     &               (parentvalues%var,tempPextend%var,nbdim)
964C
965          Call Agrif_CheckMasknD(tempPextend,
966     &                           parentvalues,
967     &                           indmin(1:nbdim),indmax(1:nbdim),
968     &                           indmin(1:nbdim),indmax(1:nbdim),
969     &                           noraftab(1:nbdim),nbdim)
970C
971          Call Agrif_nbdim_deallocation(parentvalues%var,nbdim)
972C          Deallocate(parentvalues%var)
973C
974C
975      endif     
976
977C
978C
979C     Interpolation of the current grid
980
981      IF (memberin) THEN
982      if ( nbdim .EQ. 1 ) then
983         Call Agrif_Interp_1D_recursive(TypeInterp,
984     &           tempPextend%var%array1,tempC%var%array1,
985     &           indmin,indmax,
986     &           pttruetab,cetruetab,
987     &           s_Child_temp,s_Parent_temp,
988     &           ds_Child,ds_Parent,nbdim)
989      elseif ( nbdim .EQ. 2 ) then
990
991         Call Agrif_Interp_2D_recursive(TypeInterp,
992     &           tempPextend%var%array2,tempC%var%array2,
993     &           indmin,indmax,
994     &           pttruetab,cetruetab,
995     &           s_Child_temp,s_Parent_temp,
996     &           ds_Child,ds_Parent,nbdim)
997      elseif ( nbdim .EQ. 3 ) then
998
999         Call Agrif_Interp_3D_recursive(TypeInterp,
1000     &           tempPextend%var%array3,tempC%var%array3,
1001     &           indmin,indmax,
1002     &           pttruetab,cetruetab,
1003     &           s_Child_temp,s_Parent_temp,
1004     &           ds_Child,ds_Parent,nbdim)
1005      elseif ( nbdim .EQ. 4 ) then
1006         Call Agrif_Interp_4D_recursive(TypeInterp,
1007     &           tempPextend%var%array4,tempC%var%array4,
1008     &           indmin,indmax,
1009     &           pttruetab,cetruetab,
1010     &           s_Child_temp,s_Parent_temp,
1011     &           ds_Child,ds_Parent,nbdim)
1012      elseif ( nbdim .EQ. 5 ) then
1013         Call Agrif_Interp_5D_recursive(TypeInterp,
1014     &           tempPextend%var%array5,tempC%var%array5,
1015     &           indmin,indmax,
1016     &           pttruetab,cetruetab,
1017     &           s_Child_temp,s_Parent_temp,
1018     &           ds_Child,ds_Parent,nbdim)
1019      elseif ( nbdim .EQ. 6 ) then
1020         Call Agrif_Interp_6D_recursive(TypeInterp,
1021     &           tempPextend%var%array6,tempC%var%array6,
1022     &           indmin,indmax,
1023     &           pttruetab,cetruetab,
1024     &           s_Child_temp,s_Parent_temp,
1025     &           ds_Child,ds_Parent,nbdim)
1026       endif
1027
1028
1029C 
1030
1031      Call Agrif_nbdim_Get_bound_dimension(child % var,
1032     &                               lowerbound,upperbound,nbdim)
1033
1034#ifdef key_mpp_mpi
1035      Call Agrif_GlobtoLocInd2(childarray,
1036     &                     lowerbound,upperbound,
1037     &                     pttruetab,cetruetab,
1038     &                     nbdim,Agrif_Procrank,
1039     &                     memberout)
1040
1041#else
1042       childarray(:,1,1) = pttruetab
1043       childarray(:,2,1) = cetruetab
1044       childarray(:,1,2) = pttruetab
1045       childarray(:,2,2) = cetruetab
1046ccccccccccccccc       memberout = .TRUE.
1047#endif
1048
1049
1050C
1051C
1052C     Special values on the child grid 
1053      if (Agrif_UseSpecialValueFineGrid) then
1054C
1055
1056          Call GiveAgrif_SpecialValueToTab_mpi(child%var,tempC%var,
1057     &                 childarray,
1058     &                 pttruetab,cetruetab,
1059     &                 Agrif_SpecialValueFineGrid,nbdim)
1060
1061C       
1062      endif
1063     
1064      endif
1065
1066C
1067      if (torestore) then
1068C
1069#ifdef key_mpp_mpi
1070C
1071        SELECT CASE (nbdim)
1072        CASE (1)
1073             do i = pttruetab(1),cetruetab(1)         
1074ChildarrayAModifier                if (restore%var%restore1D(i) == 0) 
1075ChildarrayAModifier     &                child%var%array1(childarray(i,1,2)
1076ChildarrayAModifier     &                                 ) = 
1077ChildarrayAModifier     &                tempC%var%array1(i)
1078             enddo
1079        CASE (2)
1080             do i = pttruetab(1),cetruetab(1)
1081             do j = pttruetab(2),cetruetab(2)
1082ChildarrayAModifier                   if (restore%var%restore2D(i,j) == 0) 
1083ChildarrayAModifier     &                child%var%array2(childarray(i,1,2),
1084ChildarrayAModifier     &                                 childarray(j,2,2)) = 
1085ChildarrayAModifier     &                tempC%var%array2(i,j)
1086             enddo
1087             enddo
1088        CASE (3)
1089             do i = pttruetab(1),cetruetab(1)
1090             do j = pttruetab(2),cetruetab(2) 
1091             do k = pttruetab(3),cetruetab(3)
1092ChildarrayAModifier                      if (restore%var%restore3D(i,j,k) == 0) 
1093ChildarrayAModifier     &                child%var%array3(childarray(i,1,2),
1094ChildarrayAModifier     &                                 childarray(j,2,2),
1095ChildarrayAModifier     &                                 childarray(k,3,2)) = 
1096ChildarrayAModifier     &                tempC%var%array3(i,j,k)
1097             enddo
1098             enddo
1099             enddo
1100        CASE (4)
1101             do i = pttruetab(1),cetruetab(1)
1102             do j = pttruetab(2),cetruetab(2)
1103             do k = pttruetab(3),cetruetab(3)
1104             do l = pttruetab(4),cetruetab(4)
1105ChildarrayAModifier                         if (restore%var%restore4D(i,j,k,l) == 0) 
1106ChildarrayAModifier     &                      child%var%array4(childarray(i,1,2),
1107ChildarrayAModifier     &                                       childarray(j,2,2),
1108ChildarrayAModifier     &                                       childarray(k,3,2),
1109ChildarrayAModifier     &                                       childarray(l,4,2)) = 
1110ChildarrayAModifier     &                      tempC%var%array4(i,j,k,l)
1111             enddo
1112             enddo
1113             enddo
1114             enddo
1115        CASE (5)
1116             do i = pttruetab(1),cetruetab(1)
1117             do j = pttruetab(2),cetruetab(2)
1118             do k = pttruetab(3),cetruetab(3)
1119             do l = pttruetab(4),cetruetab(4)
1120             do m = pttruetab(5),cetruetab(5)
1121ChildarrayAModifier              if (restore%var%restore5D(i,j,k,l,m) == 0) 
1122ChildarrayAModifier     &                child%var%array5(childarray(i,1,2),
1123ChildarrayAModifier     &                                 childarray(j,2,2),
1124ChildarrayAModifier     &                                 childarray(k,3,2),
1125ChildarrayAModifier     &                                 childarray(l,4,2),
1126ChildarrayAModifier     &                                 childarray(m,5,2)) = 
1127ChildarrayAModifier     &                tempC%var%array5(i,j,k,l,m)
1128             enddo
1129             enddo
1130             enddo
1131             enddo
1132             enddo
1133        CASE (6)
1134             do i = pttruetab(1),cetruetab(1)
1135             do j = pttruetab(2),cetruetab(2)
1136             do k = pttruetab(3),cetruetab(3)
1137             do l = pttruetab(4),cetruetab(4)
1138             do m = pttruetab(5),cetruetab(5)
1139             do n = pttruetab(6),cetruetab(6)
1140ChildarrayAModifier              if (restore%var%restore6D(i,j,k,l,m,n) == 0) 
1141ChildarrayAModifier     &                child%var%array6(childarray(i,1,2),
1142ChildarrayAModifier     &                                 childarray(j,2,2),
1143ChildarrayAModifier     &                                 childarray(k,3,2),
1144ChildarrayAModifier     &                                 childarray(l,4,2),
1145ChildarrayAModifier     &                                 childarray(m,5,2),
1146ChildarrayAModifier     &                                 childarray(n,6,2)) = 
1147ChildarrayAModifier     &                tempC%var%array6(i,j,k,l,m,n)
1148             enddo
1149             enddo
1150             enddo
1151             enddo
1152             enddo
1153             enddo
1154        END SELECT
1155C
1156#else
1157        SELECT CASE (nbdim)
1158        CASE (1)
1159           do i = pttruetab(1),cetruetab(1)         
1160            if (restore%var%restore1D(i) == 0)
1161     &            child % var % parray1(i) = 
1162     &            tempC % var % array1(i)   
1163          enddo
1164        CASE (2)
1165           do j = pttruetab(2),cetruetab(2)
1166             do i = pttruetab(1),cetruetab(1) 
1167              if (restore%var%restore2D(i,j) == 0)     
1168     &              child % var % parray2(i,j) = 
1169     &              tempC % var % array2(i,j)   
1170              enddo
1171             enddo
1172        CASE (3)
1173           do k = pttruetab(3),cetruetab(3)
1174           do j = pttruetab(2),cetruetab(2)
1175             do i = pttruetab(1),cetruetab(1) 
1176              if (restore%var%restore3D(i,j,k) == 0)
1177     &                  child % var % parray3(i,j,k) =
1178     &                  tempC % var % array3(i,j,k)   
1179                  enddo
1180              enddo
1181             enddo
1182        CASE (4)
1183           do l = pttruetab(4),cetruetab(4)
1184           do k = pttruetab(3),cetruetab(3)
1185          do j = pttruetab(2),cetruetab(2)
1186             do i = pttruetab(1),cetruetab(1)
1187                if (restore%var%restore4D(i,j,k,l) == 0)
1188     &                 child % var % parray4(i,j,k,l) = 
1189     &                 tempC % var % array4(i,j,k,l)   
1190             enddo
1191             enddo
1192              enddo
1193             enddo
1194        CASE (5)
1195           do m = pttruetab(5),cetruetab(5)
1196          do l = pttruetab(4),cetruetab(4)
1197         do k = pttruetab(3),cetruetab(3)
1198           do j = pttruetab(2),cetruetab(2)
1199             do i = pttruetab(1),cetruetab(1)
1200                if (restore%var%restore5D(i,j,k,l,m) == 0)
1201     &                  child % var % parray5(i,j,k,l,m) = 
1202     &                  tempC % var % array5(i,j,k,l,m)   
1203             enddo
1204             enddo
1205                  enddo
1206              enddo
1207             enddo
1208        CASE (6)
1209           do n = pttruetab(6),cetruetab(6)
1210          do m = pttruetab(5),cetruetab(5)
1211          do l = pttruetab(4),cetruetab(4)
1212         do k = pttruetab(3),cetruetab(3)
1213          do j = pttruetab(2),cetruetab(2)
1214             do i = pttruetab(1),cetruetab(1)
1215                if (restore%var%restore6D(i,j,k,l,m,n) == 0)
1216     &                      child % var % parray6(i,j,k,l,m,n) = 
1217     &                      tempC % var % array6(i,j,k,l,m,n)   
1218             enddo
1219            enddo
1220                      enddo
1221                  enddo
1222              enddo
1223             enddo
1224        END SELECT
1225C
1226#endif
1227C       
1228        else
1229C
1230C
1231          IF (memberin) THEN
1232          SELECT CASE (nbdim)
1233          CASE (1)
1234            child%var%parray1(childarray(1,1,2):childarray(1,2,2)) =
1235     &       tempC%var%array1(childarray(1,1,1):childarray(1,2,1))
1236          CASE (2)
1237            child%var%parray2(childarray(1,1,2):childarray(1,2,2),
1238     &                       childarray(2,1,2):childarray(2,2,2)) =
1239     &      tempC%var%array2(childarray(1,1,1):childarray(1,2,1),
1240     &                       childarray(2,1,1):childarray(2,2,1))
1241          CASE (3)
1242            child%var%parray3(childarray(1,1,2):childarray(1,2,2),
1243     &                       childarray(2,1,2):childarray(2,2,2),
1244     &                       childarray(3,1,2):childarray(3,2,2)) =
1245     &      tempC%var%array3(childarray(1,1,1):childarray(1,2,1),
1246     &                       childarray(2,1,1):childarray(2,2,1),
1247     &                       childarray(3,1,1):childarray(3,2,1))
1248          CASE (4)
1249            child%var%parray4(childarray(1,1,2):childarray(1,2,2),
1250     &                       childarray(2,1,2):childarray(2,2,2),
1251     &                       childarray(3,1,2):childarray(3,2,2),
1252     &                       childarray(4,1,2):childarray(4,2,2)) =
1253     &      tempC%var%array4(childarray(1,1,1):childarray(1,2,1),
1254     &                       childarray(2,1,1):childarray(2,2,1),
1255     &                       childarray(3,1,1):childarray(3,2,1),
1256     &                       childarray(4,1,1):childarray(4,2,1))
1257          CASE (5)
1258            child%var%parray5(childarray(1,1,2):childarray(1,2,2),
1259     &                       childarray(2,1,2):childarray(2,2,2),
1260     &                       childarray(3,1,2):childarray(3,2,2),
1261     &                       childarray(4,1,2):childarray(4,2,2),
1262     &                       childarray(5,1,2):childarray(5,2,2)) =
1263     &      tempC%var%array5(childarray(1,1,1):childarray(1,2,1),
1264     &                       childarray(2,1,1):childarray(2,2,1),
1265     &                       childarray(3,1,1):childarray(3,2,1),
1266     &                       childarray(4,1,1):childarray(4,2,1),
1267     &                       childarray(5,1,1):childarray(5,2,1))
1268          CASE (6)
1269            child%var%parray6(childarray(1,1,2):childarray(1,2,2),
1270     &                       childarray(2,1,2):childarray(2,2,2),
1271     &                       childarray(3,1,2):childarray(3,2,2),
1272     &                       childarray(4,1,2):childarray(4,2,2),
1273     &                       childarray(5,1,2):childarray(5,2,2),
1274     &                       childarray(6,1,2):childarray(6,2,2)) =
1275     &      tempC%var%array6(childarray(1,1,1):childarray(1,2,1),
1276     &                       childarray(2,1,1):childarray(2,2,1),
1277     &                       childarray(3,1,1):childarray(3,2,1),
1278     &                       childarray(4,1,1):childarray(4,2,1),
1279     &                       childarray(5,1,1):childarray(5,2,1),
1280     &                       childarray(6,1,1):childarray(6,2,1))
1281          END SELECT
1282          ENDIF
1283C
1284C       
1285      endif
1286
1287        Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
1288C        deallocate(tempPextend%var)
1289
1290      Call Agrif_nbdim_deallocation(tempC%var,nbdim)
1291     
1292C      Deallocate(tempC % var)
1293      ELSE
1294     
1295C      deallocate(tempPextend%var)
1296
1297      ENDIF
1298C
1299C             
1300C     Deallocations
1301#ifdef key_mpp_mpi       
1302      IF (member) THEN
1303      Call Agrif_nbdim_deallocation(tempP%var,nbdim)
1304C      Deallocate(tempP % var)
1305      endif
1306#endif
1307C
1308C
1309     
1310C
1311C
1312      End Subroutine Agrif_InterpnD 
1313C
1314C
1315C
1316C                 
1317C
1318C     **************************************************************************
1319CCC   Subroutine Agrif_Parentbounds
1320C     **************************************************************************
1321C
1322      Subroutine Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax,
1323     &                              s_Parent_temp,
1324     &                              s_Child_temp,s_Child,ds_Child,
1325     &                              s_Parent,ds_Parent,
1326     &                              pttruetab,cetruetab,pttab_Child,
1327     &                              pttab_Parent,posvar,interptab)
1328C
1329CCC   Description:
1330CCC   Subroutine calculating the bounds of the parent grid for the interpolation
1331CCC   of the child grid     
1332C
1333C
1334C     Declarations:
1335C
1336C
1337C     Arguments
1338      INTEGER :: nbdim
1339      INTEGER, DIMENSION(6) :: TypeInterp
1340      INTEGER,DIMENSION(nbdim) :: indmin,indmax
1341      REAL,DIMENSION(nbdim) :: s_Parent_temp,s_child_temp
1342      REAL,DIMENSION(nbdim) :: s_Child,ds_child
1343      REAL,DIMENSION(nbdim) :: s_Parent,ds_Parent
1344      INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
1345      INTEGER,DIMENSION(nbdim) :: pttab_Child,pttab_Parent
1346      INTEGER,DIMENSION(nbdim) :: posvar
1347      CHARACTER(6), DIMENSION(nbdim) :: interptab
1348C
1349C     Local variables
1350      INTEGER :: i
1351      REAL,DIMENSION(nbdim) :: dim_newmin,dim_newmax     
1352C
1353      dim_newmin = s_Child + (pttruetab - pttab_Child) * ds_Child
1354      dim_newmax = s_Child + (cetruetab - pttab_Child) * ds_Child
1355     
1356      DO i = 1,nbdim         
1357C     
1358        indmin(i) = pttab_Parent(i) + 
1359     &         agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i))
1360C
1361        indmax(i) = pttab_Parent(i) + 
1362     &                agrif_ceiling((dim_newmax(i)-
1363     &                s_Parent(i))/ds_Parent(i))
1364     
1365C
1366C
1367C       Necessary for the Quadratic interpolation
1368C 
1369
1370        IF ((pttruetab(i) == cetruetab(i)) .AND. 
1371     &                           (posvar(i) == 1)) THEN
1372        ELSEIF (interptab(i) .EQ. 'N') THEN
1373        ELSEIF ( TYPEinterp(i) .eq. Agrif_ppm .or.
1374     &      TYPEinterp(i) .eq. Agrif_eno  .or.
1375     &      TYPEinterp(i) .eq. Agrif_weno) THEN           
1376           indmin(i) = indmin(i) - 2 
1377           indmax(i) = indmax(i) + 2                 
1378        ELSE IF (( TYPEinterp(i) .ne. Agrif_constant )
1379     &        .AND.( TYPEinterp(i) .ne. Agrif_linear )) THEN
1380           indmin(i) = indmin(i) - 1 
1381           indmax(i) = indmax(i) + 1
1382        ENDIF
1383       
1384
1385C       
1386       ENDDO 
1387C
1388        s_Parent_temp = s_Parent + (indmin - pttab_Parent) * ds_Parent
1389C     
1390        s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child
1391C
1392C
1393      Return
1394C
1395C
1396      End Subroutine Agrif_Parentbounds
1397C
1398C
1399C
1400C     **************************************************************************
1401CCC   Subroutine Agrif_Interp_1D_Recursive 
1402C     **************************************************************************
1403C
1404      Subroutine Agrif_Interp_1D_recursive(TypeInterp,tabin,tabout,
1405     &           indmin,indmax, 
1406     &           pttab_child,petab_child,
1407     &           s_child,s_parent,ds_child,ds_parent,nbdim)     
1408C
1409CCC   Description:
1410CCC   Subroutine for the interpolation of a 1D grid variable. 
1411CCC   It calls Agrif_InterpBase. 
1412C
1413C     Declarations:
1414C
1415     
1416C
1417C     Arguments
1418      INTEGER :: nbdim
1419      INTEGER,DIMENSION(1) :: TypeInterp
1420      INTEGER, DIMENSION(nbdim) :: indmin,indmax
1421      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1422      REAL, DIMENSION(nbdim) :: s_child,s_parent
1423      REAL, DIMENSION(nbdim) :: ds_child,ds_parent
1424      REAL, INTENT(IN),DIMENSION(indmin(nbdim):indmax(nbdim)) :: tabin       
1425      REAL, INTENT(OUT),
1426     &      DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tabout
1427      INTEGER :: coeffraf
1428C
1429C
1430C     Commentaire perso : nbdim vaut toujours 1 ici. 
1431C
1432      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1433     
1434      Call Agrif_InterpBase(TypeInterp(1),
1435     &                  tabin(indmin(nbdim):indmax(nbdim)),
1436     &                  tabout(pttab_child(nbdim):petab_child(nbdim)),
1437     &                  indmin(nbdim),indmax(nbdim),           
1438     &                  pttab_child(nbdim),petab_child(nbdim),
1439     &                  s_parent(nbdim),s_child(nbdim),
1440     &                  ds_parent(nbdim),ds_child(nbdim),coeffraf)
1441               
1442C               
1443      Return
1444C
1445C
1446      End Subroutine Agrif_Interp_1D_recursive
1447C
1448C
1449C     
1450C     **************************************************************************
1451CCC   Subroutine Agrif_Interp_2D_Recursive 
1452C     **************************************************************************
1453C
1454      Subroutine Agrif_Interp_2D_recursive(TypeInterp,
1455     &           tabin,tabout,
1456     &           indmin,indmax,   
1457     &           pttab_child,petab_child,
1458     &            s_child, s_parent,
1459     &           ds_child,ds_parent,
1460     &           nbdim)
1461C
1462CCC   Description:
1463CCC   Subroutine for the interpolation of a 2D grid variable. 
1464CCC   It calls Agrif_Interp_1D_recursive and Agrif_InterpBase.   
1465C
1466C     Declarations:
1467C
1468     
1469C     
1470      INTEGER                   :: nbdim
1471      INTEGER,DIMENSION(2)      :: TypeInterp
1472      INTEGER, DIMENSION(nbdim) :: indmin,indmax
1473      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1474      REAL   , DIMENSION(nbdim) ::  s_child, s_parent
1475      REAL   , DIMENSION(nbdim) :: ds_child,ds_parent
1476      REAL   ,INTENT(IN), DIMENSION(
1477     &                indmin(nbdim-1):indmax(nbdim-1),
1478     &                indmin(nbdim):indmax(nbdim)
1479     &                ) :: tabin       
1480      REAL   ,INTENT(OUT), DIMENSION(
1481     &                pttab_child(nbdim-1):petab_child(nbdim-1),
1482     &                pttab_child(nbdim):petab_child(nbdim)
1483     &                ) :: tabout
1484C
1485C     Local variables     
1486      REAL, DIMENSION(pttab_child(nbdim-1):petab_child(nbdim-1),
1487     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
1488      INTEGER i,j
1489      INTEGER :: coeffraf
1490      REAL   , DIMENSION(
1491     &                pttab_child(nbdim):petab_child(nbdim),
1492     &                pttab_child(nbdim-1):petab_child(nbdim-1)
1493     &                ) :: tabout_trsp
1494      REAL, DIMENSION(indmin(nbdim):indmax(nbdim),
1495     &        pttab_child(nbdim-1):petab_child(nbdim-1)) :: tabtemp_trsp
1496
1497C
1498C
1499C
1500C
1501C     Commentaire perso : nbdim vaut toujours 2 ici.
1502C
1503      coeffraf = nint ( ds_parent(1) / ds_child(1) )
1504      IF((TypeInterp(1) == Agrif_Linear) .AND. (coeffraf /= 1 ) )THEN
1505
1506!---CDIR NEXPAND
1507          IF(.NOT. precomputedone(1) ) call linear1Dprecompute2D(
1508     &          indmax(2)-indmin(2)+1,   
1509     &          indmax(1)-indmin(1)+1,   
1510     &          petab_child(1)-pttab_child(1)+1,
1511     &          s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1512!---CDIR NEXPAND
1513           call linear1daftercompute(tabin,tabtemp,
1514     &          size(tabin), size(tabtemp), 
1515     &          s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1516 
1517      ELSEIF((TypeInterp(1) == Agrif_PPM) .AND. (coeffraf /= 1 ) )THEN
1518!---CDIR NEXPAND
1519          IF(.NOT. precomputedone(1) ) call ppm1Dprecompute2D(
1520     &          indmax(2)-indmin(2)+1,   
1521     &          indmax(1)-indmin(1)+1,   
1522     &          petab_child(1)-pttab_child(1)+1,
1523     &          s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1524!---CDIR NEXPAND
1525           call ppm1daftercompute(tabin,tabtemp,
1526     &          size(tabin), size(tabtemp), 
1527     &          s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1528
1529      ELSE
1530
1531      do j = indmin(nbdim),indmax(nbdim)
1532C       
1533!---CDIR NEXPAND
1534        Call Agrif_Interp_1D_recursive(TypeInterp(1),
1535     &         tabin(indmin(nbdim-1):indmax(nbdim-1),j),
1536     &         tabtemp(pttab_child(nbdim-1):petab_child(nbdim-1),j),
1537     &         indmin(1:nbdim-1),indmax(1:nbdim-1),
1538     &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1539     &         s_child(1:nbdim-1),s_parent(1:nbdim-1),
1540     &         ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1541C       
1542      enddo
1543      ENDIF   
1544
1545      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1546     
1547      tabtemp_trsp = TRANSPOSE(tabtemp)
1548
1549      IF((TypeInterp(2) == Agrif_Linear) .AND. (coeffraf /= 1 ) )THEN
1550
1551!---CDIR NEXPAND
1552          IF(.NOT. precomputedone(2) ) call linear1Dprecompute2D(
1553     &          petab_child(1)-pttab_child(1)+1,
1554     &          indmax(2)-indmin(2)+1,
1555     &          petab_child(2)-pttab_child(2)+1,
1556     &          s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1557!---CDIR NEXPAND
1558           call linear1daftercompute(tabtemp_trsp,tabout_trsp,
1559     &          size(tabtemp_trsp), size(tabout_trsp),
1560     &          s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1561
1562      ELSEIF((TypeInterp(2) == Agrif_PPM) .AND. (coeffraf /= 1 ) )THEN
1563
1564!---CDIR NEXPAND
1565           IF(.NOT. precomputedone(1) )call ppm1Dprecompute2D(
1566     &          petab_child(1)-pttab_child(1)+1,
1567     &          indmax(2)-indmin(2)+1,
1568     &          petab_child(2)-pttab_child(2)+1,
1569     &          s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1570!---CDIR NEXPAND
1571           call ppm1daftercompute(tabtemp_trsp,tabout_trsp,
1572     &          size(tabtemp_trsp), size(tabout_trsp),
1573     &          s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1574
1575      ELSE
1576      do i=pttab_child(nbdim-1),petab_child(nbdim-1)
1577C
1578!---CDIR NEXPAND
1579        Call Agrif_InterpBase(TypeInterp(2),
1580     &           tabtemp_trsp(indmin(nbdim):indmax(nbdim),i),
1581     &           tabout_trsp(pttab_child(nbdim):petab_child(nbdim),i),
1582     &           indmin(nbdim),indmax(nbdim),
1583     &           pttab_child(nbdim),petab_child(nbdim),
1584     &           s_parent(nbdim),s_child(nbdim),
1585     &           ds_parent(nbdim),ds_child(nbdim),coeffraf)
1586
1587C       
1588      enddo
1589      ENDIF
1590     
1591      tabout = TRANSPOSE(tabout_trsp)
1592C
1593      Return
1594C
1595C
1596      End Subroutine Agrif_Interp_2D_recursive
1597C
1598C
1599C     
1600C     **************************************************************************
1601CCC   Subroutine Agrif_Interp_3D_Recursive 
1602C     **************************************************************************
1603C
1604      Subroutine Agrif_Interp_3D_recursive(TypeInterp,tabin,tabout,
1605     &           indmin,indmax,   
1606     &           pttab_child,petab_child,
1607     &           s_child,s_parent,ds_child,ds_parent,nbdim)
1608C
1609CCC   Description:
1610CCC   Subroutine for the interpolation of a 3D grid variable. 
1611CCC   It calls Agrif_Interp_2D_recursive and Agrif_InterpBase.   
1612C
1613C     Declarations:
1614C
1615     
1616C     
1617      INTEGER :: nbdim
1618      INTEGER,DIMENSION(3) :: TypeInterp
1619      INTEGER, DIMENSION(nbdim) :: indmin,indmax
1620      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1621      REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
1622      REAL,INTENT(IN), DIMENSION(indmin(nbdim-2):indmax(nbdim-2),
1623     &                indmin(nbdim-1):indmax(nbdim-1),
1624     &                indmin(nbdim)  :indmax(nbdim)) :: tabin       
1625      REAL,INTENT(OUT),
1626     &        DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
1627     &                pttab_child(nbdim-1):petab_child(nbdim-1),
1628     &                pttab_child(nbdim):petab_child(nbdim)) :: tabout
1629C
1630C     Local variables     
1631      REAL, DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
1632     &                 pttab_child(nbdim-1):petab_child(nbdim-1),
1633     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
1634      INTEGER i,j,k
1635      INTEGER :: coeffraf, locind_child_left, kdeb
1636C
1637C
1638      coeffraf = nint ( ds_parent(1) / ds_child(1) )
1639      IF((TypeInterp(1) == Agrif_Linear) .AND. (coeffraf/=1))THEN
1640        Call linear1Dprecompute2D(
1641     &          indmax(2)-indmin(2)+1,
1642     &          indmax(1)-indmin(1)+1,
1643     &          petab_child(1)-pttab_child(1)+1,
1644     &          s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1645      precomputedone(1) = .TRUE. 
1646      ELSEIF((TypeInterp(1) == Agrif_PPM) .AND. (coeffraf/=1))THEN
1647        Call ppm1Dprecompute2D(
1648     &          indmax(2)-indmin(2)+1,
1649     &          indmax(1)-indmin(1)+1,
1650     &          petab_child(1)-pttab_child(1)+1,
1651     &          s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
1652      precomputedone(1) = .TRUE.
1653      ENDIF
1654
1655      coeffraf = nint ( ds_parent(2) / ds_child(2) )
1656      IF((TypeInterp(2) == Agrif_Linear) .AND. (coeffraf/=1)) THEN
1657         Call linear1Dprecompute2D(
1658     &          petab_child(1)-pttab_child(1)+1,
1659     &          indmax(2)-indmin(2)+1,
1660     &          petab_child(2)-pttab_child(2)+1,
1661     &          s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1662      precomputedone(2) = .TRUE. 
1663      ELSEIF((TypeInterp(2) == Agrif_PPM) .AND. (coeffraf/=1)) THEN
1664         Call ppm1Dprecompute2D(
1665     &          petab_child(1)-pttab_child(1)+1,
1666     &          indmax(2)-indmin(2)+1,
1667     &          petab_child(2)-pttab_child(2)+1,
1668     &          s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
1669      precomputedone(2) = .TRUE.
1670      ENDIF
1671
1672      do k = indmin(nbdim),indmax(nbdim)
1673C       
1674        Call Agrif_Interp_2D_recursive(TypeInterp(1:2),
1675     &         tabin(indmin(nbdim-2):indmax(nbdim-2),
1676     &         indmin(nbdim-1):indmax(nbdim-1),k),
1677     &         tabtemp(pttab_child(nbdim-2):petab_child(nbdim-2),
1678     &         pttab_child(nbdim-1):petab_child(nbdim-1),k),
1679     &         indmin(1:nbdim-1),indmax(1:nbdim-1),
1680     &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1681     &         s_child(1:nbdim-1),s_parent(1:nbdim-1),
1682     &         ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1683C       
1684      enddo
1685     
1686      precomputedone(1) = .FALSE.
1687      precomputedone(2) = .FALSE.
1688      coeffraf = nint ( ds_parent(3) / ds_child(3) )
1689
1690      Call Agrif_Compute_nbdim_interp(s_parent(nbdim),s_child(nbdim),
1691     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
1692           
1693      IF (coeffraf == 1) THEN
1694     
1695      kdeb = indmin(3)+locind_child_left-2
1696      do k=pttab_child(3),petab_child(3)
1697      kdeb = kdeb + 1
1698      do j = pttab_child(2),petab_child(2)
1699        do i = pttab_child(1),petab_child(1)
1700        tabout(i,j,k) = tabtemp(i,j,kdeb)
1701      enddo
1702      enddo
1703      enddo
1704             
1705      ELSE     
1706C
1707      do j=pttab_child(nbdim-1),petab_child(nbdim-1) 
1708C       
1709        do i=pttab_child(nbdim-2),petab_child(nbdim-2)
1710C
1711          Call Agrif_InterpBase(TypeInterp(3),
1712     &           tabtemp(i,j,indmin(nbdim):indmax(nbdim)),
1713     &           tabout(i,j,pttab_child(nbdim):petab_child(nbdim)),
1714     &           indmin(nbdim),indmax(nbdim),
1715     &           pttab_child(nbdim),petab_child(nbdim),
1716     &           s_parent(nbdim),s_child(nbdim),
1717     &           ds_parent(nbdim),ds_child(nbdim),coeffraf)
1718C
1719        enddo 
1720C       
1721      enddo
1722      ENDIF
1723C
1724      Return
1725C       
1726C
1727      End Subroutine Agrif_Interp_3D_recursive
1728C
1729C
1730C
1731C     **************************************************************************
1732CCC   Subroutine Agrif_Interp_4D_Recursive 
1733C     **************************************************************************
1734C
1735      Subroutine Agrif_Interp_4D_recursive(TypeInterp,tabin,tabout,
1736     &           indmin,indmax,   
1737     &           pttab_child,petab_child,
1738     &           s_child,s_parent,ds_child,ds_parent,nbdim)
1739C
1740CCC   Description:
1741CCC   Subroutine for the interpolation of a 4D grid variable. 
1742CCC   It calls Agrif_Interp_3D_recursive and Agrif_InterpBase.   
1743C
1744C     Declarations:
1745C
1746     
1747C     
1748      INTEGER :: nbdim
1749      INTEGER,DIMENSION(4) :: TypeInterp
1750      INTEGER, DIMENSION(nbdim) :: indmin,indmax
1751      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1752      REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
1753      REAL,INTENT(IN), DIMENSION(indmin(nbdim-3):indmax(nbdim-3),
1754     &                indmin(nbdim-2):indmax(nbdim-2),
1755     &                indmin(nbdim-1):indmax(nbdim-1),
1756     &                indmin(nbdim):indmax(nbdim)) :: tabin       
1757      REAL,INTENT(OUT),
1758     &       DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
1759     &                pttab_child(nbdim-2):petab_child(nbdim-2),
1760     &                pttab_child(nbdim-1):petab_child(nbdim-1),
1761     &                pttab_child(nbdim):petab_child(nbdim)) :: tabout
1762C
1763C     Local variables     
1764      REAL, DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
1765     &                 pttab_child(nbdim-2):petab_child(nbdim-2),
1766     &                 pttab_child(nbdim-1):petab_child(nbdim-1), 
1767     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
1768      INTEGER i,j,k,l
1769      INTEGER :: coeffraf
1770C
1771C
1772      do l = indmin(nbdim),indmax(nbdim)
1773C       
1774        Call Agrif_Interp_3D_recursive(TypeInterp(1:3),
1775     &         tabin(indmin(nbdim-3):indmax(nbdim-3),
1776     &               indmin(nbdim-2):indmax(nbdim-2),
1777     &               indmin(nbdim-1):indmax(nbdim-1),l),
1778     &         tabtemp(pttab_child(nbdim-3):petab_child(nbdim-3),
1779     &         pttab_child(nbdim-2):petab_child(nbdim-2),
1780     &         pttab_child(nbdim-1):petab_child(nbdim-1),l),
1781     &         indmin(1:nbdim-1),indmax(1:nbdim-1),
1782     &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1783     &         s_child(1:nbdim-1),s_parent(1:nbdim-1),
1784     &         ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1785C       
1786      enddo
1787C
1788      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1789     
1790      do k = pttab_child(nbdim-1),petab_child(nbdim-1)
1791C
1792        do j = pttab_child(nbdim-2),petab_child(nbdim-2) 
1793C       
1794          do i = pttab_child(nbdim-3),petab_child(nbdim-3)
1795C
1796            Call Agrif_InterpBase(TypeInterp(4),
1797     &           tabtemp(i,j,k,indmin(nbdim):indmax(nbdim)),
1798     &           tabout(i,j,k,pttab_child(nbdim):petab_child(nbdim)),
1799     &           indmin(nbdim),indmax(nbdim),
1800     &           pttab_child(nbdim),petab_child(nbdim),
1801     &           s_parent(nbdim),s_child(nbdim),
1802     &           ds_parent(nbdim),ds_child(nbdim),coeffraf)
1803C
1804          enddo
1805C
1806        enddo 
1807C       
1808      enddo
1809C
1810      Return
1811C
1812C       
1813      End Subroutine Agrif_Interp_4D_recursive
1814C
1815C
1816C
1817C     **************************************************************************
1818CCC   Subroutine Agrif_Interp_5D_Recursive 
1819C     **************************************************************************
1820C
1821      Subroutine Agrif_Interp_5D_recursive(TypeInterp,tabin,tabout,
1822     &           indmin,indmax,   
1823     &           pttab_child,petab_child,
1824     &           s_child,s_parent,ds_child,ds_parent,nbdim)
1825C
1826CCC   Description:
1827CCC   Subroutine for the interpolation of a 5D grid variable. 
1828CCC   It calls Agrif_Interp_4D_recursive and Agrif_InterpBase.   
1829C
1830C     Declarations:
1831C
1832     
1833C     
1834      INTEGER :: nbdim
1835      INTEGER,DIMENSION(5) :: TypeInterp
1836      INTEGER, DIMENSION(nbdim) :: indmin,indmax
1837      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1838      REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
1839      REAL,INTENT(IN), DIMENSION(indmin(nbdim-4):indmax(nbdim-4),
1840     &                indmin(nbdim-3):indmax(nbdim-3),
1841     &                indmin(nbdim-2):indmax(nbdim-2),
1842     &                indmin(nbdim-1):indmax(nbdim-1),
1843     &                indmin(nbdim):indmax(nbdim)) :: tabin 
1844      REAL,INTENT(OUT),
1845     &    DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
1846     &                pttab_child(nbdim-3):petab_child(nbdim-3),
1847     &                pttab_child(nbdim-2):petab_child(nbdim-2),
1848     &                pttab_child(nbdim-1):petab_child(nbdim-1),
1849     &                pttab_child(nbdim):petab_child(nbdim)) :: tabout
1850C
1851C     Local variables     
1852      REAL, DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
1853     &                 pttab_child(nbdim-3):petab_child(nbdim-3),
1854     &                 pttab_child(nbdim-2):petab_child(nbdim-2),
1855     &                 pttab_child(nbdim-1):petab_child(nbdim-1),   
1856     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
1857      INTEGER i,j,k,l,m
1858      INTEGER :: coeffraf
1859C
1860C
1861      do m = indmin(nbdim),indmax(nbdim)
1862C       
1863        Call Agrif_Interp_4D_recursive(TypeInterp(1:4),
1864     &         tabin(indmin(nbdim-4):indmax(nbdim-4),
1865     &               indmin(nbdim-3):indmax(nbdim-3),
1866     &               indmin(nbdim-2):indmax(nbdim-2),
1867     &               indmin(nbdim-1):indmax(nbdim-1),m),
1868     &         tabtemp(pttab_child(nbdim-4):petab_child(nbdim-4),
1869     &                 pttab_child(nbdim-3):petab_child(nbdim-3),
1870     &                 pttab_child(nbdim-2):petab_child(nbdim-2),
1871     &                 pttab_child(nbdim-1):petab_child(nbdim-1),m),
1872     &         indmin(1:nbdim-1),indmax(1:nbdim-1),
1873     &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1874     &         s_child(1:nbdim-1),s_parent(1:nbdim-1),
1875     &         ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1876C       
1877      enddo
1878     
1879      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1880C
1881      do l = pttab_child(nbdim-1),petab_child(nbdim-1) 
1882C
1883        do k = pttab_child(nbdim-2),petab_child(nbdim-2)
1884C
1885          do j = pttab_child(nbdim-3),petab_child(nbdim-3) 
1886C       
1887            do i = pttab_child(nbdim-4),petab_child(nbdim-4)
1888C
1889              Call Agrif_InterpBase(TypeInterp(5),
1890     &             tabtemp(i,j,k,l,indmin(nbdim):indmax(nbdim)),
1891     &                    tabout(i,j,k,l,
1892     &             pttab_child(nbdim):petab_child(nbdim)),
1893     &             indmin(nbdim),indmax(nbdim),
1894     &             pttab_child(nbdim),petab_child(nbdim),
1895     &             s_parent(nbdim),s_child(nbdim),
1896     &             ds_parent(nbdim),ds_child(nbdim),coeffraf)
1897C
1898            enddo
1899C
1900          enddo
1901C
1902        enddo 
1903C       
1904      enddo
1905C
1906C
1907      Return
1908C
1909C       
1910      End Subroutine Agrif_Interp_5D_recursive
1911C
1912C
1913C
1914C     **************************************************************************
1915CCC   Subroutine Agrif_Interp_6D_Recursive 
1916C     **************************************************************************
1917C
1918      Subroutine Agrif_Interp_6D_recursive(TypeInterp,tabin,tabout,
1919     &           indmin,indmax,   
1920     &           pttab_child,petab_child,
1921     &           s_child,s_parent,ds_child,ds_parent,nbdim)
1922C
1923CCC   Description:
1924CCC   Subroutine for the interpolation of a 6D grid variable. 
1925CCC   It calls Agrif_Interp_4D_recursive and Agrif_InterpBase.   
1926C
1927C     Declarations:
1928C
1929     
1930C     
1931      INTEGER :: nbdim
1932      INTEGER,DIMENSION(6) :: TypeInterp
1933      INTEGER, DIMENSION(nbdim) :: indmin,indmax
1934      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
1935      REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
1936      REAL,INTENT(IN), DIMENSION(indmin(nbdim-5):indmax(nbdim-5),
1937     &                indmin(nbdim-4):indmax(nbdim-4),
1938     &                indmin(nbdim-3):indmax(nbdim-3), 
1939     &                indmin(nbdim-2):indmax(nbdim-2),
1940     &                indmin(nbdim-1):indmax(nbdim-1),
1941     &                indmin(nbdim):indmax(nbdim)) :: tabin       
1942      REAL,INTENT(OUT),
1943     &    DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
1944     &                pttab_child(nbdim-4):petab_child(nbdim-4),
1945     &                pttab_child(nbdim-3):petab_child(nbdim-3),
1946     &                pttab_child(nbdim-2):petab_child(nbdim-2),
1947     &                pttab_child(nbdim-1):petab_child(nbdim-1),
1948     &                pttab_child(nbdim):petab_child(nbdim)) :: tabout
1949C
1950C     Local variables     
1951      REAL, DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
1952     &                 pttab_child(nbdim-4):petab_child(nbdim-4),
1953     &                 pttab_child(nbdim-3):petab_child(nbdim-3),
1954     &                 pttab_child(nbdim-2):petab_child(nbdim-2),   
1955     &                 pttab_child(nbdim-1):petab_child(nbdim-1),   
1956     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
1957      INTEGER i,j,k,l,m,n
1958      INTEGER :: coeffraf
1959C
1960C       
1961C
1962      do n = indmin(nbdim),indmax(nbdim)
1963C       
1964        Call Agrif_Interp_5D_recursive(TypeInterp(1:5),
1965     &         tabin(indmin(nbdim-5):indmax(nbdim-5),
1966     &               indmin(nbdim-4):indmax(nbdim-4),
1967     &               indmin(nbdim-3):indmax(nbdim-3),
1968     &               indmin(nbdim-2):indmax(nbdim-2),
1969     &               indmin(nbdim-1):indmax(nbdim-1),n),
1970     &         tabtemp(pttab_child(nbdim-5):petab_child(nbdim-5),
1971     &                 pttab_child(nbdim-4):petab_child(nbdim-4),
1972     &                 pttab_child(nbdim-3):petab_child(nbdim-3),
1973     &                 pttab_child(nbdim-2):petab_child(nbdim-2),
1974     &                 pttab_child(nbdim-1):petab_child(nbdim-1),n),
1975     &         indmin(1:nbdim-1),indmax(1:nbdim-1),
1976     &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
1977     &         s_child(1:nbdim-1),s_parent(1:nbdim-1),
1978     &         ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
1979C       
1980      enddo
1981     
1982      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
1983C
1984      do m = pttab_child(nbdim-1),petab_child(nbdim-1) 
1985      do l = pttab_child(nbdim-2),petab_child(nbdim-2) 
1986C
1987        do k = pttab_child(nbdim-3),petab_child(nbdim-3)
1988C
1989          do j = pttab_child(nbdim-4),petab_child(nbdim-4) 
1990C       
1991            do i = pttab_child(nbdim-5),petab_child(nbdim-5)
1992C
1993              Call Agrif_InterpBase(TypeInterp(6),
1994     &             tabtemp(i,j,k,l,m,indmin(nbdim):indmax(nbdim)),
1995     &                    tabout(i,j,k,l,m,
1996     &                    pttab_child(nbdim):petab_child(nbdim)),
1997     &             indmin(nbdim),indmax(nbdim),
1998     &             pttab_child(nbdim),petab_child(nbdim),
1999     &             s_parent(nbdim),s_child(nbdim),
2000     &             ds_parent(nbdim),ds_child(nbdim),coeffraf)
2001C
2002            enddo
2003C
2004          enddo
2005C
2006        enddo 
2007C       
2008      enddo
2009      enddo
2010C               
2011C
2012      Return
2013C
2014C       
2015      End Subroutine Agrif_Interp_6D_recursive
2016C
2017C
2018C
2019C     **************************************************************************
2020CCC   Subroutine Agrif_InterpBase 
2021C     **************************************************************************
2022C 
2023      Subroutine Agrif_InterpBase(TypeInterp,
2024     &                           parenttab,childtab,
2025     &                           indmin,indmax,pttab_child,petab_child,
2026     &                           s_parent,s_child,ds_parent,ds_child,
2027     &                           coeffraf)   
2028C
2029CCC   Description:
2030CCC   Subroutine calling the interpolation method chosen by the user (linear, 
2031CCC   lagrange or spline). 
2032C
2033C     Declarations:
2034C
2035     
2036C
2037      INTEGER                :: TypeInterp
2038      INTEGER :: indmin,indmax
2039      INTEGER :: pttab_child,petab_child
2040      REAL,INTENT(IN),DIMENSION(indmin:indmax)           :: parenttab       
2041      REAL,INTENT(OUT),DIMENSION(pttab_child:petab_child) :: childtab       
2042      REAL    :: s_parent,s_child,ds_parent,ds_child 
2043      INTEGER :: coeffraf
2044C 
2045C
2046       IF ((indmin == indmax).AND.(pttab_child == petab_child)) THEN
2047         childtab(pttab_child) = parenttab(indmin)
2048       ELSEIF (TYPEinterp .EQ. AGRIF_LINEAR) then   
2049C
2050C         Linear interpolation 
2051 
2052          Call linear1D
2053     &         (parenttab,childtab,
2054     &          indmax-indmin+1,petab_child-pttab_child+1,
2055     &          s_parent,s_child,ds_parent,ds_child)
2056C         
2057      elseif ( TYPEinterp .EQ. AGRIF_PPM ) then
2058
2059          Call ppm1D
2060     &         (parenttab,childtab,
2061     &         indmax-indmin+1,petab_child-pttab_child+1,
2062     &         s_parent,s_child,ds_parent,ds_child)
2063C
2064
2065        elseif (TYPEinterp .EQ. AGRIF_LAGRANGE) then
2066C         
2067C         Lagrange interpolation   
2068          Call lagrange1D
2069     &        (parenttab,childtab,
2070     &         indmax-indmin+1,petab_child-pttab_child+1,
2071     &         s_parent,s_child,ds_parent,ds_child)
2072C           
2073        elseif (TYPEinterp .EQ. AGRIF_ENO) then
2074C         
2075C         Eno interpolation
2076          Call eno1D
2077     &         (parenttab,childtab,
2078     &         indmax-indmin+1,petab_child-pttab_child+1,
2079     &         s_parent,s_child,ds_parent,ds_child)
2080C       
2081        elseif (TYPEinterp .EQ. AGRIF_WENO) then
2082C         
2083C         Eno interpolation
2084          Call weno1D
2085     &         (parenttab,childtab,
2086     &         indmax-indmin+1,petab_child-pttab_child+1,
2087     &         s_parent,s_child,ds_parent,ds_child)
2088C           
2089        Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERV) then
2090C         
2091C         Linear conservative interpolation
2092         
2093          Call linear1Dconserv
2094     &         (parenttab,childtab,
2095     &         indmax-indmin+1,petab_child-pttab_child+1,
2096     &         s_parent,s_child,ds_parent,ds_child)   
2097C             
2098        Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERVLIM) then
2099C         
2100C         Linear conservative interpolation
2101         
2102          Call linear1Dconservlim
2103     &         (parenttab,childtab,
2104     &         indmax-indmin+1,petab_child-pttab_child+1,
2105     &         s_parent,s_child,ds_parent,ds_child)         
2106C             
2107        elseif (TYPEinterp .EQ. AGRIF_CONSTANT) then
2108C         
2109          Call constant1D
2110     &         (parenttab,childtab,
2111     &         indmax-indmin+1,petab_child-pttab_child+1,
2112     &         s_parent,s_child,ds_parent,ds_child)
2113C             
2114      endif
2115C
2116C     
2117      End Subroutine Agrif_InterpBase 
2118C
2119
2120      Subroutine Agrif_Compute_nbdim_interp(s_parent,s_child,
2121     &  ds_parent,ds_child,coeffraf,locind_child_left)
2122      real :: s_parent,s_child,ds_parent,ds_child
2123      integer :: coeffraf,locind_child_left
2124     
2125      coeffraf = nint(ds_parent/ds_child)
2126      locind_child_left = 1 + agrif_int((s_child-s_parent)/ds_parent)
2127      End Subroutine Agrif_Compute_nbdim_interp
2128C         
2129
2130      Subroutine Agrif_Find_list_interp(list_interp,pttab,petab,
2131     &                          pttab_Child,pttab_Parent,nbdim,
2132     &                          indmin,indmax,indminglob,
2133     &      indmaxglob,indminglob2,indmaxglob2,parentarray,
2134     &       pttruetab,cetruetab,member,memberin,
2135     &      find_list_interp
2136#if defined key_mpp_mpi
2137     &     ,tab4t,memberinall,sendtoproc1,recvfromproc1
2138#endif
2139     &    )     
2140      TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
2141      INTEGER :: nbdim
2142      INTEGER,DIMENSION(nbdim)   :: pttab,petab,pttab_Child,pttab_Parent
2143      LOGICAL :: find_list_interp
2144      Type(Agrif_List_Interp_loc), Pointer :: parcours
2145      INTEGER,DIMENSION(nbdim)   :: indmin,indmax 
2146      INTEGER,DIMENSION(nbdim)   :: indminglob,indmaxglob
2147      INTEGER,DIMENSION(nbdim)   :: pttruetab,cetruetab     
2148      INTEGER,DIMENSION(nbdim)   :: indminglob2,indmaxglob2 
2149      INTEGER,DIMENSION(nbdim,2,2) :: parentarray
2150      LOGICAL :: member, memberin
2151      INTEGER :: i
2152#ifdef key_mpp_mpi
2153C
2154      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
2155      LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
2156      LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
2157#endif
2158                   
2159      find_list_interp = .FALSE.
2160     
2161      parcours => list_interp
2162      Find_loop :   Do While (associated(parcours))
2163        Do i=1,nbdim
2164          IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
2165     &        (petab(i) /= parcours%interp_loc%petab(i)).OR.
2166     &        (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
2167     &        (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
2168     &               THEN
2169            parcours=>parcours%suiv
2170            Cycle Find_loop
2171          ENDIF
2172        EndDo
2173
2174        indmin = parcours%interp_loc%indmin(1:nbdim)
2175        indmax = parcours%interp_loc%indmax(1:nbdim)
2176       
2177        pttruetab = parcours%interp_loc%pttruetab(1:nbdim)
2178        cetruetab = parcours%interp_loc%cetruetab(1:nbdim)
2179               
2180#if !defined key_mpp_mpi
2181        indminglob = parcours%interp_loc%indminglob(1:nbdim)
2182        indmaxglob = parcours%interp_loc%indmaxglob(1:nbdim)
2183#else
2184        indminglob2 = parcours%interp_loc%indminglob2(1:nbdim)
2185        indmaxglob2 = parcours%interp_loc%indmaxglob2(1:nbdim)
2186        parentarray = parcours%interp_loc%parentarray(1:nbdim,:,:)
2187        member = parcours%interp_loc%member
2188        tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:8)
2189        memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
2190        sendtoproc1 = parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1)
2191        recvfromproc1 = 
2192     &    parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1)
2193#endif       
2194        memberin = parcours%interp_loc%memberin
2195        find_list_interp = .TRUE.   
2196        Exit Find_loop
2197      End Do Find_loop 
2198                             
2199      End Subroutine Agrif_Find_list_interp   
2200     
2201      Subroutine Agrif_AddTo_list_interp(list_interp,pttab,petab,
2202     &                          pttab_Child,pttab_Parent,indmin,indmax,
2203     &                          indminglob,indmaxglob,
2204     &                          indminglob2,indmaxglob2,
2205     &                          parentarray,pttruetab,cetruetab,
2206     &                          member,memberin,nbdim
2207#if defined key_mpp_mpi
2208     &      ,tab4t,memberinall,sendtoproc1,recvfromproc1
2209#endif
2210     &    )
2211         
2212      TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
2213      INTEGER :: nbdim
2214      INTEGER,DIMENSION(nbdim)   :: pttab,petab,pttab_Child,pttab_Parent
2215      INTEGER,DIMENSION(nbdim)   :: indmin,indmax
2216      INTEGER,DIMENSION(nbdim)   :: indminglob,indmaxglob
2217      INTEGER,DIMENSION(nbdim)   :: indminglob2,indmaxglob2
2218      INTEGER,DIMENSION(nbdim)   :: pttruetab,cetruetab
2219      INTEGER,DIMENSION(nbdim,2,2) :: parentarray
2220      LOGICAL :: member, memberin
2221#ifdef key_mpp_mpi
2222C
2223      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
2224      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
2225      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1
2226      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: recvfromproc1
2227#endif                   
2228      Type(Agrif_List_Interp_loc), Pointer :: parcours
2229           
2230       Allocate(parcours)
2231      Allocate(parcours%interp_loc)
2232     
2233      parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
2234      parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
2235      parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
2236      parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
2237 
2238 
2239      parcours%interp_loc%indmin(1:nbdim) = indmin(1:nbdim)
2240      parcours%interp_loc%indmax(1:nbdim) = indmax(1:nbdim)
2241
2242      parcours%interp_loc%memberin = memberin
2243#if !defined key_mpp_mpi
2244      parcours%interp_loc%indminglob(1:nbdim) = indminglob(1:nbdim)
2245      parcours%interp_loc%indmaxglob(1:nbdim) = indmaxglob(1:nbdim)
2246#else
2247      parcours%interp_loc%indminglob2(1:nbdim) = indminglob2(1:nbdim)
2248      parcours%interp_loc%indmaxglob2(1:nbdim) = indmaxglob2(1:nbdim)
2249      parcours%interp_loc%parentarray(1:nbdim,:,:) 
2250     &       = parentarray(1:nbdim,:,:)
2251      parcours%interp_loc%member = member
2252      Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,8))
2253      Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
2254      Allocate(parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1))
2255      Allocate(parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1))                 
2256      parcours%interp_loc%tab4t=tab4t   
2257      parcours%interp_loc%memberinall=memberinall   
2258      parcours%interp_loc%sendtoproc1=sendtoproc1
2259      parcours%interp_loc%recvfromproc1=recvfromproc1           
2260#endif     
2261
2262      parcours%interp_loc%pttruetab(1:nbdim) = pttruetab(1:nbdim)
2263      parcours%interp_loc%cetruetab(1:nbdim) = cetruetab(1:nbdim)
2264     
2265      parcours%suiv => list_interp
2266     
2267      list_interp => parcours
2268      End Subroutine Agrif_Addto_list_interp 
2269               
2270      End Module Agrif_Interpolation
Note: See TracBrowser for help on using the repository browser.