!-------------------------------------------------------------------------------
!>
!! Vertical metrics module
!!
!! @par Description
!!         In this module, the vertical metrics is calculated for the
!!         non-hydrostatic icoshaedral model.
!!
!! @author  H.Tomita
!!
!! @par History
!! @li      2004-02-17 (H.Tomita)  Imported from igdc-4.33
!! @li      2006-08-11 (        )  Trivial bug fix for VMTR_VOLUME in using shallow water model
!!
!<
module mod_vmtr
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: VMTR_setup

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !

  ! index for VMTR_C2Wfact
  integer, public, parameter :: I_a_GZXH = 1
  integer, public, parameter :: I_b_GZXH = 2
  integer, public, parameter :: I_a_GZYH = 3
  integer, public, parameter :: I_b_GZYH = 4
  integer, public, parameter :: I_a_GZZH = 5
  integer, public, parameter :: I_b_GZZH = 6

  !--- gsqrt X gamma^2 at the interger level
  real(8), public, allocatable, save :: VMTR_GSGAM2   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GSGAM2_pl(:,:,:)

  !--- 1/(gsqrt X gamma^2) at the interger level
  real(8), public, allocatable, save :: VMTR_RGSGAM2   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGSGAM2_pl(:,:,:)

  !--- gsqrt X gamma^2 at the half-integer level
  real(8), public, allocatable, save :: VMTR_GSGAM2H   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GSGAM2H_pl(:,:,:)

  !--- 1/(gsqrt X gamma^2) at the half-integer level
  real(8), public, allocatable, save :: VMTR_RGSGAM2H   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGSGAM2H_pl(:,:,:)

  !--- vector G^z at the half-integer level
  real(8), public, allocatable, save :: VMTR_GZXH   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GZXH_pl(:,:,:)
  real(8), public, allocatable, save :: VMTR_GZYH   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GZYH_pl(:,:,:)
  real(8), public, allocatable, save :: VMTR_GZZH   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GZZH_pl(:,:,:)

  !--- vector G^z at the integer level
  real(8), public, allocatable, save :: VMTR_GZX   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GZX_pl(:,:,:)
  real(8), public, allocatable, save :: VMTR_GZY   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GZY_pl(:,:,:)
  real(8), public, allocatable, save :: VMTR_GZZ   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GZZ_pl(:,:,:)

  !--- gsqrt X gamma at the half-integer level
  real(8), public, allocatable, save :: VMTR_GSGAMH   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GSGAMH_pl(:,:,:)

  !--- 1/gamma at the integer level
  real(8), public, allocatable, save :: VMTR_RGAM   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGAM_pl(:,:,:)

  !--- 1/gamma at the half-integer level
  real(8), public, allocatable, save :: VMTR_RGAMH   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGAMH_pl(:,:,:)

  !--- 1/gamma^2 at the integer level
  real(8), public, allocatable, save :: VMTR_RGAM2   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGAM2_pl(:,:,:)

  !--- gamma^2 at the half-integer level
  real(8), public, allocatable, save :: VMTR_GAM2H   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GAM2H_pl(:,:,:)

  !--- gamma^2 at the integer level
  real(8), public, allocatable, save :: VMTR_GAM2   (:,:,:)
  real(8), public, allocatable, save :: VMTR_GAM2_pl(:,:,:)

  !--- 1/gamma^2 at the half-integer level
  real(8), public, allocatable, save :: VMTR_RGAM2H   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGAM2H_pl(:,:,:)

  !--- 1/gsqrt at the half-integer level
  real(8), public, allocatable, save :: VMTR_RGSH   (:,:,:)
  real(8), public, allocatable, save :: VMTR_RGSH_pl(:,:,:)

  !--- volume at the integer level
  real(8), public, allocatable, save :: VMTR_VOLUME   (:,:,:)
  real(8), public, allocatable, save :: VMTR_VOLUME_pl(:,:,:)

  ! [Add] 20120717 H.Yashiro
  !--- geopotential at the integer level
  real(8), public, allocatable, save :: VMTR_PHI   (:,:,:)
  real(8), public, allocatable, save :: VMTR_PHI_pl(:,:,:)

  !--- factor for integer to half integer level
  real(8), public, allocatable, save :: VMTR_C2Wfact   (:,:,:,:)
  real(8), public, allocatable, save :: VMTR_C2Wfact_pl(:,:,:,:)

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
!  logical, private, save :: deep = .true. [mod] 20120704 H.Yashiro
  logical, private, save :: deep = .false.

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !>
  !> Setup the vertical metrics
  !>
  subroutine VMTR_setup
    use mod_adm, only: &
       ADM_proc_stop, &
       ADM_LOG_FID,   &
       ADM_CTL_FID,   &
       ADM_prc_me,    &
       ADM_prc_pl,    &
       ADM_gall,      &
       ADM_gall_pl,   &
       ADM_lall,      &
       ADM_lall_pl,   &
       ADM_kall,      &
       ADM_kmin,      &
       ADM_kmax,      &
       ADM_KNONE,     &
       ADM_gmin,      &
       ADM_gall_1d
    use mod_cnst, only: &
       CNST_ERADIUS, &
       CNST_EGRAV
    use mod_comm, only: &
       COMM_data_transfer
    use mod_grd, only: &
       GRD_Z,     &
       GRD_ZH,    &
       GRD_vz,    &
       GRD_vz_pl, &
       GRD_dgz,   &
       GRD_dgzh,  &
       GRD_afac,  &
       GRD_bfac,  &
       GRD_grid_type
    use mod_gmtr, only: &
       GMTR_P_AREA,  &
       GMTR_P_var,   &
       GMTR_P_var_pl
