RFLU_ModInterpolation.F90

Go to the documentation of this file.

! *********************************************************************
! * Rocstar Simulation Suite                                          *
! * Copyright@2015, Illinois Rocstar LLC. All rights reserved.        *
! *                                                                   *
! * Illinois Rocstar LLC                                              *
! * Champaign, IL                                                     *
! * www.illinoisrocstar.com                                           *
! * sales@illinoisrocstar.com                                         *
! *                                                                   *
! * License: See LICENSE file in top level of distribution package or *
! * http://opensource.org/licenses/NCSA                               *
! *********************************************************************
! *********************************************************************
! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,   *
! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES   *
! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND          *
! * NONINFRINGEMENT.  IN NO EVENT SHALL THE CONTRIBUTORS OR           *
! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER       *
! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,   *
! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE    *
! * USE OR OTHER DEALINGS WITH THE SOFTWARE.                          *
! *********************************************************************
! ******************************************************************************
!
! Purpose: Suite of routines to carry out interpolation operations.
!
! Description: None.
!
! Notes: None.
!  1. Removed RFLU_InterpCells2FacesPatches because it uses bf2bg
!     and bf2bg is being removed as bGradFace is moved from pRegion to patch
!
! ******************************************************************************
!
! $Id: RFLU_ModInterpolation.F90,v 1.21 2008/12/06 08:44:22 mtcampbe Exp $
!
! Copyright: (c) 2002-2005 by the University of Illinois
!
! ******************************************************************************

MODULE rflu_modinterpolation

  USE moddatatypes
  USE moderror
  USE modparameters  
  USE modglobal, ONLY: t_global
  USE modbndpatch, ONLY: t_patch
  USE moddatastruct, ONLY: t_region
  USE modgrid, ONLY: t_grid
  USE modtools, ONLY: compfact
  USE modmpi

  USE rflu_modstencilsutils, ONLY: rflu_computestencilweights

  USE modinterfaces, ONLY: rflu_invertmatrixsvd

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: rflu_interpcells2face, &
            rflu_interpcells2facepatch, &  
            rflu_interpcells2faces, &
            rflu_interpcells2verts, & 
            rflu_interpsimplecells2verts
  
  SAVE
  
! ******************************************************************************
! Declarations and definitions
! ******************************************************************************  
       
  CHARACTER(CHRLEN) :: RCSIdentString = & 
    '$RCSfile: RFLU_ModInterpolation.F90,v $ $Revision: 1.21 $'
       
       
! ******************************************************************************
! Routines
! ******************************************************************************

  CONTAINS
  
  
  
! ******************************************************************************
!
! Purpose: Interpolation from cells to single face.
!
! Description: None.
!
! Input:
!   pRegion             Pointer to region data
!   ifg                 Global face index
!   src                 Source array of cell data
!
! Output:
!   dst                 Destination array of face data
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_interpcells2face(pRegion,ifg,src,dst)
 
    IMPLICIT NONE

! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************

! ==============================================================================  
!   Arguments 
! ==============================================================================  

    INTEGER, INTENT(IN) :: ifg
    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: src
    REAL(RFREAL), DIMENSION(:), INTENT(OUT) :: dst
    TYPE(t_region), POINTER :: pregion

! ==============================================================================  
!   Locals 
! ==============================================================================  

    INTEGER :: errorflag,icg,idst,ienddst,iendsrc,isrc,isl
    REAL(RFREAL) :: c11,c12,c13,c14,c22,c23,c24,c33,c34,c44,dx,dy,dz, &
                    r11,r12,r13,r14,r22,r23,r24,r33,r34,r44,term,wti
    TYPE(t_grid), POINTER :: pgrid
    TYPE(t_global), POINTER :: global
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_InterpCells2Face',&
  'RFLU_ModInterpolation.F90')

! ******************************************************************************
!   Set pointers and variables
! ******************************************************************************

    pgrid => pregion%grid        

    iendsrc = ubound(src,1)
    ienddst = ubound(dst,1)

