C$Procedure DRDLAT ( Derivative of rectangular w.r.t. latitudinal )

      SUBROUTINE DRDLAT ( R, LONG, LAT, JACOBI )
      IMPLICIT NONE

C$ Abstract
C
C     Compute the Jacobian of the transformation from latitudinal to
C     rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     COORDINATES
C     DERIVATIVES
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION      R
      DOUBLE PRECISION      LONG
      DOUBLE PRECISION      LAT
      DOUBLE PRECISION      JACOBI ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     RADIUS     I   Distance of a point from the origin.
C     LONG       I   Angle of the point from the XZ plane in radians.
C     LAT        I   Angle of the point from the XY plane in radians.
C     JACOBI     O   Matrix of partial derivatives.
C
C$ Detailed_Input
C
C      RADIUS     Distance of a point from the origin.
C
C      LONG       Angle of the point from the XZ plane in radians.
C                 The angle increases in the counterclockwise sense
C                 about the +Z axis.
C
C      LAT        Angle of the point from the XY plane in radians.
C                 The angle increases in the direction of the +Z axis.
C
C$ Detailed_Output
C
C     JACOBI     is the matrix of partial derivatives of the conversion
C                between latitudinal and rectangular coordinates. It has
C                the form
C
C                    .-                                 -.
C                    |  DX/DR     DX/DLONG     DX/DLAT   |
C                    |                                   |
C                    |  DY/DR     DY/DLONG     DY/DLAT   |
C                    |                                   |
C                    |  DZ/DR     DZ/DLONG     DZ/DLAT   |
C                    `-                                 -'
C
C               evaluated at the input values of R, LONG and LAT.
C               Here X, Y, and Z are given by the familiar formulae
C
C                   X = R * COS(LONG) * COS(LAT)
C                   Y = R * SIN(LONG) * COS(LAT)
C                   Z = R *             SIN(LAT)
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     It is often convenient to describe the motion of an object
C     in latitudinal coordinates. It is also convenient to manipulate
C     vectors associated with the object in rectangular coordinates.
C
C     The transformation of a latitudinal state into an equivalent
C     rectangular state makes use of the Jacobian of the
C     transformation between the two systems.
C
C     Given a state in latitudinal coordinates,
C
C          ( r, long, lat, dr, dlong, dlat )
C
C     the velocity in rectangular coordinates is given by the matrix
C     equation
C                    t          |                                t
C        (dx, dy, dz)   = JACOBI|             * (dr, dlong, dlat)
C                               |(r,long,lat)
C
C     This routine computes the matrix
C
C              |
C        JACOBI|
C              |(r,long,lat)
C
C$ Examples
C
C     Suppose you have a model that gives radius, longitude, and
C     latitude as functions of time (r(t), long(t), lat(t)), and
C     that the derivatives (dr/dt, dlong/dt, dlat/dt) are computable.
C     To find the velocity of the object in rectangular coordinates,
C     multiply the Jacobian of the transformation from latitudinal
C     to rectangular (evaluated at r(t), long(t), lat(t)) by the
C     vector of derivatives of the latitudinal coordinates.
C
C     This is illustrated by the following code fragment.
C
C        C
C        C     Load the derivatives of r, long and lat into the
C        C     latitudinal velocity vector LATV.
C        C
C              LATV(1) = DR_DT    ( T )
C              LATV(2) = DLONG_DT ( T )
C              LATV(3) = DLAT_DT  ( T )
C
C        C
C        C     Determine the Jacobian of the transformation from
C        C     latitudinal to rectangular coordinates, using the
C        C     latitudinal coordinates at time T.
C        C
C              CALL DRDLAT ( R(T), LONG(T), LAT(T), JACOBI )
C
C        C
C        C     Multiply the Jacobian by the latitudinal velocity to
C        C     obtain the rectangular velocity RECV.
C        C
C              CALL MXV ( JACOBI, LATV, RECV )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 19-JUL-2001 (WLT)
C
C-&

C$ Index_Entries
C
C     Jacobian of rectangular w.r.t. latitudinal coordinates
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     Local variables
C
      INTEGER               DX
      PARAMETER           ( DX   = 1 )

      INTEGER               DY
      PARAMETER           ( DY   = 2 )

      INTEGER               DZ
      PARAMETER           ( DZ   = 3 )

      INTEGER               DR
      PARAMETER           ( DR   = 1 )

      INTEGER               DLON
      PARAMETER           ( DLON = 2 )

      INTEGER               DLAT
      PARAMETER           ( DLAT = 3 )

C
C     Construct the matrix directly.
C
      JACOBI (DX,DR)   =      DCOS( LONG ) * DCOS( LAT )
      JACOBI (DY,DR)   =      DSIN( LONG ) * DCOS( LAT )
      JACOBI (DZ,DR)   =                     DSIN( LAT )

      JACOBI (DX,DLON) = -R * DSIN( LONG ) * DCOS( LAT )
      JACOBI (DY,DLON) =  R * DCOS( LONG ) * DCOS( LAT )
      JACOBI (DZ,DLON) =  0.0D0

      JACOBI (DX,DLAT) = -R * DCOS( LONG ) * DSIN( LAT )
      JACOBI (DY,DLAT) = -R * DSIN( LONG ) * DSIN( LAT )
      JACOBI (DZ,DLAT) =  R *                DCOS( LAT )

      RETURN
      END


      subroutine annulus_basis_complete(x,y, t, tinv,tderivs, flag)
      implicit none

      double precision x,y
      integer flag
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta_vec(2)
      common /annulus_comm/ beta, theta_vec

      double precision r1, r1x, r1xx, r1y, r1yy, r1xy
      double precision R,  Rx,  Rxx,  Ry,  Ryy,  Rxy
      double precision f(3), fx(3), fy(3), fxx(3), fyy(3), fxy(3)
      double precision g(3), gx(3), gy(3), gxx(3), gyy(3), gxy(3)
      double precision t1(3), t2(3), a11, a12, a22, a21
      double precision det, a11inv, a22inv, a12inv, a21inv
      double precision pi4
      double precision annulus_dot

      integer k, kk, i
      logical compute_covariant, compute_contravariant
      logical compute_derivatives, b(32)

      double precision theta, thetax, thetay

      if (flag > 7) then
          write(6,*) 'psi.f : flag > 7'
          stop
      endif

c     # flag = 0      NA
c     # flag = 1      Covariant basis only
c     # flag = 2      NA
c     # flag = 3      Covariant + contravariant basis
c     # flag = 4      Derivatives only
c     # flag = 5      Derivatives + covariant basis
c     # flag = 6      NA
c     # flag = 7      Covariant + contravariant + derivatives

      do i = 1,bit_size(flag)
          b(i) = btest(flag,i-1)
      enddo

      compute_covariant     = b(1) .or. b(2)
      compute_contravariant = b(2)
      compute_derivatives   = b(3)

c      pi4 = pi2*pi2

      call map_comp2annulus_derivs(x,y,theta,r,
     &              thetax, thetay, rx, ry)

c      r = beta + (1-beta)*yc
c      xp = r*cos(2*pi*xc)
c      yp = r*sin(2*pi*xc)

      if (compute_covariant) then
          t(1,1) = -thetax*r*sin(theta)
          t(2,1) = thetax*r*cos(theta)
          t(3,1) = 0

          t(1,2) = ry*cos(theta)
          t(2,2) = ry*sin(theta)
          t(3,2) = 0

      endif

      R     = beta + (1-beta)*y
      Rx    = 0
      Rxx   = 0
      Ry    = 1-beta
      Ryy   = 0
      Rxy   = 0

      f(1)  = cos(theta);
      fx(1) = -thetax*sin(theta)
      fy(1) = 0

      f(2)  = sin(theta);
      fx(2) = thetax*cos(theta)
      fy(2) = 0

      f(3) = 0
      fx(3) = 0
      fy(3) = 0

      g(1)  = R
      g(2)  = R
      g(3) = 0

      gx(1) = Rx
      gx(2) = Rx
      gx(3) = 0

      gy(1) = Ry
      gy(2) = Ry
      gy(3) = 0

      if (compute_covariant) then
          do k = 1,3
              t(k,1) = gx(k)*f(k) + g(k)*fx(k);
              t(k,2) = gy(k)*f(k) + g(k)*fy(k);
          enddo
      endif

      if (compute_contravariant) then
           call map_contravariant(t,tinv)
      endif

      if (compute_derivatives) then
          fxx(1) = -thetax**2*cos(theta)
          fyy(1) = 0
          fxy(1) = 0

          fxx(2) = -thetax**2*sin(theta)
          fyy(2) = 0
          fxy(2) = 0

          fxx(3) = 0
          fxy(3) = 0
          fyy(3) = 0

          gxx(1) = Rxx
          gxx(2) = Rxx
          gxx(3) = 0

          gyy(1) = Ryy
          gyy(2) = Ryy
          gyy(3) = 0

          gxy(1) = Rxy
          gxy(2) = Rxy
          gxy(3) = 0

          do k = 1,3
c             # d(t1)/dx = d(g*fx + gx*f)/dx
              tderivs(k,1,1) = g(k)*fxx(k) + 2*fx(k)*gx(k) + gxx(k)*f(k)

c             # d(t1)/dy = d(g*fx + gx*f)/dy
              tderivs(k,1,2) = g(k)*fxy(k) + gy(k)*fx(k) +
     &                    gx(k)*fy(k) + gxy(k)*f(k)

c             # d(t2)/dx = d(g*fy + gy*f)/dx
              tderivs(k,2,1) = g(k)*fxy(k) + gx(k)*fy(k) +
     &                    gy(k)*fx(k) + gxy(k)*f(k)

c             # d(t2)/dy = d(g*fy + gy*f)/dy
              tderivs(k,2,2) = g(k)*fyy(k) + 2*fy(k)*gy(k) + gyy(k)*f(k)
          enddo
      endif

      end

      subroutine map_comp2annulus(xc,yc,theta,r)
      implicit none

      double precision xc,yc,theta, r

      double precision thetax, thetay, rx, ry

c     # Map xc in [0,1] to theta in [-pi,pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      call map_comp2annulus_derivs(xc,yc,theta,r,
     &               thetax, thetay, rx, ry)

      end

      subroutine map_comp2annulus_derivs(xc,yc,theta,r,
     &      thetax, thetay, rx, ry)
      implicit none

      double precision xc,yc,theta, r

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta_range(2)
      common /annulus_comm/ beta, theta_range

      double precision  thetax, thetay, rx, ry
      double precision tr1, tr2, pr1, pr2

c     # Map xc in [0,1] to theta in [0,2*pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      tr1 = pi2*theta_range(1)
      tr2 = pi2*theta_range(2)

      theta = tr1 + (tr2-tr1)*xc
      thetax = tr2-tr1
      thetay = 0

      r = beta + (1-beta)*yc
      rx = 0
      ry = 1-beta

      end

      subroutine map_annulus2comp(theta,r, xc,yc)
      implicit none

      double precision xc,yc,phi,theta, r

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta_range(2)
      common /annulus_comm/ beta, theta_range

      double precision tr1, tr2, pr1, pr2

c     # Map xc in [0,1] to theta in [0,2*pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      tr1 = pi2*theta_range(1)
      tr2 = pi2*theta_range(2)

      xc = (theta-tr1)/(tr2-tr1)
      yc = (r - beta)/(1-beta)

      end

      subroutine map2annulus(xp,yp,zp,theta,r)
      implicit none

      double precision xp,yp,zp,theta, r

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta_range(2)
      common /annulus_comm/ beta, theta_range

c      r1 = alpha*(1 + beta*sin(pi2*xc))
c      R = 1 + r1*cos(pi2*yc)
c
c      xp = R*cos(pi2*xc)
c      yp = R*sin(pi2*xc)
c      zp = r1*sin(pi2*yc)

      theta = atan2(yp,xp)    !! returns value in [-pi, pi]
      if (theta < 0) then
          theta = theta + pi2
      endif

      r = sqrt(xp**2 + yp**2)

      end

      subroutine map2comp(xp,yp,zp,xc,yc)
      implicit none

      double precision xp,yp,zp, xc,yc

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision r, theta

      call map2annulus(xp,yp,zp,theta,r)

      call map_annulus2comp(theta,r,xc,yc)

      end


! { dg-do run }
! { dg-options "-Warray-temporaries" }
! PR 71961 - no array temporary was created.
! Original test case by Joost VandeVondele
program main
  implicit none
  integer :: i
  integer, dimension(:,:), pointer :: a
  integer, dimension(:,:), allocatable :: b
  ALLOCATE(a(4,4),b(4,2))
  a=1 ; b=2
  a(:,1:2)=matmul(a(:,1:4),b(:,:)) ! { dg-warning "Creating array temporary" }
  if (any(a /= reshape((/8,8,8,8,8,8,8,8,1,1,1,1,1,1,1,1/),(/4,4/)))) &
       STOP 1
  a = reshape([((-1**i)*i,i=1,16)],[4,4])
  b = reshape([((-1**(i-1))*i**2,i=1,8)],[4,2])
  b(1:2,1:2) = matmul(a(1:2,:),b) ! { dg-warning "Creating array temporary" }
  if (any(b /= reshape([310, 340, -9, -16, 1478, 1652, -49, -64],[4,2]))) &
       STOP 2
  deallocate(a)
  deallocate(b)
end program main


PROGRAM test_vectors
!
!  Purpose:
!    To test the definitions, operations, and assignments
!    associated with the vector data type.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/15/06    S. J. Chapman        Original code
!
USE vectors
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
REAL, DIMENSION(3) :: array_out         ! Output array
TYPE (vector) :: vec_1, vec_2           ! Test vectors

! Test assignments by assigning an array to vec_1 and
! assigning vec_1 to array_out.
vec_1 = (/ 1., 2., 3. /)
array_out = vec_1
WRITE (*,1000) vec_1, array_out
1000 FORMAT (' Test assignments: ',/, &
             ' vec_1 =     ', 3F8.2,/, &
             ' array_out = ', 3F8.2)

! Test addition and subtraction.
vec_1 = (/ 10., 20., 30. /)
vec_2 = (/ 1., 2., 3. /)
WRITE (*,1010) vec_1, vec_2, vec_1 + vec_2, vec_1 - vec_2
1010 FORMAT (/' Test addition and subtraction: ',/, &
              ' vec_1 =         ', 3F8.2,/, &
              ' vec_2 =         ', 3F8.2,/, &
              ' vec_1 + vec_2 = ', 3F8.2,/, &
              ' vec_1 - vec_2 = ', 3F8.2)

! Test multiplication by a scalar.
vec_1 = (/ 1., 2., 3. /)
WRITE (*,1020) vec_1, 2.*vec_1, vec_1*2., 2*vec_1, vec_1*2
1020 FORMAT (/' Test multiplication by a scalar: ',/, &
              ' vec_1 =         ', 3F8.2,/, &
              ' 2. * vec_1 =    ', 3F8.2,/, &
              ' vec_1 * 2. =    ', 3F8.2,/, &
              ' 2 * vec_1  =    ', 3F8.2,/, &
              ' vec_1 * 2  =    ', 3F8.2)

! Test division by a scalar.
vec_1 = (/ 10., 20., 30. /)
WRITE (*,1030) vec_1, vec_1/5., vec_1/5
1030 FORMAT (/' Test division by a scalar: ',/, &
              ' vec_1 =         ', 3F8.2,/, &
              ' vec_1 / 5. =    ', 3F8.2,/, &
              ' vec_1 / 5 =     ', 3F8.2)

! Test dot product.
vec_1 = (/ 1., 2., 3. /)
vec_2 = (/ 1., 2., 3. /)
WRITE (*,1040) vec_1, vec_2, vec_1 .DOT. vec_2
1040 FORMAT (/' Test dot product: ',/, &
              ' vec_1 =             ', 3F8.2,/, &
              ' vec_2 =             ', 3F8.2,/, &
              ' vec_1 .DOT. vec_2 = ', 3F8.2)

! Test cross product.
vec_1 = (/ 1., -1., 1. /)
vec_2 = (/ -1., 1., 1. /)
WRITE (*,1050) vec_1, vec_2, vec_1*vec_2
1050 FORMAT (/' Test cross product: ',/, &
              ' vec_1 =         ', 3F8.2,/, &
              ' vec_2 =         ', 3F8.2,/, &
              ' vec_1 * vec_2 = ', 3F8.2)

END PROGRAM test_vectors


      subroutine EBGDFFACEDIVINCR(
     & divvel
     & ,idivvello0,idivvello1
     & ,idivvelhi0,idivvelhi1
     & ,vel
     & ,ivello0,ivello1
     & ,ivelhi0,ivelhi1
     & ,nvelcomp
     & ,gradvel
     & ,igradvello0,igradvello1
     & ,igradvelhi0,igradvelhi1
     & ,ngradvelcomp
     & ,iregionlo0,iregionlo1
     & ,iregionhi0,iregionhi1
     & ,dx
     & ,facedir
     & ,divdir
     & )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer idivvello0,idivvello1
      integer idivvelhi0,idivvelhi1
      REAL*8 divvel(
     & idivvello0:idivvelhi0,
     & idivvello1:idivvelhi1)
      integer nvelcomp
      integer ivello0,ivello1
      integer ivelhi0,ivelhi1
      REAL*8 vel(
     & ivello0:ivelhi0,
     & ivello1:ivelhi1,
     & 0:nvelcomp-1)
      integer ngradvelcomp
      integer igradvello0,igradvello1
      integer igradvelhi0,igradvelhi1
      REAL*8 gradvel(
     & igradvello0:igradvelhi0,
     & igradvello1:igradvelhi1,
     & 0:ngradvelcomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      integer facedir
      integer divdir
      integer ii,i,jj,j, gradcomp, sdim
      sdim = 2
          ii = chf_id(facedir, 0)
          jj = chf_id(facedir, 1)
          if (facedir .eq. divdir) then
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
             divvel(i,j) = divvel(i,j) +
     $ ( vel(i ,j ,facedir)
     $ - vel(i-ii,j-jj,facedir) )/dx
      enddo
      enddo
          else
             gradcomp = divdir + sdim*divdir
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
             divvel(i,j) = divvel(i,j) +
     $ ( gradvel(i ,j , gradcomp)
     $ + gradvel(i-ii,j-jj, gradcomp) )/(2.0d0)
      enddo
      enddo
          endif
      return
      end
      subroutine EBGDFGRADVEL(
     & grad
     & ,igradlo0,igradlo1
     & ,igradhi0,igradhi1
     & ,vel
     & ,ivello0,ivello1
     & ,ivelhi0,ivelhi1
     & ,iloboxlo0,iloboxlo1
     & ,iloboxhi0,iloboxhi1
     & ,haslo
     & ,ihiboxlo0,ihiboxlo1
     & ,ihiboxhi0,ihiboxhi1
     & ,hashi
     & ,icenterboxlo0,icenterboxlo1
     & ,icenterboxhi0,icenterboxhi1
     & ,dx
     & ,divdir
     & ,loworderoneside
     & )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer igradlo0,igradlo1
      integer igradhi0,igradhi1
      REAL*8 grad(
     & igradlo0:igradhi0,
     & igradlo1:igradhi1)
      integer ivello0,ivello1
      integer ivelhi0,ivelhi1
      REAL*8 vel(
     & ivello0:ivelhi0,
     & ivello1:ivelhi1)
      integer iloboxlo0,iloboxlo1
      integer iloboxhi0,iloboxhi1
      integer haslo
      integer ihiboxlo0,ihiboxlo1
      integer ihiboxhi0,ihiboxhi1
      integer hashi
      integer icenterboxlo0,icenterboxlo1
      integer icenterboxhi0,icenterboxhi1
      REAL*8 dx
      integer divdir
      integer loworderoneside
      integer ii,i,jj,j
      ii = chf_id(divdir, 0)
      jj = chf_id(divdir, 1)
      do j = icenterboxlo1,icenterboxhi1
      do i = icenterboxlo0,icenterboxhi0
      grad(i,j) =
     $ ( vel(i+ii,j+jj)
     $ - vel(i-ii,j-jj) )/((2.0d0)*dx)
      enddo
      enddo
      if(haslo.eq.1) then
         if(loworderoneside.eq.1) then
      do j = iloboxlo1,iloboxhi1
      do i = iloboxlo0,iloboxhi0
            grad(i,j) =
     $ ( vel(i+ii,j+jj)
     $ - vel(i ,j ))/(dx)
      enddo
      enddo
         else
      do j = iloboxlo1,iloboxhi1
      do i = iloboxlo0,iloboxhi0
            grad(i,j) =
     $ ((4.0d0)*(vel(i+ ii,j+ jj) - vel(i,j))
     $ - (vel(i+2*ii,j+2*jj) - vel(i,j)))/((2.0d0)*dx)
      enddo
      enddo
         endif
      endif
      if(hashi.eq.1) then
         if(loworderoneside.eq.1) then
      do j = ihiboxlo1,ihiboxhi1
      do i = ihiboxlo0,ihiboxhi0
            grad(i,j) =
     $ ( vel(i-ii,j-jj)
     $ - vel(i ,j ))/(-dx)
      enddo
      enddo
         else
      do j = ihiboxlo1,ihiboxhi1
      do i = ihiboxlo0,ihiboxhi0
            grad(i,j) =
     $ ((4.0d0)*(vel(i- ii,j- jj) - vel(i,j))
     $ - (vel(i-2*ii,j-2*jj) - vel(i,j)))/(-(2.0d0)*dx)
      enddo
      enddo
         endif
      endif
      return
      end
      subroutine EBGDFCELLGRAD(
     & graddiv
     & ,igraddivlo0,igraddivlo1
     & ,igraddivhi0,igraddivhi1
     & ,div
     & ,idivlo0,idivlo1
     & ,idivhi0,idivhi1
     & ,lambda
     & ,ilambdalo0,ilambdalo1
     & ,ilambdahi0,ilambdahi1
     & ,iregionlo0,iregionlo1
     & ,iregionhi0,iregionhi1
     & ,dx
     & ,facedir
     & ,imultbylambda
     & )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer igraddivlo0,igraddivlo1
      integer igraddivhi0,igraddivhi1
      REAL*8 graddiv(
     & igraddivlo0:igraddivhi0,
     & igraddivlo1:igraddivhi1)
      integer idivlo0,idivlo1
      integer idivhi0,idivhi1
      REAL*8 div(
     & idivlo0:idivhi0,
     & idivlo1:idivhi1)
      integer ilambdalo0,ilambdalo1
      integer ilambdahi0,ilambdahi1
      REAL*8 lambda(
     & ilambdalo0:ilambdahi0,
     & ilambdalo1:ilambdahi1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      integer facedir
      integer imultbylambda
      integer ii,i,jj,j
      ii = chf_id(facedir, 0)
      jj = chf_id(facedir, 1)
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
      graddiv(i,j) =
     $ ( div(i+ii,j+jj)
     $ - div(i ,j ) )/dx
      if(imultbylambda .eq. 1) then
         graddiv(i,j) = lambda(i,j)*graddiv(i,j)
      endif
      enddo
      enddo
      return
      end


*> \brief \b SLAROR
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          INIT, SIDE
*       INTEGER            INFO, LDA, M, N
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       REAL               A( LDA, * ), X( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAROR pre- or post-multiplies an M by N matrix A by a random
*> orthogonal matrix U, overwriting A.  A may optionally be initialized
*> to the identity matrix before multiplying by U.  U is generated using
*> the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*> \verbatim
*>          SIDE is CHARACTER*1
*>          Specifies whether A is multiplied on the left or right by U.
*>          = 'L':         Multiply A on the left (premultiply) by U
*>          = 'R':         Multiply A on the right (postmultiply) by U'
*>          = 'C' or 'T':  Multiply A on the left by U and the right
*>                          by U' (Here, U' means U-transpose.)
*> \endverbatim
*>
*> \param[in] INIT
*> \verbatim
*>          INIT is CHARACTER*1
*>          Specifies whether or not A should be initialized to the
*>          identity matrix.
*>          = 'I':  Initialize A to (a section of) the identity matrix
*>                   before applying U.
*>          = 'N':  No initialization.  Apply U to the input matrix A.
*>
*>          INIT = 'I' may be used to generate square or rectangular
*>          orthogonal matrices:
*>
*>          For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
*>          to each other, as will the columns.
*>
*>          If M < N, SIDE = 'R' produces a dense matrix whose rows are
*>          orthogonal and whose columns are not, while SIDE = 'L'
*>          produces a matrix whose rows are orthogonal, and whose first
*>          M columns are orthogonal, and whose remaining columns are
*>          zero.
*>
*>          If M > N, SIDE = 'L' produces a dense matrix whose columns
*>          are orthogonal and whose rows are not, while SIDE = 'R'
*>          produces a matrix whose columns are orthogonal, and whose
*>          first M rows are orthogonal, and whose remaining rows are
*>          zero.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of A.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA, N)
*>          On entry, the array A.
*>          On exit, overwritten by U A ( if SIDE = 'L' ),
*>           or by A U ( if SIDE = 'R' ),
*>           or by U A U' ( if SIDE = 'C' or 'T').
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry ISEED specifies the seed of the random number
*>          generator. The array elements should be between 0 and 4095;
*>          if not they will be reduced mod 4096.  Also, ISEED(4) must
*>          be odd.  The random number generator uses a linear
*>          congruential sequence limited to small integers, and so
*>          should produce machine independent random numbers. The
*>          values of ISEED are changed on exit, and can be used in the
*>          next call to SLAROR to continue the same random number
*>          sequence.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is REAL array, dimension (3*MAX( M, N ))
*>          Workspace of length
*>              2*M + N if SIDE = 'L',
*>              2*N + M if SIDE = 'R',
*>              3*N     if SIDE = 'C' or 'T'.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          An error flag.  It is set to:
*>          = 0:  normal return
*>          < 0:  if INFO = -k, the k-th argument had an illegal value
*>          = 1:  if the random numbers generated by SLARND are bad.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup real_matgen
*
*  =====================================================================
      SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          INIT, SIDE
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      REAL               A( LDA, * ), X( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TOOSML
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0,
     $                   TOOSML = 1.0E-20 )
*     ..
*     .. Local Scalars ..
      INTEGER            IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
      REAL               FACTOR, XNORM, XNORMS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLARND, SNRM2
      EXTERNAL           LSAME, SLARND, SNRM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMV, SGER, SLASET, SSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.EQ.0 .OR. M.EQ.0 )
     $   RETURN
*
      ITYPE = 0
      IF( LSAME( SIDE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
         ITYPE = 2
      ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN
         ITYPE = 3
      END IF
*
*     Check for argument errors.
*
      IF( ITYPE.EQ.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
         INFO = -4
      ELSE IF( LDA.LT.M ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLAROR', -INFO )
         RETURN
      END IF
*
      IF( ITYPE.EQ.1 ) THEN
         NXFRM = M
      ELSE
         NXFRM = N
      END IF
*
*     Initialize A to the identity matrix if desired
*
      IF( LSAME( INIT, 'I' ) )
     $   CALL SLASET( 'Full', M, N, ZERO, ONE, A, LDA )
*
*     If no rotation possible, multiply by random +/-1
*
*     Compute rotation by computing Householder transformations
*     H(2), H(3), ..., H(nhouse)
*
      DO 10 J = 1, NXFRM
         X( J ) = ZERO
   10 CONTINUE
*
      DO 30 IXFRM = 2, NXFRM
         KBEG = NXFRM - IXFRM + 1
*
*        Generate independent normal( 0, 1 ) random numbers
*
         DO 20 J = KBEG, NXFRM
            X( J ) = SLARND( 3, ISEED )
   20    CONTINUE
*
*        Generate a Householder transformation from the random vector X
*
         XNORM = SNRM2( IXFRM, X( KBEG ), 1 )
         XNORMS = SIGN( XNORM, X( KBEG ) )
         X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) )
         FACTOR = XNORMS*( XNORMS+X( KBEG ) )
         IF( ABS( FACTOR ).LT.TOOSML ) THEN
            INFO = 1
            CALL XERBLA( 'SLAROR', INFO )
            RETURN
         ELSE
            FACTOR = ONE / FACTOR
         END IF
         X( KBEG ) = X( KBEG ) + XNORMS
*
*        Apply Householder transformation to A
*
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
*
*           Apply H(k) from the left.
*
            CALL SGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA,
     $                  X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
            CALL SGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ),
     $                 1, A( KBEG, 1 ), LDA )
*
         END IF
*
         IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
*
*           Apply H(k) from the right.
*
            CALL SGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA,
     $                  X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
            CALL SGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ),
     $                 1, A( 1, KBEG ), LDA )
*
         END IF
   30 CONTINUE
*
      X( 2*NXFRM ) = SIGN( ONE, SLARND( 3, ISEED ) )
*
*     Scale the matrix A by D.
*
      IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
         DO 40 IROW = 1, M
            CALL SSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA )
   40    CONTINUE
      END IF
*
      IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
         DO 50 JCOL = 1, N
            CALL SSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
   50    CONTINUE
      END IF
      RETURN
*
*     End of SLAROR
*
      END


REAL*8 Function Romb(y,N,dx)
  IMPLICIT NONE
  REAL*8, intent(in) :: y(N)
  REAL*8, intent(in) :: dx
  INTEGER, intent(in):: N
  ! locals
  INTEGER :: Ninterv, ni, k, istart, istop, istep, i, j, nn
  REAL*8, allocatable:: R(:,:)
  REAL*8 :: h, dsum
  !maybe we should use JISHFT instead of ISHFT!
  !
  Ninterv = N-1
  h = Ninterv*dx
  ni = 1
  k = 0
  do while(ni.LT.Ninterv)
     ni = ISHFT(ni,1)
     k = k+1
  enddo

  allocate( R(k+1,k+1) )

  R(1,1) = (y(1) + y(N))/2.0*h

  istart = Ninterv
  istop  = Ninterv
  istep = Ninterv
  do i=2,k
     istart = ISHFT(istart,-1)

     dsum=0.0
     do j=istart,istop-1,istep
        dsum = dsum + y(j+1)
     enddo

     istep  = ISHFT(istep,-1)

     R(i,1) = 0.5*(R(i-1,1) + h*dsum)

     do j=2,i
        nn = ISHFT(1, (2*(j-1)))
        R(i,j) = R(i,j-1) + (R(i,j-1)-R(i-1,j-1))/(nn-1.)
     enddo
     h = h/2.0
  enddo
  Romb = R(k,k)
  deallocate( R)
  return
END Function Romb


    Program dstevr_example

!     DSTEVR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dstevr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: abstol, vl, vu
      Integer :: ifail, il, info, iu, ldz, liwork, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), w(:), work(:), z(:, :)
      Real (Kind=dp) :: rdum(1)
      Integer :: idum(1)
      Integer, Allocatable :: isuppz(:), iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DSTEVR Example Program Results'
      Write (nout, *)
!     Skip heading in data file and read N and the lower and upper
!     indices of the eigenvalues to be found
      Read (nin, *)
      Read (nin, *) n, il, iu
      ldz = n
      m = n
      Allocate (d(n), e(n-1), w(n), z(ldz,m), isuppz(2*n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      liwork = -1
      Call dstevr('Vectors', 'Indices', n, d, e, vl, vu, il, iu, abstol, m, w, &
        z, ldz, isuppz, rdum, lwork, idum, liwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max(20*n, nint(rdum(1)))
      liwork = max(10*n, idum(1))
      Allocate (work(lwork), iwork(liwork))

!     Read the diagonal and off-diagonal elements of the matrix A
!     from data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Set the absolute error tolerance for eigenvalues.  With ABSTOL
!     set to zero, the default value is used instead

      abstol = zero

!     Solve the symmetric tridiagonal eigenvalue problem
      Call dstevr('Vectors', 'Indices', n, d, e, vl, vu, il, iu, abstol, m, w, &
        z, ldz, isuppz, work, lwork, iwork, liwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Selected eigenvalues'
        Write (nout, 100) w(1:m)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, m, z, ldz, &
          'Selected eigenvectors', ifail)

      Else
        Write (nout, 110) 'Failure in DSTEVR. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (1X, A, I5)
    End Program


module geo3x3
  implicit none
contains
  character(50) function geo3x3_encode(lat, lng, level)
    real lat
    real lng
    integer level

    real flat
    real flng
    real unit
    integer i, x, y

    flat = lat
    flng = lng
    if (lng >= 0.0) then
      geo3x3_encode = "E"
    else
      geo3x3_encode = "W"
      flng = flng + 180.0
    end if
    flat = flat + 90.0
    unit = 180.0
    do i = 1, level - 1
      unit = unit / 3
      x = floor(flng / unit)
      y = floor(flat / unit)
      geo3x3_encode(i + 1: i + 1) = char(x + y * 3 + 1 + 48)
      flng = flng - x * unit
      flat = flat - y * unit
    end do
    !geo3x3_encode = "W"
  end

  function geo3x3_decode(code)
    character(len=*) code
    real geo3x3_decode(4)

    real lat
    real lng
    real level
    real unit
    integer flg, i, n

    lat = 0.0
    lng = 0.0
    level = 0
    unit = 180.0

    if (len(code) > 0) then
      flg = 0
      if (code(1:1) == "W") then
        flg = 1
      end if
      level = level + 1
      do i = 2, len(code)
        n = index("123456789", code(i:i)) - 1
        if (n >= 0) then
          unit = unit / 3
          lng = lng + mod(n, 3) * unit
          lat = lat + n / 3 * unit
          level = level + 1
        end if
      end do

      lat = lat + unit / 2
      lng = lng + unit / 2
      lat = lat - 90
      if (flg == 1) then
        lng = lng - 180.0
      end if
    end if
    geo3x3_decode = [lat, lng, level, unit]
  end
end


SUBROUTINE fdwvnum (hbot, omega, kinf, ulen, grav, nu)
!
! This subroutine takes the dimensional (SI) values of omega, infinite
! depth wavenumber kinf, and depth hbot, and returns the non-dimensional
! finite depth wavenumber nu*ulen.
!
  IMPLICIT NONE
  INTEGER, PARAMETER :: long=SELECTED_REAL_KIND(12,99)
  REAL(kind=long) hbot, ulen, omega, grav, nu, r0, hi, hh, his, his2, his4,       &
       his8, h, twoh, fourh, kinf, rh, r0h, fh, sh, bigh, smlh, bigexp,  &
       e2h
  DATA smlh / 1.d-05 /, bigh / 1.d+05 /, bigexp / 30.0d00 /

  h = hbot * kinf

  IF (h.lt.smlh) THEN
     nu = ulen * omega / SQRT (grav * hbot)
  ELSEIF (h.gt.bigh) THEN
     nu = ulen * kinf
  ELSE
     hi = 1. / h
     twoh = h + h
     fourh = twoh + twoh
     hh = h * h
     his = hi * hi
     his2 = his + his
     his4 = his2 + his2
     his8 = his4 + his4
!
! Evaluation of real root R0H of  R0H*TANH(R0H)=H
!
     e2h = EXP ( - MIN (twoh, bigexp) )
     IF (h.le.2.d00) THEN
        r0h = SQRT (h) * ( (.031d00 * h + .169d00) * h + 1.d00)
     ELSE
        r0h = h + h * e2h * (2.d00 - 12.d00 * e2h)
     ENDIF
     IF (h.le.4.8d00) THEN
        rh = hh - r0h * r0h
        sh = 1.d00 / (h - rh)
        fh = sh * (.5d00 * LOG ( (r0h + h) / (r0h - h) ) - r0h)
        r0h = r0h - fh * rh * (1.d00 + fh * r0h * h * sh)
     ENDIF
     nu = r0h * hi * kinf * ulen
  ENDIF
  RETURN
END SUBROUTINE fdwvnum


subroutine calc_dxyz(ib,jb,kb,rr,imt,jmt,km,dzt,dxdy,dxyz)
!====================================================================
! calculate the grid cell volume at the drifter's location
!
!  Input:
!    ib,jb,kb       : new position in grid space indices
!    rr             : time interpolation constant between 0 and 1. Controls how much
!                   : of earlier time step is used in interpolation.
!    imt,jmt,km     : grid index sizing constants in (x,y,z), are for
!                     horizontal and vertical rho grid [scalar]
!    dzt            : Height of k-cells in 3 dim in meters on rho vertical grid. [imt,jmt,km]
!    dxdy           : Area of horizontal cell-walls [imt,jmt]
!
!  Output:
!    dxyz           : Volume of drifter's grid cell
!
!  Other parameters used in function:
!    rg             : rg=1-rr for time interpolation between time steps. Controls how much
!                   : of later time step is used in interpolation.
!    nsm=1,nsp=2    : Time index. nsm picks out the earlier bounding time step and
!                     nsp picks out the later bounding time step for interpolation.
!
!  Notes:
!    KMT: Assuming zgrid3Dt flag which includes free surface already, I think. Other
!         flags aren't set up in the allocations or in the input variables,
!         for example, hs is not currently input since it is already included in
!         the dzt.
!====================================================================

implicit none

integer,        intent(in)                                      :: ib,jb,kb,km,jmt,imt
real(kind=8),   intent(in),     dimension(imt,jmt,km,2)         :: dzt
real(kind=8),   intent(in),     dimension(imt,jmt)              :: dxdy
real(kind=8),   intent(in)                                      :: rr
real(kind=8),   intent(out)                                     :: dxyz
real(kind=8)                                                    :: rg
integer                                                         :: nsm=1,nsp=2

rg=1.d0-rr

! T-box volume in m3
dxyz=rg*dzt(ib,jb,kb,nsp)+rr*dzt(ib,jb,kb,nsm)
dxyz=dxyz*dxdy(ib,jb)

end subroutine calc_dxyz


      subroutine pzcon(cnvrsn,grav,dynz,prsdb,depth)
!http://sam.ucsd.edu/sio210/propseawater/ppsw_fortran/pzcon.f
c
c     title:
c     *****
c
c       pzcon  -- convert pressure in decibars to depth in meters
c                 (or visa versa)
c
c     system:
c     ******
c
c       pacodf hydrographic data library
c
c     purpose:
c     *******
c
c       to calculate depth in meters (mantyla,saunders)
c       from pressure in decibars (or pressure from depth).
c
c       ref: journ. physical ocean.,vol 11 no. 4, april, 1981
c            (saunders)
c            private correspondence 1982-1983
c            (mantyla)
c
c     method:
c     ******
c
c       a standard ocean (salinity=35.0,t=0.0) is used plus a dynamic
c       height correction to account for deviations from the standard
c       ocean. pressure to depth conversion is effected as:
c
c       z = p/(b*c) + dynz/b
c
c       where:
c
c          p    = insitu pressure (decibars)
c          b    = insitu gravity as a function of latitude and pressure
c                 (decameters/sec/sec)
c          c    = insitu mean density rho(35.0,0.0,p)
c                 (grams/centimeter**3)
c          dynz = dynamic height in dynamic meters
c          z    = depth in meters
c
c     parameters:
c     **********
c
c       cnvrsn  -> conversion to be performed:
c                  0 = pressure to depth
c                  1 = depth to pressure
c       grav    -> acceleration of gravity meters/sec/sec
c                  at station latitude, pressure =0.0db
c       dynz    -> dynamic height in dynamic meters
c       prsdb   -> pressure in decibars (cnvrsn=0)
c               <- pressure in decibars (cnvrsn=1)
c       depth   <- depth in meters (cnvrsn=0)
c               -> depth in meters (cnvrsn=1)
c
        integer cnvrsn
        real grav,prsdb,dynz,depth
c
c     variables:
c     *********
c
        real*4 a,b,c
        real*8 dd,dg,dh,da,db,dc
c
c     external functions:
c     ******** *********
c
        integer isnan
c	  /* test for Not-A-Number */
c
c     code:
c     ****
c
c     select
c       (convert pressure to depth):
          if(cnvrsn.ne.0) go to 10
          a = 2.2e-6*prsdb
c             /* pressure correction to gravity */
          b = 0.1*(grav+0.5*a)
c             /* insitu gravity decameters/sec/sec */
c
          c = 1.0285+a
c             /* insitu mean density rho(35.0,0.0,p) */
c
          depth = prsdb/(b*c)
c             /* pressure to depth conversion in standard ocean */
c
c         select
c           (dynamic height):
              if(isnan(dynz).eq.0)
     1        depth = depth + dynz/b
c           (otherwise):
c         end select
          go to 999
c       (convert depth to pressure):
   10     continue
          dd = dble(depth)
          dg = dble(grav*0.1)
          dh = dble(dynz)
          da = 2.42d-13*dd
          db = dd*(1.13135d-7+2.2e-6*dg)-1.0
          dc = dg*dd
c         select
c           (dynamic height):
              if(isnan(dynz).ne.0) go to 20
              db = db - 2.2d-6*dh
              dc = dc-dh
c           (otherwise):
   20         continue
c         end select
c
          dc = 1.0285d0*dc
c
          prsdb  = 0.0
          if(da.ne.0.0)
     1    prsdb  = sngl((-db-dsqrt(db*db-4.0d0*da*dc))/(da+da))
c     end select
c
c     /* return */
c
  999 continue
c
      return
c
c     end pzcon
c
      end


PROGRAM wave2D

!*****************************************!
!* 2d shallow-Water model                *!
!*                                       *!
!* including:                            *!
!* - horizontal pressure-gradient force  *!
!* - Shapiro filter                      *!
!* - flooding algorithm                  *!
!*                                       *!
!* Author: J. Kaempf, 2008               *!
!*****************************************!

USE param
USE sub

INTEGER j,k

INTEGER wet(0:ny+1,0:nx+1)
REAL hmin, c, lambda

! local parameters
REAL hmax,time
INTEGER n,ntot,nout

!**********
CALL INIT  ! initialisation
!**********
! output of initial eta distribution
OPEN(10,file ='eta0.dat',form='formatted')
  DO j = 1,ny
    WRITE(10,'(101F12.6)')(eta(j,k),k=1,nx)
  END DO
CLOSE(10)

! output of initial layer thickness distribution
OPEN(10,file ='h0.dat',form='formatted')
  DO j = 1,ny
    WRITE(10,'(101F12.6)')(hzero(j,k),k=1,nx)
  END DO
CLOSE(10)

! set local parameters

! set epsilon for Shapiro filter
eps = 0.05

! runtime parameters
ntot = 1000

! output parameter
nout = 5

! determine maximum water depth
hmax = 0.

DO j = 1,ny
DO k = 1,nx
  hmax = MAX(hmax,h(j,k))
END DO
END DO

! maximum phase speed
c = SQRT(2*g*hmax)

! determine stability parameter
print *,dt,g,hmax,dx,dy

lambda = dt*SQRT(g*hmax)/MIN(dx,dy)
print *,"LAMBDA:",lambda
IF(lambda > 1)THEN
  WRITE(6,*) "This will not work. Do you know why?"
  STOP
END IF

#ifndef NO_IO
! open files for output
OPEN(10,file ='eta.dat',form='formatted')
OPEN(20,file ='h.dat',form='formatted')
OPEN(30,file ='u.dat',form='formatted')
OPEN(40,file ='v.dat',form='formatted')
#endif

DO j = 26,26
DO k = 26,26
eta(j,k) = 1.0
END DO
END DO

!---------------------------
! simulation loop
!---------------------------
DO n = 1,ntot

time = REAL(n)*dt

! call predictor
CALL dyn

! updating including Shapiro filter

CALL shapiro

DO j = 0,ny+1
DO k = 0,nx+1
  h(j,k) = hzero(j,k) + eta(j,k)
  wet(j,k) = 1
  IF(h(j,k)<hmin)wet(j,k) = 0
  u(j,k) = un(j,k)
  v(j,k) = vn(j,k)
END DO
END DO

#ifndef NO_IO
! data output
IF(MOD(n,nout)==0)THEN
  DO j = 1,ny
    WRITE(10,'(101F12.6)')(eta(j,k),k=1,nx)
    WRITE(20,'(101F12.6)')(h(j,k),k=1,nx)
    WRITE(30,'(101F12.6)')(u(j,k),k=1,nx)
    WRITE(40,'(101F12.6)')(v(j,k),k=1,nx)
  END DO
  WRITE(6,*)"Data output at time = ",time/60.0," min"
ENDIF
#endif

END DO ! end of iteration loop

END PROGRAM wave2D