C$Procedure  DIAGS2   ( Diagonalize symmetric 2x2 matrix )

      SUBROUTINE DIAGS2 ( SYMMAT, DIAG, ROTATE )

C$ Abstract
C
C     Diagonalize a symmetric 2x2 matrix.
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     ROTATION
C
C$ Keywords
C
C     ELLIPSE
C     MATRIX
C     ROTATION
C     TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION      SYMMAT ( 2, 2 )
      DOUBLE PRECISION      DIAG   ( 2, 2 )
      DOUBLE PRECISION      ROTATE ( 2, 2 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C
C     SYMMAT     I   A symmetric 2x2 matrix.
C     DIAG       O   A diagonal matrix similar to SYMMAT.
C     ROTATE     O   A rotation used as the similarity transformation.
C
C$ Detailed_Input
C
C     SYMMAT         A symmetric 2x2 matrix.  That is, SYMMAT has the
C                    form
C
C                       +-        -+
C                       |  A    B  |
C                       |          |.
C                       |  B    C  |
C                       +-        -+
C
C                    This routine uses only the upper-triangular
C                    elements of SYMMAT, that is, the elements
C
C                       SYMMAT(1,1)
C                       SYMMAT(1,2)
C                       SYMMAT(2,2)
C
C                    to determine the outputs DIAG and ROTATE.
C
C$ Detailed_Output
C
C     DIAG,
C     ROTATE         are, respectively, a diagonal matrix and a 2x2
C                    rotation matrix that satisfy the equation
C
C                                        T
C                       DIAG   =   ROTATE   *  SYMMAT  *  ROTATE.
C
C                    In other words, DIAG is similar to SYMMAT, and
C                    ROTATE is a change-of-basis matrix that
C                    diagonalizes SYMMAT.  DIAGS2 chooses ROTATE so
C                    that its angle of rotation has the smallest
C                    possible magnitude.  If there are two rotations
C                    that meet these criteria (they will be inverses of
C                    one another), either rotation may be chosen.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     1)  The matrix element SYMMAT(2,1) is not used in this routine's
C         computations, so the condition
C
C            SYMMAT(1,2)  .NE.  SYMMAT(2,1)
C
C         has no effect on this routine's outputs.
C
C$ Particulars
C
C     The capability of diagonalizing a 2x2 symmetric matrix is
C     especially useful in a number of geometric applications
C     involving quadratic curves such as ellipses.  Such curves are
C     described by expressions of the form
C
C           2                    2
C        A x   +   B xy   +   C y   +   D x    +    E y   +   F   =   0.
C
C     Diagonalization of the matrix
C
C        +-         -+
C        | A     B/2 |
C        |           |
C        | B/2     C |
C        +-         -+
C
C     allows us to perform a coordinate transformation (a rotation,
C     specifically) such that the equation of the curve becomes
C
C           2         2
C        P u   +   Q v   +   R u    +    S v   +   T   =   0
C
C     in the transformed coordinates.  This form is much easier to
C     handle.  If the quadratic curve in question is an ellipse,
C     we can easily find its center, semi-major axis, and semi-minor
C     axis from the second equation.
C
C     Ellipses turn up frequently in navigation geometry problems;
C     for example, the limb and terminator (if we treat the Sun as a
C     point source) of a body modelled as a tri-axial ellipsoid are
C     ellipses.
C
C     A mathematical note:  because SYMMAT is symmetric, we can ALWAYS
C     find an orthogonal similarity transformation that diagonalizes
C     SYMMAT, and we can choose the similarity transformation to be a
C     rotation matrix.  By `orthogonal' we mean that if the ROTATE is
C     the matrix in question, then
C
C              T                         T
C        ROTATE  ROTATE  =  ROTATE ROTATE  =  I.
C
C     The reasons this routine handles only the 2x2 case are:  first,
C     the 2x2 case is much simpler than the general case, in which
C     iterative diagonalization methods must be used, and second, the
C     2x2 case is adequate for solving problems involving ellipses in
C     3 dimensional space.  Finally, this routine can be used to
C     support a routine that solves the general-dimension
C     diagonalization problem for symmetric matrices.
C
C     Another feature of the routine that might provoke curiosity is
C     its insistence on choosing the diagonalization matrix that
C     rotates the original basis vectors by the smallest amount.  The
C     rotation angle of ROTATE is of no concern for most applications,
C     but can be important if this routine is used as part of an
C     iterative diagonalization method for higher-dimensional matrices.
C     In that case, it is most undesirable to interchange diagonal
C     matrix elements willy-nilly; the matrix to be diagonalized could
C     get ever closer to being diagonal without converging.  Choosing
C     the smallest rotation angle precludes this possibility.
C
C$ Examples
C
C     1)  A case that can be verified by hand computation:
C         Suppose SYMMAT is
C
C            +-                -+
C            |  1.0D0    4.0D0  |
C            |                  |
C            |  4.0D0   -5.0D0  |
C            +-                -+
C
C         Then SYMMAT is similar to the diagonal matrix
C
C            +-                -+
C            |  3.0D0    0.0D0  |
C            |                  |
C            |  0.0D0   -7.0D0  |
C            +-                -+
C
C         so
C
C            DIAG(1,1) =  3.D0
C            DIAG(2,1) =  0.D0
C            DIAG(1,2) =  0.D0
C            DIAG(2,2) = -7.D0
C
C         and ROTATE is
C
C            +-                                   -+
C            |   0.894427191          -0.447213595 |
C            |                                     |
C            |   0.447213595           0.894427191 |
C            +-                                   -+
C
C        which is an approximation to
C
C            +-                                   -+
C            |  0.4 * 5**(1/2)     -0.2 * 5**(1/2) |
C            |                                     |
C            |  0.2 * 5**(1/2)      0.4 * 5**(1/2) |
C            +-                                   -+
C
C
C     2)  Suppose we want to find the semi-axes of the ellipse defined
C         by
C                2                 2
C            27 x  +  10 xy  +  3 y   =  1.
C
C         We can write the above equation as the matrix equation
C
C            +-     -+  +-         -+  +- -+
C            | x   y |  | 27     5  |  | x |    =   1;
C            +-     -+  |           |  |   |
C                       |  5     3  |  | y |
C                       +-         -+  +- -+
C
C         let SYMMAT be the symmetric matrix on the left.  The code
C         fragment
C
C            SYMMAT(1,1)  =  27.D0
C            SYMMAT(2,1)  =   5.D0
C            SYMMAT(1,2)  =   5.D0
C            SYMMAT(2,2)  =   3.D0
C
C            CALL DIAGS2 ( SYMMAT, DIAG, ROTATE )
C
C         will return DIAG, an array containing the eigenvalues of
C         SYMMAT, and ROTATE, the coordinate transformation required
C         to diagonalize SYMMAT.  In this case,
C
C            DIAG(1,1)   =  28.D0
C            DIAG(2,1)   =  0.D0
C            DIAG(1,2)   =  0.D0
C            DIAG(2,2)   =  2.D0
C
C          and
C
C            ROTATE(1,1) =  0.980580676D0
C            ROTATE(2,1) =  0.196116135D0
C            ROTATE(1,2) = -0.196116135D0
C            ROTATE(2,2) =  0.980580676D0
C
C         The columns of ROTATE give the ellipse's axes, after scaling
C         them by
C
C                   1                            1
C            ----------------     and     ---------------
C              ____________                 ____________
C            \/  DIAG(1,1)                \/  DIAG(2,2)
C
C         respectively.
C
C         If SMAJOR and SMINOR are semi-major and semi-minor axes,
C         we can find them as shown below.  For brevity, we omit the
C         check for zero or negative eigenvalues.  Negative or zero
C         eigenvalues will occur only as a result of round-off error;
C         mathematically, the eigenvalues of the matrix SYMMAT are
C         guaranteed to be positive, since they are the reciprocals of
C         the squares of the lengths of the ellipse's semi-axes.
C
C            DO I = 1, 2
C               SMAJOR(I) = ROTATE(I,1)  /  DSQRT( DIAG(1,1) )
C               SMINOR(I) = ROTATE(I,2)  /  DSQRT( DIAG(2,2) )
C            END DO
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1]  Calculus, Vol. II.  Tom Apostol.  John Wiley & Sons, 1969.
C          See Chapter 5, `Eigenvalues of Operators Acting on Euclidean
C          Spaces'.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 06-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VHATG and SWAPD calls.
C
C-    SPICELIB Version 1.1.0, 24-JAN-2002 (EDW)
C
C        Edited incorrect examples in the header. The example
C        outputs did not correspond to the actual function
C        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, 04-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     diagonalize symmetric 2x2_matrix
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 06-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VHATG and SWAPD calls.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      EIGVEC ( 2 )
      DOUBLE PRECISION      IDENT  ( 2, 2 )
      DOUBLE PRECISION      ROOT1  ( 2 )
      DOUBLE PRECISION      ROOT2  ( 2 )
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      TMPD
      DOUBLE PRECISION      TMPV   ( 2 )

