      real*8 function interp_bilin (a1, a2, av, b1, b2, bv, t1, t2, t3,
     &     t4)
!***********************************************************************
! Copyright 2010 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!**********************************************************************
!
! PURPOSE
!
! To calculate particle time delay using type curves.
!
!**********************************************************************
!
! Initial implementation: 09-Nov-10, Programmer: Scott Painter
!
!**********************************************************************
! Return the interpolated time value

!argument list same as interp4

      implicit none

      real*8 a1, a2, av, b1, b2, bv, t1, t2, t3, t4
      real*8 u, t
      real*8 omt, omu

      t=(av-a1)/(a2-a1)
      u=(bv-b1)/(b2-b1)

! if linear in log-space then
!      t=(dlog10 (av) - dlog10 (a1)) / (dlog10 (a2) - dlog10 (a1))
!      u=(dlog10 (bv) - dlog10 (b1)) / (dlog10 (b2) - dlog10 (b1))

      omt=1.0d0 - t
      omu=1.0d0 - u

      interp_bilin =omt*omu*t1 + t*omu*t3 + t*u*t4 + omt*u*t2

      return

      end function interp_bilin


PROGRAM F067

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, DIMENSION(100, 100)  :: TRIANGLE

    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/067/p067_triangle.txt"
    CHARACTER (LEN=300)           :: TRIANGLE_NUM_ROW
    CHARACTER (LEN=2)             :: TRIANGLE_NUM

    INTEGER :: I = 1

    INTEGER :: J, DIGITS_I, DIGITS_N

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO

        READ(2, '(A)', END=10) TRIANGLE_NUM_ROW

        J        = 1;
        DIGITS_N = 1;

        DO DIGITS_I = 1, LEN_TRIM(TRIANGLE_NUM_ROW) + 1

            IF (DIGITS_N <= 2) THEN
                TRIANGLE_NUM(DIGITS_N:DIGITS_N) = TRIANGLE_NUM_ROW(DIGITS_I:DIGITS_I);
                DIGITS_N = DIGITS_N + 1
            ELSE
                READ(TRIANGLE_NUM, *) TRIANGLE(I, J)
                DIGITS_N = 1
                J = J + 1
            END IF

        END DO

        IF (J <= 100) THEN
            DO WHILE (J /= 100)
                TRIANGLE(I, J) = 0
                J = J + 1
            END DO
        END IF

        I = I + 1

    END DO

    10 CLOSE(2)

    DO I = 99, 1, -1

        DO J = 1, I

            IF (TRIANGLE(I+1, J) >= TRIANGLE(I+1, J+1)) THEN
                TRIANGLE(I, J) = TRIANGLE(I, J) + TRIANGLE(I+1, J)
            ELSE
                TRIANGLE(I, J) = TRIANGLE(I, J) + TRIANGLE(I+1, J+1)
            END IF

        END DO

    END DO

    PRINT ('(I0)'), TRIANGLE(1, 1)

END PROGRAM F067


!= static_assert pre(T)
!= static_assert post("x == r + y * q" & "r < y")
subroutine example(x, y, q, r)

  implicit none

  integer :: x, y
  integer :: q
  integer :: r

  r = x
  q = 0
  != static_assert seq("r == x" & "q == 0")
  do while (y <= r)
     != static_assert invariant("x == r + y * q")
     r = r - y
     q = q + 1
  end do
end subroutine example

!= static_assert post("x <= y" -> "min == x")
!= static_assert post("y <= x" -> "min == y")
integer (kind=8) function min(x, y)
  implicit none

  integer (kind=8) :: x, y

  if (x <= y) then
    min = x
  else
    min = y
  end if

end function min

!= static_assert post("x <= y" -> "minf == x")
!= static_assert post("y <= x" -> "minf == y")
real function minf(x, y)
  implicit none

  real :: x, y

  if (x <= y) then
     minf = x
  else
     minf = y
  end if

end function minf

!= decl_aux("integer" :: x_)
!= decl_aux("integer" :: y_)
!= static_assert pre("x == x_" & "y == y_")
!= static_assert post("multiply == x_ * y_")
integer function multiply(x, y)
  implicit none

  integer :: x, y
  integer :: r, n

  if (x < 0) then
     x = -x
     y = -y
  end if

  r = 0
  n = 0
  != static_assert seq("x * y == x_ * y_" & "n == 0" & "r == 0" & "n <= x")
  do while (n < x)
     != static_assert invariant("x * y == x_ * y_" & "r == n * y" & "n <= x")
     r = r + y
     n = n + 1
  end do

  multiply = r
end function multiply

!= static_assert pre("x >= 0")
!= static_assert post("2 * halve > x - 2")
!= static_assert post("2 * halve <= x")
integer function halve(x)
  implicit none

  integer :: x
  integer :: n, q

  n = 2
  q = 0

  != static_assert seq("n == 2" & "q == 0" & "n <= x + 2")
  do while (n <= x)
     != static_assert invariant("n <= x + 2" & "2 * q == n - 2")
     q = q + 1
     n = n + 2
  end do

  halve = q
end function halve

! Performs (positive) integer division, rounded down.
!= decl_aux("integer" :: x_)
!= decl_aux("integer" :: y_)
!= static_assert pre("x == x_" & "y == y_")
!= static_assert pre("x >= 0")
!= static_assert post("y_ * div > x_ - y_")
!= static_assert post("y_ * div <= x_")
integer function div(x, y)

  integer :: x, y
  integer :: n = y, q = 0

  != static_assert seq("x == x_" & "y == y_" & "n == y" & "q == 0" & "n <= x + y")
  do while (n <= x)
     != static_assert invariant("x == x_" & "y == y_" & "n <= x + y" & "y * q == n - y")
     q = q + 1
     n = n + y
  end do

  div = q

end function div

!= decl_aux("integer" :: x_)
!= decl_aux("real" :: y_)
!= static_assert pre("x == x_" & "y == y_")
!= static_assert post("multiplyf == x_ * y_")
real function multiplyf(x, y)
  implicit none

  integer :: x, n
  real :: y, r

  if (x < 0) then
     x = -x
     y = -y
  end if

  r = 0.0
  n = 0
  != static_assert seq("x * y == x_ * y_" & "n == 0" & "r == 0" & "n <= x")
  do while (n < x)
     != static_assert invariant("x * y == x_ * y_" & "r == n * y" & "n <= x")
     r = r + y
     n = n + 1
  end do

  multiplyf = r
end function multiplyf


