c***********************************************************************
c
c  File:        lsm_reinitialization3d.f
c***********************************************************************
c The algorithms and notation in these subroutines closely follows
c the discussion in Osher & Fedkiw (2003).
c***********************************************************************

c***********************************************************************
c
c  lsm3dComputeReinitializationEqnRHS() computes the right-hand side of
c  the reinitialization equation using a Godunov scheme to select the
c  numerical discretization of the sgn(phi) |grad(phi)| term.
c  Forward (plus) and backward (minus) spatial derivatives used in
c  the Godunov calculation must be supplied by the user.
c
c  Arguments:
c    reinit_rhs (out):       right-hand side of reinitialization
c                            equation
c    phi (in):               level set function at current iteration
c                            of reinitialization process
c    phi0 (in):              level set function at initial iteration
c                            iteration of reinitialization process
c    phi_*_plus (in):        forward spatial derivatives for grad(phi)
c    phi_*_minus (in):       backward spatial derivatives for grad(phi)
c    use_phi0_for_sgn (in):  flag to specify whether phi0 should be
c                            used in the computation of sgn(phi).
c                              0 = use phi (do NOT use phi0)
c                              1 = use phi0
c    *_gb (in):              index range for ghostbox
c    *_fb (in):              index range for fillbox
c
c  NOTES:
c   (1) if use_phi0_for_sgn is not equal to 0 or 1, the default
c       behavior of lsm3dComputeReinitializationEqnRHS() is to use
c       phi (i.e. equivalent to setting use_phi0_for_sgn to 0)
c
c***********************************************************************
      subroutine qss3dComputeReinitializationEqnRHS(
     &  reinit_rhs,
     &  ilo_rhs_gb, ihi_rhs_gb,
     &  jlo_rhs_gb, jhi_rhs_gb,
     &  klo_rhs_gb, khi_rhs_gb,
     &  phi,
     &  ilo_phi_gb, ihi_phi_gb,
     &  jlo_phi_gb, jhi_phi_gb,
     &  klo_phi_gb, khi_phi_gb,
     &  phi0,
     &  ilo_phi0_gb, ihi_phi0_gb,
     &  jlo_phi0_gb, jhi_phi0_gb,
     &  klo_phi0_gb, khi_phi0_gb,
     &  phi_x_plus, phi_y_plus, phi_z_plus,
     &  ilo_grad_phi_plus_gb, ihi_grad_phi_plus_gb,
     &  jlo_grad_phi_plus_gb, jhi_grad_phi_plus_gb,
     &  klo_grad_phi_plus_gb, khi_grad_phi_plus_gb,
     &  phi_x_minus, phi_y_minus, phi_z_minus,
     &  ilo_grad_phi_minus_gb, ihi_grad_phi_minus_gb,
     &  jlo_grad_phi_minus_gb, jhi_grad_phi_minus_gb,
     &  klo_grad_phi_minus_gb, khi_grad_phi_minus_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dx, dy, dz,
     &  use_phi0_for_sgn)
