C$Procedure      SURFPT ( Surface point on an ellipsoid )

      SUBROUTINE SURFPT ( POSITN, U, A, B, C, POINT, FOUND )

      IMPLICIT NONE

C$ Abstract
C
C     Determine the intersection of a line-of-sight vector with the
C     surface of an ellipsoid.
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     ELLIPSOID,  GEOMETRY
C
C$ Declarations

      DOUBLE PRECISION    POSITN ( 3 )
      DOUBLE PRECISION    U      ( 3 )
      DOUBLE PRECISION    A
      DOUBLE PRECISION    B
      DOUBLE PRECISION    C
      DOUBLE PRECISION    POINT  ( 3 )
      LOGICAL             FOUND

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     POSITN     I   Position of the observer in body-fixed frame.
C     U          I   Vector from the observer in some direction.
C     A          I   Length of ellipsoid semi-axis along the x-axis.
C     B          I   Length of ellipsoid semi-axis along the y-axis.
C     C          I   Length of ellipsoid semi-axis along the z-axis.
C     POINT      O   Point on the ellipsoid pointed to by U.
C     FOUND      O   Flag indicating if U points at the ellipsoid.
C
C$ Detailed_Input
C
C     POSITN     3-vector giving the position of an observer with
C                respect to the center of an ellipsoid. The vector is
C                expressed in a body-fixed reference frame. The
C                semi-axes of the ellipsoid are aligned with the x, y,
C                and z-axes of the body-fixed frame.
C
C     U          Pointing vector emanating from the observer.
C
C     A          Length of the semi-axis of the ellipsoid that is
C                parallel to the x-axis of the body-fixed reference
C                frame.
C
C     B          Length of the semi-axis of the ellipsoid that is
C                parallel to the y-axis of the body-fixed reference
C                frame.
C
C     C          Length of the semi-axis of the ellipsoid that is
C                parallel to the z-axis of the body-fixed reference
C                frame.
C
C$ Detailed_Output
C
C     POINT      If the ray with direction vector U emanating from
C                POSITN intersects the ellipsoid, POINT will be
C                returned with the body-fixed coordinates of the point
C                where the ray first meets the ellipsoid.  Otherwise,
C                POINT will be returned as (0, 0, 0).
C
C     FOUND      A logical flag indicating whether or not the ray from
C                POSITN with direction U actually intersects the
C                ellipsoid.  If the ray does intersect the ellipsoid,
C                FOUND will be returned as .TRUE. If the ray misses the
C                ellipsoid, FOUND will be returned as .FALSE.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine assumes that an ellipsoid having semi-axes of
C      length A, B and C is given.  Moreover, it is assumed that these
C      axes are parallel to the x-, y-, and z-axes of a reference frame
C      whose origin is the geometric center of the ellipsoid---this is
C      called the body-fixed reference frame.
C
C$ Examples
C
C      A typical use of SURFPT would be to obtain the planetocentric
C      coordinates of the point at which the optic axis of a
C      spacecraft-mounted instrument intersects the surface of a target
C      body, given the following items.
C
C         1) The epoch (ET) of observation, and the inertial
C            pointing (VPNT) of the instrument at this epoch.
C
C         2) The apparent position (VTARG) of the center of the
C            target body as seen from the spacecraft at the epoch
C            of observation, and the one-way light time (TAU)
C            from the target to the spacecraft.
C
C      In order to find the point of intersection, the following
C      items are also needed.
C
C         3) The transformation (TIBF) from inertial
C            to body-fixed coordinates at epoch ET-TAU.
C
C         4) The radii (R) of the tri-axial ellipsoid
C            used to model the target body.
C
C      These may be obtained from the kernel pool via calls to PXFORM
C      and BODVRD or BODVCD respectively.
C
C      The position of the observer is just the negative of the
C      spacecraft-target vector, VTARG, computed using the VMINUS
C      module. (Note that this is NOT the same as the apparent position
C      of the spacecraft as seen from the target!) Both vectors must be
C      specified in the body-fixed reference frame. The point of
C      intersection is found as follows:
C
C          CALL VMINUS ( VTARG, VPOS )
C          CALL MXV    ( TIBF,  VPOS,  VPOS )
C          CALL MXV    ( TIBF,  VPNT,  VPNT )
C
C          CALL SURFPT ( VPOS, VPNT, R(1), R(2), R(3), VSURF, FOUND )
C
C      Note that VSURF may or may not be a point of intersection,
C      depending on whether FOUND is .TRUE. or .FALSE. Note also that
C      VSURF is a vector from the center to the surface of the
C      target, in body-fixed coordinates, which may be converted
C      directly to planetocentric latitude, longitude, and radius:
C
C          CALL RECLAT ( VSURF, RADIUS, LONG, LAT )
C
C      To get the inertial vector from the spacecraft to the
C      surface point, you must subtract VPOS from VSURF, and rotate
C      the resulting vector back to inertial coordinates:
C
C          CALL VSUB ( VSURF, VPOS,  VSURF )
C          CALL MTXV ( TIBF,  VSURF, VSURF )
C
C
C$ Restrictions
C
C     None.
C
C$ Exceptions
C
C     1) If the input vector is the zero vector, the error
C        SPICE(ZEROVECTOR) is signaled.
C
C     2) If any of the body's axes is zero, the error
C        SPICE(BADAXISLENGTH) is signaled.
C
C$ Files
C
C     None.
C
C$ Author_and_Institution
C
C     C.H. Acton     (JPL)
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.3.0, 03-APR-2006 (NJB)
C
C        Bug fix:  intercept point is now always set to the
C        ray's vertex when the vertex is on the ellipsoid's
C        surface.  This routine now uses discovery check-in.
C
C-    SPICELIB Version 1.2.2, 24-OCT-2005 (NJB)
C
C        Updated header to refer to BODVRD and BODVCD instead of
C        BODVAR.
C
C-    SPICELIB Version 1.2.1, 27-JUL-2003 (NJB) (CHA)
C
C        Various header corrections were made.  The example program
C        was upgraded to use real kernels, and the program's output is
C        shown.
C
C-    SPICELIB Version 1.2.0, 28-NOV-2002 (NJB)
C
C        Re-implemented intercept computation to reduce loss of
C        precision.
C
C        Changed SAVE statement to save only the error message.
C        Previously all local variables were saved.
C
C-    SPICELIB Version 1.1.0, 07-AUG-1996 (WLT)
C
C        Added a SAVE statement so that the error message will
C        not be lost between separate invocations of the routine.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     line of sight intercept with body
C     point of intersection between ray and ellipsoid
C     surface point of intersection of ray and ellipsoid
C
C-&

C$ Revisions
C
C-     SPICELIB Version 1.2.0, 28-NOV-2002 (NJB)
C
C         Re-implemented intercept computation to reduce loss of
C         precision.  New algorithm maps input ellipsoid to unit
C         sphere, finds closest point on input ray to the origin,
C         then finds the offset from this point to the surface.
C
C-     Beta Version 2.0.0, 9-JAN-1988 (WLT)
C
C      Short error message 'SPICE(ZEROAXISLENGTH)' changed to
C      'SPICE(BADAXISLENGTH)'
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local parameters
C
      INTEGER               MSGDIM
      PARAMETER           ( MSGDIM = 7 )

      INTEGER               MSGLEN
      PARAMETER           ( MSGLEN = 32 )

C
C     Local variables
C
      CHARACTER*(MSGLEN)    MSSG  ( MSGDIM )

      DOUBLE PRECISION      P     ( 3 )
      DOUBLE PRECISION      PMAG
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      SIGN
      DOUBLE PRECISION      UX    ( 3 )
      DOUBLE PRECISION      X     ( 3 )
      DOUBLE PRECISION      Y     ( 3 )
      DOUBLE PRECISION      YMAG
      DOUBLE PRECISION      YPROJ ( 3 )

      INTEGER               BAD

C
C     Saved variables
C
      SAVE                  MSSG

C
C     Initial values
C
      DATA                  MSSG  / 'Axis A was nonpositive.',
     .                              'Axis B was nonpositive.',
     .                              'Axes A and B were nonpositive.',
     .                              'Axis C was nonpositive.',
     .                              'Axes A and C were nonpositive.',
     .                              'Axes B and C were nonpositive.',
     .                              'All three axes were nonpositive.' /

C
C     Use discovery check-in.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

