      INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the number of singular values of the bidiagonal matrix
C
C              |q(1) e(1)  .    ...    0   |
C              | 0   q(2) e(2)         .   |
C          J = | .                     .   |
C              | .                   e(N-1)|
C              | 0   ...     ...   0  q(N) |
C
C     which are less than or equal to a given bound THETA.
C
C     This routine is intended to be called only by other SLICOT
C     routines.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the bidiagonal matrix J.  N >= 0.
C
C     THETA   (input) DOUBLE PRECISION
C             Given bound.
C             Note: If THETA < 0.0 on entry, then MB03ND is set to 0
C                   as the singular values of J are non-negative.
C
C     Q2      (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the squares of the diagonal
C             elements q(1),q(2),...,q(N) of the bidiagonal matrix J.
C             That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N.
C
C     E2      (input) DOUBLE PRECISION array, dimension (N-1)
C             This array must contain the squares of the superdiagonal
C             elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J.
C             That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1.
C
C     PIVMIN  (input) DOUBLE PRECISION
C             The minimum absolute value of a "pivot" in the Sturm
C             sequence loop.
C             PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ),
C             where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at
C             least the smallest number that can divide one without
C             overflow (see LAPACK Library routine DLAMCH).
C             Note that this condition is not checked by the routine.
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
C     METHOD
C
C     The computation of the number of singular values s(i) of J which
C     are less than or equal to THETA is based on applying Sylvester's
C     Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the
C     unreduced symmetric tridiagonal matrices associated with J as
C     follows. Let T be the following 2N-by-2N symmetric matrix
C     associated with J:
C
C               | 0   J'|
C          T =  |       |.
C               | J   0 |
C
C     (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2),
C     ...,-s(N)). Then, by permuting the rows and columns of T into the
C     order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally
C     similar to the tridiagonal matrix T" with zeros on its diagonal
C     and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals
C     [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero,
C     Sylvester's Law of Inertia may be applied directly to T".
C     Otherwise, T" is block diagonal and each diagonal block (which is
C     then unreduced) must be analysed separately by applying
C     Sylvester's Law of Inertia.
C
C     REFERENCES
C
C     [1] Parlett, B.N.
C         The Symmetric Eigenvalue Problem.
C         Prentice Hall, Englewood Cliffs, New Jersey, 1980.
C
C     [2] Demmel, J. and Kahan, W.
C         Computing Small Singular Values of Bidiagonal Matrices with
C         Guaranteed High Relative Accuracy.
C         Technical Report, Courant Inst., New York, March 1988.
C
C     [3] Van Huffel, S. and Vandewalle, J.
C         The Partial Total Least-Squares Algorithm.
C         J. Comput. and Appl. Math., 21, pp. 333-341, 1988.
C
C     [4] Golub, G.H. and Kahan, W.
C         Calculating the Singular Values and Pseudo-inverse of a
C         Matrix.
C         SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965.
C
C     [5] Demmel, J.W., Dhillon, I. and Ren, H.
C         On the Correctness of Parallel Bisection in Floating Point.
C         Computer Science Division Technical Report UCB//CSD-94-805,
C         University of California, Berkeley, CA 94720, March 1994.
C
C     NUMERICAL ASPECTS
C
C     The singular values s(i) could also be obtained with the use of
C     the symmetric tridiagonal matrix T = J'J, whose eigenvalues are
C     the squared singular values of J [4,p.213]. However, the method
C     actually used by the routine is more accurate and equally
C     efficient (see [2]).
C
C     To avoid overflow, matrix J should be scaled so that its largest
C     element is no greater than  overflow**(1/2) * underflow**(1/4)
C     in absolute value (and not much smaller than that, for maximal
C     accuracy).
C
C     With respect to accuracy the following condition holds (see [2]):
C
C     If the established value is denoted by p, then at least p
C     singular values of J are less than or equal to
C     THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values
C     are less than or equal to
C     THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     July 10, 1997.
C
C     KEYWORDS
C
C     Bidiagonal matrix, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, N
      DOUBLE PRECISION  PIVMIN, THETA
C     .. Array Arguments ..
      DOUBLE PRECISION  E2(*), Q2(*)