c***********************************************************************
c { begin subroutine
      implicit none

c     _gb refers to ghostbox
c     _fb refers to fillbox
      integer ilo_rhs_gb, ihi_rhs_gb
      integer jlo_rhs_gb, jhi_rhs_gb
      integer klo_rhs_gb, khi_rhs_gb
      integer ilo_phi_gb, ihi_phi_gb
      integer jlo_phi_gb, jhi_phi_gb
      integer klo_phi_gb, khi_phi_gb
      integer ilo_phi0_gb, ihi_phi0_gb
      integer jlo_phi0_gb, jhi_phi0_gb
      integer klo_phi0_gb, khi_phi0_gb
      integer ilo_grad_phi_plus_gb, ihi_grad_phi_plus_gb
      integer jlo_grad_phi_plus_gb, jhi_grad_phi_plus_gb
      integer klo_grad_phi_plus_gb, khi_grad_phi_plus_gb
      integer ilo_grad_phi_minus_gb, ihi_grad_phi_minus_gb
      integer jlo_grad_phi_minus_gb, jhi_grad_phi_minus_gb
      integer klo_grad_phi_minus_gb, khi_grad_phi_minus_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real reinit_rhs(ilo_rhs_gb:ihi_rhs_gb,
     &                jlo_rhs_gb:jhi_rhs_gb,
     &                klo_rhs_gb:khi_rhs_gb)
      real phi(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real phi0(ilo_phi0_gb:ihi_phi0_gb,
     &          jlo_phi0_gb:jhi_phi0_gb,
     &          klo_phi0_gb:khi_phi0_gb)
      real phi_x_plus(ilo_grad_phi_plus_gb:ihi_grad_phi_plus_gb,
     &                jlo_grad_phi_plus_gb:jhi_grad_phi_plus_gb,
     &                klo_grad_phi_plus_gb:khi_grad_phi_plus_gb)
      real phi_y_plus(ilo_grad_phi_plus_gb:ihi_grad_phi_plus_gb,
     &                jlo_grad_phi_plus_gb:jhi_grad_phi_plus_gb,
     &                klo_grad_phi_plus_gb:khi_grad_phi_plus_gb)
      real phi_z_plus(ilo_grad_phi_plus_gb:ihi_grad_phi_plus_gb,
     &                jlo_grad_phi_plus_gb:jhi_grad_phi_plus_gb,
     &                klo_grad_phi_plus_gb:khi_grad_phi_plus_gb)
      real phi_x_minus(ilo_grad_phi_minus_gb:ihi_grad_phi_minus_gb,
     &                 jlo_grad_phi_minus_gb:jhi_grad_phi_minus_gb,
     &                 klo_grad_phi_minus_gb:khi_grad_phi_minus_gb)
      real phi_y_minus(ilo_grad_phi_minus_gb:ihi_grad_phi_minus_gb,
     &                 jlo_grad_phi_minus_gb:jhi_grad_phi_minus_gb,
     &                 klo_grad_phi_minus_gb:khi_grad_phi_minus_gb)
      real phi_z_minus(ilo_grad_phi_minus_gb:ihi_grad_phi_minus_gb,
     &                 jlo_grad_phi_minus_gb:jhi_grad_phi_minus_gb,
     &                 klo_grad_phi_minus_gb:khi_grad_phi_minus_gb)
      real dx, dy, dz
      integer use_phi0_for_sgn
      real phi_cur
      integer DIM
      parameter (DIM=3)
      real grad_phi_plus_cur(1:DIM)
      real grad_phi_minus_cur(1:DIM)
      real grad_phi_star(1:DIM)
      integer i,j,k
      integer dir
      real sgn_phi
      real norm_grad_phi_sq
      real dx_sq
      real zero_tol
      parameter (zero_tol=1.e-5)
      real one
      parameter (one=1.d0)

c     set value of dx_sq to be square of max{dx,dy,dz}
      dx_sq = max(dx,dy,dz)
      dx_sq = dx_sq*dx_sq

c----------------------------------------------------
c      compute RHS of reinitialization equation
c      using Godunov's method
c----------------------------------------------------
c     { begin condition on use_phi0_for_sgn
      if (use_phi0_for_sgn .ne. 1) then

c       -----------------------------------------------
c       use phi in computation of smoothed sgn function
c       -----------------------------------------------
c       { begin loop over grid
        do k=klo_fb,khi_fb
          do j=jlo_fb,jhi_fb
            do i=ilo_fb,ihi_fb

c             cache phi and spatial derivative approximations
              phi_cur = phi(i,j,k)
              grad_phi_plus_cur(1) = phi_x_plus(i,j,k)
              grad_phi_plus_cur(2) = phi_y_plus(i,j,k)
              grad_phi_plus_cur(3) = phi_z_plus(i,j,k)
              grad_phi_minus_cur(1) = phi_x_minus(i,j,k)
              grad_phi_minus_cur(2) = phi_y_minus(i,j,k)
              grad_phi_minus_cur(3) = phi_z_minus(i,j,k)

c             { begin Godunov selection of grad_phi
              do dir=1,DIM

                if (phi_cur .gt. 0.d0) then
                  grad_phi_plus_cur(dir) = max(-grad_phi_plus_cur(dir),
     &                                         0.d0)
                  grad_phi_minus_cur(dir) = max(grad_phi_minus_cur(dir),
     &                                          0.d0)
                else
                  grad_phi_plus_cur(dir) =
     &              max(grad_phi_plus_cur(dir), 0.d0)
                  grad_phi_minus_cur(dir) =
     &              max(-grad_phi_minus_cur(dir), 0.d0)
                endif

                grad_phi_star(dir) = max(grad_phi_plus_cur(dir),
     &                                   grad_phi_minus_cur(dir))

              enddo
c             } end Godunov selection of grad_phi

c             compute reinit_rhs(i,j) using smoothed sgn(phi)
              if (abs(phi_cur) .ge. zero_tol) then
                norm_grad_phi_sq = grad_phi_star(1)*grad_phi_star(1)
     &                           + grad_phi_star(2)*grad_phi_star(2)
     &                           + grad_phi_star(3)*grad_phi_star(3)
                sgn_phi = phi_cur
     &                  / sqrt(phi_cur*phi_cur + norm_grad_phi_sq*dx_sq)
                reinit_rhs(i,j,k) =
     &            sgn_phi*(one - sqrt(norm_grad_phi_sq))
              else
                reinit_rhs(i,j,k) = 0.d0
              endif

            enddo
          enddo
        enddo
c       } end loop over grid

      else

c       ------------------------------------------------
c       use phi0 in computation of smoothed sgn function
c       ------------------------------------------------
c       { begin loop over grid
        do k=klo_fb,khi_fb
          do j=jlo_fb,jhi_fb
            do i=ilo_fb,ihi_fb

c             cache phi and spatial derivative approximations
              phi_cur = phi0(i,j,k)
              grad_phi_plus_cur(1) = phi_x_plus(i,j,k)
              grad_phi_plus_cur(2) = phi_y_plus(i,j,k)
              grad_phi_plus_cur(3) = phi_z_plus(i,j,k)
              grad_phi_minus_cur(1) = phi_x_minus(i,j,k)
              grad_phi_minus_cur(2) = phi_y_minus(i,j,k)
              grad_phi_minus_cur(3) = phi_z_minus(i,j,k)

c             { begin Godunov selection of grad_phi
              do dir=1,DIM

                if (phi_cur .gt. 0.d0) then
                  grad_phi_plus_cur(dir) = max(-grad_phi_plus_cur(dir),
     &                                         0.d0)
                  grad_phi_minus_cur(dir) = max(grad_phi_minus_cur(dir),
     &                                          0.d0)
                else
                  grad_phi_plus_cur(dir) =
     &              max(grad_phi_plus_cur(dir), 0.d0)
                  grad_phi_minus_cur(dir) =
     &              max(-grad_phi_minus_cur(dir), 0.d0)
                endif

                grad_phi_star(dir) = max(grad_phi_plus_cur(dir),
     &                                   grad_phi_minus_cur(dir))

              enddo
c             } end Godunov selection of grad_phi

c             compute reinit_rhs(i,j) using smoothed sgn(phi)
              if (abs(phi_cur) .ge. zero_tol) then
                norm_grad_phi_sq = grad_phi_star(1)*grad_phi_star(1)
     &                           + grad_phi_star(2)*grad_phi_star(2)
     &                           + grad_phi_star(3)*grad_phi_star(3)
                sgn_phi = phi_cur / sqrt(phi_cur*phi_cur + dx_sq)
                reinit_rhs(i,j,k) =
     &            sgn_phi*(one - sqrt(norm_grad_phi_sq))
              else
                reinit_rhs(i,j,k) = 0.d0
              endif

            enddo
          enddo
        enddo
c       } end loop over grid

      endif
c     } end condition on use_phi0_for_sgn

      return
      end
c } end subroutine
c***********************************************************************

c***********************************************************************
c
c  lsm3dComputeOrthogonalizationEqnRHS() computes the right-hand side
c  of the orthogonalization equation:
c
c    phi_t + grad(phi) dot { sgn(psi)/|grad(psi)| grad(psi) } = 0
c
c  Upwinding is used to select whether the forward (plus) or backward
c  (minus) spatial derivative should be used for grad(phi).  grad(psi)
c  is computed by averaging the forward and backward spatial derivatives
c  for grad(psi).  Forward and backward spatial derivatives used in the
c  calculation must be supplied by the user.
c
c  Arguments:
c    othro_rhs (out):        right-hand side of orthogonalization
c                            equation
c    psi (in):               data array for psi
c    phi_*_plus (in):        forward spatial derivatives for grad(phi)
c    phi_*_minus (in):       backward spatial derivatives for grad(phi)
c    psi_*_plus (in):        forward spatial derivatives for grad(psi)
c    psi_*_minus (in):       backward spatial derivatives for grad(psi)
c    *_gb (in):              index range for ghostbox
c    *_fb (in):              index range for fillbox
c
c***********************************************************************
      subroutine qss3dComputeOrthogonalizationEqnRHS(
     &  ortho_rhs,
     &  ilo_rhs_gb, ihi_rhs_gb,
     &  jlo_rhs_gb, jhi_rhs_gb,
     &  klo_rhs_gb, khi_rhs_gb,
     &  phi_x_plus, phi_y_plus, phi_z_plus,
     &  ilo_grad_phi_plus_gb, ihi_grad_phi_plus_gb,
     &  jlo_grad_phi_plus_gb, jhi_grad_phi_plus_gb,
     &  klo_grad_phi_plus_gb, khi_grad_phi_plus_gb,
     &  phi_x_minus, phi_y_minus, phi_z_minus,
     &  ilo_grad_phi_minus_gb, ihi_grad_phi_minus_gb,
     &  jlo_grad_phi_minus_gb, jhi_grad_phi_minus_gb,
     &  klo_grad_phi_minus_gb, khi_grad_phi_minus_gb,
     &  psi,
     &  ilo_psi_gb, ihi_psi_gb,
     &  jlo_psi_gb, jhi_psi_gb,
     &  klo_psi_gb, khi_psi_gb,
     &  psi_x_plus, psi_y_plus, psi_z_plus,
     &  ilo_grad_psi_plus_gb, ihi_grad_psi_plus_gb,
     &  jlo_grad_psi_plus_gb, jhi_grad_psi_plus_gb,
     &  klo_grad_psi_plus_gb, khi_grad_psi_plus_gb,
     &  psi_x_minus, psi_y_minus, psi_z_minus,
     &  ilo_grad_psi_minus_gb, ihi_grad_psi_minus_gb,
     &  jlo_grad_psi_minus_gb, jhi_grad_psi_minus_gb,
     &  klo_grad_psi_minus_gb, khi_grad_psi_minus_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dx, dy, dz)
c***********************************************************************
c { begin subroutine
      implicit none

c     _gb refers to ghostbox
c     _fb refers to fillbox
      integer ilo_rhs_gb, ihi_rhs_gb
      integer jlo_rhs_gb, jhi_rhs_gb
      integer klo_rhs_gb, khi_rhs_gb
      integer ilo_grad_phi_plus_gb, ihi_grad_phi_plus_gb
      integer jlo_grad_phi_plus_gb, jhi_grad_phi_plus_gb
      integer klo_grad_phi_plus_gb, khi_grad_phi_plus_gb
      integer ilo_grad_phi_minus_gb, ihi_grad_phi_minus_gb
      integer jlo_grad_phi_minus_gb, jhi_grad_phi_minus_gb
      integer klo_grad_phi_minus_gb, khi_grad_phi_minus_gb
      integer ilo_psi_gb, ihi_psi_gb
      integer jlo_psi_gb, jhi_psi_gb
      integer klo_psi_gb, khi_psi_gb
      integer ilo_grad_psi_plus_gb, ihi_grad_psi_plus_gb
      integer jlo_grad_psi_plus_gb, jhi_grad_psi_plus_gb
      integer klo_grad_psi_plus_gb, khi_grad_psi_plus_gb
      integer ilo_grad_psi_minus_gb, ihi_grad_psi_minus_gb
      integer jlo_grad_psi_minus_gb, jhi_grad_psi_minus_gb
      integer klo_grad_psi_minus_gb, khi_grad_psi_minus_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real ortho_rhs(ilo_rhs_gb:ihi_rhs_gb,
     &               jlo_rhs_gb:jhi_rhs_gb,
     &               klo_rhs_gb:khi_rhs_gb)
      real psi(ilo_psi_gb:ihi_psi_gb,
     &         jlo_psi_gb:jhi_psi_gb,
     &         klo_psi_gb:khi_psi_gb)
      real phi_x_plus(ilo_grad_phi_plus_gb:ihi_grad_phi_plus_gb,
     &                jlo_grad_phi_plus_gb:jhi_grad_phi_plus_gb,
     &                klo_grad_phi_plus_gb:khi_grad_phi_plus_gb)
      real phi_y_plus(ilo_grad_phi_plus_gb:ihi_grad_phi_plus_gb,
     &                jlo_grad_phi_plus_gb:jhi_grad_phi_plus_gb,
     &                klo_grad_phi_plus_gb:khi_grad_phi_plus_gb)
      real phi_z_plus(ilo_grad_phi_plus_gb:ihi_grad_phi_plus_gb,
     &                jlo_grad_phi_plus_gb:jhi_grad_phi_plus_gb,
     &                klo_grad_phi_plus_gb:khi_grad_phi_plus_gb)
      real phi_x_minus(ilo_grad_phi_minus_gb:ihi_grad_phi_minus_gb,
     &                 jlo_grad_phi_minus_gb:jhi_grad_phi_minus_gb,
     &                 klo_grad_phi_minus_gb:khi_grad_phi_minus_gb)
      real phi_y_minus(ilo_grad_phi_minus_gb:ihi_grad_phi_minus_gb,
     &                 jlo_grad_phi_minus_gb:jhi_grad_phi_minus_gb,
     &                 klo_grad_phi_minus_gb:khi_grad_phi_minus_gb)
      real phi_z_minus(ilo_grad_phi_minus_gb:ihi_grad_phi_minus_gb,
     &                 jlo_grad_phi_minus_gb:jhi_grad_phi_minus_gb,
     &                 klo_grad_phi_minus_gb:khi_grad_phi_minus_gb)
      real psi_x_plus(ilo_grad_psi_plus_gb:ihi_grad_psi_plus_gb,
     &                jlo_grad_psi_plus_gb:jhi_grad_psi_plus_gb,
     &                klo_grad_psi_plus_gb:khi_grad_psi_plus_gb)
      real psi_y_plus(ilo_grad_psi_plus_gb:ihi_grad_psi_plus_gb,
     &                jlo_grad_psi_plus_gb:jhi_grad_psi_plus_gb,
     &                klo_grad_psi_plus_gb:khi_grad_psi_plus_gb)
      real psi_z_plus(ilo_grad_psi_plus_gb:ihi_grad_psi_plus_gb,
     &                jlo_grad_psi_plus_gb:jhi_grad_psi_plus_gb,
     &                klo_grad_psi_plus_gb:khi_grad_psi_plus_gb)
      real psi_x_minus(ilo_grad_psi_minus_gb:ihi_grad_psi_minus_gb,
     &                 jlo_grad_psi_minus_gb:jhi_grad_psi_minus_gb,
     &                 klo_grad_psi_minus_gb:khi_grad_psi_minus_gb)
      real psi_y_minus(ilo_grad_psi_minus_gb:ihi_grad_psi_minus_gb,
     &                 jlo_grad_psi_minus_gb:jhi_grad_psi_minus_gb,
     &                 klo_grad_psi_minus_gb:khi_grad_psi_minus_gb)
      real psi_z_minus(ilo_grad_psi_minus_gb:ihi_grad_psi_minus_gb,
     &                 jlo_grad_psi_minus_gb:jhi_grad_psi_minus_gb,
     &                 klo_grad_psi_minus_gb:khi_grad_psi_minus_gb)
      real dx, dy, dz
      real dx_sq
      integer DIM
      parameter (DIM=3)
      real grad_psi_star(1:DIM)
      real norm_grad_psi
      real sgn_psi
      integer i,j,k
      real psi_zero_tol, grad_psi_zero_tol
      parameter (psi_zero_tol=1.e-5)
      parameter (grad_psi_zero_tol=1.e-5)
      real one, half
      parameter (one=1.d0,half=0.5d0)

c     set value of dx_sq to be square of max{dx,dy,dz}
      dx_sq = max(dx,dy,dz)
      dx_sq = dx_sq*dx_sq

c----------------------------------------------------
c      compute RHS of orthogonalization equation
c      using upwinding
c----------------------------------------------------

c     { begin loop over grid
      do k=klo_fb,khi_fb
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

c           average forward and backward derivatives of
c           grad(psi) to get grad_psi_star
            grad_psi_star(1) = half
     &                       * (psi_x_plus(i,j,k)+ psi_x_minus(i,j,k))
            grad_psi_star(2) = half
     &                       * (psi_y_plus(i,j,k)+ psi_y_minus(i,j,k))
            grad_psi_star(3) = half
     &                       * (psi_z_plus(i,j,k)+ psi_z_minus(i,j,k))

c           compute norm of grad(psi)
            norm_grad_psi = grad_psi_star(1)*grad_psi_star(1)
     &                    + grad_psi_star(2)*grad_psi_star(2)
     &                    + grad_psi_star(3)*grad_psi_star(3)
            norm_grad_psi = sqrt(norm_grad_psi)

c           compute ortho_rhs(i,j,k) using upwinding on sgn_psi*grad(psi)
            if ( (abs(psi(i,j,k)) .gt. psi_zero_tol) .and.
     &           (norm_grad_psi .gt. grad_psi_zero_tol) ) then

c             CASE: nontrivial psi and grad(psi)

              sgn_psi = psi(i,j,k)/sqrt( psi(i,j,k)*psi(i,j,k)
     &                                 + dx_sq*norm_grad_psi**2)

              ortho_rhs(i,j,k) = -1.d0/norm_grad_psi
     &          * ( max(sgn_psi*grad_psi_star(1),0.d0)
     &                         *phi_x_minus(i,j,k)
     &            + min(sgn_psi*grad_psi_star(1),0.d0)
     &                          *phi_x_plus(i,j,k)
     &            + max(sgn_psi*grad_psi_star(2),0.d0)
     &                          *phi_y_minus(i,j,k)
     &            + min(sgn_psi*grad_psi_star(2),0.d0)
     &                          *phi_y_plus(i,j,k)
     &            + max(sgn_psi*grad_psi_star(3),0.d0)
     &                          *phi_z_minus(i,j,k)
     &            + min(sgn_psi*grad_psi_star(3),0.d0)
     &                          *phi_z_plus(i,j,k) )
            else

c             CASE: grad(psi) = 0 or psi = 0

              ortho_rhs(i,j,k) = 0.d0

            endif

          enddo
        enddo
      enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************

c***********************************************************************
      subroutine qss3dComputeDistanceForSubcellFix(
     &  distance0,
     &  phi0,
     &  ilo_phi0_gb, ihi_phi0_gb, jlo_phi0_gb, jhi_phi0_gb,
     &  klo_phi0_gb, khi_phi0_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dx, dy, dz)
c***********************************************************************
c { begin subroutine
      implicit none

c     _gb refers to ghostbox
c     _fb refers to fillbox
      integer ilo_phi0_gb, ihi_phi0_gb, jlo_phi0_gb, jhi_phi0_gb
      integer klo_phi0_gb, khi_phi0_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real distance0(ilo_phi0_gb:ihi_phi0_gb,
     &               jlo_phi0_gb:jhi_phi0_gb,
     &               klo_phi0_gb:khi_phi0_gb)
      real phi0(ilo_phi0_gb:ihi_phi0_gb,
     &          jlo_phi0_gb:jhi_phi0_gb,
     &          klo_phi0_gb:khi_phi0_gb)
      real dx, dy, dz, max_dx
      real zero_tol, zero
      parameter (zero_tol=1.e-5)
      parameter (zero=0.d0)
      real large_distance_flag
      real near_plus_x, near_minus_x
      real near_plus_y, near_minus_y
      real near_plus_z, near_minus_z
      logical near
      real d1, d2, d3, delta
      integer i,j,k

      max_dx = max(dx,dy,dz);
      large_distance_flag = -1000.d0*max_dx;

c       { begin loop over grid
        do k=klo_fb,khi_fb
         do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

            near = ( phi0(i+1,j,k) .gt. zero .and.
     &               phi0(i,j,k)   .le. zero ) .or.
     &             ( phi0(i+1,j,k) .le. zero .and.
     &	             phi0(i,j,k)   .gt. zero ) .or.
     &             ( phi0(i-1,j,k) .gt. zero .and.
     &               phi0(i,j,k)   .le. zero ) .or.
     &             ( phi0(i-1,j,k) .le. zero .and.
     &	             phi0(i,j,k)   .gt. zero ) .or.

     &             ( phi0(i,j+1,k) .gt. zero .and.
     &               phi0(i,j,k)   .le. zero ) .or.
     &             ( phi0(i,j+1,k) .le. zero .and.
     &	             phi0(i,j,k)   .gt. zero ) .or.
     &             ( phi0(i,j-1,k) .gt. zero .and.
     &               phi0(i,j,k)   .le. zero ) .or.
     &             ( phi0(i,j-1,k) .le. zero .and.
     &	             phi0(i,j,k)   .gt. zero ) .or.

     &             ( phi0(i,j,k+1) .gt. zero .and.
     &               phi0(i,j,k)   .le. zero ) .or.
     &             ( phi0(i,j,k+1) .le. zero .and.
     &	             phi0(i,j,k)   .gt. zero ) .or.
     &             ( phi0(i,j,k-1) .gt. zero .and.
     &               phi0(i,j,k)   .le. zero ) .or.
     &             ( phi0(i,j,k-1) .le. zero .and.
     &	             phi0(i,j,k)   .gt. zero );

	   if( near .eqv. .false. ) then
	     distance0(i,j,k) = large_distance_flag;
	   else
c version 1
c	      d1 = phi0(i+1,j,k) - phi0(i-1,j,k);
c	      d2 = phi0(i,j+1,k) - phi0(i,j-1,k);
c	      d3 = phi0(i,j,k+1) - phi0(i,j,k-1);
c	      delta  = sqrt( d1*d1 + d2*d2 + d3*d3 +zero_tol);

c version 2 - (Russo/Smereka)
              d1 = abs(phi0(i+1,j,k) - phi0(i-1,j,k))/2.d0;
	      d2 = abs(phi0(i+1,j,k) - phi0(i,j,k));
	      d3 = abs(phi0(i,j,k)   - phi0(i-1,j,k));
	      delta = max(d1,d2,d3,zero_tol);

	      d1 = abs(phi0(i,j+1,k) - phi0(i,j-1,k))/2.d0;
	      d2 = abs(phi0(i,j+1,k) - phi0(i,j,k));
	      d3 = abs(phi0(i,j,k)   - phi0(i,j-1,k));
	      delta = max(d1,d2,d3,delta);

	      d1 = abs(phi0(i,j,k+1) - phi0(i,j,k-1))/2.d0;
	      d2 = abs(phi0(i,j,k+1) - phi0(i,j,k));
	      d3 = abs(phi0(i,j,k)   - phi0(i,j,k-1));
	      delta = max(d1,d2,d3,delta);

              distance0(i,j,k) = phi0(i,j,k)/delta;
	   endif

	  enddo
	 enddo
        enddo
c       } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************

c***********************************************************************
      subroutine qss3dComputeReinitializationEqnRHSSubcellFixOrder1(
     &  reinit_rhs,
     &  phi,
     &  ilo_phi_gb, ihi_phi_gb, jlo_phi_gb, jhi_phi_gb,
     &  klo_phi_gb, khi_phi_gb,
     &  phi0, distance0,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb,klo_fb, khi_fb,
     &  dx, dy, dz)
c***********************************************************************
c { begin subroutine
      implicit none

c     _gb refers to ghostbox
c     _fb refers to fillbox
      integer ilo_phi_gb, ihi_phi_gb, jlo_phi_gb, jhi_phi_gb
      integer klo_phi_gb, khi_phi_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real reinit_rhs(ilo_phi_gb:ihi_phi_gb,
     &                jlo_phi_gb:jhi_phi_gb,
     &                klo_phi_gb:khi_phi_gb)
      real phi(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real phi0(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real distance0(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real phi_x_plus
      real phi_y_plus
      real phi_z_plus
      real phi_x_minus
      real phi_y_minus
      real phi_z_minus
      real dx, dy, dz, max_dx
      real phi_cur
      integer DIM
      parameter (DIM=3)
      real grad_phi_plus_cur(1:DIM)
      real grad_phi_minus_cur(1:DIM)
      real grad_phi_star(1:DIM)
      integer i,j,k
      integer dir
      real sgn_phi0
      real norm_grad_phi_sq
      real dx_sq
      real zero_tol
      parameter (zero_tol=1.e-5)
      real one, zero, large_distance_flag
      parameter (one=1.d0,  zero=0.d0)

      real D1_x, D1_x_plus, D2_x, D2_x_plus, D2_x_minus
      real D1_y, D1_y_plus, D2_y, D2_y_plus, D2_y_minus
      real D1_z, D1_z_plus, D2_z, D2_z_plus, D2_z_minus

      real inv_dx, inv_dy, inv_dz

c     set value of dx_sq to be square of max{dx,dy}
      max_dx = max(dx,dy,dz)
      large_distance_flag = -1000.d0*max_dx;

c     compute inv_dx, inv_dy, and inv_dz
      inv_dx = 1.0d0/dx
      inv_dy = 1.0d0/dy
      inv_dz = 1.0d0/dz

      dx_sq = max_dx*max_dx

c----------------------------------------------------
c      compute RHS of reinitialization equation
c      using Godunov's method with subcell fix near interface
c----------------------------------------------------

c       { begin loop over grid
      do k=klo_fb,khi_fb
       do j=jlo_fb,jhi_fb
        do i=ilo_fb,ihi_fb

c           phi_x_plus, minus
            D1_x = phi(i,j,k) - phi(i-1,j,k)
            D1_x_plus = phi(i+1,j,k) - phi(i,j,k)
            phi_x_plus = (D1_x_plus)*inv_dx
            phi_x_minus = (D1_x)*inv_dx

c           phi_y_plus, minus
            D1_y = phi(i,j,k) - phi(i,j-1,k)
            D1_y_plus = phi(i,j+1,k) - phi(i,j,k)
            phi_y_plus = (D1_y_plus)*inv_dy
            phi_y_minus = (D1_y)*inv_dy

c           phi_z_plus, minus
            D1_z = phi(i,j,k) - phi(i,j,k-1)
            D1_z_plus = phi(i,j,k+1) - phi(i,j,k)
            phi_z_plus = (D1_z_plus)*inv_dz
            phi_z_minus = (D1_z)*inv_dz

	      if (abs(phi0(i,j,k)) .gt. zero_tol) then
	        sgn_phi0 = sign(one,phi0(i,j,k));
	      else
	        sgn_phi0 = zero;
	      endif

          if( distance0(i,j,k) .eq. large_distance_flag ) then
c           Away from interface we do standard Godunov gradient selection
c             cache phi and spatial derivative approximations
             phi_cur = phi(i,j,k)
             grad_phi_plus_cur(1) = phi_x_plus
             grad_phi_plus_cur(2) = phi_y_plus
             grad_phi_plus_cur(3) = phi_z_plus
             grad_phi_minus_cur(1) = phi_x_minus
             grad_phi_minus_cur(2) = phi_y_minus
             grad_phi_minus_cur(3) = phi_z_minus

c             { begin Godunov selection of grad_phi
             do dir=1,DIM
               if (phi_cur .gt. 0.d0) then
                grad_phi_plus_cur(dir)=max(-grad_phi_plus_cur(dir),
     &                                         0.d0)
                grad_phi_minus_cur(dir)=max(grad_phi_minus_cur(dir),
     &                                          0.d0)
               else
                 grad_phi_plus_cur(dir) =
     &              max(grad_phi_plus_cur(dir), 0.d0)
                 grad_phi_minus_cur(dir) =
     &              max(-grad_phi_minus_cur(dir), 0.d0)
               endif

               grad_phi_star(dir) = max(grad_phi_plus_cur(dir),
     &                                  grad_phi_minus_cur(dir))

             enddo
c             } end Godunov selection of grad_phi

c           compute reinit_rhs(i,j,k) - no need for smoothing since
c           we're away from the interface
            if (abs(phi_cur) .gt. zero_tol) then
               norm_grad_phi_sq = grad_phi_star(1)*grad_phi_star(1)
     &                          + grad_phi_star(2)*grad_phi_star(2)
     &                          + grad_phi_star(3)*grad_phi_star(3)

	           reinit_rhs(i,j,k) = sgn_phi0 - sgn_phi0*
     &                  	            sqrt(norm_grad_phi_sq)
            else
               reinit_rhs(i,j,k) = 0.d0
            endif
          else

c        Close to the interface make sure you don't use information from
c        the other side of the interface (Russo/Smereka 2000. subcell fix)
	      reinit_rhs(i,j,k) = distance0(i,j,k) -
     &                       sgn_phi0*abs(phi(i,j,k))/max_dx;
	      endif

        enddo
       enddo
      enddo
c       } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************


!
!    Copyright 2011 Sebastian Heimann
!
!    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.
!

program eulermt

    use euler
    use orthodrome

    implicit none

    real dip, strike, rake
    real, dimension(3,3) :: m_unrot = reshape((/0,0,-1,0,0,0,-1,0,0/),(/3,3/))
    real, dimension(3,3) :: m_rot, trotmat, rotmat, m_use
    real, dimension(3,3) :: ned2use = reshape((/0,0,-1,-1,0,0,0,1,0/),(/3,3/))
    real, dimension(3,3) :: use2ned
    integer :: iostat

    use2ned = transpose( ned2use )

    do  ! until end-of-file on stdin

        read (unit=*,fmt=*,iostat=iostat) strike, dip, rake
        if (iostat /= 0) exit

        call init_euler(d2r(dip),d2r(strike),d2r(-rake), rotmat)
        trotmat = transpose(rotmat)
        m_rot = matmul( rotmat, matmul( m_unrot, trotmat ) )

        write (*,'(6g15.5)') m_rot(1,1), m_rot(2,2), m_rot(3,3), m_rot(1,2), m_rot(1,3), m_rot(2,3)

        m_use = matmul( ned2use, matmul( m_rot, use2ned ) )

        write (*,'(6g15.5)') m_use(1,1), m_use(2,2), m_use(3,3), m_use(1,2), m_use(1,3), m_use(2,3)

    end do

end program


c data are 89345 hourly values (10 years) in file hourly_stl_test.csv
      real y(89345), season(89345), trend(89345), rw(89345)
      real work(106817,7)
      real start, finish
      logical robust
      read(5,*)(y(i), i=1, 89345)
      n=89345
      np=8736
      ns=893451
      nt=13105
      nl=8737
      no=0
      ni=2
      nsjump=89346
      ntjump=1311
      nljump=874
      isdeg=0
      itdeg=1
      ildeg=1
      iterations = 100

      call cpu_time(start)

      do 1001 i = 1, iterations

         call stl(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,
     &        nljump,ni,no,rw,season, trend, work)

 1001 continue

      call cpu_time(finish)

      print '("Time = ",f6.3," ms.")', 1000.0 * (finish-start)
     &     / iterations

      open(unit=99, file="output.csv", status='replace')

      do 2002 i = 1, 89345
         d = y(i)
         s = season(i)
         t = trend(i)
         r = y(i) - season(i) - trend(i)
         write(unit=99,  FMT="(1x, E24.16, (3(',',E24.16)))") d, s, t, r
 2002 continue

      close(unit=99)

      end


MODULE GENERALTOOLS

CONTAINS

SUBROUTINE INTERPLTN(ND,NG,CO,AC,OC)
!*************************************************
! CALCULATE THE INTERPOLATING COEFFICENT (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
! 2     , 3     , 5     , 9
! 2**0+1, 2**1+1, 2**2+1, 2**3+1
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J
  INTEGER , INTENT(IN)  :: ND,NG
  REAL    , INTENT(IN)  :: AC(ND,NG),OC(ND)
  REAL    , INTENT(OUT) :: CO(NG)
  REAL                  :: DD(ND,NG),DC(ND)
! --------------------
! DECLARE:
!        'ND' IS THE NUMBER OF DIMENSIONS OF THE FIELD
!        'NG' IS THE NUMBER OF GRIDPOINTS NEIGHBOR TO THE POSITION, WHICH IS TO BE INTERPOLATED, NG IS EQUAL TO 2**ND
!        'CO' IS THE INTERPOLATING COEFFICIENTS.
!        'OC' IS THE POSITION WHERE TO BE INTERPOLATED
!        'AC' IS THE INDEX OF THE GRIDPOINTS, WHICH IS NEIGHBOR TO THE POSITIOIN
! --------------------
  DO I=1,ND
    IF((OC(I)-AC(I,1))*(OC(I)-AC(I,2**(I-1)+1)).GT.0.0) THEN
      PRINT*,'INTERPLTN: OC IS NOT IN THE DOMAIN ',I,OC(I),AC(I,1),AC(I,2**(I-1)+1)
      STOP
    ENDIF
  ENDDO
  DO I=1,ND
    DO J=1,NG
      DD(I,J)=AC(I,J)-OC(I)
    ENDDO
    DC(I)=ABS(AC(I,2**(I-1)+1)-AC(I,1))
!    IF(DC(I).LE.0.0)STOP 'GRID ARRANGE WRONG!!!'            ! omitted by zhongjie he
  ENDDO
  DO I=1,ND
    IF(DC(I).NE.0) THEN
      DO J=1,NG
        DD(I,J)=DD(I,J)/DC(I)
        IF(DD(I,J).GT.0.0)THEN
          DD(I,J)=DD(I,J)-1.0
        ELSE
          DD(I,J)=DD(I,J)+1.0
        ENDIF
        DD(I,J)=ABS(DD(I,J))
      ENDDO
    ELSE                                     !     added by zhongjie he
      DO J=1,NG
        DD(I,J)=1.
      ENDDO
    ENDIF
  ENDDO
  DO J=1,NG
    CO(J)=1.0
    DO I=1,ND
      CO(J)=CO(J)*DD(I,J)
    ENDDO
  ENDDO
  RETURN
END SUBROUTINE INTERPLTN

SUBROUTINE INTERPLTN_XIE(ND,NG,CO,AC,OC,IP,NP,PV)
!*************************************************
! CALCULATE THE INTERPOLATING COEFFICENT (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!
!          MARCH 31, 2009 BY YUANFU XIE FOR LOG(P)
!          INTERPOLATION.
!*************************************************
! 2     , 3     , 5     , 9
! 2**0+1, 2**1+1, 2**2+1, 2**3+1
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,K1
  INTEGER , INTENT(IN)  :: ND,NG,IP,NP
  REAL    , INTENT(IN)  :: AC(ND,NG),OC(ND),PV(NP)
  REAL    , INTENT(OUT) :: CO(NG)
  REAL                  :: DD(ND,NG),DC(ND),P
! --------------------
! DECLARE:
!        'ND' IS THE NUMBER OF DIMENSIONS OF THE FIELD
!        'NG' IS THE NUMBER OF GRIDPOINTS NEIGHBOR TO THE POSITION, WHICH IS TO BE INTERPOLATED, NG IS EQUAL TO 2**ND
!        'CO' IS THE INTERPOLATING COEFFICIENTS.
!        'OC' IS THE POSITION WHERE TO BE INTERPOLATED
!        'AC' IS THE INDEX OF THE GRIDPOINTS, WHICH IS NEIGHBOR TO THE POSITIOIN
! --------------------
  DO I=1,ND
    IF((OC(I)-AC(I,1))*(OC(I)-AC(I,2**(I-1)+1)).GT.0.0) THEN
      PRINT*,'INTERPLTN: OC IS NOT IN THE DOMAIN ',I,OC(I),AC(I,1),AC(I,2**(I-1)+1)
      STOP
    ENDIF
  ENDDO
  DO I=1,ND
    DO J=1,NG
      DD(I,J)=AC(I,J)-OC(I)
    ENDDO
    DC(I)=ABS(AC(I,2**(I-1)+1)-AC(I,1))
  ENDDO
  DO I=1,ND
    IF(DC(I).NE.0) THEN
      DO J=1,NG
        DD(I,J)=DD(I,J)/DC(I)
        IF(DD(I,J).GT.0.0)THEN
          ! LOG(P):
          IF (I .EQ. IP) THEN
            K1 = AC(I,J)
            IF (K1 .LE. 1) THEN
              DD(I,J) = 0.0
            ELSE
              K = K1-1
              P = PV(K)*DD(I,J)+(1.0-DD(I,J))*PV(K+1)
              DD(I,J) = (LOG(P)-LOG(PV(k)))/(LOG(PV(K1))-LOG(PV(K)))
            ENDIF
          ELSE
            DD(I,J)=DD(I,J)-1.0
          ENDIF
        ELSE
          IF (I .EQ. IP) THEN
            K = AC(I,J)
            IF (K .GE. NP) THEN
              DD(I,J) = 1.0
            ELSE
              K1 = K+1
              P = (1.0+DD(I,J))*PV(K)-DD(I,J)*PV(K1)
              DD(I,J) = (LOG(PV(K1))-LOG(P))/(LOG(PV(K1))-LOG(PV(K)))
            ENDIF
          ELSE
            DD(I,J)=DD(I,J)+1.0
          ENDIF
        ENDIF
        DD(I,J)=ABS(DD(I,J))
      ENDDO
    ELSE                                     !     added by zhongjie he
      DO J=1,NG
        DD(I,J)=1.
      ENDDO
    ENDIF
  ENDDO

  DO J=1,NG
    CO(J)=1.0
    DO I=1,ND
      CO(J)=CO(J)*DD(I,J)
    ENDDO
  ENDDO
  RETURN
END SUBROUTINE INTERPLTN_XIE

SUBROUTINE GDERIVEIT(Z1,Z2,Z3,A,B,C)
!*************************************************
! GENERAL DERIVATIVE OF INTERIOR (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  REAL  :: X,Y
  REAL , INTENT(IN)  :: Z1,Z2,Z3
  REAL , INTENT(OUT) :: A,B,C
! --------------------
  X=Z2-Z1
  Y=Z3-Z2
  A=-Y/(X*X+X*Y)
  B=(-X+Y)/(X*Y)
  C=X/(X*Y+Y*Y)
  RETURN
END SUBROUTINE GDERIVEIT

SUBROUTINE GDERIVELB(Z1,Z2,Z3,A,B,C)
!*************************************************
! GENERAL DERIVATIVE OF LEFT BOUNDARY (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  REAL  :: X,Y
  REAL , INTENT(IN)  :: Z1,Z2,Z3
  REAL , INTENT(OUT) :: A,B,C
! --------------------
  X=Z2-Z1
  Y=Z3-Z2
  A=(-2.0*X-Y)/(X*X+X*Y)
  B=(X+Y)/(X*Y)
  C=-X/(X*Y+Y*Y)
  RETURN
END SUBROUTINE GDERIVELB

SUBROUTINE GDERIVERB(Z1,Z2,Z3,A,B,C)
!*************************************************
! GENERAL DERIVATIVE OF RIGHT BOUNDARY (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  REAL  :: X,Y
  REAL , INTENT(IN)  :: Z1,Z2,Z3
  REAL , INTENT(OUT) :: A,B,C
! --------------------
  X=Z2-Z1
  Y=Z3-Z2
  A=Y/(X*X+X*Y)
  B=(-X-Y)/(X*Y)
  C=(X+2.0*Y)/(X*Y+Y*Y)
  RETURN
END SUBROUTINE GDERIVERB

SUBROUTINE G2ORDERIT(Z1,Z2,Z3,A,B,C)
!*************************************************
! GENERAL 2-ORDER DERIVATIVE OF INTERIOR (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  REAL  :: X,Y
  REAL , INTENT(IN)  :: Z1,Z2,Z3
  REAL , INTENT(OUT) :: A,B,C
! --------------------
  X=Z2-Z1
  Y=Z3-Z2
  A=2.0/(X*X+X*Y)
  B=-2.0/(X*Y)
  C=2.0/(X*Y+Y*Y)
  RETURN
END SUBROUTINE G2ORDERIT

SUBROUTINE PSTN2NUMB(NN,NP,NM,NC)
!*************************************************
! TRANSFORM POSITION TO NUMBER (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER               :: PT,M,N
  INTEGER , INTENT(IN)  :: NN
  INTEGER , INTENT(IN)  :: NP(NN),NM(NN)
  INTEGER , INTENT(OUT) :: NC
! --------------------
! DECLARE:
!        'NN' IS THE NUMBER OF DIMENSIONS OF THE FIELD
!        'NP' IS THE INDEX OF THE GRIDPOINT AT EACH DIMENSION
!        'NM' IS THE TOTAL GRID NUMBER OF EACH DIMENSIOIN
!        'NC' IS THE INDEX OF THE GRIDPOINT, WHEN THE FIELD IS TRANSLATED TO A 1 DIMENSIONAL FILED
! --------------------
  NC=NP(1)
  IF(NN.EQ.1)RETURN
  DO N=2,NN
    PT=NP(N)-1
    DO M=1,N-1
      PT=PT*NM(M)
    ENDDO
    NC=NC+PT
  ENDDO
  RETURN
END SUBROUTINE PSTN2NUMB

SUBROUTINE NUMB2PSTN(NN,NP,NM,NC)
!*************************************************
! TRANSFORM NUMBER TO POSITION (GENERAL) (NOT USED)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER               :: N,N0
  INTEGER , INTENT(IN)  :: NN,NC
  INTEGER , INTENT(IN)  :: NM(NN)
  INTEGER , INTENT(OUT) :: NP(NN)
! --------------------
! DECLARE:
!        'NN' IS THE NUMBER OF DIMENSIONS OF THE FIELD
!        'NP' IS THE INDEX OF THE GRIDPOINT AT EACH DIMENSION, WHEN THE FIELD IS TRANSLATED TO A NN DIMENSIONAL FILED
!        'NM' IS THE TOTAL GRID NUMBER OF EACH DIMENSIOIN
!        'NC' IS THE INDEX OF THE GRIDPOINT IN THE 1 DIMENSIONAL FIELD
! --------------------
  N0=NC
  NP(1)=MOD(N0,NM(1))
  IF(NP(1).EQ.0)NP(1)=NM(1)
  IF(NN.EQ.1)RETURN
  DO N=2,NN
    N0=(N0-NP(N-1))/NM(N-1)+1
    NP(N)=MOD(N0,NM(N))
    IF(NM(N).EQ.1)NP(N)=1
    IF(NP(N).EQ.0)NP(N)=NM(N)
  ENDDO
  RETURN
END SUBROUTINE NUMB2PSTN

SUBROUTINE VRTCLPSTN8(KM,LM,PP,P,PS,IS)
!*************************************************
! GET VERTICAL POSITION (GENERAL)
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: K
  INTEGER ,INTENT(IN)  :: KM
  REAL ,   INTENT(IN)  :: PP(KM)
  REAL ,   INTENT(IN)  :: P,LM
  REAL ,   INTENT(OUT) :: PS
  INTEGER ,INTENT(OUT) :: IS
! --------------------
! DECLARE:
!        'KM' IS THE NUMBER OF LEVELS OF THE FIELD
!        'PP' IS THE PRESURE OF EACH LEVEL
!        'P'  IS THE PRESURE OF THE POSITION, WHICH WE WANT TO GET ITS INDEX IN THE VERTICAL COORDINATE
!        'PS' IS THE INDEX OF THE POINT IN THE VERTICAL COORDINATE
!        'IS' IS THE STATE OF THE RESULT OF THIS SUBROUTINE, 0 MEANS WRONG, 1 MEANS OK
!        'LM' IS A LIMITATION TO DECIDE WHETHER THE OBSERVATION IS AVAILABLE (JUST USED FOR THE CASE: KM=1)
! --------------------
  IS=0
  IF(KM.GE.2) THEN
    DO K=1,KM-1
      IF((P-PP(K))*(P-PP(K+1)).GT.0.0)CYCLE
      PS=K+ABS(P-PP(K))/ABS(PP(K+1)-PP(K))
      IS=1
    ENDDO
  ELSEIF(KM.EQ.1) THEN
    IF(ABS(P-PP(1)).LE.LM) THEN
      PS=1
      IS=1
    ENDIF
  ENDIF
  RETURN
END SUBROUTINE VRTCLPSTN8

SUBROUTINE VRTCLPSTN(KM,LM,PP,P,PS,IS)
!*************************************************
! GET VERTICAL POSITION (GENERAL)
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: K
  INTEGER ,INTENT(IN)  :: KM
  REAL ,   INTENT(IN)  :: PP(KM),P,LM
  REAL ,   INTENT(OUT) :: PS
  INTEGER ,INTENT(OUT) :: IS
! --------------------
! DECLARE:
!        'KM' IS THE NUMBER OF LEVELS OF THE FIELD
!        'PP' IS THE PRESURE OF EACH LEVEL
!        'P'  IS THE PRESURE OF THE POSITION, WHICH WE WANT TO GET ITS INDEX IN THE VERTICAL COORDINATE
!        'PS' IS THE INDEX OF THE POINT IN THE VERTICAL COORDINATE
!        'IS' IS THE STATE OF THE RESULT OF THIS SUBROUTINE, 0 MEANS WRONG, 1 MEANS OK
!        'LM' IS A LIMITATION OF PREESURE TO DECIDE WHETHER THE OBSERVATION IS AVAILABLE (JUST USED FOR THE CASE: KM=1)
! --------------------
  IS=0
  IF(KM.GE.2) THEN
    DO K=1,KM-1
      IF((P-PP(K))*(P-PP(K+1)).GT.0.0)CYCLE
      PS=K+ABS(P-PP(K))/ABS(PP(K+1)-PP(K))
      IS=1
    ENDDO
  ELSEIF(KM.EQ.1) THEN
    IF(ABS(P-PP(1)).LE.LM) THEN
      PS=1
      IS=1
    ENDIF
  ENDIF

  RETURN
END SUBROUTINE VRTCLPSTN

SUBROUTINE ZPCONVERT(KM,ZZ,PP,Z,P,IS)
!*************************************************
! FIND PRESSURE FROM HEIGHT (GENERAL)
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER              :: K
  INTEGER ,INTENT(IN)  :: KM
  REAL ,   INTENT(IN)  :: ZZ(KM),Z
  REAL ,   INTENT(IN)  :: PP(KM)
  REAL ,   INTENT(OUT) :: P
  INTEGER ,INTENT(OUT) :: IS
! --------------------
! DECLARE:
!        'KM' IS THE NUMBER OF LEVELS OF THE FIELD
!        'ZZ' IS THE HEIGHT OF EACH LEVEL
!        'PP' IS THE PRESURE OF EACH LEVEL
!        'Z'  IS THE HEIGHT OF POINT, WHICH WE WANT TO GET ITS PRESURE
!        'P'  IS THE PRESURE CALCULATED FROM THE ZZ, PP, AND Z
!        'IS' IS THE STATE OF THE RESULT OF THIS SUBROUTINE, 0 MEANS WRONG, 1 MEANS OK
! --------------------
  IS=0
  DO K=1,KM-1
    IF((Z-ZZ(K))*(Z-ZZ(K+1)).GT.0.0)CYCLE
    P=PP(K)*ABS(ZZ(K+1)-Z)/ABS(ZZ(K+1)-ZZ(K))+PP(K+1)*ABS(Z-ZZ(K))/ABS(ZZ(K+1)-ZZ(K))
    IS=1
  ENDDO
  RETURN
END SUBROUTINE ZPCONVERT

SUBROUTINE FCST2BKGD(ND,NG,NS,NF,XF,YF,ZF,TF,NB,XB,YB,ZB,TB,FC,BK)
!*************************************************
! INTERPOLATE MODEL FORECAST TO BACKGROUND USED IN ANALYZING (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER , PARAMETER  :: MD=4
  INTEGER , INTENT(IN) :: ND,NG,NS
  INTEGER , INTENT(IN) :: NF(MD),NB(MD)
  REAL    , INTENT(IN) :: XF(NF(1)),YF(NF(2)),ZF(NF(3)),TF(NF(4))
  REAL    , INTENT(IN) :: XB(NB(1)),YB(NB(2)),ZB(NB(3)),TB(NB(4))
  REAL    , INTENT(IN) :: FC(NF(1),NF(2),NF(3),NF(4),NS)
  INTEGER              :: I,J,K,L,I0,J0,K0,L0,I1,J1,K1,L1,S,M,N,NN
  REAL                 :: PP(MD)
  REAL                 :: AC(ND,NG),OC(ND),CO(NG)
  REAL    , INTENT(OUT):: BK(NB(1),NB(2),NB(3),NB(4),NS)
  INTEGER              :: LM(ND)
! --------------------
! DECLARE:
!        'ND' IS THE NUMBER OF DIMENSIONS OF THE FIELD
!        'NG' IS THE NUMBER OF GRIDPOINTS NEIGHBOR TO THE POSITION, WHICH IS TO BE INTERPOLATED, NG IS EQUAL TO 2**ND
!        'NS' IS THE NUMBER OF VARIABLES THAT TO BE INTERPOLATED
!        'NF' THE GRID NUMBER OF THE ORIGINAL FIELD
!        'NB' THE GRID NUMBER OF THE TARGET FIELD
!        'XF', 'YF', 'ZF' AND 'TF' ARE THE SCALES OF THE ORIGINAL FILED IN THE X, Y, Z AND T COORDINATES RESPECTIVELY
!        'XB', 'YB', 'ZB' AND 'TB' ARE THE SCALES OF THE TARGET FIELD N THE X, Y, Z AND T COORDINATES
!        'FC' THE ORIGINAL FIELD
!        'BK' THE TARGET FIELD
!        'CO' IS THE INTERPOLATING COEFFICIENTS.
!        'OC' IS THE POSITION WHERE TO BE INTERPOLATED
!        'AC' IS THE INDEX OF THE GRIDPOINTS, WHICH IS NEIGHBOR TO THE POSITIOIN
! --------------------
  DO L=1,NB(4)
  DO K=1,NB(3)
  DO J=1,NB(2)
  DO I=1,NB(1)
    CALL CHECKPSTN(NF(1),XF,XB(I),I0)
    CALL CHECKPSTN(NF(2),YF,YB(J),J0)
    CALL CHECKPSTN(NF(3),ZF,ZB(K),K0)
    CALL CHECKPSTN(NF(4),TF,TB(L),L0)
    IF(I0.EQ.0.OR.J0.EQ.0.OR.K0.EQ.0.OR.L0.EQ.0)STOP 'BACKGOUND CAN NOT BE GENERATED'
    M=0
!===============================================
!    DO L1=L0,MIN0(L0+1,NF(4))
!    DO K1=K0,MIN0(K0+1,NF(3))
!    DO J1=J0,MIN0(J0+1,NF(2))
!    DO I1=I0,MIN0(I0+1,NF(1))
!      M=M+1
!      PP(1)=XF(I1)
!      PP(2)=YF(J1)
!      PP(3)=ZF(K1)
!      PP(4)=TF(L1)
!      NN=0
!      DO N=1,MD
!        IF(NF(N).GE.2)THEN
!          NN=NN+1
!          AC(NN,M)=PP(N)
!        ENDIF
!      ENDDO
!    ENDDO
!    ENDDO
!    ENDDO
!    ENDDO
!================ modified by zhongjie he =====
    LM(1)=I0+1
    LM(2)=J0+1
    LM(3)=K0+1
    LM(4)=L0+1
    DO N=1,ND
      IF(ND.LT.N) LM(N)=LM(N)-1
    ENDDO
    DO L1=L0,LM(4)
    DO K1=K0,LM(3)
    DO J1=J0,LM(2)
    DO I1=I0,LM(1)
      M=M+1
      PP(1)=XF(MIN0(I1,NF(1)))
      PP(2)=YF(MIN0(J1,NF(3)))
      PP(3)=ZF(MIN0(K1,NF(2)))
      PP(4)=TF(MIN0(L1,NF(1)))
      NN=0
      DO N=1,MD
        IF(NF(N).GE.2)THEN
          NN=NN+1
          AC(NN,M)=PP(N)
        ENDIF
      ENDDO
    ENDDO
    ENDDO
    ENDDO
    ENDDO
!===============================================
    PP(1)=XB(I)
    PP(2)=YB(J)
    PP(3)=ZB(K)
    PP(4)=TB(L)
    NN=0
    DO N=1,MD
      IF(NF(N).GE.2)THEN
        NN=NN+1
        OC(NN)=PP(N)
      ENDIF
    ENDDO
    CALL INTERPLTN(ND,NG,CO,AC,OC)
    DO S=1,NS
      M=0
      BK(I,J,K,L,S)=0.0
      DO L1=L0,MIN0(L0+1,NF(4))
      DO K1=K0,MIN0(K0+1,NF(3))
      DO J1=J0,MIN0(J0+1,NF(2))
      DO I1=I0,MIN0(I0+1,NF(1))
        M=M+1
        BK(I,J,K,L,S)=BK(I,J,K,L,S)+CO(M)*FC(I1,J1,K1,L1,S)
      ENDDO
      ENDDO
      ENDDO
      ENDDO
    ENDDO
  ENDDO
  ENDDO
  ENDDO
  ENDDO
  RETURN
END SUBROUTINE FCST2BKGD

SUBROUTINE CHECKPSTN(KM,ZZ,Z,KZ)
!*************************************************
! FIND THE POSITION (GENERAL)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: K
  INTEGER , INTENT(IN)  :: KM
  REAL    , INTENT(IN)  :: ZZ(KM),Z
  INTEGER , INTENT(OUT) :: KZ
! --------------------
  KZ=0
  IF(KM.EQ.1.AND.ZZ(1).EQ.Z)THEN
    KZ=1
    RETURN
  ENDIF
  DO K=1,KM-1
    IF((Z-ZZ(K))*(Z-ZZ(K+1)).GT.0.0)CYCLE
    KZ=K
    EXIT
  ENDDO
  RETURN
END SUBROUTINE CHECKPSTN

SUBROUTINE GRIDTRANS(NV,N1,X1,Y1,Z1,T1,N2,X2,Y2,Z2,T2,G1,G2)
!*************************************************
!  THIS ROUTINE MAPS GRID FUNCTIONS TO OTHER GRID.
!
!  HISTORY: APR. 2008, CODED BY YUANFU XIE.
!*************************************************

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: NV	! NUMBER OF VAR TO MAP
  INTEGER, INTENT(IN) :: N1(4)	! NUMBERS OF INPUT GRIDPTS
  INTEGER, INTENT(IN) :: N2(4)	! NUMBERS OF OUTPUT GRIDPTS

  REAL,    INTENT(IN) :: X1(N1(1)),Y1(N1(2)),Z1(N1(3)),T1(N1(4))
				! BKG GRID POSITIONS
  REAL,    INTENT(IN) :: X2(N2(1)),Y2(N2(2)),Z2(N2(3)),T2(N2(4))
				! FINE GRID POSITIONS
  REAL,    INTENT(IN) :: G1(N1(1),N1(2),N1(3),N1(4),NV)
				! BACKGROUND VARIABLES
  REAL,    INTENT(OUT) :: G2(N2(1),N2(2),N2(3),N2(4),NV)

  ! LOCAL VARIABLES:
  INTEGER :: I,J,K,L
  INTEGER :: IDX(2,N2(1)),IDY(2,N2(2)),IDZ(2,N2(3)),IDT(2,N2(4))
  REAL    :: COX(2,N2(1)),COY(2,N2(2)),COZ(2,N2(3)),COT(2,N2(4)),S

  ! COEFFICIENTS AND INDICES:
  ! LEFT:
  IDX(1:2,1) = 1
  IDY(1:2,1) = 1
  IDZ(1:2,1) = 1
  IDT(1:2,1) = 1
  COX(1,1) = 1.0
  COY(1,1) = 1.0
  COZ(1,1) = 1.0
  COT(1,1) = 1.0
  COX(2,1) = 0.0
  COY(2,1) = 0.0
  COZ(2,1) = 0.0
  COT(2,1) = 0.0
  ! RIGHT:
  IDX(1:2,N2(1)) = N1(1)
  IDY(1:2,N2(2)) = N1(2)
  IDZ(1:2,N2(3)) = N1(3)
  IDT(1:2,N2(4)) = N1(4)
  COX(1,N2(1)) = 1.0
  COY(1,N2(2)) = 1.0
  COZ(1,N2(3)) = 1.0
  COT(1,N2(4)) = 1.0
  COX(2,N2(1)) = 0.0
  COY(2,N2(2)) = 0.0
  COZ(2,N2(3)) = 0.0
  COT(2,N2(4)) = 0.0

  ! X: UNIFORM GRID
  S = X1(2)-X1(1)
  DO I=2,N2(1)-1
    IDX(1,I) = INT( (X2(I)-X1(1))/S ) +1
    IDX(2,I) = IDX(1,I)+1
    COX(2,I) = (X2(I)-X1(IDX(1,I)))/S
    COX(1,I) = 1.0-COX(2,I)
  ENDDO

  ! Y: UNIFORM GRID
  S = Y1(2)-Y1(1)
  DO J=2,N2(2)-1
    IDY(1,J) = INT( (Y2(J)-Y1(1))/S ) +1
    IDY(2,J) = IDY(1,J)+1
    COY(2,J) = (Y2(J)-Y1(IDY(1,J)))/S
    COY(1,J) = 1.0-COY(2,J)
  ENDDO

  ! Z: NON-UNIFORM GRID
  DO K=2,N2(3)-1
    IDZ(1,K) = IDZ(1,K-1)
    IDZ(2,K) = IDZ(1,K)+1
    DO WHILE ( (IDZ(1,K) .LT. N1(3)) .AND. ( &
      ( (Z1(1) .LT. Z1(2)) .AND. (Z2(K) .GE. Z1(IDZ(2,K))) ) .OR. &
      ( (Z1(1) .GT. Z1(2)) .AND. (Z2(K) .LE. Z1(IDZ(2,K))) ) ) )
      IDZ(1:2,K) = IDZ(1:2,K)+1
    ENDDO
  ENDDO

  ! T: UNIFORM GRID:
  IF (N1(4) .GT. 1) S = T1(2)-T1(1)
  DO L=2,N2(4)-1
    IDT(1,L) = INT( (T2(L)-T1(1))/S ) +1
    IDT(2,L) = IDT(1,L)+1
    COT(2,L) = (T2(L)-T1(IDT(1,L)))/S
    COT(1,L) = 1.0-COT(2,L)
  ENDDO

  ! INTERPOLATIONS:
  DO L=1,N2(4)
  DO K=1,N2(3)
  DO J=1,N2(2)
  DO I=1,N2(1)
    G2(I,J,K,L,1:NV) = &
      G1(IDX(1,I),IDY(1,J),IDZ(1,K),IDT(1,L),1:NV)*COX(1,I)*COY(1,J)*COZ(1,K)*COT(1,L)+ &

      G1(IDX(2,I),IDY(1,J),IDZ(1,K),IDT(1,L),1:NV)*COX(2,I)*COY(1,J)*COZ(1,K)*COT(1,L)+ &
      G1(IDX(1,I),IDY(2,J),IDZ(1,K),IDT(1,L),1:NV)*COX(1,I)*COY(2,J)*COZ(1,K)*COT(1,L)+ &
      G1(IDX(1,I),IDY(1,J),IDZ(2,K),IDT(1,L),1:NV)*COX(1,I)*COY(1,J)*COZ(2,K)*COT(1,L)+ &
      G1(IDX(1,I),IDY(1,J),IDZ(1,K),IDT(2,L),1:NV)*COX(1,I)*COY(1,J)*COZ(1,K)*COT(2,L)+ &

      G1(IDX(2,I),IDY(2,J),IDZ(1,K),IDT(1,L),1:NV)*COX(2,I)*COY(2,J)*COZ(1,K)*COT(1,L)+ &
      G1(IDX(2,I),IDY(1,J),IDZ(2,K),IDT(1,L),1:NV)*COX(2,I)*COY(1,J)*COZ(2,K)*COT(1,L)+ &
      G1(IDX(2,I),IDY(1,J),IDZ(1,K),IDT(2,L),1:NV)*COX(2,I)*COY(1,J)*COZ(1,K)*COT(2,L)+ &
      G1(IDX(1,I),IDY(2,J),IDZ(2,K),IDT(1,L),1:NV)*COX(1,I)*COY(2,J)*COZ(2,K)*COT(1,L)+ &
      G1(IDX(1,I),IDY(2,J),IDZ(1,K),IDT(2,L),1:NV)*COX(1,I)*COY(2,J)*COZ(1,K)*COT(2,L)+ &
      G1(IDX(1,I),IDY(1,J),IDZ(2,K),IDT(2,L),1:NV)*COX(1,I)*COY(1,J)*COZ(2,K)*COT(2,L)+ &

      G1(IDX(2,I),IDY(2,J),IDZ(2,K),IDT(1,L),1:NV)*COX(2,I)*COY(2,J)*COZ(2,K)*COT(1,L)+ &
      G1(IDX(2,I),IDY(2,J),IDZ(1,K),IDT(2,L),1:NV)*COX(2,I)*COY(2,J)*COZ(1,K)*COT(2,L)+ &
      G1(IDX(2,I),IDY(1,J),IDZ(2,K),IDT(2,L),1:NV)*COX(2,I)*COY(1,J)*COZ(2,K)*COT(2,L)+ &
      G1(IDX(1,I),IDY(2,J),IDZ(2,K),IDT(2,L),1:NV)*COX(1,I)*COY(2,J)*COZ(2,K)*COT(2,L)+ &

      G1(IDX(2,I),IDY(2,J),IDZ(2,K),IDT(2,L),1:NV)*COX(2,I)*COY(2,J)*COZ(2,K)*COT(2,L)
  ENDDO
  ENDDO
  ENDDO
  ENDDO

END SUBROUTINE GRIDTRANS

SUBROUTINE BKGTOFINE(NS,NB,XB,YB,ZB,TB,NF,XF,YF,ZF,TF,BK,FG)
!*************************************************
!  THIS ROUTINE MAPS MODEL BACKGROUND VARIABLES TO
!  THE FINEST GRID OF STMAS MULTIGRID.
!
!  HISTORY: APR. 2008, CODED BY YUANFU XIE.
!*************************************************

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: NS	! NUMBER OF VAR TO MAP
  INTEGER, INTENT(IN) :: NB(4)	! NUMBERS OF BK GRIDPOINT
  INTEGER, INTENT(IN) :: NF(4)	! NUMBERS OF FINE GRIDPTS

  REAL,    INTENT(IN) :: XB(NB(1)),YB(NB(2)),ZB(NB(3)),TB(NB(4))
				! BKG GRID POSITIONS
  REAL,    INTENT(IN) :: XF(NF(1)),YF(NF(2)),ZF(NF(3)),TF(NF(4))
				! FINE GRID POSITIONS
  REAL,    INTENT(IN) :: BK(NB(1),NB(2),NB(3),NB(4),NS)
				! BACKGROUND VARIABLES
  REAL,    INTENT(OUT) :: FG(NF(1),NF(2),NF(3),NF(4),NS)

  ! LOCAL VARIABLES:
  INTEGER :: I,J,K,L,ID(2,4)
  REAL    :: CO(2,4)

  ! FOR ALL GRID POINTS OVER THE FINEST GRID:
  ID(1,4) = 1
  ID(2,4) = MIN0(2,NB(4))
  DO L=1,NF(4)

    ! FINE GRID POINTS PASSES BK GRID POINTS:
    IF (NB(4) .EQ. 1) THEN	! ONLY ONE GRIDPOINT CASE
      ID(2,4) = ID(1,4)+1
    ELSE
      DO WHILE ( (ID(1,4) .LT. NB(4)) .AND. (TF(L) .GE. TB(ID(2,4))) )
        ID(1,4) = ID(1,4)+1
        ID(2,4) = ID(1,4)+1
      ENDDO
    ENDIF

    ! COEFFICIENTS:
    IF (ID(2,4) .GT. NB(4)) THEN
      ID(1:2,4) = NB(4)
      CO(2,4) = 0.0
    ELSE
      CO(2,4) = (TF(L)-TB(ID(1,4)))/(TB(ID(2,4))-TB(ID(1,4)))
    ENDIF
    CO(1,4) = 1.0-CO(2,4)

    ! INITIALIZE GRID LEVEL 3:
    ID(1,3) = 1
    ID(2,3) = MIN0(2,NB(3))
    DO K=1,NF(3)

      ! FINE GRID POINTS PASSES BK GRID POINTS:
      IF (NB(3) .EQ. 1) THEN		! ONLY ONE GRIDPOINT CASE
        ID(2,3) = ID(1,3)+1
      ELSE
        DO WHILE ( (ID(1,3) .LT. NB(3)) .AND. ( &
	   ((ZB(1) .GT. ZB(2)) .AND. (ZF(K) .LE. ZB(ID(2,3)))) .OR. &
           ((ZB(1) .LT. ZB(2)) .AND. (ZF(K) .GE. ZB(ID(2,3)))) ) )
        ID(1,3) = ID(1,3)+1
        ID(2,3) = ID(1,3)+1
        ENDDO
      ENDIF

      ! COEFFICIENTS:
      IF (ID(2,3) .GT. NB(3)) THEN
        ID(1:2,3) = NB(3)
        CO(2,3) = 0.0
      ELSE
        CO(2,3) = (ZF(K)-ZB(ID(1,3)))/(ZB(ID(2,3))-ZB(ID(1,3)))
      ENDIF
      CO(1,3) = 1.0-CO(2,3)

      ! INITIALIZE GRID LEVEL 2:
      ID(1,2) = 1
      ID(2,2) = MIN0(2,NB(2))
      DO J=1,NF(2)

        ! FINE GRID POINTS PASSES BK GRID POINTS:
        IF (NB(2) .EQ. 1) THEN	! ONLY ONE GRIDPOINT CASE
          ID(2,2) = ID(1,2)+1
        ELSE
          DO WHILE ( (ID(1,2) .LT. NB(2)) .AND. (YF(J) .GE. YB(ID(2,2))) )
            ID(1,2) = ID(1,2)+1
            ID(2,2) = ID(1,2)+1
          ENDDO
        ENDIF

        ! COEFFICIENTS:
        IF (ID(2,2) .GT. NB(2)) THEN
          ID(1:2,2) = NB(2)
          CO(2,2) = 0.0
        ELSE
          CO(2,2) = (YF(J)-YB(ID(1,2)))/(YB(ID(2,2))-YB(ID(1,2)))
        ENDIF
        CO(1,2) = 1.0-CO(2,2)

        ! INITIALIZE GRID LEVEL 2:
        ID(1,1) = 1
        ID(2,1) = MIN0(2,NB(1))
        DO I=1,NF(1)

          ! FINE GRID POINTS PASSES BK GRID POINTS:
          IF (NB(1) .EQ. 1) THEN	! ONLY ONE GRIDPOINT CASE
            ID(2,1) = ID(1,1)+1
          ELSE
            DO WHILE ( (ID(1,1) .LT. NB(1)) .AND. (XF(I) .GE. XB(ID(2,1))) )
              ID(1,1) = ID(1,1)+1
              ID(2,1) = ID(1,1)+1
            ENDDO
          ENDIF

          ! COEFFICIENTS:
          IF (ID(2,1) .GT. NB(1)) THEN
            ID(1:2,1) = NB(1)
            CO(2,1) = 0.0
          ELSE
            CO(2,1) = (XF(I)-XB(ID(1,1)))/(XB(ID(2,1))-XB(ID(1,1)))
          ENDIF
          CO(1,1) = 1.0-CO(2,1)

	  FG(I,J,K,L,1:NS) = &
	    BK(ID(1,1),ID(1,2),ID(1,3),ID(1,4),1:NS)*CO(1,1)*CO(1,2)*CO(1,3)*CO(1,4)+ &

            BK(ID(2,1),ID(1,2),ID(1,3),ID(1,4),1:NS)*CO(2,1)*CO(1,2)*CO(1,3)*CO(1,4)+ &
            BK(ID(1,1),ID(2,2),ID(1,3),ID(1,4),1:NS)*CO(1,1)*CO(2,2)*CO(1,3)*CO(1,4)+ &
            BK(ID(1,1),ID(1,2),ID(2,3),ID(1,4),1:NS)*CO(1,1)*CO(1,2)*CO(2,3)*CO(1,4)+ &
            BK(ID(1,1),ID(1,2),ID(1,3),ID(2,4),1:NS)*CO(1,1)*CO(1,2)*CO(1,3)*CO(2,4)+ &

            BK(ID(2,1),ID(2,2),ID(1,3),ID(1,4),1:NS)*CO(2,1)*CO(2,2)*CO(1,3)*CO(1,4)+ &
            BK(ID(2,1),ID(1,2),ID(2,3),ID(1,4),1:NS)*CO(2,1)*CO(1,2)*CO(2,3)*CO(1,4)+ &
            BK(ID(2,1),ID(1,2),ID(1,3),ID(2,4),1:NS)*CO(2,1)*CO(1,2)*CO(1,3)*CO(2,4)+ &
            BK(ID(1,1),ID(2,2),ID(2,3),ID(1,4),1:NS)*CO(1,1)*CO(2,2)*CO(2,3)*CO(1,4)+ &
            BK(ID(1,1),ID(2,2),ID(1,3),ID(2,4),1:NS)*CO(1,1)*CO(2,2)*CO(1,3)*CO(2,4)+ &
            BK(ID(1,1),ID(1,2),ID(2,3),ID(2,4),1:NS)*CO(1,1)*CO(1,2)*CO(2,3)*CO(2,4)+ &

            BK(ID(2,1),ID(2,2),ID(2,3),ID(1,4),1:NS)*CO(2,1)*CO(2,2)*CO(2,3)*CO(1,4)+ &
            BK(ID(2,1),ID(2,2),ID(1,3),ID(2,4),1:NS)*CO(2,1)*CO(2,2)*CO(1,3)*CO(2,4)+ &
            BK(ID(2,1),ID(1,2),ID(2,3),ID(2,4),1:NS)*CO(2,1)*CO(1,2)*CO(2,3)*CO(2,4)+ &
            BK(ID(1,1),ID(2,2),ID(2,3),ID(2,4),1:NS)*CO(1,1)*CO(2,2)*CO(2,3)*CO(2,4)+ &

            BK(ID(2,1),ID(2,2),ID(2,3),ID(2,4),1:NS)*CO(2,1)*CO(2,2)*CO(2,3)*CO(2,4)
       ENDDO
      ENDDO
    ENDDO
  ENDDO
END SUBROUTINE BKGTOFINE

SUBROUTINE DIRECTION(U,V,DG)
!*************************************************
! CALCULATE DIRECTION (GENERAL) (NOT USED)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  REAL  :: U,V,DG,RA
! --------------------
  RA=ATAN(1.0D0)/45.0D0
  IF(U.EQ.0.0D0)THEN
    IF(V.GT.0.0D0)THEN
      DG=90.0D0
    ELSE
      DG=270.0D0
    ENDIF
  ELSE
    DG=ATAN2(V,U)/RA
    IF(DG.LT.0.0D0)DG=DG+360.0D0
  ENDIF
  RETURN
END SUBROUTINE DIRECTION

SUBROUTINE GETOBDATE(AD,DH,BD)
!*************************************************
! CALCULATE OBSERVATION DATE, MODIFIED FROM 'raob2dwl.f' (GENERAL) (NOT USED)
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!          MARCH 2008, MODIFIED BY ZHONGJIE HE.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: MN(12)
  INTEGER  :: DT,IY,IM,ID
  REAL  :: AD,BD,HR,DH
  LOGICAL      :: FG
  DATA MN/31,28,31,30,31,30,31,31,30,31,30,31/
!  REAL ,EXTERNAL :: RELDAY
! --------------------
  DT = NINT(AD)
  IY = MOD(DT/1000000,100 )
  IM = MOD(DT/10000  ,100 )
  ID = MOD(DT/100    ,100 )
  HR = AD - DT/100*100 + DH
  IF(MOD(IY,4).EQ.0) MN(2) = 29
  FG=.TRUE.
  DO WHILE (FG)
    IF(HR.LT.0) THEN
      HR = HR+24
      ID = ID-1
      IF(ID.EQ.0) THEN
        IM = IM-1
        IF(IM.EQ.0) THEN
          IM = 12
          IY = IY-1
          IF(IY.LT.0) IY = 99
        ENDIF
        ID = MN(IM)
      ENDIF
    ELSEIF(HR.GE.24) THEN
      HR = HR-24
      ID = ID+1
      IF(ID.GT.MN(IM)) THEN
        ID = 1
        IM = IM+1
        IF(IM.GT.12) THEN
          IM = 1
          IY = MOD(IY+1,100)
        ENDIF
      ENDIF
    ELSE
      FG=.FALSE.
    ENDIF
  ENDDO
!  BD = IY*1000000 + IM*10000 + ID*100 + HR
!  IF(ABS(BD-1.0D0*IDNINT(BD)).LE..01)BD=1.0D0*IDNINT(BD)
!  IY=IY+2000
!  BD=RELDAY(0,0,0,ID,IM,IY)-RELDAY(0,0,0,1,1,2000)
!  BD=BD+HR/24.0
  RETURN
END SUBROUTINE GETOBDATE

SUBROUTINE OBSTOGRID(Y0,X0,Y00,X00,IM,JM,X,Y,IS)
!*************************************************
! CALCULATE THE POSITION OF OBSERVATION AT THE MODEL GRID.
! HISTORY: FEBURARY 2008, CODED by ZHONGJIE HE.
!*************************************************
  IMPLICIT NONE
  INTEGER  :: I,J
  INTEGER , INTENT(IN)  :: IM,JM
  REAL    , INTENT(IN)  :: X0,Y0
  REAL    , INTENT(IN)  :: X00(IM,JM),Y00(IM,JM)
  REAL    , INTENT(OUT) :: X,Y
  INTEGER , INTENT(OUT) :: IS
!--------------------
  IS=0
  X=0
  Y=0

  IF(X0.LE.X00(1,1)) THEN
    IF(ABS(X00(1,1)-X00(2,1)).LE.1E-10) RETURN
    X=1-(X0-X00(1,1))/(X00(1,1)-X00(2,1))
  ENDIF
  IF(X0.GE.X00(IM,JM)) THEN
    IF(ABS(X00(IM,JM)-X00(IM-1,JM)).LE.1E-10) RETURN
    X=IM+(X0-X00(IM,JM))/(X00(IM,JM)-X00(IM-1,JM))
  ENDIF
  DO I=2,IM
    IF(X0.GE.X00(I-1,1) .AND. X0.LT.X00(I,1)) THEN
      IF(ABS(X00(I-1,1)-X00(I,1)).LE.1E-10) RETURN
      X=I-1+(X0-X00(I-1,1))/(X00(I,1)-X00(I-1,1))
    ENDIF
  ENDDO

  IF(Y0.LE.Y00(1,1)) THEN
    IF(ABS(Y00(1,1)-Y00(1,2)).LE.1E-10) RETURN
    Y=1-(Y0-Y00(1,1))/(Y00(1,1)-Y00(1,2))
  ENDIF
  IF(Y0.GE.Y00(IM,JM)) THEN
    IF(ABS(Y00(IM,JM)-Y00(IM,JM-1)).LE.1E-10) RETURN
    Y=JM+(Y0-Y00(IM,JM))/(Y00(IM,JM)-Y00(IM,JM-1))
  ENDIF
  DO J=2,JM
    IF(Y0.GE.Y00(1,J-1) .AND. Y0.LT.Y00(1,J)) THEN
      IF(ABS(Y00(1,J-1)-Y00(1,J)).LE.1E-10) RETURN
      Y=J-1+(Y0-Y00(1,J-1))/(Y00(1,J)-Y00(1,J-1))
    ENDIF
  ENDDO

  IF(X.GE.1 .AND. X.LE.IM .AND. Y.GE.1 .AND. Y.LE.JM) IS=1

  RETURN
END SUBROUTINE OBSTOGRID

END MODULE GENERALTOOLS


      subroutine cli_rhgen(iwgn)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine generates weather relative humidity, solar
!!    radiation, and wind speed.

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dewpt(:,:)  |deg C         |average dew point temperature for the month
!!    idg(:)      |none          |array location of random number seed used
!!                               |for a given process
!!    j           |none          |HRU number
!!    pr_w(3,:,:) |none          |proportion of wet days in a month
!!    rndseed(:,:)|none          |random number seeds
!!    tmpmn(:,:)  |deg C         |avg monthly minimum air temperature
!!    tmpmx(:,:)  |deg C         |avg monthly maximum air temperature
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp
!!    SWAT: Atri, Ee

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use climate_module
      use hydrograph_module
      use time_module

      implicit none

      real :: vv                  !none          |variable to hold intermediate calculation
      real :: rhm                 !none          |mean monthly relative humidity adjusted for
                                  !              |wet or dry condiditions
      real :: yy                  !none          |variable to hold intermediate calculation
      real :: uplm                !none          |highest relative humidity value allowed for
                                  !              |any day in month
      real :: blm                 !none          |lowest relative humidity value allowed for
                                  !              |any day in month
      real :: rhmo                !none          |mean monthly relative humidity
      real :: tmpmean             !deg C         |average temperature for the month in HRU
      real :: atri                !none          |daily value generated for distribution
      real :: ee                  !              |
      integer :: iwgn             !              |

      !! Climate Paramenters required for Penman-Monteith !!

      !! Generate relative humidity !!
      tmpmean = (wgn(iwgn)%tmpmx(time%mo) + wgn(iwgn)%tmpmn(time%mo)) / 2.

      !! convert dewpoint to relative humidity
      rhmo = Ee(wgn(iwgn)%dewpt(time%mo)) / Ee(tmpmean)

      yy = 0.9 * wgn_pms(iwgn)%pr_wdays(time%mo)
      rhm = (rhmo - yy) / (1.0 - yy)
      if (rhm < 0.05) rhm = 0.5 * rhmo
      if (wst(iwst)%weat%precip > 0.0) rhm = rhm * 0.1 + 0.9
      vv = rhm - 1.
      uplm = rhm - vv * Exp(vv)
      blm = rhm * (1.0 - Exp(-rhm))
      wst(iwst)%weat%rhum = Atri(blm,rhm,uplm,rndseed(idg(7),iwgn))

      return
      end subroutine cli_rhgen


      SUBROUTINE MFFTIS(C,IMSX,IVSX,IESX,NMX,NVX,NEX,TABLES,IERR)
*   PURPOSE:
*       THE SAME AS MFFTIM.  IT IS A VARIANT OF MFFTIM, OPTIMIZED FOR
*       MAXIMUM PERFORMANCE ON MATRICES WHOSE FIRST DIMENSION IS
*       LESS THAN 64.
*       IT REQUIRES THAT TABLES HAS BEEN PREPARED BY A CALL TO MFFTP
*       WITH ID .NE. 0 .
*  IMPLEMENTATION:
*       THE TRANSFORMATION IS IMPLEMENTED THROUGH REPEATED CALLS TO THE
*       "BUTTERFLY" TRANSFORMATION MFFT?9; PARAMETERS OF THE "BUTTERFLY"
*       ARE COMMUNICATED THROUGH THE COMMON BLOCK MFFTPA.
*  ARGUMENTS:
*    INPUT:
*       C : ARRAY TO BE TRANSFORMED.
*       IMSX,IVSX,IESX,NMX,NVX,NEX: THESE ARGUMENTS DEFINE THE STRUCTURE
*           OF C ACCORDING TO THE DEFINITIONS ABOVE. THEY ARE UNCHANGED
*           ON OUTPUT
*       TABLES : ARRAY PREPARED BY MFFTP. IT  IS NOT CHANGED ON OUTPUT.
*                IT SHOULD BE DECLARED INTEGER TABLES(4*NM+14);
*                IT MUST BE INITIALIZED BY MFFTP BEFORE USAGE.
*    OUTPUT:
*       C : TRANSFORM OF THE ORIGINAL ARRAY; "BIT REVERSED" ORDER
*       IERR : ERROR CODE : =0 : SUCCESSFUL
*                         : =3 :  'TABLES' NOT CORRECTLY INITIALIZED
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX C(*)
      INTEGER TABLES(-14:*)
      INTEGER IDERR,FACERR,TBERR
      PARAMETER (IDERR=1,FACERR=2,TBERR=3)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      SAVE IBASE
*  LOADING THE COMMON BLOCK : CONSTANTS
      IMS=IMSX
      IVS=IVSX
      IES=1
      NM=NMX
      NV=NVX
      NE=NEX

      IVLIM=(NV-1)*IVS
      LSTEP=IMS
*  LOADING THE COMMON BLOCK : ITERATION-DEPENDENT QUANTITIES: INITIALIZA
      LX=1
      MX=NM

      IBASE=(2+IMS)*NM
      IFAC=TABLES(-1)
      IF(IFAC.GT.3)THEN
        IERR=TBERR
        RETURN
      ENDIF
*..   RADIX 2 LOOP
200   CONTINUE
      DO 210 IM=1,TABLES(-14)
        MX=MX/2
        NUSTEP=LX*LSTEP
        ILIM=NUSTEP-1
        MSTEP=NUSTEP*2
        MLIM=NM*LSTEP-MSTEP
        CALL MFFTA9(C,TABLES(2*IBASE))
        LX=LX+LX
        IBASE=IBASE+NUSTEP
210   CONTINUE
      IF(IFAC.EQ.1)RETURN
*..   RADIX 3 LOOP
300   CONTINUE
      DO 310 IM=1,TABLES(-13)
        MX=MX/3
        NUSTEP=LX*LSTEP
        ILIM=NUSTEP-1
        MSTEP=NUSTEP*3
        MLIM=NM*LSTEP-MSTEP
        CALL MFFTB9(C,TABLES(2*IBASE))
        LX=LX*3
        IBASE=IBASE+NUSTEP*2
310   CONTINUE
      IF(IFAC.EQ.2)RETURN
*..   RADIX 5 LOOP
500   CONTINUE
      DO 510 IM=1,TABLES(-12)
        MX=MX/5
        NUSTEP=LX*LSTEP
        ILIM=NUSTEP-1
        MSTEP=NUSTEP*5
        MLIM=NM*LSTEP-MSTEP
        CALL MFFTC9(C,TABLES(2*IBASE))
        LX=LX*5
        IBASE=IBASE+NUSTEP*4
510   CONTINUE
      END


!===============================================================================
!  VERTICAL
!===============================================================================

!===============================================================================
subroutine wtt2ttt(W_FIELD,DZT,T_FIELD)
!
!     interpolated real field from WTT-grid to TTT-grid
!     interpolating between two W-levels
!     T-point is located exactly in the middle of two W-points
!     T_FIELD(i,j,k) = W_FIELD(i,j,k) + ( W_FIELD(i,j,k+1) -
!     W_FIELD(i,j,k) ) &
!                                       / dz(k) * dz(k) / 2
!
implicit none

! input/output variables
integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt,km), intent(in)  :: DZT
real,    dimension(imt,jmt,km), intent(in)  :: W_FIELD ! WTT
real,    dimension(imt,jmt,km), intent(out) :: T_FIELD ! TTT
real,    parameter                          :: p5=0.5, c0=0.0, c3=3.0

do k = 1,km-1
  do j = 1,jmt
    do i = 1,imt
      if ( DZT(i,j,k).ne.c0 ) then
        T_FIELD(i,j,k) = p5 * ( W_FIELD(i,j,k) + W_FIELD(i,j,k+1) )
      endif
    enddo !i
  enddo !j
enddo !k

! bottom level
do j = 1,jmt
  do i = 1,imt
    if ( DZT(i,j,km).ne.c0 ) then
      ! extrapolating to last level with gradient between last two
      ! W-levels
      ! T_FIELD(i,j,km) = W_FIELD(i,j,km)
      !                 + (W_FIELD(i,j,km)-W_FIELD(i,j,km-1)) / dz(k) *
      !                 dz(k)/2
      !T_FIELD(i,j,km) = p5 * (c3*W_FIELD(i,j,km) - W_FIELD(i,j,km-1) )
      T_FIELD(i,j,km) = p5 * W_FIELD(i,j,km)
    endif
  enddo !i
enddo !j

!do k = 1,km
!  call surf_int(1,1,imt,jmt,W_FIELD(:,:,:),TAREA,DZT(:,:,k),A)
!  call surf_int(1,1,imt,jmt,T_FIELD(:,:,k),TAREA,DZT(:,:,k),B)
!  write (*,*) k, ' wtt2ttt orig', A
!  write (*,*) k, ' wtt2ttt new ', B
!  write (*,*) k, ' wtt2ttt factor      ', B/A
!enddo !k
end subroutine wtt2ttt
!===============================================================================

!===============================================================================
!  HORIZONTAL
!===============================================================================

!===============================================================================
subroutine uu2tt(DZT_k,DZU_k,TAREA,UAREA,FIELD_k,NEW_FIELD_k)
!
!     interpolates real 2D field from UU-grid to TT-grid on T-depth
!     levels
!
implicit none

! input/output variables
integer                                  :: i,j,k
integer, parameter                       :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt), intent(in)  :: DZU_k,DZT_k
real,    dimension(imt,jmt), intent(in)  :: TAREA,UAREA
real,    dimension(imt,jmt), intent(in)  :: FIELD_k     ! (T)UU
real,    dimension(imt,jmt), intent(out) :: NEW_FIELD_k ! (T)TT
real,    parameter                       :: c0=0.0
! southernmost gridpoints (j=1) on TTT-grid must be 0,
! as there would not be UU gridpoints south of it otherwise
do j = 2, jmt
  ! westernmost gridpoints
  if ( DZT_k(1,j).ne.c0 ) then
    NEW_FIELD_k(1,j) = 0.25                                                    &
                  * ( FIELD_k(1  ,j  ) * UAREA(1  ,j  ) * DZU_k(1  ,j  )       &
                    + FIELD_k(imt,j  ) * UAREA(imt,j  ) * DZU_k(imt,j  )       &
                    + FIELD_k(1  ,j-1) * UAREA(1  ,j-1) * DZU_k(1  ,j-1)       &
                    + FIELD_k(imt,j-1) * UAREA(imt,j-1) * DZU_k(imt,j-1))      &
                  / TAREA(1,j) / DZT_k(1,j)
  endif
  ! most of the ocean
  do i = 2,imt
    if ( DZT_k(i,j).ne.c0 ) then
      NEW_FIELD_k(i,j) = 0.25                                                  &
                   * ( FIELD_k(i  ,j  ) * UAREA(i  ,j  ) * DZU_k(i  ,j  )      &
                     + FIELD_k(i-1,j  ) * UAREA(i-1,j  ) * DZU_k(i-1,j  )      &
                     + FIELD_k(i  ,j-1) * UAREA(i  ,j-1) * DZU_k(i  ,j-1)      &
                     + FIELD_k(i-1,j-1) * UAREA(i-1,j-1) * DZU_k(i-1,j-1) )    &
                   / TAREA(i,j) / DZT_k(i,j)
    endif
  enddo !i
enddo !j

end subroutine uu2tt
!===============================================================================

!===============================================================================
subroutine uu2tt_3D(DZT,DZU,TAREA,UAREA,TUU_FIELD,TTT_FIELD)
implicit none
!  interpolates a 3D field from UU to TT

integer                                  :: i,j,k
integer, parameter                       :: imt=3600,jmt=2400,km=42
real, dimension(imt,jmt)                 :: WORK
real, dimension(imt,jmt),    intent(in)  :: TAREA, UAREA
real, dimension(imt,jmt,km), intent(in)  :: TUU_FIELD, DZU, DZT
real, dimension(imt,jmt,km), intent(out) :: TTT_FIELD

do k = 1,km
  call uu2tt(DZT(:,:,k),DZU(:,:,k),TAREA,UAREA,TUU_FIELD(:,:,k),WORK)
  TTT_FIELD(:,:,k) = WORK
enddo

end subroutine uu2tt_3D
!===============================================================================

!===============================================================================
subroutine uu2tt_scalar(DZT_k,DZU_k,TAREA,UAREA,FIELD_k,NEW_FIELD_k)
!     interpolates real scalar 2D field (as opposed to velocity fields
!     which
!     can be related to volume transports) from UU-grid to TT-grid on
!     T-depth
!     levels
implicit none

! input/output variables
integer                                  :: i,j,k
integer, parameter                       :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt), intent(in)  :: DZU_k,DZT_k
real,    dimension(imt,jmt), intent(in)  :: TAREA,UAREA
real,    dimension(imt,jmt), intent(in)  :: FIELD_k     ! (T)UU
real,    dimension(imt,jmt), intent(out) :: NEW_FIELD_k ! (T)TT
real,    parameter                       :: c0=0.0

! southernmost gridpoints (j=1) on TTT-grid must be 0,
! as there would not be UU gridpoints south of it otherwise
do j = 2, jmt
  ! westernmost gridpoints
  if ( DZT_k(1,j).ne.c0 ) then
    NEW_FIELD_k(1,j) = 0.25 * ( FIELD_k(1  ,j  ) * UAREA(1  ,j  )              &
                              + FIELD_k(imt,j  ) * UAREA(imt,j  )              &
                              + FIELD_k(1  ,j-1) * UAREA(1  ,j-1)              &
                              + FIELD_k(imt,j-1) * UAREA(imt,j-1) )            &
                            / TAREA(1,j)
  endif
  ! most of the ocean
  do i = 2,imt
    if ( DZT_k(i,j).ne.c0 ) then
      NEW_FIELD_k(i,j) = 0.25 * ( FIELD_k(i  ,j  ) * UAREA(i  ,j  )            &
                                + FIELD_k(i-1,j  ) * UAREA(i-1,j  )            &
                                + FIELD_k(i  ,j-1) * UAREA(i  ,j-1)            &
                                + FIELD_k(i-1,j-1) * UAREA(i-1,j-1) )          &
                              / TAREA(i,j)
    endif
  enddo !i
enddo !j

! results in very small correction O(-4)

end subroutine uu2tt_scalar
!===============================================================================

!===============================================================================
subroutine uu2tt_scalar_3D(DZT,DZU,TAREA,UAREA,TUU_FIELD,TTT_FIELD)
implicit none
!
!  interpolates a 3D field from UU to TT
!

integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt)                 :: WORK
real,    dimension(imt,jmt),    intent(in)  :: TAREA, UAREA
real,    dimension(imt,jmt,km), intent(in)  :: TUU_FIELD, DZU, DZT
real,    dimension(imt,jmt,km), intent(out) :: TTT_FIELD

do k = 1,km
  call uu2tt_scalar(DZT(:,:,k),DZU(:,:,k),TAREA,UAREA,TUU_FIELD(:,:,k),WORK)
  TTT_FIELD(:,:,k) = WORK
enddo

end subroutine uu2tt_scalar_3D
!===============================================================================

!===============================================================================
!  MOMENTUM FLUX
!===============================================================================

!===============================================================================
subroutine interp_mom_fluxes(DZT_k,DZU_k,DXT,DXU,DYT,DYU,&
                                   UE_FIELD,VN_FIELD,UE_NEW_FIELD,VN_NEW_FIELD)
!
!     interpolates momentum fluxes from east side of U-cell to momentum
!     fluxes
!     at center of T-cells, for this a weighted average of the flux
!     North/South
!     and East/West of the T-cell center point is used
!
implicit none

! input/output variables
integer                                  :: i,j,k
integer, parameter                       :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt), intent(in)  :: DZU_k,DZT_k
real,    dimension(imt,jmt), intent(in)  :: DXT,DXU,DYT,DYU
real,    dimension(imt,jmt), intent(in)  :: UE_FIELD ! (T)UU
real,    dimension(imt,jmt), intent(in)  :: VN_FIELD ! (T)UU
real,    dimension(imt,jmt), intent(out) :: UE_NEW_FIELD ! (T)TT
real,    dimension(imt,jmt), intent(out) :: VN_NEW_FIELD ! (T)TT
real,    parameter                       :: c0=0.0
real :: A, B ! surface integrals, used for comparing old and new fields

! southernmost gridpoints (j=1) on TTT-grid must be 0,
! as there would not be UU gridpoints south of it otherwise

! east flux
do j = 2, jmt-1
  ! westernmost gridpoints
  if ( DZT_k(1,j).ne.c0 ) then
    if ( DZT_k(1,j-1).ne.c0 .or. DZT_k(1,j+1).ne.c0  ) then
      UE_NEW_FIELD(1,j) = 0.5 *&
       ( UE_FIELD(imt,j  ) * DYU(imt,j  )&
       + UE_FIELD(imt,j-1) * DYU(imt,j-1) )&
       / DYT(1,j)
    else
      UE_NEW_FIELD(1,j) = 0.0
    endif
  endif

  ! most of the ocean
  do i = 2,imt
    if ( DZT_k(i,j).ne.c0 ) then
      if ( DZT_k(i,j-1).ne.c0 .or. DZT_k(i,j+1).ne.c0  ) then
        UE_NEW_FIELD(i,j) = 0.5 *&
         ( UE_FIELD(i-1,j  ) * DYU(i-1,j  )&
         + UE_FIELD(i-1,j-1) * DYU(i-1,j-1) )&
         / DYT(i,j)
      else
        UE_NEW_FIELD(i,j) = 0.0
      endif
    endif
  enddo !i
enddo !j

! north flux
do j = 2, jmt
  ! western edge
  if ( DZT_k(1,j).ne.c0 ) then
    if ( DZT_k(imt,j).ne.c0 .or. DZT_k(2,j).ne.c0  ) then
      VN_NEW_FIELD(1,j) = 0.5 *&
       ( VN_FIELD(imt,j-1) * DXU(imt,j-1)&
       + VN_FIELD(1  ,j-1) * DXU(1  ,j-1) )&
       / DXT(1,j)
    else
      VN_NEW_FIELD(1,j) = 0.0
    endif
  endif
  ! rest of array
  do i = 2, imt
    if ( DZT_k(i,j).ne.c0 ) then
      if ( DZT_k(i-1,j).ne.c0 .or. DZT_k(i+1,j).ne.c0  ) then
        VN_NEW_FIELD(i,j) = 0.5 *&
         ( VN_FIELD(i-1,j-1) * DXU(i-1,j-1)&
         + VN_FIELD(i  ,j-1) * DXU(i  ,j-1) )&
         / DXT(i,j)
      else
        VN_NEW_FIELD(i,j) = 0.0
      endif
    endif
  enddo !i
enddo !j

!call surf_int(1,1,imt,jmt,UE_FIELD,    UAREA,DZT_k,A)
!call surf_int(1,1,imt,jmt,UE_NEW_FIELD,TAREA,DZT_k,B)
!      write (*,*) 'A: ', A, 'B: ', B
!write (*,*) k, 'rel. diff. of UE flux interp.: ', (A-B)/B
!call surf_int(1,1,imt,jmt,VN_FIELD,    UAREA,DZT_k,A)
!call surf_int(1,1,imt,jmt,VN_NEW_FIELD,TAREA,DZT_k,B)
!      write (*,*) 'A: ', A, 'B: ', B
!write (*,*) k, 'rel. diff. of VN flux interp.: ', (A-B)/B

end subroutine interp_mom_fluxes
!===============================================================================


      subroutine splcon(xlat,xlon,nver,verlat,verlon,verrad,
     #                  ncon,icon,con)
      dimension verlat(1)
      dimension verlon(1)
      dimension verrad(1)
      dimension icon(1)
      dimension con(1)
c
c---- all calculations done in double precision
c---- but results are single
c
      real*8 dd
      real*8 rn
      real*8 dr
c
      ncon=0
      do iver=1,nver
        if(xlat.gt.verlat(iver)-2.*verrad(iver)) then
          if(xlat.lt.verlat(iver)+2.*verrad(iver)) then
            dd=dsind(dble(verlat(iver)))*dsind(dble(xlat))
            dd=dd+dcosd(dble(verlat(iver)))*dcosd(dble(xlat))*
     #         dcosd(dble(xlon-verlon(iver)))
            dd=dacosd(dd)
            if(dd.gt.dble(verrad(iver))*2.d0) then
            else
              ncon=ncon+1
              icon(ncon)=iver
              rn=dd/dble(verrad(iver))
              dr=rn-1.d0
              if(rn.le.1.d0) then
                con(ncon)=(0.75d0*rn-1.5d0)*(rn**2)+1.d0
              else if(rn.gt.1.d0) then
                con(ncon)=((-0.25d0*dr+0.75d0)*dr-0.75d0)*dr+0.25d0
              else
                con(ncon)=0.
              endif
            endif
          endif
        endif
      enddo
      return
      end


***
      SUBROUTINE GRRAD(m1,m2,sep,ecc,jorb,djgr,de)
      implicit none
      real*8 m1,m2,sep,ecc,jorb,djgr,de,acrit
      real*8 ecc2,sqome2,sqome5,f1
*
* Include gravitational radiation for very close or massive systems.
*
      djgr = 0.d0
      de = 0.d0
      ACRIT = 10.0
      IF (m1 + m2.GT.10.0) ACRIT = 30.0
      if(sep.le.ACRIT)then
         djgr = 8.315d-10*m1*m2*(m1+m2)/(sep*sep*sep*sep)
         ecc2 = ecc*ecc
         sqome2 = SQRT(1.d0-ecc2)
         sqome5 = sqome2**5
         f1 = (19.d0/6.d0) + (121.d0/96.d0)*ecc2
         de = djgr*ecc*f1/sqome5
         djgr = djgr*jorb*(1.d0+0.875d0*ecc2)/sqome5
      endif
*
      RETURN
      END
***


   function tcul (fbuObj, k, ntv)

! ======================================================================
!
!    Calculates Coulomb energy (see Eqn. 73 in the CEM Manual)
!
!    Called by: RAZVAL
!
!     Last change: 13-Aug-2003 BY NVMokhov
!     Edited by A. J. Sierk, LANL T-16, September, 2003.
!     Edited by A. J. Sierk, LANL T-2, February, 2009.
!     Edited by AJS, LANL T-2, December, 2011.
!     Edited by LMK, XCP-3, July 2013 (included error protection).
!     Edited by CMJ, XCP-3, July 2018 (creation of FermiBreakup class)
!
!    k = Number of products
!    tcul = Coulomb barrier
!    ntv = Particle code (100*A + Z)
!    radncl = 1.5
!
! ======================================================================

     use, intrinsic :: iso_fortran_env, only: int32, real64
     use fermiBreakupParams, only : zro, one, thrd, twthrd, thousandth, &
          & ato3rd

    implicit none
     class(FermiBreakup), intent(inout) :: fbuObj
     integer(int32),      intent(in   ) :: k    ! Number of products
     integer(int32),      intent(in   ) :: ntv(fbuObj%options%recNumNucleons)   ! Particle code (100*A + Z)
     real(real64)                       :: tcul

     integer(int32) :: i, iaa
     real(real64)   :: a, ec, z, zi
     integer(int32), dimension(fbuObj%options%recNumNucleons) :: ia, iz

! ======================================================================

     real(real64), parameter :: r0     = 1.3_real64    ! Radius parameter
     real(real64), parameter :: kappa  = 1.0_real64    ! V/V_0 term
     real(real64), parameter :: eCoul2 = 1.44_real64   ! "e" variable in coulomb potential equation
     real(real64), parameter :: coef   = &
          & (0.6d0*eCoul2/r0)*(one/((one + kappa)**thrd))

! ======================================================================

     tcul = zro
     a = zro
     z = zro
     ! Obtain A, Z of each fragment in the break-up channel
     do i = 1,min(k, fbuObj%options%recNumNucleons)
        ia(i) = ntv(i)/100
        iz(i) = ntv(i) - ia(i)*100
        a = a + dble(ia(i))
        z = z + dble(iz(i))
     end do
     iaa = nint(a)

     ! Determine coulomb potential for each fragment (summation term)
     ec = zro
     do i = 1,k
        zi = dble(iz(i))
        ec = ec + zi*zi/ato3rd(ia(i))
     end do

     ! Subtract from coloumb potential of original nucleus the fragment's combined couloumb potential
     ec = z*z/ato3rd(iaa) - ec

     ! Obtain coulomb potential, ensure valid
     tcul = thousandth*( coef * ec )
     tcul = max (zro, tcul)

     return
! ======================================================================
   end function tcul


      subroutine runCP_iiiii(k,i1,i2,i3,i4,i5,f,Gr,Shat6,N0)
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,i1,i2,i3,i4,i5,np
      parameter(np=2)
      double precision f(np),Gr(np,np)
      double complex Shat6(np,z5max,-2:0)

      do ep=-2,0
      Cv(ciiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     . (Shat6(k,z5(i1,i2,i3,i4,i5),ep)
     . -2d0*delta(k,i1)*Cv(czziiii(z4(i2,i3,i4,i5))+N0,ep)
     . -2d0*delta(k,i2)*Cv(czziiii(z4(i1,i3,i4,i5))+N0,ep)
     . -2d0*delta(k,i3)*Cv(czziiii(z4(i1,i2,i4,i5))+N0,ep)
     . -2d0*delta(k,i4)*Cv(czziiii(z4(i1,i2,i3,i5))+N0,ep)
     . -2d0*delta(k,i5)*Cv(czziiii(z4(i1,i2,i3,i4))+N0,ep)
     . -Gr(k,1)*Cv(ciiiiii(z6(1,i1,i2,i3,i4,i5))+N0,ep)
     . -Gr(k,2)*Cv(ciiiiii(z6(2,i1,i2,i3,i4,i5))+N0,ep))/f(k)
      enddo

      return
      end