C
C     Check the input vector to see if its the zero vector. If it is
C     signal an error and return.
C
      IF  ( VZERO(U) )  THEN

         CALL CHKIN  ( 'SURFPT'                                       )
         CALL SETMSG ( 'SURFPT: The input vector is the zero vector.' )
         CALL SIGERR ( 'SPICE(ZEROVECTOR)'                            )
         CALL CHKOUT ( 'SURFPT'                                       )
         RETURN

      END IF

C
C     Check the axis to make sure that none of them is less than or
C     equal to zero. If one is, signal an error and return.
C
      BAD = 0

      IF ( A .LE. 0 )
     .   BAD = BAD + 1

      IF ( B .LE. 0 )
     .   BAD = BAD + 2

      IF ( C .LE. 0 )
     .   BAD = BAD + 4

      IF ( BAD .GT. 0 ) THEN

         CALL CHKIN  ( 'SURFPT'                           )
         CALL SETMSG ( MSSG (BAD)                         //
     .                 ' ? '                              )
         CALL ERRCH  ( ' ? ', 'The A,B, and C axes were ' //
     .                        '#, #, and # respectively.' )

         CALL ERRDP  ( '#', A )
         CALL ERRDP  ( '#', B )
         CALL ERRDP  ( '#', C )

         CALL SIGERR ( 'SPICE(BADAXISLENGTH)' )
         CALL CHKOUT ( 'SURFPT' )
         RETURN

      END IF

C
C     We're done with the error checks.  Set the outputs to the
C     appropriate values for the "no intersection" case.
C
      FOUND = .FALSE.

      CALL CLEARD ( 3, POINT )

C
C     Apply a linear transformation to the point, direction vector,
C     and ellipsoid to transform the problem to one having the unit
C     sphere as the target ellipsoid.  (The transformation of the
C     ellipsoid is implicit.)
C
      X(1)  = U(1) / A
      X(2)  = U(2) / B
      X(3)  = U(3) / C

      Y(1)  = POSITN(1) / A
      Y(2)  = POSITN(2) / B
      Y(3)  = POSITN(3) / C

C
C     Find the component P of Y (the ray's vertex) orthogonal to X
C     (the ray's direction).
C
      CALL VPERP ( Y, X, P )

C
C     Find the component of Y parallel to X.
C
      CALL VSUB ( Y, P, YPROJ )

C
C     Find the magnitudes of Y and P.
C
      YMAG = VNORM(Y)
      PMAG = VNORM(P)

C
C     Get a unitized copy of X.
C
      CALL VHAT ( X, UX )

C
C     Now determine whether there's an intersection.  Consider
C     the case where Y is outside the sphere first.
C
      IF ( YMAG .GT. 1 ) THEN
C
C        If P is outside of the sphere, there can be no intersection.
C
         IF ( PMAG .GT. 1.D0 ) THEN
            RETURN
         END IF

C
C        If X points in the same direction as YPROJ, then the ray
C        is pointing away from the sphere, and there is no
C        intersection.
C
         IF (  VDOT(YPROJ, X) .GT. 0.D0 ) THEN
            RETURN
         END IF

C
C        At this point we know there's an intersection.
C
         IF ( PMAG .EQ. 1.D0 ) THEN
C
C           The vector P we've found is the singleton point of
C           intersection.  All we have to do is transform P by
C           applying the inverse of our original linear transformation.
C
            POINT(1) = P(1) * A
            POINT(2) = P(2) * B
            POINT(3) = P(3) * C

            FOUND    = .TRUE.
            RETURN

         END IF

C
C        At this point we know there's a non-trivial intersection.
C
C        Set the sign of the coefficient of UX (a unitized copy
C        of X) that will be used to compute the intercept point.
C        In this case the coefficient of UX has negative sign because
C        the vector we're adding to P points toward Y.
C
         SIGN = -1.D0

      ELSE IF ( YMAG .EQ. 1 ) THEN
C
C        The ray's vertex is on the surface of the ellipsoid.
C        The vertex is the first point of intersection.
C
         CALL VEQU ( POSITN, POINT )

         FOUND = .TRUE.
         RETURN

      ELSE
C
C        Y is inside the sphere, so there's definitely an intersection.
C        In this case, the intercept is obtained by adding a positive
C        multiple of UX to P.
C
         SIGN =  1.D0

      END IF

C
C
C     We have a small amount of work to do:  we'll find the multiple
C     of X that when added to P yields the desired intercept point.
C
C     The magnitude of the half-chord connecting P and the surface
C     is just
C             ____________
C           \/ 1 - PMAG**2
C
C
      SCALE = SQRT (  MAX ( 0.D0, 1-PMAG*PMAG )  )

C
C     Find the intercept point on the unit sphere.
C
      CALL VLCOM (  1.D0,  P,  SIGN * SCALE,  UX,  POINT  )

C
C     Undo our linear transformation.
C
      POINT(1) = POINT(1) * A
      POINT(2) = POINT(2) * B
      POINT(3) = POINT(3) * C

      FOUND    = .TRUE.

      RETURN
      END


REAL*8 function kern_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
kern_num = exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2/ &
      lx**2)
end function
REAL*8 function dkdx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx_num = -exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2 &
      /lx**2)*sin(x_a - x_b)*cos(x_a - x_b)/lx**2
end function
REAL*8 function dkdy_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy_num = -exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2 &
      /lx**2)*sin(y_a - y_b)*cos(y_a - y_b)/ly**2
end function
REAL*8 function dkdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx0_num = exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2 &
      /lx**2)*sin(x_a - x_b)*cos(x_a - x_b)/lx**2
end function
REAL*8 function dkdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy0_num = exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2 &
      /lx**2)*sin(y_a - y_b)*cos(y_a - y_b)/ly**2
end function
REAL*8 function d2kdxdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdx0_num = (-lx**2*sin(x_a - x_b)**2 + lx**2*cos(x_a - x_b)**2 - sin &
      (x_a - x_b)**2*cos(x_a - x_b)**2)*exp(-0.5d0*sin(y_a - y_b)**2/ly &
      **2 - 0.5d0*sin(x_a - x_b)**2/lx**2)/lx**4
end function
REAL*8 function d2kdydy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdydy0_num = (-ly**2*sin(y_a - y_b)**2 + ly**2*cos(y_a - y_b)**2 - sin &
      (y_a - y_b)**2*cos(y_a - y_b)**2)*exp(-0.5d0*sin(y_a - y_b)**2/ly &
      **2 - 0.5d0*sin(x_a - x_b)**2/lx**2)/ly**4
end function
REAL*8 function d2kdxdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdy0_num = -exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b &
      )**2/lx**2)*sin(x_a - x_b)*sin(y_a - y_b)*cos(x_a - x_b)*cos(y_a &
      - y_b)/(lx**2*ly**2)
end function
REAL*8 function d3kdxdx0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dy0_num = (-lx**2*sin(x_a - x_b)**2 + lx**2*cos(x_a - x_b)**2 - &
      sin(x_a - x_b)**2*cos(x_a - x_b)**2)*exp(-0.5d0*sin(y_a - y_b)**2 &
      /ly**2 - 0.5d0*sin(x_a - x_b)**2/lx**2)*sin(y_a - y_b)*cos(y_a - &
      y_b)/(lx**4*ly**2)
end function
REAL*8 function d3kdydy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dy0_num = (4*ly**4 + 3*ly**2*cos(2.0d0*y_a - 2.0d0*y_b) - sin( &
      y_a - y_b)**2*cos(y_a - y_b)**2)*exp(-0.5d0*(lx**2*sin(y_a - y_b) &
      **2 + ly**2*sin(x_a - x_b)**2)/(lx**2*ly**2))*sin(y_a - y_b)*cos( &
      y_a - y_b)/ly**6
end function
REAL*8 function d3kdxdy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dy0_num = (-ly**2*sin(y_a - y_b)**2 + ly**2*cos(y_a - y_b)**2 - &
      sin(y_a - y_b)**2*cos(y_a - y_b)**2)*exp(-0.5d0*sin(y_a - y_b)**2 &
      /ly**2 - 0.5d0*sin(x_a - x_b)**2/lx**2)*sin(x_a - x_b)*cos(x_a - &
      x_b)/(lx**2*ly**4)
end function
REAL*8 function dkdlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdlx_num = exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2 &
      /lx**2)*sin(x_a - x_b)**2/lx**3
end function
REAL*8 function dkdly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdly_num = exp(-0.5d0*sin(y_a - y_b)**2/ly**2 - 0.5d0*sin(x_a - x_b)**2 &
      /lx**2)*sin(y_a - y_b)**2/ly**3