! ******************************************************************************
!   Get face weights 
! ******************************************************************************

! ==============================================================================  
!   Select appropriate dimensionality
! ==============================================================================  

    SELECT CASE ( pregion%mixtInput%dimens )
    
! ------------------------------------------------------------------------------
!     Two dimensions 
! ------------------------------------------------------------------------------    
    
      CASE ( 2 )
        r11 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_11)           
        r12 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_12) 
        r22 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_22)           
        r13 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_13) 
        r23 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_23)                   
        r33 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_33)

        c11 = 1.0_rfreal/r11
        c22 = 1.0_rfreal/r22
        c33 = 1.0_rfreal/r33

        c12 = - c11*r12
        c13 = -(c11*r13 + c12*c22*r23) 

        c23 = - c22*r23
        
! ------------------------------------------------------------------------------
!     Three dimensions 
! ------------------------------------------------------------------------------    
            
      CASE ( 3 )            
        r11 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_11)           
        r12 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_12) 
        r22 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_22)           
        r13 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_13) 
        r23 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_23)                   
        r33 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_33)
        r14 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_14)
        r24 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_24)
        r34 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_34)
        r44 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_44)                  

        c11 = 1.0_rfreal/r11
        c22 = 1.0_rfreal/r22
        c33 = 1.0_rfreal/r33
        c44 = 1.0_rfreal/r44

        c12 = - c11*r12
        c13 = -(c11*r13 + c12*c22*r23) 
        c14 = -(c11*r14 + c12*c22*r24 + c13*c33*r34) 

        c23 = - c22*r23
        c24 = -(c22*r24 + c23*c33*r34)

        c34 = - c33*r34
        
! ------------------------------------------------------------------------------
!     Default
! ------------------------------------------------------------------------------    
            
      CASE default
        CALL errorstop(global,err_reached_default,__line__)
    END SELECT ! pRegion%mixtInput%dimens

! ******************************************************************************
!   Initialize destination array
! ******************************************************************************

    DO idst = 1,ienddst ! Explicit loop because of Frost problems
      dst(idst) = 0.0_rfreal
    END DO ! iDst

! ******************************************************************************
!   Loop over stencil members and interpolate
! ******************************************************************************

! ==============================================================================  
!   Select appropriate dimensionality
! ==============================================================================  

    SELECT CASE ( pregion%mixtInput%dimens ) 

! ------------------------------------------------------------------------------
!     Two dimensions 
! ------------------------------------------------------------------------------    

      CASE ( 2 )
        DO isl = 1,pgrid%f2cs(ifg)%nCellMembs 
          icg = pgrid%f2cs(ifg)%cellMembs(isl)

          dx = pgrid%cofg(xcoord,icg) - pgrid%fc(xcoord,ifg)
          dy = pgrid%cofg(ycoord,icg) - pgrid%fc(ycoord,ifg)

          term = 1.0_rfreal/sqrt(dx*dx + dy*dy)            

          dx = term*dx
          dy = term*dy        

          wti = term*c33*c33*(term + c23*dy + c13*dx)

          idst = 1

          DO isrc = 1,iendsrc
            dst(idst) = dst(idst) + wti*src(isrc,icg)

            idst = idst + 1          
          END DO ! iSrc                    
        END DO ! isl       

! ------------------------------------------------------------------------------
!     Three dimensions 
! ------------------------------------------------------------------------------    

      CASE ( 3 ) 
        DO isl = 1,pgrid%f2cs(ifg)%nCellMembs 
          icg = pgrid%f2cs(ifg)%cellMembs(isl)

          dx = pgrid%cofg(xcoord,icg) - pgrid%fc(xcoord,ifg)
          dy = pgrid%cofg(ycoord,icg) - pgrid%fc(ycoord,ifg)
          dz = pgrid%cofg(zcoord,icg) - pgrid%fc(zcoord,ifg)   

          term = 1.0_rfreal/sqrt(dx*dx + dy*dy + dz*dz)            

          dx = term*dx
          dy = term*dy
          dz = term*dz        

          wti = term*c44*c44*(term + c34*dz + c24*dy + c14*dx)

          idst = 1

          DO isrc = 1,iendsrc
            dst(idst) = dst(idst) + wti*src(isrc,icg)

            idst = idst + 1          
          END DO ! iSrc                    
        END DO ! isl

