program test_bessely
  use types, only: dp
  use constants, only: i_
  use utils, only: assert
  use special, only: bessely
  implicit none

  ! check a few value against the ones computed with SciPy:
  integer :: i
  real(dp), parameter :: eps = 1d-12   ! ask for 12 digits precison
  real(dp), parameter :: ordersReal(7) = [0.000000000000000_dp, &
       & 1.000000000000000_dp, 2.000000000000000_dp, 3.300000000000000_dp, &
       & 7.000000000000000_dp, -1.500000000000000_dp, -4.000000000000000_dp]
  real(dp), parameter :: xReal(7) = [1.100000000000000_dp, &
       & 3.000000000000000_dp, 10.000000000000000_dp, 2.100000000000000_dp, &
       & 5.500000000000000_dp, 1.100000000000000_dp, 2.000000000000000_dp]
  real(dp), parameter :: xImag(7) = [0.100000000000000_dp, -0.300000000000000_dp, &
       & 2.500000000000000_dp, -1.800000000000000_dp, 2.000000000000000_dp, &
       & 0.500000000000000_dp, 1.500000000000000_dp]
  real(dp), parameter :: correctResultsRealArg(7) = [0.162163202926887_dp, &
       & 0.324674424791800_dp, -0.005868082442209_dp, -1.267804061151291_dp, &
       & -0.874921069456376_dp, -0.271278757000343_dp, -2.765943226330601_dp]
  complex(dp), parameter :: correctResultsComplexArg(7) = &
       [(0.166138524472016_dp, 0.069712187633448_dp), &
       & (0.341776321522289_dp, -0.081072612962834_dp), &
       & (0.133466627775052_dp, 1.443253639912400_dp), &
       & (-0.296969290084257_dp, -0.184899578288515_dp), &
       & (-0.252094851286872_dp, 0.315973789539520_dp), &
       & (-0.277544249205699_dp, -0.161447123409619_dp), &
       & (0.333070350408092_dp, 0.690575991440879_dp)]

  ! test real argument with real order:
  do i = 1,7
     print *, abs(bessely(ordersReal(i), xReal(i)) - correctResultsRealArg(i))
     call assert(abs(bessely(ordersReal(i), xReal(i)) - correctResultsRealArg(i)) < eps)
  end do

  ! test real argument with integer order:
  ! test those to machine precision
  call assert(abs(bessely(0, xReal(1)) - bessel_y0(xReal(1))) <= epsilon(1.0_dp))
  call assert(abs(bessely(1, xReal(2)) - bessel_y1(xReal(2))) <= epsilon(1.0_dp))
  call assert(abs(bessely(2, xReal(3)) - bessel_yn(2, xReal(3))) <= epsilon(1.0_dp))
  call assert(abs(bessely(3, xReal(4)) - bessel_yn(3, xReal(4))) <= epsilon(1.0_dp))
  call assert(abs(bessely(4, xReal(5)) - bessel_yn(4, xReal(5))) <= epsilon(1.0_dp))

  ! test complex data with real order:
  do i = 1,7
     print *, bessely(ordersReal(i), xReal(i)+i_*xImag(i)) - correctResultsComplexArg(i)
     call assert(abs(bessely(ordersReal(i), xReal(i)+i_*xImag(i)) - correctResultsComplexArg(i)) < eps)
  end do

end program test_bessely


C$Procedure      VCRSS ( Vector cross product, 3 dimensions )

      SUBROUTINE VCRSS ( V1, V2, VOUT )

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

      DOUBLE PRECISION    V1   ( 3 )
      DOUBLE PRECISION    V2   ( 3 )
      DOUBLE PRECISION    VOUT ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V1         I     Left hand vector for cross product.
C     V2         I     Right hand vector for cross product.
C     VOUT       O     Cross product V1xV2.
C
C$ Detailed_Input
C
C     V1       This may be any 3-dimensional vector.  Typically, this
C              might represent the (possibly unit) vector to a planet,
C              sun, or a star which defines the orientation of axes of
C              some coordinate system.
C
C     V2       Ditto.
C
C$ Detailed_Output
C
C     VOUT     This variable represents the cross product of V1 and V2.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     VCRSS calculates the three dimensional cross product of two
C     vectors according to the definition.
C
C     If V1 and V2 are large in magnitude (taken together, their
C     magnitude surpasses the limit allow by the computer) then it may
C     be possible to generate a floating point overflow from an
C     intermediate computation even though the actual cross product may
C     be well within the range of double precision numbers. VCRSS does
C     NOT check the magnitude of V1 or V2 to insure that overflow will
C     not occur.

C$ Examples
C
C     V1                  V2                  VOUT (=V1XV2)
C     -----------------------------------------------------------------
C     (0, 1, 0)           (1, 0, 0)           (0, 0, -1)
C     (5, 5, 5)           (-1, -1, -1)        (0, 0, 0)
C
C$ Restrictions
C
C     No checking of V1 or V2 is done to prevent floating point
C     overflow. The user is required to determine that the magnitude of
C     each component of the vectors is within an appropriate range so
C     as not to cause floating point overflow. In almost every case
C     there will be no problem and no checking actually needs to be
C     done.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     vector cross product
C
C-&

      DOUBLE PRECISION VTEMP(3)
C
C  Calculate the cross product of V1 and V2, store in VTEMP
C
      VTEMP(1) = V1(2)*V2(3) - V1(3)*V2(2)
      VTEMP(2) = V1(3)*V2(1) - V1(1)*V2(3)
      VTEMP(3) = V1(1)*V2(2) - V1(2)*V2(1)
C
C  Now move the result into VOUT
C
      VOUT(1) = VTEMP(1)
      VOUT(2) = VTEMP(2)
      VOUT(3) = VTEMP(3)
C
      RETURN
      END


	SUBROUTINE SNDFSP  ( xx, yy, np, iend, c, iret )
C************************************************************************
C* SNDFSP								*
C*									*
C* This subroutine gets the coefficients to be use for fitting points	*
C* which are strictly monotonic to a cubic spline.  The coefficients	*
C* are dimensioned (4,np-1)						*
C*									*
C* This algorithm is adapted from "Applied Numerical Analysis", 	*
C* Curtis F. Gerald, pp. 508-509.					*
C*									*
C* SNDFSP  ( XX, YY, NP, IEND, C, IRET )				*
C*									*
C* Input parameters:							*
C*	XX (NP)		REAL		X data positions		*
C*	YY (NP)		REAL		Y data positions		*
C*	NP		INTEGER		Number of points		*
C*	IEND		INTEGER		End point option		*
C*					  1 = linear			*
C*					  2 = parabolic			*
C*					  3 = cubic			*
C*									*
C* Output parameters:							*
C*	C (4,NP-1)	REAL		Coefficients			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92		Copied from GCFSPL		*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	REAL		xx (*), yy (*), c (4, *)
	INCLUDE		'CURVE.CMN'
	INCLUDE		'ERROR.PRM'
C------------------------------------------------------------------------
	iret = 0
C
	iret = NORMAL
	nm2 = np - 2
	nm1 = np - 1
	dx1 = xx (2) - xx (1)
	dy1 = ( yy (2) - yy (1) ) / dx1 * 6.
	DO  i = 1, nm2
	    dx2 = xx (i+2) - xx (i+1)
	    dy2 = ( yy (i+2) - yy (i+1) ) / dx2 * 6.
	    a ( 1, i ) = dx1
	    a ( 2, i ) = 2. * ( dx1 + dx2 )
	    a ( 3, i ) = dx2
	    a ( 4, i ) = dy2 - dy1
	    dx1 = dx2
	    dy1 = dy2
	END DO
C
C*	Adjust the first and last rows to the end condition.
C
	IF  ( iend .eq. 2 ) THEN
	    a ( 2,   1 ) = a ( 2,   1 ) + xx (2) - x (1)
	    a ( 2, nm2 ) = a ( 2, nm2 ) + xx (np) - xx (nm1)
	  ELSE IF ( iend .eq. 3 ) THEN
	    dx1 = xx (2) - xx (1)
	    dx2 = xx (3) - xx (2)
	    a ( 2, 1 ) = ( dx1 + dx2 ) * ( dx1 + 2. * dx2 ) / dx2
	    a ( 3, 1 ) = ( dx2 * dx2 - dx1 * dx1 ) / dx2
	    dxn2 = xx ( nm1 ) - xx ( nm2 )
	    dxn1 = xx ( np ) - xx ( nm1 )
	    a ( 1, nm2 ) = ( dxn2 * dxn2 - dxn1 * dxn1 ) / dxn2
	    a ( 2, nm2 ) = ( dxn1 + dxn2 ) * ( dxn1 + 2. * dxn2 ) / dxn2
	END IF
C
C*	Now solve the tridiagonal system.  First reduce.
C
	DO  i = 2, nm2
	    a (2,i) = a (2,i) - a (1,i) / a (2,i-1) * a (3,i-1)
	    a (4,i) = a (4,i) - a (1,i) / a (2,i-1) * a (4,i-1)
	END DO
C
C*	Now back substitute.
C
	a ( 4,nm2 ) = a ( 4, nm2 ) / a (2,nm2)
	DO  i = 2, nm2
	    j = nm1 - i
	    a (4,j) = ( a (4,j) - a (3,j) * a (4,j+1) ) / a (2,j)
	END DO
C
C*	Now put values into the s array.
C
	DO  i = 1, nm2
	    s (i+1) = a (4,i)
	END DO
C
C*	Get first and last values of s according to end conditions.
C
	IF  ( iend .eq. 1 ) THEN
	    s (1)  = 0.
	    s (np) = 0.
	  ELSE IF ( iend .eq. 2 ) THEN
	    s (1)  = s (2)
	    s (np) = s (nm1)
	  ELSE IF ( iend .eq. 3 ) THEN
	    s (1)  = ( ( dx1 + dx2 ) * s(2) - dx1 * s(3) ) / dx2
	    s (np) = ( ( dxn2 + dxn1 ) * s(nm1) - dxn1 * s(nm2)) / dxn2
	END IF
C
C*	Use the values of S to fill the coefficients array.
C
	DO  i = 1, nm1
	    dx = xx (i+1) - xx (i)
	    c (1,i) = ( s (i+1) - s (i) ) / ( 6. * dx )
	    c (2,i) = s (i) / 2.
	    c (3,i) = ( yy (i+1) - yy (i) ) / dx -
     +			( 2. * dx * s (i) + dx * s (i+1)) / 6.
	    c (4,i) = yy (i)
	END DO