end function
REAL*8 function d3kdxdx0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dlx_num = (-2*lx**4*cos(2.0d0*x_a - 2.0d0*x_b) + lx**2*(3*cos( &
      2.0d0*x_a - 2.0d0*x_b) + 2)*sin(x_a - x_b)**2 - sin(x_a - x_b)**4 &
      *cos(x_a - x_b)**2)*exp(-0.5d0*(lx**2*sin(y_a - y_b)**2 + ly**2* &
      sin(x_a - x_b)**2)/(lx**2*ly**2))/lx**7
end function
REAL*8 function d3kdydy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dlx_num = (-ly**2*sin(y_a - y_b)**2 + ly**2*cos(y_a - y_b)**2 - &
      sin(y_a - y_b)**2*cos(y_a - y_b)**2)*exp(-0.5d0*sin(y_a - y_b)**2 &
      /ly**2 - 0.5d0*sin(x_a - x_b)**2/lx**2)*sin(x_a - x_b)**2/(lx**3* &
      ly**4)
end function
REAL*8 function d3kdxdy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dlx_num = (2*lx**2 - sin(x_a - x_b)**2)*exp(-0.5d0*sin(y_a - y_b &
      )**2/ly**2 - 0.5d0*sin(x_a - x_b)**2/lx**2)*sin(x_a - x_b)*sin( &
      y_a - y_b)*cos(x_a - x_b)*cos(y_a - y_b)/(lx**5*ly**2)
end function
REAL*8 function d3kdxdx0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dly_num = (-lx**2*sin(x_a - x_b)**2 + lx**2*cos(x_a - x_b)**2 - &
      sin(x_a - x_b)**2*cos(x_a - x_b)**2)*exp(-0.5d0*sin(y_a - y_b)**2 &
      /ly**2 - 0.5d0*sin(x_a - x_b)**2/lx**2)*sin(y_a - y_b)**2/(lx**4* &
      ly**3)
end function
REAL*8 function d3kdydy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dly_num = (-2*ly**4*cos(2.0d0*y_a - 2.0d0*y_b) + ly**2*(3*cos( &
      2.0d0*y_a - 2.0d0*y_b) + 2)*sin(y_a - y_b)**2 - sin(y_a - y_b)**4 &
      *cos(y_a - y_b)**2)*exp(-0.5d0*(lx**2*sin(y_a - y_b)**2 + ly**2* &
      sin(x_a - x_b)**2)/(lx**2*ly**2))/ly**7
end function
REAL*8 function d3kdxdy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dly_num = (2*ly**2 - sin(y_a - y_b)**2)*exp(-0.5d0*sin(y_a - y_b &
      )**2/ly**2 - 0.5d0*sin(x_a - x_b)**2/lx**2)*sin(x_a - x_b)*sin( &
      y_a - y_b)*cos(x_a - x_b)*cos(y_a - y_b)/(lx**2*ly**5)
end function


      DOUBLE PRECISION FUNCTION DT_RNCLUS(N)

C***********************************************************************
C Nuclear radius for nucleus with mass number N.                       *
C This version dated 26.9.00  is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      INTEGER N
      DOUBLE PRECISION ONE , ONETHI , radnuc , RNUCLE , THREE
      SAVE

      PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)

C nucleon radius
      PARAMETER (RNUCLE=1.12D0)

C nuclear radii for selected nuclei
      DIMENSION radnuc(18)
      DATA radnuc/8*0.0D0 , 2.52D0 , 2.45D0 , 2.37D0 , 2.45D0 , 2.44D0 ,
     &     2.55D0 , 2.58D0 , 2.71D0 , 2.66D0 , 2.71D0/

      IF ( N.GT.18 ) THEN
         DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
      ELSE IF ( radnuc(N).GT.0.0D0 ) THEN
         DT_RNCLUS = radnuc(N)
      ELSE
         DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
      END IF

      END FUNCTION


  subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, &
             dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled)
  use array_lib
  use math_lib
  implicit none

! Purpose:
!   Create a discrete drop size distribution
!   Part of QuickBeam v1.03 by John Haynes
!   http://reef.atmos.colostate.edu/haynes/radarsim
!
! Inputs:
!   [Q]        hydrometeor mixing ratio (g/kg)
!   [Re]       Optional Effective Radius (microns).  0 = use default.
!   [D]        discrete drop sizes (um)
!   [nsizes]   number of elements of [D]
!   [dtype]    distribution type
!   [rho_a]    ambient air density (kg m^-3)
!   [tc]       temperature (C)
!   [dmin]     minimum size cutoff (um)
!   [dmax]     maximum size cutoff (um)
!   [rho_c]    alternate constant density (kg m^-3)
!   [p1],[p2],[p3]  distribution parameters
!
! Input/Output:
!   [fc]       scaling factor for the distribution
!   [scaled]   has this hydrometeor type been scaled?
!   [apm]      a parameter for mass (kg m^[-bpm])
!   [bmp]      b params for mass
!
! Outputs:
!   [N]        discrete concentrations (cm^-3 um^-1)
!              or, for monodisperse, a constant (1/cm^3)
!
! Requires:
!   function infind
!
! Created:
!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
! Modified:
!   01/31/06  Port from IDL to Fortran 90
!   07/07/06  Rewritten for variable DSD's
!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH)

! ----- INPUTS -----

  integer, intent(in) :: nsizes
  integer, intent(in) :: dtype
  real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, &
    rho_c,p1,p2,p3

! ----- INPUT/OUTPUT -----

  real*8, intent(inout) :: fc(nsizes),apm,bpm,Re
  logical, intent(inout) :: scaled

! ----- OUTPUTS -----

  real*8, intent(out) :: N(nsizes)

! ----- INTERNAL -----

  real*8 :: &
  N0,D0,vu,np,dm,ld, &             ! gamma, exponential variables
  dmin_mm,dmax_mm,ahp,bhp, &       ! power law variables
  rg,log_sigma_g, &           ! lognormal variables
  rho_e                       ! particle density (kg m^-3)

  real*8 :: tmp1, tmp2
  real*8 :: pi

  integer k,lidx,uidx

  pi = acos(-1.0)

! // if density is constant, store equivalent values for apm and bpm
  if ((rho_c > 0) .and. (apm < 0)) then
    apm = (pi/6)*rho_c
    bpm = 3.
  endif

  select case(dtype)

! ---------------------------------------------------------!
! // modified gamma                                        !
! ---------------------------------------------------------!
! :: N0 = total number concentration (m^-3)
! :: np = fixed number concentration (kg^-1)
! :: D0 = characteristic diameter (um)
! :: dm = mean diameter (um)
! :: vu = distribution width parameter

  case(1)
    if (abs(p1+1) < 1E-8) then

!     // D0, vu are given
      vu = p3

      if(Re.le.0) then
          dm = p2
     D0 = gamma(vu)/gamma(vu+1)*dm
      else
     D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
      endif

      if (scaled .eqv. .false.) then

        fc = ( &
             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
          ) * 1E-12
     scaled = .true.

      endif

      N = fc*rho_a*(Q*1E-3)

    elseif (abs(p2+1) < 1E-8) then

!     // N0, vu are given
      np = p1
      vu = p3
      tmp1 = (Q*1E-3)**(1./bpm)

      if (scaled .eqv. .false.) then

        fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** &
             (1./bpm))**vu

        scaled = .true.

      endif

      N = ( &
          (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
          exp(-1.*fc**(1./vu)/tmp1) &
       ) * 1E-12

    else

!     // vu isn't given
      print *, 'Error: Must specify a value for vu'
      stop

    endif

! ---------------------------------------------------------!
! // exponential                                           !
! ---------------------------------------------------------!
! :: N0 = intercept parameter (m^-4)
! :: ld = slope parameter (um)

  case(2)
    if (abs(p1+1) > 1E-8) then

!     // N0 has been specified, determine ld
      N0 = p1

      if(Re>0) then

     ! if Re is set and No is set than the distribution is fully defined.
     ! so we assume Re and No have already been chosen consistant with
     ! the water content, Q.

     ! print *,'using Re pass ...'

     ld = 1.5/Re   ! units 1/um

     N = ( &
               N0*exp(-1*ld*D) &
        ) * 1E-12

      else

          tmp1 = 1./(1.+bpm)

          if (scaled .eqv. .false.) then
          fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
          scaled = .true.

          endif

          N = ( &
          N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
     ) * 1E-12

      endif

    elseif (abs(p2+1) > 1E-8) then

!     // ld has been specified, determine N0
      ld = p2

      if (scaled .eqv. .false.) then

        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
        scaled = .true.

      endif

      N = fc*rho_a*(Q*1E-3)

    else

!     // ld will be determined from temperature, then N0 follows
      ld = 1220*10.**(-0.0245*tc)*1E-6
      N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))

      N = ( &
          N0*exp(-1*ld*D) &
          ) * 1E-12

    endif