C     .. Local Scalars ..
      INTEGER           J, NUMEIG
      DOUBLE PRECISION  R, T
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C     .. Executable Statements ..
C
C     Test the input scalar arguments.  PIVMIN is not checked.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
C
C        Error return.
C
         CALL XERBLA( 'MB03ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN
         MB03ND = 0
         RETURN
      END IF
C
      NUMEIG = N
      T = -THETA
      R = T
      IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
C
      DO 20 J = 1, N - 1
         R = T - Q2(J)/R
         IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
         IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1
         R = T - E2(J)/R
         IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
         IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1
   20 CONTINUE
C
      R = T - Q2(N)/R
      IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
      IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1
      MB03ND = NUMEIG
C
      RETURN
C *** Last line of MB03ND ***
      END


subroutine sum_with_use(x, res)
  use precision

  implicit none

  real(kind=rk), intent(in) :: x(:)
  real(kind=rk), intent(out) :: res

  integer :: i

  !print *, "size(x) = ", size(x)

  res = 0.0

  do i = 1, size(x)
    res = res + x(i)
  enddo

 end subroutine


!********************************************************************************
!   EFT: Error-Free Transformations and Compensated Arithmetic Routines
!   Author: Thomas R. Cameron and Aidan O'Neill
!   Institution: Davidson College, Mathematics and Computer Science Department
!   Last Modified: 29 March 2020
!********************************************************************************
module eft
    implicit none
    integer, parameter                          :: dp = kind(1.d0), factor = 2**27 + 1
    real(kind=dp), parameter                    :: big = huge(1.0_dp), eps = 2.0_dp**(-52), mu = 2.0_dp**(-53), small = tiny(1.0_dp)
    !********************************************************
    !   REFT: Real Error Free Transformation type.
    !********************************************************
    !   Made up of two real(kind=dp) variables x and y
    !   called primary and secondary, respectively.
    !   For TwoSum and TwoProd, x will denote floating-
    !   point result and y will denote error in result.
    !   For Split, x and y are the two parts of the
    !   floating-point number.
    !********************************************************
    type REFT
        real(kind=dp)                           :: x        ! primary
        real(kind=dp)                           :: y        ! secondary
    end type REFT
    !********************************************************
    !   CEFTSum: Complex Error Free Transformation Sum.
    !********************************************************
    !   Made up of two complex(kind=dp) variables x and y
    !   called primary and secondary, respectively.
    !   For TwoSumCplx, x denotes the floating-point
    !   result and y denotes the error.
    !********************************************************
    type CEFTSum
        complex(kind=dp)                        :: x        ! primary
        complex(kind=dp)                        :: y        ! secondary
    end type CEFTSum
    !********************************************************
    !   CEFTProd: Complex Error Free Transformation Product.
    !********************************************************
    !   Made up of four complex(kind=dp) variables p, e, f,
    !   and g, which we call primary, secondary, tertiary,
    !   and quaternary, respectively. For TwoProductCplx,
    !   p denotes the floating-point result, and e, f, and g
    !   denote errors associated with the sum and product
    !   of real and imaginary parts.
    !********************************************************
    type CEFTProd
        complex(kind=dp)                        :: p        ! primary
        complex(kind=dp)                        :: e        ! secondary
        complex(kind=dp)                        :: f        ! tertiary
        complex(kind=dp)                        :: g        ! quaternary
    end type CEFTProd
    !********************************************************
    !   REFTHorner: Real Error Free Transformation Horner.
    !********************************************************
    !   Made up of a real(kind=dp) variable h to store result
    !   of standard Horner method and two real(kind=dp)
    !   allocatable variables to store polynomial coefficients
    !   p and q, where pi is the error in the product term
    !   and qi is the error in the sum term on the ith
    !   iteration of Horner's method.
    !********************************************************
    type REFTHorner
        real(kind=dp)                           :: h        ! result
        real(kind=dp), allocatable              :: p(:)     ! error in product
        real(kind=dp), allocatable              :: q(:)     ! error in sum
    end type REFTHorner
    !********************************************************
    !   CEFTHorner: Complex Error Free Transformation Horner.
    !********************************************************
    !   Made up of a complex(kind=dp) variable h to store
    !   result of standard Horner method and four allocatable
    !   complex(kind=dp) variables to store polynomial
    !   coefficients p, q, r, and s, where pi, qi, ri is the
    !   error in the product term and si is the error in the
    !   sum term on the ith iteration of Horner's method.
    !********************************************************
    type CEFTHorner
        complex(kind=dp)                        :: h        ! result
        complex(kind=dp), allocatable           :: p(:)     ! error in product
        complex(kind=dp), allocatable           :: q(:)     ! error in product
        complex(kind=dp), allocatable           :: r(:)     ! error in product
        complex(kind=dp), allocatable           :: s(:)     ! error in sum
    end type CEFTHorner

contains

    !********************************************************
    !                       Two Sum                         *
    !********************************************************
    ! Computes the sum of two floating-point numbers
    ! a and b. The result and error is returned in
    ! comp which has type REFT.
    !********************************************************
    function TwoSum(a,b) result(comp)
        implicit none
        ! argument variables
        real(kind=dp)       :: a, b
        ! local variables
        real(kind=dp)       :: z
        type(REFT)          :: comp

        ! compute floating-point sum
        comp%x = a + b
        z = comp%x - a
        ! compute error in floating-point sum
        comp%y = (a - (comp%x - z)) + (b - z)
        return
    end function TwoSum
    !********************************************************
    !                       Two Sum Cplx                    *
    !********************************************************
    ! Computes the sum of two complex floating-point
    ! numbers a and b. The result and error is
    ! returned in comp which has type CEFTSum.
    !********************************************************
    function TwoSumCplx(a,b) result(comp)
        implicit none
        ! argument variables
        complex(kind=dp)        :: a, b
        ! local variables
        type(REFT)              :: rcomp, icomp
        type(CEFTSum)           :: comp

        ! compute sum of real and imaginary parts
        rcomp = TwoSum(real(a),real(b))
        icomp = TwoSum(aimag(a),aimag(b))
        ! store primary and secondary complex numbers in comp
        comp%x = cmplx(rcomp%x,icomp%x,kind=dp)
        comp%y = cmplx(rcomp%y,icomp%y,kind=dp)
        return
    end function TwoSumCplx
    !********************************************************
    !                       Split                           *
    !********************************************************
    ! Computes the splitting of a floating-point
    ! number a. Both parts have at most 26 nonzero bits
    ! and are returned in comp which has type REFT.
    !********************************************************
    function Split(a) result(comp)
        implicit none
        ! argument variables
        real(kind=dp)       :: a
        ! local variables
        real(kind=dp)       :: c
        type(REFT)          :: comp

        ! factor a
        c = factor * a
        ! split into two 26-bit numbers
        comp%x = c - (c - a)
        comp%y = a - comp%x
        return
    end function Split
    !********************************************************
    !                       Two Product                     *
    !********************************************************
    ! Computes the product of two floating-point
    ! numbers a and b. The result and error is
    ! returned in comp which has type REFT.
    !********************************************************
    function TwoProduct(a,b) result(comp)
        implicit none
        ! argument variables
        real(kind=dp)       :: a, b
        ! local variables
        type(REFT)          :: comp, sa, sb

        ! compute floating-point product
        comp%x = a * b
        ! split a and b
        sa = Split(a)
        sb = Split(b)
        ! compute error in floating-point product
        comp%y = sa%y * sb%y - (((comp%x - sa%x * sb%x) - sa%y * sb%x) - sa%x * sb%y)
        return
    end function TwoProduct
    !********************************************************
    !                       Two Product Cplx                *
    !********************************************************
    ! Computes the product of two complex floating-point
    ! numbers a and b. The result and error is returned
    ! in comp which has type CEFTP.
    !********************************************************
    function TwoProductCplx(a,b) result(comp)
        implicit none
        ! argument variables
        complex(kind=dp)    :: a, b
        ! local variables
        real(kind=dp)       :: z1, z2, z3, z4
        type(REFT)          :: sra, sia, srb, sib, sumr, sumi
        type(CEFTProd)      :: comp

        ! perform splitting of real(a), imag(a), real(b), imag(b)
        sra = Split(real(a)); sia = Split(aimag(a))
        srb = Split(real(b)); sib = Split(aimag(b))
        ! compute product of real and imaginary parts
        z1 = real(a) * real(b); z2 = aimag(a) * aimag(b)
        z3 = real(a) * aimag(b); z4 = aimag(a) * real(b)
        ! compute sum z1-z2
        sumr = TwoSum(z1,-z2)
        ! compute sum z3+z4
        sumi = TwoSum(z3,z4)
        ! floating-point result
        comp%p = cmplx(sumr%x,sumi%x,kind=dp)
        ! error in z1 and z3
        comp%e = cmplx(sra%y * srb%y - (((z1 - sra%x * srb%x) - sra%y * srb%x) - sra%x * srb%y),&
                        sra%y * sib%y - (((z3 - sra%x * sib%x) - sra%y * sib%x) - sra%x * sib%y),kind=dp)
        ! error in z2 and z4
        comp%f = cmplx(-sia%y * sib%y + (((z2 - sia%x * sib%x) - sia%y * sib%x) - sia%x * sib%y),&
                        sia%y * srb%y - (((z4 - sia%x * srb%x) - sia%y * srb%x) - sia%x * srb%y),kind=dp)
        ! error in sums
        comp%g = cmplx(sumr%y,sumi%y,kind=dp)
        return
    end function TwoProductCplx
    !********************************************************
    !                       EFT Horner                      *
    !********************************************************
    ! Compute the evaluation of a polynomial at a
    ! floating-point number. The result and error
    ! is returned in comp which has type REFTHorner.
    !********************************************************
    function EFTHorner(poly,x,deg) result(comp)
        implicit none
        ! argument variables
        integer             :: deg
        real(kind=dp)       :: poly(:), x
        ! local variables
        integer             :: k
        type(REFT)          :: prod, sum
        type(REFTHorner)    :: comp

        ! allocate memory for comp polynomials
        allocate(comp%p(deg),comp%q(deg))
        ! Horner's method
        comp%h = poly(deg+1)
        do k=deg,1,-1
            ! product and sum
            prod = TwoProduct(comp%h,x)
            sum = TwoSum(prod%x,poly(k))
            ! update comp
            comp%h = sum%x
            comp%p(k) = prod%y
            comp%q(k) = sum%y
        end do
        return
    end function EFTHorner
    !********************************************************
    !                       EFT Horner Cplx                 *
    !********************************************************
    ! Compute the evaluation of a polynomial at a complex
    ! floating-point number. The result and error is returned
    ! in comp which has type CEFTHorner.
    !********************************************************
    function EFTHornerCplx(poly,x,deg)  result(comp)
        implicit none
        ! argument variables
        integer             :: deg
        complex(kind=dp)    :: poly(:), x
        ! local variables
        integer             :: k
        type(CEFTSum)       :: sum
        type(CEFTProd)      :: prod
        type(CEFTHorner)    :: comp

        ! allocate memory for comp polynomials
        allocate(comp%p(deg),comp%q(deg),comp%r(deg),comp%s(deg))
        ! Horner's method
        comp%h = poly(deg+1)
        do k=deg,1,-1
            ! product and sum
            prod = TwoProductCplx(comp%h,x)
            sum = TwoSumCplx(prod%p,poly(k))
            ! update comp
            comp%h = sum%x
            comp%p(k) = prod%e
            comp%q(k) = prod%f
            comp%r(k) = prod%g
            comp%s(k) = sum%y
        end do
        return
    end function EFTHornerCplx
    !****************************************************
    !                       Next Power Two              *
    !****************************************************
    ! Computation of 2^ceil(log2(abs(p))), for p \neq 0.
    !****************************************************
    function NextPowerTwo(p) result(comp)
        implicit none
        ! argument variables
        real(kind=dp)               :: p
        ! local variables
        real(kind=dp)               :: comp, q

        q = p/mu
        comp = abs((q+p)-q)
        if(comp==0.0_dp) then
            comp = abs(p)
        end if
        return
    end function NextPowerTwo
    !****************************************************
    !                       Faith Sum                   *
    !****************************************************
    ! Computes the faithful sum of the real floating-
    ! point numbers a, b, c, and d. Result is returned
    ! in comp which has type real(kind=dp).
    !****************************************************
    function FaithSum(a,b,c,d) result(comp)
        implicit none
        ! argument variables
        real(kind=dp)                   :: a, b, c, d
        ! local variables
        integer                         :: n
        real(kind=dp)                   :: fac, m, Ms, phi, sigma
        real(kind=dp)                   :: comp, t, tau, tau1, tau2
        real(kind=dp), allocatable      :: p(:), q(:)
        real(kind=dp), parameter        :: realmin = tiny(1.0_dp)

        ! initialize arrays
        n = 4
        allocate(p(n),q(n))
        p(1)=a; p(2)=b; p(3)=c; p(4)=d
        ! check size and max
        10 m = maxval(abs(p))
        if(n==0 .or. m==0.0_dp) then
            comp = 0.0_dp
            deallocate(p,q)
            return
        end if
        ! initialize variables
        Ms = NextPowerTwo((n+2)*1.0_dp)
        sigma = Ms*NextPowerTwo(m)
        phi = mu*Ms
        fac = eps*Ms*Ms
        ! main loop
        t = 0.0_dp
        do while(.True.)
            q = (sigma + p) - sigma
            tau = sum(q)
            p = p - q
            tau1 = t + tau
            ! check new approximation tau1
            if(abs(tau1)>=fac*sigma .or. sigma<=realmin) then
                tau2 = tau - (tau1 - t)
                comp = tau1 + (tau2 + sum(p))
                deallocate(p,q)
                return
            end if
            t = tau1
            ! accelerate zero sum case
            if(t==0.0_dp) then
                p = pack(p, p /= 0.0_dp)
                n = size(p)
                deallocate(q)
                allocate(q(n))
                go to 10
            end if
            ! new extraction unit
            sigma = phi*sigma
        end do
    end function FaithSum
    !****************************************************
    !                       Faith Sum Cplx              *
    !****************************************************
    ! Computes the faithful sum of the complex floating-
    ! point numbers a, b, c, and d. Result is returned
    ! in comp which has type complex(kind=dp).
    !****************************************************
    function FaithSumCplx(a,b,c,d) result(comp)
        implicit none
        ! argument variables
        complex(kind=dp)                :: a, b, c, d
        ! local variables
        complex(kind=dp)                :: comp

        comp = cmplx(FaithSum(real(a),real(b),real(c),real(d)),&
                    FaithSum(aimag(a),aimag(b),aimag(c),aimag(d)),kind=dp)
        return
    end function FaithSumCplx
end module eft


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j
      real*8 a(12),qr(12),a_qr(12),tau(3)

      character arg*32

      A = (/ 1, -1, 4, 1, 4, -2, 1, 4, 2, 1, -1, 0 /)
      qr = (/ 1, -1, 4, 1, 4, -2, 1, 4, 2, 1, -1, 0 /)
      a_qr = (/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /)

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedqrfactorization(ceed,qr,tau,4,3,err)
      do i=1,3
        do j=i,3
          a_qr((i-1)*3+j)=qr((i-1)*3+j)
        enddo
      enddo
      call ceedhouseholderapplyq(a_qr,qr,tau,ceed_notranspose,4,3,3,3,1,err)

      do i=1,12
        if (abs(a(i)-a_qr(i))>1.0D-14) then
! LCOV_EXCL_START
        write(*,*) 'Error in QR factorization a_qr(',i,') = ',a_qr(i),&
    &    ' != a(',i,') = ',a(i)
! LCOV_EXCL_STOP
      endif
      enddo

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


module STEPSIZES
! Description:
!    Contains the subroutine DSTEPSIZE used to compute the initial step size for
!    the distinct formulations according to the reference.
!
! Reference:
!    Amato D., Baù G., and Bombardelli C., "Accurate numerical orbit propagation
!    of planetary close encounters". Submitted to MNRAS. 2016.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: dk,qk
implicit none

contains

function DSTEPSIZE(R,V,mu,DU,eqs,inSoI,tol)
! Description:
!    Choose the initial stepsize according to the formulation and the sign of the
!    orbital energy.
!
! Reference:
! [1] Battin R.H., "An Introduction to the Mathematics and Methods of
!     Astrodynamics", Revised Ed., AIAA, Reston, VA, USA. 1999.
! [2] Amato D., Baù G., and Bombardelli C., "Accurate numerical orbit
!    propagation of planetary close encounters". Submitted to MNRAS. 2016.
!
! ==============================================================================

use CONSTANTS, only: twopi,pi,smaEarth

! VARIABLES
! Arguments
real(qk),intent(in)  ::  R(1:3),V(1:3),mu,DU
real(dk),intent(in)  ::  tol
integer,intent(in)   ::  eqs
logical,intent(in)   ::  inSoI
! Function definition
real(dk)  ::  DSTEPSIZE
! Angular momentum, energy, sma, eccentricity, semi-parameter
real(dk)  ::  rn,vsq
real(dk)  ::  h(1:3),En,sma,ecc,p
! Intervals in true, Gudermannian, hyperbolic and hyperbolic mean anomalies
real(dk)  ::  fplus,zplus,Hplus,Nplus
real(dk)  ::  df,dH,dz,dN
! Elliptic and hyperbolic intervals
real(dk)  ::  rlim
real(dk)  ::  ell,hyp
integer,parameter :: nell = 100, nhyp = 600

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

! Compute energy and sma
rn = sqrt(dot_product(R,R))
vsq = dot_product(V,V)
En = 0.5_dk*vsq - mu/rn
sma = -0.5_dk*mu/En

if (En < 0._dk) then
  select case (eqs)
    case (-1,1)
      ell = twopi*sqrt(sma**3/mu)

    case (2)
      ell = twopi

    case (3)
      ell = twopi*sqrt(sma/mu)

    case (4)
      ! GDromo cannot integrate closed orbits.
      ell = 0._dk

  end select

  DSTEPSIZE = ell/nell

else
  if (inSoI) then
    ! Set rlim = 0.1 AU
    rlim = 0.1_dk*(smaEarth/DU)
  else
    rlim = 5._dk*(smaEarth/DU)
  end if

  ! Limiting true anomaly "fplus" corresponding to the point on the
  ! hyperbola at a distance "rlim" away from the primary, 0 <= fplus <= pi.
  h = [R(2)*V(3) - R(3)*V(2), R(3)*V(1) - R(1)*V(3), R(1)*V(2) - R(2)*V(1)]
  p = dot_product(h,h)/mu
  ecc = sqrt(1._dk - p/sma)
  fplus = acos((p/rlim - 1._dk)/ecc)
  df = 2._dk*fplus

  ! Limiting Gudermannian anomaly and interval of Gudermannian anomaly.
  zplus = 2._dk*atan(sqrt((ecc - 1._dk)/(ecc + 1._dk))*tan(0.5_dk*fplus))
  dz = 2._dk*zplus

  select case (eqs)
    case (-1,1)
      ! Limiting hyperbolic mean anomaly
      Nplus = ecc*tan(zplus) - log(tan(0.5_dk*zplus + 0.25_dk*pi))
      dN = 2._dk*Nplus

      hyp = sqrt((-sma)**3/mu)*dN

    case (2)
      hyp = dz

    case (3)
      ! EDromo cannot integrate open orbits.
      hyp = 0._dk

    case (4)
      ! Limiting hyperbolic anomaly
      Hplus = 2._dk*atanh(tan(0.5_dk*zplus))
      dH = 2._dk*Hplus

      hyp = dH

  end select

  DSTEPSIZE = hyp/nhyp

end if

DSTEPSIZE = -DSTEPSIZE/log10(tol)

end function DSTEPSIZE

end module STEPSIZES


PROGRAM p9

IMPLICIT NONE
INTERFACE
  REAL FUNCTION cube_root(x)
  END FUNCTION cube_root
END INTERFACE

REAL :: a,b
PRINT *, "type a number:"
READ *, a

b = cube_root(a)

PRINT *, "cube root of ", a, " is ", b

STOP
END PROGRAM p9

REAL FUNCTION cube_root(x)
  IMPLICIT NONE
  REAL :: x, log_x
  log_x = LOG(x)
  cube_root = EXP(log_x/3.0)
END FUNCTION cube_root


PROGRAM main
  !
  ! Description:
  !  Program to compute the Singular
  !  Value Decomposition of a pre-
  !  viously computed K-Matrix from
  !  the CRTM using the LAPACK subroutine
  !  DGESVD.
  !
  !  The SVD has the following form:
  !
  !  K = U * S * V'
  !
  ! Author: P. Stegmann
  ! Date: 2019-12-02
  !
  IMPLICIT NONE

  ! Data Dictionary:
  INTEGER(KIND=8), PARAMETER :: M = 92 ! Atmospheric pressure levels
  INTEGER(KIND=8), PARAMETER :: N = 5 ! AMSU-A channels
  REAL(KIND=8), DIMENSION(M,N) :: K    ! CRTM K-Matrix
  REAL(KIND=8), DIMENSION(M,N) :: s
  REAL(KIND=8), DIMENSION(M,M) :: u
  REAL(KIND=8), DIMENSION(N,N) :: v
  REAL(KIND=8), DIMENSION(MIN(M,N)) :: sdiag
  REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: work
  INTEGER(KIND=8) :: info
  INTEGER(KIND=8) :: lda
  INTEGER(KIND=8) :: ldu
  INTEGER(KIND=8) :: ldv
  CHARACTER :: jobu
  CHARACTER :: jobv
  INTEGER(KIND=4) :: lwork
  INTEGER(KIND=4) :: ii

  ! Instructions:

  ! Read in the K-Matrix for all AMSU-A channels:
  OPEN(66,FILE='output_K.txt',STATUS='OLD')
  READ(66,*) K
  CLOSE(66)

  ! Prepare DGESVD working arrays:
  lwork = MAX(3*MIN(M,N) + MAX(M,N), 5*MIN(M,N))
  ALLOCATE(work(1:lwork))
  jobu = 'A'
  jobv = 'A'
  lda = M
  ldu = M
  ldv = N
 !WRITE(*,*) K

  ! Compute SVD with LAPACK:
  CALL DGESVD(jobu,jobv,M,N,K,lda,sdiag,u,ldu,v,ldv, work,lwork,info)
  IF( info /= 0 ) THEN
    WRITE(*,*) 'Singular value decomposition failed!'
  END IF
  WRITE(*,*) 'INFO = ', info
  WRITE(*,*) 'The singular values are: '
  WRITE(*,*) sdiag
  DEALLOCATE(work)

  ! Result output:
  ! Singular values:
  OPEN(666,FILE='SVD_result.txt',STATUS='NEW')
  WRITE(666,*) sdiag
  CLOSE(666)

  !Singular vectors:
  OPEN(444,FILE='Singular_vectors.txt',STATUS='NEW')
  DO ii = 1, N
    WRITE(444,*) u(ii,:)
  END DO
  CLOSE(444)
END PROGRAM main


      function wq_semianalyt(tres, tdel, term_m, prock, cprev, cint)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This function solves a semi-analytic solution for the QUAL2E equations (cfr Befekadu Woldegiorgis).

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    xx          |none          |Exponential argument
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    tres        |days          |residence time in reach
!!    tdel        |days          |calculation time step
!!    term_m      |              |constant term in equation
!!    cprev       |mg/l          |concentration previous timestep
!!    cint        |mg/l          |incoming concentration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real, intent (in) :: tres
      real, intent (in) :: tdel
      real, intent (in) :: prock
      real, intent (in) :: term_m
      real, intent (in) :: cprev
      real, intent (in) :: cint
      real :: help1, help2, help3, help4, term1, term2, yy

      help1 = 1. / tres - prock
      help2 = exp(-tdel * help1)
      help3 = cint / tres + term_m
      help4 = help3 / help1
      term1 = cprev * help2
      term2 = help4 * (1. - help2)
      yy = term1 + term2
      wq_semianalyt = term1 + term2

      return
      end function

     function wq_k2m (t1, t2, tk, c1, c2)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This function solves a semi-analytic solution for the QUAL2E equations (cfr Befekadu Woldegiorgis).

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    xx          |none          |Exponential argument
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    tres        |days          |residence time in reach
!!    tdel        |days          |calculation time step
!!    term_m      |              |constant term in equation
!!    cprev       |mg/l          |concentration previous timestep
!!    cint        |mg/l          |incoming concentration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real, intent (in) :: t1
      real, intent (in) :: t2
      real, intent (in) :: tk
      real, intent (in) :: c1
      real, intent (in) :: c2
      real :: h1, h2, help, tm, h3

      h1 = wq_semianalyt (t1, t2, 0., 0., c1, c2)
      h2 = wq_semianalyt (t1, t2, 0., tk, c1, c2)
      help = exp(-t2 / t1)

      tm = (h2 - c1 * help) / (t1 * (1. - help)) - c2 / t1
      h3 = wq_semianalyt (t1, t2, tm, 0., c1, c2)
      wq_k2m = tm

      return
      end function


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

 subroutine basis(npt,nptperyear,f,g,yag,ydl)

!                                                                               !
! This subroutine computes sine and cosine basis functions                      !
! to be used in the subroutine SEASON. It also computes                         !
! polynomial basis functions to be used in the subroutine SAVGOL                !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 1/11-2005                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,npt,nptperyear
double precision :: pi,width,fact(7),x(5),t(npt),f(npt,5),g(npt,3)
double precision :: yag(2*nptperyear,7,2),ydl(2*nptperyear,5,2),arg(2*nptperyear)

!---- Generate sine basis -------------------------------------------------------

pi = 2.d0*asin(1.d0)
t = dble((/(i,i=1,npt)/))/dble(nptperyear)

f(:,1) = 1.d0
f(:,2) = sin(2.d0*pi*t)
f(:,3) = cos(2.d0*pi*t)
f(:,4) = sin(4.d0*pi*t)
f(:,5) = cos(4.d0*pi*t)

!---- Generate polynomial basis -------------------------------------------------

g(:,1) = 1.d0
g(:,2) = dble((/(i,i=1,npt)/))
g(:,3) = dble((/(i,i=1,npt)/))**2.d0

!---- Generate asymmetric gaussian basis ---------------------------------------

width = nptperyear/4.d0

t = dble((/(i,i=1,npt)/))

fact(1:7) = (/ 0.2d0, 0.4d0, 0.7d0, 1.d0, 1.3d0, 1.7d0, 2.1d0 /)
x(1) = nptperyear + 0.5d0
x(3) = 3.d0
x(5) = 3.d0

do i = 1,7
  do j = 1,2
    x(2) = width*fact(i)/(j*log(2.d0)**0.25d0)
	x(4) = x(2)
	arg = (/ ((x(1)-t(1:nptperyear))/x(2))**x(3), &
	              ((t(nptperyear+1:2*nptperyear)-x(1))/x(4))**x(5) /)
    yag(:,i,j) = exp(-arg)
  end do
end do

!---- Generate double logistic basis -------------------------------------------

fact(1:5) = (/ 0.3d0, 0.6d0, 1.d0, 1.5d0, 1.9d0 /)
x(2) = nptperyear/20.d0
x(4) = x(2)

do i = 1,5
  do j = 1,2
    x(1) = nptperyear - width*fact(i)/j
	x(3) = nptperyear + width*fact(i)/j
	ydl(:,i,j) = 1.d0/(1.d0 + exp((x(1)-t(1:2*nptperyear))/x(2))) &
	                - 1.d0/(1.d0 + exp((x(3)-t(1:2*nptperyear))/x(4)))
  end do
end do

end subroutine basis


!***************************************************************
!*      Purpose: This program computes the spherical Bessel    *
!*               functions yn(x) and yn'(x) using subroutine   *
!*               SPHY                                          *
!*      Input :  x --- Argument of yn(x) ( x > 0 )             *
!*               n --- Order of yn(x) ( n = 0 to 250 )         *
!*      Output:  SY(n) --- yn(x)                               *
!*               DY(n) --- yn'(x)                              *
!*      Example:   x = 10.0                                    *
!*                 n          yn(x)               yn'(x)       *
!*               --------------------------------------------  *
!*                 0     .8390715291D-01    -.6279282638D-01   *
!*                 1     .6279282638D-01     .7134858763D-01   *
!*                 2    -.6506930499D-01     .8231361788D-01   *
!*                 3    -.9532747888D-01    -.2693831344D-01   *
!*                 4    -.1659930220D-02    -.9449751377D-01   *
!*                 5     .9383354168D-01    -.5796005523D-01   *
!* ----------------------------------------------------------- *
!* REFERENCE: "Fortran Routines for Computation of Special     *
!*             Functions,                                      *
!*             jin.ece.uiuc.edu/routines/routines.html".       *
!*                                                             *
!*                          F90 Release By J-P Moreau, Paris.  *
!*                                  (www.jpmoreau.fr)          *
!***************************************************************
!        PROGRAM MSPHY
!        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!        DIMENSION SY(0:250),DY(0:250)
!        WRITE(*,*)'Please enter n and x '
!        READ(*,*)N,X
!        WRITE(*,30)N,X
!        IF (N.LE.10) THEN
!           NS=1
!        ELSE
!           WRITE(*,*)'Please enter order step Ns'
!           READ(*,*)NS
!        ENDIF
!        CALL SPHY(N,X,NM,SY,DY)
!        WRITE(*,*)
!        WRITE(*,*)'  n          yn(x)               yn''(x)'
!        WRITE(*,*)'--------------------------------------------'
!        DO 10 K=0,NM,NS
!10         WRITE(*,20)K,SY(K),DY(K)
!20      FORMAT(1X,I3,2D20.10)
!30      FORMAT(3X,6HNmax =,I3,',     ',2Hx=,F6.1)
!        END

        MODULE msphy
        CONTAINS

        SUBROUTINE SPHY(N,X,NM,SY,DY)

!       ======================================================
!       Purpose: Compute spherical Bessel functions yn(x) and
!                their derivatives
!       Input :  x --- Argument of yn(x) ( x ò 0 )
!                n --- Order of yn(x) ( n = 0,1,úúú )
!       Output:  SY(n) --- yn(x)
!                DY(n) --- yn'(x)
!                NM --- Highest order computed
!       ======================================================

        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION SY(0:N),DY(0:N)
        NM=N
        IF (X.LT.1.0D-60) THEN
           DO 10 K=0,N
              SY(K)=-1.0D+300
10            DY(K)=1.0D+300
           RETURN
        ENDIF
        SY(0)=-DCOS(X)/X
        SY(1)=(SY(0)-DSIN(X))/X
        F0=SY(0)
        F1=SY(1)
        DO 15 K=2,N
           F=(2.0D0*K-1.0D0)*F1/X-F0
           SY(K)=F
           IF (DABS(F).GE.1.0D+300) GO TO 20
           F0=F1
15         F1=F
20      NM=K-1
           DY(0)=(DSIN(X)+DCOS(X)/X)/X
           DO 25 K=1,NM
25            DY(K)=SY(K-1)-(K+1.0D0)*SY(K)/X
        RETURN
        END

        END MODULE

!end of file msphy.f90


c
c A collection of functions to compute various moist thermodynamic quantities
c
c Rodrigo Caballero Augi 2000 (rca@dcess.ku.dk)
c
c References: Bolton (1980), Mon. Wea. Rev. 108, 1046-1053
c             Bohren and Albrecht (1998), "Atmospheric Thermodynamics"
c             Flatau et al (1992), J. App. Met . 31, 1507-1513.
c
c------------------------------------------------------------------------
      real*8 function tdew(p,q)
c
c compute dew point temperature tdew  [K]
c at pressure p [mb] and specific humidity q [g/kg]
c Use Bolton eqn (11)
c
      real*8 p,q

      Rv  = 461.5
      Rd  = 287.04
      eps = Rd/Rv
      r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]
      es = p*r/(r+eps*1.e3)   ! vapor pressure of water vap