module adams_bashforth
  implicit none

  contains

  ! ---------------------------------------------------------------------------
  !> A first-order Forward Euler algorithm
  !! This is not a good algorithm. Don't use it, except to show how
  !! how bad it is.

  subroutine ForwardEuler(X_new, dXdt, X, dt, xlow, xhigh, ylow, yhigh, layers, OL, AB_order)
    implicit none

    double precision, intent(out) :: X_new(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: dXdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers, AB_order)
    double precision, intent(in) :: X(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: dt
    integer,          intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL, AB_order

    X_new = X + dt*dXdt(:,:,:,1)

  end subroutine ForwardEuler

! ---------------------------------------------------------------------------
  !> A second-order Adams-Bashforth algorithm
  subroutine AB2(X_new, dXdt, X, dt, xlow, xhigh, ylow, yhigh, layers, OL, AB_order)
    implicit none

    double precision, intent(out) :: X_new(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: dXdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers, AB_order)
    double precision, intent(in) :: X(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: dt
    integer,          intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL, AB_order

    X_new = X + dt*(3d0*dXdt(:,:,:,1) - 1d0*dXdt(:,:,:,2))/2d0

    ! Cycle tendencies
    dXdt(:,:,:,2) = dXdt(:,:,:,1)

  end subroutine AB2

! ---------------------------------------------------------------------------
  !> A third-order Adams-Bashforth algorithm
  subroutine AB3(X_new, dXdt, X, dt, xlow, xhigh, ylow, yhigh, layers, OL, AB_order)
    implicit none

    double precision, intent(out) :: X_new(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: dXdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers, AB_order)
    double precision, intent(in) :: X(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: dt
    integer,          intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL, AB_order

    X_new = X + dt*(23d0*dXdt(:,:,:,1) - 16d0*dXdt(:,:,:,2) + &
                    5d0*dXdt(:,:,:,3))/12d0

    ! Cycle tendencies
    dXdt(:,:,:,3) = dXdt(:,:,:,2)
    dXdt(:,:,:,2) = dXdt(:,:,:,1)

  end subroutine AB3

! ---------------------------------------------------------------------------
  !> A fourth-order Adams-Bashforth algorithm
  subroutine AB4(X_new, dXdt, X, dt, xlow, xhigh, ylow, yhigh, layers, OL, AB_order)
    implicit none

    double precision, intent(out) :: X_new(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: dXdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers, AB_order)
    double precision, intent(in) :: X(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: dt
    integer,          intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL, AB_order

    X_new = X + dt*(55d0*dXdt(:,:,:,1) - 59d0*dXdt(:,:,:,2) + &
                    37d0*dXdt(:,:,:,3) - 9d0*dXdt(:,:,:,4))/24d0

    ! Cycle tendencies
    dXdt(:,:,:,4) = dXdt(:,:,:,3)
    dXdt(:,:,:,3) = dXdt(:,:,:,2)
    dXdt(:,:,:,2) = dXdt(:,:,:,1)

  end subroutine AB4

! ---------------------------------------------------------------------------
  !> A fifth-order Adams-Bashforth algorithm
  subroutine AB5(X_new, dXdt, X, dt, xlow, xhigh, ylow, yhigh, layers, OL, AB_order)
    implicit none

    double precision, intent(out) :: X_new(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: dXdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers, AB_order)
    double precision, intent(in) :: X(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: dt
    integer,          intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL, AB_order

    X_new = X + dt*(1901d0*dXdt(:,:,:,1) - 2774d0*dXdt(:,:,:,2) + &
                    2616d0*dXdt(:,:,:,3) - 1274d0*dXdt(:,:,:,4) + &
                    251d0*dXdt(:,:,:,5))/720d0

    ! Cycle tendencies
    dXdt(:,:,:,5) = dXdt(:,:,:,4)
    dXdt(:,:,:,4) = dXdt(:,:,:,3)
    dXdt(:,:,:,3) = dXdt(:,:,:,2)
    dXdt(:,:,:,2) = dXdt(:,:,:,1)

  end subroutine AB5

end module adams_bashforth


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file idvtgs.f
c
c     this file includes documentation and code for
c     subroutine idvtgs         i
c
c ... files which must be loaded with idvtgs.f
c
c     sphcom.f, hrfft.f, vhsgs.f,shags.f, gaqd.f
c
c
c     subroutine idvtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,
c    +mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertbd,pertbv,ierror)
c
c     given the scalar spherical harmonic coefficients ad,bd precomputed
c     by subroutine shaes for the scalar field divg and coefficients av,bv
c     precomputed by subroutine shaes for the scalar field vort, subroutine
c     idvtgs computes a vector field (v,w) whose divergence is divg - pertbd
c     and whose vorticity is vort - pertbv.  w the is east longitude component
c     and v is the colatitudinal component of the velocity.  if nt=1 (see nt
c     below) pertrbd and pertbv are constants which must be subtracted from
c     divg and vort for (v,w) to exist (see the description of pertbd and
c     pertrbv below).  usually pertbd and pertbv are zero or small relative
c     to divg and vort.  w(i,j) and v(i,j) are the velocity components at
c     gaussian colatitude theta(i) (see nlat as input argument) and longitude
c     lambda(j) = (j-1)*2*pi/nlon
c
c     the
c
c            divergence(v(i,j),w(i,j))
c
c         =  [d(sint*v)/dtheta + dw/dlambda]/sint
c
c         =  divg(i,j) - pertbd
c
c     and
c
c            vorticity(v(i,j),w(i,j))
c
c         =  [-dv/dlambda + d(sint*w)/dtheta]/sint
c
c         =  vort(i,j) - pertbv
c
c     where
c
c            sint = cos(theta(i)).
c
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than 3. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   isym determines whether (v,w) are computed on the full or half
c            sphere as follows:
c
c      = 0
c            divg,vort are neither pairwise symmetric/antisymmetric nor
c            antisymmetric/symmetric about the equator as described for
c            isym = 1 or isym = 2  below.  in this case, the vector field
c            (v,w) is computed on the entire sphere.  i.e., in the arrays
c            w(i,j) and v(i,j) i=1,...,nlat and j=1,...,nlon.
c
c      = 1
c
c            divg is antisymmetric and vort is symmetric about the equator.
c            in this case w is antisymmetric and v is symmetric about the
c            equator.  w and v are computed on the northern hemisphere only.
c            if nlat is odd they are computed for i=1,...,(nlat+1)/2
c            and j=1,...,nlon.  if nlat is even they are computed for
c            i=1,...,nlat/2 and j=1,...,nlon.
c
c      = 2
c
c            divg is symmetric and vort is antisymmetric about the equator.
c            in this case w is symmetric and v is antisymmetric about the
c            equator.  w and v are computed on the northern hemisphere only.
c            if nlat is odd they are computed for i=1,...,(nlat+1)/2
c            and j=1,...,nlon.  if nlat is even they are computed for
c            i=1,...,nlat/2 and j=1,...,nlon.
c
c
c     nt     in the program that calls idvtgs, nt is the number of scalar
c            and vector fields.  some computational efficiency is obtained
c            for multiple fields.  the arrays ad,bd,av,bv,u, and v can be
c            three dimensional and pertbd,pertbv can be one dimensional
c            corresponding to indexed multiple arrays divg, vort.  in this
c            case, multiple synthesis will be performed to compute each
c            vector field.  the third index for ad,bd,av,bv,v,w and first
c            pertrbd,pertbv is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1. the description of
c            remaining parameters is simplified by assuming that nt=1 or that
c            ad,bd,av,bv,v,w are two dimensional and pertbd,pertbv are
c            constants.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls idvtgs. if isym = 0 then idvw
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idvw must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls idvtgs. jdvw must be at least nlon.
c
c     ad,bd  two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
c            of the divergence array divg as computed by subroutine shaes.
c
c     av,bv  two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
c            of the vorticity array vort as computed by subroutine shaes.
c     ***    ad,bd,av,bv must be computed by shaes prior to calling idvtgs.
c
c     mdab   the first dimension of the arrays ad,bd,av,bv as it appears
c            in the program that calls idvtgs (and shags). mdab must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays ad,bd,av,bv as it appears in
c            the program that calls idvtgs (and shags). ndab must be at
c            least nlat.
c
c  wvhsgs    an array which must be initialized by subroutine vhsgsi.
c            wvhsgs can be used repeatedly by idvtgs as long as nlon
c            and nlat remain unchanged.  wvhsgs must not be altered
c            between calls of idvtgs.
c
c
c  lvhsgs    the dimension of the array wvhsgs as it appears in the
c            program that calls idvtgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c               l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls idvtgs. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,nlon/2)       if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2)   if nlon is odd
c
c            if isym = 0 then lwork must be at least
c
c                       nlat*((2*nt+1)*nlon+4*nt*l1+1)
c
c            if isym = 1 or 2 then lwork must be at least
c
c                       (2*nt+1)*l2*nlon+nlat*(4*nt*l1+1)
c
c     **************************************************************
c
c     output parameters
c
c
c     v,w   two or three dimensional arrays (see input parameter nt) that
c           contain a vector field whose divergence is divg - pertbd and
c           whose vorticity is vort - pertbv.  w(i,j) is the east longitude
c           component and v(i,j) is the colatitudinal component of velocity
c           at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude
c           lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon.
c
c   pertbd  a nt dimensional array (see input parameter nt and assume nt=1
c           for the description that follows).  divg - pertbd is a scalar
c           field which can be the divergence of a vector field (v,w).
c           pertbd is related to the scalar harmonic coefficients ad,bd
c           of divg (computed by shaes) by the formula
c
c                pertbd = ad(1,1)/(2.*sqrt(2.))
c
c           an unperturbed divg can be the divergence of a vector field
c           only if ad(1,1) is zero.  if ad(1,1) is nonzero (flagged by
c           pertbd nonzero) then subtracting pertbd from divg yields a
c           scalar field for which ad(1,1) is zero.  usually pertbd is
c           zero or small relative to divg.
c
c   pertbv a nt dimensional array (see input parameter nt and assume nt=1
c           for the description that follows).  vort - pertbv is a scalar
c           field which can be the vorticity of a vector field (v,w).
c           pertbv is related to the scalar harmonic coefficients av,bv
c           of vort (computed by shaes) by the formula
c
c                pertbv = av(1,1)/(2.*sqrt(2.))
c
c           an unperturbed vort can be the vorticity of a vector field
c           only if av(1,1) is zero.  if av(1,1) is nonzero (flagged by
c           pertbv nonzero) then subtracting pertbv from vort yields a
c           scalar field for which av(1,1) is zero.  usually pertbv is
c           zero or small relative to vort.
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idvw
c           = 6  error in the specification of jdvw
c           = 7  error in the specification of mdab
c           = 8  error in the specification of ndab
c           = 9  error in the specification of lvhsgs
c           = 10 error in the specification of lwork
c **********************************************************************
c
c
      subroutine idvtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,
     +mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertbd,pertbv,ierror)
      dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt),pertbd(nt),pertbv(nt)
      dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt)
      dimension av(mdab,ndab,nt),bv(mdab,ndab,nt)
      dimension wvhsgs(lvhsgs),work(lwork)
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 4) return
      ierror = 3
      if(isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((isym.eq.0 .and. idvw.lt.nlat) .or.
     +   (isym.ne.0 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdab .lt. min0(nlat,(nlon+2)/2)) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      idz = (mmax*(nlat+nlat-mmax+1))/2
      lzimn = idz*imid
      if(lvhsgs .lt. lzimn+lzimn+nlon+15) return
      ierror = 10
c
c     verify unsaved work space length
c
      mn = mmax*nlat*nt
      if(isym.ne.0  .and. lwork .lt.
     +nlat*(2*nt*nlon+max0(6*imid,nlon))+4*mn+nlat) return
      if(isym.eq.0  .and. lwork .lt.
     +imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat) return
      ierror = 0
c
c     set work space pointers
c
      ibr = 1
      ibi = ibr+mn
      icr = ibi+mn
      ici = icr + mn
      is = ici + mn
      iwk = is + nlat
      liwk = lwork-4*mn-nlat
      call idvtgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),
     +work(ibi),work(icr),work(ici),mmax,work(is),mdab,ndab,ad,bd,
     +av,bv,wvhsgs,lvhsgs,work(iwk),liwk,pertbd,pertbv,ierror)
      return
      end

      subroutine idvtgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,
     +cr,ci,mmax,sqnn,mdab,ndab,ad,bd,av,bv,wvhsgs,lvhsgs,wk,lwk,
     +pertbd,pertbv,ierror)
      dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt)
      dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat)
      dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt)
      dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt)
      dimension av(mdab,ndab,nt),bv(mdab,ndab,nt)
      dimension wvhsgs(lvhsgs),wk(lwk)
      dimension pertbd(nt),pertbv(nt)
c
c     preset coefficient multiplyers in vector
c
      do 1 n=2,nlat
      fn = float(n-1)
      sqnn(n) = sqrt(fn*(fn+1.))
    1 continue
c
c     compute multiple vector fields coefficients
c
      do 2 k=1,nt
c
c     set divergence,vorticity perturbation constants
c
      pertbd(k) = ad(1,1,k)/(2.*sqrt(2.))
      pertbv(k) = av(1,1,k)/(2.*sqrt(2.))
c
c     preset br,bi,cr,ci to 0.0
c
      do 3 n=1,nlat
      do 4 m=1,mmax
      br(m,n,k) = 0.0
      bi(m,n,k) = 0.0
      cr(m,n,k) = 0.0
      ci(m,n,k) = 0.0
    4 continue
    3 continue
c
c     compute m=0 coefficients
c
      do 5 n=2,nlat
      br(1,n,k) = -ad(1,n,k)/sqnn(n)
      bi(1,n,k) = -bd(1,n,k)/sqnn(n)
      cr(1,n,k) = av(1,n,k)/sqnn(n)
      ci(1,n,k) = bv(1,n,k)/sqnn(n)
    5 continue
c
c     compute m>0 coefficients
c
      do 6 m=2,mmax
      do 7 n=m,nlat
      br(m,n,k) = -ad(m,n,k)/sqnn(n)
      bi(m,n,k) = -bd(m,n,k)/sqnn(n)
      cr(m,n,k) = av(m,n,k)/sqnn(n)
      ci(m,n,k) = bv(m,n,k)/sqnn(n)
    7 continue
    6 continue
    2 continue
c
c     set ityp for vector synthesis without assuming div=0 or curl=0
c
      if (isym.eq.0) then
      ityp = 0
      else if (isym.eq.1) then
      ityp = 3
      else if (isym.eq.2) then
      ityp = 6
      end if
c
c     sythesize br,bi,cr,ci into the vector field (v,w)
c
      call vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
     +           mmax,nlat,wvhsgs,lvhsgs,wk,lwk,ierror)
      return
      end


*DECK DPOFS
      SUBROUTINE DPOFS (A, LDA, N, V, ITASK, IND, WORK)