! ---------------------------------------------------------!
! // power law                                             !
! ---------------------------------------------------------!
! :: ahp = Ar parameter (m^-4 mm^-bhp)
! :: bhp = br parameter
! :: dmin_mm = lower bound (mm)
! :: dmax_mm = upper bound (mm)

  case(3)

!   :: br parameter
    if (abs(p1+2) < 1E-8) then
!     :: if p1=-2, bhp is parameterized according to Ryan (2000),
!     :: applicatable to cirrus clouds
      if (tc < -30) then
        bhp = -1.75+0.09*((tc+273)-243.16)
      elseif ((tc >= -30) .and. (tc < -9)) then
        bhp = -3.25-0.06*((tc+273)-265.66)
      else
        bhp = -2.15
      endif
    elseif (abs(p1+3) < 1E-8) then
!     :: if p1=-3, bhp is parameterized according to Ryan (2000),
!     :: applicable to frontal clouds
      if (tc < -35) then
        bhp = -1.75+0.09*((tc+273)-243.16)
      elseif ((tc >= -35) .and. (tc < -17.5)) then
        bhp = -2.65+0.09*((tc+273)-255.66)
      elseif ((tc >= -17.5) .and. (tc < -9)) then
        bhp = -3.25-0.06*((tc+273)-265.66)
      else
        bhp = -2.15
      endif
    else
!     :: otherwise the specified value is used
      bhp = p1
    endif

!   :: Ar parameter
    dmin_mm = dmin*1E-3
    dmax_mm = dmax*1E-3

!   :: commented lines are original method with constant density
      ! rc = 500.        ! (kg/m^3)
      ! tmp1 = 6*rho_a*(bhp+4)
      ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
      ! ahp = (Q*1E-3)*1E12*tmp1/tmp2

!   :: new method is more consistent with the rest of the distributions
!   :: and allows density to vary with particle size
      tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
      tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
      ahp = tmp1/tmp2 * 1E24
      ! ahp = tmp1/tmp2

      lidx = infind(D,dmin)
      uidx = infind(D,dmax)
      do k=lidx,uidx

     N(k) = ( &
        ahp*(D(k)*1E-3)**bhp &
     ) * 1E-12

      enddo

     ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm

! ---------------------------------------------------------!
! // monodisperse                                          !
! ---------------------------------------------------------!
! :: D0 = particle diameter (um)

  case(4)

    if (scaled .eqv. .false.) then

      D0 = p1
      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
      fc(1) = (6./(pi*D0**3*rho_e))*1E12
      scaled = .true.

    endif

    N(1) = fc(1)*rho_a*(Q*1E-3)

! ---------------------------------------------------------!
! // lognormal                                             !
! ---------------------------------------------------------!
! :: N0 = total number concentration (m^-3)
! :: np = fixed number concentration (kg^-1)
! :: rg = mean radius (um)
! :: log_sigma_g = ln(geometric standard deviation)

  case(5)
    if (abs(p1+1) < 1E-8) then

!     // rg, log_sigma_g are given
      log_sigma_g = p3
      tmp2 = (bpm*log_sigma_g)**2.
      if(Re.le.0) then
          rg = p2
      else
     rg =Re*exp(-2.5*(log_sigma_g**2))
      endif

      if (scaled .eqv. .false.) then

        fc = 0.5 * ( &
          (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
          log_sigma_g*D*0.5*1E-6)) * &
          exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
          ) * 1E-12
     scaled = .true.

      endif

      N = fc*rho_a*(Q*1E-3)

    elseif (abs(p2+1) < 1E-8) then

!     // N0, log_sigma_g are given
      Np = p1
      log_sigma_g = p3
      N0 = np*rho_a
      tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
      tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.
      rg = ((tmp1/tmp2)**(1/bpm))*1E6

      N = 0.5*( &
        N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
     exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
     ) * 1E-12

    else

!     // vu isn't given
      print *, 'Error: Must specify a value for sigma_g'
      stop

    endif

  end select

  end subroutine dsd


program tsunami
    use mod_diff, only: diff => diff_centered
    use mod_initial, only: populate_gaussian
    use iso_fortran_env, only: int32, real32
    implicit none

    integer, parameter :: grid_size = 100
    integer, parameter :: num_steps = 100

    real(real32), parameter :: dx = 1, dt = .02

    integer, parameter :: mu = 25
    real(real32), parameter :: decay = 0.02

    integer :: step

    ! Physical values
    real(real32), parameter :: g = 9.8
    real(real32), parameter :: h_mean = 10.
    real(real32), dimension(grid_size) :: h, u  ! Height and velocity

    ! Sense check values
    if (num_steps <= 0) stop 'Must run for positive num_steps'
    if (dt <= 0) stop 'Must have positive time step dt'
    if (dx <= 0) stop 'Must have positive spatial resolution dx'

    call populate_gaussian(h, mu, decay)
    u = 0

    print *, 0, h  ! Print initial values to STDOUT

    update_loop: do step = 1, num_steps
        u = u - (u * diff(u) + g * diff(h)) / dx * dt
        h = h - diff(u * (h_mean + h)) / dx * dt
        print *, step, h
    end do update_loop

end program tsunami


*DECK BQR
      SUBROUTINE BQR (NM, N, MB, A, T, R, IERR, NV, RV)