! ------------------------------------------------------------------------------
!     Default
! ------------------------------------------------------------------------------    

      CASE default
        CALL errorstop(global,err_reached_default,__line__)
    END SELECT ! pRegion%mixtInput%dimens 
 
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)

  END SUBROUTINE rflu_interpcells2face  
  
  
  
  

! ******************************************************************************
!
! Purpose: Interpolation from cells to single face on single patch.
!
! Description: None.
!
! Input:
!   pRegion             Pointer to region data
!   pPatch              Pointer to patch data
!   ifg                 Global face index
!   src                 Source array of cell data
!
! Output:
!   dst                 Destination array of face data
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_interpcells2facepatch(pRegion,pPatch,ifl,src,dst)
 
    IMPLICIT NONE

! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************

! ==============================================================================  
!   Arguments 
! ==============================================================================  

    INTEGER, INTENT(IN) :: ifl
    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: src
    REAL(RFREAL), DIMENSION(:), INTENT(OUT) :: dst
    TYPE(t_patch), POINTER :: ppatch
    TYPE(t_region), POINTER :: pregion

! ==============================================================================  
!   Locals 
! ==============================================================================  

    INTEGER :: errorflag,icg,idst,ienddst,iendsrc,isrc,isl
    REAL(RFREAL) :: c11,c12,c13,c14,c22,c23,c24,c33,c34,c44,dx,dy,dz, &
                    r11,r12,r13,r14,r22,r23,r24,r33,r34,r44,term,wti
    TYPE(t_grid), POINTER :: pgrid
    TYPE(t_global), POINTER :: global
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_InterpCells2FacePatch',&
  'RFLU_ModInterpolation.F90')

! ******************************************************************************
!   Set pointers and variables
! ******************************************************************************

    pgrid => pregion%grid        

    iendsrc = ubound(src,1)
    ienddst = ubound(dst,1)

! ******************************************************************************
!   Get face weights 
! ******************************************************************************

    SELECT CASE ( pregion%mixtInput%dimens )
      CASE ( 2 )
        r11 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_11)           
        r12 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_12) 
        r22 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_22)           
        r13 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_13) 
        r23 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_23)                   
        r33 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_33)

        c11 = 1.0_rfreal/r11
        c22 = 1.0_rfreal/r22
        c33 = 1.0_rfreal/r33

        c12 = - c11*r12
        c13 = -(c11*r13 + c12*c22*r23)  

        c23 = - c22*r23
      CASE ( 3 ) 
        r11 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_11)           
        r12 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_12) 
        r22 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_22)           
        r13 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_13) 
        r23 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_23)                   
        r33 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_33)
        r14 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_14)
        r24 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_24)
        r34 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_34)
        r44 = ppatch%bf2cs(ifl)%xyzMoms(xyz_mom_44)                  

        c11 = 1.0_rfreal/r11
        c22 = 1.0_rfreal/r22
        c33 = 1.0_rfreal/r33
        c44 = 1.0_rfreal/r44

        c12 = - c11*r12
        c13 = -(c11*r13 + c12*c22*r23) 
        c14 = -(c11*r14 + c12*c22*r24 + c13*c33*r34) 

        c23 = - c22*r23
        c24 = -(c22*r24 + c23*c33*r34)

        c34 = - c33*r34
      CASE default
        CALL errorstop(global,err_reached_default,__line__)
    END SELECT ! pRegion%mixtInput%dimens