C
C     Saved variables
C
      SAVE                  IDENT

C
C     Initial values
C
      DATA IDENT /  1.D0, 0.D0,
     .              0.D0, 1.D0  /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'DIAGS2' )
      END IF

C
C     We check for the case of a diagonal input matrix, since
C     eigenvector determination is simplified by ruling out this
C     case.

      IF  ( SYMMAT(1,2) .EQ. 0.D0 ) THEN

         CALL MOVED  ( IDENT,  4, ROTATE )
         CALL MOVED  ( SYMMAT, 4, DIAG   )
C
C        Explicity zero out the (2,1) entry of DIAG, since DIAG is
C        guaranteed to be diagonal.
C
         DIAG(2,1) = 0.D0

         CALL CHKOUT ( 'DIAGS2' )
         RETURN

      END IF

C
C     Getting here means there's some actual work to do.  We start out
C     by scaling our matrix, in order to reduce the chance of overflow.
C     We divide everything by the largest magnitude of any element of
C     SYMMAT.  We're guaranteed that SCALE is non-zero, since the 0
C     matrix is diagonal.
C
      SCALE  =  MAX (  DABS( SYMMAT(1,1) ),
     .                 DABS( SYMMAT(1,2) ),
     .                 DABS( SYMMAT(2,2) )   )

      A      =  SYMMAT(1,1) / SCALE
      B      =  SYMMAT(1,2) / SCALE
      C      =  SYMMAT(2,2) / SCALE

C
C     Compute the eigenvalues of the scaled version of SYMMAT.  The
C     eigenvalues are roots of the equation
C
C          DET (  (1 / SCALE) * SYMMAT  -  x * IDENTITY  ) = 0,
C
C     or equivalently,
C
C           2                             2
C          x   -  ( A + C ) x  +  ( AC - B )  =   0.
C
C
      CALL RQUAD (  1.D0,  -(A + C),   A*C - B**2,   ROOT1,   ROOT2   )

C
C     ROOT1 is the root corresponding to the positive discriminant term;
C     this is guaranteed by RQUAD.
C
      DIAG(1,1) = ROOT1(1)
      DIAG(2,1) = 0.D0
      DIAG(1,2) = 0.D0
      DIAG(2,2) = ROOT2(1)

C
C     Our next job is to find an eigenvector corresponding to the
C     eigenvalue of smaller magnitude.  We can unitize it and choose
C     an orthogonal unit vector so as to create the desired rotation
C     matrix.
C
C        If our original matrix is
C
C           +-        -+
C           |  A    B  |
C           |          |,
C           |  B    C  |
C           +-        -+
C
C        then the matrix
C
C           +-                                -+
C           |  A - DIAG(x,x)    B              |
C           |                                  |
C           |  B                C - DIAG(x,x)  |
C           +-                                -+
C
C        maps to zero all elements of the eigenspace corresponding to
C        DIAG(x,x), where x is either 1 or 2.
C
C        So
C
C           +-               -+           +-               -+
C           |  B              |           |  DIAG(x,x) - C  |
C           |                 |   and     |                 |
C           |  DIAG(x,x) - A  |           |  B              |
C           +-               -+           +-               -+
C
C        are candidates for eigenvectors for DIAG(x,x).  To minimize
C        loss of accuracy in our eigenvector due to subtraction of
C        nearly equal quantities, we choose the vector in which the
C        term involving the eigenvalue has the larger magnitude.  The
C        rigorous justification of this choice would literally take
C        pages of explanation, and we are not going to go through it
C        here.  In most cases, either choice is satisfactory, and in
C        the case where cancellation is a problem, our choice is
C        preferable.
C
C        Note that there is nothing to be gained as far as accuracy is
C        concerned by working with one eigenvalue as opposed to the
C        other:  the magnitudes of the quantities DIAG(x,x) - A and
C        DIAG(x,x) - C would be interchanged by taking x = '2' instead
C        of x = '1'.
C

      IF (  DABS( DIAG(1,1) - A ) .GE. DABS( DIAG(1,1) - C )  ) THEN
C
C        In this case, the second eigenvector component EIGVEC(2)
C        should be larger than |B|; we explain why in detail below.
C        We use the MAX function below to guard against reversal of the
C        inequality due to round-off error.
C
         EIGVEC(1)  =  B
         EIGVEC(2)  =  MAX (   DIAG(1,1) - A,   ABS(B)   )

C
C        Recall that DIAG(1,1) is an eigenvalue of the scaled version
C        of SYMMAT
C
C           +-      -+
C           | A    B |
C           |        |.
C           | B    C |
C           +-      -+
C
C        DIAG(1,1) is the positive-discriminant root of this matrix's
C        characteristic equation.  EIGVEC's y-component
C
C           DIAG(1,1) - A
C
C        is positive and of magnitude at least as large as that of B,
C        since it is the larger of
C                                                 ______________________
C                                                /         2
C                             C - A             / ( A - C )           2
C           DIAG(1,1) - A  =  -----   +     \  /  ----------    +    B
C                               2            \/       4
C
C        and
C                                                 ______________________
C                                                /         2
C                             A - C             / ( A - C )           2
C           DIAG(1,1) - C  =  -----   +     \  /  ----------    +    B
C                               2            \/       4
C
C        Equality between these expressions can occur only when A is
C        equal to C, in which case both expressions are equal (except
C        for round-off error) to |B|.
C

C
C        So the argument of EIGVEC is in the interval [pi/4, 3*pi/4].
C        The second eigenvector is EIGVEC, and the first
C        eigenvector is found by rotating EIGVEC by -pi/2.  Since
C        DIAG(1,1) is the eigenvalue for the SECOND eigenvector, we
C        must swap the eigenvalues.
C

C
C        Unitize the eigenvector.
C
         CALL VHATG ( EIGVEC, 2, TMPV   )
         CALL MOVED ( TMPV,   2, EIGVEC )

         ROTATE(1,1)  =  EIGVEC(2)
         ROTATE(2,1)  = -EIGVEC(1)
         ROTATE(1,2)  =  EIGVEC(1)
         ROTATE(2,2)  =  EIGVEC(2)

C
C        Swap DIAG(1,1) and DIAG(2,2).
C
         TMPD         =  DIAG(2,2)
         DIAG(2,2)    =  DIAG(1,1)
         DIAG(1,1)    =  TMPD

      ELSE

         EIGVEC(1)  =  MAX (  DIAG(1,1) - C,   ABS(B)  )
         EIGVEC(2)  =  B

C
C        The x-component of EIGVEC is positive and has magnitude
C        greater than or equal to that of the y-component of EIGVEC.
C        The argument of EIGVEC is in [-pi/4, pi/4], and the second
C        eigenvector is found by rotating EIGVEC by pi/2.
C