C***BEGIN PROLOGUE  BQR
C***PURPOSE  Compute some of the eigenvalues of a real symmetric
C            matrix using the QR method with shifts of origin.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A6
C***TYPE      SINGLE PRECISION (BQR-S)
C***KEYWORDS  EIGENVALUES, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BQR,
C     NUM. MATH. 16, 85-92(1970) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971).
C
C     This subroutine finds the eigenvalue of smallest (usually)
C     magnitude of a REAL SYMMETRIC BAND matrix using the
C     QR algorithm with shifts of origin.  Consecutive calls
C     can be made to find further eigenvalues.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MB is the (half) band width of the matrix, defined as the
C          number of adjacent diagonals, including the principal
C          diagonal, required to specify the non-zero portion of the
C          lower triangle of the matrix.  MB is an INTEGER variable.
C          MB must be less than or equal to N on first call.
C
C        A contains the lower triangle of the symmetric band input
C          matrix stored as an N by MB array.  Its lowest subdiagonal
C          is stored in the last N+1-MB positions of the first column,
C          its next subdiagonal in the last N+2-MB positions of the
C          second column, further subdiagonals similarly, and finally
C          its principal diagonal in the N positions of the last column.
C          Contents of storages not part of the matrix are arbitrary.
C          On a subsequent call, its output contents from the previous
C          call should be passed.  A is a two-dimensional REAL array,
C          dimensioned A(NM,MB).
C
C        T specifies the shift (of eigenvalues) applied to the diagonal
C          of A in forming the input matrix. What is actually determined
C          is the eigenvalue of A+TI (I is the identity matrix) nearest
C          to T.  On a subsequent call, the output value of T from the
C          previous call should be passed if the next nearest eigenvalue
C          is sought.  T is a REAL variable.
C
C        R should be specified as zero on the first call, and as its
C          output value from the previous call on a subsequent call.
C          It is used to determine when the last row and column of
C          the transformed band matrix can be regarded as negligible.
C          R is a REAL variable.
C
C        NV must be set to the dimension of the array parameter RV
C          as declared in the calling program dimension statement.
C          NV is an INTEGER variable.
C
C     On OUTPUT
C
C        A contains the transformed band matrix.  The matrix A+TI
C          derived from the output parameters is similar to the
C          input A+TI to within rounding errors.  Its last row and
C          column are null (if IERR is zero).
C
C        T contains the computed eigenvalue of A+TI (if IERR is zero),
C          where I is the identity matrix.
C
C        R contains the maximum of its input value and the norm of the
C          last column of the input matrix A.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30 iterations.
C
C        RV is a one-dimensional REAL array of dimension NV which is
C          at least (2*MB**2+4*MB-3), used for temporary storage.  The
C          first (3*MB-2) locations correspond to the ALGOL array B,
C          the next (2*MB-1) locations correspond to the ALGOL array H,
C          and the final (2*MB**2-MB) locations correspond to the MB
C          by (2*MB-1) ALGOL array U.
C
C     NOTE. For a subsequent call, N should be replaced by N-1, but
C     MB should not be altered even when it exceeds the current N.
C
C     Calls PYTHAG(A,B) for SQRT(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BQR
C
      INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ
      INTEGER M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT
      REAL A(NM,*),RV(*)
      REAL F,G,Q,R,S,T,SCALE
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  BQR
      IERR = 0
      M1 = MIN(MB,N)
      M = M1 - 1
      M2 = M + M
      M21 = M2 + 1
      M3 = M21 + M
      M31 = M3 + 1
      M4 = M31 + M2
      MN = M + N
      MZ = MB - M1
      ITS = 0
C     .......... TEST FOR CONVERGENCE ..........
   40 G = A(N,MB)
      IF (M .EQ. 0) GO TO 360
      F = 0.0E0
C
      DO 50 K = 1, M
         MK = K + MZ
         F = F + ABS(A(N,MK))
   50 CONTINUE
C
      IF (ITS .EQ. 0 .AND. F .GT. R) R = F
      IF (R + F .LE. R) GO TO 360
      IF (ITS .EQ. 30) GO TO 1000
      ITS = ITS + 1
C     .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
      IF (F .GT. 0.25E0 * R .AND. ITS .LT. 5) GO TO 90
      F = A(N,MB-1)
      IF (F .EQ. 0.0E0) GO TO 70
      Q = (A(N-1,MB) - G) / (2.0E0 * F)
      S = PYTHAG(Q,1.0E0)
      G = G - F / (Q + SIGN(S,Q))
   70 T = T + G
C
      DO 80 I = 1, N
   80 A(I,MB) = A(I,MB) - G
C
   90 DO 100 K = M31, M4
  100 RV(K) = 0.0E0
C
      DO 350 II = 1, MN
         I = II - M
         NI = N - II
         IF (NI .LT. 0) GO TO 230
C     .......... FORM COLUMN OF SHIFTED MATRIX A-G*I ..........
         L = MAX(1,2-I)
C
         DO 110 K = 1, M3
  110    RV(K) = 0.0E0
C
         DO 120 K = L, M1
            KM = K + M
            MK = K + MZ
            RV(KM) = A(II,MK)
  120    CONTINUE
C
         LL = MIN(M,NI)
         IF (LL .EQ. 0) GO TO 135
C
         DO 130 K = 1, LL
            KM = K + M21
            IK = II + K
            MK = MB - K
            RV(KM) = A(IK,MK)
  130    CONTINUE
C     .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
  135    LL = M2
         IMULT = 0
C     .......... MULTIPLICATION PROCEDURE ..........
  140    KJ = M4 - M1
C
         DO 170 J = 1, LL
            KJ = KJ + M1
            JM = J + M3
            IF (RV(JM) .EQ. 0.0E0) GO TO 170
            F = 0.0E0
C
            DO 150 K = 1, M1
               KJ = KJ + 1
               JK = J + K - 1
               F = F + RV(KJ) * RV(JK)
  150       CONTINUE
C
            F = F / RV(JM)
            KJ = KJ - M1
C
            DO 160 K = 1, M1
               KJ = KJ + 1
               JK = J + K - 1
               RV(JK) = RV(JK) - RV(KJ) * F
  160       CONTINUE
C
            KJ = KJ - M1
  170    CONTINUE
C
         IF (IMULT .NE. 0) GO TO 280
C     .......... HOUSEHOLDER REFLECTION ..........
         F = RV(M21)
         S = 0.0E0
         RV(M4) = 0.0E0
         SCALE = 0.0E0
C
         DO 180 K = M21, M3
  180    SCALE = SCALE + ABS(RV(K))
C
         IF (SCALE .EQ. 0.0E0) GO TO 210
C
         DO 190 K = M21, M3
  190    S = S + (RV(K)/SCALE)**2
C
         S = SCALE * SCALE * S
         G = -SIGN(SQRT(S),F)
         RV(M21) = G
         RV(M4) = S - F * G
         KJ = M4 + M2 * M1 + 1
         RV(KJ) = F - G
C
         DO 200 K = 2, M1
            KJ = KJ + 1
            KM = K + M2
            RV(KJ) = RV(KM)
  200    CONTINUE
C     .......... SAVE COLUMN OF TRIANGULAR FACTOR R ..........
  210    DO 220 K = L, M1
            KM = K + M
            MK = K + MZ
            A(II,MK) = RV(KM)
  220    CONTINUE
C
  230    L = MAX(1,M1+1-I)
         IF (I .LE. 0) GO TO 300
C     .......... PERFORM ADDITIONAL STEPS ..........
         DO 240 K = 1, M21
  240    RV(K) = 0.0E0
C
         LL = MIN(M1,NI+M1)
C     .......... GET ROW OF TRIANGULAR FACTOR R ..........
         DO 250 KK = 1, LL
            K = KK - 1
            KM = K + M1
            IK = I + K
            MK = MB - K
            RV(KM) = A(IK,MK)
  250    CONTINUE
C     .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
         LL = M1
         IMULT = 1
         GO TO 140
C     .......... STORE COLUMN OF NEW A MATRIX ..........
  280    DO 290 K = L, M1
            MK = K + MZ
            A(I,MK) = RV(K)
  290    CONTINUE
C     .......... UPDATE HOUSEHOLDER REFLECTIONS ..........
  300    IF (L .GT. 1) L = L - 1
         KJ1 = M4 + L * M1
C
         DO 320 J = L, M2
            JM = J + M3
            RV(JM) = RV(JM+1)
C
            DO 320 K = 1, M1
               KJ1 = KJ1 + 1
               KJ = KJ1 - M1
               RV(KJ) = RV(KJ1)
  320    CONTINUE
C
  350 CONTINUE
C
      GO TO 40
C     .......... CONVERGENCE ..........
  360 T = T + G
C
      DO 380 I = 1, N
  380 A(I,MB) = A(I,MB) - G
C
      DO 400 K = 1, M1
         MK = K + MZ
         A(N,MK) = 0.0E0
  400 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = N
 1001 RETURN
      END


program main
	use libfft
	implicit none
	character (len=30) :: input_file
	complex, dimension(:), allocatable :: x_fft
	integer :: i

	call get_command_argument(1, input_file)
	call dft(input_file, x_fft)

	open(unit=20, file="data_fft.dat", status="replace", action="write")
	do i=1,size(x_fft)/2
		write(20,*) sqrt(real(x_fft(i)*conjg(x_fft(i))))
	enddo
	close(20)
end program main


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vhses.f
c
c     this file contains code and documentation for subroutines
c     vhses and vhsesi
c
c ... files which must be loaded with vhses.f
c
c     sphcom.f, hrfft.f
c
c
c     subroutine vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhses,lvhses,work,lwork,ierror)
c
c     subroutine vhses performs the vector spherical harmonic synthesis
c     of the arrays br, bi, cr, and ci and stores the result in the
c     arrays v and w. v(i,j) and w(i,j) are the colatitudinal
c     (measured from the north pole) and east longitudinal components
c     respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1)
c     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
c     representation of (v,w) is given below at output parameters v,w.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of syntheses.  in the program that calls vhses,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple syntheses will be performed.
c            the third index is the synthesis index which assumes the
c            values k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhaes. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhses. jdvw must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            below at the discription of output parameters v and w.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhses. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhses. ndab must be at
c            least nlat.
c
c     wvhses an array which must be initialized by subroutine vhsesi.
c            once initialized, wvhses can be used repeatedly by vhses
c            as long as nlon and nlat remain unchanged.  wvhses must
c            not be altered between calls of vhses.
c
c     lvhses the dimension of the array wvhses as it appears in the
c            program that calls vhses. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhses must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhses. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c                       (2*nt+1)*nlat*nlon
c
c            if ityp .gt. 2 then lwork must be at least
c
c                        (2*nt+1)*l2*nlon
c
c     **************************************************************
c
c     output parameters
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            in which the synthesis is stored. v is the colatitudinal
c            component and w is the east longitudinal component.
c            v(i,j),w(i,j) contain the components at colatitude
c            theta(i) = (i-1)*pi/(nlat-1) and longitude phi(j) =
c            (j-1)*2*pi/nlon. the index ranges are defined above at
c            the input parameter ityp. v and w are computed from the
c            formulas given below
c
c
c     define
c
c     1.  theta is colatitude and phi is east longitude
c
c     2.  the normalized associated legendre funnctions
c
c         pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative
c                        of (x**2-1)**n with respect to x=cos(theta)
c
c     3.  vbar(m,n,theta) = the derivative of pbar(m,n,theta) with
c                           respect to theta divided by the square
c                           root of n(n+1).
c
c         vbar(m,n,theta) is more easily computed in the form
c
c         vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta)
c         -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1)))
c
c     4.  wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided
c                           by the square root of n(n+1).
c
c         wbar(m,n,theta) is more easily computed in the form
c
c         wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1))
c         *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta))
c         /(2*sqrt(n*(n+1)))
c
c
c    the colatitudnal dependence of the normalized surface vector
c                spherical harmonics are defined by
c
c     5.    bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta))
c
c     6.    cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta))
c
c
c    the coordinate to index mappings
c
c     7.   theta(i) = (i-1)*pi/(nlat-1) and phi(j) = (j-1)*2*pi/nlon
c
c
c     the maximum (plus one) longitudinal wave number
c
c     8.     mmax = min0(nlat,nlon/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    if we further define the output vector as
c
c     9.    h(i,j) = (v(i,j),w(i,j))
c
c    and the complex coefficients
c
c     10.   b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1))
c
c     11.   c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1))
c
c
c    then for i=1,...,nlat and  j=1,...,nlon
c
c        the expansion for real h(i,j) takes the form
c
c     h(i,j) = the sum from n=1 to n=nlat-1 of the real part of
c
c         .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i)))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c              b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j))
c             +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j))
c
c   *************************************************************
c
c   in terms of real variables this expansion takes the form
c
c             for i=1,...,nlat and  j=1,...,nlon
c
c     v(i,j) = the sum from n=1 to n=nlat-1 of
c
c               .5*br(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c       (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c    and for i=1,...,nlat and  j=1,...,nlon
c
c     w(i,j) = the sum from n=1 to n=nlat-1 of
c
c              -.5*cr(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c      -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c
c      br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are
c      assumed zero for m even.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhses
c            = 10 error in the specification of lwork
c
c ************************************************************
c
c     subroutine vhsesi(nlat,nlon,wvhses,lvhses,work,lwork,dwork,
c    +                  ldwork,ierror)
c
c     subroutine vhsesi initializes the array wvhses which can then be
c     used repeatedly by subroutine vhses until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhses the dimension of the array wvhses as it appears in the
c            program that calls vhses. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhses must be at least
c
c                  l1*l2*(nlat+nlat-l1+1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhses. lwork must be at least
c
c              3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2+5*l2*nlat
c
c     dwork  an unsaved double precision work space
c
c     ldwork the length of the array dwork as it appears in the
c            program that calls vhsesi.  ldwork must be at least
c            2*(nlat+1)
c
c
c     **************************************************************
c
c     output parameters
c
c     wvhses an array which is initialized for use by subroutine vhses.
c            once initialized, wvhses can be used repeatedly by vhses
c            as long as nlat or nlon remain unchanged.  wvhses must not
c            be altered between calls of vhses.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lvhses
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c
c *****************************************
      SUBROUTINE DVHSES(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,
     +                 MDAB,NDAB,WVHSES,LVHSES,WORK,LWORK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WVHSES
      DOUBLE PRECISION WORK
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),WORK(1),
     +          WVHSES(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IF (ITYP.LT.0 .OR. ITYP.GT.8) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ITYP.LE.2.AND.IDVW.LT.NLAT) .OR.
     +    (ITYP.GT.2.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      IF (LVHSES.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 10
      IDV = NLAT
      IF (ITYP.GT.2) IDV = IMID
      LNL = NT*IDV*NLON
      IF (LWORK.LT.LNL+LNL+IDV*NLON) RETURN
      IERROR = 0
      IST = 0
      IF (ITYP.LE.2) IST = IMID
      IW1 = IST + 1
      IW2 = LNL + 1
      IW3 = IW2 + IST
      IW4 = IW2 + LNL
      JW1 = LZIMN + 1
      JW2 = JW1 + LZIMN
      CALL DVHSES1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,BR,
     +             BI,CR,CI,IDV,WORK,WORK(IW1),WORK(IW2),WORK(IW3),
     +             WORK(IW4),IDZ,WVHSES,WVHSES(JW1),WVHSES(JW2))
      RETURN
      END

      SUBROUTINE DVHSES1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,
     +                  BR,BI,CR,CI,IDV,VE,VO,WE,WO,WORK,IDZ,VB,WB,
     +                  WRFFT)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION VE
      DOUBLE PRECISION VO
      DOUBLE PRECISION WE
      DOUBLE PRECISION WO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION WRFFT
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),
     +          VE(IDV,NLON,1),VO(IDV,NLON,1),WE(IDV,NLON,1),
     +          WO(IDV,NLON,1),WORK(1),WRFFT(1),VB(IMID,1),WB(IMID,1)

      NLP1 = NLAT + 1
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      DO 10 K = 1,NT
          DO 10 J = 1,NLON
              DO 10 I = 1,IDV
                  VE(I,J,K) = 0.D0
                  WE(I,J,K) = 0.D0
   10 CONTINUE
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
   18 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
c
c     case ityp=0   no symmetries
c
c     case m = 0
c
    1 DO 15 K = 1,NT
          DO 15 NP1 = 2,NDO2,2
              DO 15 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
   15 CONTINUE
      DO 16 K = 1,NT
          DO 16 NP1 = 3,NDO1,2
              DO 16 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
   16 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 30 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 26
          DO 25 K = 1,NT
              DO 24 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 23 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
   23             CONTINUE
                  IF (MLAT.EQ.0) GO TO 24
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
   24         CONTINUE
   25     CONTINUE
   26     IF (MP2.GT.NDO2) GO TO 30
          DO 29 K = 1,NT
              DO 28 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 27 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
   27             CONTINUE
                  IF (MLAT.EQ.0) GO TO 28
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
   28         CONTINUE
   29     CONTINUE
   30 CONTINUE
      GO TO 950
c
c     case ityp=1   no symmetries,  cr and ci equal zero
c
c     case m = 0
c
  100 CONTINUE
      DO 115 K = 1,NT
          DO 115 NP1 = 2,NDO2,2
              DO 115 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  115 CONTINUE
      DO 116 K = 1,NT
          DO 116 NP1 = 3,NDO1,2
              DO 116 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  116 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 130 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 126
          DO 125 K = 1,NT
              DO 124 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 123 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  123             CONTINUE
                  IF (MLAT.EQ.0) GO TO 124
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
  124         CONTINUE
  125     CONTINUE
  126     IF (MP2.GT.NDO2) GO TO 130
          DO 129 K = 1,NT
              DO 128 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 127 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  127             CONTINUE
                  IF (MLAT.EQ.0) GO TO 128
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
  128         CONTINUE
  129     CONTINUE
  130 CONTINUE
      GO TO 950
c
c     case ityp=2   no symmetries,  br and bi are equal to zero
c
c     case m = 0
c
  200 DO 215 K = 1,NT
          DO 215 NP1 = 2,NDO2,2
              DO 215 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  215 CONTINUE
      DO 216 K = 1,NT
          DO 216 NP1 = 3,NDO1,2
              DO 216 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  216 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 230 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 226
          DO 225 K = 1,NT
              DO 224 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 223 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  223             CONTINUE
                  IF (MLAT.EQ.0) GO TO 224
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
  224         CONTINUE
  225     CONTINUE
  226     IF (MP2.GT.NDO2) GO TO 230
          DO 229 K = 1,NT
              DO 228 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 227 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  227             CONTINUE
                  IF (MLAT.EQ.0) GO TO 228
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
  228         CONTINUE
  229     CONTINUE
  230 CONTINUE
      GO TO 950
c
c     case ityp=3   v even,  w odd
c
c     case m = 0
c
  300 DO 315 K = 1,NT
          DO 315 NP1 = 2,NDO2,2
              DO 315 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  315 CONTINUE
      DO 316 K = 1,NT
          DO 316 NP1 = 3,NDO1,2
              DO 316 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  316 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 330 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 326
          DO 325 K = 1,NT
              DO 324 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 323 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  323             CONTINUE
                  IF (MLAT.EQ.0) GO TO 324
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
  324         CONTINUE
  325     CONTINUE
  326     IF (MP2.GT.NDO2) GO TO 330
          DO 329 K = 1,NT
              DO 328 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 327 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  327             CONTINUE
                  IF (MLAT.EQ.0) GO TO 328
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
  328         CONTINUE
  329     CONTINUE
  330 CONTINUE
      GO TO 950
c
c     case ityp=4   v even,  w odd, and both cr and ci equal zero
c
c     case m = 0
c
  400 DO 415 K = 1,NT
          DO 415 NP1 = 2,NDO2,2
              DO 415 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  415 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 430 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 430
          DO 429 K = 1,NT
              DO 428 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 427 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  427             CONTINUE
                  IF (MLAT.EQ.0) GO TO 428
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,MN)
  428         CONTINUE
  429     CONTINUE
  430 CONTINUE
      GO TO 950
c
c     case ityp=5   v even,  w odd,     br and bi equal zero
c
c     case m = 0
c
  500 DO 516 K = 1,NT
          DO 516 NP1 = 3,NDO1,2
              DO 516 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  516 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 530 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 530
          DO 525 K = 1,NT
              DO 524 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 523 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  523             CONTINUE
                  IF (MLAT.EQ.0) GO TO 524
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,MN)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,MN)
  524         CONTINUE
  525     CONTINUE
  530 CONTINUE
      GO TO 950