c
      tdew = (243.5*log(es)-440.8)/(19.48-log(es))+273.15
c
      end
c------------------------------------------------------------------------
      real*8 function tstar(t,p,q)
c
c compute saturation point temperature tstar [K]
c (i.e. temperature at lifting condensation level)
c given temperature t [K], pressure p [mb], specific humidity q [g/kg].
c Use Bolton eqn (12)
c
      real*8 t,p,q
      external theta

      Rv  = 461.5
      Rd  = 287.04
      eps = Rd/Rv
      oneoverk = 3.504 ! Cp/Rd
      r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]
c
      th=theta(t,p,q)
      c=log(r/(r+eps*1.e3)/th**oneoverk/1.7743e-8)
      tstar=217.8*c/(12.992-c) + 273.15
c
      end
c------------------------------------------------------------------------
      real*8 function theta(t,p,q)
c
c compute potential temperature  theta [K]
c given temperature t [K], pressure p [mb], specific humidity q [g/kg].
c Use Bolton eqn (7)
c
      ak=0.2854 ! R_(dry air)/Cp
      r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]
c
      theta=t*(1000./p)**( ak*(1.-0.28e-3*r) )
c
      end
c------------------------------------------------------------------------
      real*8 function thetae(t,p,q)
c
c compute equivalent potential temperature thetae [K]
c given temperature t [K], pressure p [mb], specific humidity q [g/kg].
c Use Bolton eqn (38)
c
      real*8 t,p,q
      external theta,tstar

      th=theta(t,p,q)
      ts=tstar(t,p,q)
      r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]

      thetae = th * exp( (3.376/ts-0.00254)*r*(1.+0.81e-3*r) )