C*
	RETURN
	END


PROGRAM testspline
  USE mcspline

  IMPLICIT NONE

  INTEGER, PARAMETER :: nn = 12, nx = 2*12 + 2 - 1

  INTEGER :: n
  REAL*8,  DIMENSION(nn) :: y, xony
  REAL*8 :: lam, T
  INTEGER :: JJ, r

  REAL*8 :: score
  REAL*8, DIMENSION(nx) :: x

! Input
  y = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]
! y = [-1, 2, 0, -2, 0, 2, 0, -2, 0, 2, 0, -2]
  n = nn
  r = 2
  T = 0.1
  JJ = 6
  lam = 5.8

  print *, 'Call cspline'
  CALL cspline(x, xony, score, y, n, r, T, JJ, lam)

! Output
  WRITE(*,*)xony

END PROGRAM testspline


program Movavg
  implicit none

  integer :: i

  write (*, "(a)") "SIMPLE MOVING AVERAGE: PERIOD = 3"

  do i = 1, 5
    write (*, "(a, i2, a, f8.6)") "Next number:", i, "   sma = ", sma(real(i))
  end do
  do i = 5, 1, -1
    write (*, "(a, i2, a, f8.6)") "Next number:", i, "   sma = ", sma(real(i))
  end do

contains

function sma(n)
  real :: sma
  real, intent(in) :: n
  real, save :: a(3) = 0
  integer, save :: count = 0

  if (count < 3) then
    count = count + 1
    a(count) = n
  else
    a = eoshift(a, 1, n)
  end if

  sma = sum(a(1:count)) / real(count)
end function

end program Movavg


subroutine SHLocalizedAdmitCorr(tapers, taper_order, lwin, lat, lon, gilm, &
                                tilm, lmax, admit, corr, K, admit_error, &
                                corr_error, taper_wt, mtdef, k1linsig, &
                                exitstatus)