c
c     case ityp=6   v odd  ,  w even
c
c     case m = 0
c
  600 DO 615 K = 1,NT
          DO 615 NP1 = 2,NDO2,2
              DO 615 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  615 CONTINUE
      DO 616 K = 1,NT
          DO 616 NP1 = 3,NDO1,2
              DO 616 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  616 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 630 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 626
          DO 625 K = 1,NT
              DO 624 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 623 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  623             CONTINUE
                  IF (MLAT.EQ.0) GO TO 624
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
  624         CONTINUE
  625     CONTINUE
  626     IF (MP2.GT.NDO2) GO TO 630
          DO 629 K = 1,NT
              DO 628 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 627 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  627             CONTINUE
                  IF (MLAT.EQ.0) GO TO 628
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
  628         CONTINUE
  629     CONTINUE
  630 CONTINUE
      GO TO 950
c
c     case ityp=7   v odd, w even   cr and ci equal zero
c
c     case m = 0
c
  700 DO 716 K = 1,NT
          DO 716 NP1 = 3,NDO1,2
              DO 716 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1)
  716 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 730 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 730
          DO 725 K = 1,NT
              DO 724 NP1 = MP1,NDO1,2
                  MN = MB + NP1
                  DO 723 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,MN)
  723             CONTINUE
                  IF (MLAT.EQ.0) GO TO 724
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,MN)
  724         CONTINUE
  725     CONTINUE
  730 CONTINUE
      GO TO 950
