Changeset 662

Timestamp:

2007-05-25T17:58:52+02:00 (17 years ago)

Author:

opalod

Message:

RB: update Agrif internal routines with a new update scheme and performance improvment

Location:

trunk/AGRIF/AGRIF_FILES

Files:

• modarrays.F (modified) (6 diffs)
• modbc.F (modified) (24 diffs)
• modbcfunction.F (modified) (6 diffs)
• modcluster.F (modified) (2 diffs)
• modcurgridfunctions.F (modified) (1 diff)
• modflux.F (added)
• modinterp.F (modified) (55 diffs)
• modinterpbasic.F (modified) (17 diffs)
• modlinktomodel.F (modified) (4 diffs)
• modmask.F (modified) (10 diffs)
• modmpp.F (modified) (11 diffs)
• modsauv.F (modified) (4 diffs)
• modtypes.F (modified) (6 diffs)
• modupdate.F (modified) (64 diffs)
• modupdatebasic.F (modified) (7 diffs)

trunk/AGRIF/AGRIF_FILES/modarrays.F

@@ -332 +332 @@
         Variable%array2 = Value
       CASE (3)
-        Variable%array3 = Value
+        Call Agrif_set_tozero3D(Variable%array3)
+!        Variable%array3 = Value
       CASE (4)
         Variable%array4 = Value
@@ -343 +344 @@
       return
 C
-      End Subroutine Agrif_nbdim_Full_VarEQreal       
+      End Subroutine Agrif_nbdim_Full_VarEQreal   
+      
+      Subroutine Agrif_set_tozero3D(tab3D)
+      real,dimension(:,:,:),target :: tab3D
+      
+      tab3D = 0.
+      
+      end subroutine agrif_set_tozero3D    
 C
 C
@@ -450 +458 @@
      &         Variable2%array1(inf2(1):sup2(1))
       CASE (2)
-         Variable%array2(inf(1):sup(1),
-     &                         inf(2):sup(2)) = 
-     &         Variable2%array2(inf2(1):sup2(1),
-     &                          inf2(2):sup2(2))
+     
+      Call Agrif_Copy_2d(Variable%array2,Variable2%array2,
+     &  lbound(Variable%array2),
+     &  lbound(Variable2%array2),
+     &  inf,sup,inf2,sup2)
+          
       CASE (3)
-         Variable%array3(inf(1):sup(1),
-     &                         inf(2):sup(2), 
-     &                         inf(3):sup(3)) = 
-     &         Variable2%array3(inf2(1):sup2(1),
-     &                          inf2(2):sup2(2),
-     &                          inf2(3):sup2(3))
+
+      Call Agrif_Copy_3d(Variable%array3,Variable2%array3,
+     &  lbound(Variable%array3),
+     &  lbound(Variable2%array3),
+     &  inf,sup,inf2,sup2)
+
       CASE (4)
-        Variable%array4(inf(1):sup(1),
-     &                         inf(2):sup(2), 
-     &                         inf(3):sup(3),
-     &                         inf(4):sup(4)) = 
-     &         Variable2%array4(inf2(1):sup2(1),
-     &                          inf2(2):sup2(2),
-     &                          inf2(3):sup2(3),
-     &                          inf2(4):sup2(4))
+      
+      Call Agrif_Copy_4d(Variable%array4,Variable2%array4,
+     &  lbound(Variable%array4),
+     &  lbound(Variable2%array4),
+     &  inf,sup,inf2,sup2)
+     
       CASE (5)
         Variable%array5(inf(1):sup(1),
@@ -543 +551 @@
 C
 C
-C     **************************************************************************
-CCC   Subroutine Agrif_array2vector
-C     **************************************************************************
-C
-      Subroutine Agrif_array2vector(array,bounds,vector,nbdim)
-C
-CCC   Description:
-CCC   This subroutine is used to record the array into the vector
-C
-C     Declarations:
-C      
-      
-C
-C     Arguments      
-C
-      TYPE(AGRIF_Variable), Pointer       :: array
-      REAL, DIMENSION(:)         :: vector      ! Array used for the time 
-      INTEGER                    :: nbdim       ! dimension of the table
-      INTEGER,DIMENSION(nbdim,2) :: bounds
-C
-C     Local variables       
-C
-      INTEGER                      :: nind,ir,jr,kr,lr,mr,nr
-C
-      SELECT CASE (nbdim)
-      CASE (1)
-         nind=0
-         do ir=bounds(1,1),bounds(1,2)
-            nind=nind+1
-            array%array1(ir) = vector(nind)
-         enddo       
-C
-      CASE (2)
-         nind=0
-          do jr=bounds(2,1),bounds(2,2)
-           do ir=bounds(1,1),bounds(1,2)
-               nind=nind+1
-               array%array2(ir,jr) = vector(nind)
-           enddo
-         enddo        
-C
-      CASE (3)
-         nind=0
-        do kr=bounds(3,1),bounds(3,2)
-           do jr=bounds(2,1),bounds(2,2)
-             do ir=bounds(1,1),bounds(1,2)
-                  nind=nind+1
-                  array%array3(ir,jr,kr) = vector(nind)
-             enddo
-           enddo
-         enddo      
-C
-      CASE (4)
-         nind=0
-        do lr=bounds(4,1),bounds(4,2)
-          do kr=bounds(3,1),bounds(3,2)
-             do jr=bounds(2,1),bounds(2,2)
-               do ir=bounds(1,1),bounds(1,2)
-                     nind=nind+1
-                     array%array4(ir,jr,kr,lr) = vector(nind)
-               enddo
-             enddo
-           enddo
-         enddo          
-C
-      CASE (5)
-         nind=0
-         do mr=bounds(5,1),bounds(5,2)
-         do lr=bounds(4,1),bounds(4,2)
-          do kr=bounds(3,1),bounds(3,2) 
-              do jr=bounds(2,1),bounds(2,2)
-                 do ir=bounds(1,1),bounds(1,2)
-                     nind=nind+1
-                     array%array5(ir,jr,kr,lr,mr) = vector(nind)
-                 enddo
-               enddo
-             enddo
-           enddo
-         enddo        
-C
-      CASE (6)
-         nind=0
-        do nr=bounds(6,1),bounds(6,2)
-          do mr=bounds(5,1),bounds(5,2)
-          do lr=bounds(4,1),bounds(4,2)
-           do kr=bounds(3,1),bounds(3,2)
-             do jr=bounds(2,1),bounds(2,2)
-                   do ir=bounds(1,1),bounds(1,2)
-                     nind=nind+1
-                     array%array6(ir,jr,kr,lr,mr,nr) = vector(nind)
-                   enddo
-                 enddo
-               enddo
-             enddo
-           enddo
-         enddo       
-        END SELECT
-C
-      return
-C
-      End Subroutine Agrif_array2vector
-C
-C
-C
-C     **************************************************************************
-CCC   Subroutine Agrif_vector2array
-C     **************************************************************************
-C
-      Subroutine Agrif_vector2array(vector,array,bounds,nbdim)
-C
-CCC   Description:
-CCC   This subroutine is used to record the array into the vector
-C
-C     Declarations:
-C      
-      
-C
-C     Arguments      
-C
-      TYPE(AGRIF_Variable), Pointer       :: array
-      REAL, DIMENSION(:)         :: vector      ! Array used for the time 
-      INTEGER                    :: nbdim       ! dimension of the table
-      INTEGER,DIMENSION(nbdim,2) :: bounds
-C
-C     Local variables       
-C
-      INTEGER                      :: nind,ir,jr,kr,lr,mr,nr
-C
-      SELECT CASE (nbdim)
-      CASE (1)
-         nind=0
-         do ir=bounds(1,1),bounds(1,2)
-            nind=nind+1
-            vector(nind) = array%array1(ir)
-         enddo       
-C
-      CASE (2)
-         nind=0
-        do jr=bounds(2,1),bounds(2,2)
-           do ir=bounds(1,1),bounds(1,2)
-               nind=nind+1
-               vector(nind) = array%array2(ir,jr)
-           enddo
-         enddo      
-C
-      CASE (3)
-         nind=0
-        do kr=bounds(3,1),bounds(3,2)
-          do jr=bounds(2,1),bounds(2,2)
-             do ir=bounds(1,1),bounds(1,2)
-                  nind=nind+1
-                  vector(nind) = array%array3(ir,jr,kr)
-             enddo
-           enddo
-         enddo       
-C
-      CASE (4)
-         nind=0
-          do lr=bounds(4,1),bounds(4,2)
-           do kr=bounds(3,1),bounds(3,2)
-             do jr=bounds(2,1),bounds(2,2)
-               do ir=bounds(1,1),bounds(1,2)
-                     nind=nind+1
-                     vector(nind) = array%array4(ir,jr,kr,lr)
-               enddo
-             enddo
-           enddo
-         enddo         
-C
-      CASE (5)
-         nind=0
-         do mr=bounds(5,1),bounds(5,2)
-           do lr=bounds(4,1),bounds(4,2)
-            do kr=bounds(3,1),bounds(3,2) 
-              do jr=bounds(2,1),bounds(2,2)
-                 do ir=bounds(1,1),bounds(1,2)
-                     nind=nind+1
-                     vector(nind) = array%array5(ir,jr,kr,lr,mr)
-                 enddo
-               enddo
-             enddo
-           enddo
-         enddo   
-C
-      CASE (6)
-         nind=0
-        do nr=bounds(6,1),bounds(6,2)
-           do mr=bounds(5,1),bounds(5,2)
-             do lr=bounds(4,1),bounds(4,2)
-               do kr=bounds(3,1),bounds(3,2)
-                do jr=bounds(2,1),bounds(2,2)
-                   do ir=bounds(1,1),bounds(1,2)
-                     nind=nind+1
-                     vector(nind) = array%array6(ir,jr,kr,lr,mr,nr)
-                   enddo
-                 enddo
-               enddo
-             enddo
-           enddo
-         enddo       
-      END SELECT
-C
-      return
-C
-      End Subroutine Agrif_vector2array
 
 #ifdef AGRIF_MPI
@@ -1310 +1113 @@
 #ifdef AGRIF_MPI
 C
-C     **************************************************************************
-CCC   Subroutine Agrif_GlobtoLocInd
-C     **************************************************************************
-C
-      Subroutine Agrif_GlobtoLocInd(tabarray,lboundl,uboundl,tab1,tab2,
-     &                              nbdim,rank)
-C
-CCC   Description:
-CCC   For a global index located on the current processor, tabarray gives the 
-CCC   corresponding local index   
-C
-C
-C     Declarations:
-C
-
-C
-C     Arguments
-      INTEGER :: nbdim
-      INTEGER,DIMENSION(nbdim) :: tab1,tab2
-      INTEGER,DIMENSION(minval(tab1):maxval(tab2),nbdim,2 ) :: tabarray
-      INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
-      INTEGER :: rank
-C
-C     Local variables
-      INTEGER :: i,i1,k
-C
-C
-      tabarray(:,:,1) = 0
-C        
-      do i = 1,nbdim
-C       
-        Call Agrif_Invloc(lboundl(i),rank,i,i1)
-        
-        do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
-           tabarray(k-lboundl(i)+i1,i,1)=1
-           tabarray(k-lboundl(i)+i1,i,2)=k
-        enddo
-
-C
-      enddo
-C
-      Return
-C
-C
-      End Subroutine Agrif_GlobtoLocInd
-
 C
 C     **************************************************************************
@@ -1418 +1175 @@
 #endif      
 
+      Subroutine Agrif_Copy_2d(tabout,tabin,l,m,inf,sup,inf2,sup2)
+      integer,dimension(2) :: l,m,inf,sup,inf2,sup2
+      real,target,dimension(l(1):,l(2):) :: tabout
+      real,target,dimension(m(1):,m(2):) :: tabin
+          tabout(inf(1):sup(1),
+     &                         inf(2):sup(2)) = 
+     &         tabin(inf2(1):sup2(1),
+     &                          inf2(2):sup2(2))
+      End Subroutine Agrif_Copy_2d
+      
+      Subroutine Agrif_Copy_3d(tabout,tabin,l,m,inf,sup,inf2,sup2)
+      integer,dimension(3) :: l,m,inf,sup,inf2,sup2
+      real,target,dimension(l(1):,l(2):,l(3):) :: tabout
+      real,target,dimension(m(1):,m(2):,m(3):) :: tabin
+          tabout(inf(1):sup(1),
+     &                         inf(2):sup(2), 
+     &                         inf(3):sup(3)) = 
+     &         tabin(inf2(1):sup2(1),
+     &                          inf2(2):sup2(2),
+     &                          inf2(3):sup2(3))
+      End Subroutine Agrif_Copy_3d
+      
+      Subroutine Agrif_Copy_4d(tabout,tabin,l,m,inf,sup,inf2,sup2)
+      integer,dimension(4) :: l,m,inf,sup,inf2,sup2
+      real,target,dimension(l(1):,l(2):,l(3):,l(4):) :: tabout
+      real,target,dimension(m(1):,m(2):,m(3):,m(4):) :: tabin
+          tabout(inf(1):sup(1),
+     &                         inf(2):sup(2), 
+     &                         inf(3):sup(3), 
+     &                         inf(4):sup(4)) = 
+     &         tabin(inf2(1):sup2(1),
+     &                          inf2(2):sup2(2),
+     &                          inf2(3):sup2(3),
+     &                          inf2(4):sup2(4))
+      End Subroutine Agrif_Copy_4d      
+
       End Module Agrif_Arrays

trunk/AGRIF/AGRIF_FILES/modbc.F

@@ -91 +91 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &                 child % var % Interpolationshouldbemade       
+     &                 child % var % Interpolationshouldbemade  
+      childtemp % var % list_interp => child % var% list_interp          
 C
 C     Call to the procedure for the calculations of the boundary conditions
@@ -98 +99 @@
 C
       child % var % oldvalues2D => childtemp % var % oldvalues2D
+      child % var % list_interp => childtemp % var %list_interp      
 C      
       deallocate(childtemp % var)
@@ -159 +161 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &                 child % var % Interpolationshouldbemade       
+     &                 child % var % Interpolationshouldbemade   
+      childtemp % var % list_interp => child % var% list_interp    
 C
 C     Call to the procedure for the calculations of the boundary conditions
@@ -172 +175 @@
 C   
       child % var % oldvalues2D => childtemp % var % oldvalues2D
+      child % var % list_interp => childtemp % var %list_interp
 C         
       deallocate(childtemp % var)
@@ -234 +238 @@
       childtemp % var % interpIndex => child % var % interpIndex
       childtemp % var % Interpolationshouldbemade = 
-     &                 child % var % Interpolationshouldbemade       
+     &                 child % var % Interpolationshouldbemade 
+      childtemp % var % list_interp => child % var% list_interp           
 C
 C     Call to the procedure for the calculations of the boundary conditions     
@@ -246 +251 @@
 C
       child % var % oldvalues2D => childtemp % var % oldvalues2D
+      child % var % list_interp => childtemp % var %list_interp      
 C      
       deallocate(childtemp % var)
@@ -310 +316 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &                 child % var % Interpolationshouldbemade       
+     &                 child % var % Interpolationshouldbemade  
+      childtemp % var % list_interp => child % var% list_interp          
 C
 C     Call to the procedure for the calculations of the boundary conditions
@@ -322 +329 @@
 C
       child % var % oldvalues2D => childtemp % var % oldvalues2D
+      child % var % list_interp => childtemp % var %list_interp      
 C      
       deallocate(childtemp % var)
@@ -386 +394 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &                 child % var % Interpolationshouldbemade       
+     &                 child % var % Interpolationshouldbemade 
+      childtemp % var % list_interp => child % var% list_interp           
 C
 C     Call to the procedure for the calculations of the boundary conditions  
@@ -398 +407 @@
 C
       child % var % oldvalues2D => childtemp % var % oldvalues2D
+      child % var % list_interp => childtemp % var %list_interp      
 C      
       deallocate(childtemp % var)
@@ -462 +472 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &                 child % var % Interpolationshouldbemade       
+     &                 child % var % Interpolationshouldbemade 
+      childtemp % var % list_interp => child % var% list_interp           
 C
 C     Call to the procedure for the calculations of the boundary conditions
@@ -469 +480 @@
 C
       child % var % oldvalues2D => childtemp % var % oldvalues2D
+      child % var % list_interp => childtemp % var %list_interp      
 C      
       deallocate(childtemp % var)
@@ -744 +756 @@
                                        !   boundary conditions are 
       INTEGER,DIMENSION(nbdim,2,2,nbdim)   :: ptres,ptres2 ! calculated
-      INTEGER                      :: nb,ndir,n,sizetab
+      INTEGER                      :: nb,ndir,n,sizetab(1)
       REAL, DIMENSION(:), Allocatable :: tab ! Array used for the interpolation
-      INTEGER, DIMENSION(nbdim)  :: ztab ! Array used for the interpolation
       REAL    :: c1t,c2t               ! Coefficients for the time interpolation
                                        !    (c2t=1-c1t) 
@@ -772 +783 @@
         indtab(1:nbdim,1,2) = indtab(1:nbdim,1,2) - 1
       END WHERE
+      
 
 #if !defined AGRIF_MPI
@@ -805 +817 @@
       indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2),
      &     lubglob(1:nbdim,2))
-                        
+
+                              
 C 
 C
@@ -928 +941 @@
 C                on the parent grid)
 C      
-              sizetab = 1
-              ztab(1) = ptres2(1,2,ndir,nb)-ptres2(1,1,ndir,nb)+1
-C
-              do i = 2,nbdim
+              sizetab(1) = 1
+C
+              do i = 1,nbdim
 C          
-                ztab(i) = ztab(i-1) 
+                sizetab(1) = sizetab(1)
      &              * (ptres2(i,2,ndir,nb)-ptres2(i,1,ndir,nb)+1)
 C      
               enddo
-              sizetab=ztab(nbdim)  
-              allocate(tab(sizetab))
-C
-             Call Agrif_vector2array(
-     &                      tab,child%var,
-     &                      ptres2(:,:,ndir,nb),
-     &                      nbdim)
-
-C     
-              Call saveAfterInterp
-     &             (child,tab,kindex)
-C
-C
-              deallocate(tab)     
+
+              Call saveAfterInterp(child,
+     &           ptres2(:,:,ndir,nb),kindex,sizetab(1),nbdim)
+C
            ENDIF
 C
@@ -992 +994 @@
           if (loctab_child(nb) /= (-ndir) 
      &        .AND. loctab_child(nb) /= -3) then