C
C        Unitize the eigenvector.
C
         CALL VHATG ( EIGVEC, 2, TMPV   )
         CALL MOVED ( TMPV,   2, EIGVEC )

         ROTATE(1,1)  =  EIGVEC(1)
         ROTATE(2,1)  =  EIGVEC(2)
         ROTATE(1,2)  = -EIGVEC(2)
         ROTATE(2,2)  =  EIGVEC(1)

      END IF

C
C     We must scale the eigenvalues.
C
      DIAG(1,1)  =  DIAG(1,1)  *  SCALE
      DIAG(2,2)  =  DIAG(2,2)  *  SCALE

      CALL CHKOUT ( 'DIAGS2' )
      RETURN
      END


subroutine eval_surface(u, v, tu, tv, ku, kv, coef, nctlu, nctlv, ndim, &
     n, m, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_surface evaluates (possibly) many points on the surface
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, u coordinate, size(m, n)
  !     v       - Real, v coordinate, size(m, n)
  !     tu      - Real, Knot vector in u. size(nctlu+ku)
  !     tv      - Real, Knot vector in v. size(nctlv+kv)
  !     ku      - Integer, order of B-spline in u
  !     kv      - Integer, order of B-spline in v
  !     coef    - Real, Array of B-spline coefficients  Size (ndim, nctlv, nctlu)
  !     nctlu   - Integer, Number of control points in u
  !     nctlv   - Integer, Number of control points in v
  !     ndim    - Integer, Spatial Dimension
  !
  !     Ouput
  !     val     - Real, Evaluated point(s), size (ndim, m, n)

  use precision
  implicit none

  ! Input
  integer         , intent(in)    :: ku, kv, nctlu, nctlv, ndim, n, m
  real(kind=realType), intent(in) :: u(m, n), v(m, n)
  real(kind=realType), intent(in) :: tu(nctlu+ku), tv(nctlv+kv)
  real(kind=realType), intent(in) :: coef(ndim, nctlv, nctlu)

  ! Output
  real(kind=realType), intent(out):: val(ndim, m, n)

  ! Working
  integer                         :: idim, istartu, istartv, i, j, ii, jj
  integer                         :: ileftu, ileftv
  real(kind=realType)             :: basisu(ku), basisv(kv)

  val(:, :, :) = 0.0
  do ii=1, n
     do jj = 1, m
        ! U
        call findSpan(u(jj,ii), ku, tu, nctlu, ileftu)
        call basis(tu, nctlu, ku, u(jj, ii), ileftu, basisu)
        istartu = ileftu-ku

        ! V
        call findSpan(v(jj,ii), kv, tv, nctlv, ileftv)
        call basis(tv, nctlv, kv, v(jj, ii), ileftv, basisv)
        istartv = ileftv-kv

        do i=1, ku
           do j=1, kv
              do idim=1, ndim
                 val(idim, jj, ii) = val(idim, jj, ii) + basisu(i)*basisv(j)*coef(idim, istartv+j, istartu+i)
              end do
           end do
        end do
     end do
  end do

end subroutine eval_surface

subroutine eval_surface_deriv(u, v, tu, tv, ku, kv, coef, nctlu, nctlv, &
     ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_surface_deriv evaluates the derivative of a
  !     point on the surface
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, u coordinate
  !     v       - Real, v coordinate
  !     tu      - Real, Knot vector in u. size(nctlu+ku)
  !     tv      - Real, Knot vector in v. size(nctlv+kv)
  !     ku      - Integer, order of B-spline in u
  !     kv      - Integer, order of B-spline in v
  !     coef    - Real, Array of B-spline coefficients  Size (ndim, nctlv, nctlu)
  !     nctlu   - Integer, Number of control points in u
  !     nctlv   - Integer, Number of control points in v
  !     ndim    - Integer, Spatial Dimension
  !
  !     Ouput
  !     val     - Real, Evaluated derivatives, size (ndim, 2)

  use precision
  implicit none

  ! Input
  integer            , intent(in)   :: ku, kv, nctlu, nctlv, ndim
  real(kind=realType), intent(in)   :: u, v
  real(kind=realType), intent(in)   :: tu(nctlu+ku), tv(nctlv+kv)
  real(kind=realType), intent(in)   :: coef(ndim, nctlv, nctlu)

  ! Output
  real(kind=realType), intent(out)  :: val(ndim, 2)

  ! Working
  integer                           :: idim
  real(kind=realType)               :: b2val

  do idim=1, ndim
     val(idim, 1) = b2val(v, u, 0, 1, tv, tu, nctlv, nctlu, kv, ku, coef(idim, :, :))
     val(idim, 2) = b2val(v, u, 1, 0, tv, tu, nctlv, nctlu, kv, ku, coef(idim, :, :))
  end do

end subroutine eval_surface_deriv

subroutine eval_surface_deriv2(u, v, tu, tv, ku, kv, coef, nctlu, nctlv, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_surface_deriv2 evaluates the second derivative
  !     of a point on the surface
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, u coordinate
  !     v       - Real, v coordinate
  !     tu      - Real, Knot vector in u. size(nctlu+ku)
  !     tv      - Real, Knot vector in v. size(nctlv+kv)
  !     ku      - Integer, order of B-spline in u
  !     kv      - Integer, order of B-spline in v
  !     coef    - Real, Array of B-spline coefficients  Size (ndim, nctlv, nctlu)
  !     nctlu   - Integer, Number of control points in u
  !     nctlv   - Integer, Number of control points in v
  !     ndim    - Integer, Spatial Dimension
  !
  !     Ouput
  !     val     - Real, Evaluated second derivatives, size (ndim, 2, 2)

  use precision
  implicit none

  ! Input
  integer            , intent(in)   :: ku, kv, nctlu, nctlv, ndim
  real(kind=realType), intent(in)   :: u, v
  real(kind=realType), intent(in)   :: tu(nctlu+ku), tv(nctlv+kv)
  real(kind=realType), intent(in)   :: coef(ndim, nctlv, nctlu)

  ! Output
  real(kind=realType), intent(out)  :: val(ndim, 2, 2)

  ! Working
  integer                           :: idim
  real(kind=realType)               :: b2val

  do idim=1, ndim
     val(idim, 1, 1) = b2val(v, u, 0, 2, tv, tu, nctlv, nctlu, kv, ku, coef(idim, :, :))
     val(idim, 1, 2) = b2val(v, u, 1, 1, tv, tu, nctlv, nctlu, kv, ku, coef(idim, :, :))
     val(idim, 2, 1) = val(idim, 1, 2)
     val(idim, 2, 2) = b2val(v, u, 2, 0, tv, tu, nctlv, nctlu, kv, ku, coef(idim, :, :))
  end do

end subroutine eval_surface_deriv2


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape6w(xi,et,ze,xl,xsj,shp,iflag)
!
!     shape functions and derivatives for a 6-node linear
!     isoparametric wedge element. 0<=xi,et<=1,xi+et<=1,-1<=ze<=1.
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions and
!              the Jacobian determinant
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian determinant
!
!
!    Copyright (c) 2003 WB
!
!    Written January 2003 on the basis of the Guido's shape function files
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(4,6),xs(3,3),xsi(3,3),xl(3,6),sh(3)
!
      real*8 xi,et,ze,xsj,a
!
      intent(in) xi,et,ze,xl,iflag
!
      intent(out) shp,xsj
!
!     shape functions and their glocal derivatives
!
      a=1.d0-xi-et
!
!     shape functions
!
      shp(4, 1)=0.5d0*a *(1.d0-ze)
      shp(4, 2)=0.5d0*xi*(1.d0-ze)
      shp(4, 3)=0.5d0*et*(1.d0-ze)
      shp(4, 4)=0.5d0*a *(1.d0+ze)
      shp(4, 5)=0.5d0*xi*(1.d0+ze)
      shp(4, 6)=0.5d0*et*(1.d0+ze)
!
      if(iflag.eq.1) return
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1, 1)=-0.5d0*(1.d0-ze)
      shp(1, 2)= 0.5d0*(1.d0-ze)
      shp(1, 3)= 0.d0
      shp(1, 4)=-0.5d0*(1.d0+ze)
      shp(1, 5)= 0.5d0*(1.d0+ze)
      shp(1, 6)= 0.d0
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2, 1)=-0.5d0*(1.d0-ze)
      shp(2, 2)= 0.d0
      shp(2, 3)= 0.5d0*(1.d0-ze)
      shp(2, 4)=-0.5d0*(1.d0+ze)
      shp(2, 5)= 0.d0
      shp(2, 6)= 0.5d0*(1.d0+ze)

!
!     local derivatives of the shape functions: zeta-derivative
!
      shp(3, 1)=-0.5d0*a
      shp(3, 2)=-0.5d0*xi
      shp(3, 3)=-0.5d0*et
      shp(3, 4)= 0.5d0*a
      shp(3, 5)= 0.5d0*xi
      shp(3, 6)= 0.5d0*et
!
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,6
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2))
     &   -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1))
     &   +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1))