c
      end
c------------------------------------------------------------------------
      real*8 function es(t)
c
c Compute saturation partial pressure of water vapor es [mb]
c at temperature t [K].
c Use Bohren+Albrecht p. 198
c
      real*8 t
      t0m1=1./273.15
c
      es = 6.11 * exp( 6808.*(t0m1-1./t)-5.09*log(t*t0m1) )
c
      end
c------------------------------------------------------------------------
      real*8 function esflatau(t,i)
c
c Compute saturation partial pressure of water vapor es [mb]
c at temperature t [K].
c Use 8th oRder polynomial fit of Flatau et al (1992), Table 4
c
c i=1 => vapour pressure over water (valid -85C < t < 70C)
c i=2 => vapour pressure over ice (valid -90C < t < 0C)
c
      real*8 t,a(9,2)
      data a /
     &     6.11239921,    0.443987641,  0.142986287e-1,  0.264847430e-3,
     & 0.302950461e-5, 0.206739458e-7, 0.640689451e-10,-0.952447341e-13,
     & -0.976195544e-15,
     &     6.11147274,    0.503160820, 0.188439774e-1,  0.420895665e-3,
     & 0.615021634e-5, 0.602588177e-7, 0.385852041e-9, 0.146898966e-11,
     & 0.252751365e-14 /
c
      t0=273.15
c
      esflatau=a(9,i)
      do n=8,1,-1
      esflatau=esflatau*(t-t0) + a(n,i)
      enddo
c
      end
c------------------------------------------------------------------------
      real*8 function qs(t,p)
c
c Compute saturation specific humidity qs [g/kg]
c at temperature t [K] and pressure p [mb]
c use Bohren+Albrecht p. 186
c
      real*8 t,p
      external es

      Rv=461.5
      Rd=287.04
      eps=Rd/Rv
c
      ess=es(t)
      qs=eps*ess/p *1.e3
c
      end
c------------------------------------------------------------------------
      real*8 function qsflatau(t,p,i)
c
c Compute saturation specific humidity qs [g/kg]
c at temperature t [K] and pressure p [mb]
c Use 8th oRder polynomial fit of Flatau et al (1992), Table 4
c
c i=1 => sat. mix. rat. over water (valid -85C < t < 70C)
c i=2 => sat. mix. rat. over ice (valid -90C < t < 0C)
c
      real*8 t,p
      Rv=461.5
      Rd=287.04
      eps=Rd/Rv*1.e3
c
      es=esflatau(t,i)
      qsflatau=eps*es/p
c
      end
c------------------------------------------------------------------------
      real*8 function ws(t,p)
c
c Compute saturation water vapor mass mixing ratio  ws [g/kg]
c at temperature t [K] and pressure p [mb]
c use Bohren+Albrecht p. 186
c
      real*8 t,p
      external es

      Rv=461.5
      Rd=287.04
      eps=Rd/Rv
c
      ess=es(t)
      ws=eps*ess/(p-ess) *1.e3
c
      end
c------------------------------------------------------------------------
      real*8 function wsflatau(t,p,i)
c
c Compute saturation water vapor mass mixing ratio ws [g/kg]
c at temperature t [K] and pressure p [mb]
c Use 8th oRder polynomial fit of Flatau et al (1992), Table 4
c
c i=1 => sat. mix. rat. over water (valid -85C < t < 70C)
c i=2 => sat. mix. rat. over ice (valid -90C < t < 0C)
c
      real*8 t,p
      Rv=461.5
      Rd=287.04
      eps=Rd/Rv
c
      es=esflatau(t,i)
      wsflatau=eps*es/(p-es) * 1.e3
c
      end
c------------------------------------------------------------------------
      real*8 function pdryadiab(t,theta,q)
c
c compute pressure level pdryadiab [mb] at which temperature is t [K]
c on the dry (i.e. unsaturated) adiabat identified by
c potential temperature theta [K] and mixing ratio q [g/kg].
c Use Bolton eqn (7)
c
      oneoverk=3.504 ! Cp/R_(dry air)
      r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]
c
      pdryadiab=1000.*(t/theta)**( oneoverk/(1.-0.28e-3*r) )
c
      end
c------------------------------------------------------------------------
      real*8 function tdryadiab(theta,p,q)
c
c Compute temperature [K] at level p [mb]
c on the dry (i.e. unsaturated) adiabat identified by
c potential temperature theta [K] and mixing ratio q [g/kg].
c Use Bolton eqn (7)
c
      real*8 theta,p,q
      ak=0.2854 ! R_(dry air)/Cp
      r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]
c
      tdryadiab=theta*(1000./p)**( -ak*(1.-0.28e-3*r) )
c
      end
c------------------------------------------------------------------------
      real*8 function tmoistadiab(thetaes,p)
c
c Compute temperature [K] at level p [mb]
c on the moist (i.e. saturated) pseudo-adiabat identified
c by saturation equivalent potential temperature thetaes [K].
c Do it by varying t until
c delthetae := thetaes - thetae(t,p,qs(t,p)) = 0
c Use Bolton, eqn (43)
c
      external delthetae,ridder
      real*8 thetaes,p,params(10)
      logical success
c
      params(1)=thetaes
      params(2)=p
c
c   bracket zero crossing to within 2K
      tmin=50.
      tmax=51.
      f1=delthetae(params,tmin)
      f2=delthetae(params,tmax)
 1    continue
      if(tmax.gt.500.) goto 2
      if(f1*f2.lt.0.) goto 3
      tmax=tmax+1.
      f2=delthetae(params,tmax)
      goto 1
 2    stop 'tmoistadiab(): cannot bracket root'
 3    continue
      tmin=tmax-2.
c
c  refine estimate using Ridder's method
      tmoistadiab=ridder(success,delthetae,params,tmin,tmax,0.0001)
      if (.not.success) stop 'tmoistadiab(): root not bracketed'
c
      end
c-----------------------------------------------------------------------
      real*8 function delthetae(params,t)
      external qs,thetae
      real*8 t,params(10)

      thetaes   = params(1)
      p         = params(2)
      q         = qs(t,p)
      delthetae = thetaes - thetae(t,p,q)

      end
c------------------------------------------------------------------------
      real*8 function ridder(success,func,params,xmin,xmax,acc)
c
c Find zero crossing of func(x) in range xmin < x < xmax with accuracy acc
c Use Ridder's method (Numerical Recipes)
c
      external func
      real*8 params(10),xmin,xmax,acc
      logical success
c
      maxit=60  ! max number of iterations
      success=.true.
c
      fl=func(params,xmin)
      fh=func(params,xmax)
c
      if((fl.gt.0..and.fh.lt.0.).or.(fl.lt.0..and.fh.gt.0.))then
        xl=xmin
        xh=xmax
        ridder=-1.11e30
        do 11 j=1,maxit
          xm=0.5*(xl+xh)
          fm=func(params,xm)
          s=sqrt(fm**2-fl*fh)
          if(s.eq.0.)return
          xnew=xm+(xm-xl)*(sign(1.,fl-fh)*fm/s)
          if (abs(xnew-ridder).le.acc) return
          ridder=xnew
          fnew=func(params,ridder)
          if (fnew.eq.0.) return
          if(sign(fm,fnew).ne.fm) then
            xl=xm
            fl=fm
            xh=ridder
            fh=fnew
          else if(sign(fl,fnew).ne.fl) then
            xh=ridder
            fh=fnew
          else if(sign(fh,fnew).ne.fh) then
            xl=ridder
            fl=fnew
          else
            stop 'never get here in ridder'
          endif
          if(abs(xh-xl).le.acc) return
11      continue
        stop 'ridder exceed maximum iterations maxit'
      else if (fl.eq.0.) then
        ridder=xmin
      else if (fh.eq.0.) then
        ridder=xmax
      else
        success=.false.
      endif
c
      end


program test
	use constants
	use mylib
	implicit none

	integer, parameter :: N = 1000
	real, dimension(N) :: x
	integer :: i=0

	call linspace(0., 10*PI, N, x)
	open(unit=10, file="data.dat", status="replace", action="write")
	do i=1,N
		write(10,*) x(i), (sin(10*x(i)) + sin(15*x(i)))
	enddo
	close(10)
end program test


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c     this code tests subroutine gaqd for computing
c     the Gauss Legendre points and weights in file gaqd.f
c     It tests only the april 2002 version and not the
c     older version in file gaqd.old.f
c     gauss points and weights are computed using newtons method
c     with equally spaced points as first guess. Points are
c     computed as theta_i where x_i = cos(theta_i)
c     the method is discussed in "On computing the Gauss_Legendre
c     points and weights" by Paul N Swarztrauber, accepted for
c     publication in the SIAM journal of scientific computing.
c                         April 2002
c
      program testint
      parameter (nlat=63)
      double precision theta(nlat),wts(nlat),work(nlat+2),
     1                dtheta(nlat),dwts(nlat),dw(nlat+1)
      double precision dwmx,tmax,dwmax,dtmax
      dimension stheta(nlat),swts(nlat),swork(nlat+1)
      dimension diff(nlat),t1(2),t2(2)
      double precision sumw
c
      lwork = nlat+1
      hold = etime(t1)
      hold = t1(1)
      call gsqd(nlat,theta,wts,work,lwork,ierror)
      tdoub = etime(t1)
      tdoub = t1(1)-hold
      if(ierror .ne. 0) write(6,4) ierror
 4    format(' ierror=',i5)
      write(*,739) tdoub
 739  format(' tdoub ',1pe15.6)
c
c     compare double with double
c
      ldw = nlat+2
      hold = etime(t1)
      hold = t1(1)
      call gaqd(nlat,dtheta,dwts,dw,ldw,ierror)
      tdoub = etime(t1)
      tdoub = t1(1)-hold
      if(ierror .ne. 0) write(6,30) ierror
 30   format(' ierror=',i5)
      write(*,31) tdoub
 31   format(' tdoub gaqd',1pe15.6)
c
      dwmx = 0.0d0
      tmax = 0.0d0
      dwmax = 0.0d0
      dtmax = 0.0d0
      ido = (nlat+1)/2
      do 32 i=1,ido
      dtmax = max(dtmax,dabs(theta(i)-dtheta(i)))
      dwmax = max(dwmax,dabs(wts(i)-dwts(i)))
      tmax = max(tmax,abs(theta(i)))
      dwmx = max(dwmx,abs(wts(i)))
 32   continue
      dtmax = dtmax/tmax
      dwmax = dwmax/dwmx
      write(*,33) nlat,dtmax,dwmax
 33   format(' nlat',i6,'  points ',1pd15.6,' weights ',d15.6)
c
      sumw = 0.
      do i=1,nlat
      sumw = sumw+wts(i)
      end do
      write(*,638) sumw
 638  format('  sumw ',1pd39.30)
c      if(0.eq.0) go to 671
      hold = etime(t2)
      hold = t2(1)
      lwork = nlat+2
      call sgaqd(nlat,stheta,swts,swork,lwork,ierror)
      tsing = etime(t2)
      tsing = t2(1)-hold
      if(ierror .ne. 0) write(6,5) ierror
 5    format(' iserror=',i5)
      sums = 0.
      do i=1,nlat
      sums = sums+swts(i)
      end do
      write(*,636) sums
 636  format('  sums ',1pe24.15)
      dmax = 0.
      wmax = 0.
      rmax = 0.
      ido = (nlat+1)/2
      do 6 i=1,ido
      diff(i) = wts(i)-swts(i)
      dmax = max(dmax,abs(diff(i)))
      wmax = max(wmax,abs(swts(i)))
      rerr = abs(diff(i)/swts(i))
      if(rerr.gt.rmax) then
      rmax = rerr
      irm = i
      end if