-C      
-              sizetab=1  
-              ztab(1) = ptres2(1,2,ndir,nb)-ptres2(1,1,ndir,nb)+1
-              do i = 2,nbdim
-C          
-                ztab(i) = ztab(i-1)
-     &             * (ptres2(i,2,ndir,nb)-ptres2(i,1,ndir,nb)+1)
-C      
-              enddo
-C              
-              sizetab = ztab(nbdim) 
-              allocate(tab(sizetab))
-C
-             Call Agrif_vector2array(
-     &                      tab,child%var,
-     &                      ptres2(:,:,ndir,nb),
-     &                      nbdim)
-C    
-C                  
+
               Call timeInterpolation
-     &             (child,tab,kindex,c1t,c2t)           
-C
-C
-          Call Agrif_array2vector(
-     &                   child%var,
-     &                   ptres2(:,:,ndir,nb),
-     &                   tab,nbdim)
-C
-C         
-              deallocate(tab)
-C 
+     &             (child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim)
           endif
 C
@@ -1039 +1013 @@
 C     **************************************************************************
 C
-      Subroutine saveAfterInterp(child,tab,kindex)
+      Subroutine saveAfterInterp(child,bounds,kindex,newsize,nbdim)
 C
 CCC   Descritpion:
@@ -1051 +1025 @@
 C     argument
       TYPE (AGRIF_PVariable) :: child   ! The fine grid variable
-      REAL, DIMENSION(:)     :: tab     ! Values on the fine grid variable 
-                                        !   after the space interpolation  
       INTEGER                :: kindex  ! Index indicating where this safeguard 
                                         ! is done on the fine grid
+      INTEGER :: nbdim, newsize
+      INTEGER,DIMENSION(nbdim,2) :: bounds
 C
 C     Local scalars
-      INTEGER :: newsize                ! Size of the domain where boundary
-                                        !    conditions are calculated
-      INTEGER :: i
+      INTEGER                      :: ir,jr,kr,lr,mr,nr
 C
 C
 C     Allocation of the array oldvalues2d
-      newsize = size(tab)
+
 C
       if (newsize .LE. 0) return
 C
-      Call checkSize
+      Call Agrif_Checksize
      &     (child,kindex+newsize)  
-C
-C
-C     Safeguard in the oldvalues2d array       
-C            
+
       if (child % var % interpIndex 
      &        /= Agrif_Curgrid % parent % ngridstep ) then
-         do i = 1,newsize
-           child % var % oldvalues2d(kindex,1) = child % var %
-     &                                        oldvalues2d(kindex,2) 
-           child % var % oldvalues2d(kindex,2) = tab(i)
-           kindex = kindex + 1
-         enddo
-      else
-        do i = 1,newsize
-           child % var % oldvalues2d(kindex,2) = tab(i)
-           kindex = kindex + 1
-         enddo
+       child%var%oldvalues2d(kindex:kindex+newsize-1,1)=
+     &        child%var%oldvalues2d(kindex:kindex+newsize-1,2)
       endif
-     
-
+
+      SELECT CASE (nbdim)
+      CASE (1)
+
+         do ir=bounds(1,1),bounds(1,2)
+            child%var%oldvalues2d(kindex,2) =
+     &           child%var%array1(ir)
+            kindex = kindex + 1
+         enddo       
+C
+      CASE (2)
+
+        do jr=bounds(2,1),bounds(2,2)
+           do ir=bounds(1,1),bounds(1,2)
+            child%var%oldvalues2d(kindex,2) =
+     &           child%var%array2(ir,jr)
+            kindex = kindex + 1
+           enddo
+         enddo      
+C
+      CASE (3)
+        do kr=bounds(3,1),bounds(3,2)
+          do jr=bounds(2,1),bounds(2,2)
+             do ir=bounds(1,1),bounds(1,2)
+            child%var%oldvalues2d(kindex,2) =
+     &           child%var%array3(ir,jr,kr)
+            kindex = kindex + 1
+             enddo
+           enddo
+         enddo       
+C
+      CASE (4)
+          do lr=bounds(4,1),bounds(4,2)
+           do kr=bounds(3,1),bounds(3,2)
+             do jr=bounds(2,1),bounds(2,2)
+               do ir=bounds(1,1),bounds(1,2)
+            child%var%oldvalues2d(kindex,2) =
+     &           child%var%array4(ir,jr,kr,lr)
+            kindex = kindex + 1
+               enddo
+             enddo
+           enddo
+         enddo         
+C
+      CASE (5)
+         do mr=bounds(5,1),bounds(5,2)
+           do lr=bounds(4,1),bounds(4,2)
+            do kr=bounds(3,1),bounds(3,2) 
+              do jr=bounds(2,1),bounds(2,2)
+                 do ir=bounds(1,1),bounds(1,2)
+            child%var%oldvalues2d(kindex,2) =
+     &           child%var%array5(ir,jr,kr,lr,mr)
+            kindex = kindex + 1
+                 enddo
+               enddo
+             enddo
+           enddo
+         enddo   
+C
+      CASE (6)
+        do nr=bounds(6,1),bounds(6,2)
+           do mr=bounds(5,1),bounds(5,2)
+             do lr=bounds(4,1),bounds(4,2)
+               do kr=bounds(3,1),bounds(3,2)
+                do jr=bounds(2,1),bounds(2,2)
+                   do ir=bounds(1,1),bounds(1,2)
+            child%var%oldvalues2d(kindex,2) =
+     &           child%var%array6(ir,jr,kr,lr,mr,nr)
+            kindex = kindex + 1
+                   enddo
+                 enddo
+               enddo
+             enddo
+           enddo
+         enddo       
+      END SELECT
 C
 C                                                  
@@ -1099 +1133 @@
 C     **************************************************************************
 C
-      Subroutine timeInterpolation(child,tab,kindex,c1t,c2t) 
+      Subroutine timeInterpolation(child,bounds,kindex,c1t,c2t,nbdim) 
 C
 CCC   Descritpion:
@@ -1110 +1144 @@
 C     argument
       TYPE (AGRIF_PVariable) :: child  ! The fine grid variable
-      REAL, DIMENSION(:)     :: tab
+      INTEGER :: nbdim
+      INTEGER,DIMENSION(nbdim,2) :: bounds
       INTEGER                :: kindex ! Index indicating the values of the fine
                                        ! grid got before and after the space 
@@ -1120 +1155 @@
 C     Local aruments      
       INTEGER :: i
-C
-C
-      do i = 1,size(tab)
-        tab(i) = c2t*child % var % oldvalues2d(kindex,1)   
-     &         + c1t*child % var % oldvalues2d(kindex,2)        
-        kindex = kindex + 1        
-      enddo                                             
+C     Local scalars
+      INTEGER                      :: ir,jr,kr,lr,mr,nr      
+C
+C
+      
+      SELECT CASE (nbdim)
+      CASE (1)
+
+         do ir=bounds(1,1),bounds(1,2)
+                child%var%array1(ir) =
+     &           c2t*child % var % oldvalues2d(kindex,1)   
+     &         + c1t*child % var % oldvalues2d(kindex,2)    
+            kindex = kindex + 1
+         enddo       
+C
+      CASE (2)
+
+        do jr=bounds(2,1),bounds(2,2)
+           do ir=bounds(1,1),bounds(1,2)
+                child%var%array2(ir,jr) =
+     &           c2t*child % var % oldvalues2d(kindex,1)   
+     &         + c1t*child % var % oldvalues2d(kindex,2) 
+            kindex = kindex + 1
+           enddo
+         enddo      
+C
+      CASE (3)
+        do kr=bounds(3,1),bounds(3,2)
+          do jr=bounds(2,1),bounds(2,2)
+             do ir=bounds(1,1),bounds(1,2)
+                child%var%array3(ir,jr,kr) =
+     &           c2t*child % var % oldvalues2d(kindex,1)   
+     &         + c1t*child % var % oldvalues2d(kindex,2) 
+            kindex = kindex + 1
+             enddo
+           enddo
+         enddo       
+C
+      CASE (4)
+          do lr=bounds(4,1),bounds(4,2)
+           do kr=bounds(3,1),bounds(3,2)
+             do jr=bounds(2,1),bounds(2,2)
+               do ir=bounds(1,1),bounds(1,2)
+                child%var%array4(ir,jr,kr,lr) =
+     &           c2t*child % var % oldvalues2d(kindex,1)   
+     &         + c1t*child % var % oldvalues2d(kindex,2) 
+            kindex = kindex + 1
+               enddo
+             enddo
+           enddo
+         enddo         
+C
+      CASE (5)
+         do mr=bounds(5,1),bounds(5,2)
+           do lr=bounds(4,1),bounds(4,2)
+            do kr=bounds(3,1),bounds(3,2) 
+              do jr=bounds(2,1),bounds(2,2)
+                 do ir=bounds(1,1),bounds(1,2)
+                child%var%array5(ir,jr,kr,lr,mr) =
+     &           c2t*child % var % oldvalues2d(kindex,1)   
+     &         + c1t*child % var % oldvalues2d(kindex,2) 
+            kindex = kindex + 1
+                 enddo
+               enddo
+             enddo
+           enddo
+         enddo   
+C
+      CASE (6)
+        do nr=bounds(6,1),bounds(6,2)
+           do mr=bounds(5,1),bounds(5,2)
+             do lr=bounds(4,1),bounds(4,2)
+               do kr=bounds(3,1),bounds(3,2)
+                do jr=bounds(2,1),bounds(2,2)
+                   do ir=bounds(1,1),bounds(1,2)
+                child%var%array6(ir,jr,kr,lr,mr,nr) =
+     &           c2t*child % var % oldvalues2d(kindex,1)   
+     &         + c1t*child % var % oldvalues2d(kindex,2) 
+            kindex = kindex + 1
+                   enddo
+                 enddo
+               enddo
+             enddo
+           enddo
+         enddo       
+      END SELECT
+                                                   
 C
 C
@@ -1134 +1249 @@
 C
 C     **************************************************************************
-CCC   Subroutine checkSize
-C     **************************************************************************
-C
-      Subroutine checkSize(child,newsize)
+CCC   Subroutine Agrif_Checksize
+C     **************************************************************************
+C
+      Subroutine Agrif_Checksize(child,newsize)
 C
 CCC   Descritpion:
@@ -1189 +1304 @@
 C
 C
-      End  Subroutine checkSize
+      End  Subroutine Agrif_Checksize
 C
 C

trunk/AGRIF/AGRIF_FILES/modbcfunction.F

@@ -34 +34 @@
       Use Agrif_Boundary
       Use Agrif_Update
+      Use Agrif_fluxmod
 C             
       IMPLICIT NONE
@@ -109 +110 @@
       dimensio = Agrif_Mygrid % tabvars(tabvarsindic) %var % nbdim
 C
+      if (.not.associated(Agrif_Mygrid % tabvars(tabvarsindic)
+     &                                 %var % posvar)) then
       Allocate( 
      & Agrif_Mygrid % tabvars(tabvarsindic)%var % posvar(dimensio))
-
+      endif 
+            
       do i = 1 , dimensio
          Agrif_Mygrid % tabvars(tabvarsindic) %var % posvar(i)
@@ -214 +218 @@
 C
       dimensio = Agrif_Mygrid % tabvars(tabvarsindic) %var % nbdim
-C         
+C        
+      if (.not.associated(Agrif_Mygrid % tabvars(tabvarsindic)
+     &                                 %var % interptab)) then 
       Allocate(
      & Agrif_Mygrid % tabvars(tabvarsindic)%var% interptab(dimensio))
+      endif
 
       do i = 1 , dimensio
@@ -254 +261 @@
 C
 C     
-      if (Agrif_Curgrid % fixedrank .NE. 0) then    
-      allocate(Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex)
-      Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex = -1
-      if ( PRESENT(Interpolationshouldbemade) ) then
+      if (Agrif_Curgrid % fixedrank .NE. 0) then  
+       IF (.Not.Associated(Agrif_Curgrid%tabvars(tabvarsindic)%var
+     &                % interpIndex)) THEN
+        Allocate(Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex)
+          Agrif_Curgrid%tabvars(tabvarsindic)%var % interpIndex = -1
+
+        Allocate(
+     &    Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D(1,2))
+          Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D = 0. 
+       ENDIF      
+       if ( PRESENT(Interpolationshouldbemade) ) then
          Agrif_Curgrid%tabvars(tabvarsindic)%var %
      &     Interpolationshouldbemade = Interpolationshouldbemade
-      endif
-      Allocate(
-     & Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D(1,2))
-      Agrif_Curgrid%tabvars(tabvarsindic)%var % oldvalues2D = 0. 
+       endif
+
       endif
 C
@@ -591 +603 @@
      & weight,pweight,procname)
       ELSE
+          
       Call Agrif_Interp_Bc_2D(
      & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
@@ -1418 +1431 @@
 
       Return
-      End Subroutine Agrif_update_var5d          
+      End Subroutine Agrif_update_var5d  
+          
+      Subroutine Agrif_Declare_Flux(fluxname,profilename) 
+      character*(*) :: fluxname, profilename
+      Type(Agrif_Flux), pointer :: newflux
+      Type(Agrif_Profile), pointer  :: parcours
+      logical :: foundprofile
+      integer :: i,j,n
+            
+      foundprofile = .FALSE.
+      parcours => Agrif_Myprofiles
+      
+      Do While (Associated(parcours))
+         IF (parcours % profilename == profilename) THEN
+           foundprofile = .TRUE.
+           EXIT
+         ENDIF
+         parcours => parcours%nextprofile
+      End Do      
+      
+      IF (.NOT.foundprofile) THEN
+      write(*,*) 'The profile '''
+     &           //TRIM(profilename)//''' has not been declared'  
+      stop    
+      ENDIF
+      
+      print *,'ici'
+      Allocate(Newflux)
+      
+      Newflux % fluxname = fluxname
+      
+      Newflux % profile => parcours
+      
+      Newflux % nextflux => Agrif_Curgrid % fluxes
+      
+      Agrif_Curgrid % fluxes => Newflux
+      
+      End Subroutine Agrif_Declare_Flux  
+       
+      Subroutine Agrif_Save_Flux(fluxname, fluxtab)
+      character*(*) :: fluxname
+      REAL, DIMENSION(:,:) :: fluxtab
+      
+      
+      Type(Agrif_Flux), pointer :: Flux
+      
+      Type(Agrif_pgrid), pointer :: parcours_child
+      
+      Type(Agrif_grid), Pointer :: currentgrid,oldcurgrid
+      
+      IF (.Not.Agrif_Root()) THEN
+      Flux => Agrif_Search_Flux(fluxname)
+
+      IF (.NOT.Flux%fluxallocated) THEN
+        CALL Agrif_AllocateFlux(Flux,fluxtab)
+      ENDIF
+      
+      Call Agrif_Save_Fluxtab(Flux,fluxtab)
+      
+      ENDIF
+      
+      oldcurgrid=> Agrif_Curgrid
+      
+      parcours_child => Agrif_Curgrid%child_grids
+      
+      Do While (Associated(parcours_child))
+        currentgrid => parcours_child%gr
+        Agrif_Curgrid => parcours_child%gr
+        Flux => Agrif_Search_Flux(fluxname)
+        IF (.NOT.Flux%fluxallocated) THEN
+          CALL Agrif_AllocateFlux(Flux,fluxtab)
+        ENDIF        
+        Call Agrif_Save_Fluxtab_child(Flux,fluxtab)
+        parcours_child=> parcours_child%next
+      End Do
+      
+      Agrif_Curgrid=>oldcurgrid
+      
+      End Subroutine Agrif_Save_Flux
+
+      Subroutine Agrif_Cancel_Flux(fluxname)
+      character*(*) :: fluxname
+      
+      Type(Agrif_Flux), pointer :: Flux
+      
+      Flux => Agrif_Search_Flux(fluxname)
+
+      IF (Flux%FluxAllocated) Call Agrif_Cancel_Fluxarray(Flux)
+      
+      End Subroutine Agrif_Cancel_Flux
+ 
+      Subroutine Agrif_Flux_Correction(fluxname, procname)
+      character*(*) :: fluxname
+      external :: procname
+      
+      Type(Agrif_Flux), pointer :: Flux
+      
+      Flux => Agrif_Search_Flux(fluxname)
+      
+      Call Agrif_FluxCorrect(Flux, procname)
+
+      
+      End Subroutine Agrif_Flux_Correction
+                  
+      Subroutine Agrif_Declare_Profile(profilename,posvar,firstpoint,
+     &    raf)
+      character*(*) :: profilename
+      Type(Agrif_Profile), Pointer :: newprofile
+      INTEGER, DIMENSION(:) :: posvar
+      INTEGER, DIMENSION(:) :: firstpoint
+      CHARACTER(*) ,DIMENSION(:) :: raf      
+      INTEGER :: dimensio
+            
+      dimensio = SIZE(posvar)
+C
+C    
+      Allocate(newprofile)
+      Allocate(newprofile%posvar(dimensio))
+      Allocate(newprofile%interptab(dimensio))
+      newprofile%profilename = profilename
+      newprofile%interptab = raf
+      newprofile%nbdim = dimensio
+      newprofile%posvar = posvar
+      newprofile%point(1:dimensio) = firstpoint
+      
+      newprofile % nextprofile => Agrif_myprofiles
+      
+      Agrif_myprofiles => newprofile
+      
+      End Subroutine Agrif_Declare_Profile
+              
 C
       End module Agrif_bcfunction

trunk/AGRIF/AGRIF_FILES/modcluster.F

@@ -131 +131 @@
 C
 C       Recursive call to Agrif_Cluster_All            
-        Call Agrif_Cluster_All (newgrid, parcours % r)       
+        Call Agrif_Cluster_All (newgrid, parcours % r)     
 C
         parcours => parcours % next 
@@ -574 +574 @@
 C coefficient 1.05 avant 1.15 possibilité de laisser choix à l utilisateur
                   if  (REAL(nbpointsflag)/REAL(nbpoints)
-     &                 .LT.(1.05*cureff)) then
+     &                 .LT.(1.0001*cureff)) then
                       parcbox2 => boxlib            
                       do While (associated(parcbox2))

trunk/AGRIF/AGRIF_FILES/modcurgridfunctions.F

@@ -779 +779 @@
 C
       End Function Agrif_Get_Unit
