source: trunk/AGRIF/AGRIF_FILES/modupdate.F @ 396

Last change on this file since 396 was 396, checked in by opalod, 15 years ago

Initial revision

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