! ******************************************************************************
!   Initialize destination array
! ******************************************************************************

    DO idst = 1,ienddst ! Explicit loop because of Frost problems
      dst(idst) = 0.0_rfreal
    END DO ! iDst

! ******************************************************************************
!   Loop over stencil members and interpolate
! ******************************************************************************

    SELECT CASE ( pregion%mixtInput%dimens ) 
      CASE ( 2 ) 
        DO isl = 1,ppatch%bf2cs(ifl)%nCellMembs 
          icg = ppatch%bf2cs(ifl)%cellMembs(isl)

          dx = pgrid%cofg(xcoord,icg) - ppatch%fc(xcoord,ifl)
          dy = pgrid%cofg(ycoord,icg) - ppatch%fc(ycoord,ifl)

          term = 1.0_rfreal/sqrt(dx*dx + dy*dy)            

          dx = term*dx
          dy = term*dy       

          wti = term*c33*c33*(term + c23*dy + c13*dx)

          idst = 1

          DO isrc = 1,iendsrc
            dst(idst) = dst(idst) + wti*src(isrc,icg)

            idst = idst + 1          
          END DO ! iSrc                    
        END DO ! isl      
      CASE ( 3 ) 
        DO isl = 1,ppatch%bf2cs(ifl)%nCellMembs 
          icg = ppatch%bf2cs(ifl)%cellMembs(isl)

          dx = pgrid%cofg(xcoord,icg) - ppatch%fc(xcoord,ifl)
          dy = pgrid%cofg(ycoord,icg) - ppatch%fc(ycoord,ifl)
          dz = pgrid%cofg(zcoord,icg) - ppatch%fc(zcoord,ifl)   

          term = 1.0_rfreal/sqrt(dx*dx + dy*dy + dz*dz)            

          dx = term*dx
          dy = term*dy
          dz = term*dz        

          wti = term*c44*c44*(term + c34*dz + c24*dy + c14*dx)

          idst = 1

          DO isrc = 1,iendsrc
            dst(idst) = dst(idst) + wti*src(isrc,icg)

            idst = idst + 1          
          END DO ! iSrc                    
        END DO ! isl
      CASE default
        CALL errorstop(global,err_reached_default,__line__)
    END SELECT ! pRegion%mixtInput%dimens
 
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)

  END SUBROUTINE rflu_interpcells2facepatch
  
  
  
  
  
  
  
! ******************************************************************************
!
! Purpose: Interpolation from cells to faces.
!
! Description: None.
!
! Input:
!   pRegion             Pointer to region data
!   src                 Source array of cell data
!
! Output:
!   dst                 Destination array of face data
!
! Notes: 
!   1. Could call RFLU_InterpCells2Face for each face, but do not do so for
!      performance reasons (repeated call with src array) 
!
! ******************************************************************************

  SUBROUTINE rflu_interpcells2faces(pRegion,src,dst)
 
    IMPLICIT NONE

! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************

! ==============================================================================  
!   Arguments 
! ==============================================================================  

    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: src
    REAL(RFREAL), DIMENSION(:,:), INTENT(OUT) :: dst
    TYPE(t_region), POINTER :: pregion

! ==============================================================================  
!   Locals 
! ==============================================================================  

    INTEGER :: errorflag,icg,idst,ienddst,iendsrc,ifg,isl,isrc
    REAL(RFREAL) :: c11,c12,c13,c14,c22,c23,c24,c33,c34,c44,dx,dy,dz, &
                    r11,r12,r13,r14,r22,r23,r24,r33,r34,r44,term,wti
    TYPE(t_grid), POINTER :: pgrid
    TYPE(t_global), POINTER :: global
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_InterpCells2Faces',&
  'RFLU_ModInterpolation.F90')

! ******************************************************************************
!   Set pointers and variables
! ******************************************************************************

    pgrid => pregion%grid

    iendsrc = ubound(src,1)
    ienddst = ubound(dst,1)