+      
+      Subroutine Agrif_Set_Efficiency(eff)
+      REAL :: eff
+      
+      IF ((eff.LT.0.).OR.(eff.GT.1)) THEN
+      write(*,*)'Error Efficiency should be between 0 and 1'
+      stop
+      ELSE
+      Agrif_efficiency = eff
+      ENDIF
+      End Subroutine Agrif_Set_Efficiency
+      
+      Subroutine Agrif_Set_Regridding(regfreq)
+      INTEGER :: regfreq
+      
+      IF (regfreq.LT.0) THEN
+      write(*,*)'Regridding frequency should be positive'
+      stop
+      ELSE
+      Agrif_regridding = regfreq
+      ENDIF
+      End Subroutine Agrif_Set_Regridding
 C
       End Module Agrif_CurgridFunctions 

trunk/AGRIF/AGRIF_FILES/modinterp.F

@@ -104 +104 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &    child % var % Interpolationshouldbemade       
+     &    child % var % Interpolationshouldbemade 
+      childtemp % var % list_interp => child % var% list_interp            
 C      
       Call Agrif_InterpVariable
      &     (TypeInterp,parent,childtemp,torestore)
+      child % var % list_interp => childtemp % var %list_interp     
 C      
       deallocate(childtemp % var)
@@ -173 +175 @@
       childtemp % var % interpIndex => child % var % interpIndex       
       childtemp % var % Interpolationshouldbemade = 
-     &    child % var % Interpolationshouldbemade       
+     &    child % var % Interpolationshouldbemade   
+      childtemp % var % list_interp => child % var% list_interp          
 C     
       Call Agrif_InterpVariable
      &     (TypeInterp,parent,childtemp,torestore)
+      child % var % list_interp => childtemp % var %list_interp     
 C      
       deallocate(childtemp % var)
@@ -243 +247 @@
       childtemp % var % interpIndex => child % var % interpIndex    
       childtemp % var % Interpolationshouldbemade = 
-     &    child % var % Interpolationshouldbemade       
+     &    child % var % Interpolationshouldbemade   
+      childtemp % var % list_interp => child % var% list_interp          
 C     
       Call Agrif_InterpVariable
      &     (TypeInterp,parent,childtemp,torestore)
+      child % var % list_interp => childtemp % var %list_interp     
 C      
       deallocate(childtemp % var)
@@ -314 +320 @@
       childtemp % var % interpIndex => child % var % interpIndex    
       childtemp % var % Interpolationshouldbemade = 
-     &    child % var % Interpolationshouldbemade       
+     &    child % var % Interpolationshouldbemade  
+      childtemp % var % list_interp => child % var% list_interp           
 C     
       Call Agrif_InterpVariable
      &     (TypeInterp,parent,childtemp,torestore)
+      child % var % list_interp => childtemp % var %list_interp
 C      
       deallocate(childtemp % var)
@@ -386 +394 @@
       childtemp % var % interpIndex => child % var % interpIndex    
       childtemp % var % Interpolationshouldbemade = 
-     &    child % var % Interpolationshouldbemade       
+     &    child % var % Interpolationshouldbemade   
+      childtemp % var % list_interp => child % var% list_interp          
 C      
       Call Agrif_InterpVariable
      &     (TypeInterp,parent,childtemp,torestore)
+     
+      child % var % list_interp => childtemp % var %list_interp
 C      
       deallocate(childtemp % var)
@@ -459 +470 @@
       childtemp % var % interpIndex => child % var % interpIndex    
       childtemp % var % Interpolationshouldbemade = 
-     &    child % var % Interpolationshouldbemade       
+     &    child % var % Interpolationshouldbemade  
+     
+      childtemp % var % list_interp => child % var% list_interp           
 C      
       Call Agrif_InterpVariable
      &     (TypeInterp,parent,childtemp,torestore)
 C      
+      child % var % list_interp => childtemp % var %list_interp
       deallocate(childtemp % var)
 C
@@ -591 +605 @@
 C
 C     Local pointers
-      TYPE(AGRIF_PVARIABLE)      :: tempP,tempPextend  ! Temporary parent grid variable
-      TYPE(AGRIF_PVARIABLE)      :: tempC      ! Temporary child grid variable
+      TYPE(AGRIF_PVARIABLE),SAVE      :: tempP,tempPextend  ! Temporary parent grid variable
+      TYPE(AGRIF_PVARIABLE),SAVE      :: tempC      ! Temporary child grid variable
 C
 C     Local scalars        
@@ -605 +619 @@
       INTEGER,DIMENSION(nbdim,2,2) :: parentarray
       LOGICAL :: memberin,member
-      TYPE(AGRIF_PVARIABLE)                      ::  parentvalues
+      TYPE(AGRIF_PVARIABLE),SAVE                      ::  parentvalues
+      LOGICAL :: find_list_interp
+      INTEGER,DIMENSION(nbdim)    :: indminglob2,indmaxglob2      
 C
 #ifdef AGRIF_MPI
@@ -612 +628 @@
       INTEGER,PARAMETER                          :: etiquette = 100
       INTEGER                                    :: code
-      INTEGER,DIMENSION(nbdim)    :: indminglob2,indmaxglob2
       INTEGER,DIMENSION(nbdim,4)           :: tab3
       INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4
       INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t
+      LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
+      LOGICAL, DIMENSION(1) :: memberin1
 C
 #endif      
@@ -621 +638 @@
 C   
 C     Boundaries of the current grid where interpolation is done
+
+      
+      
+      
+      IF (Associated(child%var%list_interp)) THEN
+      Call Agrif_Find_list_interp(child%var%list_interp,pttab,petab,
+     &                          pttab_Child,pttab_Parent,nbdim,
+     &                          indmin,indmax,indminglob,
+     &       indmaxglob,indminglob2,indmaxglob2,parentarray,
+     &       pttruetab,cetruetab,member,memberin,find_list_interp
+#if defined AGRIF_MPI
+     &       ,tab4t,memberinall
+#endif
+     &    )
+      ELSE
+      find_list_interp = .FALSE.
+      ENDIF
+      
+      IF (.not.find_list_interp) THEN
       Call Agrif_nbdim_Get_bound_dimension(child % var,
      &                               lowerbound,upperbound,nbdim)
@@ -627 +663 @@
      &                                   pttab,petab,
      &                                   pttruetab,cetruetab,memberin)
+     
 C
 C
@@ -640 +677 @@
 
 
-#ifdef AGRIF_MPI 
-
-      IF (memberin) THEN
-      Call Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax,
+#ifdef AGRIF_MPI
+       IF (memberin) THEN
+        Call Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax,
      &                        s_Parent_temp,s_Child_temp,
      &                        s_Child,ds_Child,
@@ -651 +687 @@
      &                        child%var%root_var%posvar,
      &                        child % var % root_var % interptab)
-      ENDIF
-   
+      ENDIF 
 
       Call Agrif_nbdim_Get_bound_dimension(parent%var,
@@ -671 +706 @@
      &                     nbdim,Agrif_Procrank,
      &                     member)
-            endif
-
+       endif
+       
       Call Agrif_ParentGrid_to_ChildGrid()
 #else
@@ -684 +719 @@
 #endif
 
+      ELSE
+      
+#if !defined AGRIF_MPI
+      parentarray(:,1,1) = indminglob
+      parentarray(:,2,1) = indmaxglob
+      parentarray(:,1,2) = indminglob
+      parentarray(:,2,2) = indmaxglob
+      indmin = indminglob
+      indmax = indmaxglob
+      member = .TRUE.
+      s_Parent_temp = s_Parent + (indminglob - pttab_Parent)*ds_Parent
+      s_Child_temp = s_Child + (pttab - pttab_Child) * ds_Child
+#else      
+      s_Parent_temp = s_Parent + (indmin - pttab_Parent)*ds_Parent
+      s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child
+#endif      
+           
+      ENDIF
+
 
 
       IF (member) THEN
-      allocate(tempP%var)
+      IF (.not.associated(tempP%var)) allocate(tempP%var)
 
 C
@@ -736 +790 @@
       Call Agrif_ParentGrid_to_ChildGrid()
       ELSE
+
       Call Agrif_nbdim_VarEQvar(tempP%var,
      &        parentarray(:,1,1),parentarray(:,2,1),
@@ -744 +799 @@
 
 #ifdef AGRIF_MPI
+      if (.not.find_list_interp) then
       tab3(:,1) = indminglob2(:)
       tab3(:,2) = indmaxglob2(:)
@@ -753 +809 @@
      &                   MPI_INTEGER,MPI_COMM_WORLD,code)
 
-      Allocate(tempPextend%var)
+      IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
+
       DO k=0,Agrif_Nbprocs-1
        do j=1,4
@@ -761 +818 @@
       enddo
       enddo
+      
+      memberin1(1) = memberin
+      CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
+     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code)
+     
+      endif     
+           
       Call Get_External_Data(tempP,tempPextend,tab4t(:,:,1),
      &            tab4t(:,:,2),
-     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin)
+     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin,
+     &            memberinall)
 #else
       tempPextend%var => tempP%var
 #endif
 
+      if (.not.find_list_interp) then
+      Call Agrif_Addto_list_interp(child%var%list_interp,pttab,petab,
+     &                          pttab_Child,pttab_Parent,indmin,indmax,
+     &   indminglob,indmaxglob,indminglob2,indmaxglob2,parentarray,
+     &   pttruetab,cetruetab,member,memberin,nbdim
+#if defined AGRIF_MPI
+     &   ,tab4t,memberinall
+#endif
+     &    )
+      endif
+      
 C
 C
       IF (memberin) THEN
-      allocate(tempC%var)
+      IF (.not.associated(tempC%var)) allocate(tempC%var)
 C
 
@@ -784 +860 @@
      &         child % var % root_var % interptab(1:nbdim) .EQ. 'N'
 C
-          Allocate(parentvalues%var)
+          IF (.not.associated(parentvalues%var))
+     &            Allocate(parentvalues%var)
 C
           Call Agrif_nbdim_allocation
@@ -798 +875 @@
 C
           Call Agrif_nbdim_deallocation(parentvalues%var,nbdim)
-          Deallocate(parentvalues%var)
+C          Deallocate(parentvalues%var)
 C
 C
@@ -999 +1076 @@
         CASE (2)
            do j = pttruetab(2),cetruetab(2)
-             do i = pttruetab(1),cetruetab(1)    
-              if (restore%var%restore2D(i,j) == 0)
+             do i = pttruetab(1),cetruetab(1)            
+              if (restore%var%restore2D(i,j) == 0)     
      &              child % var % array2(i,j) = 
      &              tempC % var % array2(i,j)    
@@ -1121 +1198 @@
 
         Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
-        deallocate(tempPextend%var)
+C        deallocate(tempPextend%var)
 
       Call Agrif_nbdim_deallocation(tempC%var,nbdim)
       
-      Deallocate(tempC % var)
+C      Deallocate(tempC % var)
       ELSE
       
-      deallocate(tempPextend%var)
+C      deallocate(tempPextend%var)
 
       ENDIF
@@ -1137 +1214 @@
       IF (member) THEN
       Call Agrif_nbdim_deallocation(tempP%var,nbdim)
-      Deallocate(tempP % var)
+C      Deallocate(tempP % var)
       endif
 #endif
@@ -1169 +1246 @@
 C     Declarations:
 C
-      
-C
-#ifdef AGRIF_MPI
-C
-ccccccccccccccccccccccc#include "mpif.h"
-C
-#endif
 C
 C     Arguments
@@ -1214 +1284 @@
         ELSEIF (interptab(i) .EQ. 'N') THEN
         ELSEIF ( TYPEinterp(i) .eq. Agrif_ppm .or.
-     &      TYPEinterp(i) .eq. Agrif_eno ) THEN            
+     &      TYPEinterp(i) .eq. Agrif_eno  .or.
+     &      TYPEinterp(i) .eq. Agrif_weno) THEN            
            indmin(i) = indmin(i) - 2  
            indmax(i) = indmax(i) + 2                  
-        ELSE IF( TYPEinterp(i) .ne. Agrif_constant ) THEN
+        ELSE IF (( TYPEinterp(i) .ne. Agrif_constant )
+     &        .AND.( TYPEinterp(i) .ne. Agrif_linear )) THEN
            indmin(i) = indmin(i) - 1  
            indmax(i) = indmax(i) + 1
@@ -1262 +1334 @@
       REAL, DIMENSION(nbdim) :: s_child,s_parent
       REAL, DIMENSION(nbdim) :: ds_child,ds_parent
-      REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tabin        
-      REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tabout
+      REAL, INTENT(IN),DIMENSION(indmin(nbdim):indmax(nbdim)) :: tabin        
+      REAL, INTENT(OUT),
+     &      DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tabout
+      INTEGER :: coeffraf
 C
 C
 C     Commentaire perso : nbdim vaut toujours 1 ici. 
 C
+      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+      
       Call Agrif_InterpBase(TypeInterp(1),
      &                  tabin(indmin(nbdim):indmax(nbdim)),
@@ -1274 +1350 @@
      &                  pttab_child(nbdim),petab_child(nbdim),
      &                  s_parent(nbdim),s_child(nbdim),
-     &                  ds_parent(nbdim),ds_child(nbdim))
+     &                  ds_parent(nbdim),ds_child(nbdim),coeffraf)
 C                
       Return
@@ -1309 +1385 @@
       REAL   , DIMENSION(nbdim) ::  s_child, s_parent
       REAL   , DIMENSION(nbdim) :: ds_child,ds_parent
-      REAL   , DIMENSION(
+      REAL   ,INTENT(IN), DIMENSION(
      &                indmin(nbdim-1):indmax(nbdim-1),
      &                indmin(nbdim):indmax(nbdim)
      &                ) :: tabin        
-      REAL   , DIMENSION(
+      REAL   ,INTENT(OUT), DIMENSION(
      &                pttab_child(nbdim-1):petab_child(nbdim-1),
      &                pttab_child(nbdim):petab_child(nbdim)
@@ -1319 +1395 @@
 C
 C     Local variables      
-      REAL, DIMENSION(:,:), Allocatable :: tabtemp
+      REAL, DIMENSION(pttab_child(nbdim-1):petab_child(nbdim-1),
+     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
       INTEGER i,j
-C
-C        
-      Allocate(tabtemp(pttab_child(nbdim-1):petab_child(nbdim-1),
-     &                 indmin(nbdim):indmax(nbdim)))
+      INTEGER :: coeffraf
+C
+C
 C
 C
@@ -1341 +1417 @@
       enddo
 C        
+      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+      
       do i=pttab_child(nbdim-1),petab_child(nbdim-1)
 C
@@ -1349 +1427 @@
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),coeffraf)
 C        
       enddo
-C                
-      Deallocate(tabtemp)
 C
       Return
@@ -1384 +1460 @@
       INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
       REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
-      REAL, DIMENSION(indmin(nbdim-2):indmax(nbdim-2),
+      REAL,INTENT(IN), DIMENSION(indmin(nbdim-2):indmax(nbdim-2),
      &                indmin(nbdim-1):indmax(nbdim-1),
      &                indmin(nbdim)  :indmax(nbdim)) :: tabin        
-      REAL, DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
+      REAL,INTENT(OUT),
+     &        DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
      &                pttab_child(nbdim-1):petab_child(nbdim-1),
      &                pttab_child(nbdim):petab_child(nbdim)) :: tabout
 C
 C     Local variables      
-      REAL, DIMENSION(:,:,:), Allocatable :: tabtemp
+      REAL, DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
+     &                 pttab_child(nbdim-1):petab_child(nbdim-1),
+     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
       INTEGER i,j,k
-C
-C        
-      Allocate(tabtemp(pttab_child(nbdim-2):petab_child(nbdim-2),
-     &                 pttab_child(nbdim-1):petab_child(nbdim-1),
-     &                 indmin(nbdim):indmax(nbdim)))
+      INTEGER :: coeffraf, locind_child_left, kdeb
+C
 C
       do k = indmin(nbdim),indmax(nbdim)
@@ -1413 +1489 @@
 C        
       enddo
+      
+
+      Call Agrif_Compute_nbdim_interp(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+           
+      IF (coeffraf == 1) THEN
+      
+      kdeb = indmin(3)+locind_child_left-2
+      do k=pttab_child(3),petab_child(3)
+      kdeb = kdeb + 1
+      do j = pttab_child(2),petab_child(2)
+        do i = pttab_child(1),petab_child(1)
+        tabout(i,j,k) = tabtemp(i,j,kdeb)
+      enddo
+      enddo
+      enddo
+              
+      ELSE      
 C
       do j=pttab_child(nbdim-1),petab_child(nbdim-1) 
@@ -1424 +1518 @@
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),coeffraf)
 C
         enddo 
 C       
       enddo
-C                
-      Deallocate(tabtemp)
+      ENDIF
 C
       Return
@@ -1461 +1554 @@
       INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
       REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
-      REAL, DIMENSION(indmin(nbdim-3):indmax(nbdim-3),
+      REAL,INTENT(IN), DIMENSION(indmin(nbdim-3):indmax(nbdim-3),
      &                indmin(nbdim-2):indmax(nbdim-2),
      &                indmin(nbdim-1):indmax(nbdim-1),
      &                indmin(nbdim):indmax(nbdim)) :: tabin        
-      REAL, DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
+      REAL,INTENT(OUT),
+     &       DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
      &                pttab_child(nbdim-2):petab_child(nbdim-2),
      &                pttab_child(nbdim-1):petab_child(nbdim-1),
@@ -1471 +1565 @@
 C
 C     Local variables      
-      REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp
-      INTEGER i,j,k,l
-C
-C        
-      Allocate(tabtemp(pttab_child(nbdim-3):petab_child(nbdim-3),
+      REAL, DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
      &                 pttab_child(nbdim-2):petab_child(nbdim-2),
      &                 pttab_child(nbdim-1):petab_child(nbdim-1),  
-     &                 indmin(nbdim):indmax(nbdim)))
+     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
+      INTEGER i,j,k,l
+      INTEGER :: coeffraf
+C
 C
       do l = indmin(nbdim),indmax(nbdim)
@@ -1496 +1589 @@
       enddo
 C
+      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+      
       do k = pttab_child(nbdim-1),petab_child(nbdim-1)
 C
@@ -1508 +1603 @@
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),coeffraf)
 C
           enddo
@@ -1515 +1610 @@
 C       
       enddo
-C                
-      Deallocate(tabtemp)
 C
       Return
@@ -1547 +1640 @@
       INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
       REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