c      if(i.lt.121) write(*,27) wts(i),swts(i),rerr
 27   format(' wts ',1pd15.6,' swts ',e15.6,' rpter ',e15.6)
 6    continue
c      write(*,7) (diff(i),i=nlat-25,nlat)
 7    format(' diff in weights'/(1p8e10.3))
      dmax = dmax/wmax
      write(*,9) nlat,irm,dmax,rmax
 9    format(' weights: nlat ',i6,' irele ',i6,
     1    ' dmax ',1pe15.6,' rmax ',1pe15.6)
      dmax = 0.
      pmax = 0.
      rmax = 0.
      do 10 i=1,ido
      diff(i) = theta(i)-stheta(i)
      dmax = max(dmax,abs(diff(i)))
      pmax = max(pmax,abs(stheta(i)))
      rerr = abs(diff(i)/stheta(i))
      if(rerr.gt.rmax) then
      rmax = rerr
      irm = i
      end if
 10   continue
c      write(*,11) (diff(i),i=nlat-25,nlat)
 11   format(' diff in points'/(1p8e10.3))
      dmax = dmax/pmax
      write(*,12) nlat,irm,dmax,rmax
 12   format(' points:  nlat ',i6,' irele ',i6,
     1    ' dmax ',1pe15.6,' rmax ',1pe15.6)
      dmax = 0.
      do 110 i=1,nlat
      diff(i) = dcos(theta(i))-cos(stheta(i))
      dmax = max(dmax,abs(diff(i)))
 110  continue
c      write(*,111) (diff(i),i=nlat-25,nlat)
 111  format(' diff in points'/(1p8e10.3))
      write(*,112) dmax
 112  format(' max difference in mu',1pe15.6)
      write(*,1) nlat,tsing,tdoub
 1    format(' nlat',i6,' tsing',1pe15.6,' tdoub',e15.6)
 671  end
c
c     a single precision version of gaqd.
c     gauss points and weights are computed using newtons method
c     with equally spaced points as first guess. Points are
c     computed as theta_i where x_i = cos(theta_i)
c     the method is discussed in "On computing the Gauss_Legendre
c     points and weights" by Paul N Swarztrauber, accepted for
c     publication in the SIAM journal of scientific computing.
c                         April 2002
c
      subroutine gsqd(nlat,theta,wts,dwork,ldwork,ierror)
c
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 2001 by ucar                 .
c  .                                                             .
c  .       university corporation for atmospheric research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         spherepack 3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c     subroutine gsqd computes the nlat gaussian colatitudes and weights
c     in double precision. The colatitudes are in radians and lie in the
c     in the interval (0,pi).
c
c     input parameters
c
c     nlat    the number of gaussian colatitudes in the interval (0,pi)
c             (between the two poles).  nlat must be greater than zero.
c
c     dwork   a double precision temporary work space.
c
c     ldwork  the length of the work space  in the routine calling gsqd
c             ldwork must be at least nlat+1.
c
c     output parameters
c
c     theta   a double precision vector of length nlat containing the
c             nlat gaussian colatitudes on the sphere in increasing radians
c             in the interval (0,pi).
c
c     wts     a double precision vector of length nlat containing the
c             nlat gaussian weights.
c
c     ierror = 0 no errors
c            = 1 if ldwork.lt.nlat+1
c            = 2 if nlat.le.0
c
c  *****************************************************************
c
      dimension dwork(nlat+1),theta(nlat),wts(nlat)
      double precision pis2,x,theta,wts,dwork
      ierror = 1
c
c     check work space length
c
      if (ldwork.lt.nlat+1) return
      ierror = 2
      if (nlat.le.0) return
      ierror = 0
c
c     compute weights and points analytically when nlat=1,2
c
      if (nlat.eq.1) then
      theta(1) = dacos(0.0d0)
      wts(1) = 2.d0
      return
      end if
      if (nlat.eq.2) then
      x = dsqrt(1.0d0/3.0d0)
      theta(1) = dacos(x)
      theta(2) = dacos(-x)
      wts(1) = 1.d0
      wts(2) = 1.d0
      return
      end if
c
c     compute points
c
      call gsqd1(nlat,theta,dwork)
c
c     compute weights
c
      call egwts(nlat,theta,wts,dwork)
c
c     extend points and weights via symmetries
c
      pis2 = 4.0d0*datan(1.0d0)
      ns2 = nlat/2
      do i=1,ns2
      wts(nlat-i+1) = wts(i)
      theta(nlat-i+1) = pis2-theta(i)
      end do
      return
      end
c
      subroutine gsqd1(nlat,theta,cp)
      double precision  theta((nlat+1)/2),cp(nlat/2+1)
      double precision pi,pis2,dtheta,dthalf,
     1  cmax,dcor,pb,dpb,sgnd,zero,zlast
c
      eps = sqrt(dzeps(1.0d0))
      eps = eps*sqrt(eps)
      pis2 = 2.0d0*datan(1.0d0)
      pi = pis2+pis2
      theta(1) = pis2
      if(nlat.eq.1) go to 30
      ns2 = nlat/2
      nhalf = (nlat+1)/2
c
      call dlfcz (nlat,cp)
c
c      check fourier-legendre coefficients
c
      sum = 0.
      do i=1,ns2+1
      sum = sum+cp(i)
      end do
      sum = sum/ns2
c      write(*,689)  sum
 689  format(' check on dble f-l coefficients ',1pe15.6)
c
      dtheta = pis2/nhalf
      dthalf = dtheta/2.0d0
      cmax = .2d0*dtheta
      if(mod(nlat,2).ne.0) then
      theta(nhalf) = pis2
      zero = pis2-dtheta
      nix = nhalf-1
      else
      zero = pis2-dthalf
      nix = nhalf
      end if
 9    it = 0
 10   it = it+1
      zlast = zero
c
c     newton iterations to convergence
c
      call lft (0,nlat,zero,cp,pb)
      call dlft (0,nlat,zero,cp,dpb)
      dcor = pb/dpb
      sgnd = 1.0d0
      if(dcor .ne. 0.0d0) sgnd = dcor/dabs(dcor)
c      write(*,2) nix,zero,theta(nix),dcor,cmax,sgnd
 2    format(i7,1p5d15.6)
      dcor = sgnd*min(dabs(dcor),cmax)
      zero = zero-dcor
      if(dabs(zero-zlast).gt.eps*dabs(zero)) go to 10
      theta(nix) = zero
      nix = nix-1
      if(nix.eq.0) go to 30
      if(nix.eq.nhalf-1)  zero = 3.0d0*zero-pi
      if(nix.lt.nhalf-1)  zero = zero+zero-theta(nix+2)
      go to 9
 30   return
      end
      subroutine egwts(n,theta,wts,work)
c
c     computes gauss weights as described in swarztrauber
c     and spotz, generalized harmonic transforms
c
      double precision theta(n),wts(n),work(n+1)
c
      call egwts1(n,theta,wts,work,work(n/2+2))
      return
      end
      subroutine egwts1(n,theta,wts,dcp,cp)
      double precision theta((n+1)/2),wts((n+1)/2),cp((n-1)/2+1),
     1                 dcp(n/2+1),fn,sqnn,pb,dpb
      fn = n
      sqnn = dsqrt((fn+fn-1)*(fn+fn+1))
      call dlfcz (n-1,cp)
      call dlfcz (n,dcp)
      nhalf = (n+1)/2
      do i=1,nhalf
      call lft (0,n-1,theta(i),cp,pb)
      call dlft (0,n,theta(i),dcp,dpb)
      wts(i) = -sqnn*dsin(theta(i))/(fn*pb*dpb)
      end do
      return
      end
      subroutine lfc (m,n,cp)
c
      double precision cp,fnum,fden,fnmh,a1,b1,c1,cp2,fnnp1,fnmsq,fk,
     1       t1,t2,pm1,sc10,sc20,sc40
      dimension       cp(n/2+1)
      parameter (sc10=1024.d0)
      parameter (sc20=sc10*sc10)
      parameter (sc40=sc20*sc20)
c
      cp(1) = 0.
      ma = iabs(m)
      if(ma .gt. n) return
      if(n-1) 2,3,5
    2 cp(1) = dsqrt(2.d0)
      return
    3 if(ma .ne. 0) go to 4
      cp(1) = dsqrt(1.5d0)
      return
    4 cp(1) = dsqrt(.75d0)
      if(m .eq. -1) cp(1) = -cp(1)
      return
    5 if(mod(n+ma,2) .ne. 0) go to 10
      nmms2 = (n-ma)/2
      fnum = n+ma+1
      fnmh = n-ma+1
      pm1 = 1.d0
      go to 15
   10 nmms2 = (n-ma-1)/2
      fnum = n+ma+2
      fnmh = n-ma+2
      pm1 = -1.d0