! ******************************************************************************
!   Loop over faces and interpolate from cells in stencil
! ******************************************************************************
 
! ==============================================================================
!   Select appropriate dimensionality
! ============================================================================== 
 
    SELECT CASE ( pregion%mixtInput%dimens ) 
    
! --- Two dimensions -----------------------------------------------------------    
    
      CASE ( 2 ) 
        DO ifg = 1,pgrid%nFaces                                                       
          r11 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_11)           
          r12 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_12) 
          r22 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_22)           
          r13 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_13) 
          r23 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_23)                   
          r33 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_33)

          c11 = 1.0_rfreal/r11
          c22 = 1.0_rfreal/r22
          c33 = 1.0_rfreal/r33

          c12 = - c11*r12
          c13 = -(c11*r13 + c12*c22*r23) 

          c23 = - c22*r23
          
          DO idst = 1,ienddst ! Explicit loop because of Frost problems
            dst(idst,ifg) = 0.0_rfreal
          END DO ! iDst

          DO isl = 1,pgrid%f2cs(ifg)%nCellMembs 
            icg = pgrid%f2cs(ifg)%cellMembs(isl)

            dx = pgrid%cofg(xcoord,icg) - pgrid%fc(xcoord,ifg)
            dy = pgrid%cofg(ycoord,icg) - pgrid%fc(ycoord,ifg)

            term = 1.0_rfreal/sqrt(dx*dx + dy*dy)            

            dx = term*dx
            dy = term*dy       

            wti = term*c33*c33*(term + c23*dy + c13*dx)

            idst = 1

            DO isrc = 1,iendsrc
              dst(idst,ifg) = dst(idst,ifg) + wti*src(isrc,icg)

              idst = idst + 1          
            END DO ! iSrc                    
          END DO ! isl                  
        END DO ! ifg      

! --- Three dimensions ---------------------------------------------------------    

      CASE ( 3 )  
        DO ifg = 1,pgrid%nFaces                                                       
          r11 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_11)           
          r12 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_12) 
          r22 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_22)           
          r13 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_13) 
          r23 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_23)                   
          r33 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_33)
          r14 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_14)
          r24 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_24)
          r34 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_34)
          r44 = pgrid%f2cs(ifg)%xyzMoms(xyz_mom_44)                  

          c11 = 1.0_rfreal/r11
          c22 = 1.0_rfreal/r22
          c33 = 1.0_rfreal/r33
          c44 = 1.0_rfreal/r44

          c12 = - c11*r12
          c13 = -(c11*r13 + c12*c22*r23) 
          c14 = -(c11*r14 + c12*c22*r24 + c13*c33*r34) 

          c23 = - c22*r23
          c24 = -(c22*r24 + c23*c33*r34)

          c34 = - c33*r34

          DO idst = 1,ienddst ! Explicit loop because of Frost problems
            dst(idst,ifg) = 0.0_rfreal
          END DO ! iDst

          DO isl = 1,pgrid%f2cs(ifg)%nCellMembs 
            icg = pgrid%f2cs(ifg)%cellMembs(isl)

            dx = pgrid%cofg(xcoord,icg) - pgrid%fc(xcoord,ifg)
            dy = pgrid%cofg(ycoord,icg) - pgrid%fc(ycoord,ifg)
            dz = pgrid%cofg(zcoord,icg) - pgrid%fc(zcoord,ifg)   

            term = 1.0_rfreal/sqrt(dx*dx + dy*dy + dz*dz)            

            dx = term*dx
            dy = term*dy
            dz = term*dz        

            wti = term*c44*c44*(term + c34*dz + c24*dy + c14*dx)

            idst = 1

            DO isrc = 1,iendsrc
              dst(idst,ifg) = dst(idst,ifg) + wti*src(isrc,icg)

              idst = idst + 1          
            END DO ! iSrc                    
          END DO ! isl                  
        END DO ! ifg