-      REAL, DIMENSION(indmin(nbdim-4):indmax(nbdim-4),
+      REAL,INTENT(IN), DIMENSION(indmin(nbdim-4):indmax(nbdim-4),
      &                indmin(nbdim-3):indmax(nbdim-3),
      &                indmin(nbdim-2):indmax(nbdim-2),
      &                indmin(nbdim-1):indmax(nbdim-1),
      &                indmin(nbdim):indmax(nbdim)) :: tabin  
-      REAL, DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
+      REAL,INTENT(OUT),
+     &    DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
      &                pttab_child(nbdim-3):petab_child(nbdim-3),
      &                pttab_child(nbdim-2):petab_child(nbdim-2),
@@ -1559 +1653 @@
 C
 C     Local variables      
-      REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp
-      INTEGER i,j,k,l,m
-C
-C        
-      Allocate(tabtemp(pttab_child(nbdim-4):petab_child(nbdim-4),
+      REAL, DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
      &                 pttab_child(nbdim-3):petab_child(nbdim-3),
      &                 pttab_child(nbdim-2):petab_child(nbdim-2),
      &                 pttab_child(nbdim-1):petab_child(nbdim-1),    
-     &                 indmin(nbdim):indmax(nbdim)))
+     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
+      INTEGER i,j,k,l,m
+      INTEGER :: coeffraf
+C
 C
       do m = indmin(nbdim),indmax(nbdim)
@@ -1586 +1679 @@
 C        
       enddo
+      
+      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
 C
       do l = pttab_child(nbdim-1),petab_child(nbdim-1) 
@@ -1602 +1697 @@
      &             pttab_child(nbdim),petab_child(nbdim),
      &             s_parent(nbdim),s_child(nbdim),
-     &             ds_parent(nbdim),ds_child(nbdim))
+     &             ds_parent(nbdim),ds_child(nbdim),coeffraf)
 C
             enddo
@@ -1611 +1706 @@
 C       
       enddo
-C                
-      Deallocate(tabtemp)
+C
 C
       Return
@@ -1643 +1737 @@
       INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
       REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
-      REAL, DIMENSION(indmin(nbdim-5):indmax(nbdim-5),
+      REAL,INTENT(IN), DIMENSION(indmin(nbdim-5):indmax(nbdim-5),
      &                indmin(nbdim-4):indmax(nbdim-4),
      &                indmin(nbdim-3):indmax(nbdim-3), 
@@ -1649 +1743 @@
      &                indmin(nbdim-1):indmax(nbdim-1),
      &                indmin(nbdim):indmax(nbdim)) :: tabin        
-      REAL, DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
+      REAL,INTENT(OUT),
+     &    DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
      &                pttab_child(nbdim-4):petab_child(nbdim-4),
      &                pttab_child(nbdim-3):petab_child(nbdim-3),
@@ -1657 +1752 @@
 C
 C     Local variables      
-      REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp
-      INTEGER i,j,k,l,m,n
-C
-C        
-      Allocate(tabtemp(pttab_child(nbdim-5):petab_child(nbdim-5),
+      REAL, DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
      &                 pttab_child(nbdim-4):petab_child(nbdim-4),
      &                 pttab_child(nbdim-3):petab_child(nbdim-3),
      &                 pttab_child(nbdim-2):petab_child(nbdim-2),    
      &                 pttab_child(nbdim-1):petab_child(nbdim-1),    
-     &                 indmin(nbdim):indmax(nbdim)))
+     &                 indmin(nbdim):indmax(nbdim)) :: tabtemp
+      INTEGER i,j,k,l,m,n
+      INTEGER :: coeffraf
+C
+C        
 C
       do n = indmin(nbdim),indmax(nbdim)
@@ -1687 +1782 @@
 C        
       enddo
+      
+      coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
 C
       do m = pttab_child(nbdim-1),petab_child(nbdim-1) 
@@ -1704 +1801 @@
      &             pttab_child(nbdim),petab_child(nbdim),
      &             s_parent(nbdim),s_child(nbdim),
-     &             ds_parent(nbdim),ds_child(nbdim))
+     &             ds_parent(nbdim),ds_child(nbdim),coeffraf)
 C
             enddo
@@ -1715 +1812 @@
       enddo
 C                
-      Deallocate(tabtemp)
 C
       Return
@@ -1731 +1827 @@
      &                           parenttab,childtab,
      &                           indmin,indmax,pttab_child,petab_child,
-     &                           s_parent,s_child,ds_parent,ds_child)   
+     &                           s_parent,s_child,ds_parent,ds_child,
+     &                           coeffraf)   
 C
 CCC   Description:
@@ -1744 +1841 @@
       INTEGER :: indmin,indmax
       INTEGER :: pttab_child,petab_child
-      REAL,DIMENSION(indmin:indmax)           :: parenttab       
-      REAL,DIMENSION(pttab_child:petab_child) :: childtab      
+      REAL,INTENT(IN),DIMENSION(indmin:indmax)           :: parenttab       
+      REAL,INTENT(OUT),DIMENSION(pttab_child:petab_child) :: childtab        
       REAL    :: s_parent,s_child,ds_parent,ds_child 
+      INTEGER :: coeffraf
 C 
 C
@@ -1774 +1872 @@
      &         indmax-indmin+1,petab_child-pttab_child+1,
      &         s_parent,s_child,ds_parent,ds_child)
-C              
+C        
+        elseif (TYPEinterp .EQ. AGRIF_WENO) then
+C          
+C         Eno interpolation
+          Call weno1D
+     &         (parenttab,childtab,
+     &         indmax-indmin+1,petab_child-pttab_child+1,
+     &         s_parent,s_child,ds_parent,ds_child)
+C            
         Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERV) then
 C          
@@ -1812 +1918 @@
 C
 
-
-C                        
+      Subroutine Agrif_Compute_nbdim_interp(s_parent,s_child,
+     &  ds_parent,ds_child,coeffraf,locind_child_left)
+      real :: s_parent,s_child,ds_parent,ds_child
+      integer :: coeffraf,locind_child_left
+     
+      coeffraf = nint(ds_parent/ds_child)
+      locind_child_left = 1 + agrif_int((s_child-s_parent)/ds_parent)
+      End Subroutine Agrif_Compute_nbdim_interp
+C          
+
+      Subroutine Agrif_Find_list_interp(list_interp,pttab,petab,
+     &                          pttab_Child,pttab_Parent,nbdim,
+     &                          indmin,indmax,indminglob,
+     &      indmaxglob,indminglob2,indmaxglob2,parentarray,
+     &       pttruetab,cetruetab,member,memberin,
+     &      find_list_interp
+#if defined AGRIF_MPI
+     &     ,tab4t,memberinall
+#endif
+     &    )     
+      TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
+      INTEGER :: nbdim
+      INTEGER,DIMENSION(nbdim)   :: pttab,petab,pttab_Child,pttab_Parent
+      LOGICAL :: find_list_interp
+      Type(Agrif_List_Interp_loc), Pointer :: parcours
+      INTEGER,DIMENSION(nbdim)   :: indmin,indmax  
+      INTEGER,DIMENSION(nbdim)   :: indminglob,indmaxglob
+      INTEGER,DIMENSION(nbdim)   :: pttruetab,cetruetab      
+      INTEGER,DIMENSION(nbdim)   :: indminglob2,indmaxglob2  
+      INTEGER,DIMENSION(nbdim,2,2) :: parentarray
+      LOGICAL :: member, memberin
+      INTEGER :: i
+#ifdef AGRIF_MPI
+C
+      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t
+      LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
+#endif 
+                    
+      find_list_interp = .FALSE.
+      
+      parcours => list_interp
+      Find_loop :   Do While (associated(parcours))
+        Do i=1,nbdim
+          IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
+     &        (petab(i) /= parcours%interp_loc%petab(i)).OR.
+     &        (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
+     &        (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
+     &               THEN
+            parcours=>parcours%suiv
+            Cycle Find_loop
+          ENDIF
+        EndDo
+C        print *,'ok trouve'
+        indmin = parcours%interp_loc%indmin(1:nbdim)
+        indmax = parcours%interp_loc%indmax(1:nbdim)
+        
+        pttruetab = parcours%interp_loc%pttruetab(1:nbdim)
+        cetruetab = parcours%interp_loc%cetruetab(1:nbdim)
+                
+#if !defined AGRIF_MPI
+        indminglob = parcours%interp_loc%indminglob(1:nbdim)
+        indmaxglob = parcours%interp_loc%indmaxglob(1:nbdim)
+#else
+        indminglob2 = parcours%interp_loc%indminglob2(1:nbdim)
+        indmaxglob2 = parcours%interp_loc%indmaxglob2(1:nbdim)
+        parentarray = parcours%interp_loc%parentarray(1:nbdim,:,:)
+        member = parcours%interp_loc%member
+        tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:4)
+        memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
+#endif        
+        memberin = parcours%interp_loc%memberin
+        find_list_interp = .TRUE.   
+        Exit Find_loop
+      End Do Find_loop  
+                              
+      End Subroutine Agrif_Find_list_interp   
+      
+      Subroutine Agrif_AddTo_list_interp(list_interp,pttab,petab,
+     &                          pttab_Child,pttab_Parent,indmin,indmax,
+     &                          indminglob,indmaxglob,
+     &                          indminglob2,indmaxglob2,
+     &                          parentarray,pttruetab,cetruetab,
+     &                          member,memberin,nbdim
+#if defined AGRIF_MPI
+     &      ,tab4t,memberinall
+#endif
+     &    )
+          
+      TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
+      INTEGER :: nbdim
+      INTEGER,DIMENSION(nbdim)   :: pttab,petab,pttab_Child,pttab_Parent
+      INTEGER,DIMENSION(nbdim)   :: indmin,indmax
+      INTEGER,DIMENSION(nbdim)   :: indminglob,indmaxglob
+      INTEGER,DIMENSION(nbdim)   :: indminglob2,indmaxglob2
+      INTEGER,DIMENSION(nbdim)   :: pttruetab,cetruetab
+      INTEGER,DIMENSION(nbdim,2,2) :: parentarray
+      LOGICAL :: member, memberin
+#ifdef AGRIF_MPI
+C
+      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t
+      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
+#endif                   
+      Type(Agrif_List_Interp_loc), Pointer :: parcours
+            
+       Allocate(parcours)
+      Allocate(parcours%interp_loc)
+      
+      parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
+      parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
+      parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
+      parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
+  
+  
+      parcours%interp_loc%indmin(1:nbdim) = indmin(1:nbdim)
+      parcours%interp_loc%indmax(1:nbdim) = indmax(1:nbdim)
+
+      parcours%interp_loc%memberin = memberin
+#if !defined AGRIF_MPI
+      parcours%interp_loc%indminglob(1:nbdim) = indminglob(1:nbdim)
+      parcours%interp_loc%indmaxglob(1:nbdim) = indmaxglob(1:nbdim)
+#else
+      parcours%interp_loc%indminglob2(1:nbdim) = indminglob2(1:nbdim)
+      parcours%interp_loc%indmaxglob2(1:nbdim) = indmaxglob2(1:nbdim)
+      parcours%interp_loc%parentarray(1:nbdim,:,:) 
+     &       = parentarray(1:nbdim,:,:)
+      parcours%interp_loc%member = member
+      Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,4))
+      Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
+      parcours%interp_loc%tab4t=tab4t   
+      parcours%interp_loc%memberinall=memberinall   
+#endif      
+
+      parcours%interp_loc%pttruetab(1:nbdim) = pttruetab(1:nbdim)
+      parcours%interp_loc%cetruetab(1:nbdim) = cetruetab(1:nbdim)
+      
+      parcours%suiv => list_interp
+      
+      list_interp => parcours
+      End Subroutine Agrif_Addto_list_interp 
+                
       End Module Agrif_Interpolation

trunk/AGRIF/AGRIF_FILES/modinterpbasic.F

@@ -36 +36 @@
       IMPLICIT NONE
 C             
+      Real,Dimension(Agrif_MaxRaff) :: tabdiff2, tabdiff3
+      Real,Dimension(:),Allocatable::tabtest4      
+       
       CONTAINS
 C     Define procedures contained in this module
-C 
-C
+C  
 C     **************************************************************************  
 CCC   Subroutine Linear1d  
@@ -59 +61 @@
 C     Arguments
       INTEGER             :: np,nc      
-      REAL, DIMENSION(np) :: x      
-      REAL, DIMENSION(nc) :: y  
+      REAL,INTENT(IN), DIMENSION(np) :: x      
+      REAL,INTENT(OUT), DIMENSION(nc) :: y  
       REAL                :: s_parent,s_child,ds_parent,ds_child
 C
 C     Local scalars
       INTEGER :: i,coeffraf,locind_parent_left
-      REAL    :: ypos,globind_parent_left
+      REAL    :: ypos,globind_parent_left,globind_parent_right
+      REAL    :: invds, invds2
+      REAL :: ypos2,diff
 C
 C
@@ -81 +85 @@
       endif                          
 C
-      ypos = s_child      
-C
-      do i = 1,nc-1
-C
-        locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
-C
+      ypos = s_child 
+
+      locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
         globind_parent_left = s_parent 
      &                        + (locind_parent_left - 1)*ds_parent
-C        
-        y(i) = ((globind_parent_left + ds_parent - ypos)
-     &          *x(locind_parent_left)
-     &        + (ypos - globind_parent_left)
-     &          *x(locind_parent_left+1))
-     &         / ds_parent                
-C
-        ypos = ypos + ds_child
+
+        globind_parent_right = globind_parent_left + ds_parent
+
+C
+      invds = 1./ds_parent
+      invds2 = ds_child/ds_parent
+      
+      ypos2 = ypos*invds
+      globind_parent_right=globind_parent_right*invds
+      
+      do i = 1,nc-1
+C
+        if (ypos2 > globind_parent_right) then
+           locind_parent_left = locind_parent_left + 1.
+           globind_parent_right = globind_parent_right + 1.
+        endif
+        
+        diff=(globind_parent_right - ypos2)
+        
+        y(i) = (diff*x(locind_parent_left)
+     &        + (1.-diff)*x(locind_parent_left+1))
+C
+        ypos2 = ypos2 + invds2
 C
       enddo
 C
+      ypos = s_child + (nc-1)*ds_child
       locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
 C
@@ -114 +132 @@
      &            *x(locind_parent_left)
      &          + (ypos - globind_parent_left)
-     &            *x(locind_parent_left+1))
-     &           / ds_parent     
+     &            *x(locind_parent_left+1))*invds
 C
       endif                                          
@@ -123 +140 @@
 C       
       End Subroutine Linear1d   
+       
 C
 C
@@ -145 +163 @@
 C     Arguments
       INTEGER             :: np,nc      
-      REAL, DIMENSION(np) :: x      
-      REAL, DIMENSION(nc) :: y  
+      REAL,INTENT(IN), DIMENSION(np) :: x      
+      REAL,INTENT(OUT), DIMENSION(nc) :: y  
       REAL                :: s_parent,s_child,ds_parent,ds_child 
 C
@@ -153 +171 @@
       REAL    :: ypos,globind_parent_left
       REAL    :: X1,X2,X3 
+      real :: deltax,invdsparent
+      real t1,t2,t3,t4,t5,t6,t7,t8
 C
 C 
@@ -175 +195 @@
 C
       endif
+      
+      invdsparent=1./ds_parent
 C
       ypos = s_child      
@@ -182 +204 @@
         locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
 C
+
         globind_parent_left = s_parent 
      &                        + (locind_parent_left - 1)*ds_parent 
-C
-        if (locind_parent_left+2 <= np) then            
-C
-            X1 = (x(locind_parent_left+1)-x(locind_parent_left))
-     &           /ds_parent
-C 
-            X2 = (x(locind_parent_left+2)-x(locind_parent_left+1))
-     &           /ds_parent
-C
-            X3 = (X2 - X1)/(2.*ds_parent)                 
-C
-            y(i) = x(locind_parent_left) + 
-     &             (ypos - globind_parent_left)*X1 +
-     &             (ypos - globind_parent_left)*
-     &             (ypos - globind_parent_left - ds_parent)*X3 
-C
-          elseif (locind_parent_left+1 <= np) then 
-C
-            X1 = (x(locind_parent_left)-x(locind_parent_left-1))
-     &           /ds_parent
-C     
-            X2 = (x(locind_parent_left+1)-x(locind_parent_left))
-     &           /ds_parent
-C 
-            X3 = (X2 - X1)/(2.*ds_parent)                 
-C
-            y(i) = x(locind_parent_left-1) + 
-     &             (ypos - globind_parent_left - ds_parent)*X1 +
-     &             (ypos - globind_parent_left - ds_parent)*
-     &             (ypos - globind_parent_left)*X3
-C
-          else
-C
-            X1 = (x(locind_parent_left-1)-x(locind_parent_left-2))
-     &           /ds_parent
-C     
-            X2 = (x(locind_parent_left)-x(locind_parent_left-1))
-     &           /ds_parent
-C 
-            X3 = (X2 - X1)/(2.*ds_parent)                 
-C
-            y(i) = x(locind_parent_left-2) + 
-     &             (ypos - globind_parent_left - 2.*ds_parent)*X1 +
-     &             (ypos - globind_parent_left - 2.*ds_parent)*
-     &             (ypos - globind_parent_left - ds_parent)*X3
-C
-        endif   
-C       
-        ypos = ypos + ds_child 
+     
+        deltax = invdsparent*(ypos-globind_parent_left)
+        ypos = ypos + ds_child
+         if (abs(deltax).LE.0.0001) then
+           y(i)=x(locind_parent_left)
+           
+           cycle
+         endif
+C           
+C
+        t2 = deltax - 2.
+        t3 = deltax - 1.
+        t4 = deltax + 1.
+        
+        t5 = -(1./6.)*deltax*t2*t3
+        t6 = 0.5*t2*t3*t4
+        t7 = -0.5*deltax*t2*t4
+        t8 = (1./6.)*deltax*t3*t4
+        
+        y(i)=t5*x(locind_parent_left-1)+t6*x(locind_parent_left)
+     &  +t7*x(locind_parent_left+1)+t8*x(locind_parent_left+2)
+C
 C
       enddo
@@ -261 +257 @@
 C     Arguments
       INTEGER             :: np,nc      
-      REAL, DIMENSION(np) :: x      
-      REAL, DIMENSION(nc) :: y  
+      REAL,INTENT(IN), DIMENSION(np) :: x      
+      REAL,INTENT(OUT), DIMENSION(nc) :: y  
       REAL                :: s_parent,s_child,ds_parent,ds_child
 C
@@ -551 +547 @@
 C     Arguments
       Integer             :: np,nc      
-      Real, Dimension(np) :: x      
-      Real, Dimension(nc) :: y
-      Real, Dimension(:),Allocatable :: ytemp
+      Real, INTENT(IN),Dimension(np) :: x      
+      Real, INTENT(OUT),Dimension(nc) :: y
+C      Real, Dimension(:),Allocatable :: ytemp
       Real                :: s_parent,s_child,ds_parent,ds_child
 C