!
      if(iflag.eq.2) return
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
      xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj
      xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj
      xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj
      xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj
      xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj
      xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj
      xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj
      xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj
      xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj
!
!     computation of the global derivatives of the shape functions
!
      do k=1,6
        do j=1,3
          sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j)
        enddo
        do j=1,3
          shp(j,k)=sh(j)
        enddo
      enddo
!
      return
      end


   !        Generated by TAPENADE     (INRIA, Tropics team)
   !  Tapenade 3.10 (r5363) -  9 Sep 2014 09:53
   !
   !  Differentiation of getmag in forward (tangent) mode (with options noISIZE i4 dr8 r8):
   !   variations   of useful results: mag
   !   with respect to varying inputs: v
   SUBROUTINE GETMAG_D(v, vb, mag, magb)
   USE CONSTANTS
   IMPLICIT NONE
   ! Subroutine Variables
   REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v
   REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: vb
   REAL(kind=realtype), INTENT(OUT) :: mag
   REAL(kind=realtype), INTENT(OUT) :: magb
   INTRINSIC SQRT
   REAL(kind=realtype) :: arg1
   REAL(kind=realtype) :: arg1b
   arg1b = 2*v(1)*vb(1) + 2*v(2)*vb(2) + 2*v(3)*vb(3)
   arg1 = v(1)**2 + v(2)**2 + v(3)**2 + 1e-30
   IF (arg1 .EQ. 0.0_8) THEN
   magb = 0.0_8
   ELSE
   magb = arg1b/(2.0*SQRT(arg1))
   END IF
   mag = SQRT(arg1)
   END SUBROUTINE GETMAG_D


program test
  implicit none
  integer :: i, j, n

  do i = 1, 5
    write(*, "(a, i0, a)", advance = "no") "Degree ", i, ": "
    do j = 1, 10
      n = multifactorial(j, i)
      write(*, "(i0, 1x)", advance = "no") n
    end do
    write(*,*)
  end do

contains

function multifactorial (range, degree)
  integer :: multifactorial, range, degree
  integer :: k

  multifactorial = product((/(k, k=range, 1, -degree)/))

end function multifactorial
end program test


program mtx_multi_loop_test

    !Undergraduate Student: Arturo Burgos
    !Professor: João Rodrigo Andrade
    !Federal University of Uberlândia - UFU, Fluid Mechanics Laboratory
    !MFLab, Block 5P, Uberlândia, MG, Brazil

    implicit none !To avoid variable definition problems, checking if they are correctly defined
    real, DIMENSION(5000,5000) :: mtx1, mtx2, mtx3
    DOUBLE PRECISION :: start, finish

    call random_number(mtx1)
    call random_number(mtx2)

    call cpu_time(start)

    mtx3 = matmul(mtx1,mtx2)

    call cpu_time(finish)

    write(*,'(A/)')
    print '("Elapsed time is: ",f8.5," seconds")', finish - start
    !print '("Elapsed time is: ",f6.5," seconds")', finish - start

end program mtx_multi_loop_test


      function quad(x,y,u)
c-------------------------------------------------------------------
c     quad does a simple quadratic interpolation by lagranges
c  formula
c
c  arguments-
c
c     x-array of abscissa values (length at least 3)
c     y-corresponding ordinate values
c       (quad fits a parabola through the three given point of x and y)
c     u-abscissa value to evaluate y value at
c----------------------------------------------------------------------
      dimension x(3),y(3)
      dx31=x(3)-x(1)
      dx32=x(3)-x(2)
      dx21=x(2)-x(1)
      dux3=u-x(3)
      dux2=u-x(2)
      dux1=u-x(1)
      quad = ((dux2*dux3)/(dx21*dx31)) * y(1)
     1     - ((dux1*dux3)/(dx21*dx32)) * y(2)
     2     + ((dux1*dux2)/(dx31*dx32)) * y(3)
      return
      end

c $Id$


! Demonstrate a do loop
program loop
implicit none
integer :: i,ssq
ssq = 0
do i=1,5
   ssq = ssq + i**2
end do
print*,"sum of squares is ",ssq ! 1 + 4 + 9 + 16 + 25 = 55
end program loop


c     comment section
c
c     fm031
c
c         this routine tests arithmetic assignment statements of the
c     form
c               integer variable = arithmetic expression
c     where the arithmetic expression is formed with the arithmetic
c     operator -, integer constants and integer variables.  some of the
c     tests use parentheses to group elements in an arithmetic
c     expression.
c
c         there are tests where the arithmetic expression contains
c           (1)  integer constant-integer constant-integer variable
c                integer constant-integer variable-integer constant
c                integer variable-integer constant-integer constant
c           (2)  same as (1) but with parentheses to group elements
c                in arithmetic expression.
c           (3)  integer variable - integer variable
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 10.1, arithmetic assignment statement
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c     test 300 through test 309 contain 2 integer constants, an integer
c     variable and operator - in an arithmetic expression.
c
 3001 continue
      ivtnum = 300
c
c      ****  test 300  ****
c
      if (iczero) 33000, 3000, 33000
 3000 continue
      ivon01 = 9
      ivcomp =ivon01 -3 -4
      go to 43000
33000 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43000, 3011, 43000
43000 if (ivcomp-2) 23000,13000,23000
13000 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3011
23000 ivfail = ivfail + 1
      ivcorr =2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3011 continue
      ivtnum = 301
c
c      ****  test 301  ****
c
      if (iczero) 33010, 3010, 33010
 3010 continue
      ivon02 =3
      ivcomp =9-ivon02-4
      go to 43010
33010 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43010, 3021, 43010
43010 if (ivcomp-2) 23010,13010,23010
13010 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3021
23010 ivfail = ivfail + 1
      ivcorr =2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3021 continue
      ivtnum = 302
c
c      ****  test 302  ****
c
      if (iczero) 33020, 3020, 33020
 3020 continue
      ivon03 = 4
      ivcomp = 9-3-ivon03
      go to 43020
33020 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43020, 3031, 43020
43020 if (ivcomp-2) 23020,13020,23020
13020 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3031
23020 ivfail = ivfail + 1
      ivcorr =2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3031 continue
      ivtnum = 303
c
c      ****  test 303  ****
c
      if (iczero) 33030, 3030, 33030
 3030 continue
      ivon01 = 57
      ivcomp = ivon01 -25-22
      go to 43030
33030 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43030, 3041, 43030
43030 if (ivcomp-10) 23030,13030,23030
13030 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3041
23030 ivfail = ivfail + 1
      ivcorr = 10
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3041 continue
      ivtnum = 304
c
c      ****  test 304  ****
c
      if (iczero) 33040, 3040, 33040
 3040 continue
      ivon02 =683
      ivcomp = 101-ivon02-156
      go to 43040
33040 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43040, 3051, 43040
43040 if (ivcomp+738) 23040,13040,23040
13040 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3051
23040 ivfail = ivfail + 1
      ivcorr = -738
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3051 continue
      ivtnum = 305
c
c      ****  test 305  ****
c
      if (iczero) 33050, 3050, 33050
 3050 continue
      ivon03 = 1289
      ivcomp = 8542-1122-ivon03
      go to 43050
