New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
modupdate.F in branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES – NEMO

source: branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdate.F @ 7960

Last change on this file since 7960 was 7960, checked in by jwhile, 7 years ago

Updated namelist_ref and 2nd attemp at updating SVN keywords

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