@@ -561 +557 @@
       Real    :: ypos
       integer :: i1,jj
-      Real :: xpmin,cavg,a,b
+      Real :: xpmin,a
 C      
       Real :: xrmin,xrmax,am3,s2,s1  
-      Real, Dimension(np) :: dela,xr,xl,delta,a6,slope,slope2
-      Real, Dimension(:),Allocatable  :: diff,diff2,diff3    
+      Real, Dimension(np) :: xl,delta,a6,slope
+C      Real, Dimension(:),Allocatable  :: diff,diff2,diff3    
       INTEGER :: diffmod
+      REAL :: invcoeffraf
 C      
       coeffraf = nint(ds_parent/ds_child)
@@ -575 +572 @@
           return
       End If
-C      
-      Allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+      invcoeffraf = ds_child/ds_parent
+C      
+
+      IF( .NOT. allocated(tabtest4) ) THEN    
+      Allocate(tabtest4(-2*coeffraf:nc+2*coeffraf))
+      ELSE
+         IF (size(tabtest4) .LT. nc+4*coeffraf+1)THEN
+         deallocate( tabtest4 )
+         Allocate(tabtest4(-2*coeffraf:nc+2*coeffraf))
+         ENDIF
+      ENDIF  
       ypos = s_child  
 C
@@ -587 +593 @@
       i1 = 1+agrif_int((xpmin-s_child)/ds_child)        
 C     
-      Allocate( diff(coeffraf),diff2(coeffraf),diff3(coeffraf) )
-C      
-         diff(:) = ds_child/ds_parent
-C      
+C
+      
       Do i=1,coeffraf
-         a = real(i-1)*ds_child/ds_parent
-         b = real(i)*ds_child/ds_parent
-         diff2(i) = 0.5*(b*b - a*a)  
-         diff3(i) = (1./3.)*(b*b*b - a*a*a)
-      End do
+        tabdiff2(i)=(real(i)-0.5)*invcoeffraf
+      EndDo
+
+      a = invcoeffraf**2 
+      tabdiff3(1) = (1./3.)*a
+      a=2.*a
+      Do i=2,coeffraf
+        tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a
+      EndDo
 C
       if( locind_parent_last+2 <= np ) then
@@ -612 +620 @@
       endif    
 C 
+C
       Do i = nmin,nmax
          slope(i) = x(i) - x(i-1)
-         slope2(i) = 2.*abs(slope(i))
       Enddo
-C
-      Do i = nmin,nmax-1
-         dela(i) = 0.5 * ( slope(i) + slope(i+1) )
-C Van Leer slope limiter
-         dela(i) = min( abs(dela(i)),slope2(i),
-     &                  slope2(i+1) )*sign(1.,dela(i))
-         IF( slope(i)*slope(i+1) <= 0. ) dela(i) = 0.
+
+      Do i = nmin+1,nmax-1
+         xl(i)= 0.5*(x(i-1)+x(i))
+     &      -0.08333333333333*(slope(i+1)-slope(i-1)) 
       Enddo
 C
-      Do i = nmin,nmax-2
-         xr(i) = x(i) + (1./2.)*slope(i+1) + (-1./6.)*dela(i+1)
-     &                                     + ( 1./6. )*dela(i)
-      Enddo
-C
-      Do i = nmin,nmax-2
-         xrmin = min(x(i),x(i+1))
-         xrmax = max(x(i),x(i+1))
-         xr(i) = min(xr(i),xrmax)
-         xr(i) = max(xr(i),xrmin)
-         xl(i+1) = xr(i)         
-      Enddo
 C apply parabolic monotonicity
        Do i = locind_parent_left,locind_parent_last
-          If( ( (xr(i)-x(i))* (x(i)-xl(i)) ) .le. 0. ) then
-             xl(i) = x(i) 
-             xr(i) = x(i)
-          Endif          
-          delta(i) = xr(i) - xl(i)
-          am3 = 3. * x(i)
-          s1  = am3 - 2. * xr(i)
-          s2  = am3 - 2. * xl(i)
-          IF( delta(i) * (xl(i) - s1) .le. 0. ) xl(i) = s1
-          IF( delta(i) * (s2 - xr(i)) .le. 0. ) xr(i) = s2
-          delta(i) = xr(i) - xl(i)
-          a6(i) = 6.*x(i)-3.*(xl(i) +xr(i))
+          delta(i) = xl(i+1) - xl(i)
+          a6(i) = 6.*x(i)-3.*(xl(i) +xl(i+1))
 C
        End do   
 C
         diffmod = 0
-        IF (mod(coeffraf,2) == 0) diffmod = 1           
+       IF (mod(coeffraf,2) == 0) diffmod = 1
 C
         ipos = i1
@@ -661 +644 @@
         Do iparent = locind_parent_left,locind_parent_last       
              pos=1
-             cavg = 0.
              Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
 C
-               ytemp(jj) = (diff(pos)*xl(iparent)   
-     &             + diff2(pos)
-     &             *  (delta(iparent)+a6(iparent))
-     &             - diff3(pos)*a6(iparent))*coeffraf
-                              
-               cavg = cavg + ytemp(jj)
+               tabtest4(jj) = xl(iparent)   
+     &             + tabdiff2(pos) *  (delta(iparent)+a6(iparent))
+     &             - tabdiff3(pos) *  a6(iparent)
                pos = pos+1 
              End do 
@@ -677 +656 @@
 C
 C
+        y(1:nc)=tabtest4(1:nc)
+        
+      Return
+      End Subroutine ppm1d
+      
+C     **************************************************************************  
+CCC   Subroutine weno1d
+C     ************************************************************************** 
+C 
+      Subroutine weno1dnew(x,y,np,nc,
+     &                    s_parent,s_child,ds_parent,ds_child) 
+C
+CCC   Description:
+CCC   Subroutine to do a 1D interpolation and apply monotonicity constraints
+CCC   using piecewise parabolic method  
+CCC   on a child grid (vector y) from its parent grid (vector x).
+CC    Method:
+C
+C     Declarations:
+C
+      Implicit none
+C        
+C     Arguments
+      Integer             :: np,nc
+      Real, Dimension(np) :: x
+      Real, Dimension(nc) :: y
+      Real, Dimension(:),Allocatable :: ytemp
+      Real                :: s_parent,s_child,ds_parent,ds_child
+C
+C     Local scalars
+      Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+      Integer :: iparent,ipos,pos,nmin,nmax
+      Real    :: ypos
+      integer :: i1,jj
+      Real :: xpmin,cavg,a,b
+C      
+      Real :: xrmin,xrmax,am3,s2,s1
+      Real, Dimension(np) :: xr,xl,delta,a6,slope,slope2,smooth
+      Real, Dimension(:),Allocatable  :: diff,diff2,diff3
+      INTEGER :: diffmod
+      REAL :: invcoeffraf
+      integer :: s,l,k
+      integer :: etan, etap
+      real :: delta0, delta1, delta2
+      real :: epsilon
+      parameter (epsilon = 1.D-8)
+      real, dimension(:,:), allocatable :: ak, ck
+C      
+      coeffraf = nint(ds_parent/ds_child)
+C
+      If (coeffraf == 1) Then
+          locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+          y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+          return
+      End If
+      invcoeffraf = ds_child/ds_parent
+      Allocate(ak(0:1,coeffraf))
+      Allocate(ck(0:1,coeffraf))
+            
+C      
+      Allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+      ypos = s_child
+C
+      locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+      locind_parent_last = 1 +
+     &      agrif_ceiling((ypos +(nc - 1)
+     &      *ds_child - s_parent)/ds_parent)
+C
+      xpmin = s_parent + (locind_parent_left-1)*ds_parent
+      i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+C     
+      Allocate( diff(coeffraf),diff2(coeffraf),diff3(coeffraf) )
+C      
+      diff(1)=0.5*invcoeffraf
+      do i=2,coeffraf
+         diff(i) = diff(i-1)+invcoeffraf
+      enddo
+      
+      ak = 0.
+      ck = 0.
+      
+      do i=1,coeffraf
+         do k=0,1
+         do s=0,2
+         do l=0,2
+           if (l /= s) then
+            ak(k,i) = ak(k,i)+(diff(i)-(k-l+1.))
+           endif
+         enddo
+         enddo
+         enddo
+               
+         etap = 0
+         etan = 0
+         do k=0,1
+          if (ak(k,i) > 0) then
+            etap = etap+1
+          else if (ak(k,i) < 0) then
+            etan = etan + 1
+          endif
+         enddo
+               
+         do k=0,1
+           if (ak(k,i) == 0) then
+            Ck(k,i) = 1.
+           else if (ak(k,i) > 0) then
+            Ck(k,i) = 1./(etap * ak(k,i))
+           else
+            Ck(k,i) = -1./(etan * ak(k,i))
+           endif
+         enddo
+      enddo
+                     
+C      
+      a = 0.
+      b = invcoeffraf
+      Do i=1,coeffraf
+         diff2(i) = 0.5*(b*b - a*a)  
+         diff3(i) = (1./3.)*(b*b*b - a*a*a)
+         a = a + invcoeffraf
+         b = b + invcoeffraf
+      End do
+C
+      if( locind_parent_last+2 <= np ) then
+           nmax = locind_parent_last+2    
+      elseif( locind_parent_last+1 <= np ) then
+           nmax = locind_parent_last+1
+      else
+           nmax = locind_parent_last 
+      endif     
+C      
+      if(locind_parent_left-2 >= 1) then
+          nmin = locind_parent_left-2
+      elseif(locind_parent_left-1 >= 1) then
+          nmin = locind_parent_left-1
+      else 
+          nmin = locind_parent_left
+      endif    
+C 
+      Do i = nmin+1,nmax
+         slope(i) = (x(i) - x(i-1))
+      Enddo 
+      DO i=nmin+2,nmax
+        smooth(i) = 0.5*(slope(i)**2+slope(i-1)**2)
+     &       +(slope(i)-slope(i-1))**2
+      enddo
+C
+        diffmod = 0
+        IF (mod(coeffraf,2) == 0) diffmod = 1           
+C
+        ipos = i1
+C               
+        Do iparent = locind_parent_left,locind_parent_last       
+             pos=1
+             
+            delta0=1./(epsilon+smooth(iparent  ))**3
+            delta1=1./(epsilon+smooth(iparent+1))**3
+            delta2=1./(epsilon+smooth(iparent+2))**3   
+                      
+             Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
+C
+               pos = pos+1 
+             End do 
+             ipos = ipos + coeffraf
+C
+        End do     
+C
+C
         y(1:nc)=ytemp(1:nc)                                 
         deallocate(ytemp)                
         deallocate(diff, diff2, diff3)
+        
+        deallocate(ak,ck)
+        
       Return
-      End Subroutine ppm1d
+      End Subroutine weno1dnew
+      
+C     **************************************************************************  
+CCC   Subroutine weno1d
+C     ************************************************************************** 
+C 
+      Subroutine weno1d(x,y,np,nc,
+     &                    s_parent,s_child,ds_parent,ds_child) 
+C
+CCC   Description:
+CCC   Subroutine to do a 1D interpolation and apply monotonicity constraints
+CCC   using piecewise parabolic method  
+CCC   on a child grid (vector y) from its parent grid (vector x).
+CC    Method:
+C
+C     Declarations:
+C
+      Implicit none
+C        
+C     Arguments
+      Integer             :: np,nc
+      Real, Dimension(np) :: x
+      Real, Dimension(nc) :: y
+      Real, Dimension(:),Allocatable :: ytemp
+      Real                :: s_parent,s_child,ds_parent,ds_child
+C
+C     Local scalars
+      Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+      Integer :: iparent,ipos,pos,nmin,nmax
+      Real    :: ypos
+      integer :: i1,jj
+      Real :: xpmin,cavg,a,b
+C      
+      Real :: xrmin,xrmax,am3,s2,s1
+      Real, Dimension(np) :: xr,xl,delta,a6,slope,slope2
+      Real, Dimension(:),Allocatable  :: diff,diff2,diff3
+      INTEGER :: diffmod
+      REAL :: invcoeffraf
+      integer :: s,l,k
+      integer :: etan, etap
+      real :: delta0, delta1,sumdelta
+      real :: epsilon
+      parameter (epsilon = 1.D-8)
+C      
+      coeffraf = nint(ds_parent/ds_child)
+C
+      If (coeffraf == 1) Then
+          locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+          y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+          return
+      End If
+      invcoeffraf = ds_child/ds_parent
+            
+C      
+      Allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+      ypos = s_child
+C
+      locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+      locind_parent_last = 1 +
+     &      agrif_ceiling((ypos +(nc - 1)
+     &      *ds_child - s_parent)/ds_parent)
+C
+      xpmin = s_parent + (locind_parent_left-1)*ds_parent
+      i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+C     
+      Allocate( diff(coeffraf))
+C      
+      diff(1)=0.5*invcoeffraf
+      do i=2,coeffraf
+         diff(i) = diff(i-1)+invcoeffraf
+      enddo
+C
+      if( locind_parent_last+2 <= np ) then
+           nmax = locind_parent_last+2   
+      else if( locind_parent_last+1 <= np ) then
+           nmax = locind_parent_last+1
+      else
+           nmax = locind_parent_last 
+      endif     
+C      
+      if(locind_parent_left-1 >= 1) then
+          nmin = locind_parent_left-1
+      else 
+          nmin = locind_parent_left
+      endif    
+C 
+      Do i = nmin+1,nmax
+         slope(i) = (x(i) - x(i-1))
+      Enddo 
+C
+        diffmod = 0
+        IF (mod(coeffraf,2) == 0) diffmod = 1           
+C
+        ipos = i1
+C               
+        Do iparent = locind_parent_left,locind_parent_last       
+             pos=1
+            delta0=1./(epsilon+slope(iparent  )**2)**2
+            delta1=1./(epsilon+slope(iparent+1)**2)**2
+            sumdelta = 1./(delta0+delta1)             
+             Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
+C                              
+          ytemp(jj) = x(iparent)+(diff(pos)-0.5)*(
+     &                delta0*slope(iparent)+
+     &                delta1*slope(iparent+1))*sumdelta
+               pos = pos+1 
+             End do 
+             ipos = ipos + coeffraf
+C
+        End do     
+C
+C
+        y(1:nc)=ytemp(1:nc)                                 
+        deallocate(ytemp)                
+        deallocate(diff)
+        
+      Return
+      End Subroutine weno1d
+                 
 C                              
 C     **************************************************************************  

trunk/AGRIF/AGRIF_FILES/modlinktomodel.F

@@ -19 +19 @@
 C
 C
-C
       Module Agrif_link
 C
@@ -31 +30 @@
 c        external Agrif_detect
 C
-      IMPLICIT NONE        
         external Agrif_probdim_modtype_def
         external Agrif_clustering_def
@@ -40 +38 @@
          TYPE(Agrif_Grid), Pointer :: Agrif_Gr   ! Pointer on the current grid  
          End Subroutine Agrif_Set_numberofcells
-        
+      End interface
+      Interface
          Subroutine Agrif_Get_numberofcells(Agrif_Gr)
          Use Agrif_Types, Only : Agrif_grid
          TYPE(Agrif_Grid), Pointer :: Agrif_Gr   ! Pointer on the current grid  
          End Subroutine Agrif_Get_numberofcells
-         
+      End interface
+      Interface
          Subroutine Agrif_Allocationcalls(Agrif_Gr)
          Use Agrif_Types, Only : Agrif_grid
@@ -51 +51 @@
          End Subroutine Agrif_Allocationcalls
       End interface
-   
+C   
       End Module Agrif_link
 C     **************************************************************************

trunk/AGRIF/AGRIF_FILES/modmask.F

@@ -202 +202 @@
 C     Local scalar
       INTEGER                  :: i,ii,iii,jj,kk,ll,mm,nn 
-      INTEGER,DIMENSION(nbdim) :: imin,imax
+      INTEGER,DIMENSION(nbdim) :: imin,imax,idecal
       INTEGER                  :: Nbvals
       REAL                     :: Res
@@ -235 +235 @@
                   imin(iii) = max(indic(iii) - i,ppbtab(iii))
                   imax(iii) = min(indic(iii) + i,ppetab(iii))
+                  if (firsttest) then               
+                  if (indic(iii).GT.ppbtab(iii)) then
+
+                     idecal = indic
+                     idecal(iii) = idecal(iii)-1
+                     SELECT CASE(nbdim)
+                     CASE (1)
+                        if (tempP%var%array1(idecal(1)
+     &                            ) == Agrif_SpecialValue) then
+                           imin(iii) = imax(iii)
+                        endif                     
+                     CASE (2)
+                        if (tempP%var%array2(idecal(1),
+     &            idecal(2)) == Agrif_SpecialValue) then
+                           imin(iii) = imax(iii)
+                        endif
+                     CASE (3)
+                        if (tempP%var%array3(idecal(1),
+     &            idecal(2),idecal(3)) 
+     &                               == Agrif_SpecialValue) then
+                           imin(iii) = imax(iii)
+                        endif  
+                     CASE (4)
+                        if (tempP%var%array4(idecal(1),
+     &            idecal(2),idecal(3),idecal(4)) 
+     &                               == Agrif_SpecialValue) then
+                           imin(iii) = imax(iii)
+                        endif     
+                     CASE (5)
+                        if (tempP%var%array5(idecal(1),
+     &            idecal(2),idecal(3),idecal(4),idecal(5)) 
+     &                               == Agrif_SpecialValue) then
+                           imin(iii) = imax(iii)
+                        endif  
+                     CASE (6)
+                        if (tempP%var%array6(idecal(1),
+     &            idecal(2),idecal(3),idecal(4),idecal(5),idecal(6)) 
+     &                               == Agrif_SpecialValue) then
+                           imin(iii) = imax(iii)
+                        endif                                                                                           
+                     END SELECT
+                  endif
+                  endif
                endif            
             enddo
@@ -241 +284 @@
             Nbvals = 0
 C
-            if ( nbdim .EQ. 1 ) then
+            SELECT CASE(nbdim)
+            CASE (1)
                do ii = imin(1),imax(1)
                     ValParent = parent%var%array1(ii)
@@ -249 +293 @@
                     endif 
                enddo
-            endif
-C
-            if ( nbdim .EQ. 2 ) then
+C
+            CASE (2)
                do jj = imin(2),imax(2)
                do ii = imin(1),imax(1)
@@ -261 +304 @@
                enddo  
                enddo