33050 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43050, 3061, 43050
43050 if (ivcomp-6131) 23050,13050,23050
13050 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3061
23050 ivfail = ivfail + 1
      ivcorr = 6131
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3061 continue
      ivtnum = 306
c
c      ****  test 306  ****
c
      if (iczero) 33060, 3060, 33060
 3060 continue
      ivon03 = 11111
      ivcomp = 32333-11111-ivon03
      go to 43060
33060 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43060, 3071, 43060
43060 if (ivcomp-10111) 23060,13060,23060
13060 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3071
23060 ivfail = ivfail + 1
      ivcorr =10111
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3071 continue
      ivtnum = 307
c
c      ****  test 307  ****
c
      if (iczero) 33070, 3070, 33070
 3070 continue
      ivon01 = -3
      ivcomp = ivon01-2-4
      go to 43070
33070 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43070, 3081, 43070
43070 if (ivcomp +9) 23070,13070,23070
13070 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3081
23070 ivfail = ivfail + 1
      ivcorr =-9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3081 continue
      ivtnum = 308
c
c      ****  test 308  ****
c
      if (iczero) 33080, 3080, 33080
 3080 continue
      ivon02 =-9
      ivcomp =1-ivon02-4
      go to 43080
33080 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43080, 3091, 43080
43080 if (ivcomp-6) 23080,13080,23080
13080 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3091
23080 ivfail = ivfail + 1
      ivcorr = 6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3091 continue
      ivtnum = 309
c
c      ****  test 309  ****
c
      if (iczero) 33090, 3090, 33090
 3090 continue
      ivon03 = -8542
      ivcomp = 100-3-ivon03
      go to 43090
33090 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43090, 3101, 43090
43090 if (ivcomp-8639) 23090,13090,23090
13090 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3101
23090 ivfail = ivfail + 1
      ivcorr = 8639
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 310 through test 319 contain 2 integer constants, an integer
c     variable and operator - in an arithmetic expression.  parentheses
c     are used to group elements in the arithmetic expression.
c
 3101 continue
      ivtnum = 310
c
c      ****  test 310  ****
c
      if (iczero) 33100, 3100, 33100
 3100 continue
      ivon01 =9
      ivcomp = ivon01-(3-4)
      go to 43100
33100 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43100, 3111, 43100
43100 if (ivcomp-10) 23100,13100,23100
13100 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3111
23100 ivfail = ivfail + 1
      ivcorr=10
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3111 continue
      ivtnum = 311
c
c      ****  test 311  ****
c
      if (iczero) 33110, 3110, 33110
 3110 continue
      ivon01=9
      ivcomp=(ivon01-3)-4
      go to 43110
33110 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43110, 3121, 43110
43110 if (ivcomp-2) 23110,13110,23110
13110 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3121
23110 ivfail = ivfail + 1
      ivcorr =2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3121 continue
      ivtnum = 312
c
c      ****  test 312  ****
c
      if (iczero) 33120, 3120, 33120
 3120 continue
      ivon02 = 3
      ivcomp = 9-(ivon02-4)
      go to 43120
33120 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43120, 3131, 43120
43120 if (ivcomp-10) 23120,13120,23120
13120 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3131
23120 ivfail = ivfail + 1
      ivcorr = 10
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3131 continue
      ivtnum = 313
c
c      ****  test 313  ****
c
      if (iczero) 33130, 3130, 33130
 3130 continue
      ivon02 = 3
      ivcomp = (9-ivon02) -4
      go to 43130
33130 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43130, 3141, 43130
43130 if (ivcomp-2) 23130,13130,23130
13130 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3141
23130 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3141 continue
      ivtnum = 314
c
c      ****  test 314  ****
c
      if (iczero) 33140, 3140, 33140
 3140 continue
      ivon03 = 4
      ivcomp = 9 -(3-ivon03)
      go to 43140
33140 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43140, 3151, 43140
43140 if (ivcomp-10) 23140,13140,23140
13140 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3151
23140 ivfail = ivfail + 1
      ivcorr = 10
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3151 continue
      ivtnum = 315
c
c      ****  test 315  ****
c
      if (iczero) 33150, 3150, 33150
 3150 continue
      ivon03 = 4
      ivcomp = (9-3)-ivon03
      go to 43150
33150 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43150, 3161, 43150
43150 if (ivcomp-2) 23150,13150,23150
13150 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3161
23150 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3161 continue
      ivtnum = 316
c
c      ****  test 316  ****
c
      if (iczero) 33160, 3160, 33160
 3160 continue
      ivon01 = -9
      ivcomp = (ivon01-3)-4
      go to 43160
33160 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43160, 3171, 43160
43160 if (ivcomp +16) 23160,13160,23160
13160 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3171
23160 ivfail = ivfail + 1
      ivcorr = -16
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3171 continue
      ivtnum = 317
c
c      ****  test 317  ****
c
      if (iczero) 33170, 3170, 33170
 3170 continue
      ivon02 = -3
      ivcomp = 9-(ivon02-4)
      go to 43170
33170 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43170, 3181, 43170
43170 if (ivcomp-16) 23170,13170,23170
13170 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3181
23170 ivfail = ivfail + 1
      ivcorr = 16
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3181 continue
      ivtnum = 318
c
c      ****  test 318  ****
c
      if (iczero) 33180, 3180, 33180
 3180 continue
      ivon03 = +4
      ivcomp = 9 - (3 - ivon03)
      go to 43180
33180 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43180, 3191, 43180
43180 if (ivcomp - 10) 23180,13180,23180
13180 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3191
23180 ivfail = ivfail + 1
      ivcorr= 10
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3191 continue
      ivtnum = 319
c
c      ****  test 319  ****
c
      if (iczero) 33190, 3190, 33190
 3190 continue
      ivon02 = 11111
      ivcomp = (32333-ivon02) -11111
      go to 43190
33190 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43190, 3201, 43190
43190 if (ivcomp - 10111) 23190,13190,23190
13190 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3201
23190 ivfail = ivfail + 1
      ivcorr = 10111
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 320 through test 329 contain 2 integer variables and
c     operator - in an arithmetic expression.  the integer variables
c     contain positive and negative values.
c
 3201 continue
      ivtnum = 320
c
c      ****  test 320  ****
c
      if (iczero) 33200, 3200, 33200
 3200 continue
      ivon01 = 3
      ivon02 = 2
      ivcomp = ivon01 - ivon02
      go to 43200
33200 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43200, 3211, 43200
43200 if (ivcomp - 1) 23200,13200,23200
13200 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3211
23200 ivfail = ivfail + 1
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3211 continue
      ivtnum = 321
c
c      ****  test 321  ****
c
      if (iczero) 33210, 3210, 33210
 3210 continue
      ivon01 =2
      ivon02 =3
      ivcomp = ivon01 - ivon02
      go to 43210
33210 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43210, 3221, 43210
43210 if (ivcomp +1) 23210,13210,23210
13210 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3221
23210 ivfail = ivfail + 1
      ivcorr = -1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3221 continue
      ivtnum = 322
c
c      ****  test 322  ****
c
      if (iczero) 33220, 3220, 33220
 3220 continue
      ivon01 = -2
      ivon02 =  3
      ivcomp = ivon01 - ivon02
      go to 43220
33220 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43220, 3231, 43220
43220 if (ivcomp +5) 23220,13220,23220
13220 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3231
23220 ivfail = ivfail + 1
      ivcorr =-5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3231 continue
      ivtnum = 323
c
c      ****  test 323  ****
c
      if (iczero) 33230, 3230, 33230
 3230 continue
      ivon01 = -2
      ivon02 = -3
      ivcomp = ivon01 - ivon02
      go to 43230
33230 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43230, 3241, 43230
43230 if (ivcomp -1) 23230,13230,23230
13230 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3241
23230 ivfail = ivfail + 1
      ivcorr = 1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3241 continue
      ivtnum = 324