! --- Default -------------------------------------------------------------------    

      CASE default
        CALL errorstop(global,err_reached_default,__line__)
    END SELECT ! pRegion%mixtInput%dimens
 
! ******************************************************************************
!   End
! ******************************************************************************

    CALL deregisterfunction(global)

  END SUBROUTINE rflu_interpcells2faces







! ******************************************************************************
!
! Purpose: Interpolation from cells to vertices.
!
! Description: None.
!
! Input:
!   pRegion             Pointer to region data
!   orderNominal        Nominal order of accuracy
!   nVar                Number of variables
!   src                 Source data array of cell data
!
! Output:
!   dst                 Destination data array of vertex data
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_interpcells2verts(pRegion,orderNominal,nVar,src,dst)

    IMPLICIT NONE

! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************

! ==============================================================================  
!   Arguments 
! ==============================================================================  

    INTEGER, INTENT(IN) :: nvar,ordernominal
    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: src
    REAL(RFREAL), DIMENSION(:,:), INTENT(OUT) :: dst
    TYPE(t_region), POINTER :: pregion

! ==============================================================================  
!   Locals 
! ==============================================================================  

    INTEGER :: errorflag,icg,isl,ivg,ivar,nrows,orderactual,scount        
    REAL(RFREAL), DIMENSION(:,:), ALLOCATABLE :: dr,wts
    TYPE(t_grid), POINTER :: pgrid
    TYPE(t_global), POINTER :: global
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_InterpCells2Verts',&
  'RFLU_ModInterpolation.F90')

    IF ( global%myProcid == masterproc ) THEN 
      IF ( global%verbLevel > verbose_none ) THEN
        WRITE(stdout,'(A,1X,A)') solver_name, &
                                 'Interpolating from cells to vertices...'
      END IF ! global%verbLevel
      
      IF ( global%verbLevel > verbose_low ) THEN
        WRITE(stdout,'(A,3X,A)') solver_name,'Method: Proper' 
      END IF ! global%verbLevel > VERBOSE_LOW       
    END IF ! global%verbLevel 

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid
    
! ******************************************************************************
!   Loop over vertices and interpolate from cells in stencil
! ******************************************************************************
 
    DO ivg = 1,pgrid%nVertTot                                                       
      nrows = pgrid%v2cs(ivg)%nCellMembs      

      orderactual = ordernominal      

      ALLOCATE(dr(xcoord:zcoord,nrows),stat=errorflag)
      global%error = errorflag   
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_allocate,__line__,'dr')
      END IF ! global%error 

      ALLOCATE(wts(1,nrows),stat=errorflag)
      global%error = errorflag   
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_allocate,__line__,'wts')
      END IF ! global%error

      DO isl = 1,pgrid%v2cs(ivg)%nCellMembs   
        icg = pgrid%v2cs(ivg)%cellMembs(isl)

        dr(xcoord,isl) = pgrid%cofg(xcoord,icg) - pgrid%xyz(xcoord,ivg)
        dr(ycoord,isl) = pgrid%cofg(ycoord,icg) - pgrid%xyz(ycoord,ivg)
        dr(zcoord,isl) = pgrid%cofg(zcoord,icg) - pgrid%xyz(zcoord,ivg)                 
      END DO ! isl

! ==============================================================================  
!     Compute interpolation weights
! ==============================================================================  

      CALL rflu_computestencilweights(global,pregion%mixtInput%dimens, & 
                                      compwts_mode_adapt,compwts_scal_invdist, &
                                      deriv_degree_0,orderactual,nrows,dr, &
                                      wts,scount)

! ==============================================================================  
!     Initialize destination array
! ==============================================================================  

      DO ivar = 1,nvar ! Explicit loop because of ASCI White problems      
        dst(ivar,ivg) = 0.0_rfreal
      END DO ! iVar