-            endif
-C
-            if ( nbdim .EQ. 3 ) then
+               
+            CASE (3)
                do kk = imin(3),imax(3)
                do jj = imin(2),imax(2)
@@ -275 +317 @@
                   enddo  
                enddo
-            endif
-C
-            if ( nbdim .EQ. 4 ) then
+
+            CASE (4)
                do ll = imin(4),imax(4)
                do kk = imin(3),imax(3)
@@ -291 +332 @@
                   enddo  
                enddo
-            endif
-C
-            if ( nbdim .EQ. 5 ) then
+
+            CASE (5)
                do mm = imin(5),imax(5)
                do ll = imin(4),imax(4)
@@ -309 +349 @@
                   enddo  
                enddo
-            endif
-C
-            if ( nbdim .EQ. 6 ) then
+
+            CASE (6)
                do nn = imin(6),imax(6)
                do mm = imin(5),imax(5)
@@ -329 +368 @@
                   enddo  
                enddo
-            endif
+
+            END SELECT
 C
 C
@@ -336 +376 @@
               if (firsttest) then
                    firsttest = .FALSE.
+                   i=1
                    cycle
               endif
-              if ( nbdim .EQ. 1 ) tempP%var%array1(indic(1)) 
+            SELECT CASE(nbdim)
+            CASE (1)              
+              tempP%var%array1(indic(1)) 
      &           = Res/Nbvals