c
c      ****  test 324  ****
c
      if (iczero) 33240, 3240, 33240
 3240 continue
      ivon01 = 51
      ivon02 = 52
      ivcomp = ivon01 - ivon02
      go to 43240
33240 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43240, 3251, 43240
43240 if (ivcomp + 1) 23240,13240,23240
13240 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3251
23240 ivfail = ivfail + 1
      ivcorr = -1
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3251 continue
      ivtnum = 325
c
c      ****  test 325  ****
c
      if (iczero) 33250, 3250, 33250
 3250 continue
      ivon01 = 676
      ivon02 =-189
      ivcomp = ivon01 - ivon02
      go to 43250
33250 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43250, 3261, 43250
43250 if (ivcomp - 865) 23250,13250,23250
13250 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3261
23250 ivfail = ivfail + 1
      ivcorr = 865
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3261 continue
      ivtnum = 326
c
c      ****  test 326  ****
c
      if (iczero) 33260, 3260, 33260
 3260 continue
      ivon01 = 1358
      ivon02 = -8001
      ivcomp = ivon01 - ivon02
      go to 43260
33260 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43260, 3271, 43260
43260 if (ivcomp - 9359) 23260,13260,23260
13260 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3271
23260 ivfail = ivfail + 1
      ivcorr = 9359
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3271 continue
      ivtnum = 327
c
c      ****  test 327  ****
c
      if (iczero) 33270, 3270, 33270
 3270 continue
      ivon01 =-16383
      ivon02 = 16383
      ivcomp = ivon01 - ivon02
      go to 43270
33270 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43270, 3281, 43270
43270 if (ivcomp + 32766) 23270,13270,23270
13270 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3281
23270 ivfail = ivfail + 1
      ivcorr = -32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3281 continue
      ivtnum = 328
c
c      ****  test 328  ****
c
      if (iczero) 33280, 3280, 33280
 3280 continue
      ivon01 = 9876
      ivon02 = 189
      ivcomp = ivon01 - ivon02
      go to 43280
33280 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43280, 3291, 43280
43280 if (ivcomp - 9687) 23280,13280,23280
13280 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3291
23280 ivfail = ivfail + 1
      ivcorr = 9687
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3291 continue
      ivtnum = 329
c
c      ****  test 329  ****
c
      if (iczero) 33290, 3290, 33290
 3290 continue
      ivon01 = 11112
      ivon02 = 11112
      ivcomp = ivon01 - ivon02
      go to 43290
33290 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43290, 3301, 43290
43290 if (ivcomp) 23290,13290,23290
13290 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3301
23290 ivfail = ivfail + 1
      ivcorr = 0
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c      ****  end of tests  ****
 3301 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm031)
      end


! { dg-do run }
! { dg-options "-ffree-form -std=legacy" }
!
! Test DEC-style PARAMETER statements without parentheses in free form.
!

subroutine sub1(t, x, y)
  implicit real(8) (A-H,O-Z)
  parameter   (pi_1 = 3.141592654d0, f_1 = 3.d08)
  parameter    pi_2 = 3.141592654d0, f_2 = 3.d08 ! legacy PARAMETER
  ! Note that if the parameter statements above are matched
  ! incorrectly as assignments, the below specification
  ! statements will be considered out-of-order and we see
  ! 'unexpected specification statement'. A PARAMETER
  ! statement should still be a specification statement.

  real(8), intent(in) :: t
  real(8), intent(out) :: x, y

  real(8), volatile :: two
  two = 2.0d0
  x = two * pi_1 * f_1 * t
  y = two * pi_2 * f_2 * t
  return
end subroutine

subroutine sub2(t, x, y, z)
  implicit none
  real(8) :: pi_1, pi_2, f_1, f_2
           parameter   (pi_1 = 3.141592654d0, f_1 = 3.d08)
           parameter    pi_2 = 3.141592654d0, f_2 = 3.d08 ! legacy PARAMETER
  real(8), parameter :: pi_3 = 3.141592654d0, f_3 = 3.d08
  ! Ditto sub1

  real(8), intent(in) :: t
  real(8), intent(out) :: x, y, z

  real(8), volatile :: two
  two = 2.0d0
  x = two * pi_1 * f_1 * t
  y = two * pi_2 * f_2 * t
  z = two * pi_3 * f_3 * t
end subroutine

implicit none
real(8) :: x1, x2, y1, y2, z2
real(8), volatile :: t
t = 1.5e-6

call sub1(t, x1, y1)
call sub2(t, x2, y2, z2)

write(*,'(4D18.5)') t, x1, y1
write(*,'(4D18.5)') t, x2, y2, z2

if (x1 .ne. x2 .or. y1 .ne. y2 &
    .or. x1 .ne. y1 .or. x2 .ne. y2 &
    .or. y2 .ne. z2) then
  STOP 1
endif

end


PROGRAM Test_SPCtoIFG

  USE Type_Kinds           , ONLY: fp=>fp_kind
  USE Binary_File_Utility  , ONLY: Open_Binary_File
  USE Message_Handler      , ONLY: SUCCESS
  USE Fundamental_Constants, ONLY: PI
  USE FFT_Spectral_Utility , ONLY: SPCtoIFG
  IMPLICIT NONE
  ! Parameters
  CHARACTER(*), PARAMETER :: FILENAME='test_spc.bin'
  ! Variables
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: f
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: rSpc, iSpc
  COMPLEX(fp), DIMENSION(:), ALLOCATABLE :: spc
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: x
  COMPLEX(fp), DIMENSION(:), ALLOCATABLE :: ifg
  INTEGER :: fileId
  INTEGER :: n, n2
  INTEGER :: i, j, errStatus, ioStatus, allocStatus

  ! Read the spectral data
  WRITE(*,'(/5x,"Reading input test spectrum...")' )
  errStatus = Open_Binary_File( FILENAME, &
                                fileId    )
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error opening test spectrum file.'
    STOP
  END IF
  READ(fileId) n  ! The number of SPC points
  n2 = 2*(n-1)    ! The number of IFG points
  ALLOCATE(f(n), rSpc(n), iSpc(n), spc(n), x(n2), ifg(n2), STAT=allocStatus)
  IF ( allocStatus /= 0 ) THEN
    WRITE(*,*) 'Error allocating arrays. STAT=',allocStatus
    STOP
  END IF
  READ(fileId)f     ! Frequency data
  READ(fileId)rSpc  ! Real part of SPC
  READ(fileId)iSpc  ! Imaginary part of SPC
  CLOSE(fileId)

  ! Make the spectrum complex
  spc = CMPLX(rSpc,iSpc,fp)

  ! Call the routine
  WRITE(*,'(5x,"Calling SPCtoIFG......")' )
  errStatus=SPCtoIFG(f, Spc, x, ifg)
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error in SPCtoIFG call'
    STOP
  END IF

  ! Output the SPC and IFG to a file
  WRITE(*,'(5x,"Writing output file......")' )
  errStatus = Open_Binary_File( 'Test_SPCtoIFG.bin', &
                                fileId, &
                                For_Output=1 )
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error opening output results file.'
    STOP
  END IF
  ! The SPC data
  WRITE(fileId) n            ! The number of SPC points
  WRITE(fileId) f            ! Frequency data
  WRITE(fileId) rSpc         ! Real part of SPC
  WRITE(fileId) iSpc         ! Imaginary part of SPC
  ! The IFG data
  WRITE(fileId) n2           ! The number of IFG points
  WRITE(fileId) x            ! Optical delay data
  WRITE(fileId) REAL(ifg,fp) ! Real part of IFG
  WRITE(fileId) AIMAG(ifg)   ! Imaginary part of IFG
  CLOSE(fileId)

END PROGRAM Test_SPCtoIFG


\ .( Loading Bubble Sort benchmark...) cr

\ A classical benchmark of an O(n**2) algorithm; Bubble sort
\
\ Part of the programs gathered by John Hennessy for the MIPS
\ RISC project at Stanford. Translated to forth by Marty Fraeman
\ Johns Hopkins University/Applied Physics Laboratory.