c
c     case ityp=8   v odd,  w even   br and bi equal zero
c
c     case m = 0
c
  800 DO 815 K = 1,NT
          DO 815 NP1 = 2,NDO2,2
              DO 815 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1)
  815 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 830 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 830
          DO 829 K = 1,NT
              DO 828 NP1 = MP2,NDO2,2
                  MN = MB + NP1
                  DO 827 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,MN)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,MN)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,MN)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,MN)
  827             CONTINUE
                  IF (MLAT.EQ.0) GO TO 828
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,MN)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,MN)
  828         CONTINUE
  829     CONTINUE
  830 CONTINUE
  950 DO 14 K = 1,NT
          CALL DHRFFTB(IDV,NLON,VE(1,1,K),IDV,WRFFT,WORK)
          CALL DHRFFTB(IDV,NLON,WE(1,1,K),IDV,WRFFT,WORK)
   14 CONTINUE
      IF (ITYP.GT.2) GO TO 12
      DO 60 K = 1,NT
          DO 60 J = 1,NLON
              DO 60 I = 1,IMM1
                  V(I,J,K) = .5D0* (VE(I,J,K)+VO(I,J,K))
                  W(I,J,K) = .5D0* (WE(I,J,K)+WO(I,J,K))
                  V(NLP1-I,J,K) = .5D0* (VE(I,J,K)-VO(I,J,K))
                  W(NLP1-I,J,K) = .5D0* (WE(I,J,K)-WO(I,J,K))
   60 CONTINUE
      GO TO 13
   12 DO 11 K = 1,NT
          DO 11 J = 1,NLON
              DO 11 I = 1,IMM1
                  V(I,J,K) = .5D0*VE(I,J,K)
                  W(I,J,K) = .5D0*WE(I,J,K)
   11 CONTINUE
   13 IF (MLAT.EQ.0) RETURN
      DO 65 K = 1,NT
          DO 65 J = 1,NLON
              V(IMID,J,K) = .5D0*VE(IMID,J,K)
              W(IMID,J,K) = .5D0*WE(IMID,J,K)
   65 CONTINUE
      RETURN
      END

      SUBROUTINE DVHSESI(NLAT,NLON,WVHSES,LVHSES,WORK,LWORK,DWORK,
     +                   LDWORK,IERROR)
      DOUBLE PRECISION WVHSES
      DOUBLE PRECISION WORK
      DIMENSION WVHSES(LVHSES),WORK(LWORK)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMID = (NLAT+1)/2
      LZIMN = (IMID*MMAX* (NLAT+NLAT-MMAX+1))/2
      IF (LVHSES.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 4
      LABC = 3* (MAX0(MMAX-2,0)* (NLAT+NLAT-MMAX-1))/2
      IF (LWORK.LT.5*NLAT*IMID+LABC) RETURN
      IERROR = 5
      IF (LDWORK.LT.2* (NLAT+1)) RETURN
      IERROR = 0
      IW1 = 3*NLAT*IMID + 1
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      CALL DVES1(NLAT,NLON,IMID,WVHSES,WVHSES(LZIMN+1),IDZ,WORK,
     +          WORK(IW1),DWORK)
      CALL DHRFFTI(NLON,WVHSES(2*LZIMN+1))
      RETURN
      END
      SUBROUTINE DVES1(NLAT,NLON,IMID,VB,WB,IDZ,VIN,WZVIN,DWORK)
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION VIN
      DOUBLE PRECISION WZVIN
      DIMENSION VB(IMID,*),WB(IMID,*),VIN(IMID,NLAT,3),WZVIN(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(*)

      MMAX = MIN0(NLAT, (NLON+1)/2)
      CALL DVBINIT(NLAT,NLON,WZVIN,DWORK)
      DO 33 MP1 = 1,MMAX
          M = MP1 - 1
          CALL DVBIN(0,NLAT,NLON,M,VIN,I3,WZVIN)
          DO 33 NP1 = MP1,NLAT
              MN = M* (NLAT-1) - (M* (M-1))/2 + NP1
              DO 33 I = 1,IMID
                  VB(I,MN) = VIN(I,NP1,I3)
   33 CONTINUE
      CALL DWBINIT(NLAT,NLON,WZVIN,DWORK)
      DO 34 MP1 = 1,MMAX
          M = MP1 - 1
          CALL DWBIN(0,NLAT,NLON,M,VIN,I3,WZVIN)
          DO 34 NP1 = MP1,NLAT
              MN = M* (NLAT-1) - (M* (M-1))/2 + NP1
              DO 34 I = 1,IMID
                  WB(I,MN) = VIN(I,NP1,I3)
   34 CONTINUE
      RETURN
      END


C++******************************************************************
C OBJECT
C To create an image for simulations
C Written initially by A. Lannes
C
C Syntax:    OBJET NX,NY FILE
C Example:   objet 64,64 test.bdf
C
C JLP
C Version:  18-05-92
C--******************************************************************
	PROGRAM OBJECT
	PARAMETER(NMAX=40,NCLMAX=256)
	CHARACTER NAME*40, COMMENTS*80
	INTEGER X(NMAX),Y(NMAX),Z(NMAX)
	REAL A(NMAX),B(NMAX),SUM
	REAL OBJET(NCLMAX,NCLMAX)
	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

	WRITE(6,11)
11	FORMAT(' Program OBJECT, Version 18-05-92',/,
     1	' To create a test object for simulations')
	WRITE(6,12)
12	FORMAT(' Size of the output image (less than 256,256):')
	READ(5,*) NC,NL

	PI=3.14159265358979323846

C DEFINITION OBJET
C POSITION : X,Y ; Z : PARAM GAUSS ; A : AMPLITUDE
	NO = 26

C POINT 1 FOND CONTINU
        I=1
	X(I)=0
	Y(I)=0
	Z(I)=30
	A(I)=0.5

C POINT 2
        I=2
	X(I)=-8.
	Y(I)=-8.
	Z(I)=4
	A(I)=1

C Can be zeroed if needed:
C POINT 3
        I=3
	X(I)=8.
	Y(I)=8
	Z(I)=4
	A(I)=0.1

C Big spot on the middle:
C POINT 4
        I=4
	X(I)=-7
	Y(I)=8
	Z(I)=10
	A(I)=2.2

C Can be zeroed if needed:
C POINT 5
        I=5
	X(I)=-10
	Y(I)=-16
	Z(I)=4
	A(I)=0.1

C Two points on right:
C POINT 6
        I=6
	X(I)=26
	Y(I)=22
	Z(I)=4
	A(I)=2.

C POINT 13
        I=13
	X(I)=12
	Y(I)=24
	Z(I)=4
	A(I)=1.9

C POINT 7
        I=7
	X(I)= -4
	Y(I)=-7
	Z(I)=4
	A(I)=1.6

C POINT 8
        I=8
	X(I)= -24
	Y(I)=4
	Z(I)=4
	A(I)=1.2

C POINT 9
        I=9
	X(I)=3
	Y(I)=14
	Z(I)=4
	A(I)=0.5

C 3 points on top:
C POINT 10
        I=10
	X(I)=-13
	Y(I)=32
	Z(I)=4.5
	A(I)=2.2

C POINT 21
        I=21
	X(I)=-4
	Y(I)=25
	Z(I)=4.5
	A(I)=2.2

C POINT 22
        I=22
	X(I)=2
	Y(I)=34
	Z(I)=4.5
	A(I)=2.2

C POINT 12
        I=12
	X(I)=12
	Y(I)=-28
	Z(I)=4
	A(I)=1.8

C POINT 14
        I=14
	X(I)=-34
	Y(I)=20
	Z(I)=6
	A(I)=1.7

C Can be zeroed if needed:
C POINT 15
        I=15
	X(I)=-22
	Y(I)=5
	Z(I)=5
	A(I)=.9

C POINT 16
        I=16
	X(I)=-24
	Y(I)=8
	Z(I)=4
	A(I)=.5

C POINT 17
        I=17
	X(I)=-34
	Y(I)=20
	Z(I)=5
	A(I)=1.

C Big spot on the bottom:
C POINT 18
        I=18
	X(I)=-14
	Y(I)=-22
	Z(I)=10
	A(I)=2.3

C Can be zeroed if needed:
C POINT 19
        I=19
	X(I)=-12
	Y(I)=14
	Z(I)=4
	A(I)=0.1

C POINT 20
        I=20
	X(I)=4
	Y(I)=-30
	Z(I)=4
	A(I)=2.0

C Points to fill the gaps:
C POINT 23
        I=23
	X(I)=-20
	Y(I)=+20
	Z(I)=5
	A(I)=2.0

C POINT 24
        I=24
	X(I)=0
	Y(I)=-20
	Z(I)=4
	A(I)=2.0

C POINT 25
        I=25
	X(I)=-20
	Y(I)=-10
	Z(I)=4
	A(I)=2.0

C Two big spots on the right
C POINT 11
        I=11
	X(I)=+17
	Y(I)=+8
	Z(I)=10
	A(I)=2.1

C POINT 26
        I=26
	X(I)=+14
	Y(I)=-13
	Z(I)=10
	A(I)=2.2

C RECENTRAGE ET CALCUL DES PARAMETRES
	IXC=(NC/2)+1
	IYC=(NL/2)+1
	DO 1 N=1,NO
	  X(N) = IXC+X(N)*FLOAT(NC)/128.
	  Y(N) = IYC+Y(N)*FLOAT(NL)/128.
	  B(N) = -PI/FLOAT(Z(N)**2)
1	CONTINUE

C INTENSITE OBJET (GLOBAL) CENTRE
C OBTENUE LIGNE PAR LIGNE, POINT PAR POINT

        SUM=0.
	DO 2 J=1,NL
	DO 3 I=1,NC
	XO=0.
C EN CHAQUE POINT DU RESEAU LA CONTRIBUTION DE CHAQUE OBJET
	   DO 4 N=1,NO
	   TT=FLOAT((I-X(N))**2+(J-Y(N))**2)
	   XO = XO + A(N)*EXP(B(N)*TT)
4	   CONTINUE

	OBJET(I,J)= XO
        SUM=SUM+XO
3	CONTINUE
2	CONTINUE

C Normalization to one:
	DO 22 J=1,NL
	 DO 23 I=1,NC
           OBJET(I,J)=OBJET(I,J)/SUM
23       CONTINUE
22      CONTINUE

C ECRITURE DU TABLEAU OBJET DANS FICHIER OBJET.MID
	COMMENTS=' Simulated object'
	NAME=' '
	CALL JLP_WRITEIMAG(OBJET,NC,NL,NCLMAX,NAME,COMMENTS)
	CALL JLP_END
	STOP
	END


Program TestExpandDH
!------------------------------------------------------------------------------
!
!    This program will expand a grid containing n samples in both longitude and
!    latitude into spherical harmonics using the sampling theorems given in
!    Driscoll and Heally (1994).
!
!    Copyright (c) 2005, SHTOOLS
!    All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS
    use ftypes

    implicit none
    integer(int32), parameter :: maxdeg = 120, maxgrid = 800
    character(80) :: infile
    real(dp) :: cilm(2, maxdeg+1, maxdeg+1), grid(maxgrid, maxgrid), &
                griddh(maxgrid, maxgrid), cilm2(2, maxdeg+1, maxdeg+1), &
                interval, error, maxerror
    integer(int32) :: lmax, n, nlat, nlong, lmax2, l, m, i

    infile = "../../ExampleDataFiles/MarsTopo719.shape"

    call SHRead(infile, cilm, lmax)
    print*, "Lmax of data file = ", lmax

    !--------------------------------------------------------------------------
    !
    !     Create an equally sampled grid
    !
    !--------------------------------------------------------------------------

    lmax = 89
    print*, "For this test of SHExpandDH, the initial grid will be created with lmax = ", lmax

    interval = 1.0_dp

    print*, "Making grid using MakeGrid2D..."

    call MakeGrid2D(grid, cilm, lmax, interval, nlat, nlong)
    print*, "nlat, nlong = ", nlat, nlong

    print*, "Minimum and maximum values of the input grid = ", minval(grid(1:nlat, 1:nlong)), maxval(grid(1:nlat,1:nlong))

    n = nlat -1

    print*, "Number of samples in latitude used with SHExpandDH = ", n

    griddh(1:n,1:2*n) = grid(1:n, 1:2*n)

    !--------------------------------------------------------------------------
    !
    !    Expand equally spaced grid using Driscoll and Heally routine, and
    !    compute relative error between input and output spherical harmonic
    !    coefficients.
    !
    !--------------------------------------------------------------------------

    call SHExpandDH(griddh, n, cilm2, lmax2, sampling = 2)
    print*, "Lmax of Driscoll Heally expansion = ", lmax2

    maxerror = 0.0_dp

    do l = 0, lmax
        error = (cilm2(1,l+1,1)-cilm(1,l+1,1)) / cilm(1,l+1,1)
        if (error > maxerror) maxerror = error
        do m = 1, l, 1
            error = (cilm2(1,l+1,m+1)-cilm(1,l+1,m+1)) / cilm(1,l+1,m+1)
            if (error > maxerror) maxerror = error
            error = (cilm2(2,l+1,m+1)-cilm(2,l+1,m+1)) / cilm(2,l+1,m+1)
            if (error > maxerror) maxerror = error
        end do
    end do

    print*, "Maximum relative error between initial and output spherical harmonic coefficients = ", maxerror

    !--------------------------------------------------------------------------
    !
    !    Re-expand coefficients in the space domain, and compare
    !    with input grid.
    !
    !--------------------------------------------------------------------------

    griddh = 0.0_dp
    call MakeGridDH(griddh, n, cilm2, lmax2)
    print*, "Number of samples in latitude and longitude = ", n

    maxerror = 0.0_dp

    do i = 1, n
        error = maxval( abs( griddh(1:n,i) - grid(1:n, 2*i-1) ) )
        if (error > maxerror) maxerror = error
    end do

    print*, "Maximum error (meters) in the space domain = ", maxerror

end program TestExpandDH


FUNCTION Motion( Model,n,t ) RESULT(uy)
USE Types

IMPLICIT NONE

TYPE(Model_t) :: Model

INTEGER :: n
DOUBLE PRECISION :: t, uy, x, umax, tpulse

x = Model % Nodes % x(n)

! Total displacement
umax = 0.05

! Duration of the motion (umax)
tpulse = 0.6

x = Model % Nodes % x(n)

IF (t < tpulse/2) THEN
   uy = (umax/2)*(SIN((2*t-tpulse/2)/tpulse*pi)+1)
ELSE
   uy = umax
END IF

END FUNCTION Motion