C***BEGIN PROLOGUE  DPOFS
C***PURPOSE  Solve a positive definite symmetric system of linear
C            equations.
C***LIBRARY   SLATEC
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPOFS-S, DPOFS-D, CPOFS-C)
C***KEYWORDS  HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C    Subroutine DPOFS solves a  positive definite symmetric
C    NxN system of double precision linear equations using
C    LINPACK subroutines DPOCO and DPOSL.  That is, if A is an
C    NxN double precision positive definite symmetric matrix and if
C    X and B are double precision N-vectors, then DPOFS solves
C    the equation
C
C                          A*X=B.
C
C    The matrix A is first factored into upper and lower tri-
C    angular matrices R and R-TRANPOSE.  These factors are used to
C    find the solution vector X.  An approximate condition number is
C    calculated to provide a rough estimate of the number of
C    digits of accuracy in the computed solution.
C
C    If the equation A*X=B is to be solved for more than one vector
C    B, the factoring of A does not need to be performed again and
C    the option only to solve (ITASK .GT. 1) will be faster for
C    the succeeding solutions.  In this case, the contents of A,
C    LDA, and N must not have been altered by the user following
C    factorization (ITASK=1).  IND will not be changed by DPOFS
C    in this case.
C
C  Argument Description ***
C
C    A      DOUBLE PRECISION(LDA,N)
C             on entry, the doubly subscripted array with dimension
C               (LDA,N) which contains the coefficient matrix.  Only
C               the upper triangle, including the diagonal, of the
C               coefficient matrix need be entered and will subse-
C               quently be referenced and changed by the routine.
C             on return, A contains in its upper triangle an upper
C               triangular matrix R such that A = (R-TRANPOSE) * R .
C    LDA    INTEGER
C             the leading dimension of the array A.  LDA must be great-
C             er than or equal to N.  (terminal error message IND=-1)
C    N      INTEGER
C             the order of the matrix A.  N must be greater
C             than or equal to 1.  (terminal error message IND=-2)
C    V      DOUBLE PRECISION(N)
C             on entry, the singly subscripted array(vector) of di-
C               mension N which contains the right hand side B of a
C               system of simultaneous linear equations  A*X=B.
C             on return, V contains the solution vector, X .
C    ITASK  INTEGER
C             If ITASK = 1, the matrix A is factored and then the
C               linear equation is solved.
C             If ITASK .GT. 1, the equation is solved using the existing
C               factored matrix A.
C             If ITASK .LT. 1, then terminal error message IND=-3 is
C               printed.
C    IND    INTEGER
C             GT. 0  IND is a rough estimate of the number of digits
C                     of accuracy in the solution, X.
C             LT. 0  See error message corresponding to IND below.
C    WORK   DOUBLE PRECISION(N)
C             a singly subscripted array of dimension at least N.
C
C  Error Messages Printed ***
C
C    IND=-1  Terminal   N is greater than LDA.
C    IND=-2  Terminal   N is less than 1.
C    IND=-3  Terminal   ITASK is less than 1.
C    IND=-4  Terminal   The matrix A is computationally singular or
C                         is not positive definite.  A solution
C                         has not been computed.
C    IND=-10 Warning    The solution has no apparent significance.
C                         The solution may be inaccurate or the
C                         matrix A may be poorly scaled.
C
C               Note-  The above Terminal(*fatal*) Error Messages are
C                      designed to be handled by XERMSG in which
C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
C                      for warning error messages from XERMSG.  Unless
C                      the user provides otherwise, an error message
C                      will be printed followed by an abort.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  D1MACH, DPOCO, DPOSL, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800514  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOFS
C
      INTEGER LDA,N,ITASK,IND,INFO
      DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH
      DOUBLE PRECISION RCOND
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  DPOFS
      IF (LDA.LT.N) THEN
         IND = -1
         WRITE (XERN1, '(I8)') LDA
         WRITE (XERN2, '(I8)') N
         CALL XERMSG ('SLATEC', 'DPOFS', 'LDA = ' // XERN1 //
     *      ' IS LESS THAN N = ' // XERN2, -1, 1)
         RETURN
      ENDIF
C
      IF (N.LE.0) THEN
         IND = -2
         WRITE (XERN1, '(I8)') N
         CALL XERMSG ('SLATEC', 'DPOFS', 'N = ' // XERN1 //
     *      ' IS LESS THAN 1', -2, 1)
         RETURN
      ENDIF
C
      IF (ITASK.LT.1) THEN
         IND = -3
         WRITE (XERN1, '(I8)') ITASK
         CALL XERMSG ('SLATEC', 'DPOFS', 'ITASK = ' // XERN1 //
     *      ' IS LESS THAN 1', -3, 1)
         RETURN
      ENDIF
C
      IF (ITASK.EQ.1) THEN
C
C        FACTOR MATRIX A INTO R
C
         CALL DPOCO(A,LDA,N,RCOND,WORK,INFO)
C
C        CHECK FOR POSITIVE DEFINITE MATRIX
C
         IF (INFO.NE.0) THEN
            IND = -4
            CALL XERMSG ('SLATEC', 'DPOFS',
     *         'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1)
            RETURN
         ENDIF
C
C        COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
C        AND CHECK FOR IND GREATER THAN ZERO
C
         IND = -LOG10(D1MACH(4)/RCOND)
         IF (IND.EQ.0) THEN
            IND = -10
            CALL XERMSG ('SLATEC', 'DPOFS',
     *         'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
         ENDIF
      ENDIF
C
C     SOLVE AFTER FACTORING
C
      CALL DPOSL(A,LDA,N,V)
      RETURN
      END


      program main
            implicit none

            call runge_kutta_nystrom(0.01d0, 10000, 0.0d0)
      end

      subroutine runge_kutta_nystrom(h, N, x0)
            implicit none
            real*8 h, x0
            real*8 k1, k2, k3, k4, K, L
            real*8 x, y, yd, f
            real*8 i, hon2
            integer N

            hon2 = h/2.0d0
            x = x0
            y = 0.0d0
            yd = 1.0d0

            do i = 0, N-1, +1
                  k1 = hon2*f(x, y, yd)

                  K = hon2*(yd + k1/2.0d0)
                  k2 = hon2*f(x + hon2, y + K, yd + k1)

                  k3 = hon2*f(x + hon2, y + K, yd + k2)

                  L = h*(yd + k3)
                  k4 = hon2*f(x + h, y + L, yd + 2.0d0*k3)

                  x = x + h
                  y = y + h*(yd + (k1 + k2 + k3)/3.0d0 )

                  yd = yd + (k1 + 2.0d0*k2 + 2.0d0*k3 + k4)/3.0d0

                  write(*,*)x, y
            end do

      end

      double precision function f(x, y, yd)
            implicit none
            real*8 f2, f3
            real*8 x, y, yd

            f = (f2(x,y,yd)/f3(x,y,yd))**2.0d0
            return
      end

      double precision function f1(x, y, yd)
            implicit none
            real*8 x, y, yd

            f1 = (-3.0d0/(x + 1))*yd
            return
      end

       double precision function f2(x, y, yd)
            implicit none
            real*8 x, y, yd

            f2 = ((-7.0d0/2.0d0)*(x+1)*yd-3.0d0*y/2.0d0)/((x+1)**2.0d0)
            return
      end

       double precision function f3(x, y, yd)
            implicit none
            real*8 x, y, yd

            f3 = ((-7.0d0/2.0d0)*(x+1)*yd)/((x+1)**2.0d0)
            return
      end


SUBROUTINE interp_bilinear(di,dj,var,velp)
    !== give 4 corner points of a square, interpolate point values inside
    !== di is the distance of the particle to the left face
    !== dj is the distance of the particle to the southern face

    IMPLICIT NONE
    REAL*8, INTENT(in) :: di,dj
    REAL*4, INTENT(in), DIMENSION( 2, 2 ) :: var
    REAL*8, INTENT(out) :: velp
    REAL*8 :: i1,i4

    ! calcuate the bilinear interpolation
    i1 = (var(2,1) - var(1,1))*di + var(1,1)
    i4 = (var(2,2) - var(1,2))*di + var(1,2)
    velp = (i4 - i1)*dj + i1

END SUBROUTINE interp_bilinear


C     voronoi_center and routines using voronoi center

      subroutine voronoi_center (
     1      pts11,pts12,pts13,
     2      pts21,pts22,pts23,
     3      pts31,pts32,pts33,
     4      pts41,pts42,pts43,
     5      center1,  center2,  center3, radius  )
c
c     This code takes pts as input and outputs the
c     Voronoi point of the tetrahedra formed by the 4 pts.
c     This is the translation to Fortran of the C code of
c     Mike Murphy called compute_center.
C
C      CHANGE HISTORY -
C
C      $Log: voronoi_center.f,v $
C      Revision 2.00  2007/11/09 20:04:06  spchu
C      Import to CVS
C
CPVCS
CPVCS       Rev 1.1   08 Feb 2006 14:38:08   dcg
CPVCS     "enforce lower case - add external statements for shift routines
CPVCS    these changes needed to compile with absoft pro fortran"
CPVCS
CPVCS       Rev 1.0   Thu Jun 19 17:33:08 1997   gable
CPVCS    Initial revision.
c
      implicit none

      real*8 A(3,3)
      real*8 B(3)
      real*8 f11,f12,f13,f21,f22,f23,f31,f32,f33
      real*8 pts11,pts12,pts13,pts21,pts22,pts23,
     x pts31,pts32,pts33,pts41,pts42,pts43,
     x center1,  center2,  center3, radius
      real*8 deta,detai
      real*8 det3
      det3(f11,f12,f13,f21,f22,f23,f31,f32,f33) =
     1    ((f31*((f12*f23)-(f22*f13)))-
     2     (f32*((f11*f23)-(f13*f21)))+
     3     (f33*((f11*f22)-(f21*f12))))

      A(1,1) = pts41 - pts11
      A(1,2) = pts42 - pts12
      A(1,3) = pts43 - pts13

      A(2,1) = pts41 - pts21
      A(2,2) = pts42 - pts22
      A(2,3) = pts43 - pts23

      A(3,1) = pts41 - pts31
      A(3,2) = pts42 - pts32
      A(3,3) = pts43 - pts33

      B(1) = 0.5d0*(A(1,1)*(pts11+pts41)+
     1              A(1,2)*(pts12+pts42)+
     2              A(1,3)*(pts13+pts43))

      B(2) = 0.5d0*(A(2,1)*(pts21+pts41)+
     1              A(2,2)*(pts22+pts42)+
     2              A(2,3)*(pts23+pts43))

      B(3) = 0.5d0*(A(3,1)*(pts31+pts41)+
     1              A(3,2)*(pts32+pts42)+
     2              A(3,3)*(pts33+pts43))

      deta = det3(A(1,1),A(1,2),A(1,3),
     1       A(2,1),A(2,2),A(2,3),
     2       A(3,1),A(3,2),A(3,3))

      detai = 1.0d0/(deta + 1.e-30)

      center1 = det3(B(1),A(1,2),A(1,3),
     1            B(2),A(2,2),A(2,3),
     2            B(3),A(3,2),A(3,3))*detai

      center2 = det3(A(1,1),B(1),A(1,3),
     1            A(2,1),B(2),A(2,3),
     2            A(3,1),B(3),A(3,3))*detai

      center3 = det3(A(1,1),A(1,2),B(1),
     1            A(2,1),A(2,2),B(2),
     2            A(3,1),A(3,2),B(3))*detai

      radius = sqrt((center1-pts11)**2 +
     1              (center2-pts12)**2 +
     2              (center3-pts13)**2 )
      return
      end

C####################

      subroutine voronoi_vector_area (
     1      x1,y1,z1,
     1      x2,y2,z2,
     1      x3,y3,z3,
     5      xarea,  yarea,  zarea  )
c
c     This code takes 3 pts of triangle as input
c     and outputs the Voronoi area associated with first point
c     which is the sum of 2 triangles formed with
c     point 1, edge midpoints, voronoi center point
c
c     note convention has faces pointing inward

      implicit none

      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,xarea,yarea,zarea
      real*8 xvor,yvor,zvor,xm,ym,zm,ax1,ay1,az1,ax2,ay2,az2

      xarea=0.0d+00
      yarea=0.0d+00
      zarea=0.0d+00

      call voronoi_center_2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
     *           xvor,yvor,zvor)

C           area of right side triangle first (pt,midpt,vorpt)
            xm=(x2+x1)*0.5d+00
            ym=(y2+y1)*0.5d+00
            zm=(z2+z1)*0.5d+00

            ax1=  0.5d+00*((y1-ym)*(zvor-zm)-(yvor-ym)*(z1-zm))
            ay1= -0.5d+00*((x1-xm)*(zvor-zm)-(xvor-xm)*(z1-zm))
            az1=  0.5d+00*((x1-xm)*(yvor-ym)-(xvor-xm)*(y1-ym))

C           area of left side triangle (pt,vorpt,midpt)
            xm=(x3+x1)*0.5d+00
            ym=(y3+y1)*0.5d+00
            zm=(z3+z1)*0.5d+00

            ax2=  0.5d+00*((y1-yvor)*(zm-zvor)-(ym-yvor)*(z1-zvor))
            ay2= -0.5d+00*((x1-xvor)*(zm-zvor)-(xm-xvor)*(z1-zvor))
            az2=  0.5d+00*((x1-xvor)*(ym-yvor)-(xm-xvor)*(y1-yvor))

            xarea =  ax1 + ax2
            yarea =  ay1 + ay2
            zarea =  az1 + az2

c           print*,"area 1:   ",ax1,ay1,az1
c           print*,"area 2:   ",ax2,ay2,az2
c           print*,"area sum: ",xarea,yarea,zarea

      return
      end


! vim: set ft=fortran sw=4 ts=4 :

program stock_volatility

    use mod_arrays, only: reverse, average, std, moving_average, moving_std
    use mod_io, only: read_stock, write_stock

    implicit none

    character(len=4), allocatable :: symbols(:)
    character(len=:), allocatable :: time(:)
    real, allocatable :: open(:), high(:), low(:),&
          close(:), adjclose(:), volume(:)
    real, allocatable :: mvavg(:), mvstd(:)
    integer :: n, im
    real :: gain, mean, stddev

    symbols = ['AAPL', 'AMZN', 'CRAY', 'CSCO', 'HPQ ',&
          'IBM ', 'INTC', 'MSFT', 'NVDA', 'ORCL']

    do n = 1, size(symbols)
        call read_stock('data/' // trim(symbols(n)) // '.csv', time,&
              open, high, low, close, adjclose, volume)

        im = size(time)

        adjclose = reverse(adjclose)
        time = time(size(time):1:-1)

        gain = (adjclose(size(adjclose)) - adjclose(1))
        mean = average(adjclose)
        stddev = std(adjclose)

        mvavg = moving_average(adjclose, 30)
        mvstd = moving_std(adjclose, 30)

        if (n == 1) then
              print *, time(size(time)) // ' through ' // time(1)
              print *, 'Symbol, Gain (USD), Relative gain (%), Mean (USD), Standard deviation (USD)'
              print *, '---------------------------------------------------------------------------'
        end if
        print *, symbols(n), gain, nint(gain / adjclose(1) * 100), mean, stddev

        call write_stock('results/' // trim(symbols(n)) // '_volatility',&
            time, adjclose, mvavg, mvstd)
    end do
end program stock_volatility


! ======================================================================
! NAME
!
!     FTPSD
!
! DESCRIPTION
!
!     FTPSD is a supporting program of GPECN1DTDPBC that uses the
!     Fourier-Transform Phase Shift Determination algorithm* to compute
!     the phase shift observed in the probability densities generated by
!     interferometry-related simulations.
!
!     * Goldberg, K. A. and Bokor, J., "Fourier-Transform Method of
!       Phase-Shift Determination", Applied Optics, 40 (17): 2886-2894
!       (2001).
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010, 2011, 2017 Martin Charles Kandes
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Friday, March 31st, 2017
!
! ----------------------------------------------------------------------
      PROGRAM FTPSD
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: NUMBER_OF_TIME_STEPS_BEFORE_WRITE
      INTEGER :: START_FILE
      INTEGER :: END_FILE

      REAL :: RADIUS
      REAL :: GAMMA_FACTOR
      REAL :: CARRIER_FREQUENCY

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_FILE
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE

      COMPLEX :: FOURIER_TRANSFORM

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS_BEFORE_WRITE

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) START_FILE

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) END_FILE

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAMMA_FACTOR

      CALL GET_COMMAND_ARGUMENT(7,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) CARRIER_FREQUENCY

      WRITE(6,*) NUMBER_OF_GRID_POINTS
      WRITE(6,*) NUMBER_OF_TIME_STEPS_BEFORE_WRITE
      WRITE(6,*) START_FILE
      WRITE(6,*) END_FILE
      WRITE(6,*) RADIUS
      WRITE(6,*) GAMMA_FACTOR
      WRITE(6,*) CARRIER_FREQUENCY

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)
      TIME_STEP_SIZE = ((RADIUS*ANGULAR_GRID_SPACING_SIZE)**2/(2.0E0*GAMMA_FACTOR))*FLOAT(NUMBER_OF_TIME_STEPS_BEFORE_WRITE)

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))