\ MM forth2c doesn't have it !
: mybounds  over + swap ;

\ 1 cells constant cell

variable seed ( -- addr)

: initiate-seed ( -- )  74755 seed ! ;
: random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;

6000 constant elements ( -- int)

align create thelist elements cells allot

: initiate-list ( -- )
  thelist elements cells + thelist do random i ! 1 cells +loop
;

: dump-list ( -- )
  thelist elements cells + thelist do i @ . 1 cells +loop cr
;

: verify-list ( -- )
  thelist elements 1- cells mybounds do
    i 2@ > abort" bubble-sort: not sorted"
  1 cells +loop
;

: bubble ( -- )
\ ." bubbling..." cr
  1 elements 1 do
    thelist elements i - cells mybounds do
      i 2@ > if i 2@ swap i 2! then
    1 cells +loop
  loop
;

: bubble-sort ( -- )
  initiate-seed
  initiate-list
  bubble
  verify-list
;

: bubble-with-flag ( -- )
  1 elements 1 do
    -1 thelist elements i - cells mybounds do
      i 2@ > if i 2@ swap i 2! drop 0 then
    1 cells +loop
    if leave then
  loop
;

: bubble-sort-with-flag ( -- )
  initiate-seed
  initiate-list
  bubble-with-flag
  verify-list
;

: main	( -- )
	5 0 do bubble-sort loop
\	bubble-sort-with-flag
;


program Combsort_Demo
  implicit none

  integer, parameter :: num = 20
  real :: array(num)

  call random_seed
  call random_number(array)
  write(*,*) "Unsorted array:-"
  write(*,*) array
  write(*,*)
  call combsort(array)
  write(*,*) "Sorted array:-"
  write(*,*) array

contains

  subroutine combsort(a)

    real, intent(in out) :: a(:)
    real :: temp
    integer :: i, gap
    logical :: swapped = .true.

    gap = size(a)
    do while (gap > 1 .or. swapped)
      gap = gap / 1.3
      if (gap < 1) gap = 1
      swapped = .false.
      do i = 1, size(a)-gap
        if (a(i) > a(i+gap)) then
          temp = a(i)
          a(i) = a(i+gap)
          a(i+gap) = temp;
          swapped = .true.
        end if
      end do
    end do

  end subroutine combsort

end program Combsort_Demo


program t
  integer :: a(10,10)
  integer :: n =10,i,j

  do i = 1,n,1
    do j = 1,n,1
      a(i,j) =  i * j + 3
  end do
    end do
    i = 10
    j = 10
  call dummy(a,n,i,j)
end program t

subroutine dummy(vin, n,i,j)
  integer,intent(inout) :: vin(10,10),n,i,j

  IF (n == 10) THEN
    do i = 1,n,1
      do j = 1,n,1
        print *,vin(j,i)
      end do
    end do
  END IF
  call printOthers(n,i,j)
end subroutine dummy

subroutine printOthers(n,i,j)
  integer,intent(in) :: n,i,j

  PRINT *, n,i,j
end subroutine printOthers


c { dg-do run }
      program foo
      complex(kind=8)      z0, z1, z2

      z0 = dcmplx(0.,.5)
      z1 = 1./z0
      if (z1 .ne. dcmplx(0.,-2)) call abort

      z0 = 10.*z0
      if (z0 .ne. dcmplx(0.,5.)) call abort

      z2 = cmplx(1.,2.)
      z1 = z0/z2
      if (z1 .ne. dcmplx(2.,1.)) call abort

      z1 = z0*z2
      if (z1 .ne. dcmplx(-10.,5.)) call abort
      end


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 ... file shsec.f
c
c     this file contains code and documentation for subroutines
c     shsec and shseci
c
c ... files which must be loaded with shsec.f
c
c     sphcom.f, hrfft.f
c
c     subroutine shsec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                    wshsec,lshsec,work,lwork,ierror)
c
c     subroutine shsec performs the spherical harmonic synthesis
c     on the arrays a and b and stores the result in the array g.
c     the synthesis is performed on an equally spaced grid.  the
c     associated legendre functions are recomputed rather than stored
c     as they are in subroutine shses.  the synthesis is described
c     below at output parameter g.
c
c     required files from spherepack2
c
c     sphcom.f, hrfft.f
c
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 or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the synthesis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the synthesis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls shsec,
c            the arrays g,a and b can be three dimensional in which
c            case multiple syntheses will be performed.  the third
c            index is the synthesis index which assumes the values
c            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 the arrays g,a and b
c            have only two dimensions.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shsec.  if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg
c            must be at least nlat/2 if nlat is even or at least
c            (nlat+1)/2 if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shsec.  jdg must be at least nlon.
c
c     a,b    two or three dimensional arrays (see the input parameter
c            nt) that contain the coefficients in the spherical harmonic
c            expansion of g(i,j) given below at the definition of the
c            output parameter g.  a(m,n) and b(m,n) are defined for
c            indices m=1,...,mmax and n=m,...,nlat where mmax is the
c            maximum (plus one) longitudinal wave number given by
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shsec. mdab must be at least
c            min0(nlat,(nlon+2)/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 a and b as it appears
c            in the program that calls shsec. ndab must be at least nlat
c
c     wshsec an array which must be initialized by subroutine shseci.
c            once initialized, wshsec can be used repeatedly by shsec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not be altered between calls of shsec.
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls shsec. define
c
c               l1 = min0(nlat,(nlon+2)/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 lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+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 shsec. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                    nlat*(nt*nlon+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                    l2*(nt*nlon+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the spherical harmonic synthesis of
c            the arrays a and b at the colatitude point theta(i) =
c            (i-1)*pi/(nlat-1) and longitude point phi(j) =
c            (j-1)*2*pi/nlon. the index ranges are defined above at
c            at the input parameter isym.  for isym=0, g(i,j) is
c            given by the the equations listed below.  symmetric
c            versions are used when isym is greater than zero.
c
c     the normalized associated legendre functions are given by
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c     define the maximum (plus one) longitudinal wave number
c     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then g(i,j) = the sum from n=0 to n=nlat-1 of
c
c                   .5*pbar(0,n,theta(i))*a(1,n+1)
c
c              plus the sum from m=1 to m=mmax-1 of
c
c                   the sum from n=m to n=nlat-1 of
c
c              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
c                                    -b(m+1,n+1)*sin(m*phi(j)))
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 isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshsec
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c     subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror)
c
c     subroutine shseci initializes the array wshsec which can then
c     be used repeatedly by subroutine shsec.
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 or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls shseci. the array wshsec is an output
c            parameter which is described below. define
c
c               l1 = min0(nlat,(nlon+2)/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 lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c     dwork  a double precision work array that does not have to be
c            saved.
c
c     ldwork the dimension of array dwork as it appears in the program
c            that calls shseci.  ldwork must be at least nlat+1.
c
c     output parameters
c
c     wshsec an array which is initialized for use by subroutine shsec.
c            once initialized, wshsec can be used repeatedly by shsec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not be altered between calls of shsec.
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 lshsec
c            = 4  error in the specification of ldwork
c
c
c ****************************************************************
      subroutine shsec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
     1                    wshsec,lshsec,work,lwork,ierror)
      dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),wshsec(1),
     1          work(1)
      ierror = 1
      if(nlat.lt.3) return
      ierror = 2
      if(nlon.lt.4) return
      ierror = 3
      if(isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      if((isym.eq.0 .and. idg.lt.nlat) .or.
     1   (isym.ne.0 .and. idg.lt.(nlat+1)/2)) return
      ierror = 6
      if(jdg .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,nlon/2+1)
      if(mdab .lt. mmax) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      imid = (nlat+1)/2
      lzz1 = 2*nlat*imid
      labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2
      if(lshsec .lt. lzz1+labc+nlon+15) return
      ierror = 10
      ls = nlat
      if(isym .gt. 0) ls = imid
      nln = nt*ls*nlon
      if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)) return
      ierror = 0
      ist = 0
      if(isym .eq. 0) ist = imid
      iw1 = lzz1+labc+1
      call shsec1(nlat,isym,nt,g,idg,jdg,a,b,mdab,ndab,imid,ls,nlon,
     1     work,work(ist+1),work(nln+1),work(nln+1),wshsec,wshsec(iw1))
      return
      end
      subroutine shsec1(nlat,isym,nt,g,idgs,jdgs,a,b,mdab,ndab,imid,
     1                idg,jdg,ge,go,work,pb,walin,whrfft)