! ==============================================================================  
!     Interpolate   
! ==============================================================================  
                                                    
      DO isl = 1,pgrid%v2cs(ivg)%nCellMembs
        icg = pgrid%v2cs(ivg)%cellMembs(isl)

        DO ivar = 1,nvar                                        
          dst(ivar,ivg) = dst(ivar,ivg) + wts(1,isl)*src(ivar,icg)                                    
        END DO ! iVar                             
      END DO ! isl         
                
! ==============================================================================  
!     Deallocate memory         
! ==============================================================================  
        
      DEALLOCATE(dr,stat=errorflag)
      global%error = errorflag   
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_deallocate,__line__,'dr')
      END IF ! global%error 

      DEALLOCATE(wts,stat=errorflag)
      global%error = errorflag   
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_deallocate,__line__,'wts')
      END IF ! global%error                                          
    END DO ! ivg
 
! ******************************************************************************
!   End
! ******************************************************************************

    IF ( global%myProcid == masterproc .AND. &
         global%verbLevel > verbose_none ) THEN
      WRITE(stdout,'(A,1X,A)') solver_name, & 
                               'Interpolating from cells to vertices done.'            
    END IF ! global%verbLevel  

    CALL deregisterfunction(global)

  END SUBROUTINE rflu_interpcells2verts
    
    
    
    



! ******************************************************************************
!
! Purpose: Interpolation from cells to vertices by simple averaging.
!
! Description: None.
!
! Input:
!   pRegion             Pointer to region data
!   nVar                Number of variables
!   src                 Source data array of cell data
!
! Output:
!   dst                 Destination data array of vertex data
!
! Notes: None.
!
! ******************************************************************************

  SUBROUTINE rflu_interpsimplecells2verts(pRegion,nVar,src,dst)

    IMPLICIT NONE

! ******************************************************************************
!   Declarations and definitions
! ******************************************************************************

! ==============================================================================  
!   Arguments 
! ==============================================================================  

    INTEGER, INTENT(IN) :: nvar
    REAL(RFREAL), DIMENSION(:,:), INTENT(IN) :: src
    REAL(RFREAL), DIMENSION(:,:), INTENT(OUT) :: dst
    TYPE(t_region), POINTER :: pregion

! ==============================================================================  
!   Locals 
! ==============================================================================  

    INTEGER :: icg,icl,ivg,ivar,ncells,v2cbeg,v2cend 
    REAL(RFREAL) :: wt       
    TYPE(t_grid), POINTER :: pgrid
    TYPE(t_global), POINTER :: global
    
! ******************************************************************************
!   Start
! ******************************************************************************

    global => pregion%global

    CALL registerfunction(global,'RFLU_InterpSimpleCells2Verts',&
  'RFLU_ModInterpolation.F90')

    IF ( global%myProcid == masterproc ) THEN 
      IF ( global%verbLevel > verbose_none ) THEN
        WRITE(stdout,'(A,1X,A)') solver_name, &
                                 'Interpolating from cells to vertices...'
      END IF ! global%verbLevel
      
      IF ( global%verbLevel > verbose_low ) THEN
        WRITE(stdout,'(A,3X,A)') solver_name,'Method: Simple' 
      END IF ! global%verbLevel > VERBOSE_LOW       
    END IF ! global%verbLevel  

! ******************************************************************************
!   Set pointers
! ******************************************************************************

    pgrid => pregion%grid
    
! ******************************************************************************
!   Loop over vertices and interpolate from cells in stencil
! ******************************************************************************
 
    DO ivg = 1,pgrid%nVertTot 
      v2cbeg = pgrid%v2cInfo(v2c_beg,ivg)
      v2cend = pgrid%v2cInfo(v2c_end,ivg)
                                                              
      ncells = v2cend - v2cbeg + 1
          
! ==============================================================================  
!     Initialize destination array
! ==============================================================================  

      DO ivar = 1,nvar ! Explicit loop because of ASCI White problems      
        dst(ivar,ivg) = 0.0_rfreal
      END DO ! iVar