c      t1 = 1.
c      t1 = 2.d0**(n-1)
c      t1 = 1.d0/t1
 15   t1 = 1.d0/sc20
      nex = 20
      fden = 2.d0
      if(nmms2 .lt. 1) go to 20
      do 18 i=1,nmms2
      t1 = fnum*t1/fden
      if(t1 .gt. sc20) then
      t1 = t1/sc40
      nex = nex+40
      end if
      fnum = fnum+2.
      fden = fden+2.
   18 continue
   20 t1 = t1/2.d0**(n-1-nex)
      if(mod(ma/2,2) .ne. 0) t1 = -t1
      t2 = 1.
      if(ma .eq. 0) go to 26
      do 25 i=1,ma
      t2 = fnmh*t2/(fnmh+pm1)
      fnmh = fnmh+2.
   25 continue
   26 cp2 = t1*dsqrt((n+.5d0)*t2)
      fnnp1 = n*(n+1)
      fnmsq = fnnp1-2.d0*ma*ma
      l = (n+1)/2
      if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1
      cp(l) = cp2
      if(m .ge. 0) go to 29
      if(mod(ma,2) .ne. 0) cp(l) = -cp(l)
   29 if(l .le. 1) return
      fk = n
      a1 = (fk-2.)*(fk-1.)-fnnp1
      b1 = 2.*(fk*fk-fnmsq)
      cp(l-1) = b1*cp(l)/a1
   30 l = l-1
      if(l .le. 1) return
      fk = fk-2.
      a1 = (fk-2.)*(fk-1.)-fnnp1
      b1 = -2.*(fk*fk-fnmsq)
      c1 = (fk+1.)*(fk+2.)-fnnp1
      cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1
      go to 30
      end
      subroutine lft (m,n,theta,cp,pb)
      double precision cp(*),pb,theta,cdt,sdt,cth,sth,chh
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      nmod=mod(n,2)
      mmod=mod(m,2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo=n/2
      pb = .5*cp(1)
      if(n .eq. 0) return
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c     pb = pb+cp(k+1)*dcos(2*k*theta)
      pb = pb+cp(k+1)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      return
c
c     n even, m odd
c
    4 kdo = n/2
      pb = 0.
      cth = cdt
      sth = sdt
      do 180 k=1,kdo
c     pb = pb+cp(k)*dsin(2*k*theta)
      pb = pb+cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  180 continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c     pb = pb+cp(k)*dcos((2*k-1)*theta)
      pb = pb+cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      return
c
c     n odd, m odd
c
   14 kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 200 k=1,kdo
c     pb = pb+cp(k)*dsin((2*k-1)*theta)
      pb = pb+cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  200 continue
      return
      end
      subroutine dlft (m,n,theta,cp,pb)
c
c     computes the derivative of pmn(theta) with respect to theta
c
      dimension cp(1)
      double precision cp,pb,theta,cdt,sdt,cth,sth,chh
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      nmod=mod(n,2)
      mmod=mod(abs(m),2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo=n/2
      pb = 0.d0
      if(n .eq. 0) return
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c     pb = pb+cp(k+1)*dcos(2*k*theta)
      pb = pb-2.d0*k*cp(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      return
c
c     n even, m odd
c
    4 kdo = n/2
      pb = 0.
      cth = cdt
      sth = sdt
      do 180 k=1,kdo
c     pb = pb+cp(k)*dsin(2*k*theta)
      pb = pb+2.d0*k*cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  180 continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c     pb = pb+cp(k)*dcos((2*k-1)*theta)
      pb = pb-(2.d0*k-1)*cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      return
c
c     n odd, m odd
c
   14 kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 200 k=1,kdo
c     pb = pb+cp(k)*dsin((2*k-1)*theta)
      pb = pb+(2.d0*k-1)*cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  200 continue
      return
      end
      subroutine dlfcz(n,cp)
c
c     computes the fourier coefficients of the legendre
c     polynomials. n is the degree and integer(n/2+1)
c     coefficients are returned in cp
c
      double precision cp(n/2+1)
      double precision cn,t1,t2,t3,t4,coef,fi
c
      cn = 2.0d0
       write(*,9) cn
 9     format(' check1 on dble cn ',1pd20.11)
      if(n.gt.0) then
      ic = 0
      fi = 0.0d0
      do i=1,n
      fi = fi+2.0d0
      cn = (1.0d0-1.0d0/fi**2)*cn
      if(dabs(cn).gt. 5.0d0.and.ic.eq.0) then
      ic = 1
      write(*,7) i,cn
 7    format('  i ',i7,' check3 on cn',1pd15.6)
      end if
      end do
      end if
       write(*,8) cn
 8     format(' check2 on dble cn ',1pd20.11)
      cn = dsqrt(cn)
      ncp = n/2+1
      t1 = -1.0d0
      t2 = n+1.0d0
      t3 = 0.
      t4 = n+n+1.0d0
      cp(ncp) = cn
      coef = 1.0d0
       write(*,11) cn
 11    format(' check on dble cn ',1pd20.11)
c      do j = ncp-1,1,-1
      j = ncp
 10   j = j-1
      t1 = t1+2.0d0
      t2 = t2-1.0d0
      t3 = t3+1.0d0
      t4 = t4-2.0d0
      coef = (t1*t2)/(t3*t4)*coef
      cp(j) = coef*cn
      if(j.gt.1) go to 10
c      end do
      return
      end
c
      subroutine sgaqd(nlat,theta,wts,w,lwork,ierror)
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 2001 by ucar                 .
c  .                                                             .
c  .       university corporation for atmospheric research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c                             February 2002
c
c     gauss points and weights are computed using the fourier-newton
c     described in "on computing the points and weights for
c     gauss-legendre quadrature", paul n. swarztrauber, siam journal
c     on scientific computing that has been accepted for publication.
c     This routine is faster and more accurate than older program
c     with the same name.
c
c     subroutine sgaqd computes the nlat gaussian colatitudes and
c     weights in single precision. the colatitudes are in radians
c     and lie in the interval (0,pi).
c
c     input parameters
c
c     nlat    the number of gaussian colatitudes in the interval (0,pi)
c             (between the two poles).  nlat must be greater than zero.
c
c     w       unused variable that permits a simple exchange with the
c             old routine with the same name in spherepack.
c
c     lwork   unused variable that permits a simple exchange with the
c             old routine with the same name in spherepack.
c
c     output parameters
c
c     theta   a vector of length nlat containing the nlat gaussian
c             colatitudes on the sphere in increasing radians
c             in the interval (0,pi).
c
c     wts     a vector of length nlat containing the
c                   nlat gaussian weights.
c
c     ierror = 0 no errors
c            = 1 if nlat.le.0
c
c  *****************************************************************
c
      dimension theta(nlat),wts(nlat)
c
c     check work space length
c
      ierror = 1
      if (nlat.le.0) return
      ierror = 0
c
c     compute weights and points analytically when nlat=1,2
c
      if (nlat.eq.1) then
      theta(1) = acos(0.0d0)
      wts(1) = 2.0
      return
      end if
      if (nlat.eq.2) then
      x = sqrt(1.0/3.0)
      theta(1) = acos(x)
      theta(2) = acos(-x)
      wts(1) = 1.0
      wts(2) = 1.0
      return
      end if
      eps = sqrt(zeps(1.0))
      eps = eps*sqrt(eps)
      pis2 = 2.0*atan(1.0)
      pi = pis2+pis2
      mnlat = mod(nlat,2)
      ns2 = nlat/2
      nhalf = (nlat+1)/2
      idx = ns2+2
c
      call lfcz (nlat,cz,theta(ns2+1),wts(ns2+1))
c
      dtheta = pis2/nhalf
      dthalf = dtheta/2.0
      cmax = .2*dtheta
c
c     estimate first point next to theta = pi/2
c
      if(mnlat.ne.0) then
      zprev = pis2
      zero = pis2-dtheta
      nix = nhalf-1
      else
      zero = pis2-dthalf
      nix = nhalf
      end if
      itmax = 0
 9    it = 0
 10   it = it+1
      zlast = zero
c
c     newton iterations
c
      call slpdp (nlat,zero,cz,theta(ns2+1),wts(ns2+1),pb,dpb)
      dcor = pb/dpb
      sgnd = 1.0
      if(dcor .ne. 0.0) sgnd = dcor/abs(dcor)
      dcor = sgnd*min(abs(dcor),cmax)
      zero = zero-dcor
      if(abs(zero-zlast).gt.eps*abs(zero)) go to 10
      theta(nix) = zero
      zhold = zero
c      wts(nix) = (nlat+nlat+1)/(dpb*dpb)
c
c     yakimiw's formula permits using old pb and dpb
c
      wts(nix) = (nlat+nlat+1)/(dpb+pb*cos(zlast)/sin(zlast))**2
      nix = nix-1
      if(nix.eq.0) go to 30
      if(nix.eq.nhalf-1)  zero = 3.0*zero-pi
      if(nix.lt.nhalf-1)  zero = zero+zero-zprev
      zprev = zhold
      go to 9
c
c     extend points and weights via symmetries
c
 30   if(mnlat.ne.0) then
      theta(nhalf) = pis2
      call slpdp (nlat,pis2,cz,theta(ns2+1),wts(ns2+1),pb,dpb)
      wts(nhalf) = (nlat+nlat+1)/(dpb*dpb)
      end if
      do i=1,ns2
      wts(nlat-i+1) = wts(i)
      theta(nlat-i+1) = pi-theta(i)
      end do
      sum = 0.
      do i=1,nlat
      sum = sum+wts(i)
      end do
      do i=1,nlat
      wts(i) = 2.0*wts(i)/sum
      end do
      return
      end
      subroutine lfcz(n,cz,cp,dcp)
c
c     computes the fourier coefficients of the legendre
c     polynomial p_n^0 and its derivative.
c     n is the degree and n/2 or (n+1)/2
c     coefficients are returned in cp depending on whether
c     n is even or odd. The same number of coefficients
c     are returned in dcp. For n even the constant
c     coefficient is returned in cz.
c
      dimension cp((n+1)/2),dcp((n+1)/2)
      ncp = (n+1)/2
      t1 = -1.0
      t2 = n+1.0
      t3 = 0.
      t4 = n+n+1.0
      if(mod(n,2).eq.0) then
      cp(ncp) = 1.0
      do j = ncp,2,-1
      t1 = t1+2.0
      t2 = t2-1.0
      t3 = t3+1.0
      t4 = t4-2.0
      cp(j-1) = (t1*t2)/(t3*t4)*cp(j)
      end do
      t1 = t1+2.0
      t2 = t2-1.0
      t3 = t3+1.0
      t4 = t4-2.0
      cz = (t1*t2)/(t3*t4)*cp(1)
      do j=1,ncp
      dcp(j) = (j+j)*cp(j)
      end do
      else
      cp(ncp) = 1.0
      do j = ncp-1,1,-1
      t1 = t1+2.0
      t2 = t2-1.0
      t3 = t3+1.0
      t4 = t4-2.0
      cp(j) = (t1*t2)/(t3*t4)*cp(j+1)
      end do
      do j=1,ncp
      dcp(j) = (j+j-1)*cp(j)
      end do
      end if
c      write(*,23) (cp(j),dcp(j),j=1,ncp)
 23   format(' coefficients '/(1p4e15.6))
      return
      end
      subroutine slpdp (n,theta,cz,cp,dcp,pb,dpb)
c
c     computes pn(theta) and its derivative dpb(theta) with
c                          respect to theta
c
      dimension cp(n/2+1),dcp(n/2+1)
c
      fn = float(n)
      cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      if(mod(n,2) .eq.0) then
c
c     n even
c
      kdo = n/2
      pb = .5*cz
      dpb = 0.0
      if(n .gt. 0) then
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c      pb = pb+cp(k)*cos(2*k*theta)
      pb = pb+cp(k)*cth
c      dpb = dpb-(k+k)*cp(k)*sin(2*k*theta)
      dpb = dpb-dcp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      end if
      else
c
c     n odd
c
      kdo = (n+1)/2
      pb = 0.
      dpb = 0.
      cth = cos(theta)
      sth = sin(theta)
      do 190 k=1,kdo
c      pb = pb+cp(k)*cos((2*k-1)*theta)
      pb = pb+cp(k)*cth
c      dpb = dpb-(k+k-1)*cp(k)*sin((2*k-1)*theta)
      dpb = dpb-dcp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      end if
      return
      end
      real function zeps (x)
c
c     estimate unit roundoff in quantities of size x.
c
c
c     this program should function properly on all systems
c     satisfying the following two assumptions,
c        1.  the base used in representing floating point
c            numbers is not a power of three.
c        2.  the quantity  a  in statement 10 is represented to
c            the accuracy used in floating point variables
c            that are stored in memory.
c     the statement number 10 and the go to 10 are intended to
c     force optimizing compilers to generate code satisfying
c     assumption 2.
c     under these assumptions, it should be true that,
c            a  is not exactly equal to four-thirds,
c            b  has a zero for its last bit or digit,
c            c  is not exactly equal to one,
c            eps  measures the separation of 1.0 from
c                 the next larger floating point number.
c     the developers of eispack would appreciate being informed
c     about any systems where these assumptions do not hold.
c
c     this version dated 4/6/83.
c
      a = 4.0/3.0
   10 b = a - 1.0
      c = b + b + b
      eps = abs(c-1.0)
      if (eps .eq. 0.0) go to 10
      zeps = eps*abs(x)
      return
      end
c


! Heat transport in 2D
!
! Parallelize the following serial code.
!
! $ gfortran -g -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace heat_serial.f90
! $ ./a.out < in.txt
program heat_serial
    implicit none
    real, parameter :: alpha = 2.5e-4
    real, dimension(:, :), pointer :: prev_t, next_t, temp_t
    real :: diff_t
    integer :: s, i, time

    read *, s
    allocate(prev_t(0:s + 1, 0:s + 1))
    do i = 0, s + 1
        read *, prev_t(i, 0:s + 1)
    end do
    allocate(next_t(0:s + 1, 0:s + 1))
    next_t(:, :) = prev_t(:, :) ! copy boundaries

    time = 0
    do
        next_t(1:s, 1:s) = &
            (1.0 - 4.0 * alpha) *     prev_t(1:s,     1:s)     &
                       + alpha  * (   prev_t(0:s - 1, 1:s    ) &
                                    + prev_t(2:s + 1, 1:s    ) &
                                    + prev_t(1:s    , 0:s - 1) &
                                    + prev_t(1:s    , 2:s + 1) )
        diff_t = maxval(abs(next_t(1:s, 1:s) - prev_t(1:s, 1:s)))
        if (modulo(time, 10000) == 0) then
            print "(a, i0, a, es12.5)", "time = ", time, ", diff_t = ", diff_t
            do i = 0, s + 1
                print "(*(f4.0, 1x))", prev_t(i, 0:s + 1)
            end do
            call sleep(1)
        end if
        if (diff_t < epsilon(0.0)) exit
        temp_t => prev_t; prev_t => next_t; next_t => temp_t
        time = time + 1
    end do
    print "(a, i0)", "Final time is ", time
    deallocate(prev_t)
    deallocate(next_t)
end program heat_serial


! Program to test array IO.  Should print the numbers 1-20 in order
program arrayio
   implicit none
   integer, dimension(5, 4) :: a
   integer i, j

   do j=1,4
      a(:, j) = (/ (i + (j - 1) * 5, i=1,5) /)
   end do

   write (*,*) a
end program


subroutine calc_bpf_coef(fl, fh, sample, m, n, h, c, gn)
  use constants, only : pi
  implicit none
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!! Butterworth band-pass filter by Saito(1978)
  !!! Input
  !!! fl, fh: low- and high- passband frequency (not normalized)
  !!! sample: sampling sequence (sec)
  !!! m, n: filter order (calculated by calc_bpf_order.f90)
  !!! h(4 * m) : filter coefficient
  !!! gn : gain factor
  !!!
  !!! Author   : Masashi Ogiso (masashi.ogiso@gmail.com)
  !!! Reference: Saito, M. (1978) An automatic design algorithm for band selective recursive
  !!!                             digital filters, Geophysical Exploration, 31(4), 240-263 (In Japanese)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  integer, intent(IN) :: m, n
  real*8, intent(IN) :: c, fl, fh, sample
  real*8, intent(OUT) :: h(4 * m)
  real*8, intent(OUT) :: gn

  real*8 :: g, fj, a1, dp, sigma_fl, sigma_fh, re, ri, wpc, wmc, clh
  complex*16 :: oj, r(2), cq
  integer :: i, j, k

  dp = pi / 2.0d0 / dble(n)
  sigma_fl = pi * fl * sample
  sigma_fh = pi * fh * sample

  clh = 1.0d0 / (cos(sigma_fl) * cos(sigma_fh))
  g = 1.0d0
  fj = 1.0d0
  k = 0

  do j = 1, int(n / 2)
    oj = dcmplx(cos(dp * fj), sin(dp * fj)) * 0.5d0
    fj = fj + 2.0d0
    cq = sqrt(oj ** 2 + c ** 2 * tan(sigma_fl) * tan(sigma_fh))
    r(1) = oj + cq
    r(2) = oj - cq
    g = g * c ** 2
    do i = 1, 2
      re = dble(r(i)) ** 2
      ri = imag(r(i))
      a1 = 1.0d0 / ((c + ri) ** 2 + re)
      g = g * a1
      h(k + 1) = 0.0d0
      h(k + 2) = -1.0d0
      h(k + 3) = 2.0d0 * ((ri - c) * (ri + c) + re) * a1
      h(k + 4) = ((ri - c) ** 2 + re) * a1
      k = k + 4
    enddo
  enddo
  gn = g
  if(n .ne. 2 * int(n / 2)) then
    wpc = c ** 2 * cos(sigma_fh - sigma_fl) * clh
    wmc = - c ** 2 * cos(sigma_fh + sigma_fl) * clh
    a1 = 1.0d0 / (wpc + c)
    gn = g * c * a1
    h(k + 1) = 0.0d0
    h(k + 2) = -1.0d0
    h(k + 3) = 2.0d0 * wmc * a1
    h(k + 4) = (wpc - c) * a1
  endif

  return
end subroutine calc_bpf_coef


	FUNCTION SND_RCH  ( datain, nparm, k, deltaz, ivcord )
C************************************************************************
C* SND_RCH								*
C*									*
C* This function computes the Richardson number for a layer.		*
C*									*
C*		RICH = BFVQ ** 2 / SHRM ** 2				*
C*									*
C* SND_RCH  ( DATAIN, NPARM, CLEV, IVCORD )				*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	SND_RCH		REAL		Richardson number		*
C**									*
C* Log:									*
C* K. Brill/NMC		 7/90						*
C* J. Whistler/SSAI	 4/93		Modified for SNDIAG		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	REAL            datain (*)
C*
	REAL    	stndb (10), stndt (10), stndl (10)
	CHARACTER       cvalue*20
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	SND_RCH = RMISSD
C
C*	Get information over a depth.
C
	depth = deltaz * 2.
	thtop = datain((k-1+1)*nparm+ITHTV)
	thbot = datain((k-1-1)*nparm+ITHTV)
	theta = .5 * ( thtop + thbot )
	bvfsqd = ( GRAVTY / theta ) * ( thtop - thbot ) / depth
C*
	utop = datain((k-1+1)*nparm+IUWND)
	vtop = datain((k-1+1)*nparm+IVWND)
	ubot = datain((k-1-1)*nparm+IUWND)
	vbot = datain((k-1-1)*nparm+IVWND)
	dudz = ( utop - ubot ) / depth
	dvdz = ( vtop - vbot ) / depth
	shrsqd = ( dudz * dudz + dvdz * dvdz )
	IF  ( shrsqd .eq. 0.0 )  RETURN
C*
	SND_RCH = bvfsqd / shrsqd
C*
	RETURN
	END


program chol_ppal

use datasissim_interface
use sistu_interface
use sistl_interface
use chol_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:,:), allocatable :: a_copia
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: w
real, dimension(:), allocatable :: r

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), a_copia(n,n), b(n), u(n), w(n), r(n))