-              if ( nbdim .EQ. 2 ) tempP%var%array2(indic(1),
+            CASE (2)
+              tempP%var%array2(indic(1),
      &                            indic(2)) = Res/Nbvals
-              if ( nbdim .EQ. 3 ) tempP%var%array3(indic(1),
+            CASE (3)
+              tempP%var%array3(indic(1),
      &                            indic(2),indic(3)) = Res/Nbvals
-              if ( nbdim .EQ. 4 ) tempP%var%array4(indic(1),
+            CASE (4)
+              tempP%var%array4(indic(1),
      &                            indic(2),indic(3),indic(4))
      &                = Res/Nbvals
-              if ( nbdim .EQ. 5 ) tempP%var%array5(indic(1),
+            CASE (5)
+              tempP%var%array5(indic(1),
      &                            indic(2),indic(3),indic(4),
      &                   indic(5)) = Res/Nbvals
-              if ( nbdim .EQ. 6 ) tempP%var%array6(indic(1),
+            CASE (6)
+              tempP%var%array6(indic(1),
      &                            indic(2),indic(3),indic(4),
      &                           indic(5),indic(6)) = Res/Nbvals
+            END SELECT
               exit
             else

trunk/AGRIF/AGRIF_FILES/modmpp.F

@@ -34 +34 @@
       Subroutine Get_External_Data(tempC,tempCextend,pttruetab,
      &   cetruetab,pttruetabwhole,cetruetabwhole,nbdim,memberin,
-     &   memberout)
+     &   memberout,memberoutall1)
 
       IMPLICIT NONE
@@ -54 +54 @@
      &                                                 cetruetab2
       LOGICAL :: memberout1(1),memberoutall(0:Agrif_Nbprocs-1)
+      LOGICAL, OPTIONAL :: memberoutall1(0:Agrif_Nbprocs-1)
       INTEGER :: code
 
@@ -60 +61 @@
 
         
+        IF (present(memberoutall1)) THEN
+        memberoutall = memberoutall1
+        ELSE
          memberout1(1) = memberout
 
          CALL MPI_ALLGATHER(memberout1,1,MPI_LOGICAL,memberoutall,
      &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code)
-
+        ENDIF
          pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
          cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
@@ -198 +202 @@
       LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: recvfromproc
       LOGICAL                                    :: res
-      TYPE(AGRIF_PVARIABLE)                      :: temprecv
+      TYPE(AGRIF_PVARIABLE), SAVE                      :: temprecv
 
 #include "mpif.h"
@@ -243 +247 @@
      &                        MPI_COMM_WORLD,code)
                 CASE(3)
-                   Call MPI_SEND(tempC%var%array3(
-     &                        imin(1,k):imax(1,k),
-     &                        imin(2,k):imax(2,k),
-     &                        imin(3,k):imax(3,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
+                  Call Agrif_Send_3Darray(tempC%var%array3,
+     &             lbound(tempC%var%array3),imin(:,k),imax(:,k),k)
                 CASE(4)
                    Call MPI_SEND(tempC%var%array4(
@@ -311 +311 @@
                 enddo
 
-                allocate(temprecv%var)
+             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
              call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
      &   imax_recv(:,k),nbdim)
@@ -341 +341 @@
      &               MPI_COMM_WORLD,statut,code)
        END SELECT
+            endif
             
+            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
+     &                    MPI_COMM_WORLD,code)
+C
+            if (sendtoproc(k)) then
+C
+                iminmax_temp(:,1,k) = imin(:,k)
+                iminmax_temp(:,2,k) = imax(:,k)
+
+                Call MPI_SEND(iminmax_temp(:,:,k),
+     &                        2*nbdim,MPI_INTEGER,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+C
+                SELECT CASE(nbdim)
+                CASE(1)
+                datasize=SIZE(tempC%var%array1(
+     &                        imin(1,k):imax(1,k)))
+                   Call MPI_SEND(tempC%var%array1(
+     &                        imin(1,k):imax(1,k)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+                CASE(2)
+                datasize=SIZE(tempC%var%array2(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k)))
+                   Call MPI_SEND(tempC%var%array2(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+                CASE(3)
+                datasize=SIZE(tempC%var%array3(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k)))
+                   Call MPI_SEND(tempC%var%array3(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+                CASE(4)
+                datasize=SIZE(tempC%var%array4(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k),
+     &                        imin(4,k):imax(4,k)))
+                   Call MPI_SEND(tempC%var%array4(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k),
+     &                        imin(4,k):imax(4,k)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+                CASE(5)
+                datasize=SIZE(tempC%var%array5(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k),
+     &                        imin(4,k):imax(4,k),
+     &                        imin(5,k):imax(5,k)))
+                   Call MPI_SEND(tempC%var%array5(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k),
+     &                        imin(4,k):imax(4,k),
+     &                        imin(5,k):imax(5,k)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+                CASE(6)
+                datasize=SIZE(tempC%var%array6(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k),
+     &                        imin(4,k):imax(4,k),
+     &                        imin(5,k):imax(5,k),
+     &                        imin(6,k):imax(6,k)))
+                   Call MPI_SEND(tempC%var%array6(
+     &                        imin(1,k):imax(1,k),
+     &                        imin(2,k):imax(2,k),
+     &                        imin(3,k):imax(3,k),
+     &                        imin(4,k):imax(4,k),
+     &                        imin(5,k):imax(5,k),
+     &                        imin(6,k):imax(6,k)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+                END SELECT
+C
+            endif            
+            
+            if (recvfromproc(k)) then
+                        
             Call where_valtabtotab_mpi(tempCextend%var,
      &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
      
                 Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
-                deallocate(temprecv%var)
-
-            endif
-
-C
-      enddo
-
-
-      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
-C
-C
-            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
-     &                    MPI_COMM_WORLD,code)
-C
-            if (sendtoproc(k)) then
-C
-                iminmax_temp(:,1,k) = imin(:,k)
-                iminmax_temp(:,2,k) = imax(:,k)
-
-                Call MPI_SEND(iminmax_temp(:,:,k),
-     &                        2*nbdim,MPI_INTEGER,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-C
-                datasize = 1
-C
-                do i = 1,nbdim
-C
-                  datasize = datasize * (imax(i,k)-imin(i,k)+1)
-C
-                enddo
-C
-                SELECT CASE(nbdim)
-                CASE(1)
-                   Call MPI_SEND(tempC%var%array1(
-     &                        imin(1,k):imax(1,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-                CASE(2)
-                   Call MPI_SEND(tempC%var%array2(
-     &                        imin(1,k):imax(1,k),
-     &                        imin(2,k):imax(2,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-                CASE(3)
-                   Call MPI_SEND(tempC%var%array3(
-     &                        imin(1,k):imax(1,k),
-     &                        imin(2,k):imax(2,k),
-     &                        imin(3,k):imax(3,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-                CASE(4)
-                   Call MPI_SEND(tempC%var%array4(
-     &                        imin(1,k):imax(1,k),
-     &                        imin(2,k):imax(2,k),
-     &                        imin(3,k):imax(3,k),
-     &                        imin(4,k):imax(4,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-                CASE(5)
-                   Call MPI_SEND(tempC%var%array5(
-     &                        imin(1,k):imax(1,k),
-     &                        imin(2,k):imax(2,k),
-     &                        imin(3,k):imax(3,k),
-     &                        imin(4,k):imax(4,k),
-     &                        imin(5,k):imax(5,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-                CASE(6)
-                   Call MPI_SEND(tempC%var%array6(
-     &                        imin(1,k):imax(1,k),
-     &                        imin(2,k):imax(2,k),
-     &                        imin(3,k):imax(3,k),
-     &                        imin(4,k):imax(4,k),
-     &                        imin(5,k):imax(5,k),
-     &                        imin(6,k):imax(6,k)),
-     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
-     &                        MPI_COMM_WORLD,code)
-                END SELECT
-C
+C                deallocate(temprecv%var)
+
             endif
 
@@ -448 +463 @@
      &                        MPI_COMM_WORLD,statut,code)
 
-                imin_recv(:,k) = iminmax_temp(:,1,k)
-                imax_recv(:,k) = iminmax_temp(:,2,k)
-
-                datasize = 1
-C
-                do i = 1,nbdim
-C
-                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
-C
-                enddo
-                allocate(temprecv%var)
-             call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
-     &   imax_recv(:,k),nbdim)
+C                imin_recv(:,k) = iminmax_temp(:,1,k)
+C                imax_recv(:,k) = iminmax_temp(:,2,k)
+
+C                datasize = 1
+C
+C                do i = 1,nbdim
+C
+C                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
+C
+C                enddo
+             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
+             call Agrif_nbdim_allocation(temprecv%var,
+     &   iminmax_temp(:,1,k),iminmax_temp(:,2,k),nbdim)
             SELECT CASE(nbdim)
             CASE(1)
+              datasize=SIZE(temprecv%var%array1)
               Call MPI_RECV(temprecv%var%array1,
      &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
      &               MPI_COMM_WORLD,statut,code)
             CASE(2)
+              datasize=SIZE(temprecv%var%array2)
               Call MPI_RECV(temprecv%var%array2,
      &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
      &               MPI_COMM_WORLD,statut,code)
             CASE(3)
+              datasize=SIZE(temprecv%var%array3)
               Call MPI_RECV(temprecv%var%array3,
      &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
@@ -476 +494 @@
 
             CASE(4)
+              datasize=SIZE(temprecv%var%array4)
               Call MPI_RECV(temprecv%var%array4,
      &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
      &               MPI_COMM_WORLD,statut,code)
             CASE(5)
+              datasize=SIZE(temprecv%var%array5)
               Call MPI_RECV(temprecv%var%array5,
      &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
      &               MPI_COMM_WORLD,statut,code)
             CASE(6)
+              datasize=SIZE(temprecv%var%array6)
               Call MPI_RECV(temprecv%var%array6,
      &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
@@ -490 +511 @@
             
             Call where_valtabtotab_mpi(tempCextend%var,
-     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
+     &             temprecv%var,iminmax_temp(:,1,k),iminmax_temp(:,2,k)
+     &            ,0.,nbdim)
      
                 Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
-                deallocate(temprecv%var)
+C                deallocate(temprecv%var)
             endif
 
@@ -500 +522 @@
 
           End Subroutine ExchangeSamelevel
+
+          Subroutine Agrif_Send_3Darray(tab3D,bounds,imin,imax,k)
+          integer, dimension(3) :: bounds, imin, imax
+          real,dimension(bounds(1):,bounds(2):,bounds(3):),target
+     &                             :: tab3D
+          integer :: k
+          integer :: etiquette = 100
+          integer :: datasize, code
+#include "mpif.h"   
+
+          datasize = SIZE(tab3D(
+     &                       imin(1):imax(1),
+     &                        imin(2):imax(2),
+     &                        imin(3):imax(3)))
+       
+                   Call MPI_SEND(tab3D(
+     &                        imin(1):imax(1),
+     &                        imin(2):imax(2),
+     &                        imin(3):imax(3)),
+     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+     &                        MPI_COMM_WORLD,code)
+     
+         End Subroutine Agrif_Send_3Darray
 
 #else

trunk/AGRIF/AGRIF_FILES/modsauv.F

@@ -156 +156 @@
                Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex)
             endif
+            
+            if (associated(Agrif_Gr%tabvars(i)%var%posvar)) then
+               Deallocate(Agrif_Gr%tabvars(i)%var%posvar)
+            endif     
+            
+            if (associated(Agrif_Gr%tabvars(i)%var%interptab)) then
+               Deallocate(Agrif_Gr%tabvars(i)%var%interptab)
+            endif  
+                             
 C
             Deallocate(Agrif_Gr%tabvars(i)%var)
@@ -291 +300 @@
                Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex)
             endif
+            
+            if (associated(Agrif_Gr%tabvars(i)%var%posvar)) then
+               Deallocate(Agrif_Gr%tabvars(i)%var%posvar)
+            endif     
+            
+            if (associated(Agrif_Gr%tabvars(i)%var%interptab)) then
+               Deallocate(Agrif_Gr%tabvars(i)%var%interptab)
+            endif              
 !
             Deallocate(Agrif_Gr%tabvars(i)%var)
@@ -349 +366 @@
             eps = min(g_eps,oldgrid_eps)/100.                  
 C
+            do iii = 1 , Agrif_Probdim
 
-            do iii = 1 , Agrif_Probdim
                if (g % Agrif_d(iii) .LT. 
      &             (parcours % gr % Agrif_d(iii) - eps)) then
@@ -358 +375 @@
                    out = 1
 C   
-                   Cycle
+                   Exit
 C             
                endif

trunk/AGRIF/AGRIF_FILES/modtypes.F

@@ -29 +29 @@
 C
       IMPLICIT NONE
+      
+C     Maximum refinement ratio
+
+      INTEGER, PARAMETER :: Agrif_MaxRaff = 7      
 C
 C     **************************************************************************
@@ -156 +160 @@
            INTEGER ,DIMENSION(:,:)        ,Pointer :: tabpoint2D
            INTEGER ,DIMENSION(:,:,:)      ,Pointer :: tabpoint3D
+           
+           Type(Agrif_Flux), Pointer               :: fluxes => NULL()
       End TYPE Agrif_grid
 C
@@ -191 +197 @@
          REAL   , DIMENSION(:,:,:,:,:,:),Pointer :: array6    => NULL()
 C        Arrays containing the values of the grid variables (REAL*8)
-         REAL(8)                                 :: darray0
-         REAL(8), DIMENSION(:)          ,Pointer :: darray1   => NULL()
-         REAL(8), DIMENSION(:,:)        ,Pointer :: darray2   => NULL()
-         REAL(8), DIMENSION(:,:,:)      ,Pointer :: darray3   => NULL()
-         REAL(8), DIMENSION(:,:,:,:)    ,Pointer :: darray4   => NULL()
-         REAL(8), DIMENSION(:,:,:,:,:)  ,Pointer :: darray5   => NULL()
-         REAL(8), DIMENSION(:,:,:,:,:,:),Pointer :: darray6   => NULL()
+         REAL*8                                 :: darray0
+         REAL*8, DIMENSION(:)          ,Pointer :: darray1   => NULL()
+         REAL*8, DIMENSION(:,:)        ,Pointer :: darray2   => NULL()
+         REAL*8, DIMENSION(:,:,:)      ,Pointer :: darray3   => NULL()
+         REAL*8, DIMENSION(:,:,:,:)    ,Pointer :: darray4   => NULL()
+         REAL*8, DIMENSION(:,:,:,:,:)  ,Pointer :: darray5   => NULL()
+         REAL*8, DIMENSION(:,:,:,:,:,:),Pointer :: darray6   => NULL()
 C        Arrays containing the values of the grid variables (LOGICAL)
          LOGICAL                                 :: larray0
@@ -240 +246 @@
          INTEGER, DIMENSION(6) :: TYPEinterp ! option interp
          INTEGER, DIMENSION(6) :: TYPEupdate ! option update
-C
-      End TYPE Agrif_Variable   
+         
+         Type(Agrif_List_Interp_Loc), Pointer :: list_interp => NULL()
+         Type(Agrif_List_Interp_Loc), Pointer :: list_update => NULL()
+C
+      End TYPE Agrif_Variable 
+      
+      Type Agrif_Interp_Loc
+      integer,dimension(6) :: pttab,petab,
+     &                          pttab_Child,pttab_Parent = -99
+      integer,dimension(6) :: indmin, indmax
+      INTEGER,DIMENSION(6)    :: pttruetab,cetruetab
+      logical :: member, memberin      
+#if !defined AGRIF_MPI      
+      integer,dimension(6) :: indminglob,indmaxglob
+#else
+      integer,dimension(6) :: indminglob2,indmaxglob2
+      INTEGER,DIMENSION(6,2,2) :: parentarray
+      INTEGER,DIMENSION(:,:,:), POINTER :: tab4t
+      LOGICAL, DIMENSION(:), POINTER :: memberinall
+      INTEGER,DIMENSION(:,:,:), POINTER :: tab5t
+      LOGICAL, DIMENSION(:), POINTER :: memberinall2
+#endif      
+      End Type Agrif_Interp_Loc
+      
+      Type Agrif_List_Interp_Loc
+      Type(Agrif_Interp_Loc), Pointer :: interp_loc
+      Type(Agrif_List_Interp_Loc), Pointer :: suiv
+      End Type Agrif_List_Interp_Loc
+        
+       TYPE Agrif_Profile
+          character*80 :: profilename
+C
+         ! index of the first point in the REAL domain (x,y and z direction)
+         INTEGER     ,DIMENSION(6)          :: point
+         ! position of the variable on the cell (1 for the boarder of 
+         !    the edge, 2 for the center)
+         INTEGER     ,DIMENSION(:) ,Pointer :: posvar      => NULL() 
+         ! Indication for the space interpolation (module Agrif_Boundary)
+         INTEGER                   ,Pointer :: interpIndex => NULL() 
+         ! number of DIMENSIONs of the grid variable
+         INTEGER                            :: nbdim = 0             
+         ! Array indicating the TYPE of DIMENSION (space or not) for 
+         !    each of them 
+         CHARACTER(6),DIMENSION(:) ,Pointer :: interptab   => NULL() 
+         Type(Agrif_Profile), Pointer :: nextprofile  => NULL()
+       END TYPE Agrif_Profile
+       
+       Type(Agrif_Profile), Pointer :: Agrif_MyProfiles => NULL()
+           
+C  Boundaries Fluxes
+
+      Type Agrif_Flux
+        Character*80 fluxname
+        Type(Agrif_Variable), Pointer :: fluxtabx
+        Type(Agrif_Variable), Pointer :: fluxtaby
+        Type(Agrif_Variable), Pointer :: fluxtabz        
+        Type(Agrif_Profile), Pointer  :: profile
+        Logical :: Fluxallocated = .FALSE.
+        Type(Agrif_Flux), Pointer     :: nextflux => NULL()
+      End Type Agrif_Flux      
 C
 C     **************************************************************************
@@ -285 +349 @@
       INTEGER               :: Agrif_Regridding
       INTEGER               :: Agrif_Minwidth
-      REAL                  :: Agrif_Efficiency
+      REAL                  :: Agrif_Efficiency = 0.7
       REAL    ,DIMENSION(3) :: Agrif_mind
 C     PARAMETERs for the interpolation of the child grids
@@ -302 +366 @@
       ! linear conservative interpolation       
       INTEGER ,PARAMETER    :: Agrif_linearconservlim=7
-      INTEGER ,PARAMETER    :: Agrif_ppm=8    
+      INTEGER ,PARAMETER    :: Agrif_ppm=8 
+      INTEGER ,PARAMETER    :: Agrif_weno=9         
 C     PARAMETERs for the update of the parent grids      
       INTEGER ,PARAMETER    :: Agrif_Update_Copy=1           ! copy

trunk/AGRIF/AGRIF_FILES/modupdate.F

@@ -85 +85 @@
 C      
 C     Values on the current grid used for the update
-      childtemp % var % array1 => tab      
+      childtemp % var % array1 => tab     
+      
+C      childtemp % var % list_update => child%var%list_update
+             
 C
      
@@ -96 +99 @@
       ENDIF     
 C      
+C      child % var % list_update => childtemp%var%list_update
+      
       deallocate(childtemp % var)
 C
@@ -146 +151 @@
 C     Values on the current grid used for the update
       childtemp % var % array2 => tab      
+      
+C      childtemp % var % list_update => child%var%list_update      
 C
       IF (present(procname)) THEN
@@ -155 +162 @@
       ENDIF
 C      
+C      child % var % list_update => childtemp%var%list_update
+      
       deallocate(childtemp % var)
 C
@@ -204 +213 @@
 C     Values on the current grid used for the update
       childtemp % var % array3 => tab     
+      
+C      childtemp % var % list_update => child%var%list_update      
 C
       IF (present(procname)) THEN
@@ -213 +224 @@
       ENDIF
 C      
+C      child % var % list_update => childtemp%var%list_update
+      
       DEALLOCATE(childtemp % var)
 C
@@ -262 +275 @@
 C     Values on the current grid used for the update
       childtemp % var % array4 => tab     
+      
+C      childtemp % var % list_update => child%var%list_update
+            
 C
       IF (present(procname)) THEN
@@ -270 +286 @@
      &     (TypeUpdate,parent,child,deb,fin)
       ENDIF
+
+C      child % var % list_update => childtemp%var%list_update      
 C
       deallocate(childtemp % var)
@@ -322 +340 @@
 C     Values on the current grid used for the update
       childtemp % var % array5 => tab      
+      
+C      childtemp % var % list_update => child%var%list_update      
 C
       IF (present(procname)) THEN
@@ -330 +350 @@
      &     (TypeUpdate,parent,child,deb,fin)
       ENDIF
+      
+C      child % var % list_update => childtemp%var%list_update
+            
 C      
       deallocate(childtemp % var)
@@ -380 +403 @@
 C     Values on the current grid used for the update
       childtemp % var % array6 => tab      
+C      childtemp % var % list_update => child%var%list_update
 C
       Call Agrif_UpdateVariable
      &     (TypeUpdate,parent,child,deb,fin)
+     
+C      child % var % list_update => childtemp%var%list_update
+           
 C      
       deallocate(childtemp % var)
@@ -658 +685 @@
 
         IF (posvartab_child(i) == 1) THEN
-          IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
+          IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+            indtab(i,1,1) = indtab(i,1,1) - (coeffraf - 1)
+            indtab(i,1,2) = indtab(i,1,2) + (coeffraf - 1)        
+          ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
             indtab(i,1,1) = indtab(i,1,1) - coeffraf / 2
             indtab(i,1,2) = indtab(i,1,2) + coeffraf / 2
@@ -665 +695 @@
           indtab(i,1,1) = indtab(i,1,1) - coeffraf
           indtab(i,1,2) = indtab(i,1,2) - 1
+          IF ((TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting)
+     &                            .AND.(mod(coeffraf,2) == 1)) THEN
+            indtab(i,1,1) = indtab(i,1,1) - 1
+            indtab(i,1,2) = indtab(i,1,2) + 1
+          ENDIF
         ENDIF
         IF (loctab_child(i) == -3) THEN
@@ -832 +867 @@
 
         IF (posvartab_child(i) == 1) THEN
-          IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
+          IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+            indtab(i,:,1) = indtab(i,:,1) - (coeffraf - 1)
+            indtab(i,:,2) = indtab(i,:,2) + (coeffraf - 1)        
+          ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
             indtab(i,:,1) = indtab(i,:,1) - coeffraf / 2
             indtab(i,:,2) = indtab(i,:,2) + coeffraf / 2
@@ -840 +878 @@
           indtab(i,1,2) = indtab(i,1,2) - 1
           indtab(i,2,2) = indtab(i,2,2) + coeffraf - 1
+          IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+            indtab(i,1,1) = indtab(i,1,1) - 1
+            indtab(i,1,2) = indtab(i,1,2) + 1
+            indtab(i,2,1) = indtab(i,2,1) - 1
+            indtab(i,2,2) = indtab(i,2,2) + 1
+          ENDIF          
         ENDIF
       ENDDO
@@ -952 +996 @@
      &              ds_Child(1:nbdim),ds_Parent(1:nbdim),
      &              posvartab_Child,loctab_Child,
-     &              nbdim,procname)
+     &              nbdim,procname,nb,ndir)
            ELSE
               Call Agrif_UpdatenD              
@@ -985 +1029 @@
      &                          ds_Child,ds_Parent,
      &                          posvartab_Child,loctab_Child,
-     &                          nbdim,procname)  
+     &                          nbdim,procname,nb,ndir)  
 C
 C     Description:
@@ -1030 +1074 @@
       External :: procname
       Optional ::  procname
+      Integer :: nb,ndir
+      Optional :: nb,ndir
+      
 C
 C     Local pointers
-      TYPE(AGRIF_PVARIABLE)      :: tempP      ! Temporary parent grid variable
-      TYPE(AGRIF_PVARIABLE)      :: tempC      ! Temporary child grid variable
+      TYPE(AGRIF_PVARIABLE), SAVE      :: tempP      ! Temporary parent grid variable
+      TYPE(AGRIF_PVARIABLE), SAVE      :: tempC      ! Temporary child grid variable
 C
 C     Local scalars
@@ -1047 +1094 @@
       INTEGER,DIMENSION(nbdim,2,2) :: childarray
       INTEGER,DIMENSION(nbdim,2,2) :: parentarray
-      TYPE(AGRIF_PVARIABLE)      :: tempCextend,tempPextend ! Temporary child
-                                                            !    grid
+      TYPE(AGRIF_PVARIABLE), SAVE      :: tempCextend,tempPextend ! Temporary child
+      INTEGER :: nbin, ndirin
 C
 #ifdef AGRIF_MPI
@@ -1057 +1104 @@
       INTEGER,DIMENSION(nbdim,4)           :: tab3
       INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4
-      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t
-ccccccccccccccc      TYPE(AGRIF_PVARIABLE)                :: childvalues
+      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t
+      LOGICAL :: find_list_update
+      LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
+      LOGICAL, DIMENSION(1) :: memberin1      
 C
 #endif
@@ -1119 +1168 @@
 #endif
 
-
+       IF (present(procname)) THEN
+       IF (.Not.present(nb)) THEN
+       nbin=0
+       ndirin=0
+       ELSE
+       nbin = nb
+       ndirin = ndir
+       ENDIF
+       ENDIF
+       
       IF (memberin) THEN
-      allocate(tempC%var)
+      IF (.not.associated(tempC%var)) allocate(tempC%var)
 
 C
@@ -1136 +1194 @@
           CALL procname(tempC%var%array1,
      &                          childarray(1,1,2),childarray(1,2,2),
-     &                                   .TRUE.)
+     &                                   .TRUE.,nbin,ndirin)
         CASE(2)
           CALL procname(tempC%var%array2,
      &                          childarray(1,1,2),childarray(1,2,2),
      &                          childarray(2,1,2),childarray(2,2,2),
-     &                                   .TRUE.)
+     &                                   .TRUE.,nbin,ndirin)
         CASE(3)
           CALL procname(tempC%var%array3,
@@ -1147 +1205 @@
      &                          childarray(2,1,2),childarray(2,2,2),
      &                          childarray(3,1,2),childarray(3,2,2),
-     &                                   .TRUE.)
+     &                                   .TRUE.,nbin,ndirin)
         CASE(4)
           CALL procname(tempC%var%array4,
@@ -1154 +1212 @@
      &                          childarray(3,1,2),childarray(3,2,2),
      &                          childarray(4,1,2),childarray(4,2,2),
-     &                                   .TRUE.)
+     &                                   .TRUE.,nbin,ndirin)
         CASE(5)
           CALL procname(tempC%var%array5,
@@ -1162 +1220 @@
      &                          childarray(4,1,2),childarray(4,2,2),
      &                          childarray(5,1,2),childarray(5,2,2),
-     &                                   .TRUE.)
+     &                                   .TRUE.,nbin,ndirin)
         CASE(6)
           CALL procname(tempC%var%array6,
@@ -1171 +1229 @@
      &                          childarray(5,1,2),childarray(5,2,2),
      &                          childarray(6,1,2),childarray(6,2,2),
-     &                                   .TRUE.)
+     &                                   .TRUE.,nbin,ndirin)
         END SELECT
       ELSE
@@ -1189 +1247 @@
 C     tab2 contains the necessary limits of the parent grid for each processor
 
+      IF (Associated(child%var%list_update)) THEN
+      Call Agrif_Find_list_update(child%var%list_update,pttab,petab,
+     &                          pttab_Child,pttab_Parent,nbdim,
+     &       find_list_update,tab4t,tab5t,memberinall,memberinall2)
+      ELSE
+      find_list_update = .FALSE.
+      ENDIF
+      
+      if (.not.find_list_update) then      
       tab3(:,1) = pttruetab(:)
       tab3(:,2) = cetruetab(:)
@@ -1198 +1265 @@
      &                   MPI_INTEGER,MPI_COMM_WORLD,code)
 
-      Allocate(tempCextend%var)
+      IF (.not.associated(tempCextend%var)) Allocate(tempCextend%var)
       DO k=0,Agrif_Nbprocs-1
        do j=1,4
@@ -1206 +1273 @@
        enddo
       enddo
+      
+      memberin1(1) = memberin
+      CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
+     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code)
+           
+      endif
+      
       Call Get_External_Data(tempC,tempCextend,tab4t(:,:,1),
      &            tab4t(:,:,2),
-     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin)
+     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin,
+     &            memberinall)
 
 #else
@@ -1221 +1296 @@
       IF (memberin) THEN
 
-      allocate(tempP%var)
+      IF (.not.associated(tempP%var)) allocate(tempP%var)
       Call Agrif_nbdim_allocation(tempP%var,
      &                 indmin,indmax,nbdim)
@@ -1276 +1351 @@
 
       Call Agrif_nbdim_deallocation(tempCextend%var,nbdim)
-      Deallocate(tempCextend%var)
+C      Deallocate(tempCextend%var)
 
       ENDIF
@@ -1301 +1376 @@
       Call Agrif_ParentGrid_to_ChildGrid()
 
+      if (.not.find_list_update) then
       tab3(:,1) = indmin(:)
       tab3(:,2) = indmax(:)
@@ -1309 +1385 @@
      &                   MPI_INTEGER,MPI_COMM_WORLD,code)
 
-      Allocate(tempPextend%var)
+      IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
       DO k=0,Agrif_Nbprocs-1
        do j=1,4
          do i=1,nbdim
-         tab4t(i,k,j) = tab4(i,j,k)
+         tab5t(i,k,j) = tab4(i,j,k)
          enddo
        enddo
       enddo
-      Call Get_External_Data(tempP,tempPextend,tab4t(:,:,1),
-     &            tab4t(:,:,2),
-     &            tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,member)
+ 
+      memberin1(1) = member
+      CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2,
+     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code)
+     
+      Call Agrif_Addto_list_update(child%var%list_update,pttab,petab,
+     &                          pttab_Child,pttab_Parent,nbdim
+     &   ,tab4t,tab5t,memberinall,memberinall2) 
+          
+      endif
+      
+      Call Get_External_Data(tempP,tempPextend,tab5t(:,:,1),
+     &            tab5t(:,:,2),
+     &            tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member,
+     &            memberinall2)
 
 #else
@@ -1407 +1495 @@
      &                      parentarray(1,1,1):parentarray(1,2,1)),
      &                      parentarray(1,1,2),parentarray(1,2,2),
-     &                                   .FALSE.
+     &                                   .FALSE.,nbin,ndirin
      &                      )
             CASE(2)
@@ -1416 +1504 @@
      &                      parentarray(1,1,2),parentarray(1,2,2),
      &                      parentarray(2,1,2),parentarray(2,2,2),
-     &                                   .FALSE.
+     &                                   .FALSE.,nbin,ndirin
      &                      )
             CASE(3)
@@ -1427 +1515 @@
      &                      parentarray(2,1,2),parentarray(2,2,2),
      &                      parentarray(3,1,2),parentarray(3,2,2),
-     &                                   .FALSE.
+     &                                   .FALSE.,nbin,ndirin
      &                      )
             CASE(4)
@@ -1440 +1528 @@
      &                      parentarray(3,1,2),parentarray(3,2,2),
      &                      parentarray(4,1,2),parentarray(4,2,2),
-     &                                   .FALSE.
+     &                                   .FALSE.,nbin,ndirin
      &                      )
             CASE(5)
@@ -1455 +1543 @@
      &                      parentarray(4,1,2),parentarray(4,2,2),
      &                      parentarray(5,1,2),parentarray(5,2,2),
-     &                                   .FALSE.
+     &                                   .FALSE.,nbin,ndirin
      &                      )
             CASE(6)
@@ -1472 +1560 @@
      &                      parentarray(5,1,2),parentarray(5,2,2),
      &                      parentarray(6,1,2),parentarray(6,2,2),
-     &                                   .FALSE.
+     &                                   .FALSE.,nbin,ndirin
      &                      )
             END SELECT
@@ -1545 +1633 @@
       Call Agrif_nbdim_deallocation(tempP%var,nbdim)
       Call Agrif_nbdim_deallocation(tempC%var,nbdim)
-      Deallocate(tempC % var)
+!      Deallocate(tempC % var)
 #endif
-      Deallocate(tempP % var)
+!      Deallocate(tempP % var)
       ENDIF
 #ifdef AGRIF_MPI
-      Deallocate(tempPextend%var)
-      IF (.Not.memberin) Deallocate(tempCextend%var)
+!      Deallocate(tempPextend%var)
+!      IF (.Not.memberin) Deallocate(tempCextend%var)
 #endif
 
@@ -1628 +1716 @@
         IF (loctab_Child(i) .NE. -3) THEN
         IF (posvartab_child(i) == 1) THEN
-          IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
-        positionmin = positionmin - ds_Parent(i)/2.
+          IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
+          positionmin = positionmin - ds_Parent(i)/2.
+          ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+          positionmin = positionmin - (ds_Parent(i)-ds_Child(i))
           ENDIF
         ELSE
         positionmin = positionmin - ds_Parent(i)/2.
+        IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+          positionmin = positionmin - ds_Child(i)
+        ENDIF
         ENDIF
         ENDIF
@@ -1647 +1740 @@
         IF (loctab_Child(i) .NE. -3) THEN
         IF (posvartab_child(i) == 1) THEN
-          IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
+          IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
         positionmax = positionmax  + ds_Parent(i)/2.
+          ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+          positionmax = positionmax  + (ds_Parent(i)-ds_Child(i))
           ENDIF
         ELSE
         positionmax = positionmax  + ds_Parent(i)/2.
+        IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+          positionmax = positionmax + ds_Child(i)
+        ENDIF        
         ENDIF
         ENDIF
@@ -1684 +1782 @@
 C
 C
-C     **************************************************************************
-CCC   Subroutine Agrif_Update_1D_Recursive
-C     **************************************************************************
-C
-      Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC,
-     &                                     indmin,indmax,
-     &                                     pttab_child,petab_child,
-     &                                     s_child,s_parent,
-     &                                     ds_child,ds_parent,nbdim)
-C
-CCC   Description:
-CCC   Subroutine to update a 1D grid variable on the parent grid.
-C
-CC    Method:
-C
-C     Declarations:
-C
-      
-C
-C     Arguments
-      INTEGER                   :: nbdim
-      INTEGER, DIMENSION(nbdim) :: TypeUpdate            ! TYPE of update (copy or average)
-      INTEGER, DIMENSION(nbdim) :: indmin,indmax
-      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
-      REAL, DIMENSION(nbdim)    :: s_child,s_parent
-      REAL, DIMENSION(nbdim)    :: ds_child,ds_parent
-      REAL, DIMENSION(indmin(nbdim):indmax(nbdim))           :: tempP
-      REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC
-C
-C
-      Call Agrif_UpdateBase(TypeUpdate(1),
-     &                  tempP(indmin(nbdim):indmax(nbdim)),
-     &                  tempC(pttab_child(nbdim):petab_child(nbdim)),
-     &                  indmin(nbdim),indmax(nbdim),           
-     &                  pttab_child(nbdim),petab_child(nbdim),
-     &                  s_parent(nbdim),s_child(nbdim),
-     &                  ds_parent(nbdim),ds_child(nbdim))
-C
-      Return
-C
-C
-      End Subroutine Agrif_Update_1D_recursive
+
 C
 C
@@ -1734 +1791 @@
 C
       Subroutine Agrif_Update_2D_recursive(TypeUpdate,tempP,tempC,
-     &                                     indmin,indmax,   
+     &                                     indmin,indmax,
      &                                     pttab_child,petab_child,
      &                                     s_child,s_parent,
@@ -1757 +1814 @@
       REAL, DIMENSION(indmin(1):indmax(1),
      &                indmin(2):indmax(2))           :: tempP
-      REAL, DIMENSION(pttab_child(1):petab_child(1),
-     &                pttab_child(2):petab_child(2)) :: tempC
+C      REAL, DIMENSION(pttab_child(1):petab_child(1),
+C     &                pttab_child(2):petab_child(2)) :: tempC
+     
+      REAL, DIMENSION(:,:) :: tempC     
 C
 C     Local variables      
-      REAL, DIMENSION(:,:), Allocatable :: tabtemp
+      REAL, DIMENSION(indmin(1):indmax(1),
+     &                 pttab_child(2):petab_child(2)) :: tabtemp
       INTEGER :: i,j
-C
-C
-      Allocate(tabtemp(indmin(1):indmax(1),
-     &                 pttab_child(2):petab_child(2)))
+      INTEGER :: coeffraf,locind_child_left
 C
       do j = pttab_child(nbdim),petab_child(nbdim)
 C
-        Call Agrif_Update_1D_recursive(TypeUpdate,    
-     &         tabtemp(indmin(nbdim-1):indmax(nbdim-1),j),
-     &         tempC(pttab_child(nbdim-1):petab_child(nbdim-1),j),
+        Call Agrif_Update_1D_recursive(TypeUpdate(1:nbdim-1),    
+     &         tabtemp(:,j),
+     &         tempC(:,j-pttab_child(nbdim)+1),
      &         indmin(1:nbdim-1),indmax(1:nbdim-1),
      &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
@@ -1779 +1836 @@
 C
       enddo
+      
+      Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
 C
       do i = indmin(1),indmax(1)
 C
         Call Agrif_UpdateBase(TypeUpdate(2),
-     &           tempP(i,indmin(nbdim):indmax(nbdim)),
-     &          tabtemp(i,pttab_child(nbdim):petab_child(nbdim)),
+     &           tempP(i,:),
+     &          tabtemp(i,:),
      &           indmin(nbdim),indmax(nbdim),
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),
+     &                  coeffraf,locind_child_left)
 C        
       enddo
-C
-      Deallocate(tabtemp)
 C
       Return
@@ -1835 +1894 @@
 C
 C     Local variables      
-      REAL, DIMENSION(:,:,:), Allocatable :: tabtemp
+      REAL, DIMENSION(indmin(1):indmax(1),
+     &                 indmin(2):indmax(2), 
+     &                 pttab_child(3):petab_child(3)) :: tabtemp
       INTEGER :: i,j,k
-C
-C
-      Allocate(tabtemp(indmin(1):indmax(1),
-     &                 indmin(2):indmax(2), 
-     &                 pttab_child(3):petab_child(3)))
+      INTEGER :: coeffraf,locind_child_left
+      INTEGER :: kdeb
+C
 C
       do k = pttab_child(nbdim),petab_child(nbdim)
 C
-        Call Agrif_Update_2D_recursive(TypeUpdate,    
-     &         tabtemp(indmin(nbdim-2):indmax(nbdim-2),
-     &                 indmin(nbdim-1):indmax(nbdim-1),k),
-     &         tempC(pttab_child(nbdim-2):petab_child(nbdim-2),
-     &               pttab_child(nbdim-1):petab_child(nbdim-1),k),
+        Call Agrif_Update_2D_recursive(TypeUpdate(1:nbdim-1),    
+     &         tabtemp(:,:,k),
+     &         tempC(:,:,k),
      &         indmin(1:nbdim-1),indmax(1:nbdim-1),
      &         pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
@@ -1857 +1914 @@
       enddo
 C
-C
+      Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+      
+      IF (coeffraf == 1) THEN
+      
+      kdeb = pttab_child(3)+locind_child_left-2
+      do k=indmin(3),indmax(3)
+      kdeb = kdeb + 1
       do j = indmin(2),indmax(2)
-C
         do i = indmin(1),indmax(1)
+        tempP(i,j,k) = tabtemp(i,j,kdeb)
+      enddo
+      enddo
+      enddo
+              
+      ELSE
+C
+      do j = indmin(2),indmax(2)
+C
+        do i = indmin(1),indmax(1)
 C
           Call Agrif_UpdateBase(TypeUpdate(3),
-     &           tempP(i,j,indmin(nbdim):indmax(nbdim)),
-     &          tabtemp(i,j,pttab_child(nbdim):petab_child(nbdim)),
+     &           tempP(i,j,:),
+     &          tabtemp(i,j,:),
      &           indmin(nbdim),indmax(nbdim),
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),
+     &                  coeffraf,locind_child_left)
 C
         enddo 
 C        
       enddo
-C
-      Deallocate(tabtemp)
+      ENDIF
 C
       Return
@@ -1921 +1994 @@
       REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp
       INTEGER :: i,j,k,l
+      INTEGER :: coeffraf,locind_child_left
 C
 C
@@ -1930 +2004 @@
       do l = pttab_child(nbdim),petab_child(nbdim)
 C
-        Call Agrif_Update_3D_recursive(TypeUpdate,    
+        Call Agrif_Update_3D_recursive(TypeUpdate(1:nbdim-1),    
      &         tabtemp(indmin(nbdim-3):indmax(nbdim-3),
      &                 indmin(nbdim-2):indmax(nbdim-2),
@@ -1943 +2017 @@
 C
       enddo
+      
+      Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
 C
       do k = indmin(3),indmax(3)
@@ -1956 +2033 @@
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),
+     &                  coeffraf,locind_child_left)
 C
           enddo 
@@ -2013 +2091 @@
       REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp
       INTEGER :: i,j,k,l,m
+      INTEGER :: coeffraf,locind_child_left
 C
 C
@@ -2023 +2102 @@
       do m = pttab_child(nbdim),petab_child(nbdim)
 C
-        Call Agrif_Update_4D_recursive(TypeUpdate,    
+        Call Agrif_Update_4D_recursive(TypeUpdate(1:nbdim-1),    
      &         tabtemp(indmin(nbdim-4):indmax(nbdim-4),
      &                 indmin(nbdim-3):indmax(nbdim-3),
@@ -2038 +2117 @@
 C
       enddo
+      
+      Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
 C
       do l = indmin(4),indmax(4)
@@ -2054 +2136 @@
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),
+     &                  coeffraf,locind_child_left)
 C
             enddo
@@ -2116 +2199 @@
       REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp
       INTEGER :: i,j,k,l,m,n
+      INTEGER :: coeffraf,locind_child_left
 C
 C
@@ -2127 +2211 @@
       do n = pttab_child(nbdim),petab_child(nbdim)
 C
-        Call Agrif_Update_5D_recursive(TypeUpdate,    
+        Call Agrif_Update_5D_recursive(TypeUpdate(1:nbdim-1),    
      &         tabtemp(indmin(nbdim-5):indmax(nbdim-5),
      &                 indmin(nbdim-4):indmax(nbdim-4),
@@ -2144 +2228 @@
 C
       enddo
+      
+      Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
 C
       do m = indmin(5),indmax(5)
@@ -2161 +2248 @@
      &           pttab_child(nbdim),petab_child(nbdim),
      &           s_parent(nbdim),s_child(nbdim),
-     &           ds_parent(nbdim),ds_child(nbdim))
+     &           ds_parent(nbdim),ds_child(nbdim),
+     &                  coeffraf,locind_child_left)
 C
             enddo
@@ -2188 +2276 @@
      &                            parenttab,childtab,
      &                            indmin,indmax,pttab_child,petab_child,
-     &                            s_parent,s_child,ds_parent,ds_child)
+     &                            s_parent,s_child,ds_parent,ds_child,
+     &                            coeffraf,locind_child_left)
 C
 CCC   Description:
@@ -2206 +2295 @@
       REAL,DIMENSION(pttab_child:petab_child) :: childtab      
       REAL    :: s_parent,s_child
-      REAL    :: ds_parent,ds_child       
+      REAL    :: ds_parent,ds_child      
+      INTEGER :: coeffraf,locind_child_left
 C
 C
       if (TypeUpdate == AGRIF_Update_copy) then
 C             
-          Call copy1D
+          Call agrif_copy1D
      &       (parenttab,childtab,
      &          indmax-indmin+1,petab_child-pttab_child+1,
@@ -2228 +2318 @@
      &       (parenttab,childtab,
      &          indmax-indmin+1,petab_child-pttab_child+1,
-     &          s_parent,s_child,ds_parent,ds_child)
+     &          s_parent,s_child,ds_parent,ds_child,
+     &          coeffraf,locind_child_left)
 C
       endif 
@@ -2238 +2329 @@
 C
 C
+
+      Subroutine Agrif_Compute_nbdim_update(s_parent,s_child,
+     &  ds_parent,ds_child,coeffraf,locind_child_left)
+      real :: s_parent,s_child,ds_parent,ds_child
+      integer :: coeffraf,locind_child_left
+     
+      coeffraf = nint(ds_parent/ds_child)
+      locind_child_left = 1 + agrif_int((s_parent-s_child)/ds_child)
+      
+      End Subroutine Agrif_Compute_nbdim_update
+ 
+#if defined AGRIF_MPI      
+      Subroutine Agrif_Find_list_update(list_update,pttab,petab,
+     &                          pttab_Child,pttab_Parent,nbdim,
+     &     find_list_update,tab4t,tab5t,memberinall,memberinall2)     
+      TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
+      INTEGER :: nbdim
+      INTEGER,DIMENSION(nbdim)   :: pttab,petab,pttab_Child,pttab_Parent
+      LOGICAL :: find_list_update
+      Type(Agrif_List_Interp_loc), Pointer :: parcours
+      INTEGER :: i
+C
+      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t
+      LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall,memberinall2
+                    
+      find_list_update = .FALSE.
+      
+      parcours => list_update
+      
+      Find_loop :   Do While (associated(parcours))
+        Do i=1,nbdim
+          IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
+     &        (petab(i) /= parcours%interp_loc%petab(i)).OR.
+     &        (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
+     &        (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
+     &               THEN
+            parcours=>parcours%suiv
+            Cycle Find_loop
+          ENDIF
+        EndDo
+        
+        tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:4)
+        memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
+        
+        tab5t = parcours%interp_loc%tab5t(1:nbdim,0:Agrif_Nbprocs-1,1:4)
+        memberinall2 = 
+     &       parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1)
+        
+        find_list_update = .TRUE.   
+        Exit Find_loop
+      End Do Find_loop  
+                              
+      End Subroutine Agrif_Find_list_update  
+      
+      Subroutine Agrif_AddTo_list_update(list_update,pttab,petab,
+     &                          pttab_Child,pttab_Parent,nbdim
+     &      ,tab4t,tab5t,memberinall,memberinall2)
+          
+      TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
+      INTEGER :: nbdim
+      INTEGER,DIMENSION(nbdim)   :: pttab,petab,pttab_Child,pttab_Parent
+      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,4) :: tab4t, tab5t
+      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
+
+      Type(Agrif_List_Interp_loc), Pointer :: parcours
+            
+       Allocate(parcours)
+      Allocate(parcours%interp_loc)
+      
+      parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
+      parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
+      parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
+      parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
+      Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,4))
+      Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
+      
+      Allocate(parcours%interp_loc%tab5t(nbdim,0:Agrif_Nbprocs-1,4))
+      Allocate(parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1))
+            
+      parcours%interp_loc%tab4t=tab4t   
+      parcours%interp_loc%memberinall=memberinall
+ 
+      parcours%interp_loc%tab5t=tab5t   
+      parcours%interp_loc%memberinall2=memberinall2
+            
+      parcours%suiv => list_update
+      
+      list_update => parcours
+      
+      End Subroutine Agrif_Addto_list_update
+#endif
+           
       End Module Agrif_Update
 
-
-
-      
+C     **************************************************************************
+CCC   Subroutine Agrif_Update_1D_Recursive
+C     **************************************************************************
+C
+      Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC,
+     &                                     indmin,indmax,
+     &                                     pttab_child,petab_child,
+     &                                     s_child,s_parent,
+     &                                     ds_child,ds_parent,nbdim)
+C
+CCC   Description:
+CCC   Subroutine to update a 1D grid variable on the parent grid.
+C
+CC    Method:
+C
+C     Declarations:
+C
+      
+C
+C     Arguments
+      USE Agrif_Update
+      INTEGER                   :: nbdim
+      INTEGER, DIMENSION(nbdim) :: TypeUpdate            ! TYPE of update (copy or average)
+      INTEGER, DIMENSION(nbdim) :: indmin,indmax
+      INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+      REAL, DIMENSION(nbdim)    :: s_child,s_parent
+      REAL, DIMENSION(nbdim)    :: ds_child,ds_parent
+      REAL, DIMENSION(indmin(nbdim):indmax(nbdim))           :: tempP
+      REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC
+      INTEGER :: coeffraf,locind_child_left
+C
+C
+      Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+     &  ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+      
+      Call Agrif_UpdateBase(TypeUpdate(1),
+     &                  tempP(indmin(nbdim):indmax(nbdim)),
+     &                  tempC(pttab_child(nbdim):petab_child(nbdim)),
+     &                  indmin(nbdim),indmax(nbdim),           
+     &                  pttab_child(nbdim),petab_child(nbdim),
+     &                  s_parent(nbdim),s_child(nbdim),
+     &                  ds_parent(nbdim),ds_child(nbdim),
+     &                  coeffraf,locind_child_left)
+C
+      Return
+C
+C
+      End Subroutine Agrif_Update_1D_recursive      

trunk/AGRIF/AGRIF_FILES/modupdatebasic.F

@@ -48 +48 @@
 C     ************************************************************************** 
 C
-      Subroutine copy1d(x,y,np,nc,
+      Subroutine agrif_copy1d(x,y,np,nc,
      &                  s_parent,s_child,ds_parent,ds_child) 
 C
@@ -99 +99 @@
 C
 C
-      End Subroutine copy1d
+      End Subroutine agrif_copy1d
 C
 C
@@ -147 +147 @@
       
       IF ( mod(coeffraf,2) == 0 ) diffmod = 1
+
+        locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child)
       
       do i = 1,np
 C
-        locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child)
-C
-        if ((locind_child_left-1 < 1) 
-     &      .OR. (locind_child_left+1 > nc)) then 
-C
-            x(i) = y(locind_child_left)                
-C
-          else 
+
+C
+c        if ((locind_child_left-1 < 1) 
+c     &      .OR. (locind_child_left+1 > nc)) then 
+C
+c            x(i) = y(locind_child_left)                
+C
+c          else 
           nbnonnuls = 0
           Do ii = -coeffraf/2+locind_child_left+diffmod,