! ==============================================================================  
!     Interpolate   
! ==============================================================================  
     
      wt = 1.0_rfreal/REAL(nCells,RFREAL)     
                                                    
      DO icl = 1,ncells
        icg = pgrid%v2c(v2cbeg+icl-1)

        DO ivar = 1,nvar                                        
          dst(ivar,ivg) = dst(ivar,ivg) + wt*src(ivar,icg)                                    
        END DO ! iVar                             
      END DO ! isl                                                            
    END DO ! ivg
 
! ******************************************************************************
!   End
! ******************************************************************************

    IF ( global%myProcid == masterproc .AND. &
         global%verbLevel > verbose_none ) THEN
      WRITE(stdout,'(A,1X,A)') solver_name, & 
                               'Interpolating from cells to vertices done.'            
    END IF ! global%verbLevel  

    CALL deregisterfunction(global)

  END SUBROUTINE rflu_interpsimplecells2verts

    
    
    


! ******************************************************************************
! End
! ******************************************************************************

END MODULE rflu_modinterpolation


! ******************************************************************************
!
! RCS Revision history:
!
! $Log: RFLU_ModInterpolation.F90,v $
! Revision 1.21  2008/12/06 08:44:22  mtcampbe
! Updated license.
!
! Revision 1.20  2008/11/19 22:17:33  mtcampbe
! Added Illinois Open Source License/Copyright
!
! Revision 1.19  2006/08/19 15:39:23  mparmar
! Removed RFLU_InterpCells2FacesPatches routine
!
! Revision 1.18  2006/04/07 15:19:19  haselbac
! Removed tabs
!
! Revision 1.17  2005/10/05 13:57:47  haselbac
! Adapted to changes in module contents
!
! Revision 1.16  2005/03/09 14:56:49  haselbac
! Added code for 2d interpolation
!
! Revision 1.15  2004/07/21 15:00:06  haselbac
! Added RFLU_InterpSimpleCells2Verts, cosmetics
!                                                    
! Revision 1.14  2004/03/18 03:31:56  haselbac                                           
! Added routines for interp from cells to faces, clean-up                                
!
! Revision 1.13  2004/01/22 16:03:59  haselbac                                           
! Made contents of modules PRIVATE, only procs PUBLIC, to avoid errors on ALC 
! and titan  
!
! Revision 1.12  2003/12/04 03:28:52  haselbac                                           
! Complete rewrite                                                                       
!
! Revision 1.11  2003/07/22 15:39:14  haselbac                                           
! Added Nullify routines, distinction betw PUBLIC and PRIVATE members                    
!
! Revision 1.10  2003/07/22 02:05:14  haselbac                                           
! Added comp of proper wghts for cell-to-vertex interp                                   
!
! Revision 1.9  2003/03/15 18:12:59  haselbac                                            
! Now also interpolate to dummy vertices                                                 
!
! Revision 1.8  2003/01/28 16:34:29  haselbac                                            
! Cosmetics only                                                                         
!
! Revision 1.7  2002/10/09 20:47:53  haselbac                                            
! Fixed bug in RFLU_DestroyInterpolant: Missing errorFlag declaration                    
!
! Revision 1.6  2002/10/08 15:49:21  haselbac                                            
! {IO}STAT=global%error replaced by {IO}STAT=errorFlag - SGI problem                     
!
! Revision 1.5  2002/09/09 15:09:41  haselbac                                            
! global now under regions                                                               
!
! Revision 1.4  2002/07/25 15:02:59  haselbac                                            
! Only write out for MASTERPROC                                                          
!
! Revision 1.3  2002/06/17 13:39:45  haselbac                                            
! Prefixed SOLVER_NAME to all screen output                                              
!
! Revision 1.2  2002/05/04 16:39:51  haselbac                                            
! Added PRIVATE attribute to RCSIdentString                                              
!
! Revision 1.1  2002/04/11 18:48:48  haselbac                                            
! Initial revision                                                                       
!
! ******************************************************************************