CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C BenchIT - Performance Measurement for Scientific Applications
C Contact: developer@benchit.org
C
C $Id: work.f 1 2009-09-11 12:26:19Z william $
C $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/elementary/F77/0/0/sqrt/work.f $
C For license details see COPYING in the package base directory
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Kernel: Core for Square Root addict to input value
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE mathopsqrt( x, y)
         double precision x, y
         if(x .NE. 0.0) y=sqrt(x)
      END


      DOUBLE PRECISION FUNCTION LINTER( XTEST, X1, Y1, X2, Y2)
C function to linearly interpolate between two points
C arguements (xtest,x1,y1,x2,y2)
C function returns y value for xtest between
C two points (x1,y1) and (x2,y2)
      DOUBLE PRECISION XTEST, X1, Y1, X2, Y2

C linear coeffs
      DOUBLE PRECISION A, B

C end of decs

      A = (Y1-Y2)/(X1-X2)
      B = (Y2*X1-Y1*X2)/(X1-X2)
      LINTER = A*XTEST + B
      RETURN
      END


*> \brief \b CHPT21
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CHPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP,
*                          TAU, WORK, RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            ITYPE, KBAND, LDU, N
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), E( * ), RESULT( 2 ), RWORK( * )
*       COMPLEX            AP( * ), TAU( * ), U( LDU, * ), VP( * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CHPT21  generally checks a decomposition of the form
*>
*>         A = U S UC>
*> where * means conjugate transpose, A is hermitian, U is
*> unitary, and S is diagonal (if KBAND=0) or (real) symmetric
*> tridiagonal (if KBAND=1).  If ITYPE=1, then U is represented as
*> a dense matrix, otherwise the U is expressed as a product of
*> Householder transformations, whose vectors are stored in the
*> array "V" and whose scaling constants are in "TAU"; we shall
*> use the letter "V" to refer to the product of Householder
*> transformations (which should be equal to U).
*>
*> Specifically, if ITYPE=1, then:
*>
*>         RESULT(1) = | A - U S U* | / ( |A| n ulp ) *andC>         RESULT(2) = | I - UU* | / ( n ulp )
*>
*> If ITYPE=2, then:
*>
*>         RESULT(1) = | A - V S V* | / ( |A| n ulp )
*>
*> If ITYPE=3, then:
*>
*>         RESULT(1) = | I - UV* | / ( n ulp )
*>
*> Packed storage means that, for example, if UPLO='U', then the columns
*> of the upper triangle of A are stored one after another, so that
*> A(1,j+1) immediately follows A(j,j) in the array AP.  Similarly, if
*> UPLO='L', then the columns of the lower triangle of A are stored one
*> after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
*> in the array AP.  This means that A(i,j) is stored in:
*>
*>    AP( i + j*(j-1)/2 )                 if UPLO='U'
*>
*>    AP( i + (2*n-j)*(j-1)/2 )           if UPLO='L'
*>
*> The array VP bears the same relation to the matrix V that A does to
*> AP.
*>
*> For ITYPE > 1, the transformation U is expressed as a product
*> of Householder transformations:
*>
*>    If UPLO='U', then  V = H(n-1)...H(1),  where
*>
*>        H(j) = I  -  tau(j) v(j) v(j)C>
*>    and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
*>    (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
*>    the j-th element is 1, and the last n-j elements are 0.
*>
*>    If UPLO='L', then  V = H(1)...H(n-1),  where
*>
*>        H(j) = I  -  tau(j) v(j) v(j)C>
*>    and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
*>    (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
*>    in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ITYPE
*> \verbatim
*>          ITYPE is INTEGER
*>          Specifies the type of tests to be performed.
*>          1: U expressed as a dense unitary matrix:
*>             RESULT(1) = | A - U S U* | / ( |A| n ulp )   *andC>             RESULT(2) = | I - UU* | / ( n ulp )
*>
*>          2: U expressed as a product V of Housholder transformations:
*>             RESULT(1) = | A - V S V* | / ( |A| n ulp )
*>
*>          3: U expressed both as a dense unitary matrix and
*>             as a product of Housholder transformations:
*>             RESULT(1) = | I - UV* | / ( n ulp )
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER
*>          If UPLO='U', the upper triangle of A and V will be used and
*>          the (strictly) lower triangle will not be referenced.
*>          If UPLO='L', the lower triangle of A and V will be used and
*>          the (strictly) upper triangle will not be referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The size of the matrix.  If it is zero, CHPT21 does nothing.
*>          It must be at least zero.
*> \endverbatim
*>
*> \param[in] KBAND
*> \verbatim
*>          KBAND is INTEGER
*>          The bandwidth of the matrix.  It may only be zero or one.
*>          If zero, then S is diagonal, and E is not referenced.  If
*>          one, then S is symmetric tri-diagonal.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*>          AP is COMPLEX array, dimension (N*(N+1)/2)
*>          The original (unfactored) matrix.  It is assumed to be
*>          hermitian, and contains the columns of just the upper
*>          triangle (UPLO='U') or only the lower triangle (UPLO='L'),
*>          packed one after another.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The diagonal of the (symmetric tri-) diagonal matrix.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is REAL array, dimension (N)
*>          The off-diagonal of the (symmetric tri-) diagonal matrix.
*>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
*>          (3,2) element, etc.
*>          Not referenced if KBAND=0.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is COMPLEX array, dimension (LDU, N)
*>          If ITYPE=1 or 3, this contains the unitary matrix in
*>          the decomposition, expressed as a dense matrix.  If ITYPE=2,
*>          then it is not referenced.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of U.  LDU must be at least N and
*>          at least 1.
*> \endverbatim
*>
*> \param[in] VP
*> \verbatim
*>          VP is REAL array, dimension (N*(N+1)/2)
*>          If ITYPE=2 or 3, the columns of this array contain the
*>          Householder vectors used to describe the unitary matrix
*>          in the decomposition, as described in purpose.
*>          *NOTE* If ITYPE=2 or 3, V is modified and restored.  The
*>          subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
*>          is set to one, and later reset to its original value, during
*>          the course of the calculation.
*>          If ITYPE=1, then it is neither referenced nor modified.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*>          TAU is COMPLEX array, dimension (N)
*>          If ITYPE >= 2, then TAU(j) is the scalar factor of
*>          v(j) v(j)* in the Householder transformation H(j) of
*>          the product  U = H(1)...H(n-2)
*>          If ITYPE < 2, then TAU is not referenced.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (N**2)
*>          Workspace.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (N)
*>          Workspace.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (2)
*>          The values computed by the two tests described above.  The
*>          values are currently limited to 1/ulp, to avoid overflow.
*>          RESULT(1) is always modified.  RESULT(2) is modified only
*>          if ITYPE=1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE CHPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP,
     $                   TAU, WORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            ITYPE, KBAND, LDU, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * ), RESULT( 2 ), RWORK( * )
      COMPLEX            AP( * ), TAU( * ), U( LDU, * ), VP( * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TEN
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 10.0E+0 )
      REAL               HALF
      PARAMETER          ( HALF = 1.0E+0 / 2.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER
      CHARACTER          CUPLO
      INTEGER            IINFO, J, JP, JP1, JR, LAP
      REAL               ANORM, ULP, UNFL, WNORM
      COMPLEX            TEMP, VSAVE
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANGE, CLANHP, SLAMCH
      COMPLEX            CDOTC
      EXTERNAL           LSAME, CLANGE, CLANHP, SLAMCH, CDOTC
*     ..
*     .. External Subroutines ..
      EXTERNAL           CAXPY, CCOPY, CGEMM, CHPMV, CHPR, CHPR2,
     $                   CLACPY, CLASET, CUPMTR
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
*     Constants
*
      RESULT( 1 ) = ZERO
      IF( ITYPE.EQ.1 )
     $   RESULT( 2 ) = ZERO
      IF( N.LE.0 )
     $   RETURN
*
      LAP = ( N*( N+1 ) ) / 2
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         LOWER = .FALSE.
         CUPLO = 'U'
      ELSE
         LOWER = .TRUE.
         CUPLO = 'L'
      END IF
*
      UNFL = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
*     Some Error Checks
*
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         RESULT( 1 ) = TEN / ULP
         RETURN
      END IF
*
*     Do Test 1
*
*     Norm of A:
*
      IF( ITYPE.EQ.3 ) THEN
         ANORM = ONE
      ELSE
         ANORM = MAX( CLANHP( '1', CUPLO, N, AP, RWORK ), UNFL )
      END IF
*
*     Compute error matrix:
*
      IF( ITYPE.EQ.1 ) THEN
*
*        ITYPE=1: error = A - U S U*
*
         CALL CLASET( 'Full', N, N, CZERO, CZERO, WORK, N )
         CALL CCOPY( LAP, AP, 1, WORK, 1 )
*
         DO 10 J = 1, N
            CALL CHPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
   10    CONTINUE
*
         IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
            DO 20 J = 1, N - 1
               CALL CHPR2( CUPLO, N, -CMPLX( E( J ) ), U( 1, J ), 1,
     $                     U( 1, J-1 ), 1, WORK )
   20       CONTINUE
         END IF
         WNORM = CLANHP( '1', CUPLO, N, WORK, RWORK )
*
      ELSE IF( ITYPE.EQ.2 ) THEN
*
*        ITYPE=2: error = V S V* - A
*
         CALL CLASET( 'Full', N, N, CZERO, CZERO, WORK, N )
*
         IF( LOWER ) THEN
            WORK( LAP ) = D( N )
            DO 40 J = N - 1, 1, -1
               JP = ( ( 2*N-J )*( J-1 ) ) / 2
               JP1 = JP + N - J
               IF( KBAND.EQ.1 ) THEN
                  WORK( JP+J+1 ) = ( CONE-TAU( J ) )*E( J )
                  DO 30 JR = J + 2, N
                     WORK( JP+JR ) = -TAU( J )*E( J )*VP( JP+JR )
   30             CONTINUE
               END IF
*
               IF( TAU( J ).NE.CZERO ) THEN
                  VSAVE = VP( JP+J+1 )
                  VP( JP+J+1 ) = CONE
                  CALL CHPMV( 'L', N-J, CONE, WORK( JP1+J+1 ),
     $                        VP( JP+J+1 ), 1, CZERO, WORK( LAP+1 ), 1 )
                  TEMP = -HALF*TAU( J )*CDOTC( N-J, WORK( LAP+1 ), 1,
     $                   VP( JP+J+1 ), 1 )
                  CALL CAXPY( N-J, TEMP, VP( JP+J+1 ), 1, WORK( LAP+1 ),
     $                        1 )
                  CALL CHPR2( 'L', N-J, -TAU( J ), VP( JP+J+1 ), 1,
     $                        WORK( LAP+1 ), 1, WORK( JP1+J+1 ) )
*
                  VP( JP+J+1 ) = VSAVE
               END IF
               WORK( JP+J ) = D( J )
   40       CONTINUE
         ELSE
            WORK( 1 ) = D( 1 )
            DO 60 J = 1, N - 1
               JP = ( J*( J-1 ) ) / 2
               JP1 = JP + J
               IF( KBAND.EQ.1 ) THEN
                  WORK( JP1+J ) = ( CONE-TAU( J ) )*E( J )
                  DO 50 JR = 1, J - 1
                     WORK( JP1+JR ) = -TAU( J )*E( J )*VP( JP1+JR )
   50             CONTINUE
               END IF
*
               IF( TAU( J ).NE.CZERO ) THEN
                  VSAVE = VP( JP1+J )
                  VP( JP1+J ) = CONE
                  CALL CHPMV( 'U', J, CONE, WORK, VP( JP1+1 ), 1, CZERO,
     $                        WORK( LAP+1 ), 1 )
                  TEMP = -HALF*TAU( J )*CDOTC( J, WORK( LAP+1 ), 1,
     $                   VP( JP1+1 ), 1 )
                  CALL CAXPY( J, TEMP, VP( JP1+1 ), 1, WORK( LAP+1 ),
     $                        1 )
                  CALL CHPR2( 'U', J, -TAU( J ), VP( JP1+1 ), 1,
     $                        WORK( LAP+1 ), 1, WORK )
                  VP( JP1+J ) = VSAVE
               END IF
               WORK( JP1+J+1 ) = D( J+1 )
   60       CONTINUE
         END IF
*
         DO 70 J = 1, LAP
            WORK( J ) = WORK( J ) - AP( J )
   70    CONTINUE
         WNORM = CLANHP( '1', CUPLO, N, WORK, RWORK )
*
      ELSE IF( ITYPE.EQ.3 ) THEN
*
*        ITYPE=3: error = U V* - I
*
         IF( N.LT.2 )
     $      RETURN
         CALL CLACPY( ' ', N, N, U, LDU, WORK, N )
         CALL CUPMTR( 'R', CUPLO, 'C', N, N, VP, TAU, WORK, N,
     $                WORK( N**2+1 ), IINFO )
         IF( IINFO.NE.0 ) THEN
            RESULT( 1 ) = TEN / ULP
            RETURN
         END IF
*
         DO 80 J = 1, N
            WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - CONE
   80    CONTINUE
*
         WNORM = CLANGE( '1', N, N, WORK, N, RWORK )
      END IF
*
      IF( ANORM.GT.WNORM ) THEN
         RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
      ELSE
         IF( ANORM.LT.ONE ) THEN
            RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
         ELSE
            RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
         END IF
      END IF
*
*     Do Test 2
*
*     Compute  UU* - I
*
      IF( ITYPE.EQ.1 ) THEN
         CALL CGEMM( 'N', 'C', N, N, N, CONE, U, LDU, U, LDU, CZERO,
     $               WORK, N )
*
         DO 90 J = 1, N
            WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - CONE
   90    CONTINUE
*
         RESULT( 2 ) = MIN( CLANGE( '1', N, N, WORK, N, RWORK ),
     $                 REAL( N ) ) / ( N*ULP )
      END IF
*
      RETURN
*
*     End of CHPT21
*
      END


module colatitudinal_derivative_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI

    use type_SpherepackUtility, only: &
        SpherepackUtility

    use gaussian_latitudes_and_weights_routines, only: &
        compute_gaussian_latitudes_and_weights

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: vtsec, vtseci, initialize_vtsec
    public :: vtses, vtsesi, initialize_vtses
    public :: vtsgc, vtsgci, initialize_vtsgc
    public :: vtsgs, vtsgsi, initialize_vtsgs
    public :: check_calling_arguments, check_init_calling_arguments
    public :: get_lwvts, get_lwvts_saved

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp

    ! Declare interfaces for submodule implementation
    interface
        module subroutine vtsec(nlat, nlon, ityp, nt, vt, wt, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vt(idvw, jdvw, nt)
            real(wp),    intent(out) :: wt(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: br(mdab, ndab, nt)
            real(wp),    intent(in)  :: bi(mdab, ndab, nt)
            real(wp),    intent(in)  :: cr(mdab, ndab, nt)
            real(wp),    intent(in)  :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtsec

        module subroutine vtses(nlat, nlon, ityp, nt, vt, wt, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vt(idvw, jdvw, nt)
            real(wp),    intent(out) :: wt(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: br(mdab, ndab, nt)
            real(wp),    intent(in)  :: bi(mdab, ndab, nt)
            real(wp),    intent(in)  :: cr(mdab, ndab, nt)
            real(wp),    intent(in)  :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtses

        module subroutine vtsgc(nlat, nlon, ityp, nt, vt, wt, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vt(idvw, jdvw, nt)
            real(wp),    intent(out) :: wt(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: br(mdab, ndab, nt)
            real(wp),    intent(in)  :: bi(mdab, ndab, nt)
            real(wp),    intent(in)  :: cr(mdab, ndab, nt)
            real(wp),    intent(in)  :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtsgc

        module subroutine vtsgs(nlat, nlon, ityp, nt, vt, wt, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vt(idvw, jdvw, nt)
            real(wp),    intent(out) :: wt(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: br(mdab, ndab, nt)
            real(wp),    intent(in)  :: bi(mdab, ndab, nt)
            real(wp),    intent(in)  :: cr(mdab, ndab, nt)
            real(wp),    intent(in)  :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtsgs

        module subroutine vtseci(nlat, nlon, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtseci

        module subroutine vtsesi(nlat, nlon, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtsesi

        module subroutine vtsgci(nlat, nlon, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtsgci

        module subroutine vtsgsi(nlat, nlon, wvts, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvts(:)
            integer(ip), intent(out) :: ierror
        end subroutine vtsgsi
    end interface

contains

    subroutine initialize_vtsec(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lwvts, vtseci, error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            error stop "Failed to initialize wavetable for vtsec"
        end if

    end subroutine initialize_vtsec

    subroutine initialize_vtsgc(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lwvts, vtsgci, error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            error stop "Failed to initialize wavetable for vtsgc"
        end if

    end subroutine initialize_vtsgc

    subroutine initialize_vtses(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lwvts_saved, vtsesi, error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            error stop "Failed to initialize wavetable for vtses"
        end if

    end subroutine initialize_vtses

    subroutine initialize_vtsgs(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lwvts_saved, vtsgsi, error_flag)

        ! Check error flag
        if (error_flag /= 0) then
            error stop "Failed to initialize wavetable for vtsgs"
        end if

    end subroutine initialize_vtsgs

    subroutine check_init_calling_arguments(&
        nlat, nlon, wvts, error_flag, required_size)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(in)  :: wvts(:)
        integer(ip), intent(out) :: error_flag
        integer(ip), intent(in)  :: required_size

        ! Check calling arguments
        if (nlat < 3) then
            error_flag = 1
        else if (nlon < 1) then
            error_flag = 2
        else if (size(wvts) < required_size) then
            error_flag = 3
        else
            error_flag = 0
        end if

    end subroutine check_init_calling_arguments

    subroutine check_calling_arguments( &
        nlat, nlon, ityp, nt, idvw, jdvw, mdab, ndab, wvts, error_flag, required_size)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(in)  :: nt
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvts(:)
        integer(ip), intent(out) :: error_flag
        integer(ip), intent(in)  :: required_size

        ! Local variable
        integer(ip) :: imid, mmax

        imid = (nlat + 1)/2
        mmax = min(nlat, (nlon + 1)/2)

        ! Check calling arguments
        if (nlat < 3) then
            error_flag = 1
        else if (nlon < 1) then
            error_flag = 2
        else if (ityp < 0 .or. ityp > 8) then
            error_flag = 3
        else if (nt < 0) then
            error_flag = 4
        else if ((ityp <= 2 .and. idvw < nlat) &
            .or. &
            (ityp > 2 .and. idvw < imid)) then
            error_flag = 5
        else if (jdvw < nlon) then
            error_flag = 6
        else if (mdab < mmax) then
            error_flag = 7
        else if (ndab < nlat) then
            error_flag = 8
        else if (size(wvts) < required_size) then
            error_flag = 9
        else
            error_flag = 0
        end if

    end subroutine check_calling_arguments

    pure function get_lwvts(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip)              :: return_value

        ! Local variables
        integer(ip) :: imid, lzz1, mmax, labc

        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        mmax = min(nlat, (nlon + 1)/2)
        labc = 3*(max(mmax-2, 0)*(2 * nlat - mmax - 1))/2
        return_value = 2*(lzz1 + labc) + nlon + 15

    end function get_lwvts

    pure function get_lwvts_saved(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip)              :: return_value

        ! Local variables
        integer(ip) :: imid, lzimn, mmax

        mmax = min(nlat, nlon/2+1)
        imid = (nlat + 1)/2
        lzimn = (imid * mmax * (2*nlat - mmax + 1))/2
        return_value = (2 * lzimn) + nlon + 15

    end function get_lwvts_saved

end module colatitudinal_derivative_routines


************************************************************************
*
*     Function DLNGAM                          Called by: EXPON, EXPVAR
*
*     compute logarithm of the GAMMA function; valid only for XX>0
*
************************************************************************
      DOUBLE PRECISION FUNCTION DLNGAM(XX)
*
*     subroutine args
*
      DOUBLE PRECISION XX
*
*     local vars
*
      INTEGER*4 J
      DOUBLE PRECISION SER,COF(6)

      DATA COF /76.18009173D0,-86.50532033D0,24.01409822D0,
     &          -1.231739516D0,1.20858003D-3,-5.36382D-6/
*
*
*
      SER = 1.D0
      DO 10 J=1,6
         SER = SER+COF(J)/(XX+DBLE(J-1))
 10   CONTINUE

      DLNGAM = ((XX-0.5D0)*LOG(XX+4.5D0)-(XX+4.5D0))
     &         + LOG(2.50662827465D0*SER)

      RETURN
      END


!----------------------------------------------------j.ostertag---------
     subroutine SPL_P(x,y,n,y2)
!
!     jasmin ostertag                       IAG
!                                           Universitaet Stuttgart
!     03.02.1998
!-----------------------------------------------------------------------
!
!     scope                     prepare spline interpolation
!                               (natural splines)
!-----------------------------------------------------------------------
!     declarations
!-----------------------------------------------------------------------
USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   ::  n, i, k
INTEGER(4),PARAMETER          ::  NMAX=5000

REAL(DbKi)                   :: yp1, ypn,p, qn, sig, un
REAL(DbKi)                   :: x(n), y(n), y2(n),u(NMAX)

      yp1 = -25.0d0 / 12.0d0 * y(1   ) &
            +48.0d0 / 12.0d0 * y(2   ) &
            -36.0d0 / 12.0d0 * y(3   ) &
            +16.0d0 / 12.0d0 * y(4   ) &
             -3.0d0 / 12.0d0 * y(5   )
      ypn =   3.0d0 / 12.0d0 * y(n-4) &
            -16.0d0 / 12.0d0 * y(n-3) &
            +36.0d0 / 12.0d0 * y(n-2) &
            -48.0d0 / 12.0d0 * y(n-1) &
           +25.0d0 / 12.0d0 * y(n  )

!-----------------------------------------------------------------------
!     prepare spline interpolation
!-----------------------------------------------------------------------
!     lower boundary condition is set either to be "natural"
!jo   erste Ableitung in Punkt 1
      if (yp1.gt..99e30) then
        y2(1) = 0.
        u(1) = 0.

!     or else to have a first derivative
      else
        y2(1) = -0.5
        u(1) = (3./(x(2) - x(1)))*((y(2) - y(1))/(x(2) - x(1)) - yp1)
      endif

!     this is the decomposition loop of the tridiagonal algorithm.
!     (y2 und u are used for temporary storage of the decomposed factors)
      do i=2,n-1
        sig = (x(i) - x(i-1))/(x(i+1) - x(i-1))
        p = sig*y2(i-1) + 2.0d0
        y2(i) = (sig - 1.0d0)/p
        u(i) = (6.0d0*((y(i+1) - y(i))/(x(i+1) - x(i)) - (y(i) - y(i-1))/ &
               (x(i) - x(i-1)))/(x(i+1) - x(i-1)) - sig*u(i-1))/p
      enddo

!     upper boundary condition is set either to be "natural"
!     erste Ableitung in Punkt n
      if (ypn.gt..99e30) then
        qn = 0.
        un = 0.

!     or else to have a first derivative
      else
        qn = 0.5
        un = (3.0d0/(x(n) - x(n-1)))*(ypn - (y(n) - y(n-1))/(x(n) - x(n-1)))
      endif

      y2(n) = (un - qn*u(n-1))/(qn*y2(n-1) + 1.0d0)

!     backsubstitution loop of the tridiagonal algorithm
      do k=n-1,1,-1
        y2(k) = y2(k)*y2(k+1) + u(k)
      enddo

!-----------------------------------------------------------------------
!     end of subroutine
!-----------------------------------------------------------------------
      return
!-----------------------------------------------------------------------
      end


      subroutine svd(nm,m,n,a,w,matu,u,matv,v,ierr,rv1)
c
      integer i,j,k,l,m,n,ii,i1,kk,k1,ll,l1,mn,nm,its,ierr
      real a(nm,n),w(n),u(nm,n),v(nm,n),rv1(n)
      real c,f,g,h,s,x,y,z,scale,anorm
      logical matu,matv
c
c     this subroutine is a translation of the algol procedure svd,
c     num. math. 14, 403-420(1970) by golub and reinsch.
c     handbook for auto. comp., vol ii-linear algebra, 134-151(1971).
c
c     this subroutine determines the singular value decomposition
c          t
c     a=usv  of a real m by n rectangular matrix.  householder
c     bidiagonalization and a variant of the qr algorithm are used.
c
c     on input.
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.  note that nm must be at least
c          as large as the maximum of m and n.
c
c        m is the number of rows of a (and u).
c
c        n is the number of columns of a (and u) and the order of v.
c
c        a contains the rectangular input matrix to be decomposed.
c
c        matu should be set to .true. if the u matrix in the
c          decomposition is desired, and to .false. otherwise.
c
c        matv should be set to .true. if the v matrix in the
c          decomposition is desired, and to .false. otherwise.
c
c     on output.
c
c        a is unaltered (unless overwritten by u or v).
c
c        w contains the n (non-negative) singular values of a (the
c          diagonal elements of s).  they are unordered.  if an
c          error exit is made, the singular values should be correct
c          for indices ierr+1,ierr+2,...,n.
c
c        u contains the matrix u (orthogonal column vectors) of the
c          decomposition if matu has been set to .true.  otherwise
c          u is used as a temporary array.  u may coincide with a.
c          if an error exit is made, the columns of u corresponding
c          to indices of correct singular values should be correct.
c
c        v contains the matrix v (orthogonal) of the decomposition if
c          matv has been set to .true.  otherwise v is not referenced.
c          v may also coincide with a if u is not needed.  if an error
c          exit is made, the columns of v corresponding to indices of
c          correct singular values should be correct.
c
c        ierr is set to
c          zero       for normal return,
c          k          if the k-th singular value has not been
c                     determined after 30 iterations.
c
c        rv1 is a temporary storage array.
c
c     questions and comments should be directed to b. s. garbow,
c     applied mathematics division, argonne national laboratory
c
c     modified to eliminate machep
c
      ierr = 0
c
      do 100 i = 1, m
c
         do 100 j = 1, n
            u(i,j) = a(i,j)
  100 continue
c     .......... householder reduction to bidiagonal form ..........
      g = 0.0
      scale = 0.0
      anorm = 0.0
c
      do 300 i = 1, n
         l = i + 1
         rv1(i) = scale * g
         g = 0.0
         s = 0.0
         scale = 0.0
         if (i .gt. m) go to 210
c
         do 120 k = i, m
  120    scale = scale + abs(u(k,i))
c
         if (scale .eq. 0.0) go to 210
c
         do 130 k = i, m
            u(k,i) = u(k,i) / scale
            s = s + u(k,i)**2
  130    continue
c
         f = u(i,i)
         g = -sign(sqrt(s),f)
         h = f * g - s
         u(i,i) = f - g
         if (i .eq. n) go to 190
c
         do 150 j = l, n
            s = 0.0
c
            do 140 k = i, m
  140       s = s + u(k,i) * u(k,j)
c
            f = s / h
c
            do 150 k = i, m
               u(k,j) = u(k,j) + f * u(k,i)
  150    continue
c
  190    do 200 k = i, m
  200    u(k,i) = scale * u(k,i)
c
  210    w(i) = scale * g
         g = 0.0
         s = 0.0
         scale = 0.0
         if (i .gt. m .or. i .eq. n) go to 290
c
         do 220 k = l, n
  220    scale = scale + abs(u(i,k))
c
         if (scale .eq. 0.0) go to 290
c
         do 230 k = l, n
            u(i,k) = u(i,k) / scale
            s = s + u(i,k)**2
  230    continue
c
         f = u(i,l)
         g = -sign(sqrt(s),f)
         h = f * g - s
         u(i,l) = f - g
c
         do 240 k = l, n
  240    rv1(k) = u(i,k) / h
c
         if (i .eq. m) go to 270
c
         do 260 j = l, m
            s = 0.0
c
            do 250 k = l, n
  250       s = s + u(j,k) * u(i,k)
c
            do 260 k = l, n
               u(j,k) = u(j,k) + s * rv1(k)
  260    continue
c
  270    do 280 k = l, n
  280    u(i,k) = scale * u(i,k)
c
  290    anorm = amax1(anorm,abs(w(i))+abs(rv1(i)))
  300 continue
c     .......... accumulation of right-hand transformations ..........
      if (.not. matv) go to 410
c     .......... for i=n step -1 until 1 do -- ..........
      do 400 ii = 1, n
         i = n + 1 - ii
         if (i .eq. n) go to 390
         if (g .eq. 0.0) go to 360
c
         do 320 j = l, n
c     .......... double division avoids possible underflow ..........
  320    v(j,i) = (u(i,j) / u(i,l)) / g
c
         do 350 j = l, n
            s = 0.0
c
            do 340 k = l, n
  340       s = s + u(i,k) * v(k,j)
c
            do 350 k = l, n
               v(k,j) = v(k,j) + s * v(k,i)
  350    continue
c
  360    do 380 j = l, n
            v(i,j) = 0.0
            v(j,i) = 0.0
  380    continue
c
  390    v(i,i) = 1.0
         g = rv1(i)
         l = i
  400 continue
c     .......... accumulation of left-hand transformations ..........
  410 if (.not. matu) go to 510
c     ..........for i=min(m,n) step -1 until 1 do -- ..........
      mn = n
      if (m .lt. n) mn = m
c
      do 500 ii = 1, mn
         i = mn + 1 - ii
         l = i + 1
         g = w(i)
         if (i .eq. n) go to 430
c
         do 420 j = l, n
  420    u(i,j) = 0.0
c
  430    if (g .eq. 0.0) go to 475
         if (i .eq. mn) go to 460
c
         do 450 j = l, n
            s = 0.0
c
            do 440 k = l, m
  440       s = s + u(k,i) * u(k,j)
c     .......... double division avoids possible underflow ..........
            f = (s / u(i,i)) / g
c
            do 450 k = i, m
               u(k,j) = u(k,j) + f * u(k,i)
  450    continue
c
  460    do 470 j = i, m
  470    u(j,i) = u(j,i) / g
c
         go to 490
c
  475    do 480 j = i, m
  480    u(j,i) = 0.0
c
  490    u(i,i) = u(i,i) + 1.0
  500 continue
c     .......... diagonalization of the bidiagonal form ..........
c     .......... for k=n step -1 until 1 do -- ..........
  510 do 700 kk = 1, n
         k1 = n - kk
         k = k1 + 1
         its = 0
c     .......... test for splitting.
c                for l=k step -1 until 1 do -- ..........
  520    do 530 ll = 1, k
            l1 = k - ll
            l = l1 + 1
            if (abs(rv1(l)) + anorm .eq. anorm) go to 565
c     .......... rv1(1) is always zero, so there is no exit
c                through the bottom of the loop ..........
            if (abs(w(l1)) + anorm .eq. anorm) go to 540
  530    continue
c     .......... cancellation of rv1(l) if l greater than 1 ..........
  540    c = 0.0
         s = 1.0
c
         do 560 i = l, k
            f = s * rv1(i)
            rv1(i) = c * rv1(i)
            if (abs(f) + anorm .eq. anorm) go to 565
            g = w(i)
            h = sqrt(f*f+g*g)
            w(i) = h
            c = g / h
            s = -f / h
            if (.not. matu) go to 560
c
            do 550 j = 1, m
               y = u(j,l1)
               z = u(j,i)
               u(j,l1) = y * c + z * s
               u(j,i) = -y * s + z * c
  550       continue
c
  560    continue
c     .......... test for convergence ..........
  565    z = w(k)
         if (l .eq. k) go to 650
c     .......... shift from bottom 2 by 2 minor ..........
         if (its .eq. 30) go to 1000
         its = its + 1
         x = w(l)
         y = w(k1)
         g = rv1(k1)
         h = rv1(k)
         f = ((y - z) * (y + z) + (g - h) * (g + h)) / (2.0 * h * y)
         g = sqrt(f*f+1.0)
         f = ((x - z) * (x + z) + h * (y / (f + sign(g,f)) - h)) / x
c     .......... next qr transformation ..........
         c = 1.0
         s = 1.0
c
         do 600 i1 = l, k1
            i = i1 + 1
            g = rv1(i)
            y = w(i)
            h = s * g
            g = c * g
            z = sqrt(f*f+h*h)
            rv1(i1) = z
            c = f / z
            s = h / z
            f = x * c + g * s
            g = -x * s + g * c
            h = y * s
            y = y * c
            if (.not. matv) go to 575
c
            do 570 j = 1, n
               x = v(j,i1)
               z = v(j,i)
               v(j,i1) = x * c + z * s
               v(j,i) = -x * s + z * c
  570       continue
c
  575       z = sqrt(f*f+h*h)
            w(i1) = z
c     .......... rotation can be arbitrary if z is zero ..........
            if (z .eq. 0.0) go to 580
            c = f / z
            s = h / z
  580       f = c * g + s * y
            x = -s * g + c * y
            if (.not. matu) go to 600
c
            do 590 j = 1, m
               y = u(j,i1)
               z = u(j,i)
               u(j,i1) = y * c + z * s
               u(j,i) = -y * s + z * c
  590       continue
c
  600    continue
c
         rv1(l) = 0.0
         rv1(k) = f
         w(k) = x
         go to 520
c     .......... convergence ..........
  650    if (z .ge. 0.0) go to 700
c     .......... w(k) is made non-negative ..........
         w(k) = -z
         if (.not. matv) go to 700
c
         do 690 j = 1, n
  690    v(j,k) = -v(j,k)
c
  700 continue
c
      go to 1001
c     .......... set error -- no convergence to a
c                singular value after 30 iterations ..........
 1000 ierr = k
 1001 return
      end


!version: serial with no mpi
! solves the 2d Stommel Model of Ocean Circulation
! using a Five-point stencil and Jacobi iteration
!
! gamma*((d(d(psi)/dx)/dx) + (d(d(psi)/dy)/dy))
! +beta(d(psi)/dx)=-alpha*sin(pi*y/(2*ly))
!
module numz
! module defines the basic real type and pi
    integer, parameter:: b8 = selected_real_kind(14)
    real(b8), parameter :: pi = 3.141592653589793239_b8
end module
!*********************
module input
! module contains the inputs
    use numz
    integer nx,ny             ! number of interior points for our grid (50 50)
    real(b8) lx,ly            ! physical size of our grid (2000 2000)
    real(b8) alpha,beta,gamma ! parameters of the calculation (1.0e-9 2.25e-11 3.0e-6)
    integer steps             ! number of Jacobi iteration steps (60)
end module
!*********************
module constants
! this module contains the invariants (constants) of the
! calculation.  these values are determined in the main
! routine and used in the do_jacobi Jacobi iteration subroutine
! a6 is used in the force function
    use numz
    real(b8) dx,dy,a1,a2,a3,a4,a5,a6
    real(b8), allocatable:: for(:,:)     ! our force grid
end module
!*********************
module face
! this module contains the interface for the two subroutines
! that modify the grid.  an interface is a good idea in this
! case because we are passing allocatable arrays
    interface bc
        subroutine bc (psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface do_jacobi
        subroutine do_jacobi (psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
            real(b8) diff
        end subroutine
    end interface
! interface for the forcing function
    interface force
        function force(y)
            use numz
            real(b8) force,y
        end function force
    end interface
    interface do_force
        subroutine do_force (i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
! interface for routine to write the grid
    interface write_grid
        subroutine write_grid (psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
end module


      PROGRAM xfitexy
C     driver for routine fitexy
      INTEGER NPT
      PARAMETER (NPT=30)
      REAL a,b,chi2,gasdev,q,ran1,sa,sb,siga,sigb
      REAL x(NPT),y(NPT),dx(NPT),dy(NPT),dz(NPT)
      INTEGER idum,j
      DATA dz /NPT*0./
      idum=-1
      do 11 j=1,NPT
        dx(j)=0.1+ran1(idum)
        dy(j)=0.1+ran1(idum)
        x(j)=10.+10.*gasdev(idum)
        y(j)=2.*x(j)-5.+dy(j)*gasdev(idum)
        x(j)=x(j)+dx(j)*gasdev(idum)
11    continue
      write(*,*) 'Values of a,b,siga,sigb,chi2,q:'
      write(*,*) 'Fit with x and y errors gives:'
      call fitexy(x,y,NPT,dx,dy,a,b,siga,sigb,chi2,q)
      write(*,'(6f11.6)') a,b,siga,sigb,chi2,q
      write(*,*)
      write(*,*) 'Setting x errors to zero gives:'
      call fitexy(x,y,NPT,dz,dy,a,b,siga,sigb,chi2,q)
      write(*,'(6f11.6)') a,b,siga,sigb,chi2,q
      write(*,*) '...to be compared with fit result:'
      call fit(x,y,NPT,dy,1,a,b,siga,sigb,chi2,q)
      write(*,'(6f11.6)') a,b,siga,sigb,chi2,q
      write(*,*)
      write(*,*) 'Setting y errors to zero gives:'
      call fitexy(x,y,NPT,dx,dz,a,b,siga,sigb,chi2,q)
      write(*,'(6f11.6)') a,b,siga,sigb,chi2,q
      write(*,*) '...to be compared with fit result:'
      call fit(y,x,NPT,dx,1,a,b,siga,sigb,chi2,q)
      sa=sqrt(siga**2+sigb**2*(a/b)**2)/b
      sb=sigb/b**2
      write(*,'(6f11.6)') -a/b,1./b,sa,sb,chi2,q
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfitexy.for


        subroutine idzr_svd(m,n,a,krank,u,v,s,ier,r)
c
c       constructs a rank-krank SVD  u diag(s) v^*  approximating a,
c       where u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine combines a QR code
c       (which is based on plane/Householder reflections)
c       with the LAPACK routine zgesdd.
c
c       input:
c       m -- first dimension of a and u
c       n -- second dimension of a, and first dimension of v
c       a -- matrix to be SVD'd
c       krank -- desired rank of the approximation to a
c
c       output:
c       u -- left singular vectors of a corresponding
c            to the k greatest singular values of a
c       v -- right singular vectors of a corresponding
c            to the k greatest singular values of a
c       s -- k greatest singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero when the routine encounters an error
c
c       work:
c       r -- must be at least
c            (krank+2)*n+8*min(m,n)+6*krank**2+8*krank
c            complex*16 elements long
c
c       _N.B._: This routine destroys a. Also, please beware that
c               the source code for this routine could be clearer.
c
        implicit none
        character*1 jobz
        integer m,n,k,krank,ifadjoint,ldr,ldu,ldvadj,lwork,
     1          info,j,ier,io
        real*8 s(krank)
        complex*16 a(m,n),u(m,krank),v(n*krank),r(*)
c
c
        io = 8*min(m,n)
c
c
        ier = 0
c
c
c       Compute a pivoted QR decomposition of a.
c
        call idzr_qrpiv(m,n,a,krank,r,r(io+1))
c
c
c       Extract R from the QR decomposition.
c
        call idz_retriever(m,n,a,krank,r(io+1))
c
c
c       Rearrange R according to ind.
c
        call idz_permuter(krank,r,krank,n,r(io+1))
c
c
c       Use LAPACK to SVD r,
c       storing the krank (krank x 1) left singular vectors
c       in r(io+krank*n+1 : io+krank*n+krank*krank).
c
        jobz = 'S'
        ldr = krank
        lwork = 2*(krank**2+2*krank+n)
        ldu = krank
        ldvadj = krank
c
        call zgesdd(jobz,krank,n,r(io+1),ldr,s,r(io+krank*n+1),ldu,
     1              v,ldvadj,r(io+krank*n+krank*krank+1),lwork,
     2              r(io+krank*n+krank*krank+lwork+1),r,info)
c
        if(info .ne. 0) then
          ier = info
          return
        endif
c
c
c       Multiply the U from R from the left by Q to obtain the U
c       for A.
c
        do k = 1,krank
c
          do j = 1,krank
            u(j,k) = r(io+krank*n+j+krank*(k-1))
          enddo ! j
c
          do j = krank+1,m
            u(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        ifadjoint = 0
        call idz_qmatmat(ifadjoint,m,n,a,krank,krank,u,r)
c
c
c       Take the adjoint of v to obtain r.
c
        call idz_adjer(krank,n,v,r)
c
c
c       Copy r into v.
c
        do k = 1,n*krank
          v(k) = r(k)
        enddo ! k
c
c
        return
        end
c
c
c
c