!------------------------------------------------------------------------------
!
!   Given two spherical harmonic fields (gilm and tilm), this routine will
!   calculate the localized admittance and correlation using the first
!   space-concentrated window of Wieczorek and Simons (2005). All functions
!   must be 4-pi normalized, and exclude the Condon-Shortley phase factor. Two
!   manners of calculating the localized admittance and correlation are
!   possible according to the optional parameter MTDEF. In one case, the
!   multitaper cross-power spectra are calculated, and from these, the
!   admittance and correlation. In the second, the admittance and correlation
!   are calculated for each taper, and these are then averaged.
!
!   Calling Parameters
!
!       IN
!
!           tapers          A matrix of tapers obtained from SHReturnTapers.
!           taper_order     A vector continaing the angular order of each column
!                           of taper.
!           lwin            Spectral bandwidth of the localizing window.
!           lat, lon        Latitude and longitude that the window will be
!                           rotated to, in DEGREES.
!           gilm, tilm      Input spherical harmonic fields.
!           K               Number of tapers to use in Multitaper spectral
!                           estimations.
!           lmax            Maximum spherical harmonic degree of the intput
!                           fields.
!
!       OUT
!           admit           Admittance between the localized gilm and tilm
!                           assuming that gilm = Z tilm.
!           corr            Correlation of the two fields.
!
!       OPTIONAL (OUT)
!           admit_error     Error of the admittance (only when K>1)
!           corr_error      Error of the admittance (only when K>1)
!
!       OPTIONAL (IN)
!           mtdef           1 (default): Calculate multitaper cross-spectral
!                           estimates, and use these to calculate a single
!                           admittance and correlations.
!                           2: Calculate the admittance and correlation using
!                           each individual taper, and then average these to
!                           get the admittance and correlation.
!           taper_wt        Weights to be applied to the spectral estimates.
!                           This can only be used when MTDEF is 1.
!           k1linsig:       If present and equal to 1, the uncertainty in the
!                           admittance will be calculated by assuming the
!                           gravity and topography coefficients are linearly
!                           correlated, and that any lack of correlation is the
!                           result of uncorrelated noise. This should only be
!                           used when one expects the gravity and topography
!                           to be linearly correlated and when only a single
!                           taper is being used. This should not be used with a
!                           Forsyth type model that predicts a less than 1
!                           correlation coefficient. This is the square root
!                           of eq. 33 of Simons et al. 1997.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1. The units of the output admittance will correspond to the units of
!       the spherical harmonic coefficients. If gravity/topography admittances
!       are desired, then either the gravity coefficients should be multiplied
!       by G M (l+1) * (r0/r)**(l+2) / r0**2 before calling this routine, or
!       the admittances should be multiplied by this factor afterwards.
!
!       2. The correlation is defined as Sgt / sqrt(Sgg Stt), which varies
!       between -1 and 1. To obtain the "coherence" (which is also sometimes
!       referred to as the "coherence squared"), just square this number.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only:  djpi2, SHRotateRealCoef, &
                        SHCrossPowerSpectrum, SHPowerSpectrum, MakeGridGLQ, &
                        SHGLQ, SHExpandGLQ
    use ftypes

    implicit none

    real(dp), intent(in) :: tapers(:,:), lat, lon, gilm(:,:,:), tilm(:,:,:)
    integer(int32), intent(in) :: lwin, lmax, K, taper_order(:)
    real(dp), intent(out) :: admit(:), corr(:)
    real(dp), intent(out), optional :: admit_error(:), corr_error(:)
    integer(int32), intent(in), optional :: mtdef, k1linsig
    real(dp), intent(in), optional :: taper_wt(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: lmaxwin, l, def, astat(9), phase, norm, i, nlat, nlong
    integer(int32), save :: first = 1, lmaxwin_last = -1, lwin_last = -1
    real(dp) :: pi, g_power(2,lwin+lmax+1), t_power(2,lwin+lmax+1), &
                gt_power(2,lwin+lmax+1), x(3), sgt(lmax-lwin+1, K), &
                sgg(lmax-lwin+1, K), stt(lmax-lwin+1, K), &
                admit_k(lmax-lwin+1, K), corr_k(lmax-lwin+1, K), factor
    real(dp), allocatable :: shwin(:,:,:), shwinrot(:,:,:), shloc_g(:,:,:), &
                             shloc_t(:,:,:), gridtglq(:,:), gridgglq(:,:), &
                             gridwinglq(:,:), temp(:,:)
    real(dp), allocatable, save :: dj(:,:,:), zero(:), w(:)

!$OMP   threadprivate(first, lmaxwin_last, lwin_last, dj)

    if (present(exitstatus)) exitstatus = 0

    phase = 1
    norm = 1

    pi = acos(-1.0_dp)
    lmaxwin = lmax + lwin

    if (present(k1linsig) .and. K /= 1) then
        if (k1linsig == 1) then
            print*, "Error --- SHlocalizedAdmitCorr"
            print*, "If K1LINSIG is present and equal to 1, K must be " // &
                    "equal to 1."
            print*, "Input value of K1LINSIG is ", k1linsig
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    end if

    if (size(admit) < lmax-lwin+1) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "ADMIT must be dimensioned as (LMAX-LWIN+1) where " // &
                "LMAX and LWIN are ", lmax, lwin
        print*, "Input array is dimensioned ", size(admit)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(corr) < lmax-lwin+1) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "CORR must be dimensioned as (LMAX-LWIN+1) where " // &
                "LMAX and LWIN are ", lmax, lwin
        print*, "Input array is dimensioned ", size(corr)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(tapers(:,1)) < lwin+1 .or. size(tapers(1,:)) < K) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "TAPERS must be dimensioned as (LWIN+1, K) where " // &
                "LWIN and K are ", lwin, K
        print*, "Iinput array is dimensioned as ", size(tapers(:,1)), &
                size(tapers(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(taper_order) < K ) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "TAPER_ORDER must be dimensioned as (K) where K is ", K
        print*, "Input array is dimensioned ", size(taper_order)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(gilm(:,1,1)) < 2 .or. size(gilm(1,:,1)) < lmax+1 .or. &
             size(gilm(1,1,:)) < lmax+1) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "GILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(gilm(:,1,1)), &
                size(gilm(1,:,1)), size(gilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(tilm(:,1,1)) < 2 .or. size(tilm(1,:,1)) < lmax+1 .or. &
             size(tilm(1,1,:)) < lmax+1) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "TILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(tilm(:,1,1)), &
                size(tilm(1,:,1)), size(tilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(admit_error)) then
        if (size(admit_error) < lmax - lwin+1) then
            print*, "Error ---SHLocalizedAdmitCorr"
            print*, "ADMIT_ERROR must be dimensioned as (LMAX-LWIN+1) " // &
                    "where LMAX and LMAXT are ", lmax, lwin
            print*, "Input array is dimensioned ", size(admit_error)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(corr_error)) then
        if (size(corr_error) < lmax - lwin + 1) then
            print*, "Error ---SHLocalizedAdmitCorr"
            print*, "CORR_ERROR  must be dimensioned as (LMAX-LWIN+1) " // &
                    "where LMAX and LMAXT are ", lmax, lwin
            print*, "Input array is dimensioned ", size(corr_error)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if(present(taper_wt)) then
        if (size(taper_wt) < K) then
            print*, "Error --- SHLocalizedAdmitCorr"
            print*, "TAPER_WT must be dimensioned as (K) where K is ", K
            print*, "Input array has dimension ", size(taper_wt)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(mtdef)) then
        if (mtdef == 2 .and. present(taper_wt)) then
            print*, "Error --- SHLocalizedAdmitCorr"
            print*, "TAPER_WT can only be used when MTDEF is 1."
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    end if

    if (present(mtdef)) then
        if (mtdef /= 1 .and. mtdef /= 2) then
            print*, "SHLocalizedAdmitCorr --- Error"
            print*, "MTDEF must be 1 or 2."
            print*, "Input value is ", mtdef
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            def = mtdef

        end if

    else
        def = 1

    end if

    admit = 0.0_dp
    corr = 0.0_dp

    if (present(admit_error)) then
        admit_error = 0.0_dp
    end if

    if (present(corr_error)) then
        corr_error = 0.0_dp
    end if

    !--------------------------------------------------------------------------
    !
    !   Determine multitaper cross spectra estimates of gilm and tilm, and then
    !   calculate the admittance and correlation. Errors for the latter are
    !   calculated by adding the error sources in quadrature. Taper weights can
    !   be specified in order to minimize the variance of the multitaper
    !   cross-spectral estimates.
    !
    !   Note that only the admittances with degrees greater than lwin and less
    !   than Lmax - lwin should be interpretted.
    !
    !--------------------------------------------------------------------------
    x(1) = 0.0_dp
    x(2) = -(90.0_dp - lat) * pi / 180.0_dp
    x(3) = -lon * pi / 180.0_dp

    if (first == 1) then
        lwin_last = lwin
        lmaxwin_last = lmaxwin
        first = 0

        allocate (zero(lmaxwin+1), stat = astat(1))
        allocate (w(lmaxwin+1), stat = astat(2))
        allocate (dj(lwin+1,lwin+1,lwin+1), stat = astat(3))

        if (sum(astat(1:3)) /= 0) then
            print*, "Error --- SHLocalizedAdmitCorr"
            print*, "Problem allocating arrays ZERO, W and DJ", &
                    astat(1), astat(2), astat(3)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

        end if

        if (present(exitstatus)) then
            call SHGLQ(lmaxwin, zero, w, csphase = phase, norm = 1, &
                       exitstatus = exitstatus)
            if (exitstatus /= 0) return
            dj = 0.0_dp
            call djpi2(dj, lwin, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHGLQ(lmaxwin, zero, w, csphase = phase, norm = 1)
            dj = 0.0_dp
            call djpi2(dj, lwin)
        end if

    end if

    if (lwin > lwin_last) then
        lwin_last = lwin
        deallocate (dj)

        allocate (dj(lwin+1,lwin+1,lwin+1), stat = astat(1))

        if (astat(1) /= 0) then
            print*, "Error --- SHLocalizedAdmitCorr"
            print*, "Problem allocating array DJ", astat(1)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

        end if

        dj = 0.0_dp

        if (present(exitstatus)) then
            call djpi2(dj, lwin, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call djpi2(dj, lwin)
        end if

    end if

    if (lmaxwin /= lmaxwin_last) then
        lmaxwin_last = lmaxwin

        deallocate (zero)
        deallocate (w)
        allocate (zero(lmaxwin+1), stat = astat(1))
        allocate (w(lmaxwin+1), stat = astat(2))

        if (sum(astat(1:2)) /= 0) then
            print*, "Error --- SHLocalizedAdmitCorr"
            print*, "Problem allocating arrays ZERO and W", astat(1), astat(2)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

        end if

        if (present(exitstatus)) then
            call SHGLQ(lmaxwin, zero, w, csphase = phase, norm = 1, &
                       exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHGLQ(lmaxwin, zero, w, csphase = phase, norm = 1)
        end if

    end if

    nlat = lmax + lwin + 1
    nlong = 2 * (lmax + lwin) + 1

    allocate (shwin(2,lwin+1,lwin+1), stat = astat(1))
    allocate (shwinrot(2,lwin+1,lwin+1), stat = astat(2))
    allocate (shloc_g(2, lmaxwin+1, lmaxwin+1), stat= astat(3))
    allocate (shloc_t(2, lmaxwin+1, lmaxwin+1), stat= astat(4))
    allocate (gridtglq(nlat,nlong), stat = astat(5))
    allocate (gridgglq(nlat,nlong), stat = astat(6))
    allocate (gridwinglq(nlat,nlong), stat = astat(7))
    allocate (temp(nlat,nlong), stat = astat(8))

    if (sum(astat(1:8)) /= 0) then
        print*, "Error --- SHLocalizedAdmitCorr"
        print*, "Problem allocating arrays SHWIN, SHWINROT, SHLOC_G, " // &
            "SHLOC_T, GRIDTGLQ, GRIDGGLQ, GRIDWINGLQ, and TEMP", &
            astat(1), astat(2), astat(3), astat(4), astat(5), astat(6), &
            astat(7), astat(8)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

    end if

    if (present(exitstatus)) then
        call MakeGridGLQ(gridtglq, tilm(1:2,1:lmax+1, 1:lmax+1), &
                         lmaxwin, zero = zero, csphase = phase, norm = 1, &
                         exitstatus = exitstatus)
        if (exitstatus /= 0) return
        call MakeGridGLQ(gridgglq, gilm(1:2,1:lmax+1, 1:lmax+1), &
                         lmaxwin, zero = zero, csphase = phase, norm = 1, &
                         exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call MakeGridGLQ(gridtglq, tilm(1:2,1:lmax+1, 1:lmax+1), &
                         lmaxwin, zero = zero, csphase = phase, norm = 1)
        call MakeGridGLQ(gridgglq, gilm(1:2,1:lmax+1, 1:lmax+1), &
                         lmaxwin, zero = zero, csphase = phase, norm = 1)
    end if

    if (def == 1) then
        do i = 1, K
            shwin = 0.0_dp

            if (taper_order(i) < 0) then
                shwin(2,1:lwin+1,abs(taper_order(i))+1) = tapers(1:lwin+1,i)

            else
                shwin(1,1:lwin+1,taper_order(i)+1) = tapers(1:lwin+1,i)

            end if

            if (present(exitstatus)) then
                call SHRotateRealCoef(shwinrot, shwin, lwin, x, dj, &
                                      exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call MakeGridGLQ(gridwinglq, shwinrot(1:2,1:lwin+1, 1:lwin+1),&
                                 lmaxwin, zero = zero, csphase = phase, &
                                 norm = 1, exitstatus = exitstatus)
                if (exitstatus /= 0) return
                temp(1:nlat,1:nlong) = gridtglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_t, lmaxwin, temp, w, zero = zero, &
                                 csphase = phase, norm = 1, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
                temp(1:nlat,1:nlong) = gridgglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_g, lmaxwin, temp, w, zero = zero, &
                                csphase = phase, norm = 1, &
                                exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call SHCrossPowerSpectrum(shloc_g, shloc_t, lmax-lwin, &
                                          sgt(:,i), exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call SHPowerSpectrum(shloc_g, lmax-lwin, sgg(:,i), &
                                     exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call SHPowerSpectrum(shloc_t, lmax-lwin, stt(:,i), &
                                     exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHRotateRealCoef(shwinrot, shwin, lwin, x, dj)
                call MakeGridGLQ(gridwinglq, shwinrot(1:2,1:lwin+1, 1:lwin+1),&
                                 lmaxwin, zero = zero, csphase = phase, &
                                 norm = 1)
                temp(1:nlat,1:nlong) = gridtglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_t, lmaxwin, temp, w, zero = zero, &
                                 csphase = phase, norm = 1)
                temp(1:nlat,1:nlong) = gridgglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_g, lmaxwin, temp, w, zero = zero, &
                                csphase = phase, norm = 1)
                call SHCrossPowerSpectrum(shloc_g, shloc_t, lmax-lwin, &
                                          sgt(:,i))
                call SHPowerSpectrum(shloc_g, lmax-lwin, sgg(:,i))
                call SHPowerSpectrum(shloc_t, lmax-lwin, stt(:,i))
        end if

            if (present(taper_wt)) then
                factor = sum(taper_wt(1:K))**2 - sum(taper_wt(1:K)**2)
                factor = factor * sum(taper_wt(1:K))
                factor = sum(taper_wt(1:K)**2) / factor

                do  l= 0, lmax-lwin, 1
                    g_power(1,l+1) = dot_product(sgg(l+1,1:K), taper_wt(1:K)) &
                                     / sum(taper_wt(1:K))
                    t_power(1,l+1) = dot_product(stt(l+1,1:K), taper_wt(1:K)) &
                                     / sum(taper_wt(1:K))
                    gt_power(1,l+1) = dot_product(sgt(l+1,1:K), &
                                      taper_wt(1:K)) / sum(taper_wt(1:K))

                    if (K > 1) then
                        g_power(2,l+1) = dot_product( (sgg(l+1,1:K) &
                                         - g_power(1,l+1) )**2, &
                                         taper_wt(1:K) ) * factor
                        t_power(2,l+1) = dot_product( (stt(l+1,1:K) &
                                         - t_power(1,l+1) )**2, &
                                         taper_wt(1:K) ) * factor
                        gt_power(2,l+1) = dot_product( (sgt(l+1,1:K) &
                                          - gt_power(1,l+1) )**2, &
                                          taper_wt(1:K)) * factor

                    end if

                end do

            else
                do l = 0, lmax-lwin, 1
                    g_power(1,l+1) = sum(sgg(l+1,1:K)) / dble(K)
                    t_power(1,l+1) = sum(stt(l+1,1:K)) / dble(K)
                    gt_power(1,l+1) = sum(sgt(l+1,1:K)) / dble(K)

                    if (K > 1) then
                        g_power(2,l+1) = sum( ( sgg(l+1,1:K) &
                                         - g_power(1,l+1) )**2 ) / dble(K-1) &
                                         / dble(K) ! standard error!
                        t_power(2,l+1) = sum( ( stt(l+1,1:K) &
                                         - t_power(1,l+1) )**2 ) / dble(K-1) &
                                         / dble(K) ! standard error!
                        gt_power(2,l+1) = sum( ( sgt(l+1,1:K) &
                                          - gt_power(1,l+1) )**2 ) / dble(K-1) &
                                          / dble(K) ! standard error!

                    end if

                end do

            end if

            if (K > 1) then
                g_power(2,1:lmax-lwin+1) = sqrt(g_power(2,1:lmax-lwin+1))
                t_power(2,1:lmax-lwin+1) = sqrt(t_power(2,1:lmax-lwin+1))
                gt_power(2,1:lmax-lwin+1) = sqrt(gt_power(2,1:lmax-lwin+1))

            end if

        end do

        admit(1:lmax-lwin+1) = gt_power(1,1:lmax-lwin+1) &
                               / t_power(1,1:lmax-lwin+1)
        corr(1:lmax-lwin+1) = gt_power(1,1:lmax-lwin+1) &
                              / sqrt(t_power(1,1:lmax-lwin+1) &
                              * g_power(1,1:lmax-lwin+1))

        if (K > 1 .and. present(admit_error)) then
            admit_error(1:lmax-lwin+1) = ( gt_power(2,1:lmax-lwin+1) &
                                           / t_power(1,1:lmax-lwin+1) )**2 + &
                                           ( gt_power(1,1:lmax-lwin+1) &
                                           / t_power(1,1:lmax-lwin+1)**2 &
                                           * t_power(2,1:lmax-lwin+1) )**2
            admit_error(1:lmax-lwin+1) = sqrt(admit_error(1:lmax-lwin+1))

        end if

        if (K > 1 .and. present(corr_error)) then
            corr_error(1:lmax-lwin+1) = gt_power(2,1:lmax-lwin+1)**2 &
                            / t_power(1,1:lmax-lwin+1) &
                            / g_power(1,1:lmax-lwin+1) + &
                            ( gt_power(1,1:lwin-lmax+1) &
                            * t_power(2,1:lwin-lmax+1) / &
                            sqrt(g_power(1,1:lmax-lwin+1)) / 2.0_dp &
                            / t_power(1,1:lmax-lwin+1)**(3.0_dp/2.0_dp))**2 + &
                            ( gt_power(1,1:lwin-lmax+1) &
                            * g_power(2,1:lwin-lmax+1) &
                            / sqrt(t_power(1,1:lmax-lwin+1)) / 2.0_dp &
                            / g_power(1,1:lmax-lwin+1)**(3.0_dp/2.0_dp))**2
            corr_error(1:lmax-lwin+1) = sqrt(corr_error(1:lmax-lwin+1))

        end if

        if (K == 1 .and. present(k1linsig) .and. present(admit_error)) then
            admit_error = 0.0_dp

            if (k1linsig == 1) then
                do l = 1, lmax-lwin
                    admit_error(l+1) = g_power(1,l+1)*(1.0_dp - corr(l+1)**2) &
                                       / ( t_power(1,l+1) * dble(2*l) )
                end do

                admit_error(1:lmax-lwin+1) = sqrt(admit_error(1:lmax-lwin+1))

            end if

        end if

    !--------------------------------------------------------------------------
    !
    !   Calculate the admittance and correlation for each individual taper.
    !   Then average these in order to get the multitaper estimates and
    !   uncertainties.
    !
    !--------------------------------------------------------------------------
    else
        do i = 1, K
            shwin = 0.0_dp

            if (taper_order(i) < 0) then
                shwin(2,1:lwin+1,abs(taper_order(i))+1) = tapers(1:lwin+1,i)

            else
                shwin(1,1:lwin+1,taper_order(i)+1) = tapers(1:lwin+1,i)

            end if

            if (present(exitstatus)) then
                call SHRotateRealCoef(shwinrot, shwin, lwin, x, dj, &
                                      exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call MakeGridGLQ(gridwinglq, shwinrot(1:2,1:lwin+1, 1:lwin+1),&
                                 lmaxwin, zero = zero, csphase = phase, &
                                 norm = 1, exitstatus = exitstatus)
                if (exitstatus /= 0) return
                temp(1:nlat,1:nlong) = gridtglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_t, lmaxwin, temp, w, zero = zero, &
                                csphase = phase, norm = 1, &
                                exitstatus = exitstatus)
                if (exitstatus /= 0) return
                temp(1:nlat,1:nlong) = gridgglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_g, lmaxwin, temp, w, zero = zero, &
                                 csphase = phase, norm = 1, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call SHCrossPowerSpectrum(shloc_g, shloc_t, lmax-lwin, &
                                          sgt(:,i), exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call SHPowerSpectrum(shloc_g, lmax-lwin, sgg(:,i), &
                                     exitstatus = exitstatus)
                if (exitstatus /= 0) return
                call SHPowerSpectrum(shloc_t, lmax-lwin, stt(:,i), &
                                     exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHRotateRealCoef(shwinrot, shwin, lwin, x, dj)
                call MakeGridGLQ(gridwinglq, shwinrot(1:2,1:lwin+1, 1:lwin+1),&
                                 lmaxwin, zero = zero, csphase = phase, &
                                 norm = 1)
                temp(1:nlat,1:nlong) = gridtglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_t, lmaxwin, temp, w, zero = zero, &
                                csphase = phase, norm = 1)
                temp(1:nlat,1:nlong) = gridgglq(1:nlat,1:nlong) &
                                       * gridwinglq(1:nlat,1:nlong)
                call SHExpandGLQ(shloc_g, lmaxwin, temp, w, zero = zero, &
                                csphase = phase, norm = 1)
                call SHCrossPowerSpectrum(shloc_g, shloc_t, lmax-lwin, &
                                          sgt(:,i))
                call SHPowerSpectrum(shloc_g, lmax-lwin, sgg(:,i))
                call SHPowerSpectrum(shloc_t, lmax-lwin, stt(:,i))
            end if

            admit_k(1:lmax-lwin+1, i) = sgt(1:lmax-lwin+1, i) &
                                         / stt(1:lmax-lwin+1, i)
            corr_k(1:lmax-lwin+1, i) = sgt(1:lmax-lwin+1, i) &
                                        / sqrt(stt(1:lmax-lwin+1, i)) &
                                        / sqrt(sgg(1:lmax-lwin+1, i))

        end do

        do l = 0, lmax-lwin, 1
            admit(l+1) = sum(admit_k(l+1,1:K)) / dble(K)
            corr(l+1) = sum(corr_k(l+1,1:K)) / dble(K)

        end do

        if (present(admit_error) .or. present(corr_error)) then
            do l = 0, lmax-lwin, 1
                if (present(admit_error)) then
                    if (K > 1) then
                        admit_error(l+1) = sum( ( admit_k(l+1,1:K) &
                                           - admit(l+1) )**2 ) / dble(K-1) &
                                           / dble(K) ! standard error!
                        admit_error(l+1) = sqrt(admit_error(l+1))

                    else if (K == 1 .and. present(k1linsig)) then
                        if (k1linsig == 1) then
                            if (l == 0) then
                                admit_error(1) = 0.0_dp

                            else
                                admit_error(l+1) = sgg(l+1,1)*(1.0_dp &
                                                   - corr(l+1)**2) &
                                                   / (stt(l+1,1) * dble(2*l))
                                admit_error(l+1) = sqrt(admit_error(l+1))

                            end if

                        end if

                    end if

                end if

                if (present(corr_error)) then
                    if (K > 1) then
                        ! standard error!
                        corr_error(l+1) = sum((corr_k(l+1,1:K) &
                                               - corr(l+1))**2 ) &
                                          / dble(K-1) / dble(K)
                        corr_error(l+1) = sqrt(corr_error(l+1))

                    end if

                end if

            end do

        end if

    end if

    deallocate (shwin)
    deallocate (shwinrot)
    deallocate (shloc_g)
    deallocate (shloc_t)
    deallocate (gridtglq)
    deallocate (gridgglq)
    deallocate (gridwinglq)
    deallocate (temp)

end subroutine SHLocalizedAdmitCorr


  subroutine lorentzTransform (photonEG, p, v, pstar, t, cm)

! ======================================================================
!
!     Momentum calculation in system which has a relative velocity
!     v to given one.
!     Lorentz transformation; see Jackson, 2nd ed., p541.
!
!    Called by: ISOBAR STAT
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk  LANL  T-2  February, 1996.
!    Edited by AJS, August, 1997.
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    class(PhotonEventGenerator), intent(inout) :: photonEG
    real(real64),   intent(in   ) :: p(3)
    real(real64),   intent(in   ) :: v(3)
    real(real64),   intent(  out) :: pstar(3)
    real(real64),   intent(in   ) :: t
    real(real64),   intent(in   ) :: cm

    real(real64) :: spv, sv, temp1, temp2, v2

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

    v2 = v(1)**2 + v(2)**2 + v(3)**2
    temp1 = sqrt(abs(one - v2))
    spv = p(1)*v(1) + p(2)*v(2) + p(3)*v(3)
    if (temp1 < divZerLim ) then
       temp1 = divZerLim
       write(photonEG%io%message,1000) "45 and 46"
       call photonEG%io%print(4, 3, photonEG%io%message)
    end if
    temp2 = spv*(one/temp1 - one)/v2
    sv = (t + cm)/temp1

    pstar(1) = p(1) + v(1)*temp2 - v(1)*sv
    pstar(2) = p(2) + v(2)*temp2 - v(2)*sv
    pstar(3) = p(3) + v(3)*temp2 - v(3)*sv
    return

! ======================================================================
1000 format("Divide by zero error prevented in ", &
          & "'lorentzTransform.f90', line(s) ", A)
! ======================================================================
  end subroutine lorentzTransform


C      This file contains a number of simple matrix manipulation routines.
C      All of the routines operate on REAL*8 matrices.
C      The size is passed as the first parameters:  N rows by M columns.
C      If there is no M parameter then a N by N square matrix is assumed.
C
C    CALL MCOPY (N,M, X, Y)        Copies matrix: Y = X
C
C    CALL MADD (N,M, X, Y, Z)      Adds matrices: Z = X + Y
C                                    Z can be X or Y
C    CALL MSUB (N,M, X, Y, Z)      Subtracts matrices: Z = X - Y
C                                    Z can be X or Y
C    CALL MSCALARMULT (N,M, C, X, Y) Scalar multiply: Y = C*X
C                                    C is real scalar; Y can be X
C    CALL MZERO (N,M, X)           Zeros all elements in X
C
C    CALL MDIAG (N, V, X)          Formats a vector (V) into a diagonal
C                                    matrix (X)
C    CALL MIDENTITY (N, X)         Make identity matrix in X
C                                                   t
C    CALL MTRANSPOSE (N,M, X, Y)   Transposes: Y = X ;   Y cannot be X
C
C    CALL MMULT (N,M,L, X, Y, Z)   Matrix multiply: Z = X*Y
C                                    X is N by M and Y is M by L.
C                                    Z cannot be X or Y
C                                                          -1
C    CALL MINVERT (N, X, Y)        Matrix inversion:  Y = X
C				     X gets LU decomposition.

      SUBROUTINE MCOPY (N, M, MATRIX1, MATRIX2)
      INTEGER  N, M, I
      REAL*8   MATRIX1(1), MATRIX2(1)

      DO 100 I = 1, N*M
          MATRIX2(I) = MATRIX1(I)
100   CONTINUE

      RETURN
      END

      SUBROUTINE MADD (N, M, MATRIX1, MATRIX2, MATRIX3)
      INTEGER  N, M, I
      REAL*8   MATRIX1(1), MATRIX2(1),  MATRIX3(1)

      DO 100 I = 1, N*M
          MATRIX3(I) = MATRIX1(I) + MATRIX2(I)
100   CONTINUE

      RETURN
      END

      SUBROUTINE MSUB (N, M, MATRIX1, MATRIX2, MATRIX3)
      INTEGER  N, M, I
      REAL*8   MATRIX1(1), MATRIX2(1),  MATRIX3(1)

      DO 100 I = 1, N*M
          MATRIX3(I) = MATRIX1(I) - MATRIX2(I)
100   CONTINUE

      RETURN
      END

      SUBROUTINE MSCALARMULT (N, M, C, MATRIX1, MATRIX2)
      INTEGER  N, M, I
      REAL*8   C, MATRIX1(1), MATRIX2(1)

      DO 100 I = 1, N*M
          MATRIX2(I) = C*MATRIX1(I)
100   CONTINUE

      RETURN
      END

      SUBROUTINE MZERO (N, M, MATRIX1)
      INTEGER  N, M, I
      REAL*8   MATRIX1(1)

      DO 100 I = 1, N*M
          MATRIX1(I) = 0.0D0
100   CONTINUE

      RETURN
      END

      SUBROUTINE MDIAG (N,  VECTOR, MATRIX)
      INTEGER  N,  I, J
      REAL*8   VECTOR(1), MATRIX(N,N)

      DO 110 I = 1, N
        DO 100 J = 1, N
          MATRIX(I,J) = 0.0
100     CONTINUE
        MATRIX(I,I) = VECTOR(I)
110   CONTINUE

      RETURN
      END

      SUBROUTINE MIDENTITY (N, MATRIX)
      INTEGER  N, I, J
      REAL*8   MATRIX(N,N)

      DO 110 I = 1, N
        DO 100 J = 1, N
          MATRIX(I,J) = 0.0
100     CONTINUE
        MATRIX(I,I) = 1.0
110   CONTINUE

      RETURN
      END

      SUBROUTINE MTRANSPOSE (N, M, MATRIX1, MATRIX2)
      INTEGER  N, M, I, J
      REAL*8   MATRIX1(N,M), MATRIX2(M,N)

      DO I = 1, N
        DO J = 1, M
             MATRIX2(I,J) = MATRIX1(J,I)
        ENDDO
      ENDDO

      RETURN
      END

      SUBROUTINE MMULT (N, M, L, MATRIX1, MATRIX2, MATRIX3)
      INTEGER  N, M, L,  I, J, K
      REAL*8   MATRIX1(N,M), MATRIX2(M,L), MATRIX3(N,L),   SUM

      DO I = 1, N
        DO J = 1, L
          SUM = 0.0
          DO 100 K = 1, M
            SUM = SUM + MATRIX1(I,K)*MATRIX2(K,J)
100       CONTINUE
          MATRIX3(I,J) = SUM
        ENDDO
      ENDDO
      RETURN
      END

      SUBROUTINE MINVERT (N, MATRIX1, MATRIX2)
      INTEGER  N
      REAL*8   MATRIX1(N,N), MATRIX2(N,N)
      INTEGER  NMAX
      PARAMETER (NMAX=256)
      INTEGER  I, J, INDX(NMAX), IZ
      REAL*8   DET(2), WORK(NMAX)

      IF (N .GT. NMAX) THEN
          WRITE (*,'(1X,A,I3)')
     .    'Exceeded maximum matrix size for inversion.  Max = ', NMAX
          STOP
      ENDIF
      CALL DGEFA (MATRIX1, N, N, INDX, IZ)
      IF (IZ .GT. 0) THEN
	  WRITE (*,'(1X,A,I3)')
     .    'Encountered a zero pivot at element ', IZ
	  STOP
      ENDIF
      DO 100 I = 1, N
	DO 110 J = 1, N
           MATRIX2(I,J) = MATRIX1(I,J)
110     CONTINUE
100   CONTINUE
      CALL DGEDI (MATRIX2, N, N, INDX, DET, WORK, 1 )

      RETURN
      END

      subroutine dgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(1),info
      double precision a(lda,1)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end

      subroutine dgedi(a,lda,n,ipvt,det,work,job)
      integer lda,n,ipvt(1),job
      double precision a(lda,1),det(2),work(1)
c
c     dgedi computes the determinant and inverse of a matrix
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        work    double precision(n)
c                work vector.  contents destroyed.
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        a       inverse of original matrix if requested.
c                otherwise unchanged.
c
c        det     double precision(2)
c                determinant of original matrix if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. dabs(det(1)) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if dgeco has set rcond .gt. 0.0 or dgefa has set
c        info .eq. 0 .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,dswap
c     fortran dabs,mod
c
c     internal variables
c
      double precision t
      double precision ten
      integer i,j,k,kb,kp1,l,nm1
c
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0d0
         det(2) = 0.0d0
         ten = 10.0d0
         do 50 i = 1, n
            if (ipvt(i) .ne. i) det(1) = -det(1)
            det(1) = a(i,i)*det(1)
c        ...exit
            if (det(1) .eq. 0.0d0) go to 60
   10       if (dabs(det(1)) .ge. 1.0d0) go to 20
               det(1) = ten*det(1)
               det(2) = det(2) - 1.0d0
            go to 10
   20       continue
   30       if (dabs(det(1)) .lt. ten) go to 40
               det(1) = det(1)/ten
               det(2) = det(2) + 1.0d0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(u)
c
      if (mod(job,10) .eq. 0) go to 150
         do 100 k = 1, n
            a(k,k) = 1.0d0/a(k,k)
            t = -a(k,k)
            call dscal(k-1,t,a(1,k),1)
            kp1 = k + 1
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = a(k,j)
               a(k,j) = 0.0d0
               call daxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
c
c        form inverse(u)*inverse(l)
c
         nm1 = n - 1
         if (nm1 .lt. 1) go to 140
         do 130 kb = 1, nm1
            k = n - kb
            kp1 = k + 1
            do 110 i = kp1, n
               work(i) = a(i,k)
               a(i,k) = 0.0d0
  110       continue
            do 120 j = kp1, n
               t = work(j)
               call daxpy(n,t,a(1,j),1,a(1,k),1)
  120       continue
            l = ipvt(k)
            if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1)
  130    continue
  140    continue
  150 continue
      return
      end

      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end

      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      double precision da,dx(1)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end

      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      double precision dx(1),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end

      subroutine  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end


module user_func
  use utils

  implicit none

contains
  function k(x)
    real(wp), intent(in) :: x
    real(wp) :: k
    k = 1.0_wp
  end function k

  function q(x)
    real(wp), intent(in) :: x
    real(wp) :: q
    q = 0.0_wp
  end function q

  function f(x)
    real(wp), intent(in) :: x
    real(wp) :: f
    !f = (pi**2)*(sin(pi*x)-9*sin(3*pi*x))
    f = -2
  end function f

  function u(x)
    real(wp), intent(in) :: x
    real(wp) :: u
    !u = sin(pi*x) - sin(3*pi*x)
    u = (x-1.0)*x
  end function u

end module user_func


  module m_indexing
    !! Contains routines to obtain packed and unpacked indices into arrays

  use variableKind, only: i32, r64

  implicit none

  contains

  !====================================================================!
  function ind2sub(iG,nSub) result(iSub)
    !! Compute the indices in each dimension from the global index
  !====================================================================!
  integer(i32), intent(in) :: iG !! Index into a global vector
  integer(i32), intent(in) :: nSub(:) !! Size in each dimension
  integer(i32) :: iSub(size(nSub)) !! Indices in each dimension to return
  integer(i32) :: i,iGtmp,iTmp
  integer(i32) :: nDims
  integer(i32) :: prod

  nDims=size(nSub)
  if (nDims == 1) then
    iSub(1) = iG
    return
  end if

  prod = product(nSub)
  iGtmp = iG
  do i = nDims, 1, -1
    prod = prod / nSub(i)
    iTmp = mod(iGtmp-1,prod)+1
    iSub(i) = (iGtmp - iTmp)/prod + 1
    iGtmp = iTmp
  end do

  end function
  !====================================================================!
  !====================================================================!
  function sub2ind(iSub,nSub) result(iG)
    !! Given component indices, get the global vector location.
  !====================================================================!
  integer(i32), intent(in) :: iSub(:) !! Indices in each dimension. The first entry in iL is the left most index
  integer(i32), intent(in) :: nSub(:) !! Size in each dimension
  integer(i32) :: iG !! Index in the global vector
  integer(i32) :: i
  integer(i32) :: nDims
  integer(i32) :: prod
  nDims=size(iSub)

  prod = 1
  iG = 1
  do i = 1,nDims
    iG = iG + (iSub(i)-1)*prod
    prod = prod * nSub(i)
  end do

  end function
  !====================================================================!
  !====================================================================!
  function integerBin(this,n,bound) result(i)
  !====================================================================!
  ! Given a real number this, that is assumed to lie between 1 and N
  ! Round the real number and if it is outside 1 or N, limit the output to
  ! either of those values
  ! Automatically limits the output between 1 and N, unless bound is .false.
  ! TODO: This is not an integer bin, its the integer Nearest.
  real(r64) :: this
  integer(i32) :: n
  logical :: bound
  integer(i32) :: i
  i=idnint(this)
  if (bound) then
    if (i < 1) i=1
    if (i > n) i=n
  endif
  end function
  !====================================================================!
  end module


module single
  integer, parameter :: float = selected_real_kind ( 6,37 )
  real ( float ) :: pi = 3.1415927_float
  real ( float ) :: e  = 2.7182818_float
end module single

module double
  integer, parameter :: float = selected_real_kind ( 15,37 )
  real ( float ) :: pi = 3.141592653589793_float
  real ( float ) :: e  = 2.718281828459045_float
end module double

program constants
  !
  !     Select a precision for the constants for PI and E.
  !     USE SINGLE selects single precision whereas
  !     USE DOUBLE selects double precision.  Only one
  !     precision can be in selected per subprogram.
  !     Let the main program select single precision.
  use single
  character (len=60) :: pi_single
  character (len=60) :: e_single
  integer :: eslen, pislen
  write (UNIT=pi_single, FMT=*) pi
  write (UNIT=e_single, FMT=*) e
  pislen=len_trim(adjustl(pi_single))
  eslen=len_trim(adjustl(e_single))
  if((pislen.GE.7).AND.(eslen.GE.7)) then
     call more_precision
  else
     print *, "failed"
  end if
end program constants

subroutine more_precision
  !
  !     Let the subroutine select double precision.
  use double
  character (len=60) :: pi_double
  character (len=60) :: e_double
  integer :: edlen, pidlen
  write (UNIT=pi_double, FMT=*) pi
  write (UNIT=e_double, FMT=*) e
  pidlen=len_trim(adjustl(pi_double))
  edlen=len_trim(adjustl(e_double))

  if((pidlen.GE.16).AND.(edlen.GE.16)) then
     print *, "OK"
  else
     print *, "failed"
  end if
end subroutine more_precision


!**********************************************************************************************************************************
!
!  PROGRAM: Test_NWTC_Library
!
!  PURPOSE:  Tests the functionality of the NWTC Subroutine Library using IVF for Windows.
!
!  TESTED ROUTINES:
!     NWTC_Init
!     WrScr
!     WrScr1
!     Num2LStr: Int2LStr, R2LStr16
!  TESTED DATA/PARAMETERS:
!     QuKi
!

!**********************************************************************************************************************************

PROGRAM Test_NWTC_Library

    USE NWTC_Library
    USE NWTC_LAPACK

    IMPLICIT NONE

    ! Variables

      ! IVF for Windows hard-coded kinds

    REAL(16)   :: Real16Var      ! a 16-byte real variable
    REAL(8)    :: Real8Var       ! an 8-byte real variable
    REAL(4)    :: Real4Var       ! a 4-byte real variable

      ! Type-specific Library kinds

    REAL(QuKi) :: RealQuVar      ! a 16-byte real variable
    REAL(R8Ki) :: RealR8Var      ! an 8-byte real variable
    REAL(SiKi) :: RealSiVar      ! a 4-byte real variable

      ! Default kinds from Library

   REAL(ReKi)  :: RealReVar      ! a default real variable (different in SingPrec.f90 or DoubPrec.f90)
   REAL(DbKi)  :: RealDbVar      ! a default double variable (different in SingPrec.f90 or DoubPrec.f90)

   REAL(ReKi), ALLOCATABLE  :: RealReAry(:)

      ! File name
   CHARACTER(1024) :: InputFileName = 'TestData/TestLibrary_InputFile.txt'

   INTEGER(IntKi) :: ErrStat
   CHARACTER(1024) :: ErrMsg

   INTEGER(IntKi), ALLOCATABLE  :: TempVec(:,:)
   INTEGER(IntKi), ALLOCATABLE  :: IC(:)
   integer,parameter ::    NMX = 9
   integer :: i, j, k, i4

   integer, parameter:: m=5
   integer, parameter:: n=5
   double precision :: a(m,n), b(n)
   integer :: ipiv(m)

   type(meshtype) :: mesh1, mesh2, mesh3

   integer,parameter :: ndims=10
   real(reki),dimension(ndims,3) :: vec1,  vec2
   real(reki),dimension(3,ndims) :: vec11, vec21
   real(reki),dimension(3)       :: vec3

   REAL time_begin, time_end

   integer,parameter :: nx=1, ny=1, nz=2, n4=1
   complex(ReKi)     :: data2d(nx,nz), data3d(nx,nz,n4) , data4d(nx,ny,nz,n4) ,interpVal
   real(reki)        :: x(nx), y(ny), z(nz), w(n4), InCoord2(2), InCoord(3), InCoord4(4)
   integer           :: LastIndex(3) = 0, LastIndex4(4) = 0, LastIndex2(2) = 0
   !...............................................................................................................................
   ! Initialize the library
   !...............................................................................................................................

   CALL NWTC_Init(  )

   !print *, sqrt(epsilon(1.0_ReKi)), sqrt(epsilon(1.0_SiKi)), sqrt(epsilon(1.0_R8Ki))
   !stop

   call Test_TestMeshMapping()
   stop

   !...............................................................................................................................
   ! arrays for interpolation:

#ifdef WAMIT_INTERPOLATION

   do i=1,n4
      w(i) = -120 + (i-1) * 200/max(1,n4-1)
   end do

   do i=1,nz
      z(i) = -180 + (i-1) * 90/max(1,nz-1)
   end do

   do i=1,ny
      y(i) = -10 + (i-1)*20
   end do

   do i=1,nx
      x(i) = (i-1)*10
   end do

   !...............................................................................................................................
   ! 2d interpolation:

print *, x
print *, z

   data2d = 0.0_ReKi
   do j =1,nz
      do i =1,nx
         data2d(i,j) = (j-1)*nx + i
      end do
   end do

   do j =1,nz
      do i =1,nx
         InCoord2(1) = x(i)
         InCoord2(2) = z(j) + 45

         call WAMIT_Interp2D_Cplx( InCoord2, data2d, x, z, LastIndex2, interpVal, ErrStat, ErrMsg )

!if   ( .not. equalrealnos( REAL(data2d(i,j)), REAL(interpVal) ) .or. &
!       .not. equalrealnos( IMAG(data2d(i,j)), IMAG(interpVal) ) ) then
!print *, '----------------- not equal ---------------------------------------------------'
print *, '**** ', i, j, ' ****'
print *, ''
print *, 'input value:', InCoord2

print *, 'data at point:', data2d(i,j)
print *, 'interp data  :', interpVal
print *, '-------------------------------------------------------------------------------'
!end if

      end do
   end do

   !...............................................................................................................................
   ! 3d interpolation:

   data3d = 0.0_ReKi
   do k=1,n4
      do j =1,nz
         do i =1,nx
            data3d(i,j,k) = (k-1)*(nx*nz) + (j-1)*nx + i
         end do
      end do
   end do

   do k=1,n4
      do j =1,nz
         do i =1,nx
            InCoord(1) = x(i)
            InCoord(2) = z(j)
            InCoord(3) = w(k)

   call WAMIT_Interp3D_Cplx( InCoord, data3d, x, z, w, LastIndex, interpVal, ErrStat, ErrMsg )

if   ( .not. equalrealnos( REAL(data3d(i,j,k)), REAL(interpVal) ) .or. &
       .not. equalrealnos( IMAG(data3d(i,j,k)), IMAG(interpVal) ) ) then
print *, '----------------- not equal ---------------------------------------------------'
print *, '**** ', i, j, k, ' ****'
print *, ''
print *, 'input value:', InCoord

print *, 'data at point:', data3d(i,j,k)
print *, 'interp data  :', interpVal
print *, '-------------------------------------------------------------------------------'
end if

         end do
      end do
   end do

   !...............................................................................................................................
   ! 4d interpolation:
   data4d = 0.0_ReKi
   do i4 = 1,n4
      do k=1,nz
         do j =1,ny
            do i =1,nx
               data4d(i,j,k,i4) = (i4-1)*nz*ny*nx + (k-1)*(nx*ny) + (j-1)*nx + i
            end do
         end do
      end do
   end do

   do i4 = 1,n4
      do k=1,nz
         do j =1,ny
            do i =1,nx
               InCoord4(1) = x(i)
               InCoord4(2) = y(j)
               InCoord4(3) = z(k)
               InCoord4(4) = w(i4)

   call WAMIT_Interp4D_Cplx( InCoord4, data4d, x, y, z, w, LastIndex4, interpVal, ErrStat, ErrMsg )

if   ( .not. equalrealnos( REAL(data4d(i,j,k,i4)), REAL(interpVal) ) .or. &
       .not. equalrealnos( IMAG(data4d(i,j,k,i4)), IMAG(interpVal) ) ) then
print *, '----------------- not equal ---------------------------------------------------'
print *, '**** ', i, j, k, i4 , ' ****'
print *, ''
print *, 'input value:', InCoord4

print *, 'data at point:', data4d(i,j,k,i4)
print *, 'interp data  :', interpVal
print *, '-------------------------------------------------------------------------------'
end if
            end do
         end do
      end do
   end do

   stop
#endif
   !...............................................................................................................................
   ! Test cross_product timing with array dimensions
   !...............................................................................................................................

   do k=1,5

   CALL CPU_TIME(time_begin)
   vec1 = 1.;
   vec2 = 2.
   do    i=1,ndims
      vec1(i,1) = i
      vec1(i,2) = 0.2
      vec1(i,3) = 0.25
      do j=1,20
         vec3 = cross_product(vec1(i,:), vec2(i,:))
         vec1(i,:) = vec3
      end    do
   end do
   print *, vec3
   print *, vec1(1,:)
   CALL CPU_TIME ( time_end )
   WRITE (*,*) 'Time of operation A was ', time_end - time_begin, ' seconds'

   CALL CPU_TIME(time_begin)
   vec11 = 1.;
   vec21 = 2.
   do    i=1,ndims
      vec11(1,i) = i
      vec11(2,i) = 0.2
      vec11(3,i) = 0.25
      do j=1,20
         vec3 = cross_product(vec11(:,i), vec21(:,i))
         vec11(:,i) = vec3
      end    do
   end do
   print *, vec3
   print *, vec11(:,i)
   CALL CPU_TIME ( time_end )
   WRITE (*,*) 'Time of operation B was ', time_end - time_begin, ' seconds'

   end do

stop;

   !...............................................................................................................................
   ! Test interface with LAPACK
   !...............................................................................................................................

   call LAPACK_GETRF( m, n, a, IPIV, ErrStat, ErrMsg )
   print *, 'LAPACK_Getrf: ', ErrStat, TRIM(ErrMsg)

   call LAPACK_GETRs( 'N', n, a, IPIV, b, ErrStat, ErrMsg )
   print *, 'LAPACK_GETRs: ', ErrStat, TRIM(ErrMsg)

   !...............................................................................................................................
   ! Let's check that the PRECISION kinds are specified correctly:
   !...............................................................................................................................
   CALL WrScr( 'Real KIND parameters:' )
   CALL WrScr( '  QuKi is '//Num2LStr(QuKi)//'-> It should be 16.' )
   CALL WrScr( '  R8Ki is '//Num2LStr(R8Ki)//'-> It should be  8.' )
   CALL WrScr( '  SiKi is '//Num2LStr(SiKi)//'-> It should be  4.' )
   CALL WrScr1('  ReKi is '//Num2LStr(ReKi) )
   CALL WrScr( '  DbKi is '//Num2LStr(DbKi) )

   !...............................................................................................................................
   ! Test NWTC_Num routines: EqualRealNos
   !...............................................................................................................................

   CALL WrScr1( ' Testing EqualRealNos for quad kinds: ')

   Real16Var = 5.0_QuKi
   RealQuVar = Real16Var + 0.00005_QuKi

   print *, Real16Var
   print *, RealQuVar

   IF ( EqualRealNos  ( Real16Var, RealQuVar ) ) THEN
      CALL WrScr( ' '//TRIM(Num2LStr(Real16Var))//' is approximately equal to '//Num2LStr(RealQuVar) )
   ELSE
      CALL WrScr( ' '//TRIM(Num2LStr(Real16Var))//' is not equal to '//Num2LStr(RealQuVar) )

   END IF

   CALL WrScr1( ' Testing EqualRealNos for double kinds: ')
   Real8Var = 5.0_R8Ki
   RealR8Var = Real8Var + 0.00005_R8Ki

   print *, Real8Var
   print *, RealR8Var

   IF ( EqualRealNos  ( Real8Var, RealR8Var ) ) THEN
      CALL WrScr( ' '//TRIM(Num2LStr(Real8Var))//' is approximately equal to '//Num2LStr(RealR8Var) )
   ELSE
      CALL WrScr( ' '//TRIM(Num2LStr(Real8Var))//' is not equal to '//Num2LStr(RealR8Var) )

   END IF

   CALL WrScr1( ' Testing EqualRealNos for single kinds: ')
   Real4Var = 5.0_SiKi
   RealSiVar = Real8Var + 0.00005_SiKi

   print *, Real4Var
   print *, RealSiVar

   IF ( EqualRealNos  ( Real4Var, RealSiVar ) ) THEN
      CALL WrScr( ' '//TRIM(Num2LStr(Real4Var))//' is approximately equal to '//Num2LStr(RealSiVar) )
   ELSE
      CALL WrScr( ' '//TRIM(Num2LStr(Real4Var))//' is not equal to '//Num2LStr(RealSiVar) )
   END IF

   !...............................................................................................................................
   ! Test Formatted Input File:
   !...............................................................................................................................

   !CALL OpenFInpFile( )

!INTEGER(IntKi)  :: TempVec(3,2)
   allocate( TempVec(3,2) )

   TempVec(:,1) = (/ 1, 2, 3 /)
   TempVec(:,2) = TempVec(:,1)*6

   print *, TempVec

   print *, 'SIZE = ', SIZE(TempVec)

   print *, PACK(TempVec,.TRUE.)
   print *, TempVec(1:SIZE(TempVec),1)

   print *, TempVec(1:6,1)

   call  WrScr('  This is line 1.'//CHAR(10)//' This is line 2.')

   call  WrScr(NewLine//'  This is line 1.'//NewLine//'   This is line 2.'//NewLine//'  This is line 3.')
   CALL WrScr(NewLine//NewLine//NewLine//'This is really important'//NewLine//NewLine//&
        '   This is line 2 a really long line that i need to be more than 98 characters so that it will print on two lines. is this long enough, yet. I''m not sure' )

   call wrscr('')
   call wrscr(' one line' )
   call wrscr('  two lines.')

   do i=-1,6
      call wrscr( GetErrStr(i) )
   end do

   deallocate(TempVec)

   print *, 'This is the size of a deallocated array: ', size(TempVec), allocated(TempVec)
   print *, 'This is the size of a deallocated array: ', size(RealReAry), allocated(RealReAry)

   RealR8Var = 0.00000001_DbKi
   print *, MOD( NINT(RealR8Var), 10 ) == 1
   RealR8Var = 1.00000001_DbKi
   print *, MOD( NINT(RealR8Var), 10 ) == 1
   RealR8Var = 10.00000001_DbKi
   print *, MOD( NINT(RealR8Var), 10 ) == 1
   RealR8Var = 10.00000001_DbKi  + 1.0
   print *, MOD( NINT(RealR8Var), 10 ) == 1

!----------------------------
   !allocate( IC( NMX ) )
   !
   !IC(1) = 1
   !DO I = 2,NMX
   !   IC(I) = IC(1) - I + 1 + NMX
   !ENDDO
   !
   !write( *, '( A, I1, A, '//TRIM(Num2LStr(NMX))//'(I2,1X) )') 'SHIFT ', 0, ': ', IC
   !
   !DO j = 1,10
   !
   !   IC(1) = IC(1) + 1
   !   IF ( IC(1) > NMX )  IC(1) = IC(1) - NMX
   !   DO I = 2,NMX
   !      IC(I) = IC(1) - I + 1
   !      IF ( IC(I) <= 0 )  IC(I) = IC(I) + NMX
   !   ENDDO
   !
   !   write ( *, '( A, I1, A, '//TRIM(Num2LStr(NMX))//'(I2,1X) )') 'SHIFT ', j, ': ', IC
   !
   !end do
   !
   !print *, ' '
   !
   !IC(1) = 1
   !DO I = 2,NMX
   !   IC(I) = IC(1) - I + 1 + NMX
   !ENDDO
   !
   !write( *, '( A, I1, A, '//TRIM(Num2LStr(NMX))//'(I2,1X) )') 'SHIFT ', 0, ': ', IC
   !
   !DO j = 1,10
   !
   !   IC = CSHIFT( IC, -1 )
   !   write( *, '( A, I1, A, '//TRIM(Num2LStr(NMX))//'(I2,1X) )') 'SHIFT ', j, ': ', IC
   !
   !
   !end do
   !
   !deallocate( IC )

   !-----------------------------------------------------------
   ! Test some mesh routines:
   !-----------------------------------------------------------

   CALL WRSCR( 'start of mesh tests:' )
   ! PAUSE

   i = 2

   CALL MeshCreate( BlankMesh       = Mesh1       &
                     ,IOS           = COMPONENT_INPUT        &
                     ,NNodes        = i                      &
                     ,Force         = .TRUE.                 &
                     ,Moment        = .TRUE.                 &
                     ,ErrStat       = ErrStat                &
                     ,ErrMess       = ErrMsg                 )

   do j=1,i
         ! place nodes in a line
      CALL MeshPositionNode ( Mesh1, j, (/0.0_ReKi, 0.0_ReKi, j*1.0_ReKi /), ErrStat, ErrMsg )
      IF (ErrStat /= ErrID_None) CALL WrScr(TRIM(ErrMsg))

         ! create an element from this point

      CALL MeshConstructElement ( Mesh1, ELEMENT_POINT, ErrStat, ErrMsg, j )
      IF (ErrStat /= ErrID_None) CALL WrScr(TRIM(ErrMsg))

   END DO

      ! that's our entire mesh:
   CALL MeshCommit ( Mesh1, ErrStat, ErrMsg )
   IF (ErrStat /= ErrID_None) CALL WrScr(TRIM(ErrMsg))
   Mesh1%Force  = 1.
   Mesh1%Moment = 0.

   CALL WRSCR( 'finished creating mesh 1' )
   if (i<5) THEN
      CALL WRSCR( 'mesh 1 info:' )
      call meshprintinfo(CU,Mesh1)
   end if
   ! PAUSE

   CALL MeshCopy ( SrcMesh  = Mesh1 &
                 , DestMesh = Mesh2 &
                 , CtrlCode = MESH_SIBLING     &
                 , RotationVel     = .TRUE.    &
                 , ErrStat  = ErrStat          &
                 , ErrMess  = ErrMsg           )

   CALL WRSCR( 'finished creating sibling mesh 2' )
   Mesh2%RotationVel = 3

   if (i<5) THEN
      CALL WRSCR( 'mesh 2 info:' )
      call meshprintinfo(CU,Mesh2)
   end if
   ! PAUSE

   CALL MeshCopy ( SrcMesh  = Mesh1 &
                 , DestMesh = Mesh3 &
                 , CtrlCode = MESH_NEWCOPY     &
                 , ErrStat  = ErrStat          &
                 , ErrMess  = ErrMsg           )

   CALL WRSCR( 'finished creating new mesh 3' )
   MESH3%Force=10
   if (i<5) THEN
      CALL WRSCR( 'mesh 3 info:' )
      call meshprintinfo(CU,Mesh3)
   end if
   !PAUSE

   CALL MeshDestroy( Mesh2, ErrStat, ErrMsg, .TRUE. ) !delete only mesh 2 (not its sibling, too)
   if (i<5) THEN
      CALL WRSCR( 'mesh 1 info:' )
      call meshprintinfo(CU,Mesh1)
   end if
   CALL WRSCR( 'finished deleting mesh 2' )
   !PAUSE

   CALL MeshCopy ( SrcMesh  = Mesh1 &
                 , DestMesh = Mesh2 &
                 , CtrlCode = MESH_SIBLING     &
                 , TranslationDisp = .TRUE.    &
                 , Orientation     = .TRUE.    &
                 , RotationVel     = .TRUE.    &
                 , TranslationVel  = .TRUE.    &
                 , RotationAcc     = .TRUE.    &
                 , TranslationAcc  = .TRUE.    &
                 , ErrStat  = ErrStat          &
                 , ErrMess  = ErrMsg           )

   CALL WRSCR( 'finished creating sibling mesh 2' )
   !PAUSE

   CALL MeshDestroy( Mesh2, ErrStat, ErrMsg, .true. ) !delete mesh 2 BUT NOT its sibling (mesh 1)
   CALL WRSCR( 'finished deleting mesh 1' )
   !CALL MeshDestroy( Mesh2, ErrStat, ErrMsg, .FALSE. ) !delete both mesh 2 and its sibling (mesh 1)
   !CALL WRSCR( 'finished deleting meshes 1 and 2' )
   !PAUSE

   CALL MeshDestroy( Mesh3, ErrStat, ErrMsg ) !delete mesh 3
   CALL WRSCR( 'finished deleting mesh 3' )
   !PAUSE

   CALL WRSCR( 'finished this test' )
   ! PAUSE

   do i=1,10000
      print *, i, 'Copy:'
      CALL MeshCopy ( SrcMesh  = Mesh1 &
                    , DestMesh = Mesh3 &
                    , CtrlCode = MESH_NEWCOPY     &
                    , ErrStat  = ErrStat          &
                    , ErrMess  = ErrMsg           )
      IF (ErrStat/=ErrID_None) print *, TRIM(ErrMsg)

      print *, i, 'Destroy:'
      CALL MeshDestroy( Mesh3, ErrStat, ErrMsg, .FALSE. ) !delete mesh 3
      IF (ErrStat/=ErrID_None) print *, TRIM(ErrMsg)

   END DO

   CALL MeshDestroy( Mesh1, ErrStat, ErrMsg, .FALSE. )
   CALL WRSCR( 'finished mesh copy/destroy test' )
   !! PAUSE

   !-----------------------------------------------------------

END PROGRAM Test_NWTC_Library


      SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute all, or part, of the singular value decomposition of a
C     real upper triangular matrix.
C
C     The N-by-N upper triangular matrix A is factored as  A = Q*S*P',
C     where Q and P are N-by-N orthogonal matrices and S is an
C     N-by-N diagonal matrix with non-negative diagonal elements,
C     SV(1), SV(2), ..., SV(N), ordered such that
C
C        SV(1) >= SV(2) >= ... >= SV(N) >= 0.
C
C     The columns of Q are the left singular vectors of A, the diagonal
C     elements of S are the singular values of A and the columns of P
C     are the right singular vectors of A.
C
C     Either or both of Q and P' may be requested.
C     When P' is computed, it is returned in A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBQ    CHARACTER*1
C             Specifies whether the user wishes to compute the matrix Q
C             of left singular vectors as follows:
C             = 'V':  Left singular vectors are computed;
C             = 'N':  No left singular vectors are computed.
C
C     JOBP    CHARACTER*1
C             Specifies whether the user wishes to compute the matrix P'
C             of right singular vectors as follows:
C             = 'V':  Right singular vectors are computed;
C             = 'N':  No right singular vectors are computed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix A.
C             On exit, if JOBP = 'V', the leading N-by-N part of this
C             array contains the N-by-N orthogonal matrix  P'; otherwise
C             the N-by-N upper triangular part of A is used as internal
C             workspace. The strictly lower triangular part of A is set
C             internally to zero before the reduction to bidiagonal form
C             is performed.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If JOBQ = 'V', the leading N-by-N part of this array
C             contains the orthogonal matrix Q.
C             If JOBQ = 'N', Q is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,  and when JOBQ = 'V',  LDQ >= MAX(1,N).
C
C     SV      (output) DOUBLE PRECISION array, dimension (N)
C             The N singular values of the matrix A, sorted in
C             descending order.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK;
C             if INFO > 0, DWORK(2:N) contains the unconverged
C             superdiagonal elements of an upper bidiagonal matrix B
C             whose diagonal is in SV (not necessarily sorted).
C             B satisfies A = Q*B*P', so it has the same singular
C             values as A, and singular vectors related by Q and P'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,5*N).
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  the QR algorithm has failed to converge. In this
C                   case INFO specifies how many superdiagonals did not
C                   converge (see the description of DWORK).
C                   This failure is not likely to occur.
C
C     METHOD
C
C     The routine reduces A to bidiagonal form by means of elementary
C     reflectors and then uses the QR algorithm on the bidiagonal form.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute of Informatics, Bucharest, and
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     March 1998. Based on the RASP routine DTRSVD.
C
C     REVISIONS
C
C     V. Sima, Feb. 2000, Aug. 2011.
C
C     KEYWORDS
C
C     Bidiagonalization, orthogonal transformation, singular value
C     decomposition, singular values, triangular form.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBP, JOBQ
      INTEGER           INFO, LDA, LDQ, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), Q(LDQ,*), SV(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, WANTQ, WANTP
      INTEGER           I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK,
     $                  MINWRK, NCOLP, NCOLQ
      DOUBLE PRECISION  ANRM, BIGNUM, EPS, SMLNUM
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANTR
      EXTERNAL          DLAMCH, DLANTR, LSAME
C     .. External Subroutines ..
      EXTERNAL          DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, SQRT
C     .. Executable Statements ..
C
C     Check the input scalar arguments.
C
      INFO  = 0
      WANTQ = LSAME( JOBQ, 'V' )
      WANTP = LSAME( JOBP, 'V' )
      IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR.
     $    ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN
         INFO = -7
      ELSE
C
C        Compute workspace
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of workspace needed at that point in the code,
C        as well as the preferred amount for good performance.
C        NB refers to the optimal block size for the immediately
C        following subroutine, as returned by ILAENV.)
C
         MINWRK = MAX( 1, 5*N )
         LQUERY = LDWORK.EQ.-1
         IF ( LQUERY ) THEN
            CALL DGEBRD( N, N, A, LDA, SV, DWORK, DWORK, DWORK, DWORK,
     $                   -1, INFO )
            MAXWRK = INT( DWORK(1) )
            IF( WANTQ ) THEN
               CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK, DWORK, -1,
     $                      INFO )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            END IF
            IF( WANTP ) THEN
               CALL DORGBR( 'P', N, N, N, A, LDA, DWORK, DWORK, -1,
     $                      INFO )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            END IF
            MAXWRK = MAX( 3*N + MAXWRK, MINWRK )
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $      INFO = -10
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03UD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Get machine constants.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale A if max entry outside range [SMLNUM,BIGNUM].
C
      ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO )
      END IF
C
C     Zero out below.
C
      IF ( N.GT.1 )
     $   CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA )
C
C     Find the singular values and optionally the singular vectors
C     of the upper triangular matrix A.
C
      IE = 1
      ITAUQ = IE + N
      ITAUP = ITAUQ + N
      JWORK = ITAUP + N
C
C     First reduce the matrix to bidiagonal form. The diagonal
C     elements will be in SV and the superdiagonals in DWORK(IE).
C     (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
      CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ),
     $             DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO )
      MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
      IF( WANTQ ) THEN
C
C        Generate the transformation matrix Q corresponding to the
C        left singular vectors.
C        (Workspace: need 4*N, prefer 3*N+N*NB)
C
         NCOLQ = N
         CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ )
         CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
      ELSE
         NCOLQ = 0
      END IF
      IF( WANTP ) THEN
C
C        Generate the transformation matrix P' corresponding to the
C        right singular vectors.
C        (Workspace: need 4*N, prefer 3*N+N*NB)
C
         NCOLP = N
         CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
      ELSE
         NCOLP = 0
      END IF
      JWORK = IE + N
C
C     Perform bidiagonal QR iteration, to obtain all or part of the
C     singular value decomposition of A.
C     (Workspace: need 5*N)
C
      CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA,
     $             Q, LDQ, DUM, 1, DWORK(JWORK), INFO )
C
C     If DBDSQR failed to converge, copy unconverged superdiagonals
C     to DWORK(2:N).
C
      IF( INFO.NE.0 ) THEN
         DO 10 I = N - 1, 1, -1
            DWORK(I+1) = DWORK(I+IE-1)
   10    CONTINUE
      END IF
C
C     Undo scaling if necessary.
C
      IF( ISCL.EQ.1 ) THEN
         IF( ANRM.GT.BIGNUM )
     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO )
         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N,
     $                   INFO )
         IF( ANRM.LT.SMLNUM )
     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO )
         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N,
     $                   INFO )
      END IF
C
C     Return optimal workspace in DWORK(1).
C
      DWORK(1) = MAXWRK
C
      RETURN
C *** Last line of MB03UD ***
      END


module pmmf_fic_case3
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FOUR, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  Flow In Cylinder - case3 prescribed motion.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: fic_case3_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type fic_case3_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(fic_case3_pmmf),  intent(inout)  :: self

        ! Set function name
        call self%set_name("Flow In Cylinder - Case3")

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(fic_case3_pmmf),  intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        real(rk)    :: val(3)
        real(rk)    :: Aa, alpha, psi, x0, y0, r0, theta0, &
                       a, b, e, r, x_ale, y_ale

        Aa    = 1.5
        alpha = time**TWO*(THREE-time)/FOUR
        psi   = ONE + (Aa - ONE)*alpha

        ! Get the reference frame nodeinates of the grid point
        x0     = node(1)
        y0     = node(2)
        r0     = sqrt(x0*x0 + y0*y0)
        theta0 = atan2(y0,x0)

        a = psi * r0
        b = r0 / psi
        e = sqrt(ONE - psi**(-FOUR))
        r = b/(sqrt(ONE - (e*cos(theta0))**TWO))

        x_ale = r*cos(theta0)
        y_ale = r*sin(theta0)

        val(1) = x_ale
        val(2) = y_ale
        val(3) = node(3)

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(fic_case3_pmmf),  intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        real(rk)    :: val(3)
        real(rk)    :: Aa, alpha, psi, x0, y0, r0, theta0, &
                       a, b, e, r, dalphadt, dpsidt, h, dhdt, drdt, &
                       vr, vx_ale, vy_ale, f, dedt, dbdt, dfdt

        Aa       = 1.5
        alpha    = time**TWO*(THREE-time)/FOUR
        psi      = ONE + (Aa - ONE)*alpha

        ! Get the reference frame nodeinates of the grid point
        x0     = node(1)
        y0     = node(2)
        r0     = sqrt(x0*x0 + y0*y0)
        theta0 = atan2(y0,x0)

        ! Location
        a = psi * r0
        b = r0 / psi
        e = sqrt(ONE - psi**(-FOUR))
        r = b/(sqrt(ONE - (e*cos(theta0))**TWO))
        f = sqrt(ONE - e*e*cos(theta0)*cos(theta0))

        ! Velocity
        dalphadt = TWO*time*(THREE-time)/FOUR - (time**TWO)/FOUR
        dpsidt   = (Aa - ONE)*dalphadt

        dedt = TWO*dpsidt/((psi**5._rk)*sqrt(ONE - psi**(-FOUR)))
        dfdt = - cos(theta0)**TWO * e * dedt / (sqrt(ONE - e*e*cos(theta0)*cos(theta0)))
        dbdt = -r0*dpsidt/(psi*psi)

        drdt = (dbdt*f - b*dfdt)/(f*f)
!        h        = sqrt( (psi**FOUR)*(sin(theta0)**TWO) + cos(theta0)**TWO)
!        dhdt     = TWO*psi*psi*psi*dpsidt/h
!        drdt     = (r0*dpsidt*h - r0*psi*dhdt)/(h*h)
        vr       = drdt

        ! Convert to cartesian: assumes theta is not a function of (t)
        vx_ale = vr*cos(theta0)
        vy_ale = vr*sin(theta0)

      !  print*, sign(1._rk,vr), sign(1._rk,r - r0), vx_ale, vy_ale

        val(1) = vx_ale
        val(2) = vy_ale
        val(3) = ZERO

    end function compute_vel
    !**********************************************************************************

end module pmmf_fic_case3


c     # [xc,yc] are in [-180,180]x[0,360]
      subroutine mapc2m_latlong(blockno,xc,yc,xp,yp,zp)
      implicit none

      integer blockno
      double precision xc,yc,xp,yp,zp
      double precision deg2rad,xc1,yc1

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

c     # blockno is not used here;  assume that [xc,yc] is
c     # in a box [long0, long1]x[lat0,lat1], in
c     # degrees.

      deg2rad = pi/180.d0

      xc1 = deg2rad*xc
      yc1 = deg2rad*yc

      xp = cos(yc1)*cos(xc1)
      yp = cos(yc1)*sin(xc1)
      zp = sin(yc1)

      end