call datasissim(a, b)

print*, 'O termo independente b e: '
print*, b
print*,

a_copia = a

do j = 2, n
  do i = 1, j-1
    a_copia(i,j) = a_copia(j,i)
  end do
end do

print*, 'A matriz A copia e: '

do i=1,n
  print*, a_copia(i,1:n)
end do

call chol(a, deter)

print*, 'O termo independente b e: '
print*, b
print*,

call sistl(a,b,w)

!call residuo(a, u, w, r)

print*,
print*, 'Vector w (Solucion): '
print*,

print*,
print*, w
print*,

call sistu(transpose(a),w,u)

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

call residuo(a_copia, b, u, r)

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

end program


! Name = ARPIT KUMAR JAIN ROLLNO = 180122009
PROGRAM  question3
    IMPLICIT NONE

    integer :: i
    real:: sum = 0.0, j
    ! Looping from 1 to 40
    do i = 1, 40
        ! finding only even number
        if(mod(i, 2) == 0) then
            ! converting ineger to real by multipling it to 1.0
            j = 1.0 * i
            ! Taking squre root of real number j which is equal to i and
            ! adding the squre root to sum
            sum = sum + sqrt(j)
        endif
    enddo
    ! printing sum on screen
    print *, sum

    STOP
END PROGRAM


use std
implicit none

integer(int32),allocatable :: A(:,:), X(:),x1

! Same as MATLAB rand
call print( rand() )

call print( rand(3) )

call print( rand(3,3) )

! Same as MATLAB randi

x1 = randi(10)
call print(X1)

X = randi(10,10)
call print(X)

A = randi([-10, 10],5,5)
call print(A)

end


! Rice test
!
module module_bits

contains

!-------------------------------------------------------------------------------
! implicit result type
!-------------------------------------------------------------------------------
  function number_of_bits1(i) result(num)
    num = 0
    itmp = i
    do while (itmp .gt. 0)
       num = num + 1
       itmp = ishft(itmp, -1)
    end do
  end function number_of_bits1

!-------------------------------------------------------------------------------
! result type in function definition
!-------------------------------------------------------------------------------
  integer function number_of_bits2(i) result(num)
  implicit none
  integer :: i, itmp
    num = 0
    itmp = i
    do while (itmp .gt. 0)
       num = num + 1
       itmp = ishft(itmp, -1)
    end do
  end function number_of_bits2

!-------------------------------------------------------------------------------
! result type in type declaration
!-------------------------------------------------------------------------------
  function number_of_bits3(i) result(num)
    implicit none
    integer :: i, itmp, num
    num = 0
    itmp = i
    do while (itmp .gt. 0)
       num = num + 1
       itmp = ishft(itmp, -1)
    end do
  end function number_of_bits3

!-------------------------------------------------------------------------------
! result type in function declaration
!-------------------------------------------------------------------------------
  integer function number_of_bits4(i)
  implicit none
  integer :: i, itmp
    number_of_bits4 = 0
    itmp = i
    do while (itmp .gt. 0)
       number_of_bits4 = number_of_bits4 + 1
       itmp = ishft(itmp, -1)
    end do
  end function number_of_bits4

!-------------------------------------------------------------------------------
! result type in type declaration
!-------------------------------------------------------------------------------
  function number_of_bits5(i)
  implicit none
  integer :: i, itmp, number_of_bits5
    number_of_bits5 = 0
    itmp = i
    do while (itmp .gt. 0)
       number_of_bits5 = number_of_bits5 + 1
       itmp = ishft(itmp, -1)
    end do
  end function number_of_bits5

end module module_bits

program test_module_bits
use module_bits
integer :: error

error = 0
if (4 .ne. number_of_bits1(14)) then
   error = error + 1
endif
if (4 .ne. number_of_bits2(14)) then
   error = error + 1
endif
if (4 .ne. number_of_bits4(14)) then
   error = error + 1
endif
if (4 .ne. number_of_bits4(14)) then
   error = error + 1
endif
if (4 .ne. number_of_bits5(14)) then
   error = error + 1
endif

if (0 .ne. error) then
  write(*, '(A)') "Test failed"
else
  write(*, '(A)') "Test passed"
endif

end program test_module_bits


module constants

   integer, parameter :: imiss=-99999
   integer, parameter :: ismth=0
   integer, parameter :: jsmth=0

   real, parameter :: cm2inch=1.0/2.54
   real, parameter :: cp=1005.7
   real, parameter :: grav=9.81
   real, parameter :: lapse=6.5E-03
   real, parameter :: lv=2.5E+06
   real, parameter :: m2feet=3.281
   real, parameter :: mps2knts=1.944
   real, parameter :: mps2mph=2.237
   real, parameter :: pi=3.141592654
   real, parameter :: p0=100000.0
   real, parameter :: r=287.04         ! 287.058 in Wikipedia
   real, parameter :: rv=461.5
   real, parameter :: t0=273.15
   real, parameter :: xmiss=-99999.9
   real, parameter :: cpog=cp/grav
   real, parameter :: cpor=cp/r
   real, parameter :: deg2rad=pi/180.
   real, parameter :: e=r/rv
   real, parameter :: gor=grav/r
   real, parameter :: kappa=r/cp
   real, parameter :: rad2deg=180./pi
   real, parameter :: rog=r/grav
   real, parameter :: rvolv=rv/lv
   real, parameter :: zero_thresh=1.e-10
   real, parameter :: eradius=6371200.

end module constants