@@ -181 +183 @@
             ENDIF
 C
-        endif
-C
-        xpos = xpos + ds_parent
+c       endif
+C
+c        xpos = xpos + ds_parent
+        locind_child_left = locind_child_left + coeffraf
 C
       enddo
@@ -199 +202 @@
 C
       Subroutine full_weighting1D(x,y,np,nc,
-     &                            s_parent,s_child,ds_parent,ds_child) 
+     &                            s_parent,s_child,ds_parent,ds_child,
+     &                            coeffraf,locind_child_left) 
 C
 CCC   Description:
@@ -214 +218 @@
 C     Local variables
       INTEGER :: i,locind_child_left,coeffraf
-      REAL    :: xpos 
-C 
-C
-      coeffraf = nint(ds_parent/ds_child)
+      REAL    :: xpos,sumweight,weight
+      INTEGER :: ii,diffmod
+      REAL :: xposfin
+      INTEGER :: it1,it2
+      INTEGER :: i1,i2
+      REAL :: invsumweight
+      REAL :: weights(-(coeffraf-1):coeffraf-1)
+      
+C
 C
       if (coeffraf == 1) then
-C
-          locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
 C        
           x(1:np) = y(locind_child_left:locind_child_left+np-1)
@@ -229 +236 @@
       endif
 C
-      IF (coeffraf .NE. 3) THEN
-        print *,'FULL WEIGHTING NOT READY FOR COEFFRAF = 3'
-        STOP
-      ENDIF
       xpos = s_parent      
-C
+      
+       x = 0.
+
+       xposfin = s_child + ds_child * (locind_child_left - 1)
+       IF (abs(xposfin - xpos).LT.0.001) THEN
+          diffmod = 0
+       ELSE
+          diffmod = 1
+       ENDIF
+C
+             
+       it1 = -(coeffraf-1)
+       i1 = -(coeffraf-1)+locind_child_left+diffmod
+       i2 = 2*coeffraf - 2
+       
+      invsumweight=1./coeffraf**2
+      do i=-(coeffraf-1),0
+        weights(i) = invsumweight*(coeffraf + i)
+      enddo
+      do i=1,coeffraf-1
+        weights(i) = invsumweight*(coeffraf - i)
+      enddo
+
+      sumweight = 0                    
       do i = 1,np
 C
-        locind_child_left = 1 + nint((xpos - s_child)/ds_child)
-C
-        if ((locind_child_left-1 < 1) 
-     &      .OR. (locind_child_left+1 > nc)) then 
-C      Agrif_UseSpecialValueInUpdate = .TRUE.
-            x(i) = y(locind_child_left)                
-C
-          else
-C        
-            x(i) = (y(locind_child_left-1)+2.*y(locind_child_left)+
-     &              y(locind_child_left+1))/4.                
-C
-        endif
-C
-        xpos = xpos + ds_parent
-C
-      enddo
+          it2 = it1
+          Do ii = i1,i1+i2
+C
+           IF (Agrif_UseSpecialValueInUpdate) THEN
+            IF (y(ii) .NE. Agrif_SpecialValueFineGrid) THEN
+               x(i) = x(i) + weights(it2)*y(ii)
+               sumweight = sumweight+weights(it2)
+            ENDIF
+           ELSE           
+               x(i) = x(i) + weights(it2)*y(ii)
+           ENDIF           
+           
+          it2 = it2+1
+          End Do
+
+           IF (Agrif_UseSpecialValueInUpdate) THEN          
+                 IF (sumweight .NE. 0.) THEN
+                    x(i) = x(i)/sumweight
+                    sumweight = 0
+                 ELSE
+                    x(i) = Agrif_SpecialValueFineGrid
+                 ENDIF
+           ENDIF
+        
+        i1 = i1 + coeffraf
+C
+      enddo    
 C
       Return 
 C            
 C
-      End Subroutine full_weighting1D      
-C
-C
+      End Subroutine full_weighting1D 
+
 C
       End module AGRIF_updatebasic