!     Main Program:
!     -------------
      DO CURRENT_FILE = START_FILE, END_FILE
         OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='UNFORMATTED')
         READ(UNIT=CURRENT_FILE) WAVEFUNCTION
         CLOSE(UNIT=CURRENT_FILE)
         FOURIER_TRANSFORM = CMPLX(0.0E0,0.0E0)
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            FOURIER_TRANSFORM = FOURIER_TRANSFORM+CMPLX(ABS(WAVEFUNCTION(CURRENT_GRID_POINT))**2*ANGULAR_GRID_SPACING_SIZE,0.0E0)*EXP(CMPLX(0.0E0,-CARRIER_FREQUENCY*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE))
         ENDDO
         WRITE(500,900) FLOAT(CURRENT_FILE-START_FILE)*TIME_STEP_SIZE, ATAN2(AIMAG(FOURIER_TRANSFORM),REAL(FOURIER_TRANSFORM)), REAL(FOURIER_TRANSFORM), AIMAG(FOURIER_TRANSFORM)
      ENDDO

!     Format Statements:
!     ------------------
900   FORMAT(1X,4(F23.15))

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)

      STOP
      ENDPROGRAM FTPSD
! ======================================================================


      real*8 function expint(x, n)
      INTEGER n, MAXIT
      REAL*8 x, EPS, FPMIN, EULER
      PARAMETER (MAXIT=100,EPS=1.e-7,FPMIN=1.e-30,EULER=.5772156649)

      INTEGER i, ii, nm1
      REAL a, b, c, d, del, fact, h, psi
      nm1=n-1
      if(n.lt.0.or.x.lt.0..or.(x.eq.0..and.(n.eq.0.or.n.eq.1)))then
          write(*,*) 'bad arguments in expint', n, x
      else if(n.eq.0)then            ! Special Case
          expint=exp(-x)/x
      else if(x.eq.0.)then           ! Another special case
          expint=1./nm1
      else if(x.gt.1.) then          ! Lentz's algorithm
          b=x+n
          c=1./FPMIN
          d=1./b
          h=d
          do i=1,MAXIT
              a=-1*(nm1+1)
              b=b+2
              d=1./(a*d+b)
              c=b+a/c
              del=c*d
              h=h*del
              if(abs(del-1.).lt.EPS)then
                  expint=h*exp(-x)
                  return
              endif
          enddo
          write(*,*) 'Continued Fraction failed in expint'
      else
          if(nm1.ne.0)then
              expint=1./nm1
          else
              expint=-log(x)-EULER
          endif
          fact=1.
          do i=1,MAXIT
              fact=-fact*x/i
              if(i.ne.nm1)then
                  del=-fact/(i-nm1)
              else
                  psi=-EULER
                  do ii=1,nm1
                      psi=psi+1./ii
                  enddo
              endif
              expint=expint+del
              if(abs(del).lt.abs(expint)*EPS) return
          enddo
          write(*,*) 'series failed in expint'
      endif
      return
      END


      subroutine mapc2m_cubedsphere(blockno,xc,yc,xp,yp,zp)
      implicit none

      double precision xc,yc,xp,yp,zp
      integer blockno

      if (blockno .eq. 0) then
         call csphere_basic(xc,yc,yp,xp,zp)
         zp = -zp
      elseif (blockno .eq. 1) then
         call csphere_basic(xc,yc,zp,xp,yp)
      elseif (blockno .eq. 2) then
         call csphere_basic(xc,yc,zp,yp,xp)
         xp = -xp
      elseif (blockno .eq. 3) then
         call csphere_basic(xc,yc,xp,yp,zp)
      elseif (blockno .eq. 4) then
         call csphere_basic(xc,yc,xp,zp,yp)
         yp = -yp
      elseif (blockno .eq. 5) then
         call csphere_basic(xc,yc,yp,zp,xp)
      endif

      end

      subroutine csphere_basic(xc,yc,xp,yp,zp)
      implicit none

      double precision xc,yc,xp,yp,zp
      double precision R, tan_xi, tan_eta

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

      R = 1.d0
      tan_xi = tan(0.5d0*pi*(xc-0.5d0))
      tan_eta = tan(0.5d0*pi*(yc-0.5d0))
      zp = R/sqrt(tan_xi**2 + tan_eta**2 + 1.d0)
      xp = zp*tan_xi
      yp = zp*tan_eta

      end


!=================================================
! SUBROUTINES
!	STTRANS
!
!=================================================

module mod_sttrans

	implicit none

contains
!==========
subroutine STTRANS

	use prm_var

	implicit none

	real(8) :: rh, rd

	print 600, aphi, adlt
	 600 FORMAT(' ','SOURCE GEOMETRY (PHI,DELT)=',2(F6.2,1X))

	rh = aphi * pi/180.d0
	rd = adlt * pi/180.d0

	t11 = dcos(rh)
	t12 = dsin(rh)
	u11 = dcos(rd)
	u12 = dsin(rd)

return
end subroutine STTRANS

end module mod_sttrans


      subroutine insolation(calday, dgr_lat, dgr_lon, scon, radius, daysperyear, zen, solin)
c
c Returns instantaneous insolation and zenith angle at specified time, lat and lon
c

c In
      real calday       ! Calendar day, including fraction
      real dgr_lat      ! Current centered latitude (degrees)
      real dgr_lon      ! Current centered longitude (degrees)
      real scon         ! Solar constant (W m-2)
      real radius       ! Mean orbital radius (au)
      real daysperyear  ! No. days in a year
c Out
      real zen          ! Solar zenith angle (degrees)
      real solin        ! Insolation (W m-2)
c Local
      real delta        ! Solar declination angle  in radians
      real eccf         ! Earth orbit eccentricity factor
      real coszrs       ! Cosine of zenith angle

c     Get declination angle and eccen factor
      call eccf_decl(calday, daysperyear, delta, eccf)

c     get zenith angle
      call zenith(calday, dgr_lat, dgr_lon, delta, zen, coszrs)

      if (zen .lt. 0. .or. zen .gt. 90.) then
         solin = 0.
      else
         solin = scon*eccf*coszrs/radius/radius
      endif

      end
c===============================================================================
      subroutine daily_avg_insolation(calday, dgr_lat, scon, radius, daysperyear, zen, solin)
c
c Returns daily-mean insolation and zenith angle at specified day and lat
c
c In
      real calday       ! Calendar day, including fraction
      real dgr_lat      ! Current centered latitude (degrees)
      real scon         ! Solar constant (W m-2)
      real radius       ! Mean orbital radius (au)
      real daysperyear  ! No. days in a year
c Out
      real zen          ! Solar zenith angle (degrees)
      real solin        ! Insolation (W m-2)
c Local
      real delta        ! Solar declination angle  in radians
      real eccf         ! Earth orbit eccentricity factor
      real coszrs       ! Cosine of zenith angle

c     Get declination angle and eccen factor
      calday1 = int(calday) + 0.5 ! compute at noon
      call eccf_decl(calday1, daysperyear, delta, eccf)

c     Daily-avg zenith angle and insolation
      pi = abs(acos(-1.))
      deg2rad = pi/180.
      phi = dgr_lat*deg2rad
c     handle points poleward of polar circle
      polar_circle = pi/2. - abs(delta)
      if ( abs(phi) .ge. polar_circle ) then
c       summer hemisph (permanent day)
        if (phi*delta .gt. 0.) h0 = pi
c       winter hemisph (permanent night)
        if (phi*delta .lt. 0.) h0 = 0.
      else
        h0 = acos( -tan(phi)*tan(delta) )
      endif
      coszrs = ( h0*sin(phi)*sin(delta) + cos(phi)*cos(delta)*sin(h0) )/pi
      zen = acos(coszrs)/deg2rad
      solin = scon*eccf*coszrs/radius/radius

      end
c===============================================================================
      subroutine annual_avg_insolation(dgr_lat, scon, radius, daysperyear, zen, solin)
c
c Returns annual-mean insolation and zenith angle at specified lat
c
c In
      real dgr_lat      ! Current centered latitude (degrees)
      real scon         ! Solar constant (W m-2)
      real radius       ! Mean orbital radius (au)
      real daysperyear  ! No. days in a year
c Out
      real zen          ! Solar zenith angle (degrees)
      real solin        ! Insolation (W m-2)

c     Do it the brute-force way by averaging daily insolation
      zen_avg = 0.
      zen_count = 0.
      solin_avg = 0.
      do i = 1,int(daysperyear)
        calday = float(i)
        call daily_avg_insolation(calday, dgr_lat, scon, radius, daysperyear, zen, solin)
        solin_avg = solin_avg + solin
c       average zen only when sun is up
        if (solin .gt. 0.) then
          zen_avg = zen_avg + zen
          zen_count = zen_count + 1.
        endif
      enddo

      solin = solin_avg / int(daysperyear)
      zen = zen_avg / zen_count

      end


program Factors
  implicit none
  integer :: i, number

  write(*,*) "Enter a number between 1 and 2147483647"
  read*, number

  do i = 1, int(sqrt(real(number))) - 1
    if (mod(number, i) == 0) write (*,*) i, number/i
  end do

  ! Check to see if number is a square
  i = int(sqrt(real(number)))
  if (i*i == number) then
     write (*,*) i
  else if (mod(number, i) == 0) then
     write (*,*) i, number/i
  end if

end program


      SUBROUTINE AVEVAR(DATA,N,AVE,VAR)
      DIMENSION DATA(N)
      AVE=0.0
      VAR=0.0
      DO 11 J=1,N
        AVE=AVE+DATA(J)
11    CONTINUE
      AVE=AVE/N
      DO 12 J=1,N
        S=DATA(J)-AVE
        VAR=VAR+S*S
12    CONTINUE
      VAR=VAR/(N-1)
      RETURN
      END


Function fdpiel(s)
  Parameter (srt0=2.012)
  If (s<=srt0**2) Then
    fdpiel = 0.
  Else
    fdpiel = 63.*exp(-(s-4.67)**2/0.15) + 15.*exp(-(s-6.25)**2/0.3)
  End If
  Return