!    use mod_oprt_plane, only: &
!       OPRT_PLANE_gradient
    use mod_oprt, only: &
       OPRT_gradient,         &
       OPRT_horizontalize_vec
    implicit none

    integer, parameter :: var_max = 6

    integer, parameter :: JXH     = 1
    integer, parameter :: JYH     = 2
    integer, parameter :: JZH     = 3
    integer, parameter :: JX      = 4
    integer, parameter :: JY      = 5
    integer, parameter :: JZ      = 6

    real(8) :: var   (ADM_gall,   ADM_kall,ADM_lall,   var_max)
    real(8) :: var_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl,var_max)

    real(8) :: GSQRT    (ADM_gall,   ADM_kall)
    real(8) :: GSQRT_pl (ADM_gall_pl,ADM_kall)
    real(8) :: GSQRTH   (ADM_gall,   ADM_kall)
    real(8) :: GSQRTH_pl(ADM_gall_pl,ADM_kall)

    real(8) :: GAM, GAMH

    namelist / VMTRPARAM / &
        deep

    integer :: ierr
    integer :: n, k, l
    integer :: i, j, suf
    suf(i,j) = ADM_gall_1d * ((j)-1) + (i)
    !---------------------------------------------------------------------------

    !--- read parameters
    write(ADM_LOG_FID,*)
    write(ADM_LOG_FID,*) '+++ Module[vmtr]/Category[common share]'
    rewind(ADM_CTL_FID)
    read(ADM_CTL_FID,nml=VMTRPARAM,iostat=ierr)
    if ( ierr < 0 ) then
       write(ADM_LOG_FID,*) '*** VMTRPARAM is not specified. use default.'
    elseif( ierr > 0 ) then
       write(*,          *) 'xxx Not appropriate names in namelist VMTRPARAM. STOP.'
       write(ADM_LOG_FID,*) 'xxx Not appropriate names in namelist VMTRPARAM. STOP.'
       call ADM_proc_stop
    endif
    write(ADM_LOG_FID,VMTRPARAM)

    !--- initialization
    allocate( VMTR_GSGAM2     (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GSGAM2_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGSGAM2    (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGSGAM2_pl (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GSGAM2H    (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GSGAM2H_pl (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGSGAM2H   (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGSGAM2H_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GSGAMH     (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GSGAMH_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GZXH       (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GZXH_pl    (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GZYH       (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GZYH_pl    (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GZZH       (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GZZH_pl    (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GZX        (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GZX_pl     (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GZY        (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GZY_pl     (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GZZ        (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GZZ_pl     (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGAM       (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGAM_pl    (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGAMH      (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGAMH_pl   (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GAM2       (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GAM2_pl    (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGAM2      (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGAM2_pl   (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_GAM2H      (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_GAM2H_pl   (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGAM2H     (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGAM2H_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_RGSH       (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_RGSH_pl    (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_VOLUME     (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_VOLUME_pl  (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_PHI        (ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_PHI_pl     (ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    allocate( VMTR_C2Wfact   (6,ADM_gall,   ADM_kall,ADM_lall   ) )
    allocate( VMTR_C2Wfact_pl(6,ADM_gall_pl,ADM_kall,ADM_lall_pl) )

    !--- if 1 layer model( shallow water model ),
    if ( ADM_kall == ADM_KNONE ) then

       VMTR_VOLUME   (:,:,:) = GMTR_P_var   (:,:,:,GMTR_P_AREA)
       VMTR_VOLUME_pl(:,:,:) = GMTR_P_var_pl(:,:,:,GMTR_P_AREA)

       return
    endif

    var   (:,:,:,:) = 0.D0
    var_pl(:,:,:,:) = 0.D0

    if ( trim(GRD_grid_type) == 'ON_PLANE' ) then
!       --- calculation of Jxh, Jyh, and Jzh
!       call OPRT_PLANE_gradient( var   (:,:,:,JXH),   & !--- [OUT]
!                                 var   (:,:,:,JYH),   & !--- [OUT]
!                                 GRD_vz(:,:,:,GRD_ZH) ) !--- [IN]
!       --- calculation of Jx, Jy, and Jz
!       call OPRT_PLANE_gradient( var   (:,:,:,JX),   & !--- [OUT]
!                                 var   (:,:,:,JY),   & !--- [OUT]
!                                 GRD_vz(:,:,:,GRD_Z) ) !--- [IN]
    else
       !--- calculation of Jxh, Jyh, and Jzh
       call OPRT_gradient( var(:,:,:,JXH),       var_pl(:,:,:,JXH),      & !--- [OUT]
                           var(:,:,:,JYH),       var_pl(:,:,:,JYH),      & !--- [OUT]
                           var(:,:,:,JZH),       var_pl(:,:,:,JZH),      & !--- [OUT]
                           GRD_vz(:,:,:,GRD_ZH), GRD_vz_pl(:,:,:,GRD_ZH) ) !--- [IN]

       call OPRT_horizontalize_vec( var(:,:,:,JXH), var_pl(:,:,:,JXH), & !--- [INOUT]
                                    var(:,:,:,JYH), var_pl(:,:,:,JYH), & !--- [INOUT]
                                    var(:,:,:,JZH), var_pl(:,:,:,JZH)  ) !--- [INOUT]
       !--- calculation of Jx, Jy, and Jz
       call OPRT_gradient( var(:,:,:,JX),       var_pl(:,:,:,JX),      & !--- [OUT]
                           var(:,:,:,JY),       var_pl(:,:,:,JY),      & !--- [OUT]
                           var(:,:,:,JZ),       var_pl(:,:,:,JZ),      & !--- [OUT]
                           GRD_vz(:,:,:,GRD_Z), GRD_vz_pl(:,:,:,GRD_Z) ) !--- [IN]

       call OPRT_horizontalize_vec( var(:,:,:,JX), var_pl(:,:,:,JX), & !--- [INOUT]
                                    var(:,:,:,JY), var_pl(:,:,:,JY), & !--- [INOUT]
                                    var(:,:,:,JZ), var_pl(:,:,:,JZ)  ) !--- [INOUT]
    endif

    !--- fill HALO
    call COMM_data_transfer( var, var_pl )
    var(suf(1,ADM_gall_1d),:,:,:) = var(suf(ADM_gmin,ADM_gmin),:,:,:)
    var(suf(ADM_gall_1d,1),:,:,:) = var(suf(ADM_gmin,ADM_gmin),:,:,:)

    do l = 1, ADM_lall

       !--- calculation of G^{1/2} at integer points
       !---   G^{1/2} = dz/dgz
       do k = ADM_kmin, ADM_kmax
       do n = 1, ADM_gall
          GSQRT(n,k) = ( GRD_vz(n,k+1,l,GRD_ZH) - GRD_vz(n,k,l,GRD_ZH) ) / GRD_dgz(k)
       enddo
       enddo
       do n = 1, ADM_gall
          GSQRT(n,ADM_kmin-1) = GSQRT(n,ADM_kmin)
          GSQRT(n,ADM_kmax+1) = GSQRT(n,ADM_kmax)
       enddo

       !--- calculation of G^{1/2} at half points
       do k = ADM_kmin, ADM_kmax+1
       do n = 1, ADM_gall
          GSQRTH(n,k) = ( GRD_vz(n,k,l,GRD_Z) - GRD_vz(n,k-1,l,GRD_Z) ) / GRD_dgzh(k)
       enddo
       enddo
       do n = 1, ADM_gall
          GSQRTH(n,ADM_kmin-1) = GSQRTH(n,ADM_kmin)
       enddo

       if ( deep ) then
          do k = 1, ADM_kall
          do n = 1, ADM_gall
             !--- calculation gamma at integer/half points
             GAM  = 1.D0 + GRD_vz(n,k,l,GRD_Z)  / CNST_ERADIUS
             GAMH = 1.D0 + GRD_vz(n,k,l,GRD_ZH) / CNST_ERADIUS

             VMTR_GSGAMH  (n,k,l) = GSQRTH(n,k) * GAMH

             VMTR_GAM2    (n,k,l) = GAM  * GAM
             VMTR_GAM2H   (n,k,l) = GAMH * GAMH

             VMTR_GSGAM2  (n,k,l) = GSQRT (n,k) * GAM  * GAM
             VMTR_GSGAM2H (n,k,l) = GSQRTH(n,k) * GAMH * GAMH

             VMTR_RGSH    (n,k,l) = 1.D0 / GSQRTH(n,k)
             VMTR_RGAM    (n,k,l) = 1.D0 / GAM
             VMTR_RGAMH   (n,k,l) = 1.D0 / GAMH
             VMTR_RGAM2   (n,k,l) = 1.D0 / VMTR_GAM2   (n,k,l)
             VMTR_RGAM2H  (n,k,l) = 1.D0 / VMTR_GAM2H  (n,k,l)
             VMTR_RGSGAM2 (n,k,l) = 1.D0 / VMTR_GSGAM2 (n,k,l)
             VMTR_RGSGAM2H(n,k,l) = 1.D0 / VMTR_GSGAM2H(n,k,l)
          enddo
          enddo
       else
          do k = 1, ADM_kall
          do n = 1, ADM_gall
             ! GAM  = 1.D0
             ! GAMH = 1.D0

             VMTR_GSGAMH  (n,k,l) = GSQRTH(n,k)

             VMTR_GAM2    (n,k,l) = 1.D0
             VMTR_GAM2H   (n,k,l) = 1.D0

             VMTR_GSGAM2  (n,k,l) = GSQRT (n,k)
             VMTR_GSGAM2H (n,k,l) = GSQRTH(n,k)

             VMTR_RGSH    (n,k,l) = 1.D0 / GSQRTH(n,k)
             VMTR_RGAM    (n,k,l) = 1.D0
             VMTR_RGAMH   (n,k,l) = 1.D0
             VMTR_RGAM2   (n,k,l) = 1.D0
             VMTR_RGAM2H  (n,k,l) = 1.D0
             VMTR_RGSGAM2 (n,k,l) = 1.D0 / GSQRT (n,k)
             VMTR_RGSGAM2H(n,k,l) = 1.D0 / GSQRTH(n,k)
          enddo
          enddo
       endif

       do k = 1, ADM_kall
       do n = 1, ADM_gall
          !--- calculation of GZ at half points
          !---    GZX = - JX / G^{1/2}
          !---    GZY = - JY / G^{1/2}
          !---    GZZ = - JZ / G^{1/2}
          VMTR_GZXH(n,k,l) = -var(n,k,l,JXH) / GSQRTH(n,k)
          VMTR_GZYH(n,k,l) = -var(n,k,l,JYH) / GSQRTH(n,k)
          VMTR_GZZH(n,k,l) = -var(n,k,l,JZH) / GSQRTH(n,k)
          !--- calculation of GZ at full points
          VMTR_GZX (n,k,l) = -var(n,k,l,JX)  / GSQRT (n,k)
          VMTR_GZY (n,k,l) = -var(n,k,l,JY)  / GSQRT (n,k)
          VMTR_GZZ (n,k,l) = -var(n,k,l,JZ)  / GSQRT (n,k)

          !--- calculation of volume
          VMTR_VOLUME(n,k,l) = GMTR_P_var(n,ADM_KNONE,l,GMTR_P_AREA) &
                             * VMTR_GSGAM2(n,k,l)                    &
                             * GRD_dgz(k)

          !--- calculation of geopotential
          VMTR_PHI(n,k,l) = GRD_vz(n,k,l,GRD_Z) * CNST_EGRAV
       enddo
       enddo

       do k = ADM_kmin, ADM_kall
       do n = 1, ADM_gall
          !--- calculation of factor for integer to half integer level with Gz
          VMTR_C2Wfact(I_a_GZXH,n,k,l) = 0.5D0 * GRD_afac(k) / VMTR_GSGAM2(n,k  ,l) * VMTR_GSGAM2H(n,k,l) &
                                       * VMTR_GZXH(n,k,l)
          VMTR_C2Wfact(I_b_GZXH,n,k,l) = 0.5D0 * GRD_bfac(k) / VMTR_GSGAM2(n,k-1,l) * VMTR_GSGAM2H(n,k,l) &
                                       * VMTR_GZXH(n,k,l)
          VMTR_C2Wfact(I_a_GZYH,n,k,l) = 0.5D0 * GRD_afac(k) / VMTR_GSGAM2(n,k  ,l) * VMTR_GSGAM2H(n,k,l) &
                                       * VMTR_GZYH(n,k,l)
          VMTR_C2Wfact(I_b_GZYH,n,k,l) = 0.5D0 * GRD_bfac(k) / VMTR_GSGAM2(n,k-1,l) * VMTR_GSGAM2H(n,k,l) &
                                       * VMTR_GZYH(n,k,l)
          VMTR_C2Wfact(I_a_GZZH,n,k,l) = 0.5D0 * GRD_afac(k) / VMTR_GSGAM2(n,k  ,l) * VMTR_GSGAM2H(n,k,l) &
                                       * VMTR_GZZH(n,k,l)
          VMTR_C2Wfact(I_b_GZZH,n,k,l) = 0.5D0 * GRD_bfac(k) / VMTR_GSGAM2(n,k-1,l) * VMTR_GSGAM2H(n,k,l) &
                                       * VMTR_GZZH(n,k,l)
       enddo
       enddo
    enddo

    if ( ADM_prc_me == ADM_prc_pl ) then
       do l = 1, ADM_lall_pl

       !--- calculation of G^{1/2} at integer points
       !---   G^{1/2} = dz/dgz
       do k = ADM_kmin, ADM_kmax
       do n = 1, ADM_gall_pl
          GSQRT_pl(n,k) = ( GRD_vz_pl(n,k+1,l,GRD_ZH) - GRD_vz_pl(n,k,l,GRD_ZH) ) / GRD_dgz(k)
       enddo
       enddo
       do n = 1, ADM_gall_pl
          GSQRT_pl(n,ADM_kmin-1) = GSQRT_pl(n,ADM_kmin)
          GSQRT_pl(n,ADM_kmax+1) = GSQRT_pl(n,ADM_kmax)
       enddo

       !--- calculation of G^{1/2} at half points
       do k = ADM_kmin, ADM_kmax+1
       do n = 1, ADM_gall_pl
          GSQRTH_pl(n,k) = ( GRD_vz_pl(n,k,l,GRD_Z) - GRD_vz_pl(n,k-1,l,GRD_Z) ) / GRD_dgzh(k)
       enddo
       enddo
       do n = 1, ADM_gall_pl
          GSQRTH_pl(n,ADM_kmin-1) = GSQRTH_pl(n,ADM_kmin)
       enddo

       if ( deep ) then
          do k = 1, ADM_kall
          do n = 1, ADM_gall_pl
             !--- calculation gamma at integer/half points
             GAM  = 1.D0 + GRD_vz_pl(n,k,l,GRD_Z)  / CNST_ERADIUS
             GAMH = 1.D0 + GRD_vz_pl(n,k,l,GRD_ZH) / CNST_ERADIUS

             VMTR_GSGAMH_pl  (n,k,l) = GSQRTH(n,k) * GAMH

             VMTR_GAM2_pl    (n,k,l) = GAM  * GAM
             VMTR_GAM2H_pl   (n,k,l) = GAMH * GAMH

             VMTR_GSGAM2_pl  (n,k,l) = GSQRT_pl (n,k) * GAM  * GAM
             VMTR_GSGAM2H_pl (n,k,l) = GSQRTH_pl(n,k) * GAMH * GAMH

             VMTR_RGSH_pl    (n,k,l) = 1.D0 / GSQRTH_pl(n,k)
             VMTR_RGAM_pl    (n,k,l) = 1.D0 / GAM
             VMTR_RGAMH_pl   (n,k,l) = 1.D0 / GAMH
             VMTR_RGAM2_pl   (n,k,l) = 1.D0 / VMTR_GAM2_pl (n,k,l)
             VMTR_RGAM2H_pl  (n,k,l) = 1.D0 / VMTR_GAM2H_pl(n,k,l)
             VMTR_RGSGAM2_pl (n,k,l) = 1.D0 / VMTR_GSGAM2_pl (n,k,l)
             VMTR_RGSGAM2H_pl(n,k,l) = 1.D0 / VMTR_GSGAM2H_pl(n,k,l)
          enddo
          enddo
       else
          do k = 1, ADM_kall
          do n = 1, ADM_gall_pl
             ! GAM  = 1.D0
             ! GAMH = 1.D0

             VMTR_GSGAMH_pl  (n,k,l) = GSQRTH_pl(n,k)

             VMTR_GAM2_pl    (n,k,l) = 1.D0
             VMTR_GAM2H_pl   (n,k,l) = 1.D0

             VMTR_GSGAM2_pl  (n,k,l) = GSQRT_pl (n,k)
             VMTR_GSGAM2H_pl (n,k,l) = GSQRTH_pl(n,k)

             VMTR_RGSH_pl    (n,k,l) = 1.D0 / GSQRTH_pl(n,k)
             VMTR_RGAM_pl    (n,k,l) = 1.D0
             VMTR_RGAMH_pl   (n,k,l) = 1.D0
             VMTR_RGAM2_pl   (n,k,l) = 1.D0
             VMTR_RGAM2H_pl  (n,k,l) = 1.D0
             VMTR_RGSGAM2_pl (n,k,l) = 1.D0 / GSQRT_pl (n,k)
             VMTR_RGSGAM2H_pl(n,k,l) = 1.D0 / GSQRTH_pl(n,k)
          enddo
          enddo
       endif

       do k = 1, ADM_kall
       do n = 1, ADM_gall_pl
          !--- calculation of GZ at half points
          !---    GZX = - JX / G^{1/2}
          !---    GZY = - JY / G^{1/2}
          !---    GZZ = - JZ / G^{1/2}
          VMTR_GZXH_pl(n,k,l) = -var_pl(n,k,l,JXH) / GSQRTH_pl(n,k)
          VMTR_GZYH_pl(n,k,l) = -var_pl(n,k,l,JYH) / GSQRTH_pl(n,k)
          VMTR_GZZH_pl(n,k,l) = -var_pl(n,k,l,JZH) / GSQRTH_pl(n,k)
          !--- calculation of GZ at full points
          VMTR_GZX_pl (n,k,l) = -var_pl(n,k,l,JX)  / GSQRT_pl (n,k)
          VMTR_GZY_pl (n,k,l) = -var_pl(n,k,l,JY)  / GSQRT_pl (n,k)
          VMTR_GZZ_pl (n,k,l) = -var_pl(n,k,l,JZ)  / GSQRT_pl (n,k)

          !--- calculation of volume
          VMTR_VOLUME_pl(n,k,l) = GMTR_P_var_pl(n,ADM_KNONE,l,GMTR_P_AREA) &
                                * VMTR_GSGAM2_pl(n,k,l)                    &
                                * GRD_dgz(k)

          !--- calculation of geopotential
          VMTR_PHI_pl(n,k,l) = GRD_vz_pl(n,k,l,GRD_Z) * CNST_EGRAV
       enddo
       enddo

       do k = ADM_kmin, ADM_kall
       do n = 1, ADM_gall_pl
          VMTR_C2Wfact_pl(I_a_GZXH,n,k,l) = 0.5D0 * GRD_afac(k) &
                                          * VMTR_GSGAM2H_pl(n,k,l) / VMTR_GSGAM2_pl(n,k  ,l) * VMTR_GZXH_pl(n,k,l)
          VMTR_C2Wfact_pl(I_b_GZXH,n,k,l) = 0.5D0 * GRD_bfac(k) &
                                          * VMTR_GSGAM2H_pl(n,k,l) / VMTR_GSGAM2_pl(n,k-1,l) * VMTR_GZXH_pl(n,k,l)
          VMTR_C2Wfact_pl(I_a_GZYH,n,k,l) = 0.5D0 * GRD_afac(k) &
                                          * VMTR_GSGAM2H_pl(n,k,l) / VMTR_GSGAM2_pl(n,k  ,l) * VMTR_GZYH_pl(n,k,l)
          VMTR_C2Wfact_pl(I_b_GZYH,n,k,l) = 0.5D0 * GRD_bfac(k) &
                                          * VMTR_GSGAM2H_pl(n,k,l) / VMTR_GSGAM2_pl(n,k-1,l) * VMTR_GZYH_pl(n,k,l)
          VMTR_C2Wfact_pl(I_a_GZZH,n,k,l) = 0.5D0 * GRD_afac(k) &
                                          * VMTR_GSGAM2H_pl(n,k,l) / VMTR_GSGAM2_pl(n,k  ,l) * VMTR_GZZH_pl(n,k,l)
          VMTR_C2Wfact_pl(I_b_GZZH,n,k,l) = 0.5D0 * GRD_bfac(k) &
                                          * VMTR_GSGAM2H_pl(n,k,l) / VMTR_GSGAM2_pl(n,k-1,l) * VMTR_GZZH_pl(n,k,l)
       enddo
       enddo

       enddo
    endif

    return
  end subroutine VMTR_setup

end module mod_vmtr
!-------------------------------------------------------------------------------


!==============================================================================
!
! MODULE: CalcStatTransTemp
!
!   SUBROUTINE: Calc_StatTransTemp()
!
!
! Created by Y.Tahara in Oct,02
!
!==============================================================================

module CalcStatTransTemp

  !--- modules

  use type_kinds, only : fp_kind
  use ParametersGenCoef
  use Utilities_Statistics

  !--- implicit

  implicit none

  !--- public & private

  Private

  Public  Calc_StatTransTemp
  Public  StatTbTau

  !--- type of statistics variable

  type StatTbTau
    real(fp_kind) :: index              ! index for atmos predictor set selection
    real(fp_kind) :: residual           ! regression residual

    real(fp_kind) :: tbmean             ! Tb mean error against LBL over profiles and angles
    real(fp_kind) :: tbsderr            ! Tb S.D. error
    real(fp_kind) :: tbrmse             ! Tb RMS error
    real(fp_kind) :: tbmaxerr           ! max Tb error of all profiles and angles

    real(fp_kind) :: taumean            ! total trans mean error against LBL over profiles, angles and layers
    real(fp_kind) :: tausderr           ! total trans S.D. error
    real(fp_kind) :: taurmse            ! total trans RMS error
    real(fp_kind) :: taumaxerr          ! max total trans error of all profiles and angles

    real(fp_kind) :: taumaxmean         ! max total trans mean error against LBL over layers of all profiles and angles
    real(fp_kind) :: taumaxsderr        ! max total trans S.D. error
    real(fp_kind) :: taumaxrmse         ! max total trans RMS error

    real(fp_kind) :: maxpredterm        ! max predictor term
  end type StatTbTau

 contains

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: Calc_StatTransTemp()
  !
  !   Calc_StatTransTemp() calculates the statistics of predicted
  !   transmittances and brightness temperatures against LBL.
  !
  !--------------------------------------------------------------------------

  subroutine Calc_StatTransTemp( &
                        alltrans_lev,    tb_lbl, &
                        calalltrans_lev, tb_cal, &
                        stat                     )

    !--- interface

    real(fp_kind)  ,intent(in)  :: alltrans_lev (0:Nlay,Nangle,Natm)    ! LBL total trans
    real(fp_kind)  ,intent(in)  :: tb_lbl(Nangle,Natm)                  ! LBL Tb
    real(fp_kind)  ,intent(in)  :: calalltrans_lev(0:Nlay,Nangle,Natm)  ! predicted total trans
    real(fp_kind)  ,intent(in)  :: tb_cal(Nangle,Natm)                  ! predicted Tb
    type(StatTbTau),intent(out) :: stat                                 ! statistics

    !--- local variables

    real(fp_kind)     :: erralltrans_lev
    type(StatResults) :: stat0
    integer           :: Ndata
    real(fp_kind)     :: taumaxmean, taumaxabsmean
    real(fp_kind)     :: taumaxsderr
    real(fp_kind)     :: taumaxrmse

    integer           :: Iang, Iatm, Ilev

    !--- init stat heep

    call InitStat( 2 + Nangle * Natm )

    !--- calc stat for Tb

    do Iatm = 1, Natm
    do Iang = 1, Nangle
      call AddStat( 1, (tb_cal(Iang,Iatm) - tb_lbl(Iang,Iatm)), ZERO )
    enddo
    enddo

    call CalcStat( 1, Ndata, stat0 )

    stat%tbmean   = stat0%meanerr
    stat%tbsderr  = stat0%sderr
    stat%tbrmse   = stat0%rmse
    stat%tbmaxerr = max( abs( stat0%max1 ), abs( stat0%min1 ) )

    !--- calc stat for trans

    taumaxabsmean = ZERO
    taumaxsderr   = ZERO
    taumaxrmse    = ZERO

    do Iatm = 1, Natm
    do Iang = 1, Nangle

      do Ilev = 1, Nlay

        if( alltrans_lev(Ilev,Iang,Iatm) < Threshold_TransFitTest )then
          cycle
        endif

        erralltrans_lev = calalltrans_lev(Ilev,Iang,Iatm) - alltrans_lev(Ilev,Iang,Iatm)

        call AddStat( 2,                              erralltrans_lev, ZERO )
        call AddStat( 2 + Iang + (Iatm - 1) * Nangle, erralltrans_lev, ZERO )

      enddo

      call CalcStat( 2 + Iang + (Iatm - 1) * Nangle, Ndata, stat0 )

      if( abs(stat0%meanerr) > taumaxabsmean )then
        taumaxmean    =     stat0%meanerr
        taumaxabsmean = abs(stat0%meanerr)
      endif

      taumaxsderr = max( stat0%sderr, taumaxsderr )
      taumaxrmse  = max( stat0%rmse,  taumaxrmse  )

    enddo
    enddo

    stat%taumaxmean  = taumaxmean
    stat%taumaxsderr = taumaxsderr
    stat%taumaxrmse  = taumaxrmse

    call CalcStat( 2, Ndata, stat0 )

    stat%taumean   = stat0%meanerr
    stat%tausderr  = stat0%sderr
    stat%taurmse   = stat0%rmse
    stat%taumaxerr = max( abs( stat0%max1 ), abs( stat0%min1 ) )

    !--- set index for predictor set selection

!    stat%index = stat%taurmse
    stat%index = stat%tbrmse

  end subroutine Calc_StatTransTemp

end module CalcStatTransTemp


	SUBROUTINE MT_PTEN ( stpten, iret )
C************************************************************************
C* MT_PTEN							        *
C*								        *
C* This subroutine will decode the characteristic and amount of the	*
C* 3-hourly pressure tendency.  The result is saved in common.		*
C*								        *
C* MT_PTEN ( STPTEN, IRET )				       	        *
C*								        *
C* Input parameters:						        *
C*	STPTEN		CHAR*		Pressure tendency string	*
C*								        *
C* Output parameters:						        *
C*      RIVALS(IRP03D)  REAL            3 hour pressure tendency (hPa)  *
C*	IRET		INTEGER		Return code		        *
C*					   0 = normal return 	        *
C*					  22 = decode error 	        *
C**								        *
C* Log:									*
C* D. Kidwell/NCEP	11/95	Original author		                *
C* K. Tyle/GSC	 	 1/97	Use PR_P03D; reorganize hdr & comments  *
C* K. Tyle/GSC		 2/97	Change error processing			*
C* D. Kidwell/NCEP       4/98   New interface                           *
C* D. Kidwell/NCEP       3/00   Ensure that string is all numeric       *
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
	INCLUDE 	'mtcmn.cmn'
C*
	CHARACTER*(*)	stpten
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
	CALL ST_INTG ( stpten ( 2:5 ), intg, ier )
	IF ( ier .eq. 0 ) THEN
C
            pten = PR_P03D ( stpten ( 2:5 ) )
            IF ( ERMISS ( pten ) ) THEN
	        iret = 22
              ELSE
	        rivals ( irp03d ) = pten
	    END IF
	  ELSE
	    iret = 22
	END IF
C*
	RETURN
	END


! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

module mod_polyhedra
  !! author: MDG
  !! version: 1.0
  !! date: 07/27/21
  !!
  !! class definition for a 3D polyhedral shape (general)
  !!
  !! This class can be used to initialize a 3D polyhedron shape, compute surface area
  !! and volume using the 3D Projective Geometric Algebra module.  This module also
  !! provides a method to compute the shape amplitude using Komrska's formula or provides
  !! the shape function. The 5 Platonic and 13 Archimedian solids are available in the resources/ShapeFiles
  !! folder and can be initialized directly; other shapes can be defined in the same
  !! text file format:
  !!
  !! cube                           <- a generic shape name
  !! vertex coordinates             <- starts the block of vertex coordinates
  !! 8                              <- number of vertices
  !!  0.5D0,-0.5D0,-0.5D0           <- x, y, z vertex coordinates in double precision
  !!  0.5D0, 0.5D0,-0.5D0
  !!  0.5D0, 0.5D0, 0.5D0
  !!  0.5D0,-0.5D0, 0.5D0
  !! -0.5D0,-0.5D0,-0.5D0
  !! -0.5D0, 0.5D0,-0.5D0
  !! -0.5D0, 0.5D0, 0.5D0
  !! -0.5D0,-0.5D0, 0.5D0
  !! vertices per face              <- starts the block of face descriptions
  !! 6                              <- number of faces
  !! 4, 1,2,3,4                     <- # vertices, followed by the vertex labels
  !! 4, 1,5,6,2                        using a counterclockwise winding
  !! 4, 2,6,7,3
  !! 4, 3,7,8,4
  !! 4, 1,4,8,5
  !! 4, 5,8,7,6
  !!
  !! The faces MUST have the correct winding orientation in order for the
  !! PGA3D routines to correctly generate the shape (and distinguish inside
  !! from outside).
  !!

use mod_kinds
use mod_global
use mod_PGA3D
use mod_PGA3Dsupport

IMPLICIT NONE

type, public :: face_T
  integer(kind=irg)               :: nv             ! number of vertices
  integer(kind=irg),allocatable   :: verts(:)       ! vertex indices
  real(kind=dbl),allocatable      :: edgeL(:)       ! edge lengths
  real(kind=dbl)                  :: area           ! face area
  real(kind=dbl)                  :: dorigin        ! shortest distance to origin
  integer(kind=irg),allocatable   :: otherface(:)   ! adjoining face for each edge
  type(PGA3D_T)                   :: fmv            ! face multivector
  type(PGA3D_T), allocatable      :: edgecenter(:)  ! edge center multivector
  type(PGA3D_T), allocatable      :: edge(:)        ! edge multivector
  type(PGA3D_T), allocatable      :: edgenormal(:)  ! unit normal to edge lying in face
end type face_T

! class definition
type, public :: polyhedron_T
private
  integer(kind=irg)               :: nvertices
  integer(kind=irg)               :: nfaces
  integer(kind=irg)               :: nedges
  type(face_T),allocatable        :: faces(:)
  type(PGA3D_T), allocatable      :: face(:)
  type(PGA3D_T), allocatable      :: facecenter(:)
  type(PGA3D_T), allocatable      :: vertex(:)
  type(PGA3D_T), allocatable      :: facenormal(:)
  real(kind=dbl)                  :: area
  real(kind=dbl)                  :: volume
  character(fnlen)                :: shapename
  character(fnlen)                :: shapefile

contains
private
  procedure, pass(self) :: get_nvertices_
  procedure, pass(self) :: get_nfaces_
  procedure, pass(self) :: get_nedges_
  procedure, pass(self) :: get_area_
  procedure, pass(self) :: get_volume_
  procedure, pass(self) :: get_shapename_
  procedure, pass(self) :: get_shapefile_
  procedure, pass(self) :: set_nvertices_
  procedure, pass(self) :: set_nfaces_
  procedure, pass(self) :: set_nedges_
  procedure, pass(self) :: set_area_
  procedure, pass(self) :: set_volume_
  procedure, pass(self) :: set_shapename_
  procedure, pass(self) :: set_shapefile_
  procedure, pass(self) :: polyhedron_init_
  procedure, pass(self) :: polyhedron_info_
  procedure, pass(self) :: build_polyhedron_
  procedure, pass(self) :: polyhedron_shapefunction_
  procedure, pass(self) :: polyhedron_shapeamplitude_

  generic, public :: get_nvertices => get_nvertices_
  generic, public :: get_nfaces => get_nfaces_
  generic, public :: get_nedges => get_nedges_
  generic, public :: get_area => get_area_
  generic, public :: get_volume => get_volume_
  generic, public :: get_shapename => get_shapename_
  generic, public :: get_shapefile => get_shapefile_
  generic, public :: set_nvertices => set_nvertices_
  generic, public :: set_nfaces => set_nfaces_
  generic, public :: set_nedges => set_nedges_
  generic, public :: set_area => set_area_
  generic, public :: set_volume => set_volume_
  generic, public :: set_shapename => set_shapename_
  generic, public :: set_shapefile => set_shapefile_
  generic, public :: initialize_polyhedron => polyhedron_init_
  generic, public :: polyhedron_info => polyhedron_info_
  generic, public :: build_polyhedron => build_polyhedron_
  generic, public :: polyhedron_shapefunction => polyhedron_shapefunction_
  generic, public :: polyhedron_shapeamplitude => polyhedron_shapeamplitude_

end type polyhedron_T

! the constructor routine for this class
interface polyhedron_T
  module procedure polyhedron_constructor
end interface polyhedron_T

contains

!--------------------------------------------------------------------------
type(polyhedron_T) function polyhedron_constructor( shapename, Ledge, shapefile ) result(shape)
!DEC$ ATTRIBUTES DLLEXPORT :: polyhedron_constructor
!! author: MDG
!! version: 1.0
!! date: 07/27/21
!!
!! constructor for the polyhedron_T Class; reads the name list

IMPLICIT NONE

character(fnlen), INTENT(IN)            :: shapename
real(kind=dbl),INTENT(IN)               :: Ledge
character(fnlen), INTENT(IN),OPTIONAL   :: shapefile

if (present(shapefile)) then
  call shape%polyhedron_init_( shapename, Ledge, shapefile )
else
  call shape%polyhedron_init_( shapename, Ledge )
end if

end function polyhedron_constructor

!--------------------------------------------------------------------------
subroutine polyhedron_destructor(self)
!DEC$ ATTRIBUTES DLLEXPORT :: polyhedron_destructor
!! author: MDG
!! version: 1.0
!! date: 07/27/21
!!
!! destructor for the polyhedron_T Class

IMPLICIT NONE

type(polyhedron_T), INTENT(INOUT)  :: self

call reportDestructor('polyhedron_T')

end subroutine polyhedron_destructor

!--------------------------------------------------------------------------
function get_nvertices_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_nvertices_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get nvertices from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
integer(kind=irg)                      :: out

out = self%nvertices

end function get_nvertices_

!--------------------------------------------------------------------------
subroutine set_nvertices_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_nvertices_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set nvertices in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
integer(kind=irg), INTENT(IN)          :: inp

self%nvertices = inp

end subroutine set_nvertices_

!--------------------------------------------------------------------------
function get_nfaces_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_nfaces_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get nfaces from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
integer(kind=irg)                      :: out

out = self%nfaces

end function get_nfaces_

!--------------------------------------------------------------------------
subroutine set_nfaces_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_nfaces_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set nfaces in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
integer(kind=irg), INTENT(IN)          :: inp

self%nfaces = inp

end subroutine set_nfaces_

!--------------------------------------------------------------------------
function get_nedges_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_nedges_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get nedges from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
integer(kind=irg)                      :: out

out = self%nedges

end function get_nedges_

!--------------------------------------------------------------------------
subroutine set_nedges_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_nedges_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set nedges in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
integer(kind=irg), INTENT(IN)          :: inp

self%nedges = inp

end subroutine set_nedges_

!--------------------------------------------------------------------------
function get_area_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_area_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get area from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
real(kind=dbl)                         :: out

out = self%area

end function get_area_

!--------------------------------------------------------------------------
subroutine set_area_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_area_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set area in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
real(kind=dbl), INTENT(IN)             :: inp

self%area = inp

end subroutine set_area_

!--------------------------------------------------------------------------
function get_volume_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_volume_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get volume from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
real(kind=dbl)                         :: out

out = self%volume

end function get_volume_

!--------------------------------------------------------------------------
subroutine set_volume_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_volume_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set volume in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
real(kind=dbl), INTENT(IN)             :: inp

self%volume = inp

end subroutine set_volume_

!--------------------------------------------------------------------------
function get_shapename_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_shapename_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get shapename from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
character(fnlen)                       :: out

out = self%shapename

end function get_shapename_

!--------------------------------------------------------------------------
subroutine set_shapename_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_shapename_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set shapename in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
character(fnlen), INTENT(IN)           :: inp

self%shapename = inp

end subroutine set_shapename_

!--------------------------------------------------------------------------
function get_shapefile_(self) result(out)
!DEC$ ATTRIBUTES DLLEXPORT :: get_shapefile_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! get shapefile from the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
character(fnlen)                       :: out

out = self%shapefile

end function get_shapefile_

!--------------------------------------------------------------------------
subroutine set_shapefile_(self,inp)
!DEC$ ATTRIBUTES DLLEXPORT :: set_shapefile_
!! author: MDG
!! version: 1.0
!! date: 08/13/21
!!
!! set shapefile in the polyhedron_T class

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)     :: self
character(fnlen), INTENT(IN)           :: inp

self%shapefile = inp

end subroutine set_shapefile_

!--------------------------------------------------------------------------
subroutine polyhedron_info_( self )
!DEC$ ATTRIBUTES DLLEXPORT :: polyhedron_info_
!! author: MDG
!! version: 1.0
!! date: 07/27/21
!!
!! print information about the shape
!!

use mod_IO

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)  :: self

type(IO_T)                          :: Message
integer(kind=irg)                   :: io_int(20), i, j
real(kind=dbl)                      :: io_real(10), L
type(PGA3D_T)                       :: mv

mv = self%vertex(self%faces(1)%verts(1)).vee.self%vertex(self%faces(1)%verts(2))
L = mv%norm()

call Message%printMessage(' Shape Name : '//trim(self%shapename))
call Message%printMessage(' Shape File : '//trim(self%shapefile),frm="(A/)")

io_int(1) = self%nvertices
call Message%WriteValue(' # vertices  : ', io_int, 1)
io_int(1) = self%nfaces
call Message%WriteValue(' # faces     : ', io_int, 1)
io_int(1) = self%nedges
call Message%WriteValue(' # edges     : ', io_int, 1)
io_int(1) = self%nvertices + self%nfaces - self%nedges
call Message%WriteValue(' V+F-E (should be 2) ', io_int, 1, frm="(I3/)")
io_real(1) = L
call Message%WriteValue(' Edge length : ', io_real, 1)
io_real(1:2) = (/ self%area, self%volume /)
call Message%WriteValue(' Area/Volume : ', io_real, 2)
io_real(1:2) = (/ self%area/L**2, self%volume/L**3 /)
call Message%WriteValue('   for L=1   : ', io_real, 2)

call Message%printMessage('')

call Message%printMessage('Vertex tri-vectors:',frm="(/A)")
do i=1,self%nvertices
  call self%vertex(i)%log()
end do

call Message%printMessage('Edge bi-vectors:',frm="(/A)")
do i=1,self%nfaces
  do j=1,self%faces(i)%nv
    call self%faces(i)%edge(j)%log()
  end do
end do

call Message%printMessage('Edge center tri-vectors:',frm="(/A)")
do i=1,self%nfaces
  do j=1,self%faces(i)%nv
    call self%faces(i)%edgecenter(j)%log()
  end do
end do

call Message%printMessage('Face vectors:',frm="(/A)")
do i=1,self%nfaces
  call self%faces(i)%fmv%log()
end do

call Message%printMessage('Face center vectors:',frm="(/A)")
do i=1,self%nfaces
  call self%facecenter(i)%log()
end do

call Message%printMessage('Face normal vectors:',frm="(/A)")
do i=1,self%nfaces
  ! mv = self%face(i) * E0123
  ! mv = mv.muls.(1.D0/mv%inorm())
  mv = self%facenormal(i)
  ! mv = mv.muls.(1.D0/mv%inorm())
  call mv%log()
end do

call Message%printMessage('Face edge normal bi-vectors:',frm="(/A)")
do i=1,self%nfaces
  do j=1,self%faces(i)%nv
    call self%faces(i)%edgenormal(j)%log()
  end do
end do

call Message%printMessage('Face areas & distance to origin :',frm="(/A)")
do i=1,self%nfaces
  io_int(1) = i
  io_real(1:2) = (/ self%faces(i)%area*0.5D0, self%faces(i)%dorigin /)
  call Message%WriteValue(' ', io_int, 1, frm="(I3,$)")
  call Message%WriteValue(' ', io_real, 2)
end do

end subroutine polyhedron_info_

!--------------------------------------------------------------------------
subroutine build_polyhedron_( self, Ledge )
!DEC$ ATTRIBUTES DLLEXPORT :: build_polyhedron_
!! author: MDG
!! version: 1.0
!! date: 07/27/21
!!
!! build the shape parameters; to do this we use PGA3D commands

use mod_PGA3D
use mod_IO

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)    :: self
real(kind=dbl),INTENT(IN)             :: Ledge

integer(kind=irg)                     :: i, j, i1, i2, j1, j2, k1, k2, io_int(13)
real(kind=dbl)                        :: s, pp(3), x, y, z
character(5)                          :: str
type(PGA3D_T)                         :: mv, mv2, vsum, pt, lf
type(IO_T)                            :: Message

! first scale the vertices so that the first edge length of the first face equal Ledge
mv = self%vertex(self%faces(1)%verts(1)).vee.self%vertex(self%faces(1)%verts(2))
s = Ledge / mv%norm()   ! scale factor to apply to all vertices
do i=1,self%nvertices
  call getpoint(self%vertex(i), x, y, z)
  self%vertex(i) = point(x*s, y*s, z*s)
end do

! build all the edges and edge centers
do i=1,self%nfaces
  do j=1,self%faces(i)%nv
    i1 = self%faces(i)%verts(j)
    if (j.eq.self%faces(i)%nv) then
      i2 = self%faces(i)%verts(1)
    else
      i2 = self%faces(i)%verts(j+1)
    end if
    self%faces(i)%edge(j) = self%vertex(i1).vee.self%vertex(i2)
  end do
  do j=1,self%faces(i)%nv
    i1 = self%faces(i)%verts(j)
    if (j.eq.self%faces(i)%nv) then
      i2 = self%faces(i)%verts(1)
    else
      i2 = self%faces(i)%verts(j+1)
    end if
    self%faces(i)%edgecenter(j) = self%vertex(i1) + self%vertex(i2)
    self%faces(i)%edgecenter(j) = self%faces(i)%edgecenter(j).muls.0.5D0
  end do
end do

! build the face multivectors
do i=1,self%nfaces
  mv = self%vertex(self%faces(i)%verts(1)).vee.self%vertex(self%faces(i)%verts(2))
  self%faces(i)%fmv = mv.vee.self%vertex(self%faces(i)%verts(3))
  self%faces(i)%fmv = self%faces(i)%fmv.muls.(-1.D0)
end do

! find the face centers
do j=1,self%nfaces
  mv = self%vertex(self%faces(j)%verts(1))
  do i=2,self%faces(j)%nv
    mv = mv + self%vertex(self%faces(j)%verts(i))
  end do
  s = 1.D0/dble(self%faces(j)%nv)
  mv = mv.muls.s
  self%facecenter(j) = mv%normalized()
  mv2 = self%faces(j)%fmv.inner.self%facecenter(j)
  self%facenormal(j) = mv2%normalized()
  self%face(j) = mv2.inner.self%facecenter(j)
end do

! and we get the edge lengths, areas, and volume
self%area = 0.D0
self%volume = 0.D0
do i=1,self%nfaces
  self%faces(i)%area = 0.D0
  do j=1,self%faces(i)%nv
    i1 = self%faces(i)%verts(j)
    if (j.eq.self%faces(i)%nv) then
      i2 = self%faces(i)%verts(1)
    else
      i2 = self%faces(i)%verts(j+1)
    end if
    ! edge length
    mv = self%vertex(i1).vee.self%vertex(i2)
    self%faces(i)%edgeL(j) = mv%norm()

    ! unit normal to edge lying in the face
    ! lf is the plane normal to the face p and containg the edge line ell (p . ell)
    lf = self%faces(i)%fmv.inner.self%faces(i)%edge(j)
    ! the line normal to the plane lf and containing the vertex P (lf . P)
    self%faces(i)%edgenormal(j) = lf.inner.self%vertex(self%faces(i)%verts(j))
    self%faces(i)%edgenormal(j) = self%faces(i)%edgenormal(j)%normalized()

    ! volume contribution
    mv = self%vertex(i1).vee.self%vertex(i2).vee.self%facecenter(i)
    if ((i.eq.1).and.(j.eq.1)) then
      vsum = mv
    else
      vsum = vsum + mv
    end if

    ! area contribution
    self%faces(i)%area = self%faces(i)%area + mv%norm()
  end do
  ! get the closest distance from the face to the origin
  mv = self%face(i)%normalized()
  self%faces(i)%dorigin = mv%inorm()
end do
self%area = sum(self%faces(:)%area) /  2.D0
self%volume = vsum%getcomp(1) / 6.D0

! finally, for each edge in the self%faces structure, determine which other face it shares;
! this is a little tricky, since this edge will have the opposite orientation for the other face,
! assuming that the winding is consistent.  If any otherface number remains zero at the end, then there
! must be an error in the winding of at least one of the faces...
do i=1,self%nfaces
  self%faces(i)%otherface = 0
  do j=1,self%faces(i)%nv
    i1 = self%faces(i)%verts(j)
    if (j.eq.self%faces(i)%nv) then
      i2 = self%faces(i)%verts(1)
    else
      i2 = self%faces(i)%verts(j+1)
    end if
! (i1, i2) is an oriented edge; next we look for the edge (i2,i1) in all other faces
    do j1=1,self%nfaces
      do j2=1,self%faces(j1)%nv
        if ( (j1.ne.i).or.(j2.ne.j) ) then ! don't consider the current edge
          k1 = self%faces(j1)%verts(j2)
          if (j2.eq.self%faces(j1)%nv) then
            k2 = self%faces(j1)%verts(1)
          else
            k2 = self%faces(j1)%verts(j2+1)
          end if
          if ( (k1.eq.i2).and.(k2.eq.i1) ) then
            self%faces(i)%otherface(j) = j1
          end if
        end if
      end do
    end do
  end do
  ! io_int(1) = i
  ! io_int(2:self%faces(i)%nv+1) = self%faces(i)%otherface
  ! call Message%writeValue('',io_int,self%faces(i)%nv+1,frm="('face ',I3,' -> other faces ',12I3)")
end do

! test that the winding is consistent for all the faces
do i=1,self%nfaces
  if (minval(self%faces(i)%otherface).eq.0) then
    write (str,"(I5)") i
    call Message%printMessage('WARNING: face '//trim(str)//' has inconsistent winding !!! ')
  end if
end do

end subroutine build_polyhedron_

!--------------------------------------------------------------------------
subroutine polyhedron_init_( self, shapename, Ledge, shapefile )
!DEC$ ATTRIBUTES DLLEXPORT :: polyhedron_init_
!! author: MDG
!! version: 1.0
!! date: 07/27/21
!!
!! populate the class with shape information
!!
!! We use 3D Projective Geometric Algebra to compute the face normals, the total area
!! and the volume.  The routine then stores the parameters needed to compute the shape
!! amplitude using the Komrska formula.  A shape file must have the following format:
!!

use mod_EMsoft
use mod_IO

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)      :: self
character(fnlen), INTENT(IN)            :: shapename
real(kind=dbl),INTENT(IN)               :: Ledge        ! target edge length for first edge (allows for scaling)
character(fnlen), INTENT(IN),OPTIONAL   :: shapefile

type(EMsoft_T)                          :: EMsoft
type(IO_T)                              :: Message
type(PGA3D_T)                           :: pt

character(fnlen)                        :: fname, line, pn
logical                                 :: fexists
real(kind=dbl)                          :: x, y, z
integer(kind=irg)                       :: i

pn = ''
EMsoft = EMsoft_T(pn, pn, silent=.TRUE.)

if (.not.present(shapefile)) then
  fname = EMsoft%generateFilePath('Resourcepathname','ShapeFiles')
  fname = trim(fname)//'/'//trim(shapename)
  fname = EMsoft%toNativePath(fname)
else
  fname = EMsoft%generateFilePath('EMdatapathname',trim(shapefile))
end if

self%shapename = trim(shapename)
self%shapefile = trim(fname)

inquire(file=trim(fname),exist=fexists)

if (fexists.eqv..TRUE.) then
  open(unit=dataunit, file=trim(fname), status='old', form='formatted')
  read (dataunit,"(A)") line   ! shape name
  read (dataunit,"(A)") line   ! vertex coordinates
  read (dataunit,*) self%nvertices
  allocate(self%vertex(self%nvertices))
  do i=1,self%nvertices
    read (dataunit,*) x, y, z
    pt = point(x, y, z)
    self%vertex(i) = pt
    ! call pt%log()
  end do
  read (dataunit,"(A)") line   ! vertex coordinates
  read (dataunit,*) self%nfaces
  allocate(self%faces(self%nfaces))
  allocate(self%face(self%nfaces))
  allocate(self%facenormal(self%nfaces))
  allocate(self%facecenter(self%nfaces))
  do i=1,self%nfaces
    line = ''
    read (dataunit,"(A)") line
    read (line,*) self%faces(i)%nv
    allocate(self%faces(i)%verts(self%faces(i)%nv))
    read (line,*) self%faces(i)%nv, self%faces(i)%verts(1:self%faces(i)%nv)
    allocate(self%faces(i)%otherface(self%faces(i)%nv))
    allocate(self%faces(i)%edgenormal(self%faces(i)%nv))
    allocate(self%faces(i)%edgeL(self%faces(i)%nv))
    allocate(self%faces(i)%edge(self%faces(i)%nv))
    allocate(self%faces(i)%edgecenter(self%faces(i)%nv))
  end do
  close(unit=dataunit, status='keep')
  self%nedges = sum(self%faces(1:self%nfaces)%nv) / 2
  call self%build_polyhedron_( Ledge )
else
  call Message%printError('polyhedron_init_','Shape file '//trim(fname)//' not found')
end if

end subroutine polyhedron_init_

!--------------------------------------------------------------------------
subroutine polyhedron_shapefunction_( self, shapearray, dims, dxyz)
!DEC$ ATTRIBUTES DLLEXPORT :: polyhedron_shapefunction_
!! author: MDG
!! version: 1.0
!! date: 07/28/21
!!
!! generate a discrete shape function array using pixelwise comparisons in PGA3D
!! (this is also known as the characteristic function, 1 inside and 0 outside)

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)      :: self
integer(kind=irg),INTENT(IN)            :: dims(3)
real(kind=sgl), INTENT(INOUT)           :: shapearray(-dims(1):dims(1),-dims(2):dims(2),-dims(3):dims(3))
real(kind=dbl),INTENT(IN)               :: dxyz

type(PGA3D_T)                           :: pt, mv
integer(kind=irg)                       :: i, j, k, f
real(kind=dbl)                          :: sgn, sgnsum

pt = point(0.D0,0.D0,0.D0)
mv = self%face(1) .wedge. pt
sgn = dble(self%nfaces)
if (mv%getcomp(15).lt.0.D0) sgn = -sgn

shapearray = 0.D0
do i=-dims(1),dims(1)
  do j=-dims(2),dims(2)
    do k=-dims(3),dims(3)
      pt = point(dble(i)*dxyz,dble(j)*dxyz,dble(k)*dxyz)
      sgnsum = 0.D0
      do f=1,self%nfaces
        mv = self%face(f) .wedge. pt
        if (mv%getcomp(15).gt.0.D0) then
          sgnsum = sgnsum + 1.D0
        else
          sgnsum = sgnsum - 1.D0
        end if
      end do
      if (sgnsum.eq.sgn) shapearray(i,j,k) = 1.0
    end do
  end do
end do

end subroutine polyhedron_shapefunction_

!--------------------------------------------------------------------------
subroutine polyhedron_shapeamplitude_( self, shamp, dims, dk, nthr )
!DEC$ ATTRIBUTES DLLEXPORT :: polyhedron_shapeamplitude_
!! author: MDG
!! version: 1.0
!! date: 08/06/21
!!
!! generate a shape amplitude using the Komrska algorithm
!!
! @article{komrska1987a,
!   author = {Komrska, J.},
!   journal = {Optik},
!   pages = {171-183},
!   title = {Algebraic {E}xpressions of {S}hape {A}mplitudes of {P}olygons and {P}olyhedra},
!   volume = 80,
!   year = 1987}
!!
!! This is based on a 1999 f77 version of the algorithm, written for the CTEM book illustrations.
!! The algorithm has been completely rewritten using 3D projective geometric algebra which
!! provides more flexibility and rigour to the computations (in particular in terms of
!! directional quantities).

use omp_lib
use mod_io

IMPLICIT NONE

class(polyhedron_T), INTENT(INOUT)      :: self
integer(kind=irg),INTENT(IN)            :: dims(3)
complex(kind=dbl),INTENT(INOUT)         :: shamp(-dims(1):dims(1)-1,-dims(2):dims(2)-1,-dims(3):dims(3)-1)
real(kind=dbl),INTENT(IN)               :: dk  ! step size in shape amplitude array
integer(kind=irg),INTENT(IN)            :: nthr

type(IO_T)                              :: Message
integer(kind=irg)                       :: i, j, k, l, f, e, vn, TID, io_int(2), zcnt
complex(kind=dbl)                       :: p, esum, ff
real(kind=dbl)                          :: scl, knf, qq, pp, r, arg, d, ratio, dd, x, y, z
type(PGA3D_T)                           :: kvec, qn, mv, pt

zcnt = 0

!$OMP PARALLEL NUM_THREADS(nthr) DEFAULT(SHARED) PRIVATE(TID,j,k,kvec,p,qq,f,e,qn,knf,pp,r,arg,ff,esum,mv,d,ratio,x,y,z)

TID = OMP_GET_THREAD_NUM()

!$OMP DO SCHEDULE (STATIC)
do i = -dims(1),dims(1)-1
  do j = -dims(2),dims(2)-1
    do k = -dims(3),dims(3)-1
      kvec = line(dk*dble(i), dk*dble(j), dk*dble(k))  ! this is the Fourier space frequency vector k
      if (kvec%norm().eq.0.D0) then
        p = cmplx(self%volume,0.D0)
      else
        p = cmplx(0.D0, 0.D0)
  ! length squared of q
        qq = kvec%norm()**2
  ! loop over all faces
        do f = 1,self%nfaces
  ! first make sure that the second denominator in the Komrska equation is not zero
          qn = kvec.inner.self%facenormal(f)
          knf = qn%getcomp(0)
          pp = qq-knf**2

  ! it is zero, so use the special equation for this face
          if (dabs(pp).lt.1.0D-8) then
            r = 0.5D0*knf*self%faces(f)%area/qq
            arg = knf*self%faces(f)%dorigin
            ff = cmplx(r*dsin(arg), r*dcos(arg))
          else
  ! its not zero, so do the general equation for this face
            esum = cmplx(0.D0, 0.D0)
  ! loop over all edges for this face
            do e = 1,self%faces(f)%nv
              mv = kvec.inner.self%faces(f)%edge(e)%normalized()
              d = mv%getcomp(0)
              arg = d*self%faces(f)%edgeL(e)*0.5D0 ! *cPi
              if (dabs(arg).lt.1.0D-8) then
               ratio = 1.D0
              else
               ratio = dsin(arg)/arg
              endif
              mv = kvec.inner.self%faces(f)%edgenormal(e)%normalized()
              dd = mv%getcomp(0)
              ratio = ratio*self%faces(f)%edgeL(e)*dd
              mv = point(0.D0,0.D0,0.D0).vee.self%faces(f)%edgecenter(e)
              mv = kvec.inner.mv
              arg = mv%getcomp(0)
              esum = esum + cmplx(ratio*cos(arg),-ratio*sin(arg))
            end do
            ff = knf*esum/(pp*qq)  ! the minus sign is taken care of by the projective geometric algebra routines
          endif
          p = p+ff
        end do
      end if
      shamp(i, j, k) = p
    end do
  end do
  if (TID.eq.0) then
    zcnt = zcnt+1
    io_int = (/ nthr*zcnt, 2*dims(1)+1 /)
    call Message%writeValue('   completed plane ', io_int, 2, frm="(I5,' out of ',I5)")
  end if
end do
!$OMP END DO
!$OMP END PARALLEL

call Message%printMessage(' --> done.')

end subroutine polyhedron_shapeamplitude_

end module mod_polyhedra


module nodal_sync_resid_module
  use bl_constants_module
  use bc_functions_module
  use multifab_module
  implicit none

contains

  subroutine compute_divuo(divuo, mask, vold, dx, face_type)
    type(multifab) , intent(inout) :: divuo
    type(multifab) , intent(in   ) :: mask
    type(multifab) , intent(in   ) :: vold
    real(kind=dp_t), intent(in   ) :: dx(:)
    integer        , intent(in   ) :: face_type(:,:,:)

    integer :: i, dm
    real(kind=dp_t), pointer :: msk(:,:,:,:)
    real(kind=dp_t), pointer :: vo(:,:,:,:)
    real(kind=dp_t), pointer :: dvo(:,:,:,:)

    dm = get_dim(vold)

    do i = 1, nfabs(divuo)
       dvo => dataptr(divuo, i)
       msk => dataptr(mask , i)
       vo  => dataptr(vold , i)
       select case (dm)
       case (1)
          call bl_error('divuo: 1d not done')
       case (2)
          call divuo_2d(dvo(:,:,1,1), msk(:,:,1,1), vo(:,:,1,:), dx, face_type(i,:,:))
       case (3)
          call divuo_3d(dvo(:,:,:,1), msk(:,:,:,1), vo(:,:,:,:), dx, face_type(i,:,:))
       end select
    end do

  end subroutine compute_divuo

  subroutine divuo_2d(dvo, msk, vel, dx, face_type)
    real(kind=dp_t), intent(inout) :: dvo(-1:,-1:)
    real(kind=dp_t), intent(in   ) :: msk(-1:,-1:)
    real(kind=dp_t), intent(in   ) :: vel(-1:,-1:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    integer        , intent(in   ) :: face_type(:,:)

    integer :: i, j, nx, ny
    real(kind=dp_t) :: divv

    nx = size(msk,dim=1) - 2
    ny = size(msk,dim=2) - 2

    do j = 0, ny
       do i = 0, nx
          divv = (vel(i  ,j,1)*msk(i , j) + vel(i  ,j-1,1)*msk(i  ,j-1) &
               -  vel(i-1,j,1)*msk(i-1,j) - vel(i-1,j-1,1)*msk(i-1,j-1)) / dx(1) &
               + (vel(i,j  ,2)*msk(i,j  ) + vel(i-1,j  ,2)*msk(i-1,j  ) &
               -  vel(i,j-1,2)*msk(i,j-1) - vel(i-1,j-1,2)*msk(i-1,j-1)) / dx(2)
          dvo(i,j) = HALF * divv
       end do
    end do

    if (face_type(1,1) == BC_NEU) dvo(0 ,0:ny) = TWO*dvo( 0,0:ny)
    if (face_type(1,2) == BC_NEU) dvo(nx,0:ny) = TWO*dvo(nx,0:ny)
    if (face_type(2,1) == BC_NEU) dvo(0:nx,0 ) = TWO*dvo(0:nx, 0)
    if (face_type(2,2) == BC_NEU) dvo(0:nx,ny) = TWO*dvo(0:nx,ny)

  end subroutine divuo_2d

  subroutine divuo_3d(dvo, msk, vel, dx, face_type)
    real(kind=dp_t), intent(inout) :: dvo(-1:,-1:,-1:)
    real(kind=dp_t), intent(in   ) :: msk(-1:,-1:,-1:)
    real(kind=dp_t), intent(in   ) :: vel(-1:,-1:,-1:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    integer        , intent(in   ) :: face_type(:,:)

    integer         :: i, j, k, nx, ny, nz
    real(kind=dp_t) :: ivdx,ivdy,ivdz

    nx = size(msk,dim=1) - 2
    ny = size(msk,dim=2) - 2
    nz = size(msk,dim=3) - 2

    ivdx = ONE / dx(1)
    ivdy = ONE / dx(2)
    ivdz = ONE / dx(3)

    !$OMP PARALLEL DO PRIVATE(i,j,k)
    do k = 0, nz
    do j = 0, ny
       do i = 0, nx
          dvo(i,j,k) = FOURTH * (  &
               & (vel(i  ,j  ,k  ,1) * msk(i  ,j  ,k  ) &
               +  vel(i  ,j-1,k  ,1) * msk(i  ,j-1,k  ) &
               +  vel(i  ,j  ,k-1,1) * msk(i  ,j  ,k-1) &
               +  vel(i  ,j-1,k-1,1) * msk(i  ,j-1,k-1) &
               -  vel(i-1,j  ,k  ,1) * msk(i-1,j  ,k  ) &
               -  vel(i-1,j-1,k  ,1) * msk(i-1,j-1,k  ) &
               -  vel(i-1,j  ,k-1,1) * msk(i-1,j  ,k-1) &
               -  vel(i-1,j-1,k-1,1) * msk(i-1,j-1,k-1)) * ivdx &
               + (vel(i  ,j  ,k  ,2) * msk(i  ,j  ,k  ) &
               +  vel(i-1,j  ,k  ,2) * msk(i-1,j  ,k  ) &
               +  vel(i  ,j  ,k-1,2) * msk(i  ,j  ,k-1) &
               +  vel(i-1,j  ,k-1,2) * msk(i-1,j  ,k-1) &
               -  vel(i  ,j-1,k  ,2) * msk(i  ,j-1,k  ) &
               -  vel(i-1,j-1,k  ,2) * msk(i-1,j-1,k  ) &
               -  vel(i  ,j-1,k-1,2) * msk(i  ,j-1,k-1) &
               -  vel(i-1,j-1,k-1,2) * msk(i-1,j-1,k-1)) * ivdy &
               + (vel(i  ,j  ,k  ,3) * msk(i  ,j  ,k  ) &
               +  vel(i-1,j  ,k  ,3) * msk(i-1,j  ,k  ) &
               +  vel(i  ,j-1,k  ,3) * msk(i  ,j-1,k  ) &
               +  vel(i-1,j-1,k  ,3) * msk(i-1,j-1,k  ) &
               -  vel(i  ,j  ,k-1,3) * msk(i  ,j  ,k-1) &
               -  vel(i-1,j  ,k-1,3) * msk(i-1,j  ,k-1) &
               -  vel(i  ,j-1,k-1,3) * msk(i  ,j-1,k-1) &
               -  vel(i-1,j-1,k-1,3) * msk(i-1,j-1,k-1)) * ivdz )
       end do
    end do
    end do
    !$OMP END PARALLEL DO

    if (face_type(1,1) == BC_NEU) dvo( 0,0:ny,0:nz) = TWO*dvo( 0,0:ny,0:nz)
    if (face_type(1,2) == BC_NEU) dvo(nx,0:ny,0:nz) = TWO*dvo(nx,0:ny,0:nz)
    if (face_type(2,1) == BC_NEU) dvo(0:nx, 0,0:nz) = TWO*dvo(0:nx, 0,0:nz)
    if (face_type(2,2) == BC_NEU) dvo(0:nx,ny,0:nz) = TWO*dvo(0:nx,ny,0:nz)
    if (face_type(3,1) == BC_NEU) dvo(0:nx,0:ny, 0) = TWO*dvo(0:nx,0:ny, 0)
    if (face_type(3,2) == BC_NEU) dvo(0:nx,0:ny,nz) = TWO*dvo(0:nx,0:ny,nz)

  end subroutine divuo_3d

  subroutine comp_sync_res(sync_res, divuo, mask, sign_res)
    type(multifab) , intent(inout) :: sync_res
    type(multifab) , intent(in   ) :: divuo
    type(multifab) , intent(in   ) :: mask
    real(kind=dp_t), intent(in   ) :: sign_res

    integer :: i, dm
    real(kind=dp_t), pointer :: res(:,:,:,:)
    real(kind=dp_t), pointer :: dvo(:,:,:,:)
    real(kind=dp_t), pointer :: msk(:,:,:,:)

    dm = get_dim(sync_res)

    do i = 1, nfabs(sync_res)
       res => dataptr(sync_res, i)
       dvo => dataptr(divuo   , i)
       msk => dataptr(mask    , i)
       select case (dm)
       case (1)
          call bl_error('comp_sync_res: 1d not done')
       case (2)
          call comp_sync_res_2d(res(:,:,1,1), dvo(:,:,1,1), msk(:,:,1,1), sign_res)
       case (3)
          call comp_sync_res_3d(res(:,:,:,1), dvo(:,:,:,1), msk(:,:,:,1), sign_res)
       end select
    end do

  end subroutine comp_sync_res

  subroutine comp_sync_res_2d(res, dvo, msk, sgnr)
    real(kind=dp_t), intent(inout) :: res(-1:,-1:)
    real(kind=dp_t), intent(in   ) :: dvo(-1:,-1:)
    real(kind=dp_t), intent(in   ) :: msk(-1:,-1:)
    real(kind=dp_t), intent(in   ) :: sgnr

    integer :: i, j, nx, ny

    nx = size(msk,dim=1) - 2
    ny = size(msk,dim=2) - 2

    do j = 0, ny
       do i = 0, nx
          if ( any(msk(i-1:i,j-1:j) .eq. ONE) .and. &
               any(msk(i-1:i,j-1:j) .eq. ZERO) ) then
             res(i,j) = sgnr*res(i,j) + dvo(i,j)
          else
             res(i,j) = ZERO
          end if
       end do
    end do

  end subroutine comp_sync_res_2d

  subroutine comp_sync_res_3d(res, dvo, msk, sgnr)
    real(kind=dp_t), intent(inout) :: res(-1:,-1:,-1:)
    real(kind=dp_t), intent(in   ) :: dvo(-1:,-1:,-1:)
    real(kind=dp_t), intent(in   ) :: msk(-1:,-1:,-1:)
    real(kind=dp_t), intent(in   ) :: sgnr

    integer         :: i, j, k, nx, ny, nz
    real(kind=dp_t) :: r

    nx = size(msk,dim=1) - 2
    ny = size(msk,dim=2) - 2
    nz = size(msk,dim=3) - 2

    !$OMP PARALLEL DO PRIVATE(i,j,k,r)
    do k = 0, nz
       do j = 0, ny
          do i = 0, nx
             r = ZERO
             if ( any(msk(i-1:i,j-1:j,k-1:k) .eq. ONE) ) then
                if ( any(msk(i-1:i,j-1:j,k-1:k) .eq. ZERO) ) then
                   r = sgnr*res(i,j,k) + dvo(i,j,k)
                endif
             endif
             res(i,j,k) = r
          end do
       end do
    end do
    !$OMP END PARALLEL DO

  end subroutine comp_sync_res_3d

  subroutine divuo_add_rhcc(divuo, rhcc, mask, face_type)
    type(multifab) , intent(inout) :: divuo
    type(multifab) , intent(inout) :: rhcc
    type(multifab) , intent(in   ) :: mask
    integer        , intent(in   ) :: face_type(:,:,:)

    integer                  :: i, dm
    real(kind=dp_t), pointer :: msk(:,:,:,:)
    real(kind=dp_t), pointer :: dvo(:,:,:,:)
    real(kind=dp_t), pointer :: rc(:,:,:,:)

    dm = get_dim(rhcc)

    do i = 1, nfabs(divuo)
       dvo => dataptr(divuo, i)
       msk => dataptr(mask , i)
       rc  => dataptr(rhcc , i)
       select case (dm)
       case (1)
          call bl_error('divuo_rhcc_1d: 1d not done')
       case (2)
          call divuo_rhcc_2d(dvo(:,:,1,1), msk(:,:,1,1), rc(:,:,1,1), face_type(i,:,:))
       case (3)
          call divuo_rhcc_3d(dvo(:,:,:,1), msk(:,:,:,1), rc(:,:,:,1), face_type(i,:,:))
       end select
    end do

  end subroutine divuo_add_rhcc

  subroutine divuo_rhcc_2d(dvo, msk, rc, face_type)
    real(kind=dp_t), intent(inout) :: dvo(-1:,-1:)
    real(kind=dp_t), intent(in   ) :: msk(-1:,-1:)
    real(kind=dp_t), intent(inout) ::  rc(-1:,-1:)
    integer        , intent(in   ) :: face_type(:,:)

    integer :: i, j, nx, ny
    real(kind=dp_t), pointer :: tmp(:,:)

    nx = size(msk,dim=1) - 2
    ny = size(msk,dim=2) - 2

    rc(-1,:) = ZERO
    rc(nx,:) = ZERO
    rc(:,-1) = ZERO
    rc(:,ny) = ZERO

    allocate(tmp(0:nx,0:ny))

    do j = 0, ny
       do i = 0, nx
          tmp(i,j) = FOURTH *   &
               ( rc(i-1,j-1) * msk(i-1,j-1)  &
               + rc(i  ,j-1) * msk(i  ,j-1)  &
               + rc(i-1,j  ) * msk(i-1,j  )  &
               + rc(i  ,j  ) * msk(i  ,j  ) )
       end do
    end do

    if (face_type(1,1) == BC_NEU) tmp( 0,:) = TWO*tmp( 0,:)
    if (face_type(1,2) == BC_NEU) tmp(nx,:) = TWO*tmp(nx,:)
    if (face_type(2,1) == BC_NEU) tmp(:, 0) = TWO*tmp(:, 0)
    if (face_type(2,2) == BC_NEU) tmp(:,ny) = TWO*tmp(:,ny)

    do j = 0, ny
       do i = 0, nx
          dvo(i,j) = dvo(i,j) + tmp(i,j)
       end do
    end do

    deallocate(tmp)

  end subroutine divuo_rhcc_2d

  subroutine divuo_rhcc_3d(dvo, msk, rc, face_type)
    real(kind=dp_t), intent(inout) :: dvo(-1:,-1:,-1:)
    real(kind=dp_t), intent(in   ) :: msk(-1:,-1:,-1:)
    real(kind=dp_t), intent(inout) ::  rc(-1:,-1:,-1:)
    integer        , intent(in   ) :: face_type(:,:)

    integer :: i, j, k, nx, ny, nz
    real(kind=dp_t), pointer :: tmp(:,:,:)

    nx = size(msk,dim=1) - 2
    ny = size(msk,dim=2) - 2
    nz = size(msk,dim=3) - 2

    rc(-1,:,:) = ZERO
    rc(nx,:,:) = ZERO
    rc(:,-1,:) = ZERO
    rc(:,ny,:) = ZERO
    rc(:,:,-1) = ZERO
    rc(:,:,nz) = ZERO

    allocate(tmp(0:nx,0:ny,0:nz))

    !$OMP PARALLEL DO PRIVATE(i,j,k)
    do k = 0, nz
    do j = 0, ny
    do i = 0, nx
       tmp(i,j,k) = EIGHTH *   &
            ( rc(i-1,j-1,k-1) * msk(i-1,j-1,k-1)  &
            + rc(i  ,j-1,k-1) * msk(i  ,j-1,k-1)  &
            + rc(i-1,j  ,k-1) * msk(i-1,j  ,k-1)  &
            + rc(i  ,j  ,k-1) * msk(i  ,j  ,k-1)  &
            + rc(i-1,j-1,k  ) * msk(i-1,j-1,k  )  &
            + rc(i  ,j-1,k  ) * msk(i  ,j-1,k  )  &
            + rc(i-1,j  ,k  ) * msk(i-1,j  ,k  )  &
            + rc(i  ,j  ,k  ) * msk(i  ,j  ,k  )  )
    end do
    end do
    end do
    !$OMP END PARALLEL DO

    if (face_type(1,1) == BC_NEU) tmp( 0,:,:) = TWO*tmp( 0,:,:)
    if (face_type(1,2) == BC_NEU) tmp(nx,:,:) = TWO*tmp(nx,:,:)
    if (face_type(2,1) == BC_NEU) tmp(:, 0,:) = TWO*tmp(:, 0,:)
    if (face_type(2,2) == BC_NEU) tmp(:,ny,:) = TWO*tmp(:,ny,:)
    if (face_type(3,1) == BC_NEU) tmp(:,:, 0) = TWO*tmp(:,:, 0)
    if (face_type(3,2) == BC_NEU) tmp(:,:,nz) = TWO*tmp(:,:,nz)

    !$OMP PARALLEL DO PRIVATE(i,j,k)
    do k = 0, nz
    do j = 0, ny
    do i = 0, nx
       dvo(i,j,k) = dvo(i,j,k) + tmp(i,j,k)
    end do
    end do
    end do
    !$OMP END PARALLEL DO

    deallocate(tmp)

  end subroutine divuo_rhcc_3d

  subroutine sync_res_fine_bndry(res_fine, face_type)
    type(multifab), intent(inout) :: res_fine
    integer, intent(in) :: face_type(:,:,:)

    integer :: i, dm
    real(kind=dp_t), pointer :: resp(:,:,:,:)

    dm = get_dim(res_fine)

    do i = 1, nfabs(res_fine)
       resp => dataptr(res_fine, i)
       select case (dm)
       case (1)
          call bl_error('sync_res_fine_bndry: 1d not done')
       case (2)
          call res_fine_bndry_2d(resp(:,:,1,1), face_type(i,:,:))
       case (3)
          call res_fine_bndry_3d(resp(:,:,:,1), face_type(i,:,:))
       end select
    end do

  end subroutine sync_res_fine_bndry

  subroutine res_fine_bndry_2d(res, face_type)
    real(kind=dp_t), intent(inout) :: res(-1:,-1:)
    integer        , intent(in   ) :: face_type(:,:)
    integer :: nx, ny

    nx = size(res,dim=1) - 3
    ny = size(res,dim=2) - 3

    if (face_type(1,1) == BC_NEU) res( 0,:) = HALF*res( 0,:)
    if (face_type(1,2) == BC_NEU) res(nx,:) = HALF*res(nx,:)
    if (face_type(2,1) == BC_NEU) res(:, 0) = HALF*res(:, 0)
    if (face_type(2,2) == BC_NEU) res(:,ny) = HALF*res(:,ny)

  end subroutine res_fine_bndry_2d

  subroutine res_fine_bndry_3d(res, face_type)
    real(kind=dp_t), intent(inout) :: res(-1:,-1:,-1:)
    integer        , intent(in   ) :: face_type(:,:)
    integer :: nx, ny, nz

    nx = size(res,dim=1) - 3
    ny = size(res,dim=2) - 3
    nz = size(res,dim=3) - 3

    if (face_type(1,1) == BC_NEU) res( 0,:,:) = HALF*res( 0,:,:)
    if (face_type(1,2) == BC_NEU) res(nx,:,:) = HALF*res(nx,:,:)
    if (face_type(2,1) == BC_NEU) res(:, 0,:) = HALF*res(:, 0,:)
    if (face_type(2,2) == BC_NEU) res(:,ny,:) = HALF*res(:,ny,:)
    if (face_type(3,1) == BC_NEU) res(:,:, 0) = HALF*res(:,:, 0)
    if (face_type(3,2) == BC_NEU) res(:,:,nz) = HALF*res(:,:,nz)

  end subroutine res_fine_bndry_3d

end module nodal_sync_resid_module

subroutine mgt_alloc_nodal_sync()
  use nodal_cpp_mg_module
  implicit none
  logical,dimension(3) :: nodal

  allocate(mgts%sync_res(1))
  allocate(mgts%sync_msk(1))
  allocate(mgts%vold(1))

  nodal = .true.

  call multifab_build(mgts%sync_res(1) , mgts%mla%la(1), nc = 1, ng = 1, nodal = nodal)
  call multifab_build(mgts%sync_msk(1) , mgts%mla%la(1), nc = 1, ng = 1)
  call multifab_build(mgts%vold(1)     , mgts%mla%la(1), nc = mgts%dim, ng = 1)

  call multifab_setval(mgts%sync_res(1),ZERO,all=.true.)

end subroutine mgt_alloc_nodal_sync

subroutine mgt_dealloc_nodal_sync()
  use nodal_cpp_mg_module
  implicit none

  call multifab_destroy(mgts%sync_res(1))
  call multifab_destroy(mgts%sync_msk(1))
  call multifab_destroy(mgts%vold(1))

  deallocate(mgts%sync_res)
  deallocate(mgts%sync_msk)
  deallocate(mgts%vold)

end subroutine mgt_dealloc_nodal_sync

subroutine mgt_set_sync_msk_1d(lev, n, msk_in, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(1), hi(1), plo(1), phi(1)
  real(kind=dp_t), intent(in) :: msk_in(plo(1):phi(1))
  real(kind=dp_t), pointer :: mskp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  mskp => dataptr(mgts%sync_msk(flev), fn)
  mskp(lo(1):hi(1),1,1,1) = msk_in(lo(1):hi(1))
end subroutine mgt_set_sync_msk_1d

subroutine mgt_set_sync_msk_2d(lev, n, msk_in, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(2), hi(2), plo(2), phi(2)
  real(kind=dp_t), intent(in) :: msk_in(plo(1):phi(1),plo(2):phi(2))
  real(kind=dp_t), pointer :: mskp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  mskp => dataptr(mgts%sync_msk(flev), fn)
  mskp(lo(1):hi(1),lo(2):hi(2),1,1) = msk_in(lo(1):hi(1),lo(2):hi(2))
end subroutine mgt_set_sync_msk_2d

subroutine mgt_set_sync_msk_3d(lev, n, msk_in, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(3), hi(3), plo(3), phi(3)
  real(kind=dp_t), intent(in) :: msk_in(plo(1):phi(1),plo(2):phi(2),plo(3):phi(3))
  real(kind=dp_t), pointer :: mskp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  mskp => dataptr(mgts%sync_msk(flev), fn)
  mskp       (lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),1) = &
       msk_in(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3))
end subroutine mgt_set_sync_msk_3d

subroutine mgt_set_vold_1d(lev, n, v_in, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(1), hi(1), plo(1), phi(1)
  real(kind=dp_t), intent(in) :: v_in(plo(1):phi(1))
  real(kind=dp_t), pointer :: vp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  vp => dataptr(mgts%vold(flev), fn)
  vp(lo(1):hi(1),1,1,1) = v_in(lo(1):hi(1))
end subroutine mgt_set_vold_1d

subroutine mgt_set_vold_2d(lev, n, v_in, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(2), hi(2), plo(2), phi(2)
  real(kind=dp_t), intent(in) :: v_in(plo(1):phi(1),plo(2):phi(2),1:2)
  real(kind=dp_t), pointer :: vp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  vp => dataptr(mgts%vold(flev), fn)
  vp       (lo(1):hi(1),lo(2):hi(2),1,1:2) =   &
       v_in(lo(1):hi(1),lo(2):hi(2),1:2)
end subroutine mgt_set_vold_2d

subroutine mgt_set_vold_3d(lev, n, v_in, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(3), hi(3), plo(3), phi(3)
  real(kind=dp_t), intent(in) :: v_in(plo(1):phi(1),plo(2):phi(2),plo(3):phi(3),1:3)
  real(kind=dp_t), pointer :: vp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  vp => dataptr(mgts%vold(flev), fn)
  vp       (lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),1:3) = &
       v_in(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),1:3)
end subroutine mgt_set_vold_3d

subroutine mgt_get_sync_res_1d(lev, n, res, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(1), hi(1), plo(1), phi(1)
  real(kind=dp_t), intent(inout) :: res(plo(1):phi(1))
  real(kind=dp_t), pointer :: rp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  rp => dataptr(mgts%sync_res(flev), fn)
  res(lo(1):hi(1)) = rp(lo(1):hi(1), 1, 1, 1)
end subroutine mgt_get_sync_res_1d

subroutine mgt_get_sync_res_2d(lev, n, res, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(2), hi(2), plo(2), phi(2)
  real(kind=dp_t), intent(inout) :: res(plo(1):phi(1), plo(2):phi(2))
  real(kind=dp_t), pointer :: rp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  rp => dataptr(mgts%sync_res(flev), fn)
  res(lo(1):hi(1), lo(2):hi(2)) = rp(lo(1):hi(1), lo(2):hi(2), 1, 1)
end subroutine mgt_get_sync_res_2d

subroutine mgt_get_sync_res_3d(lev, n, res, plo, phi, lo, hi)
  use nodal_cpp_mg_module
  implicit none
  integer, intent(in) :: lev, n, lo(3), hi(3), plo(3), phi(3)
  real(kind=dp_t), intent(inout) :: res(plo(1):phi(1), plo(2):phi(2), plo(3):phi(3))
  real(kind=dp_t), pointer :: rp(:,:,:,:)
  integer :: flev, fn
  fn = n + 1
  flev = lev+1
  rp => dataptr(mgts%sync_res(flev), fn)
  res(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3)) =  &
       rp(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)
end subroutine mgt_get_sync_res_3d

subroutine mgt_compute_sync_resid_crse()
  use nodal_cpp_mg_module
  use nodal_sync_resid_module
  use nodal_stencil_fill_module, only : stencil_fill_nodal
  implicit none

  integer :: dm, mglev
  real(kind=dp_t) :: sign_res
  type(multifab) :: divuo
  logical :: nodal(3)

  nodal = .true.
  dm = get_dim(mgts%sync_res(1))
  mglev = mgts%mgt(1)%nlevels

  call multifab_build(divuo, mgts%mla%la(1), nc=1, ng=1, nodal=nodal)

  call compute_divuo(divuo, mgts%sync_msk(1), mgts%vold(1), mgts%mgt(1)%dh(:,mglev), &
                     mgts%mgt(1)%face_type)

  if (associated(mgts%rhcc)) then  ! only single level solve could get here
     call divuo_add_rhcc(divuo, mgts%rhcc(1), mgts%sync_msk(1), mgts%mgt(1)%face_type)
  end if

  call multifab_mult_mult(mgts%amr_coeffs(1), mgts%sync_msk(1))

  call stencil_fill_nodal(mgts%amr_coeffs(1), mgts%mgt(1)%ss(mglev), &
                          mgts%mgt(1)%dh(:,mglev), mgts%mgt(1)%mm(mglev), &
                          mgts%mgt(1)%face_type)

  call stencil_apply(mgts%mgt(1)%ss(mglev), mgts%sync_res(1), mgts%uu(1), &
                     mgts%mgt(1)%mm(mglev), mgts%mgt(1)%stencil_type, &
                     mgts%mgt(1)%lcross, mgts%mgt(1)%uniform_dh)

  sign_res = -ONE
  call comp_sync_res(mgts%sync_res(1), divuo, mgts%sync_msk(1), sign_res)

  call multifab_destroy(divuo)

end subroutine mgt_compute_sync_resid_crse

subroutine mgt_compute_sync_resid_fine()
  use nodal_cpp_mg_module
  use nodal_sync_resid_module
  use ml_nd_module
  implicit none

  integer :: dm, mglev
  real(kind=dp_t) :: sign_res
  type(multifab) :: divuo
  type(multifab) :: rh0
  logical :: nodal(3)

  nodal = .true.
  dm = get_dim(mgts%sync_res(1))
  mglev = mgts%mgt(1)%nlevels

  call multifab_build(divuo, mgts%mla%la(1), nc=1, ng=1, nodal=nodal)

  call multifab_build(rh0, mgts%mla%la(1), nc=1, ng=1, nodal=nodal)
  call multifab_setval(rh0,ZERO,all=.true.)

  call compute_divuo(divuo, mgts%sync_msk(1), mgts%vold(1), mgts%mgt(1)%dh(:,mglev), &
       mgts%mgt(1)%face_type)

  if (associated(mgts%rhcc)) then
     call divuo_add_rhcc(divuo, mgts%rhcc(1), mgts%sync_msk(1), mgts%mgt(1)%face_type)
  end if

  call grid_res(mgts%mgt(1)%ss(mglev), &
                mgts%sync_res(1), rh0, mgts%uu(1), mgts%mgt(1)%mm(mglev), &
                mgts%mgt(1)%lcross, mgts%stencil_type, mgts%mgt(1)%uniform_dh)

  sign_res = ONE
  call comp_sync_res(mgts%sync_res(1), divuo, mgts%sync_msk(1), sign_res)

  call sync_res_fine_bndry(mgts%sync_res(1), mgts%mgt(1)%face_type)

  call multifab_destroy(divuo)
  call multifab_destroy(rh0)

end subroutine mgt_compute_sync_resid_fine


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine prep_finite_difference
  use global_variables
  implicit none
  integer,parameter :: Nd=4
  integer :: i,j,k,n
  real(8) :: t,s,s0

  allocate(lap(-Nd:Nd),nab(-Nd:Nd))
  allocate(lap1(-Nd:Nd),lap2(-Nd:Nd),lap3(-Nd:Nd))
  allocate(nab1(-Nd:Nd),nab2(-Nd:Nd),nab3(-Nd:Nd))
  allocate(ifdx1(-Nd:Nd,1:NL),ifdx2(-Nd:Nd,1:NL),ifdx3(-Nd:Nd,1:NL))

  lap=0.d0
  nab=0.d0

  n=Nd
  s=0.d0
  do i=-n,n
    if ( i==0 ) cycle
    do j=-n,n
      if ( j==i .or. j==0 ) cycle
      s=s+1.d0/dble(i*j)
    end do
  end do
  lap(0)=s

  do j=1,n
    t=1.d0
    do i=-n,n
      if ( i==j ) cycle
      t=t*(j-i)
    end do
    s=0.d0
    do k=-n,n
      if ( k==j .or. k==0 ) cycle
      s0=1.d0
      do i=-n,n
        if ( i==k .or. i==j .or. i==0 ) cycle
        s0=s0*(-i)
      end do
      s=s+s0
    end do
    lap( j)=2.d0*s/t
    lap(-j)=lap(j)
  end do

  do j=1,n
    t=1.d0
    do i=-n,n
      if ( i==j ) cycle
      t=t*(j-i)
    end do
    s=1.d0
    do i=-n,n
      if ( i==j .or. i==0 ) cycle
      s=s*(-i)
    end do
    nab( j)=s/t
    nab(-j)=-nab(j)
  end do

  lap1(-Nd:Nd)=lap(-Nd:Nd)/H1**2
  lap2(-Nd:Nd)=lap(-Nd:Nd)/H2**2
  lap3(-Nd:Nd)=lap(-Nd:Nd)/H3**2
  nab1(-Nd:Nd)=nab(-Nd:Nd)/H1
  nab2(-Nd:Nd)=nab(-Nd:Nd)/H2
  nab3(-Nd:Nd)=nab(-Nd:Nd)/H3

  do i=1,NL
    do n=-Nd,Nd
      ifdx1(n,i)=iLx123(mod(iLx(1,i)+n+NL1,NL1),iLx(2,i),iLx(3,i))
      ifdx2(n,i)=iLx123(iLx(1,i),mod(iLx(2,i)+n+NL2,NL2),iLx(3,i))
      ifdx3(n,i)=iLx123(iLx(1,i),iLx(2,i),mod(iLx(3,i)+n+NL3,NL3))
    end do
  end do

  return
end subroutine prep_finite_difference