C*****************************************************************************
C Unit test program TRFT2.F for subroutine RFT2
C input image (gen'd) is real*4.
C
C Ported to UNIX 6/3/1993
C*****************************************************************************
        include 'VICMAIN_FOR'
        subroutine main44

        dimension a(16,18)
        integer*4 n,m,iunit,stat,status,mp2
        real*4    s

C FORTRAN-callable
        call xvmessage('**** FORTRAN-callable RFT2 ****',' ')
        m = 16
	n = 16
        call xvunit(iunit,'inp',1,stat,' ')
        call xvopen(iunit,stat,' ')
        do i=1,m
           call xvread(iunit,a(1,i),stat,'line',i,'nsamps',n,' ')
        end do

c       ***********************************************
c       forward transform..
c       Resulting transform contained in lines m=1 to 18

        call xvmessage('before forward transform:',' ')
	mp2 = m + 2
	do 110 i=1,m
110	call prnt(7,n,a(1,i),' ')

	call rft2(a,m,n,1,status)
        if (status.ne.1) then
          if (status.eq.1) goto 3
          if (status.eq.2) goto 4
          if (status.eq.3) goto 5
        endif

        call xvmessage('after forward transform:',' ')
	do 130 i=1,mp2
130	call prnt(7,n,a(1,i),' ')

c       ***********************************************
c       the inverse transform..

	call rft2(a,m,n,-1,status)
        if (status.ne.1) then
          if (status.eq.1) goto 3
          if (status.eq.2) goto 4
          if (status.eq.3) goto 5
        endif

        call xvmessage('after reverse transform:',' ')
	s = 2*m*n

	do 160 i=1,m
	call divv(7,n,s,a(1,i),0,1)
160	call prnt(7,n,a(1,i),' ')

      call xvclose(iunit,stat,' ')

c ****************************************************************
c C-callable
        call xvmessage('**** C-callable RFT2 ****',' ')
        m = 16
	n = 16
        call xvunit(iunit,'inp',1,stat,' ')
        call xvopen(iunit,stat,' ')
        do i=1,m
           call xvread(iunit,a(1,i),stat,'line',i,'nsamps',n,' ')
        end do

c       ***********************************************
c       forward transform..
c       Resulting transform contained in lines m=1 to 18

        call xvmessage('before forward transform:',' ')
	mp2 = m + 2
	do 210 i=1,m
210	call prnt(7,n,a(1,i),' ')

	call tzrft2(a,m,n,1,status)

        if (status.ne.1) then
          if (status.eq.1) goto 3
          if (status.eq.2) goto 4
          if (status.eq.3) goto 5
        endif

        call xvmessage('after forward transform:',' ')
	do 230 i=1,mp2
230	call prnt(7,n,a(1,i),' ')

c       ***********************************************
c       the inverse transform..

	call tzrft2(a,m,n,-1,status)

        if (status.ne.1) then
          if (status.eq.1) goto 3
          if (status.eq.2) goto 4
          if (status.eq.3) goto 5
        endif

        call xvmessage('after reverse transform:',' ')
	s = 2*m*n

	do 260 i=1,m
	call divv(7,n,s,a(1,i),0,1)
260	call prnt(7,n,a(1,i),' ')

      call xvclose(iunit,stat,' ')
      return
c**************************************************************
3	call xvmessage('m or n has too large a prime factor',' ')
	return
4	call xvmessage(
     +    'product of square-free factors of m or n too big',' ')
	return
5	call xvmessage('number of lines must be even',' ')
	return

      end


c     program DRSRFT1
c>> 1996-06-05 DRSRFT1 Krogh Fixes for conversion to C.
c>> 1996-05-28 DRSRFT1 Krogh Moved formats up.
c>> 1994-10-19 DRSRFT1 Krogh  Changes to use M77CON
c>> 1994-08-09 DRSRFT1 WVS Removed '0' from format
c>> 1992-04-22 DRSRFT1 CAO, commented program statement
c>> 1989-05-07 DRSRFT1 FTK, CLL
c>> 1989-05-04 DRSRFT1 FTK, CLL
c     Demo driver for SRFT1 -- One-dimensional real Fourier transform
c     ------------------------------------------------------------------
c--S replaces "?": DR?RFT1, ?RFT1
c     ------------------------------------------------------------------
      integer I, K, KLAST, M, MS, N, N2, N4
      parameter (M = 7)
c      parameter (N = 2**M)
      parameter (N = 128)
      parameter (N2 = N/2)
      parameter (N4 = N/4)
      real             F(N), S(N4-1), T, DELTAT, TTIME, SIG
      real             PI, TWOPI, RTWO, ZERO, ONE, FOUR, P1, P3
      real             PIN, TB
      parameter (PI = 3.1415926535897932384E0)
      parameter (TWOPI = 2.E0 * PI)
      parameter (RTWO = 1.4142135623730950488E0)
      parameter (ZERO = 0.E0)
      parameter (ONE = 1.E0)
      parameter (FOUR = 4.E0)
      parameter (P1 = .1E0)
      parameter (P3 = .3E0)
      data TTIME /25.E0/
 1111 format(/' Transform for K=21 to 41 using sigma factors')
 2222 format(' K=', I3, ' TO', I3, 3(1P,E12.2, E10.2))
c     ------------------------------------------------------------------
      KLAST = N2 - 1
      DELTAT = TTIME / REAL(N)
      T = ZERO
c                Get sine table for use in getting sigma factors
      MS = -1
      call SRFT1(F, 'A', M, MS, S)
      PIN = PI / REAL(N)
      do 100 K = 1, KLAST
         T = T + DELTAT
         TB = TTIME - T
c                               Get sigma factor
         if (K .GT. N4) then
            SIG = S(N2-K)
         ELSE if (K .LT. N4) then
            SIG = S(K)
         else
            SIG = ONE
         end if
         SIG = SIG / (PIN * REAL(N - 2*K))
c
c                         Compute F and apply sigma factors
c
         F(K+1) = SIG*(SIN(TWOPI*(T+P1)) + FOUR*COS(TWOPI*(RTWO*T+P3)))
         F(N-K+1)=SIG*(SIN(TWOPI*(TB+P1))+FOUR*COS(TWOPI*(RTWO*TB+P3)))
  100 continue
      F(1) = ZERO
      T = T + DELTAT
      F(N2+1) = SIN(TWOPI*(T+P1)) + FOUR*COS(TWOPI*(RTWO*T+P3))
      call SRFT1(F, 'A', M, MS, S)
      write (*, 1111)
      do 120 K = 21, 41, 3
         write (*, 2222) K, K+2, (F(I), I = 2*K-1, 2*K+4)
  120 continue
      stop
      end


! *******************************************************************
!  *                                                                 *
!  *                           function gamma                        *
!  *                                                                 *
!  *******************************************************************
!  Single Precision Version 1.0
!  Written by Gordon A. Fenton, TUNS, 1991
!
!  PURPOSE  to return the Gamma (factorial) function
!
!  This routine calculates the definite integral
!
!                  inf
!    gamma(z) = int  t**(z-1)*exp(-t) dt
!                  0
!
!  which is the Gamma function, for argument z. The method used
!  is a series expansion followed by a recursion relationship. The
!  coefficients used in the series expansion are obtained from Abramowitz
!  and Stegun ("Handbook of Mathematical Functions", US Dept. of Commerce,
!  10th printing, 1972), pg 256. The result should have a relative accuracy
!  of better than 1.e-14. If gamma(zz) would result in a number bigger
!  than the maximum single precision number, "big", then "big" is
!  returned. This occurs also if zz is a negative integer.
!  Arguments are as follows;
!
!     zz    real value for which the gamma function is desired. (input)
!
!  NOTES: 1) "eps" is the machine epsilon (smallest number which can be added
!            to 1.0 without being lost)
!         2) "big" is the biggest floating point number
!         3) set IDEBUG = 1 if error messages should be reported
!--------------------------------------------------------------------------
      real function gammaf( zz )
      parameter (IDEBUG = 1)
      dimension c(26)
      data c/1.0000000000000000,  0.5772156649015329,     &
            -0.6558780715202538, -0.0420026350340952,     &
             0.1665386113822915, -0.0421977345555443,     &
            -0.0096219715278770,  0.0072189432466630,     &
            -0.0011651675918591, -0.0002152416741149,     &
             0.0001280502823882, -0.0000201348547807,     &
            -0.0000012504934821,  0.0000011330272320,     &
            -0.0000002056338417,  0.0000000061160950,     &
             0.0000000050020075, -0.0000000011812746,     &
             0.0000000001043427,  0.0000000000077823,     &
            -0.0000000000036968,  0.0000000000005100,     &
            -0.0000000000000206, -0.0000000000000054,     &
             0.0000000000000014,  0.0000000000000001/
      data zero/0./, eps/0.119209e-06/, one/1./, big/1.701411733e+38/
      data pi/3.141592653589793238462643/

   1  format(a,e13.6,a)
!----------------------------- start executable statements
      z = abs(zz)

      q = z + eps
      n = int( q )
      f = z - float(n)
!					is z an integer?
      if( f .lt. q*eps ) then
         if( zz .le. zero ) go to 20
         n = n - 1
         f = one
         a = one
      else
!					series expansion for f < 1.0
         a = f*(c(22) + f*(c(23) + f*(c(24) + f*(c(25) + f*c(26)))))
         a = f*(c(17) + f*(c(18) + f*(c(19) + f*(c(20) + f*(c(21)+a)))))
         a = f*(c(12) + f*(c(13) + f*(c(14) + f*(c(15) + f*(c(16)+a)))))
         a = f*(c( 7) + f*(c( 8) + f*(c( 9) + f*(c(10) + f*(c(11)+a)))))
         a = f*(c( 2) + f*(c( 3) + f*(c( 4) + f*(c( 5) + f*(c( 6)+a)))))
         a = one/(f*(c( 1) + a))
      endif
!					apply recursion and watch for overflow
      if( n .gt. 0 ) then
         a = a*f
         do 10 i = 1, n-1
            q = f + float(i)
            if( a .gt. (big/q) ) go to 20
            a = a*q
  10     continue
      endif

      if( zz .lt. zero ) then
         gammaf = -pi/(z*a*sin(pi*z))
      else
         gammaf = a
      endif

      return
!				overflow error
  20  if( IDEBUG .eq. 1 )                                             &
         write(0,1)'Overflow calculating Gamma(',zz,') in GAMMA.'
      gammaf = big
      return
      end


integer(4) function coordinates_to_index(i,j,cells)
	implicit none!all variables must be declared
	integer(4),intent(in)::cells!number of cells per side of the square to be used in the game
	integer(4),intent(in)::i!first coordinate
	integer(4),intent(in)::j!second coordinate
	coordinates_to_index=j*cells+i!the conversion
end function coordinates_to_index

integer(4) function index_to_first_coordinate(i,cells)
	implicit none!all variables must be declared
	integer(4),intent(in)::cells!number of cells per side of the square to be used in the game
	integer(4),intent(in)::i!index of the cell
	index_to_first_coordinate=mod(i,cells)!the conversion
end function index_to_first_coordinate

integer(4) function index_to_second_coordinate(i,cells)
	implicit none!all variables must be declared
	integer(4),intent(in)::cells!number of cells per side of the square to be used in the game
	integer(4),intent(in)::i!index of the cell
	index_to_second_coordinate=i/cells!the conversion
end function index_to_second_coordinate


      PROGRAM xrkqs
C     driver for routine rkqs
      INTEGER N
      PARAMETER(N=4)
      INTEGER i,j
      REAL bessj,bessj0,bessj1
      REAL eps,hdid,hnext,htry,x,y(N),dydx(N),dysav(N),ysav(N),yscal(N)
      EXTERNAL derivs
      x=1.0
      ysav(1)=bessj0(x)
      ysav(2)=bessj1(x)
      ysav(3)=bessj(2,x)
      ysav(4)=bessj(3,x)
      call derivs(x,ysav,dysav)
      do 11 i=1,N
        yscal(i)=1.0
11    continue
      htry=0.6
      write(*,'(/1x,t8,a,t19,a,t31,a,t43,a)')
     *     'eps','htry','hdid','hnext'
      do 13 i=1,15
        eps=exp(-float(i))
        x=1.0
        do 12 j=1,N
          y(j)=ysav(j)
          dydx(j)=dysav(j)
12      continue
        call rkqs(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)
        write(*,'(2x,e12.4,f8.2,2x,2f12.6)') eps,htry,hdid,hnext
13    continue
      END
      SUBROUTINE derivs(x,y,dydx)
      REAL x,y(*),dydx(*)
      dydx(1)=-y(2)
      dydx(2)=y(1)-(1.0/x)*y(2)
      dydx(3)=y(2)-(2.0/x)*y(3)
      dydx(4)=y(3)-(3.0/x)*y(4)
      return
      END

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


subroutine sistub(a, b, u)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: b
real, dimension(:), intent(out) :: u

integer :: n, i, j

n = size(b)

u = b

do i = n, 1, -1
  u(i) = u(i)/a(i,i)
  u(1:i-1) = u(1:i-1) - a(1:i-1, i)*u(i)
end do

end subroutine


module constants
  !! Define universally constant mathematical and physical values
  implicit none

  private
  public :: dp, pi, zero, one, p_amb

  integer, parameter :: precision=15, range=307
  integer, parameter :: dp = selected_real_kind(precision, range)

  real(dp), parameter :: pi = 3.1415926539_dp
  real(dp), parameter :: zero = 0._dp
  real(dp), parameter :: one = 1._dp
  real(dp), parameter :: p_amb = 101325._dp ! atmospheric pressure
end module constants


submodule(forlab_linalg) forlab_linalg_lu

    implicit none

contains

    module procedure lu_sp
    integer :: i, j, k, m

    if (is_square(A)) then
        m = size(A, 1)
        if (.not. allocated(L)) then
            allocate (L(m, m))
            call eye(L)
        end if
        if (.not. allocated(U)) then
            U = zeros(m, m)
        end if

        do i = 1, m
            do j = 1, m
                U(i, j) = A(i, j)
                do k = 1, i - 1
                    U(i, j) = U(i, j) - L(i, k)*U(k, j)
                end do
            end do
            do j = i + 1, m
                L(j, i) = A(j, i)
                do k = 1, i - 1
                    L(j, i) = L(j, i) - L(j, k)*U(k, i)
                end do
                L(j, i) = L(j, i)/U(i, i)
            end do
        end do
    else
        call error_stop("Error: in A = LU, A should be square.")
    end if
    return
    end procedure
    module procedure lu_dp
    integer :: i, j, k, m

    if (is_square(A)) then
        m = size(A, 1)
        if (.not. allocated(L)) then
            allocate (L(m, m))
            call eye(L)
        end if
        if (.not. allocated(U)) then
            U = zeros(m, m)
        end if

        do i = 1, m
            do j = 1, m
                U(i, j) = A(i, j)
                do k = 1, i - 1
                    U(i, j) = U(i, j) - L(i, k)*U(k, j)
                end do
            end do
            do j = i + 1, m
                L(j, i) = A(j, i)
                do k = 1, i - 1
                    L(j, i) = L(j, i) - L(j, k)*U(k, i)
                end do
                L(j, i) = L(j, i)/U(i, i)
            end do
        end do
    else
        call error_stop("Error: in A = LU, A should be square.")
    end if
    return
    end procedure

end submodule forlab_linalg_lu