End Function fdpiel


    program dsm_test

    !! This is a test program for subroutines [[dsm]] and [[fdjs]].
    !! the test data represents a neutron kinetics problem.
    !!
    !!### Reference
    !!  * Argonne National Laboratory. MINPACK Project. July 1983.
    !!    Thomas F. Coleman, Burton S. Garbow, Jorge J. More
    !!  * Thomas F. Coleman, Burton S. Garbow, Jorge J. More, "Algorithm 618:
    !!    FORTRAN subroutines for estimating sparse Jacobian Matrices",
    !!    ACM Transactions on Mathematical Software (TOMS),
    !!    Volume 10 Issue 3, Sept. 1984, Pages 346-347

    use dsm_module
    use iso_fortran_env, only: output_unit,wp => real64

    implicit none

      integer,parameter :: nwrite = output_unit  !! unit for printing

      integer i , info , ip , j , jp , l , m , maxgrp , maxrow , &
              mingrp , minrow , n , nnz , numgrp
      integer indcol(6000) , indrow(6000) , ipntr(1201) , jpntr(1201) , &
              ngrp(1200)
      logical col
      real(wp) :: dnsm , errij , errmax , fjact , fjactr , sum
      real(wp) :: d(1200) , fjac(6000) , fjacd(1200) , fvec(1200) , x(1200) ,  &
                  xd(1200)

      col = .true.
!
!     TEST FOR DSM AND FDJS.
!
      write (nwrite,99001)