c
c     whrfft must have at least nlon+15 locations
c     walin must have 3*l*imid + 3*((l-3)*l+2)/2 locations
c     zb must have 3*l*imid locations
c
      dimension g(idgs,jdgs,1),a(mdab,ndab,1),b(mdab,ndab,1),
     1          ge(idg,jdg,1),go(idg,jdg,1),pb(imid,nlat,3),walin(1),
     3          whrfft(1),work(1)
      ls = idg
      nlon = jdg
      mmax = min0(nlat,nlon/2+1)
      mdo = mmax
      if(mdo+mdo-1 .gt. nlon) mdo = mmax-1
      nlp1 = nlat+1
      modl = mod(nlat,2)
      imm1 = imid
      if(modl .ne. 0) imm1 = imid-1
      do 80 k=1,nt
      do 80 j=1,nlon
      do 80 i=1,ls
      ge(i,j,k)=0.
   80 continue
      if(isym .eq. 1) go to 125
      call alin (2,nlat,nlon,0,pb,i3,walin)
      do 100 k=1,nt
      do 100 np1=1,nlat,2
      do 100 i=1,imid
      ge(i,1,k)=ge(i,1,k)+a(1,np1,k)*pb(i,np1,i3)
  100 continue
      ndo = nlat
      if(mod(nlat,2) .eq. 0) ndo = nlat-1
      do 110 mp1=2,mdo
      m = mp1-1
      call alin (2,nlat,nlon,m,pb,i3,walin)
      do 110 np1=mp1,ndo,2
      do 110 k=1,nt
      do 110 i=1,imid
      ge(i,2*mp1-2,k) = ge(i,2*mp1-2,k)+a(mp1,np1,k)*pb(i,np1,i3)
      ge(i,2*mp1-1,k) = ge(i,2*mp1-1,k)+b(mp1,np1,k)*pb(i,np1,i3)
  110 continue
      if(mdo .eq. mmax .or. mmax .gt. ndo) go to 122
      call alin (2,nlat,nlon,mdo,pb,i3,walin)
      do 120 np1=mmax,ndo,2
      do 120 k=1,nt
      do 120 i=1,imid
      ge(i,2*mmax-2,k) = ge(i,2*mmax-2,k)+a(mmax,np1,k)*pb(i,np1,i3)
  120 continue
  122 if(isym .eq. 2) go to 155
  125 call alin(1,nlat,nlon,0,pb,i3,walin)
      do 140 k=1,nt
      do 140 np1=2,nlat,2
      do 140 i=1,imm1
      go(i,1,k)=go(i,1,k)+a(1,np1,k)*pb(i,np1,i3)
  140 continue
      ndo = nlat
      if(mod(nlat,2) .ne. 0) ndo = nlat-1
      do 150 mp1=2,mdo
      mp2 = mp1+1
      m = mp1-1
      call alin(1,nlat,nlon,m,pb,i3,walin)
      do 150 np1=mp2,ndo,2
      do 150 k=1,nt
      do 150 i=1,imm1
      go(i,2*mp1-2,k) = go(i,2*mp1-2,k)+a(mp1,np1,k)*pb(i,np1,i3)
      go(i,2*mp1-1,k) = go(i,2*mp1-1,k)+b(mp1,np1,k)*pb(i,np1,i3)
  150 continue
      mp2 = mmax+1
      if(mdo .eq. mmax .or. mp2 .gt. ndo) go to 155
      call alin(1,nlat,nlon,mdo,pb,i3,walin)
      do 152 np1=mp2,ndo,2
      do 152 k=1,nt
      do 152 i=1,imm1
      go(i,2*mmax-2,k) = go(i,2*mmax-2,k)+a(mmax,np1,k)*pb(i,np1,i3)
  152 continue
  155 do 160 k=1,nt
      if(mod(nlon,2) .ne. 0) go to 157
      do 156 i=1,ls
      ge(i,nlon,k) = 2.*ge(i,nlon,k)
  156 continue
  157 call hrfftb(ls,nlon,ge(1,1,k),ls,whrfft,work)
  160 continue
      if(isym .ne. 0) go to 180
      do 170 k=1,nt
      do 170 j=1,nlon
      do 175 i=1,imm1
      g(i,j,k) = .5*(ge(i,j,k)+go(i,j,k))
      g(nlp1-i,j,k) = .5*(ge(i,j,k)-go(i,j,k))
  175 continue
      if(modl .eq. 0) go to 170
      g(imid,j,k) = .5*ge(imid,j,k)
  170 continue
      return
  180 do 185 k=1,nt
      do 185 i=1,imid
      do 185 j=1,nlon
      g(i,j,k) = .5*ge(i,j,k)
  185 continue
      return
      end
c     subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror)
c
c     subroutine shseci initializes the array wshsec which can then
c     be used repeatedly by subroutine shsec.
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 or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls shseci. the array wshsec is an output
c            parameter which is described below. define
c
c               l1 = min0(nlat,(nlon+2)/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 lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c     dwork  a double precision work array that does not have to be
c            saved.
c
c     ldwork the dimension of array dwork as it appears in the program
c            that calls shseci.  ldwork must be at least nlat+1.
c
c     output parameters
c
c     wshsec an array which is initialized for use by subroutine shsec.
c            once initialized, wshsec can be used repeatedly by shsec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not be altered between calls of shsec.
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 lshsec
c            = 4  error in the specification of ldwork
c
c
c ****************************************************************
      subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror)
      dimension wshsec(*)
      double precision dwork(ldwork)
      ierror = 1
      if(nlat.lt.3) return
      ierror = 2
      if(nlon.lt.4) return
      ierror = 3
      imid = (nlat+1)/2
      mmax = min0(nlat,nlon/2+1)
      lzz1 = 2*nlat*imid
      labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2
      if(lshsec .lt. lzz1+labc+nlon+15) return
      ierror = 4
      if(ldwork .lt. nlat+1) return
      ierror = 0
      call alinit(nlat,nlon,wshsec,dwork)
      iw1 = lzz1+labc+1
      call hrffti(nlon,wshsec(iw1))
      return
      end


C/MEMBR ADD NAME=IWAMAX,SSI=0
c     Copyright INRIA
      integer function iwamax(n,xr,xi,incx)
c!but
c
c     la fonction iwamax determine l'indice de la composante
c     de plus grande norme l1 d'un vecteur complexe dont les
c     parties reelles des composantes sont rangees dans le
c     vecteur double precision xr et les parties imaginaires
c     dans le vecteur xi.
c
c!liste d'appel
c
c      integer function iwamax(n,xr,xi,incx)
c
c     n: taille du vecteur
c
c     xr, xi: vecteurs double precision qui contiennent,
c     respectivement, les parties reelles et imaginaires
c     des composantes du vecteur a traiter.
c
c     incx: increment entre deux elements consecitifs des
c     vecteurs xr ou xi.
c
c!auteur
c
c     cleve moler.- mathlab.
c
c!
      double precision xr(*),xi(*),s,p
c     index of norminf(x)
      k = 0
      if (n .le. 0) go to 20
      k = 1
      s = 0.0d+0
      ix = 1
      do 10 i = 1, n
         p = abs(xr(ix)) + abs(xi(ix))
         if (p .gt. s) k = i
         if (p .gt. s) s = p
         ix = ix + incx
   10 continue
   20 iwamax = k
      return
      end