!
!     FORMAT STATEMENTS.
!
99001 format (//' TESTS FOR DSM AND FDJS - NEUTRON KINETICS PROBLEM'//  &
             &' STATISTICS GENERATED '//'       N - NUMBER OF COLUMNS '/&
             &'     NNZ - NUMBER OF NON-ZERO ELEMENTS'/                 &
             &'    DNSM - MATRIX DENSITY (PERCENTAGE)'/                 &
             &'  MINROW - MINIMUM NUMBER OF NON-ZEROS IN ANY ROW'/      &
             &'  MAXROW - MAXIMUM NUMBER OF NON-ZEROS IN ANY ROW'/      &
             &'  MINGRP - LOWER BOUND ON NUMBER OF GROUPS'/             &
             &'  MAXGRP - NUMBER OF GROUPS DETERMINED BY DSM'//)
      do n = 300 , 1200 , 300
         write (nwrite,99002)
99002    format (//3x,'N',6x,'NNZ',5x,'DNSM',5x,'MINROW',4x,'MAXROW',4x,&
                &'MINGRP',4x,'MAXGRP'//)
!
!        DEFINITION OF SPARSITY PATTERN.
!
         m = n
         l = n/3
         nnz = 0
         do j = 1 , n
            nnz = nnz + 1
            indrow(nnz) = j
            indcol(nnz) = j
            if ( mod(j,l)/=0 ) then
               nnz = nnz + 1
               indrow(nnz) = j + 1
               indcol(nnz) = j
            endif
            if ( j<=2*l ) then
               nnz = nnz + 1
               indrow(nnz) = j + l
               indcol(nnz) = j
               if ( mod(j,l)/=1 ) then
                  nnz = nnz + 1
                  indrow(nnz) = j - 1
                  indcol(nnz) = j
               endif
            endif
            nnz = nnz + 1
            if ( j>l ) then
               indrow(nnz) = j - l
            else
               indrow(nnz) = j + 2*l
            endif
            indcol(nnz) = j
         enddo
!
!        CALL DSM.
!
         call dsm(m,n,nnz,indrow,indcol,ngrp,maxgrp,mingrp,info,ipntr,jpntr)
         if ( info<=0 ) write (nwrite,99003) info
99003    format (//' *** MISTAKE IN INPUT DATA, INFO IS ***',i6)
!
!        STATISTICS FOR THE MATRIX.
!
         maxrow = 0
         minrow = n
         do i = 1 , m
            maxrow = max(maxrow,ipntr(i+1)-ipntr(i))
            minrow = min(minrow,ipntr(i+1)-ipntr(i))
         enddo
         dnsm = real(100*nnz,wp)/real(m*n,wp)
         write (nwrite,99004) n , nnz , dnsm , minrow , maxrow , &
                            & mingrp , maxgrp
99004    format (2(i5,3x),f6.2,4x,4(i5,5x))
!
!        TEST FOR FDJS.
!
         do j = 1 , n
            x(j) = real(j,wp)/real(n,wp)
         enddo
         call fcn(n,x,indcol,ipntr,fvec)
!
!        APPROXIMATE THE JACOBIAN MATRIX.
!
         do numgrp = 1 , maxgrp
            do j = 1 , n
               d(j) = 0.0_wp
               if ( ngrp(j)==numgrp ) d(j) = 1.0e-6_wp !d(j) = 0.001_wp
               xd(j) = x(j) + d(j)
            enddo
            call fcn(n,xd,indcol,ipntr,fjacd)
            do i = 1 , m
               fjacd(i) = fjacd(i) - fvec(i)
            enddo
            if ( col ) then
               call fdjs(m,n,col,indrow,jpntr,ngrp,numgrp,d,fjacd,fjac)
            else
               call fdjs(m,n,col,indcol,ipntr,ngrp,numgrp,d,fjacd,fjac)
            endif
         enddo
!
!        TEST THE APPROXIMATION TO THE JACOBIAN.
!
         errmax = 0.0_wp
         if ( col ) then
!
!           TEST FOR THE COLUMN-ORIENTED DEFINITION OF
!           THE SPARSITY PATTERN.
!
            do j = 1 , n
               do jp = jpntr(j) , jpntr(j+1) - 1
                  i = indrow(jp)
                  sum = 0.0_wp
                  do ip = ipntr(i) , ipntr(i+1) - 1
                     sum = sum + x(indcol(ip))
                  enddo
                  sum = sum + x(i)
                  fjact = 1.0_wp + 2.0_wp*sum
                  if ( i==j ) fjact = 2.0_wp*fjact
                  errij = fjac(jp) - fjact
                  if ( fjact/=0.0_wp ) errij = errij/fjact
                  errmax = max(errmax,abs(errij))
               enddo
            enddo
         else
!
!           TEST FOR THE ROW-ORIENTED DEFINITION OF
!           THE SPARSITY PATTERN.
!
            do i = 1 , m
               sum = 0.0_wp
               do ip = ipntr(i) , ipntr(i+1) - 1
                  sum = sum + x(indcol(ip))
               enddo
               sum = sum + x(i)
               fjactr = 1.0_wp + 2.0_wp*sum
               do ip = ipntr(i) , ipntr(i+1) - 1
                  j = indcol(ip)
                  fjact = fjactr
                  if ( i==j ) fjact = 2.0_wp*fjact
                  errij = fjac(ip) - fjact
                  if ( fjact/=0.0_wp ) errij = errij/fjact
                  errmax = max(errmax,abs(errij))
               enddo
            enddo
         endif
         write (nwrite,99005) errmax
99005    format (//' LARGEST RELATIVE ERROR OF APPROXIMATION IS',e10.2)
         col = .not.col
      enddo
      stop

  contains

      subroutine fcn(n,x,Indcol,Ipntr,Fvec)

      !! Function subroutine for testing [[fdjs]].

      implicit none

      integer n
      integer Indcol(*) , Ipntr(n+1)
      real(wp) ::x(n) , Fvec(n)

      integer i , ip
      real(wp) :: sum

      do i = 1 , n
         sum = 0.0_wp
         do ip = Ipntr(i) , Ipntr(i+1) - 1
            sum = sum + x(Indcol(ip))
         enddo
         sum = sum + x(i)
         Fvec(i) = sum*(1.0_wp+sum) + 1.0_wp
      enddo

      end subroutine fcn

    end program dsm_test


C ------------------------------------------------------------------------------
C CONDITIONAL DISTRIBUTON:

      DOUBLE PRECISION FUNCTION DIST(Z, HH, SKEW, SHAPE, NDIST)
      IMPLICIT NONE
      INTEGER NDIST
      DOUBLE PRECISION Z, HH, SKEW, SHAPE
      DOUBLE PRECISION DNORM, DSNORM, DSTD, DSSTD, DGED, DSGED
      IF (NDIST.EQ.10) THEN
C        NORMAL:
         DIST = DNORM(Z/HH)/HH
         RETURN
      END IF
      IF (NDIST.EQ.11) THEN
C        SKEW NORMAL:
         DIST = DSNORM(Z/HH, SKEW)/HH
         RETURN
      END IF
      IF (NDIST.EQ.20) THEN
C        STUDENT-T:
         DIST = DSTD(Z/HH, SHAPE)/HH
         RETURN
      END IF
      IF (NDIST.EQ.21) THEN
C        SKEW STUDENT-T:
         DIST = DSSTD(Z/HH, SHAPE, SKEW)/HH
         RETURN
      END IF
      IF (NDIST.EQ.30) THEN
C        GED:
         DIST = DGED(Z/HH, SHAPE)/HH
         RETURN
      END IF
      IF (NDIST.EQ.31) THEN
C        SKEW GED:
         DIST = DSGED(Z/HH, SHAPE, SKEW)/HH
         RETURN
      END IF
      RETURN
      END

C ------------------------------------------------------------------------------
C NORMAL:

      DOUBLE PRECISION FUNCTION DNORM(X)
      IMPLICIT NONE
      DOUBLE PRECISION X
      DOUBLE PRECISION PI, TWO
      PI = 3.141592653589793D0
      TWO = 2.0D0
      DNORM = DEXP(-X**2/TWO) / DSQRT(TWO*PI)
      RETURN
      END

C ------------------------------------------------------------------------------
C SKEW NORMAL:

      DOUBLE PRECISION FUNCTION DSNORM(X, XI)
      IMPLICIT NONE
      DOUBLE PRECISION X, XI
      DOUBLE PRECISION ONE, TWO, PI, M1, MU, SIGMA
      DOUBLE PRECISION Z, XXI, G
      DOUBLE PRECISION DNORM
      ONE = 1.0D0
      TWO = 2.0D0
      PI = 3.141592653589793D0
      M1 = TWO/DSQRT(TWO*PI)
      MU = M1*(XI-ONE/XI)
      SIGMA = DSQRT((ONE-M1**2)*(XI**2+ONE/XI**2)+TWO*M1**2-ONE)
      Z = X*SIGMA+MU
      XXI = XI**SIGN(ONE, Z)
      IF (Z.EQ.0.0D0) THEN
        XXI = XI**0.0D0
      END IF
      G = TWO/(XI+ONE/XI)
      DSNORM = G*DNORM(Z/XXI)*SIGMA
      RETURN
      END

C ------------------------------------------------------------------------------
C GED:

      DOUBLE PRECISION FUNCTION DGED(X, NU)
      IMPLICIT NONE
      DOUBLE PRECISION X, NU
      DOUBLE PRECISION HALF, ONE, TWO, THREE, LAMBDA, G
      DOUBLE PRECISION DGAM
      HALF = 0.50D0
      ONE = 1.0D0
      TWO = 2.0D0
      THREE = 3.0D0
      LAMBDA = DSQRT(TWO**(-TWO/NU)*DGAM(ONE/NU)/DGAM(THREE/NU))
      G = NU/(LAMBDA*(TWO**(ONE+ONE/NU))*DGAM(ONE/NU))
      DGED = G*DEXP(-HALF*(DABS(X/LAMBDA))**NU)
      RETURN
      END

C ------------------------------------------------------------------------------
C SKEW GED:

      DOUBLE PRECISION FUNCTION DSGED(X, NU, XI)
      IMPLICIT NONE
      DOUBLE PRECISION X, NU, XI
      DOUBLE PRECISION HALF, ONE, TWO, THREE, LAMBDA, G, M1, MU
      DOUBLE PRECISION SIGMA, Z, XXI
      DOUBLE PRECISION DGAM, DGED
      HALF = 0.50D0
      ONE = 1.0D0
      TWO = 2.0D0
      THREE = 3.0D0
      LAMBDA = DSQRT(TWO**(-TWO/NU)*DGAM(ONE/NU)/DGAM(THREE/NU))
      G = NU/(LAMBDA*(TWO**(ONE+ONE/NU))*DGAM(ONE/NU))
      M1 = (TWO**(ONE/NU))*LAMBDA*DGAM(TWO/NU)/DGAM(ONE/NU)
      MU = M1*(XI-ONE/XI)
      SIGMA = (ONE-M1**2)*(XI**2+ONE/(XI**2))+TWO*(M1**2)-ONE
      SIGMA = DSQRT(SIGMA)
      Z = X*SIGMA+MU
      XXI = XI**SIGN(ONE, Z)
      IF (Z.EQ.0.0D0) THEN
        XXI = XI**0.0D0
      END IF
      DSGED = (TWO/(XI+ONE/XI))*DGED(Z/XXI, NU)*SIGMA
      RETURN
      END

C ------------------------------------------------------------------------------
C STUDENT T:

      DOUBLE PRECISION FUNCTION DT(X, NU)
      IMPLICIT NONE
      DOUBLE PRECISION X, NU
      DOUBLE PRECISION ONE, TWO, PI, A, B
      DOUBLE PRECISION DGAM
      ONE = 1.0D0
      TWO = 2.0D0
      PI = 3.141592653589793D0
      A = DGAM((NU+ONE)/TWO)/DSQRT(PI*NU)
      B = DGAM(NU/TWO)*(ONE+(X*X)/NU)**((NU+ONE)/TWO)
      DT = A/B
      RETURN
      END

C ------------------------------------------------------------------------------
C STANDARDIZED STUDENT T:

      DOUBLE PRECISION FUNCTION DSTD(X, NU)
      IMPLICIT NONE
      DOUBLE PRECISION X, NU
      DOUBLE PRECISION TWO, S
      DOUBLE PRECISION DT
      TWO = 2.0D0
      S = DSQRT(NU/(NU-TWO))
      DSTD = S*DT(X*S,NU)
      RETURN
      END

C ------------------------------------------------------------------------------
C STANDARDIZED SKEW STUDENT T:

      DOUBLE PRECISION FUNCTION DSSTD(X, NU, XI)
      IMPLICIT NONE
      DOUBLE PRECISION X, NU, XI
      DOUBLE PRECISION ONE, TWO, A, B, BETA, M1, MU
      DOUBLE PRECISION SIGMA, Z, G, XXI
      DOUBLE PRECISION DSTD, DGAM
      ONE = 1.0D0
      TWO = 2.0D0
      A = ONE/TWO
      B = NU/TWO
      BETA = (DGAM(A)/DGAM(A+B))*DGAM(B)
      M1 = TWO*DSQRT(NU-TWO)/(NU-ONE)/BETA
      MU = M1*(XI-ONE/XI)
      SIGMA = DSQRT((ONE-M1**2)*(XI**2+ONE/XI**2)+TWO*M1**2-ONE)
      Z = X*SIGMA+MU
      XXI = XI**SIGN(ONE, Z)
      IF (Z.EQ.0.0D0) THEN
        XXI = XI**0.0D0
      END IF
      G = TWO/(XI+ONE/XI)
      DSSTD = G*DSTD(Z/XXI,NU)*SIGMA
      RETURN
      END


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    ! variable declaration
    implicit none
    real*8 :: eta = 1.6d0
    real*8 :: c(2) = (/0.6d0, 0.8d0/)

contains

    ! function that defines the oligopoly equations
    function cournot(q)

        implicit none
        real*8, intent(in) :: q(:)
        real*8 :: cournot(size(q, 1)),QQ
        integer :: i

        QQ = sum(q)
        do i = 1,size(q, 1)
            cournot(i) = QQ**(-1d0/eta)-1d0/eta*QQ**(-1d0/eta-1)*q(i)-c(i)*q(i)
        enddo

    end function cournot

end module


! Created by EverLookNeverSee@GitHub on 5/28/20
! For more information see FCS/img/Exercise_01.png

program main
    ! I --> current(amps)
    ! E --> voltage(volts)
    ! R --> resistance(ohms)
    ! L --> inductance(henrys)
    ! C --> capacitance(farads)
    ! f --> frequency(herts)
    implicit none
    ! declaring variables
    real :: I, E, R, L, C, f
    ! getting user input
    print *, "Enter values for E, R, L, C, and f respectively:"
    read *, E, R, L, C, f
    ! calculating I and printing the result
    I = E / sqrt(R ** 2 + ((2.0 * 3.1415 / L) - 1.0 / (2.0 * 3.1415 * f * C)) ** 2)
    print "(a3,f13.9)", "I: ", I
end program main


      real*8 function qman(x1,x2,x3,x4) result (r_qman)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates flow rate or flow velocity using Manning's
!!    equation. If x1 is set to 1, the velocity is calculated. If x1 is set to
!!    cross-sectional area of flow, the flow rate is calculated.

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    x1          |m^2 or none   |cross-sectional flow area or 1.
!!    x2          |m             |hydraulic radius
!!    x3          |none          |Manning's "n" value for channel
!!    x4          |m/m           |average slope of channel
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    qman        |m^3/s or m/s  |flow rate or flow velocity
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

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

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

      real*8, intent (in) :: x1, x2, x3, x4

      r_qman = 0.
      r_qman = x1 * x2 ** .6666 * Sqrt(x4) / x3

      return
      end


c     =====================================================
      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,mx,my,
     &     xlower,ylower, dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Sample scalar equation with data that is piecewise constant with
c     # q = 1.0  if  0.1 < x < 0.6   and   0.1 < y < 0.6
c     #     0.1  otherwise
c
      implicit double precision (a-h,o-z)
      dimension q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)

      double precision a(3,3)

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

      f(x,y)=dsin(8d0*datan(1d0)*x)*dsin(8d0*datan(1d0)*y)

      a(1,1)=1d0
      a(1,2)=4d0
      a(1,3)=1d0
      a(2,1)=4d0
      a(2,2)=16d0
      a(2,3)=4d0
      a(3,1)=1d0
      a(3,2)=4d0
      a(3,3)=1d0

      do 20 j=1-mbc,my+mbc
         do 10 i=1-mbc,mx+mbc
            q(i,j,1)=0d0
   10       continue
   20    continue

      do 22 j=1-mbc,my+mbc
         yj = ylower + (j-1d0)*dy
         do 12 i=1-mbc,mx+mbc
            xi = xlower + (i-1d0)*dx
            do 33 k=0,2
               do 44 l=0,2
                  q(i,j,1)=q(i,j,1)+(1d0/36d0)*a(k+1,l+1)
     &                     * f(dx*k/2d0+xi,dy*l/2d0+yj)
   44             continue
   33          continue
   12       continue
   22    continue

      return
      end


      subroutine GAUSSJ(a,n,np,b,m,mp,ierr)

c  Purpose: Solution of the system of linear equations AX = B by
c     Gauss-Jordan elimination, where A is a matrix of order N and B is
c     an N x M matrix.  On output A is replaced by its matrix inverse
c     and B is preplaced by the corresponding set of solution vectors.

c  Source: W.H. Press et al, "Numerical Recipes," 1989, p. 28.

c  Modifications:
c     1. Double  precision.
c     2. Error parameter IERR included.  0 = no error. 1 = singular
c        matrix encountered; no inverse is returned.

c  Prepared by J. Applequist, 8/17/91.

c        Set largest anticipated value of N.

      parameter (nmax=500)
      dimension a(np,np),b(np,mp),ipiv(nmax),indxr(nmax),indxc(nmax)

      ierr=0
      do 11 j=1,n
      ipiv(j)=0
 11   continue
      do 22 i=1,n
      big=0.d0
      do 13 j=1,n
      if (ipiv(j).ne.1) then
      do 12 k=1,n
      if (ipiv(k).eq.0) then
      if (abs(a(j,k)).ge.big) then
      big=abs(a(j,k))
      irow=j
      icol=k
      endif
      else if (ipiv(k).gt.1) then
      ierr=1
      return
      endif
 12   continue
      endif
 13   continue
      ipiv(icol)=ipiv(icol)+1
      if (irow.ne.icol) then
      do 14 l=1,n
      dum=a(irow,l)
      a(irow,l)=a(icol,l)
      a(icol,l)=dum
 14   continue
      do 15 l=1,m
      dum=b(irow,l)
      b(irow,l)=b(icol,l)
      b(icol,l)=dum
 15   continue
      endif
      indxr(i)=irow
      indxc(i)=icol
      if (a(icol,icol).eq.0.d0) then
      ierr=1
      return
      endif
      pivinv=1.d0/a(icol,icol)
      a(icol,icol)=1.d0
      do 16 l=1,n
      a(icol,l)=a(icol,l)*pivinv
 16   continue
      do 17 l=1,m
      b(icol,l)=b(icol,l)*pivinv
 17   continue
      do 21 ll=1,n
      if (ll.ne.icol) then
      dum=a(ll,icol)
      a(ll,icol)=0.d0
      do 18 l=1,n
      a(ll,l)=a(ll,l)-a(icol,l)*dum
 18   continue
      do 19 l=1,m
      b(ll,l)=b(ll,l)-b(icol,l)*dum
 19   continue
      endif
 21   continue
 22   continue
      do 24 l=n,1,-1
      if (indxr(l).ne.indxc(l)) then
      do 23 k=1,n
      dum=a(k,indxr(l))
      a(k,indxr(l))=a(k,indxc(l))
      a(k,indxc(l))=dum
 23   continue
      endif
 24   continue
      return
      end


      Subroutine plegendr(n,x,pn,dpn)

Cf2py intent(in) n,x
Cf2py intent(out) pn,dpn
	implicit none

	integer n,m,i
	real*8 x,x2,x3,x4,x5,pn,dpn
	real*8 pn_1,pn_2,dpn_1,dpn_2

	x2=x*x
	x4=x2*x2

	if (n.eq.0) then
	  pn=1.
	  dpn=0.
	elseif (n.eq.1) then
	  pn = x
	  dpn = 1.
	elseif (n.eq.2) then
	  x2=x*x
	  pn=1.5*x2-.5
	  dpn=3.*x
	elseif (n.eq.3) then
	  x2=x*x
	  x3=x2*x
	  pn=2.5*x3-1.5*x
	  dpn=7.5*x2-1.5
	elseif (n.eq.4) then
	  x2=x*x
	  x3=x2*x
	  x4=x3*x
	  pn=4.375*x4-3.75*x2+.375
	  dpn=17.5*x3-7.5*x
	elseif (n.eq.5) then
	  x2=x*x
	  x3=x2*x
	  x4=x3*x
	  x5=x4*x
	  pn=7.875*x5 - 8.75*x3+1.875*x
	  dpn=39.375*x4-26.25*x2+1.875
	else
	  x2=x*x
	  x3=x2*x
	  x4=x3*x
	  x5=x4*x
	  pn_2=4.375*x4-3.75*x2+.375
	  dpn_2=17.5*x3-7.5*x
	  pn_1=7.875*x5 - 8.75*x3+1.875*x
	  dpn_1=39.375*x4-26.25*x2+1.875
	  m=5
	  do i=1,n-m
	    m=m+1
	    pn=(2.-1./m)*x*pn_1-(1.-1./m)*pn_2
	    dpn=(2.-1./m)*(pn_1+x*dpn_1)-(1.-1./m)*dpn_2
	    pn_2=pn_1
	    dpn_2=dpn_1
	    pn_1=pn
	    dpn_1=dpn
	  enddo
	endif
	return
	end


c=======================================================================
c
c     subroutine PEGARCH
c
c     Autoregressive Conditionally Heteroskedastic (ARCH) process generator
c
c                e(t) = sigma(t)*u(t)
c
c                where
c
c                sigma(t) = sqrt[w + alpha(1)*e(t-1)^2 + ... + alpha(p)*e(t-p)^2]
c
c-----------------------------------------------------------------------
      SUBROUTINE pegarch ( T, N, P, Q, w, alpha, beta, y, sigma, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            T      : time (days, months, years)                 integer
c            N      : number of sub-division(s)                  integer
c            P      : AR process order (P >= 0)                  integer
c            Q      : MA process order (Q >= 0)                  integer
c            w      : constant parameter                          double
c            alpha  : GARCH P-parameter, vector (P)               double
c            beta   : GARCH Q-parameter, vector (Q)               double
c
c     OUTPUT
c            y      : generated process (N)                       double
c            sigma  : generated conditional volatility (N)        double
c            info   : diagnostic information                     integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER N, T, P, Q, info
      DOUBLE PRECISION w, alpha(*), beta(*), y(*), sigma(*)
c
c     local variables
      INTEGER M, i, j, k
      DOUBLE PRECISION sum, epsilon
      PARAMETER (epsilon = 1.E-15)
c
c     external subroutines
      EXTERNAL PEARCH
c
c     external functions
      DOUBLE PRECISION rn
      EXTERNAL rn
c
c     intrinsic functions
      INTRINSIC max, sqrt
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     maximum order max(P,Q)
      M = max(P,Q)
c
c     case Q = 0 (ARCH process)
      IF (Q .EQ. 0) THEN
        CALL pearch ( T, N, P, w, alpha, y, sigma, info )
        RETURN
      ENDIF
c
c     test if M < 0 or M > N
      IF ((M .LT. 1).OR.(M .GT. N)) THEN
        info = -3101
        RETURN
      ENDIF
c
c     initialization step
      sum = 0.
      DO j = 1,P
        sum = sum + alpha(j)
      ENDDO
      DO j = 1,Q
        sum = sum + beta(j)
      ENDDO
c
c     test if sum(alpha+beta) < 1.
      IF (sum .GE. (1. - epsilon)) THEN
        info = -3102
        RETURN
      ENDIF
c
c     loop
      DO i = 1,M
        sigma(i) = sqrt(w/(1.-sum))
        y(i)     = sigma(i)*rn()
      ENDDO
c
c     loop
      DO i = 1,N-M
c
c        conditional volatility
         sum = w
         IF (P .GE. 1) THEN
            DO j = 1,P
              k = i + P - j
              sum = sum + alpha(j)*y(k)*y(k)
            ENDDO
         ENDIF
         IF (Q .GE. 1) THEN
            DO j = 1,Q
                k = i + Q - j
                sum = sum + beta(j)*sigma(k)*sigma(k)
            ENDDO
         ENDIF
         sigma(i + M) = sqrt(sum)
c
c        GARCH(P,Q) process
         y(i + M) = sigma(i + M)*rn()
      ENDDO
c
      RETURN
      END


      RECURSIVE FUNCTION COMMON_FACTOR(N,m,ifact) RESULT(val)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N
      INTEGER, INTENT(IN) :: m
      INTEGER, INTENT(IN) :: ifact
      INTEGER:: val

      val = 0
      IF (mod(N,m)==0) THEN
         val = m
      ELSE
         val = COMMON_FACTOR(N,m+ifact,ifact)
      END IF

      END FUNCTION COMMON_FACTOR


!>
module VortexPoint2DPeriodic
    use PrecisionMod,   only: MK
    implicit none
    real(MK),parameter :: MINNORM2=1e-8
contains
    subroutine fUi_VortexPoint2DPeriodicX_11(DeltaP,Intensity,Lambda,SmoothModel,SmoothParam,bComputeGrad,Uind, Grad)
        use MathConstants , only: twopi
        implicit none
        ! Input/output arguments
        real(MK), dimension(3), intent(in) :: DeltaP       !< 3 x 1   Pcp-Pv
        real(MK), intent(in)               :: Intensity    !<  Circulation Gamma
        real(MK), intent(in)               :: Lambda       !<  Period in the X direction
        integer, intent(in) ,optional      :: SmoothModel  !<
        real(MK), intent(inout),optional      :: SmoothParam  !<
        logical, intent(in)                :: bComputeGrad !<
        real(MK), dimension(3),intent(out) :: Uind         !< No Side effects. Note that
        real(MK), dimension(9),intent(out) :: Grad         !< No Side effects
        !         ! Variables declaration
        real(MK) :: x     !<
        real(MK) :: y     !<
        real(MK) :: r2     !<
        real(MK) :: factor !<
        real(MK) :: E      !<
        real(MK) :: rho2   !<
        real(MK) :: Qm     !<
        !
        ! No need of gradient in 2D
        if(bComputeGrad) then
            Grad(1:9)=0.0_MK !
        else
            Grad(1:9)=0.0_MK
        endif
        factor = 1._MK
        if(SmoothModel>0 .and. SmoothParam>0) then
            rho2   = r2/SmoothParam**2;
            E      = exp(-rho2);
            Qm     = 1._MK;
            factor = (1._MK-Qm*E);
            !
        else
            SmoothParam=0.0_MK
        endif
        Uind=0.0_MK

        r2  = DeltaP(1)**2+ DeltaP(2)**2
        if (r2<MINNORM2) then! to avoid strong singularity
            Uind(3)=0.0_MK
            Grad(1:9)=0.0_MK
        else
            x=DeltaP(1)*twopi/Lambda
            y=DeltaP(2)*twopi/Lambda
            Uind(1)= -(Intensity*Sinh(y))/(2.*(-Cos(x) + Cosh(y)+SmoothParam**2))
            Uind(2)=  (Intensity* Sin(x))/(2.*(-Cos(x) + Cosh(y)+SmoothParam**2))
            Uind(3)=0.0_MK

        endif

    end subroutine

end module VortexPoint2DPeriodic


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c subroutine lfin (init,theta,l,m,nm,pb,id,wlfin)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfin(4*l*(nm+1))
c arguments
c
c purpose                given m and l, routine lfin calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for n=m,...,nm and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfin (init,theta,l,m,nm,pb,id,wlfin)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and the array theta, subroutine lfin
c                            initializes the array wlfin for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization does
c                            not have to be repeated unless l, nm or
c                            the array theta are changed.
c                        = 1
c                            subroutine lfin uses the array wlfin that
c                            was computed with init = 0 to compute pb
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfin is
c                          vectorized with vector length l.
c
c                        m
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfin
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfin. (see output parameter pb)
c
c                        wlfin
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfin
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfin.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfin. the second dimension of pb must
c                          be at least nm+1. starting with m=0
c                          lfin is called repeatedly with m being
c                          increased by one between calls. on each
c                          call, subroutine lfin computes pb(i,n+1)
c                          = pbar(m,n,theta(i)) for n=m,...,nm and
c                          i=1,...l.
c
c                        wlfin
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfin must be
c                          called with init=0 to reinitialize the
c                          wlfin array.
c
c special conditions     m must be increased by one between calls
c                        of lfin in which m is not zero.
c
c precision              single
c
c algorithm              routine lfin calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      subroutine lfin (init,theta,l,m,nm,pb,id,wlfin)
      dimension       pb(1)        ,wlfin(1)
c
c     total length of wlfin is 4*l*(nm+1)
c
      lnx = l*(nm+1)
      iw1 = lnx+1
      iw2 = iw1+lnx
      iw3 = iw2+lnx
      call lfin1(init,theta,l,m,nm,id,pb,wlfin,wlfin(iw1),
     1                wlfin(iw2),wlfin(iw3),wlfin(iw2))
      return
      end
      subroutine lfin1(init,theta,l,m,nm,id,p3,phz,ph1,p1,p2,cp)
      dimension       p1(l,1)    ,p2(l,1)    ,p3(id,1)   ,phz(l,1)   ,
     1                ph1(l,1)   ,cp(1)      ,theta(1)
      nmp1 = nm+1
      if(init .ne. 0) go to 5
      ssqrt2 = 1./sqrt(2.)
      do 10 i=1,l
      phz(i,1) = ssqrt2
   10 continue
      do 15 np1=2,nmp1
      nh = np1-1
      call alfk(nh,0,cp)
      do 16 i=1,l
      call lfpt(nh,0,theta(i),cp,phz(i,np1))
   16 continue
      call alfk(nh,1,cp)
      do 17 i=1,l
      call lfpt(nh,1,theta(i),cp,ph1(i,np1))
   17 continue
   15 continue
      return
    5 mp1 = m+1
      fm = float(m)
      tm = fm+fm
      if(m-1)25,30,35
   25 do 45 np1=1,nmp1
      do 45 i=1,l
      p3(i,np1) = phz(i,np1)
      p1(i,np1) = phz(i,np1)
   45 continue
      return
   30 do 50 np1=2,nmp1
      do 50 i=1,l
      p3(i,np1) = ph1(i,np1)
      p2(i,np1) = ph1(i,np1)
   50 continue
      return
   35 temp = tm*(tm-1.)
      cc = sqrt((tm+1.)*(tm-2.)/temp)
      ee = sqrt(2./temp)
      do 85 i=1,l
      p3(i,m+1) = cc*p1(i,m-1)-ee*p1(i,m+1)
   85 continue
      if(m .eq. nm) return
      temp = tm*(tm+1.)
      cc = sqrt((tm+3.)*(tm-2.)/temp)
      ee = sqrt(6./temp)
      do 70 i=1,l
      p3(i,m+2) = cc*p1(i,m)-ee*p1(i,m+2)
   70 continue
      mp3 = m+3
      if(nmp1 .lt. mp3) go to 80
      do 75 np1=mp3,nmp1
      n = np1-1
      fn = float(n)
      tn = fn+fn
      cn = (tn+1.)/(tn-3.)
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      dd = sqrt(cn*fnmm*(fnmm-1.)/temp)
      ee = sqrt((fnmm+1.)*(fnmm+2.)/temp)
      do 75 i=1,l
      p3(i,np1) = cc*p1(i,np1-2)+dd*p3(i,np1-2)-ee*p1(i,np1)
   75 continue
   80 do 90 np1=m,nmp1
      do 90 i=1,l
      p1(i,np1) = p2(i,np1)
      p2(i,np1) = p3(i,np1)
   90 continue
      return
      end


! $UWHPSC/codes/fortran/vectorops.f90

program vectorops

    implicit none
    real(kind=8), dimension(3) :: x, y

    x = (/10.,20.,30./)
    y = (/100.,400.,900./)

    print *, "x = "
    print *, x

    print *, "x**2 + y = "
    print *, x**2 + y

    print *, "x*y = "
    print *, x*y

    print *, "sqrt(y) = "
    print *, sqrt(y)

    print *, "dot_product(x,y) = "
    print *, dot_product(x,y)

end program vectorops


module simplex
    use sort_n_swap
    implicit none

    ! FOR COMPILATION WITH F2PY COPY DECLARATIONS INTO SUBROUTINES

    ! parameters
    ! reflection, expansion, contraction, shrinking
    real(8), parameter :: a = 1.d0, g = 2.d0, q = .5d0, s = .5d0
    ! dimension
    integer, parameter :: n = 2

    ! indices
    ! integer, dimension(3) :: idx
    ! values fn(x)
    real(8), dimension(n+1) :: z
    ! middle, reflected, expanded, contracted
    real(8), dimension(n) :: m, r, e, c
    ! reflected value
    real(8) :: fr
    ! loop index
    integer :: i

contains
    subroutine step(x, fn)
        ! arguments
        real(8), dimension(n, n+1), intent(inout) :: x
        ! declaring fn two times is required for compilation with f2py
        real(8) :: fn
        external :: fn

        ! calculate and sort values fn(x)
        ! ONLY FOR size(x) == 3
        z = [( fn(x(:, i)), i=1,n+1 )]
        call sort3r(x, z)
        ! argsort doesn't quite work yet...
        ! idx = argsort3(z)
        ! z = z(idx)
        ! x = x(:,idx)

        ! calculate middle, omitting x(:,n+1)
        m = sum(x(:,1:n), dim=1) / n

        ! calculate reflection
        r = m + a*(m - x(:, n+1))
        fr = fn(r)
        if (z(1) <= fr .and. fr <= z(n)) then
            x(:, n+1) = r
            return
        end if

        ! calculate expansion
        if (fr < z(1)) then
            e = m + g*(r - m)
            if (fn(e) < fr) then
                x(:, n+1) = e
            else
                x(:, n+1) = r
            end if
            return
        end if

        ! calculate contraction
        ! here it is known, that fn(r) >= fn(x(n))
        c = m + q*(x(:, n+1) - m)
        if (fn(c) < z(n+1)) then
            x(:, n+1) = c
            return
        end if

        ! if all else fails: shrinking
        do i=2, n+1
            x(:, i) = x(:, 1) + s*(x(:, i) - x(:, 1))
        end do
        return
    end subroutine step

    subroutine find(x, fn, tol, maxiter, conv)
        ! arguments
        real(8), dimension(n, n+1), intent(inout) :: x
        ! declaring fn two times is required for compilation with f2py
        real(8) :: fn
        external :: fn
        real(8), intent(in) :: tol
        integer, intent(in) :: maxiter
        logical, intent(out) :: conv
        integer :: step
        conv = .false.
        step = 0

        100 step = step + 1
        if (all(std(x, n) < tol)) then
            conv = .true.
            return
        else if (step > maxiter) then
            return
        end if

        ! calculate and sort values fn(x)
        ! ONLY FOR size(x) == 3
        z = [( fn(x(:, i)), i=1,n+1 )]
        call sort3r(x, z)

        ! calculate middle, omitting x(:,n+1)
        m = sum(x(:,1:n), dim=1) / n

        ! calculate reflection
        r = m + a*(m - x(:, n+1))
        fr = fn(r)
        if (z(1) <= fr .and. fr <= z(n)) then
            x(:, n+1) = r
            goto 100
        end if

        ! calculate expansion
        if (fr < z(1)) then
            e = m + g*(r - m)
            if (fn(e) < fr) then
                x(:, n+1) = e
            else
                x(:, n+1) = r
            end if
            goto 100
        end if

        ! calculate contraction
        ! here it is known, that fn(r) >= fn(x(n))
        c = m + q*(x(:, n+1) - m)
        if (fn(c) < z(n+1)) then
            x(:, n+1) = c
            goto 100
        end if

        ! if all else fails: shrinking
        do i=2, n+1
            x(:, i) = x(:, 1) + s*(x(:, i) - x(:, 1))
        end do
        goto 100
    end subroutine find

end module simplex

program test
    use simplex, only: step, find
    implicit none
    ! integer :: i
    real(8), dimension(2, 3) :: x = reshape([-1., -3.5, 0., -4.5, 1., -3.5], &
                                            [2, 3])
    logical :: conv

    100 format(2(3(3X, F9.6)/))

    call find(x, himmelblau, 1d-7, 100, conv)
    print 100, transpose(x)
    print *, 'convergence: ', conv

    ! print 100, transpose(x)
    ! do i=1, 20
    !     call step(x, himmelblau)
    !     print 100, transpose(x)
    ! end do

contains
    real(8) pure &
    function himmelblau(x)
        real(8), dimension(2), intent(in) :: x
        himmelblau = (x(1)**2+x(2)-11d0)**2 + (x(1)+x(2)**2-7d0)**2
    end function himmelblau

end program


      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      program conv_exp

      ! Test convolution of two DLR expansions for Green's functions
      ! which are each a single exponential. Compare result with
      ! analytically-known convolution. Test two methods of
      ! convolution; directly forming matrix of convolution, and fast
      ! convolution in the DLR coefficient domain.

      implicit none
      integer ntst
      real *8 lambda,eps,beta

      ! Input parameters

      lambda = 1000.0d0   ! DLR high energy cutoff
      eps = 1.0d-14       ! DLR error tolerance

      ntst = 10000        ! # imaginary time test points
      beta = 1000.0d0     ! Inverse temperature

      ! Main test subroutine

      call conv_exp_main(lambda,eps,ntst,beta)

      end program conv_exp

      subroutine conv_exp_main(lambda,eps,ntst,beta)

      implicit none
      integer ntst
      real *8 lambda,eps,beta

      integer i,j,r
      integer, allocatable :: it2cfp(:)
      real *8 one,gtrue,gtst1,gtst2
      real *8 err1l2,err2l2,err1linf,err2linf,gmax,gl2
      real *8, allocatable :: dlrit(:),dlrrf(:)
      real *8, allocatable :: cf2it(:,:),it2cf(:,:),fstconv(:,:)
      real *8, allocatable :: ttst(:),g1(:),g2(:),g31(:),g32(:)

      real *8, allocatable :: phi(:,:),gmat(:,:)

      one = 1.0d0

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

      allocate(dlrrf(r),dlrit(r))

      call dlr_it_build(lambda,eps,r,dlrrf,dlrit)

      ! Get DLR coefficients -> imaginary time values matrix

      allocate(cf2it(r,r))

      call dlr_cf2it_init(r,dlrrf,dlrit,cf2it)

      ! Get imaginary time values -> DLR coefficients matrix (LU form)

      allocate(it2cf(r,r),it2cfp(r))

      call dlr_it2cf_init(r,dlrrf,dlrit,it2cf,it2cfp)

      ! Sample G1 and G2 at imaginary time nodes

      allocate(g1(r),g2(r),g31(r),g32(r))

      do i=1,r

        call gfun1(beta,dlrit(i),g1(i))
        call gfun2(beta,dlrit(i),g2(i))

      enddo

      ! Get convolution tensor

      allocate(phi(r*r,r))

      call dlr_convtens(beta,-1,r,dlrrf,dlrit,it2cf,it2cfp,phi)

      ! Get matrix of convolution by G1

      allocate(gmat(r,r))

      call dlr_convmat(r,1,it2cf,it2cfp,phi,g1,gmat)

      ! Get convolution G3 of G1 with G2

      call dlr_conv(r,1,gmat,g2,g31)

      ! Get DLR coefficients of G3

      call dlr_it2cf(r,1,it2cf,it2cfp,g31,g31)

      ! Initialize fast convolution routine

      allocate(fstconv(r,2*r))

      call dlr_fstconv_init(beta,r,dlrrf,dlrit,cf2it,fstconv)

      ! Get convolution G3 of G1 with G2 by fast convolution

      call dlr_fstconv(r,1,cf2it,it2cf,it2cfp,fstconv,g1,g2,g32)

      ! Get DLR coefficients of G3

      call dlr_it2cf(r,1,it2cf,it2cfp,g32,g32)

      ! Get test points in relative format

      allocate(ttst(ntst))

      call eqpts_rel(ntst,ttst)

      ! Measure L^inf and L^2 errors of convolution

      err1linf = 0*one
      err1l2 = 0*one
      err2linf = 0*one
      err2l2 = 0*one
      gmax = 0*one
      gl2 = 0*one

      do i=1,ntst

        ! Evaluate true convolution

        call gfun3(beta,ttst(i),gtrue)

        ! Evaluate DLR

        call dlr_it_eval(r,1,dlrrf,g31,ttst(i),gtst1)
        call dlr_it_eval(r,1,dlrrf,g32,ttst(i),gtst2)

        ! Update L^inf and L^2 errors, norms

        err1linf = max(err1linf,abs(gtrue-gtst1))
        err1l2 = err1l2 + (gtrue-gtst1)**2
        err2linf = max(err2linf,abs(gtrue-gtst2))
        err2l2 = err2l2 + (gtrue-gtst2)**2

        gmax = max(gmax,abs(gtrue))
        gl2 = gl2 + gtrue**2

      enddo

      err1l2 = sqrt((ttst(2)-ttst(1))*err1l2)
      err2l2 = sqrt((ttst(2)-ttst(1))*err2l2)
      gl2 = sqrt((ttst(2)-ttst(1))*gl2)

      write(6,*) ''
      write(6,*) 'DLR rank = ',r
      write(6,*) 'Abs L^inf err = ',err1linf
      write(6,*) 'Abs L^2 err   = ',err1l2
      write(6,*) 'Rel L^inf err = ',err1linf/gmax
      write(6,*) 'Rel L^2 err   = ',err1l2/gl2

      write(6,*) 'Abs L^inf err = ',err2linf
      write(6,*) 'Abs L^2 err   = ',err2l2
      write(6,*) 'Rel L^inf err = ',err2linf/gmax
      write(6,*) 'Rel L^2 err   = ',err2l2/gl2
      write(6,*) ''

      ! Return failed status if error is not sufficiently small

      if (err1linf.gt.1.0d-13.or.err2linf.gt.1.0d-13) then
        call exit(1)
      endif

      end subroutine conv_exp_main

      subroutine gfun1(beta,t,g)

      ! Evaluate single exponential Green's function

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a1

      a1 = 0.804d0

      g = kfunf_rel(t,beta*a1)

      end subroutine gfun1

      subroutine gfun2(beta,t,g)

      ! Evaluate single exponential Green's function

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a2

      a2 = -0.443d0

      g = kfunf_rel(t,beta*a2)

      end subroutine gfun2

      subroutine gfun3(beta,t,g)

      ! Evaluate Green's function corresponding to convolution of two
      ! single exponentials

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a1,a2

      a1 = 0.804d0
      a2 = -0.443d0

      g = (kfunf_rel(t,beta*a2)-kfunf_rel(t,beta*a1))/(a1-a2)

      end subroutine gfun3


! { dg-do compile }
!
! PR fortran/53732
! this was leading to an internal "mismatching comparison operand types"
! error.
!
! Original testcase by minzastro <minzastro@googlemail.com>
! Fixed by Dominique Dhumieres <dominiq@lps.ens.fr>

program test
implicit none

real(8) arr(4,4,4,4)

arr(:,:,:,:) = 1d0

arr(1,:,:,:) = sum(arr, dim=1, mask=(arr(:,:,:,:) > 0d0))

end program test


program FIRDMAIN

  implicit none

  ! LOCAL SCALARS
  integer :: flag,ftype,i,me,mi,n,fcnt
  logical :: verbose
  real(8) :: epsfeas,epsopt,f,feas

  ! LOCAL ARRAYS
  real(8), allocatable :: l(:), u(:), x(:)

  n  = 2
  me = 1
  mi = 0

  allocate(x(n),l(n),u(n))

  x(1) = 5.0D0
  x(2) = 5.0D0

  l(1) = - 1.0D+20
  l(2) = - 1.0D+20
  u(1) =   1.0D+20
  u(2) =   1.0D+20

  verbose = .true.

  epsfeas = 1.0D-8
  epsopt  = 1.0D-4

  ftype = 1

  call fird(n,x,l,u,me,mi,evalf,evalc,evaljac,verbose,ftype, &
       epsfeas,epsopt,f,feas,fcnt,flag)

  deallocate(x,l,u)

contains

  !------------------------------------------------------------!
  ! SUBROUTINE EVALF                                           !
  !                                                            !
  ! Defines the objetive function.                             !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evalf(n,x,f,flag)

    ! SCALAR ARGUMENTS
    integer :: flag,n
    real(8) :: f

    ! ARRAY ARGUMENTS
    real(8) :: x(n)

    intent(in ) :: n,x
    intent(out) :: f,flag

    flag = 0

    f = (x(1) * x(2)) ** 2.0D0

  end subroutine evalf

  !------------------------------------------------------------!
  ! SUBROUTINE EVALC                                           !
  !                                                            !
  ! Defines the contraints.                                    !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evalc(n,x,ind,c,flag)

  ! SCALAR ARGUMENTS
  integer :: flag,ind,n
  real(8) :: c

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in ) :: ind,n,x
  intent(out) :: c,flag

  flag = 0

  if ( ind .eq. 1 ) then
     c = (x(1) - 1.0D0) ** 2.0D0 + 1.0D0 - x(2)
  else
     flag = 1
  end if

  end subroutine evalc

  !------------------------------------------------------------!
  ! SUBROUTINE EVALJAC                                         !
  !                                                            !
  ! Defines the Jacobian of the constraints.                   !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evaljac(n,x,ind,jcvar,jcval,jcnnz,flag)

    ! SCALAR ARGUMENTS
    integer :: flag,ind,jcnnz,n

    ! ARRAY ARGUMENTS
    integer :: jcvar(n)
    real(8) :: jcval(n),x(n)

    intent(in ) :: ind,n,x
    intent(out) :: flag,jcnnz,jcval,jcvar

    flag = 0

    if ( ind .eq. 1 ) then
       jcnnz = 2
       jcvar(1) = 1
       jcval(1) = 2.0D0 * (x(1) - 1.0D0)
       jcvar(2) = 2
       jcval(2) = - 1.0D0
    else
       flag = 1
    end if

  end subroutine evaljac

end program FIRDMAIN