      subroutine mkbicub(x,nx,y,ny,f,nf2,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   ibcymin,bcymin,ibcymax,bcymax,
     >   ilinx,iliny,ier)
C
C  setup bicubic spline, dynamic allocation of workspace
C  fortran-90 fixed form source
C
C  ** see mkbicubw.for **
C  arguments are identical, except the workspace argument is
C  omitted (created here)
C
C  --NOTE-- dmc 22 Feb 2004 -- rewrite for direct calculation of
C  coefficients, to avoid large transient use of memory.  mkbicubw is
C  no longer called (but reference to mkbicubw comments is still correct).
C
C  abbreviated description of arguments, mkbicubw has details:
C
      implicit NONE
C
C  input:
      integer nx                        ! length of x vector
      integer ny                        ! length of y vector
      real x(nx)                        ! x vector, strict ascending
      real y(ny)                        ! y vector, strict ascending
C
      integer nf2                       ! 2nd dimension of f, nf2.ge.nx
C  input/output:
      real f(4,nf2,ny)                  ! data & spline coefficients
C
C  input bdy condition data:
      integer ibcxmin                   ! bc flag for x=xmin
      real bcxmin(ny)                   ! bc data vs. y at x=xmin
      integer ibcxmax                   ! bc flag for x=xmax
      real bcxmax(ny)                   ! bc data vs. y at x=xmax
C
      integer ibcymin                   ! bc flag for y=ymin
      real bcymin(nx)                   ! bc data vs. x at y=ymin
      integer ibcymax                   ! bc flag for y=ymax
      real bcymax(nx)                   ! bc data vs. x at y=ymax
C
C  output linear grid flags and completion code (ier=0 is normal):
C
      integer ilinx                     ! =1: x grid is "nearly" equally spaced
      integer iliny                     ! =1: y grid is "nearly" equally spaced
C
      integer ier                       ! =0 on exit if there is no error.
C
C-----------------------
      integer ierx,iery
C
      real, dimension(:,:), allocatable :: fwk
      real :: zbcmin,zbcmax
      integer ix,iy,ibcmin,ibcmax
c
      real, dimension(:,:,:), allocatable :: fcorr
      integer iflg2
      real zdiff(2),hy
C
C-----------------------
c
c  see if 2nd pass is needed due to inhomogeneous d/dy bdy cond.
c
      iflg2=0
      if(ibcymin.ne.-1) then
         if((ibcymin.eq.1).or.(ibcymin.eq.2)) then
            do ix=1,nx
               if (bcymin(ix).ne.0.0) iflg2=1
            enddo
         endif
         if((ibcymax.eq.1).or.(ibcymax.eq.2)) then
            do ix=1,nx
               if (bcymax(ix).ne.0.0) iflg2=1
            enddo
         endif
      endif
c
c  check boundary condition specifications
c
      ier=0
c
      call ibc_ck(ibcxmin,'bcspline','xmin',-1,7,ier)
      if(ibcxmin.ge.0) call ibc_ck(ibcxmax,'bcspline','xmax',0,7,ier)
      call ibc_ck(ibcymin,'bcspline','ymin',-1,7,ier)
      if(ibcymin.ge.0) call ibc_ck(ibcymax,'bcspline','ymax',0,7,ier)
c
c  check ilinx & x vector
c
      call splinck(x,nx,ilinx,1.0e-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?bcspline:  x axis not strict ascending'')')
      endif
c
c  check iliny & y vector
c
      call splinck(y,ny,iliny,1.0e-3,iery)
      if(iery.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?bcspline:  y axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
      allocate(fwk(2,max(nx,ny)))
c
c  evaluate fxx (spline in x direction)
c
      zbcmin=0
      zbcmax=0
      do iy=1,ny
         fwk(1,1:nx) = f(1,1:nx,iy)
         if((ibcxmin.eq.1).or.(ibcxmin.eq.2)) zbcmin=bcxmin(iy)
         if((ibcxmax.eq.1).or.(ibcxmax.eq.2)) zbcmax=bcxmax(iy)
         call mkspline(x,nx,fwk,
     >      ibcxmin,zbcmin,ibcxmax,zbcmax,ilinx,ier)
         if(ier.ne.0) return
         f(2,1:nx,iy)=fwk(2,1:nx)
      enddo
c
c  evaluate fyy (spline in y direction)
c  use homogeneous boundary condition; correction done later if necessary
c
      zbcmin=0
      zbcmax=0
      ibcmin=ibcymin
      ibcmax=ibcymax
      do ix=1,nx
         fwk(1,1:ny) = f(1,ix,1:ny)
         if(iflg2.eq.1) then
            if((ibcymin.eq.1).or.(ibcymin.eq.2)) ibcmin=0
            if((ibcymax.eq.1).or.(ibcymax.eq.2)) ibcmax=0
         endif
         call mkspline(y,ny,fwk,
     >      ibcmin,zbcmin,ibcmax,zbcmax,iliny,ier)
         if(ier.ne.0) return
         f(3,ix,1:ny)=fwk(2,1:ny)
      enddo
c
c  evaluate fxxyy (spline fxx in y direction; BC simplified; avg
c  d2(d2f/dx2)/dy2 and d2(df2/dy2)/dx2
c
      zbcmin=0
      zbcmax=0
      ibcmin=ibcymin
      ibcmax=ibcymax
      do ix=1,nx
         fwk(1,1:ny) = f(2,ix,1:ny)
         if(iflg2.eq.1) then
            if((ibcymin.eq.1).or.(ibcymin.eq.2)) ibcmin=0
            if((ibcymax.eq.1).or.(ibcymax.eq.2)) ibcmax=0
         endif
         call mkspline(y,ny,fwk,
     >      ibcmin,zbcmin,ibcmax,zbcmax,iliny,ier)
         if(ier.ne.0) return
         f(4,ix,1:ny)= fwk(2,1:ny)
      enddo
c
      if(iflg2.eq.1) then
         allocate(fcorr(2,nx,ny))
c
c  correct for inhomogeneous y boundary condition
c
         do ix=1,nx
            !  the desired inhomogenous BC is the difference btw the
            !  requested derivative (1st or 2nd) and the current value

            zdiff(1)=0.0
            if(ibcymin.eq.1) then
               hy=y(2)-y(1)
               zdiff(1)=(f(1,ix,2)-f(1,ix,1))/hy +
     >            hy*(-2*f(3,ix,1)-f(3,ix,2))/6
               zdiff(1)=bcymin(ix)-zdiff(1)
            else if(ibcymin.eq.2) then
               zdiff(1)=bcymin(ix)-f(3,ix,1)
            endif

            zdiff(2)=0.0
            if(ibcymax.eq.1) then
               hy=y(ny)-y(ny-1)
               zdiff(2)=(f(1,ix,ny)-f(1,ix,ny-1))/hy +
     >            hy*(2*f(3,ix,ny)+f(3,ix,ny-1))/6
               zdiff(2)=bcymax(ix)-zdiff(2)
            else if(ibcymax.eq.2) then
               zdiff(2)=bcymax(ix)-f(3,ix,ny)
            endif
c
            fwk(1,1:ny)=0.0  ! values are zero; only BC is not
            call mkspline(y,ny,fwk,ibcymin,zdiff(1),ibcymax,zdiff(2),
     >         iliny,ier)
            if(ier.ne.0) return
            fcorr(1,ix,1:ny)=fwk(2,1:ny)  ! fyy-correction
         enddo
c
         zbcmin=0
         zbcmax=0
         do iy=1,ny
            fwk(1,1:nx)=fcorr(1,1:nx,iy)
            call mkspline(x,nx,fwk,ibcxmin,zbcmin,ibcxmax,zbcmax,
     >         ilinx,ier)
            if(ier.ne.0) return
            fcorr(2,1:nx,iy)=fwk(2,1:nx)  ! fxxyy-correction
         enddo
c
         f(3:4,1:nx,1:ny)=f(3:4,1:nx,1:ny)+fcorr(1:2,1:nx,1:ny)
c
         deallocate(fcorr)
      endif
c
c  correction spline -- f=fxx=zero; fyy & fxxyy are affected
c
      deallocate(fwk)
c------------------------------------
C
C  thats all
C
      return
      end


! Copyright (c) 2012, Johannes Feist
! licensed under the MIT open source license, see LICENSE file

program plotlaserfourier
  use laserfields
  implicit none
  real(dp), parameter :: TWOPI = 6.283185307179586476925286766559005768394_dp
  integer :: ii, i_field, nsteps
  real(dp) :: omega, de, emax
  complex(dpc), dimension(:), allocatable :: lf_ft
  complex(dpc) :: alft
  character(len=200) :: parfile

  parfile = 'laserfields.in'
  if (command_argument_count() >= 1) then
     call get_command_argument(1,parfile)
  end if
  call laserfields_read_parameters(trim(parfile))

  if (.not.laserfields_can_get_fourier()) then
     write(0,*) 'ERROR: can not get analytical fourier transform for these laser fields. Stopping!'
     STOP 733
  end if

  allocate(lf_ft(0:n_laserfields))

  ! determine energy resolution by estimating fourier bandwidth
  de = 1.d0
  emax = 0.d0
  do i_field = 1, n_laserfields
     de = min(de,TWOPI/(100*all_laserfields(i_field)%duration))
     ! go up to twice the maximum frequency - for really broadband pulses, this might not actually be enough
     emax = max(emax,all_laserfields(i_field)%omega*2.01) ! use 2.01 here so we do not get omega==lf%omega as an argument, where some of the routines have problems
  end do
  nsteps = nint(emax/de)
  de = emax/(nsteps+1)

  do ii = 1, nsteps
     omega = ii * de
     do i_field = 1, n_laserfields
        lf_ft(i_field) = get_EL_fourier_transform(all_laserfields(i_field), omega)
     end do
     lf_ft(0) = sum(lf_ft(1:))
     alft = get_AL_fourier_transform(omega)

     ! we are not unrolling the phases here (i.e. removing phase jumps by 2 pi)
     ! neither are we shifting in time to get a flatter phase overall
     write(6,'(9999(1x,g22.14e3))') omega, lf_ft(0), alft, lf_ft(1:)
  end do

end program plotlaserfourier


        SUBROUTINE FROBER(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF ROBERTSON EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        F(1)=-0.04D0*Y(1)+1.D4*Y(2)*Y(3)
        F(3)=3.D7*Y(2)*Y(2)
        F(2)=-F(1)-F(3)
        RETURN
        END
C
        SUBROUTINE JROBER(N,X,Y,DFY,LDFY,RPAR,IPAR)
C --- JACOBIAN OF ROBERTSON EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
        PROD1=1.0D4*Y(2)
        PROD2=1.0D4*Y(3)
        PROD3=6.0D7*Y(2)
        DFY(1,1)=-0.04D0
        DFY(1,2)=PROD2
        DFY(1,3)=PROD1
        DFY(2,1)=0.04D0
        DFY(2,2)=-PROD2-PROD3
        DFY(2,3)=-PROD1
        DFY(3,1)=0.D0
        DFY(3,2)=PROD3
        DFY(3,3)=0.D0
        RETURN
        END


!***********************************************************************
!   Copyright (c) 2019 D. de Vries
!   Original Copyright (c) 2000 Mark Drela
!
!   This file is part of XFoil.
!
!   XFoil is free software: you can redistribute it and/or modify
!   it under the terms of the GNU General Public License as published by
!   the Free Software Foundation, either version 3 of the License, or
!   (at your option) any later version.
!
!   XFoil is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!   GNU General Public License for more details.
!
!   You should have received a copy of the GNU General Public License
!   along with XFoil.  If not, see <https://www.gnu.org/licenses/>.
!***********************************************************************

!*==GAUSS.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
module m_xsolve
contains
    subroutine gauss(Nsiz, Nn, Z, R, Nrhs)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: Nn, Nrhs, Nsiz
        real, dimension(Nsiz, Nrhs) :: R
        real, dimension(Nsiz, Nsiz) :: Z
        intent (in) Nn, Nrhs, Nsiz
        intent (inout) R, Z
        !
        ! Local variables
        !
        integer :: k, l, n, np, np1, nx
        real :: pivot, temp, ztmp
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !     *******************************************************
        !     *                                                     *
        !     *   Solves general NxN system in NN unknowns          *
        !     *    with arbitrary number (NRHS) of righthand sides. *
        !     *   Assumes system is invertible...                   *
        !     *    ...if it isn't, a divide by zero will result.    *
        !     *                                                     *
        !     *   Z is the coefficient matrix...                    *
        !     *     ...destroyed during solution process.           *
        !     *   R is the righthand side(s)...                     *
        !     *     ...replaced by the solution vector(s).          *
        !     *                                                     *
        !     *                              Mark Drela  1984       *
        !     *******************************************************
        !
        !
        do np = 1, Nn - 1
            np1 = np + 1
            !
            !------ find max pivot index NX
            nx = np
            do n = np1, Nn
                if (abs(Z(n, np))>abs(Z(nx, np))) nx = n
            enddo
            !
            pivot = 1.0 / Z(nx, np)
            !
            !------ switch pivots
            Z(nx, np) = Z(np, np)
            !
            !------ switch rows & normalize pivot row
            do l = np1, Nn
                temp = Z(nx, l) * pivot
                Z(nx, l) = Z(np, l)
                Z(np, l) = temp
            enddo
            !
            do l = 1, Nrhs
                temp = R(nx, l) * pivot
                R(nx, l) = R(np, l)
                R(np, l) = temp
            enddo
            !
            !------ forward eliminate everything
            do k = np1, Nn
                ztmp = Z(k, np)
                !
                !          IF(ZTMP.EQ.0.0) GO TO 15
                !
                do l = np1, Nn
                    Z(k, l) = Z(k, l) - ztmp * Z(np, l)
                enddo
                do l = 1, Nrhs
                    R(k, l) = R(k, l) - ztmp * R(np, l)
                enddo
            enddo
            !
        enddo
        !
        !---- solve for last row
        do l = 1, Nrhs
            R(Nn, l) = R(Nn, l) / Z(Nn, Nn)
        enddo
        !
        !---- back substitute everything
        do np = Nn - 1, 1, -1
            np1 = np + 1
            do l = 1, Nrhs
                do k = np1, Nn
                    R(np, l) = R(np, l) - Z(np, k) * R(k, l)
                enddo
            enddo
        enddo
        !
    end subroutine gauss
    !*==CGAUSS.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
    ! GAUSS

    subroutine cgauss(Nsiz, Nn, Z, R, Nrhs)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: Nn, Nrhs, Nsiz
        complex, dimension(Nsiz, Nrhs) :: R
        complex, dimension(Nsiz, Nsiz) :: Z
        intent (in) Nn, Nrhs, Nsiz
        intent (inout) R, Z
        !
        ! Local variables
        !
        integer :: k, l, n, np, np1, nx
        complex :: pivot, temp, ztmp
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !********************************************
        !     Solves general complex linear systems.
        !********************************************
        !
        do np = 1, Nn - 1
            np1 = np + 1
            !
            !------ find max pivot index NX
            nx = np
            do n = np1, Nn
                if (abs(Z(n, np))>abs(Z(nx, np))) nx = n
            enddo
            !
            pivot = (1.0, 0.0) / Z(nx, np)
            !
            !------ switch pivots
            Z(nx, np) = Z(np, np)
            !
            !------ switch rows & normalize pivot row
            do l = np1, Nn
                temp = Z(nx, l) * pivot
                Z(nx, l) = Z(np, l)
                Z(np, l) = temp
            enddo
            !
            do l = 1, Nrhs
                temp = R(nx, l) * pivot
                R(nx, l) = R(np, l)
                R(np, l) = temp
            enddo
            !
            !------ forward eliminate everything
            do k = np1, Nn
                ztmp = Z(k, np)
                !
                !          IF(ZTMP.EQ.0.0) GO TO 15
                !
                do l = np1, Nn
                    Z(k, l) = Z(k, l) - ztmp * Z(np, l)
                enddo
                do l = 1, Nrhs
                    R(k, l) = R(k, l) - ztmp * R(np, l)
                enddo
            enddo
            !
        enddo
        !
        !---- solve for last row
        do l = 1, Nrhs
            R(Nn, l) = R(Nn, l) / Z(Nn, Nn)
        enddo
        !
        !---- back substitute everything
        do np = Nn - 1, 1, -1
            np1 = np + 1
            do l = 1, Nrhs
                do k = np1, Nn
                    R(np, l) = R(np, l) - Z(np, k) * R(k, l)
                enddo
            enddo
        enddo
        !
    end subroutine cgauss
    !*==LUDCMP.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
    ! CGAUSS

    subroutine ludcmp(Nsiz, N, A, Indx)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        integer, parameter :: NVX = 500
        !
        ! Dummy arguments
        !
        integer :: N, Nsiz
        real, dimension(Nsiz, Nsiz) :: A
        integer, dimension(Nsiz) :: Indx
        intent (in) N, Nsiz
        intent (out) Indx
        intent (inout) A
        !
        ! Local variables
        !
        real :: aamax, dum, sum
        integer :: i, imax, j, k
        real, dimension(NVX) :: vv
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !     *******************************************************
        !     *                                                     *
        !     *   Factors a full NxN matrix into an LU form.        *
        !     *   Subr. BAKSUB can back-substitute it with some RHS.*
        !     *   Assumes matrix is non-singular...                 *
        !     *    ...if it isn't, a divide by zero will result.    *
        !     *                                                     *
        !     *   A is the matrix...                                *
        !     *     ...replaced with its LU factors.                *
        !     *                                                     *
        !     *                              Mark Drela  1988       *
        !     *******************************************************
        !
        !
        !
        if (N>NVX) stop 'LUDCMP: Array overflow. Increase NVX.'
        !
        do i = 1, N
            aamax = 0.
            do j = 1, N
                aamax = max(abs(A(i, j)), aamax)
            enddo
            vv(i) = 1.0 / aamax
        enddo
        !
        do j = 1, N
            do i = 1, j - 1
                sum = A(i, j)
                do k = 1, i - 1
                    sum = sum - A(i, k) * A(k, j)
                enddo
                A(i, j) = sum
            enddo
            !
            aamax = 0.
            do i = j, N
                sum = A(i, j)
                do k = 1, j - 1
                    sum = sum - A(i, k) * A(k, j)
                enddo
                A(i, j) = sum
                !
                dum = vv(i) * abs(sum)
                if (dum>=aamax) then
                    imax = i
                    aamax = dum
                endif
            enddo
            !
            if (j/=imax) then
                do k = 1, N
                    dum = A(imax, k)
                    A(imax, k) = A(j, k)
                    A(j, k) = dum
                enddo
                vv(imax) = vv(j)
            endif
            !
            Indx(j) = imax
            if (j/=N) then
                dum = 1.0 / A(j, j)
                do i = j + 1, N
                    A(i, j) = A(i, j) * dum
                enddo
            endif
            !
        enddo
        !
    end subroutine ludcmp
    !*==BAKSUB.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
    ! LUDCMP

    subroutine baksub(Nsiz, N, A, Indx, B)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N, Nsiz
        real, dimension(Nsiz, Nsiz) :: A
        real, dimension(Nsiz) :: B
        integer, dimension(Nsiz) :: Indx
        intent (in) A, Indx, N, Nsiz
        intent (inout) B
        !
        ! Local variables
        !
        integer :: i, ii, j, ll
        real :: sum
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        ii = 0
        do i = 1, N
            ll = Indx(i)
            sum = B(ll)
            B(ll) = B(i)
            if (ii/=0) then
                do j = ii, i - 1
                    sum = sum - A(i, j) * B(j)
                enddo
            elseif (sum/=0.0) then
                ii = i
            endif
            B(i) = sum
        enddo
        !
        do i = N, 1, -1
            sum = B(i)
            if (i<N) then
                do j = i + 1, N
                    sum = sum - A(i, j) * B(j)
                enddo
            endif
            B(i) = sum / A(i, i)
        enddo
        !
    end subroutine baksub
    !*==BLSOLV.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
    ! BAKSUB

    subroutine blsolv
        use i_xfoil
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Local variables
        !
        integer :: iv, ivp, ivte1, ivz, k, kv, l
        real :: pivot, vacc1, vacc2, vacc3, vtmp, vtmp1, vtmp2, vtmp3
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------------------------------
        !      Custom solver for coupled viscous-inviscid Newton system:
        !
        !        A  |  |  .  |  |  .  |    d       R       S
        !        B  A  |  .  |  |  .  |    d       R       S
        !        |  B  A  .  |  |  .  |    d       R       S
        !        .  .  .  .  |  |  .  |    d   =   R - dRe S
        !        |  |  |  B  A  |  .  |    d       R       S
        !        |  Z  |  |  B  A  .  |    d       R       S
        !        .  .  .  .  .  .  .  |    d       R       S
        !        |  |  |  |  |  |  B  A    d       R       S
        !
        !       A, B, Z  3x3  blocks containing linearized BL equation coefficients
        !       |        3x1  vectors containing mass defect influence
        !                     coefficients on Ue
        !       d        3x1  unknown vectors (Newton deltas for Ctau, Theta, m)
        !       R        3x1  residual vectors
        !       S        3x1  Re influence vectors
        !-----------------------------------------------------------------
        !
        ivte1 = ISYs(IBLte(1), 1)
        !
        vacc1 = VACcel
        vacc2 = VACcel * 2.0 / (S(N) - S(1))
        vacc3 = VACcel * 2.0 / (S(N) - S(1))
        !
        do iv = 1, NSYs
            !
            ivp = iv + 1
            !
            !====== Invert VA(IV) block
            !
            !------ normalize first row
            pivot = 1.0 / VA(1, 1, iv)
            VA(1, 2, iv) = VA(1, 2, iv) * pivot
            do l = iv, NSYs
                VM(1, l, iv) = VM(1, l, iv) * pivot
            enddo
            VDEl(1, 1, iv) = VDEl(1, 1, iv) * pivot
            VDEl(1, 2, iv) = VDEl(1, 2, iv) * pivot
            !
            !------ eliminate lower first column in VA block
            do k = 2, 3
                vtmp = VA(k, 1, iv)
                VA(k, 2, iv) = VA(k, 2, iv) - vtmp * VA(1, 2, iv)
                do l = iv, NSYs
                    VM(k, l, iv) = VM(k, l, iv) - vtmp * VM(1, l, iv)
                enddo
                VDEl(k, 1, iv) = VDEl(k, 1, iv) - vtmp * VDEl(1, 1, iv)
                VDEl(k, 2, iv) = VDEl(k, 2, iv) - vtmp * VDEl(1, 2, iv)
            enddo
            !
            !
            !------ normalize second row
            pivot = 1.0 / VA(2, 2, iv)
            do l = iv, NSYs
                VM(2, l, iv) = VM(2, l, iv) * pivot
            enddo
            VDEl(2, 1, iv) = VDEl(2, 1, iv) * pivot
            VDEl(2, 2, iv) = VDEl(2, 2, iv) * pivot
            !
            !------ eliminate lower second column in VA block
            k = 3
            vtmp = VA(k, 2, iv)
            do l = iv, NSYs
                VM(k, l, iv) = VM(k, l, iv) - vtmp * VM(2, l, iv)
            enddo
            VDEl(k, 1, iv) = VDEl(k, 1, iv) - vtmp * VDEl(2, 1, iv)
            VDEl(k, 2, iv) = VDEl(k, 2, iv) - vtmp * VDEl(2, 2, iv)
            !
            !
            !------ normalize third row
            pivot = 1.0 / VM(3, iv, iv)
            do l = ivp, NSYs
                VM(3, l, iv) = VM(3, l, iv) * pivot
            enddo
            VDEl(3, 1, iv) = VDEl(3, 1, iv) * pivot
            VDEl(3, 2, iv) = VDEl(3, 2, iv) * pivot
            !
            !
            !------ eliminate upper third column in VA block
            vtmp1 = VM(1, iv, iv)
            vtmp2 = VM(2, iv, iv)
            do l = ivp, NSYs
                VM(1, l, iv) = VM(1, l, iv) - vtmp1 * VM(3, l, iv)
                VM(2, l, iv) = VM(2, l, iv) - vtmp2 * VM(3, l, iv)
            enddo
            VDEl(1, 1, iv) = VDEl(1, 1, iv) - vtmp1 * VDEl(3, 1, iv)
            VDEl(2, 1, iv) = VDEl(2, 1, iv) - vtmp2 * VDEl(3, 1, iv)
            VDEl(1, 2, iv) = VDEl(1, 2, iv) - vtmp1 * VDEl(3, 2, iv)
            VDEl(2, 2, iv) = VDEl(2, 2, iv) - vtmp2 * VDEl(3, 2, iv)
            !
            !------ eliminate upper second column in VA block
            vtmp = VA(1, 2, iv)
            do l = ivp, NSYs
                VM(1, l, iv) = VM(1, l, iv) - vtmp * VM(2, l, iv)
            enddo
            VDEl(1, 1, iv) = VDEl(1, 1, iv) - vtmp * VDEl(2, 1, iv)
            VDEl(1, 2, iv) = VDEl(1, 2, iv) - vtmp * VDEl(2, 2, iv)
            !
            !
            if (iv/=NSYs) then
                !
                !====== Eliminate VB(IV+1) block, rows  1 -> 3
                do k = 1, 3
                    vtmp1 = VB(k, 1, ivp)
                    vtmp2 = VB(k, 2, ivp)
                    vtmp3 = VM(k, iv, ivp)
                    do l = ivp, NSYs
                        VM(k, l, ivp) = VM(k, l, ivp) - (vtmp1 * VM(1, l, iv) &
                                + vtmp2 * VM(2, l, iv) + vtmp3 * VM(3, l, iv))
                    enddo
                    VDEl(k, 1, ivp) = VDEl(k, 1, ivp) &
                            - (vtmp1 * VDEl(1, 1, iv) + vtmp2 * VDEl(2, 1, iv) + vtmp3 * VDEl(3, 1, iv))
                    VDEl(k, 2, ivp) = VDEl(k, 2, ivp) &
                            - (vtmp1 * VDEl(1, 2, iv) + vtmp2 * VDEl(2, 2, iv) + vtmp3 * VDEl(3, 2, iv))
                enddo
                !
                if (iv==ivte1) then
                    !------- eliminate VZ block
                    ivz = ISYs(IBLte(2) + 1, 2)
                    !
                    do k = 1, 3
                        vtmp1 = VZ(k, 1)
                        vtmp2 = VZ(k, 2)
                        do l = ivp, NSYs
                            VM(k, l, ivz) = VM(k, l, ivz) - (vtmp1 * VM(1, l, iv) + vtmp2 * VM(2, l, iv))
                        enddo
                        VDEl(k, 1, ivz) = VDEl(k, 1, ivz) - (vtmp1 * VDEl(1, 1, iv) + vtmp2 * VDEl(2, 1, iv))
                        VDEl(k, 2, ivz) = VDEl(k, 2, ivz) - (vtmp1 * VDEl(1, 2, iv) + vtmp2 * VDEl(2, 2, iv))
                    enddo
                endif
                !
                if (ivp/=NSYs) then
                    !
                    !====== Eliminate lower VM column
                    do kv = iv + 2, NSYs
                        vtmp1 = VM(1, iv, kv)
                        vtmp2 = VM(2, iv, kv)
                        vtmp3 = VM(3, iv, kv)
                        !
                        if (abs(vtmp1)>vacc1) then
                            do l = ivp, NSYs
                                VM(1, l, kv) = VM(1, l, kv) - vtmp1 * VM(3, l, iv)
                            enddo
                            VDEl(1, 1, kv) = VDEl(1, 1, kv) - vtmp1 * VDEl(3, 1, iv)
                            VDEl(1, 2, kv) = VDEl(1, 2, kv) - vtmp1 * VDEl(3, 2, iv)
                        endif
                        !
                        if (abs(vtmp2)>vacc2) then
                            do l = ivp, NSYs
                                VM(2, l, kv) = VM(2, l, kv) - vtmp2 * VM(3, l, iv)
                            enddo
                            VDEl(2, 1, kv) = VDEl(2, 1, kv) - vtmp2 * VDEl(3, 1, iv)
                            VDEl(2, 2, kv) = VDEl(2, 2, kv) - vtmp2 * VDEl(3, 2, iv)
                        endif
                        !
                        if (abs(vtmp3)>vacc3) then
                            do l = ivp, NSYs
                                VM(3, l, kv) = VM(3, l, kv) - vtmp3 * VM(3, l, iv)
                            enddo
                            VDEl(3, 1, kv) = VDEl(3, 1, kv) - vtmp3 * VDEl(3, 1, iv)
                            VDEl(3, 2, kv) = VDEl(3, 2, kv) - vtmp3 * VDEl(3, 2, iv)
                        endif
                        !
                    enddo
                endif
            endif
            !
        enddo
        !
        !
        !
        do iv = NSYs, 2, -1
            !
            !------ eliminate upper VM columns
            vtmp = VDEl(3, 1, iv)
            do kv = iv - 1, 1, -1
                VDEl(1, 1, kv) = VDEl(1, 1, kv) - VM(1, iv, kv) * vtmp
                VDEl(2, 1, kv) = VDEl(2, 1, kv) - VM(2, iv, kv) * vtmp
                VDEl(3, 1, kv) = VDEl(3, 1, kv) - VM(3, iv, kv) * vtmp
            enddo
            !
            vtmp = VDEl(3, 2, iv)
            do kv = iv - 1, 1, -1
                VDEl(1, 2, kv) = VDEl(1, 2, kv) - VM(1, iv, kv) * vtmp
                VDEl(2, 2, kv) = VDEl(2, 2, kv) - VM(2, iv, kv) * vtmp
                VDEl(3, 2, kv) = VDEl(3, 2, kv) - VM(3, iv, kv) * vtmp
            enddo
            !
        enddo
        !
    end subroutine blsolv

end module m_xsolve


!> -------------------------------------------
!! Supply regression utilities to GARD
!!
!! Provides least squares regression and logistic regression
!! includes output of both the coefficients and the residual error, optionally computed with supplied weights
!!
!! See regression_h header file for interface
!!
!! --------------------------------------------
submodule(regression_mod) regression_implementation
contains

    module function compute_regression(x, training_x, training_y, coefficients, y_test, error, weights, used_vars) result(y)
        implicit none
        real,    intent(in),    dimension(:)   :: x
        real,    intent(in),    dimension(:,:) :: training_x
        real,    intent(in),    dimension(:)   :: training_y
        real(8), intent(inout), dimension(:)   :: coefficients
        real,    intent(inout),                             optional :: error
        real,    intent(in),    dimension(:),               optional :: y_test
        real,    intent(inout), dimension(:),  allocatable, optional :: weights
        integer, intent(inout), dimension(:),               optional :: used_vars

        real,    allocatable,   dimension(:,:) :: training_x_lp
        real,    allocatable,   dimension(:)   :: training_y_lp

        real :: y

        integer :: nvars, ntimes, i, j, info, useable_vars, thisvar, nonzero_count
        integer, dimension(:), allocatable :: varlist
        real,    dimension(:), allocatable :: useful_x

        if (maxval(training_y) == minval(training_y)) then
            y = training_y(1)
            coefficients = 0
            if (present(error)) error=0
            return
        endif

        nvars  = size(x)
        ntimes = size(training_x,1)

        allocate(varlist(nvars))
        varlist = -1
        varlist(1) = 1   ! this assumes there is a constant passed in for the first variable...
        useable_vars = 1 ! the constant

        ! find all vars that have some variability through time.
        do i=2,nvars
            nonzero_count = 0
            do j=1,ntimes
                if (abs(training_x(j,i)-training_x(1,i))>0) then
                    nonzero_count = nonzero_count + 1
                endif
            enddo
            ! need at least two data points that are different from the first data point
            ! to ensure that the regression on that variable might be useful.
            if ( nonzero_count > 2 ) then
                useable_vars = useable_vars + 1
                varlist(i) = i
            end if
        enddo
        if (present(used_vars)) used_vars=varlist

        ! if there are no useable training variables other than the constant, just return (this should never happen?)
        if (useable_vars <= 1) then
            y = 1e20 ! error value so it will recompute from analogs if possible
            coefficients = 0
            if (present(error)) error=0
            return
        endif

        allocate(useful_x(useable_vars))
        allocate(training_x_lp(ntimes, useable_vars))

        thisvar=1
        do i=1,nvars
            if (varlist(i) /= -1) then
                training_x_lp(:,thisvar) = training_x(:,i)
                useful_x(thisvar) = x(i)
                thisvar = thisvar + 1
            endif
        enddo

        allocate(training_y_lp(ntimes))
        training_y_lp = training_y

        call lapack_least_squares(training_x_lp, training_y_lp, coefficients, info=info)
        if (info/=0) then
            y = 1e20 ! error value so it will recompute from analogs
            ! !$omp critical (print_lock)
            ! print*, "Regression error, using value:",y
            ! !$omp end critical (print_lock)
            coefficients = 0
            if (present(error)) error=0
            return
        endif

        if (maxval(abs(coefficients)) == 0) then
            y = 1e20
            if (present(error)) error=0
            return
        endif

        y = 0
        do i=1,useable_vars
            y = y + coefficients(i) * useful_x(i)
        end do

        if (present(error)) then
            training_y_lp = 0
            thisvar       = 1
            do i=1, nvars
                if (varlist(i) /= -1) then
                    training_y_lp = training_y_lp + coefficients(thisvar) * training_x(:,i)
                    thisvar       = thisvar + 1
                endif
            enddo
            ! root mean square error
            ! this is the regression error

            ! optionally use the weights computed in analog_weights to weight the error calculation
            ! weights should sum to 1, but just in case, we divide by sum(weights)
            if (present(weights)) then
                if (allocated(weights)) then
                    if (size(weights)/=size(training_y_lp)) then
                        !$omp critical (print_lock)
                        write(*,*) "ERROR size of weights /= data"
                        write(*,*) shape(weights), shape(training_y_lp)
                        !$omp end critical (print_lock)
                    endif
                    if (present(y_test)) then
                        error = sqrt( sum(((training_y_lp - y_test)**2)*weights) / sum(weights) )
                    else
                        error = sqrt( sum(((training_y_lp - training_y)**2)*weights) / sum(weights) )
                    endif

                else
                    if (present(y_test)) then
                        error = sqrt( sum((training_y_lp - y_test)**2) / ntimes )
                    else
                        error = sqrt( sum((training_y_lp - training_y)**2) / ntimes )
                    endif
                endif
            else
                if (present(y_test)) then
                    error = sqrt( sum((training_y_lp - y_test)**2) / ntimes )
                else
                    error = sqrt( sum((training_y_lp - training_y)**2) / ntimes )
                endif
            endif
        endif

    end function compute_regression

    !
    ! Solve linear equation for x (Ax = b => x = bA^-1) using the lapack SGELS library call
    ! Input:
    !   X  = An m by n array.
    !   Y  = An m-element vector containing the right-hand side of the linear system Ax = b.
    ! Output:
    !   B  = An n-element vector.
    !
    subroutine lapack_least_squares(X, Y, B, working_space, info)
        implicit none
        real,    intent(inout), dimension(:,:) :: X
        real,    intent(inout), dimension(:)   :: Y
        real(8), intent(inout), dimension(:)   :: B
        real,    intent(inout), dimension(:), optional :: working_space ! temporary working space
        integer, intent(inout),               optional :: info

        ! it could be more efficient to keep one space allocated and pass it in every time (working_space),
        ! in practice, having a modest "WORK" allocated on the stack seems to be at least as fast.
        real, dimension(1000) :: WORK
        integer :: n, m, nrhs, LDX, LDY, LWORK, innerINFO

        m = size(X,1)
        LDX = m

        n = size(X,2)
        LDY = m

        nrhs = 1

        ! passing working_space in and out *could* be more efficient.  Only used in tests right now
        if (present(working_space)) then
            ! First find the optimal work size (LWORK)
            LWORK = -1
            CALL SGELS( 'N', M, N, NRHS, X, LDX, Y, LDY, working_space, LWORK, innerINFO )
            LWORK = MIN( size(working_space), INT( working_space( 1 ) ) )

            ! Now solve the equations X*B = Y
            CALL SGELS( 'N', M, N, NRHS, X, LDX, Y, LDY, working_space, LWORK, innerINFO )
        else
            ! First find the optimal work size (LWORK)
            LWORK = -1
            CALL SGELS( 'N', M, N, NRHS, X, LDX, Y, LDY, WORK, LWORK, innerINFO )
            LWORK = MIN( 1000, INT( WORK( 1 ) ) )

            ! Now solve the equations X*B = Y
            CALL SGELS( 'N', M, N, NRHS, X, LDX, Y, LDY, WORK, LWORK, innerINFO )
        endif
        if (innerINFO/=0) then
            Y(1) = sum(Y)/size(Y)
            Y(2:)= 0
        endif

        if (present(info)) info = innerINFO
        B(1:n) = Y(1:n)

    end subroutine lapack_least_squares

    subroutine weighted_least_squares(X, Y, B, W)
        implicit none
        real, intent(inout), dimension(:,:) :: X
        real, intent(inout), dimension(:)   :: Y, W
        real(8), intent(inout), dimension(:)   :: B
        real, dimension(:,:), allocatable :: W_full
        real, dimension(:),   allocatable :: Bs, output_y

        real, dimension(10000) :: WORK
        integer :: i, n, m, nrhs, LDX, LDY, LDW, LWORK, INFO, p

        ! ntimes
        m = size(X,1)
        LDX = m
        LDY = m
        LDW = m
        p   = m

        ! nvars
        n = size(X,2)

        nrhs = 1

        allocate(output_y(p))
        allocate(Bs(n))
        allocate(W_full(m,m))
        W_full = 0
        do i=1,m
            W_full(i,i) = 1/W(i)
        enddo

        ! print*, "entering sggglm"
        LWORK = 10000
        call sggglm(m, n, p, X, LDX, W_full, LDW, Y, Bs, output_y, WORK, LWORK, INFO)

        B(1:n) = Bs(1:n)

    end subroutine weighted_least_squares

    module function compute_logistic_regression(x, training_x, binary_values, coefficients) result(output)
        implicit none
        real,    intent(in) :: x(:)
        real,    intent(in) :: training_x(:,:)
        real,    intent(in) :: binary_values(:)
        real(8), intent(out):: coefficients(:)
        real :: output

        call logistic_regression(training_x, binary_values, coefficients)

        output = dot_product(x, coefficients)
        ! at this point exp(-output) is foolishly large, much higher will cause an overflow
        output = max(-80.0, output)

        output = 1.0 / (1.0 + exp(-output))

    end function compute_logistic_regression

    subroutine logistic_regression(X, Y, B)
        implicit none
        real,    intent(in) :: X(:,:)
        real,    intent(in) :: Y(:)
        real(8), intent(out) :: B(:)

        real,    allocatable :: Yp(:), P(:), V(:,:)
        real(8), allocatable :: BN(:)
        real,    allocatable :: YN(:), XV(:,:)

        integer :: nvars, ntimes, i, t, f, it
        integer :: info

        ! skip the logistic regression and force the result to be 1
        if (all(Y > 0)) then
            B(1) = 88
            B(2:)= 0
            return
        ! skip the logistic regression and force the result to be 0
        elseif (all(Y==0)) then
            B(1) = -88
            B(2:)= 0
            return
        endif

        nvars = size(X,2) -1
        ntimes = size(Y)

        allocate(BN(nvars+1))
        allocate(Yp(ntimes))
        allocate(YN(ntimes))
        allocate(P(ntimes))
        allocate(V(ntimes,ntimes))
        allocate(XV(ntimes, nvars+1))

        do t = 1, ntimes, 1
            if(Y(t) .ne. 0.0) then
                Yp(t) = 1.0d0
            else
                Yp(t) = 0.0d0
            end if
        end do

        B = 0.0d0
        f = 0
        i = 0
        it = 0
        do while (f /= 1)

            P = max(-80.0, matmul(X, B))
            P = 1.0 / (1.0 + exp(-P))
            if (ANY(P > 0.9999999)) then
                ! !$omp critical (print_lock)
                !print*, "WARNING: logistic regression diverging"
                ! !$omp end critical (print_lock)
                f = 1
            else

                YN = Yp - P
                V = 0.0
                do t = 1, ntimes, 1
                    V(t,t) = P(t)*(1.0-P(t))
                enddo
                XV = matmul(V,X)

                ! This only seems to be a problem for Intel's MKL library which can crash with a float overflow otherwise
                if ((maxval(XV) < 1e-30) .and. (minval(XV) > -1e-30) .and. (maxval(YN) > 0.999999)) then
                    info = -1
                    ! !$omp critical (print_lock)
                    ! print*, "WARNING: logistic regression failed to converge"
                    ! print*, it, maxval(XV), minval(XV), maxval(YN), minval(YN)
                    ! !$omp end critical (print_lock)
                else
                    call lapack_least_squares(XV, YN, BN, info=info)
                endif

                if (info /= 0) then
                    B(1) = -1 * log( (1.0 / (sum(Y)/size(Y))) - 1.0)
                    B(2:)= 0
                    return
                endif

                f = 1
                do i = 1, nvars+1, 1
                    if(BN(i) .GT. 1.0E-04 .OR. BN(i) .LT. -1.0E-04) then
                        f = 0
                    end if
                end do
                if(it > 8) then
                    ! !$omp critical (print_lock)
                    !print*, "WARNING: logistic regression failed to converge"
                    ! !$omp end critical (print_lock)
                    f = 1
                endif

                B = B + BN

            endif
            it = it+1
        end do

    end subroutine logistic_regression

end submodule regression_implementation


************************************************************************
*
*     Subroutine DGQTST                               Called by: DHUMIT
*
*     compute Goldfeld-Quandt-Trotter step by More-Hebden technique
*
C     (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN
C
C        GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
C     HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
C     THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
C     APPROXIMATE LENGTH V(8) BY THE MORE-HEBDEN TECHNIQUE.  IN
C     OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
C     PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP  SUCH THAT THE
C     2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(8), WHERE
C     G  IS THE GRADIENT,  H  IS THE HESSIAN, AND  D  IS A DIAGONAL
C     SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
C     (DGQTST ASSUMES  DIG = D**-1 * G  AND  DIHDI = D**-1 * H * D**-1.)
C
C     D (IN)  = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
C              MATRIX  D  MENTIONED ABOVE UNDER PURPOSE.
C   DIG (IN)  = THE SCALED GRADIENT VECTOR, D**-1 * G.  IF G = 0, THEN
C              STEP = 0  AND  V(5) = 0  ARE RETURNED.
C DIHDI (IN)  = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
C              I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
C              IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
C    KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
C              MINE STEP.  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
C              ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
C              -- KA IS INITIALIZED TO 0 IN THIS CASE.  OUTPUT WITH
C              KA = 0  (OR V(5) = 0)  MEANS  STEP = -(H**-1)*G.
C     L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
C     P (IN)  = NUMBER OF PARAMETERS -- THE HESSIAN IS A  P X P  MATRIX.
C  STEP (I/O) = THE STEP COMPUTED.
C     V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C     W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
C
C  ***  ENTRIES IN V  ***
C
C V(1) (I/O) = 2-NORM OF (D**-1)*G.
C V(2) (OUTPUT) = 2-NORM OF D*STEP.
C V(3)   (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
C             OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
C V(19) (IN)  = MAX. REL. ERROR ALLOWED FOR PSI(STEP).  FOR THE
C             STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
C             BY LESS THAN -V(19)*PSI(STEP).  SUGGESTED VALUE = 0.1.
C V(4) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(6) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP)  (FOR POS. DEF.
C             H ONLY -- V(6) IS SET TO ZERO OTHERWISE).
C V(20) (IN)  = TOL. (TOGETHER WITH V(21)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(2) - V(8) MUST LIE
C             BETWEEN V(20)*V(8) AND V(21)*V(8).
C V(21) (IN)  (SEE V(20).)
C             SUGGESTED VALUES -- V(20) = -0.25, V(21) = 0.5.
C V(7) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
C V(8) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(9)   (I/O) = VALUE OF V(8) FROM PREVIOUS CALL.
C V(5) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
C             DESCRIBED BELOW UNDER ALGORITHM NOTES.  IF H + ALPHA*D**2
C             (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
C             THEN V(5) = -ALPHA.
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(8), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(8).  (THIS EXPLAINS
C     WHY STEP AND W ARE LISTED AS I/O).  ON AN INITIAL CALL (ONE WITH
C     KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
C     NENTS V(19), V(5), V(20), V(21), V(8), AND
C     V(9) OF V MUST BE INITIALIZED.
C
C        THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES
C     (H + ALPHA*D**2)*STEP = -G  FOR SOME NONNEGATIVE ALPHA SUCH THAT
C     H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE.  ALPHA AND STEP ARE
C     COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
C     ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
C     ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
C     SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7.  CASES IN WHICH
C     H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
C     THE TECHNIQUE DISCUSSED IN REF. 2.  IN THESE CASES, A STEP OF
C     (EXACT) LENGTH V(8) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
C     ITS OPTIMAL VALUE BY LESS THAN -V(19)*PSI(STEP).  THE TEST
C     SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED
C     ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER
C     SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT
C     CALL THIS ROUTINE.
C
C DLITVM - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C DLIVMU - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C DLSQRT  - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
C DLSVMN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
C             SOFTWARE, VOL. 7, NO. 3.
C 2.  GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
C             SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
C             186-197.
C 3.  GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
C             MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
C             PP. 541-551.
C 4.  HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
C             SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
C             DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
C 5.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C 6.  MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION
C             STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB.
C 7.  VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
C             PP. 719-729.
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
*
************************************************************************
      SUBROUTINE DGQTST(D,DIG,DIHDI,KA,L,NP,STEP,V,W)
*
*     subroutine arguments
*
      INTEGER*4 KA,NP
      DOUBLE PRECISION D(*),DIG(*),DIHDI(*),L(*),V(*),STEP(*),W(*)
*
*     local vars
*
      LOGICAL RESTRT
      INTEGER*4 I,INC,IRC,J,K,KALIM,KAMIN,K1
      DOUBLE PRECISION ALPHAK,AKI,AKK,DELTA,DST,EPS,GTSTA,LK,OLDPHI,
     &                 PHI,PHIMAX,PHIMIN,PSIFAC,RAD,RADSQ,ROOT,SI,SK,
     &                 SW,T,TWOPSI,T1,T2,UK,WI
      DOUBLE PRECISION BIG,DGXFAC
*
*     function declarations
*
      DOUBLE PRECISION DDOT,DLSVMN,D1MACH,DNRM2
      DATA BIG/0.D0/,DGXFAC/0.D0/
*
*     store largest abs. entry in (D**-1)*H*(D**-1) at W(NP+2)
*
*     store Gerschgorin over- and underestimates of the largest and
*     smallest eigenvalues of (D**-1)*H*(D**-1) at W(NP+3) and W(NP+4)
*     respectively
*
*     for use in recomputing step, the final values of LK, UK, DST,AND
*     the inverse derivative of More*s PHI at 0 (for pos. def. H) are
*     stored in W(NP+5), W(NP+7), W(NP+8), and W(NP+6) respectively.
*
*     store diag of (D**-1)*H*(D**-1) in W(NP+9),...,W(NP+NP+9)
*
*     store -D*STEP in W(Q),...,W(NP+NP+NP+10)
*
*     allocate storage for scratch vector X
*
      RAD = V(8)
      RADSQ = RAD**2
*
*     PHITOL = max. error allowed in DST = V(2) = 2-norm of D*STEP
*
      PHIMAX = V(21) * RAD
      PHIMIN = V(20) * RAD
      PSIFAC = 2.D0 * V(19)/(3.D0 * (4.D0 * (V(20) + 1.D0) * 3.D0
     &                       +  4.D0) * RAD**2)
*
*     OLDPHI is used to detect limits of numerical accuracy;  if we
*     recompute step and it does not change, then we accept it
*
      OLDPHI = 0.D0
      EPS = V(19)
      IRC = 0
      RESTRT = .FALSE.
      KALIM = KA + 50
*
*     start or restart, depending on KA
*
      IF (KA .GE. 0) GOTO 290
*
*     fresh start
*
      K = 0
      UK = -1.D0
      KA = 0
      KALIM = 50
      V(1) = DNRM2(NP+1,DIG)
      V(6) = 0.D0
      V(3) = 0.D0
      KAMIN = 3
      IF (V(1) .EQ. 0.D0) KAMIN = 0
*
*     store DIAG(DIHDI) in W(NP+9),...,W(NP+NP+9)
*
      J = 0
      DO 10 I=1,NP+1
         J = J + I
         K1 = NP + 8 + I
         W(K1) = DIHDI(J)
 10   CONTINUE
*
*     determine W(NP+2), the largest element of DIHDI
*
      T1 = 0.D0
      J = (NP+1) * (NP+2) / 2
      DO 20 I = 1, J
         T = DABS(DIHDI(I))
         IF (T1 .LT. T) T1 = T
 20   CONTINUE
      W(NP+2) = T1
*
*     try ALPHA = 0
*
 30   CALL DLSQRT(NP+1,L,DIHDI,IRC)
      IF (IRC .EQ. 0) GOTO 50
*
*     indef. H -- underestimate smallest eigenvalue, use this estimate
*     to initialize lower bound LK on ALPHA.
*
      J = IRC*(IRC+1)/2
      T = L(J)
      L(J) = 1.D0
      DO 40 I = 1, IRC
         W(I) = 0.D0
 40   CONTINUE
      W(IRC) = 1.D0
      CALL DLITVM(IRC,W,L,W)
      T1 = DNRM2(IRC,W)
      LK = -T / T1 / T1
      V(3) = -LK
      IF (RESTRT) GOTO 210
      GOTO 70
*
*     positive definite H -- compute unmodified newton step
*
 50   LK = 0.D0
      T = DLSVMN(NP,L,W(NP+NP+10),W(NP+NP+10))
      IF (T .GE. 1.D0) GOTO 60
      IF (BIG .LE. 0.D0) BIG = D1MACH(2)
      IF (V(1) .GE. T*T*BIG) GOTO 70
 60   CALL DLIVMU(NP+1,W(NP+NP+10),L,DIG)
      GTSTA = DDOT(NP+1,W(NP+NP+10),W(NP+NP+10))
      V(6) = 0.5D0 * GTSTA
      CALL DLITVM(NP+1,W(NP+NP+10),L,W(NP+NP+10))
      DST = DNRM2(NP+1,W(NP+NP+10))
      V(3) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GOTO 260
      IF (RESTRT) GOTO 210
*
*     prepare to compute Gerschgorin estimates of largest (and
*     smallest) eigenvalues.
*
 70   K = 0
      DO 100 I = 1, NP+1
         WI = 0.D0
         IF (I .EQ. 1) GOTO 90
         DO 80 J = 1, I-1
            K = K + 1
            T = DABS(DIHDI(K))
            WI = WI + T
            W(J) = W(J) + T
 80      CONTINUE
 90      W(I) = WI
         K = K + 1
 100  CONTINUE
*
*     (under-)estimate smallest eigenvalue of (D**-1)*H*(D**-1)
*
      K = 1
      T1 = W(NP+9) - W(1)
      IF (NP+1 .LE. 1) GOTO 120
      DO 110 I = 2, NP+1
         J = NP + 8 + I
         T = W(J) - W(I)
         IF (T .GE. T1) GOTO 110
         T1 = T
         K = I
 110  CONTINUE

 120  SK = W(K)
      J = NP + 8 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = 0.D0
      DO 150 I = 1, NP+1
         IF (I .EQ. K) GOTO 130
         AKI = DABS(DIHDI(K1))
         SI = W(I)
         J = NP + 8 + I
         T1 = 0.5D0 * (AKK - W(J) + SI - AKI)
         T1 = T1 + DSQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GOTO 140
 130     INC = I
 140     K1 = K1 + INC
 150  CONTINUE

      W(NP+4) = AKK - T
      UK = V(1)/RAD - W(NP+4)
      IF (V(1) .EQ. 0.D0) UK = UK + 1.D-3 + 1.D-3*UK
*
*     compute Gerschgorin (over-)estimate of largest eigenvalue
*
      K = 1
      T1 = W(NP+9) + W(1)
      IF (NP+1 .LE. 1) GOTO 170
      DO 160 I = 2, NP+1
         J = NP + 8 + I
         T = W(J) + W(I)
         IF (T .LE. T1) GOTO 160
         T1 = T
         K = I
 160  CONTINUE

 170  SK = W(K)
      J = NP + 8 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = 0.D0
      DO 200 I = 1, NP+1
         IF (I .EQ. K) GOTO 180
         AKI = DABS(DIHDI(K1))
         SI = W(I)
         J = NP + 8 + I
         T1 = 0.5D0 * (W(J) + SI - AKI - AKK)
         T1 = T1 + DSQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GOTO 190
 180     INC = I
 190     K1 = K1 + INC
 200  CONTINUE

      W(NP+3) = AKK + T
      LK = DMAX1(LK, V(1)/RAD - W(NP+3))
*
*     ALPHAK = current value of ALPHA (see alg. notes above); we use
*     More*s scheme for initializing it
*
      ALPHAK = DABS(V(5)) * V(9)/RAD

      IF (IRC .NE. 0) GOTO 210
*
*     compute L0 for positive definite H
*
      CALL DLIVMU(NP+1,W,L,W(NP+NP+10))
      T = DNRM2(NP+1,W)
      W(NP+6) = DST / T / T
      LK = DMAX1(LK, PHI*W(NP+6))
*
*     safeguard ALPHAK and add ALPHAK*I to (D**-1)*H*(D**-1)
*
 210  KA = KA + 1
      IF (-V(3) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     &   ALPHAK = UK * DMAX1(1.D-3, DSQRT(LK/UK))
      IF(ALPHAK .LE. 0.D0) ALPHAK = 0.5D0 * UK
      K = 0
      DO 220 I = 1, NP+1
         K = K + I
         J = NP + 8 + I
         DIHDI(K) = W(J) + ALPHAK
 220  CONTINUE
*
*     try Cholesky decomposition
*
      CALL DLSQRT(NP+1,L,DIHDI,IRC)
      IF (IRC .EQ. 0) GOTO 240
*
*     (D**-1)*H*(D**-1) + ALPHAK*I is indefinite -- overestimate
*     smallest eigenvalue for use in updating LK
*
      J = (IRC*(IRC+1))/2
      T = L(J)
      L(J) = 1.D0
      DO 230 I = 1,IRC
         W(I) = 0.D0
 230  CONTINUE
      W(IRC) = 1.D0
      CALL DLITVM(IRC,W,L,W)
      T1 = DNRM2(IRC,W)
      LK = ALPHAK - T/T1/T1
      V(3) = -LK
      GOTO 210
*
*     ALPHAK makes (D**-1)*H*(D**-1) positive definite; compute
*     Q = -D*STEP, check for convergence
*
 240  CALL DLIVMU(NP+1,W(NP+NP+10),L,DIG)
      GTSTA = DDOT(NP+1,W(NP+NP+10),W(NP+NP+10))
      CALL DLITVM(NP+1,W(NP+NP+10),L,W(NP+NP+10))
      DST = DNRM2(NP+1,W(NP+NP+10))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GOTO 270
      IF (PHI .EQ. OLDPHI) GOTO 270
      OLDPHI = PHI
      IF (PHI .LT. 0.D0) GOTO 330
*
*     unacceptable ALPHAK -- update LK, UK, ALPHAK
*
 250  IF (KA .GE. KALIM) GOTO 270
*
*     the following DMIN1 is necessary because of restarts
*
      IF (PHI .LT. 0.D0) UK = DMIN1(UK, ALPHAK)
*
*     KAMIN = 0 only iff the gradient vanishes
*
      IF (KAMIN .EQ. 0) GOTO 210
      CALL DLIVMU(NP+1,W,L,W(NP+NP+10))
      T1 = DNRM2(NP+1,W)
      ALPHAK = ALPHAK  +  (PHI/T1) * (DST/T1) * (DST/RAD)
      LK = DMAX1(LK, ALPHAK)
      GOTO 210
*
*     acceptable step on first try
*
 260  ALPHAK = 0.D0
*
*     successful step in general; compute STEP = -(D**-1)*Q
*
 270  DO 280 I = 1, NP+1
         J = NP + NP + 9 + I
         STEP(I) = -W(J)/D(I)
 280  CONTINUE
      V(4) = -GTSTA
      V(7) = 0.5D0 * (DABS(ALPHAK)*DST*DST + GTSTA)
      GOTO 410
*
*     restart with new radius
*
 290  IF (V(3) .LE. 0.D0 .OR. V(3) - RAD .GT. PHIMAX) GOTO 310
*
*     prepare to return Newton step
*
      RESTRT = .TRUE.
      KA = KA + 1
      K = 0
      DO 300 I = 1, NP+1
         K = K + I
         J = NP + 8 + I
         DIHDI(K) = W(J)
 300  CONTINUE
      UK = -1.D0
      GOTO 30

 310  KAMIN = KA + 3
      IF (V(1) .EQ. 0.D0) KAMIN = 0
      IF (KA .EQ. 0) GOTO 50

      DST = W(NP+8)
      ALPHAK = DABS(V(5))
      PHI = DST - RAD
      T = V(1)/RAD
      UK = T - W(NP+4)
      IF (V(1) .EQ. 0.D0) UK = UK + 1.D-3 + 1.D-3*UK
      IF (RAD .GT. V(9)) GOTO 320
*
*     SMALLER RADIUS
*
      LK = 0.D0
      IF (ALPHAK .GT. 0.D0) LK = W(NP+5)
      LK = DMAX1(LK, T - W(NP+3))
      IF (V(3) .GT. 0.D0) LK = DMAX1(LK, (V(3)-RAD)*W(NP+6))
      GOTO 250
*
*     bigger radius
*
 320  IF (ALPHAK .GT. 0.D0) UK = DMIN1(UK, W(NP+7))
      LK = DMAX1(0.D0, -V(3), T - W(NP+3))
      IF (V(3) .GT. 0.D0) LK = DMAX1(LK, (V(3)-RAD)*W(NP+6))
      GOTO 250
*
*     decide whether to check for special case... in practice (from
*     the standpoint of the calling optimization code) it seems best
*     not to check until a few iterations have failed -- hence the
*     test on KAMIN below.
*
 330  DELTA = ALPHAK + DMIN1(0.D0, V(3))
      TWOPSI = ALPHAK*DST*DST + GTSTA
      IF (KA .GE. KAMIN) GOTO 340
*
*     if the test in ref. 2 is satisfied, fall through to handle the
*     special case (as soon as the More-Sorensen test detects it).
*
      IF (DELTA .GE. PSIFAC*TWOPSI) GOTO 370
*
*     check for the special case of H + ALPHA*D**2 (nearly) singular.
*     Use one step of inverse power method with start from DLSVMN to
*     obtain approximate eigenvector corresponding to smallest
*     eigenvalue of (D**-1)*H*(D**-1).  DLSVMN returns X and W with
*     L*W = X.
*
 340  T = DLSVMN(NP,L,W(3*NP+11),W)
*
*     normalize W
*
      DO 350 I = 1, NP+1
         W(I) = T*W(I)
 350  CONTINUE
*
*     complete current inv. power iter. -- replace W by (L**-T)*W.
*
      CALL DLITVM(NP+1,W,L,W)
      T2 = 1.D0/DNRM2(NP+1,W)
      DO 360 I = 1, NP+1
         W(I) = T2*W(I)
 360  CONTINUE
      T = T2 * T
*
*     now W is the desired approximate (unit) eigenvector and
*     T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
*
      SW = DDOT(NP+1,W(NP+NP+10),W)
      T1 = (RAD + DST) * (RAD - DST)
      ROOT = DSQRT(SW*SW + T1)
      IF (SW .LT. 0.D0) ROOT = -ROOT
      SI = T1 / (SW + ROOT)
*
*     the actual test for the special case...
*
      IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GOTO 380
*
*     update upper bound on smallest eigenvalue (when not positive)
*     (as recommended by More and Sorensen) and continue...
*
      IF (V(3) .LE. 0.D0) V(3) = DMIN1(V(3), T2**2 - ALPHAK)
      LK = DMAX1(LK, -V(3))
*
*     check whether we can hope to detect the special case in the
*     available arithmetic.  Accept STEP as it is if not.
*     If not yet available, obtain machine dependent value DGXFAC.
*
 370  IF (DGXFAC .EQ. 0.D0) DGXFAC = 50.D0 * D1MACH(4)
      IF (DELTA .GT. DGXFAC*W(NP+2)) GOTO 250
      GOTO 270
*
*     special case detected... negate ALPHAK to indicate special case
*
 380  ALPHAK = -ALPHAK
      V(7) = 0.5D0 * TWOPSI
*
*     accept current step if adding SI*W would lead to a further
*     relative reduction in PSI of less than V(19)/3.
*
      T1 = 0.D0
      T = SI*(ALPHAK*SW-0.5D0*SI*(ALPHAK + T*DDOT(NP+1,W(3*NP+11),W)))
      IF (T .LT. EPS*TWOPSI/6.D0) GOTO 390
      V(7) = V(7) + T
      DST = RAD
      T1 = -SI
 390  DO 400 I = 1, NP+1
         J = NP + NP + 9 + I
         W(J) = T1*W(I) - W(J)
         STEP(I) = W(J) / D(I)
 400  CONTINUE
      V(4) = DDOT(NP+1,DIG,W(NP+NP+10))
*
*     save values for use in a possible restart
*
 410  V(2) = DST
      V(5) = ALPHAK
      W(NP+5) = LK
      W(NP+7) = UK
      V(9) = RAD
      W(NP+8) = DST
*
*     restore diagonal of DIHDI
*
      J = 0
      DO 420 I=1,NP+1
         J = J + I
         K = NP + 8 + I
         DIHDI(J) = W(K)
 420  CONTINUE

      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DRELHUMI(P,TK,QW, RH)
      IMPLICIT NONE
C NCL: qw = relhum_ice(p:numeric,tk:numeric,qw:numeric)

c"Improved Magnus' Form Approx. of Saturation Vapor pressure"
c Oleg A. Alduchov and Robert E. Eskridge
c  http://www.osti.gov/scitech/servlets/purl/548871/
c  One of Three best approx for +50 to -80 C max relative errors of (0.337/0.823) ?

c input
      DOUBLE PRECISION P,TK,QW
c output
      DOUBLE PRECISION RH
c NCLEND

c computes rh (relative humidity) from p, t and qw (mixing ratio)

c definition of mixing ratio
c if,
c    es  - is the saturation mixing ratio
c    ep  - is the ratio of the molecular weights of water vapor to
c          dry air
c    p   - is the atmospheric pressure
c    rh  - is the relative humidity (given as a percent)

c    rh =  100*  q / ( (ep*es)/(p-es) )

c input-
c    p      - pressure (Pa) (this function was originally written for
c             hPa/mb, so we have to do conversion below)
c    tk     - temperature (k)
c    qw     - mixing ratio (kg/kg)

c output-
c    rh     - relative humidity as %

c local
      DOUBLE PRECISION T0,EP,ONEMEP,ES0,A,B,EST,QST
      DATA T0,EP,ONEMEP,ES0,A,B/273.15D0,0.622D0,0.378D0,6.1128D0,
     +     22.571D0,273.71D0/

      EST = ES0*EXP((A* (TK-T0))/ ((TK-T0)+B))
      QST = (EP*EST)/ ((P*0.01D0)-ONEMEP*EST)
c                                    mix ratio
      RH =  100* (QW / QST)

      RETURN
      END


PROGRAM ISO

  ! Generates the time series for an isovelocity problem

  INTEGER STKFIL
  PARAMETER ( STKFIL = 6, PI = 3.141592 )

  REAL      RD( 51 ), STACK( 51, 1001 ), SD( 1 )
  COMPLEX   ST
  CHARACTER PULSE*4, PULSTITL*80

  C0    = 1500.0   ! Reference soundspeed
  PULSE = 'P   '   ! Pulse type
  FREQ  = 50.0
  FMIN  =   0.0
  FMAX  =  10.0 * FREQ
  OMEGA =   2.0 * PI * FREQ
  R     =  200.0   ! Range in meters

  TMIN = 0.0
  TMAX = 1.0
  NT   = 512
  DELT = TMAX / ( NT - 1 )

  ! Generate the vector of source/receiver depths

  NSD = 1
  SD( 1 ) = 0

  NRD = 11
  RD = [ ( IRD, IRD = 1, NRD ) ] * 10.0

  ! Construct the time series

  DO IR = 1, NRD
     SLANTR = SQRT( RD( IR ) ** 2 + R ** 2 )
     DO IT = 1, NT
        TIME = TMIN + ( IT - 1 ) * DELT
        T = TIME - SLANTR / C0    ! Reduced time

        !  calculate the source time series

        CALL SOURCE( T, ST, SD, NSD, NT, OMEGA, FMIN, FMAX, PULSE, PULSTITL )

        STACK( IR, IT ) = -ST / SLANTR
     END DO   ! Next TIME
  END DO  ! Next depth

  ! Write out the stack

  WRITE( STKFIL, * ) ''''//'Analytic- '//PULSTITL(1:69)//''''
  WRITE( STKFIL, * ) NRD, ( RD( IR ), IR = 1, NRD )

  DO IT = 1, NT
     TIME = TMIN + ( IT - 1 ) * DELT
     WRITE( STKFIL, * ) TIME, ( STACK( IR, IT ), IR = 1, NRD )
  END DO

  STOP
END PROGRAM ISO


C/MEMBR ADD NAME=COSHIN,SSI=0
c
c fonction:  coshin
c fonction cosinus hyperbolique inverse de x
c en double precision
c acheve le 05/12/85
c ecrit par philippe touron
c
c
c sous programmes appeles: aucun
c
c
c     Copyright INRIA
      double precision function coshin(x)
      double precision x
      coshin=log(x+sqrt(x*x-1.0d+0))
      return
      end


      subroutine resid_BB_hgd_adv(ctfmp,n_BB,n_DLamx,n_beta,np1_BB,np1_D
     &Lamx,np1_beta,x,Nx,advc,eta,ht,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 advc
      real*8 eta
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 n_BB(Nx)
      real*8 n_DLamx(Nx)
      real*8 n_beta(Nx)
      real*8 np1_BB(Nx)
      real*8 np1_DLamx(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_BB(i) + myzero * x(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_BB(i) + np1_BB(i)) / ht - 0.2500000000000000D0 *
     #advc * np1_beta(i) * (-0.1D1 * np1_BB(i - 1) + np1_BB(i + 1)) / hx
     # / ctfmp(i) + 0.5000000000000000D0 * eta * np1_BB(i) - 0.500000000
     #0000000D0 * np1_DLamx(i) - 0.2500000000000000D0 * advc * n_beta(i)
     # * (-0.1D1 * n_BB(i - 1) + n_BB(i + 1)) / hx / ctfmp(i) + 0.500000
     #0000000000D0 * eta * n_BB(i) - 0.5000000000000000D0 * n_DLamx(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_BB(i) + myzero * x(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


program main
  use function_generator
  implicit none

  type(c_funptr) :: cproc
  real(kind=c_double) :: a, b, tol, mw, x
  integer(kind=c_int8_t) :: error_model
  type(fg_func) :: myfun

  cproc = c_funloc(log_wrapper)
  a = 1E-15
  b = 1000
  tol = 1E-10
  mw = 1E-15
  error_model = 0

  myfun = fg_init_8_4096(cproc, a, b, tol, mw, error_model)
  x = 0.5
  print *, fg_eval(myfun, x) - log(x)

  call fg_free(myfun)

contains
  function log_wrapper (arg) bind(c) result(y)
    use, intrinsic :: iso_c_binding
    real(kind=c_double), intent(in), value :: arg
    real(kind=c_double) :: y
    y = log(arg)
  end function log_wrapper

end program main


module held_suarez_mod
  implicit none
  public :: held_suarez_driver
  private
  real, parameter :: dtabs_y = 60.0, dtheta_z = 10.0, p0=1000.,&
    kappa=2./7., sig_b = 0.7
contains
  subroutine held_suarez_driver()
    use vars
    use grid
    integer it, jt

    call t_startf('held_squarez')

    call task_rank_to_index(rank,it,jt)
    call held_suarez_t(t(1:nx,1:ny,1:nzm), tabs, pres, gamaz, dy, ny_gl, it, jt,&
      presi(1), presi(nz), dtn)
    call held_suarez_vel(u(1:nx,1:ny,1:nzm), dudt(1:nx,1:ny,1:nzm,na),&
      pres, presi(1), presi(nz))
    call held_suarez_vel(v(1:nx,1:ny,1:nzm), dvdt(1:nx,1:ny,1:nzm,na),&
      pres, presi(1), presi(nz))

    call t_stopf('held_squarez')
  end subroutine held_suarez_driver

  subroutine held_suarez_vel(u, dudt, pres, pbot, ptop)
    real, intent(in) :: u(:,:,:), pres(:)
    real, intent(inout) ::  dudt(:,:,:)
    real, intent(in) :: pbot, ptop

    ! locals
    real :: k_f, k_v
    integer :: i, j, k

    k_f = 1.0/86400.

    do k=1,size(pres, 1)
      k_v =  k_f * coef(sigma(pres(k), pbot, ptop))
      do j=lbound(dudt,2),ubound(dudt,2)
        do i=lbound(dudt,1),ubound(dudt,1)
          dudt(i,j,k) = dudt(i,j,k) - k_v * u(i,j,k)
        end do
      end do
    end do

  end subroutine held_suarez_vel

  subroutine held_suarez_t(t, tabs, pres, gamaz, dy, ny_gl, it, jt,&
      pbot, ptop, dt)
    real, intent(inout) :: t(:,:,:), tabs(:,:,:), pres(:), gamaz(:)
    real, intent(in) :: dt, dy, pbot, ptop
    integer, intent(in) :: ny_gl, it, jt
    ! locals
    real :: y, lat, pi
    real :: k_a, k_s
    real :: k_t
    integer :: nx, ny, nzm
    integer :: i, j, k

    nx = size(tabs, 1)
    ny = size(tabs, 2)
    nzm = size(tabs, 3)

    pi = atan(1.0)*4.0

    k_a = 1./40./86400.
    k_s = 1./4./86400.

    do k=1,nzm
      do j=1,ny
        y =  dy*(j+jt-(ny_gl-1.0)/2-1)
        lat = y*2.5e-8*2*pi
        ! print *, i,j,k, y, lat/2/pi*360, pres(k), t_eq(lat, pres(k))
        do i=1,nx
          k_t = k_a + cos(lat)**4&
            *(k_s - k_a) &
            * coef(sigma(pres(k), pbot, ptop))
          t(i,j,k) = t(i,j,k) - dt * k_t &
            * (tabs(i,j,k) - t_eq(lat, pres(k)))
        end do
      end do
    end do
  end subroutine held_suarez_t

  function t_eq(phi, p)
    real t_eq
    real, intent(in) :: phi, p
    ! locals
    real s, c
    s = sin(phi)
    c = cos(phi)

    t_eq = (315 - dtabs_y * s * s - dtheta_z * log(p/p0) * c * c) &
      * (p/p0)**kappa

    t_eq = max(200.0, t_eq)

  end function t_eq

  function sigma(p, pbot, ptop)
    real, intent(in) :: p, pbot, ptop
    real :: sigma
    sigma =  (p - ptop)/(pbot-ptop)
  end function sigma

  function coef(sig)
    real :: coef
    real, intent(in) :: sig
    coef = max(0.0, (sig-sig_b)/(1-sig_b))
  end function coef
end


      REAL FUNCTION FU(RLATD)
C
C SPECIFIES RIGHT HAND SIDE OF BALANCE EQUATION FOR PURPOSES OF
C NUMERICAL INTEGRATION; REQUIRES REAL FUNCTION US;
C USED FOR TEST CASE 3 GEOPOTENTIAL FIELD IN SUBROUTINE INIT
C
C CALLED BY: D01AHE
C CALLS: US
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Common Blocks ----------------------------------------------------
C
C Constants & Timesteps
      INCLUDE 'consts.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C LATITUDE
      REAL RLATD
C
C----- External Functions ----------------------------------------------
C
C Zonal flow
C
      EXTERNAL US
      REAL US
C
C----- Executable Statements -------------------------------------------
C
      FU = (2.0*OMEGA*A*SIN(RLATD) + TAN(RLATD)*US(RLATD))*US(RLATD)
      RETURN
      END


      SUBROUTINE fasper(x,y,n,ofac,hifac,wk1,wk2,nwk,nout,jmax,prob)
      INTEGER jmax,n,nout,nwk,MACC
      REAL hifac,ofac,prob,wk1(nwk),wk2(nwk),x(n),y(n)
      PARAMETER (MACC=4)
CU    USES avevar,realft,spread
      INTEGER j,k,ndim,nfreq,nfreqt
      REAL ave,ck,ckk,cterm,cwt,den,df,effm,expy,fac,fndim,hc2wt,hs2wt,
     *hypo,pmax,sterm,swt,var,xdif,xmax,xmin
      EXTERNAL spread
      nout=0.5*ofac*hifac*n
      nfreqt=ofac*hifac*n*MACC
      nfreq=64
1     if (nfreq.lt.nfreqt) then
        nfreq=nfreq*2
      goto 1
      endif
      ndim=2*nfreq
      if(ndim.gt.nwk) pause 'workspaces too small in fasper'
      call avevar(y,n,ave,var)
      xmin=x(1)
      xmax=xmin
      do 11 j=2,n
        if(x(j).lt.xmin)xmin=x(j)
        if(x(j).gt.xmax)xmax=x(j)
11    continue
      xdif=xmax-xmin
      do 12 j=1,ndim
        wk1(j)=0.
        wk2(j)=0.
12    continue
      fac=ndim/(xdif*ofac)
      fndim=ndim
      do 13 j=1,n
        ck=1.+mod((x(j)-xmin)*fac,fndim)
        ckk=1.+mod(2.*(ck-1.),fndim)
        call spread(y(j)-ave,wk1,ndim,ck,MACC)
        call spread(1.,wk2,ndim,ckk,MACC)
13    continue
      call realft(wk1,ndim,1)
      call realft(wk2,ndim,1)
      df=1./(xdif*ofac)
      k=3
      pmax=-1.
      do 14 j=1,nout
        hypo=sqrt(wk2(k)**2+wk2(k+1)**2)
        hc2wt=0.5*wk2(k)/hypo
        hs2wt=0.5*wk2(k+1)/hypo
        cwt=sqrt(0.5+hc2wt)
        swt=sign(sqrt(0.5-hc2wt),hs2wt)
        den=0.5*n+hc2wt*wk2(k)+hs2wt*wk2(k+1)
        cterm=(cwt*wk1(k)+swt*wk1(k+1))**2/den
        sterm=(cwt*wk1(k+1)-swt*wk1(k))**2/(n-den)
        wk1(j)=j*df
        wk2(j)=(cterm+sterm)/(2.*var)
        if (wk2(j).gt.pmax) then
          pmax=wk2(j)
          jmax=j
        endif
        k=k+2
14    continue
      expy=exp(-pmax)
      effm=2.*nout/ofac
      prob=effm*expy
      if(prob.gt.0.01)prob=1.-(1.-expy)**effm
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fasper.for


        SUBROUTINE STEPQS(N,NFE,IFLAG,LENQR,START,CRASH,HOLD,H,
     $            WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,PIVOT,PP,
     $            RHOVEC,Z0,DZ,T,WORK,SSPAR,PAR,IPAR)
C
C SUBROUTINE  STEPQS  TAKES ONE STEP ALONG THE ZERO CURVE OF THE
C HOMOTOPY MAP  RHO(X,LAMBDA)  USING A PREDICTOR-CORRECTOR ALGORITHM.
C THE PREDICTOR USES A HERMITE CUBIC INTERPOLANT, AND THE CORRECTOR
C RETURNS TO THE ZERO CURVE USING A NEWTON ITERATION, REMAINING
C IN A HYPERPLANE PERPENDICULAR TO THE MOST RECENT TANGENT VECTOR.
C  STEPQS  ALSO ESTIMATES A STEP SIZE  H  FOR THE NEXT STEP ALONG THE
C ZERO CURVE.
C
C
C ON INPUT:
C
C N = DIMENSION OF  X.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C LENQR = THE LENGTH OF THE ONE DIMENSIONAL ARRAY  QR.
C
C START = .TRUE. ON FIRST CALL TO  STEPQS, .FALSE. OTHERWISE.
C         SHOULD NOT BE MODIFIED BY THE USER AFTER THE FIRST CALL.
C
C HOLD = ||Y - YOLD|| ; SHOULD NOT BE MODIFIED BY THE USER.
C
C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED.  H  MUST
C    BE SET TO A POSITIVE NUMBER ON THE FIRST CALL TO  STEPQS.
C    THEREAFTER,  STEPQS  CALCULATES AN OPTIMAL VALUE FOR  H, AND  H
C    SHOULD NOT BE MODIFIED BY THE USER.
C
C WK = APPROXIMATE CURVATURE FOR THE LAST STEP (COMPUTED BY PREVIOUS
C    CALL TO  STEPQS).  UNDEFINED ON FIRST CALL.  SHOULD NOT BE
C    MODIFIED BY THE USER.
C
C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES.  THE ITERATION
C    IS CONSIDERED TO HAVE CONVERGED WHEN A POINT  Z=(X,LAMBDA)  IS
C    FOUND SUCH THAT
C       ||DZ|| .LE. RELERR*||Z|| + ABSERR,
C    WHERE  DZ  IS THE LAST NEWTON STEP.
C
C S  = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO
C    Y(S) = (X(S),LAMBDA(S)).
C
C Y(1:N+1) = PREVIOUS POINT (X(S),LAMBDA(S)) FOUND ON THE ZERO CURVE
C    OF THE HOMOTOPY MAP.
C
C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY
C    MAP AT  Y.  INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL
C    TO  STEPQS.
C
C YOLD(1:N+1) = A POINT BEFORE  Y  ON THE ZERO CURVE OF THE HOMOTOPY
C    MAP.  INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL TO
C    STEPQS.
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE
C    HOMOTOPY MAP AT  YOLD.
C
C A(1:N) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR.  (SEE SUBROUTINE  PCGQS  FOR A DESCRIPTION
C    OF THIS DATA STRUCTURE).
C
C PIVOT(1:N+2)  IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN
C    THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR.
C
C PP(1:N)  IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN
C    OF THE JACOBIAN MATRIX  -[D RHO/D LAMBDA].
C
C RHOVEC(1:N+1), Z0(1:N+1), DZ(1:N+1), T(1:N+1)  ARE ALL WORK ARRAYS
C    USED BY  STEPQS, TANGQS, AND ROOTQS  TO CALCULATE THE TANGENT
C    VECTORS AND NEWTON STEPS.
C
C WORK(1:8*(N+1)+LENQR)  IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT
C    ALGORITHM TO SOLVE LINEAR SYSTEMS.
C
C SSPAR(1:4) = PARAMETERS USED FOR COMPUTATION OF THE OPTIMAL STEP SIZE.
C    SSPAR(1) = HMIN, SSPAR(2) = HMAX, SSPAR(3) = BMIN, SSPAR(4) = BMAX.
C    THE OPTIMAL STEP  H  IS RESTRICTED SUCH THAT
C       HMIN .LE. H .LE. HMAX, AND  BMIN*HOLD .LE. H .LE. BMAX*HOLD.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C N, LENQR, A  ARE UNCHANGED.
C
C NFE HAS BEEN UPDATED.
C
C IFLAG
C
C    = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN.
C
C    = 4 IF A JACOBIAN MATRIX WITH RANK <  N  HAS OCCURRED.  THE
C        ITERATION WAS NOT COMPLETED.
C
C    = 6 IF THE ITERATION FAILED TO CONVERGE.
C
C START = .FALSE. ON A NORMAL RETURN.
C
C CRASH
C
C    = .FALSE. ON A NORMAL RETURN.
C
C    = .TRUE. IF THE STEP SIZE  H  WAS TOO SMALL.  H  HAS BEEN
C      INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH  STEPQS  MAY BE
C      CALLED AGAIN.
C
C    = .TRUE. IF  RELERR  AND/OR  ABSERR  WERE TOO SMALL.  THEY HAVE
C      BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH  STEPQS  MAY
C      BE CALLED AGAIN.
C
C HOLD = ||Y-YOLD||.
C
C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED.  NORMALLY  H  SHOULD
C     NOT BE MODIFIED BY THE USER.
C
C WK = APPROXIMATE CURVATURE FOR THE STEP TAKEN BY  STEPQS.
C
C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY
C     MAP UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN  Y.
C
C RELERR, ABSERR  ARE UNCHANGED ON A NORMAL RETURN.  THEY ARE POSSIBLY
C     CHANGED IF  CRASH  = .TRUE. (SEE DESCRIPTION OF  CRASH  ABOVE).
C
C Y, YP, YOLD, YPOLD  CONTAIN THE TWO MOST RECENT POINTS AND TANGENT
C     VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP.
C
C
C CALLS  D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, F (OR RHO), FJACS
C     (OR RHOJS), PCGQS, TANGQS.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ALPHA, CORDIS, DD001, DD0011,DD01,DD011,DELS,
     $    FOURU, GAMMA, HFAIL, HTEMP, IDLERR, LAMBDA, OMEGA, ONE, P0,
     $    P1, PP0, PP1, SIGMA, TEMP, THETA, TWOU, WKOLD, XSTEP
        INTEGER I, ITCNT, LITFH, J, LK, LST, NP1, PCGWK, ZU
        LOGICAL FAILED
C
C     SCALAR ARGUMENTS
C
        INTEGER N, NFE, IFLAG, LENQR
        LOGICAL START, CRASH
        DOUBLE PRECISION HOLD, H, WK, RELERR, ABSERR, S
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1),
     $    A(N), QR(LENQR), PP(N), RHOVEC(N+1), Z0(N+1), DZ(N+1),
     $    T(N+1), WORK(8*(N+1)+LENQR), SSPAR(4), PAR(1)
        INTEGER PIVOT(N+2), IPAR(1)
        REAL WRGE(8),ACOF(12)
C
        SAVE
C
        DATA WRGE  /
     $   .8735115E+00, .1531947E+00, .3191815E-01, .3339946E-10,
     $   .4677788E+00, .6970123E-03, .1980863E-05, .1122789E-08/
        DATA ACOF  /
     $   .9043128E+00,-.7075675E+00,-.4667383E+01,-.3677482E+01,
     $   .8516099E+00,-.1953119E+00,-.4830636E+01,-.9770528E+00,
     $   .1040061E+01, .3793395E-01, .1042177E+01, .4450706E-01/
C
C ***** END OF DECLARATIONS *****
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
        DD01(P0,P1,DELS) = (P1-P0)/DELS
        DD001(P0,PP0,P1,DELS) = (DD01(P0,P1,DELS)-PP0)/DELS
        DD011(P0,P1,PP1,DELS) = (PP1-DD01(P0,P1,DELS))/DELS
        DD0011(P0,PP0,P1,PP1,DELS) = (DD011(P0,P1,PP1,DELS) -
     $                                DD001(P0,PP0,P1,DELS))/DELS
        QOFS(P0,PP0,P1,PP1,DELS,S) = ((DD0011(P0,PP0,P1,PP1,DELS)*
     $    (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C
C ***** INITIALIZATION *****
C
C LITFH = MAXIMUM NUMBER OF NEWTON ITERATIONS ALLOWED.
C
        ONE = 1.0
        TWOU = 2.0*D1MACH(4)
        FOURU = TWOU + TWOU
        NP1 = N+1
        FAILED = .FALSE.
        CRASH = .TRUE.
        LITFH = 10
        PCGWK = 2*N+3
        ZU = 3*N+4
C
C CHECK THAT ALL INPUT PARAMETERS ARE CORRECT.
C
C     THE ARCLENGTH  S  MUST BE NONNEGATIVE.
C
        IF (S .LT. 0.0) RETURN
C
C     IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE.
C
        IF (H .LT. FOURU*(1.0+S)) THEN
          H=FOURU*(1.0 + S)
          RETURN
        END IF
C
C     IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE
C     VALUES.
C
        TEMP=DNRM2(NP1,Y,1) + 1.0
        IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN
          IF (RELERR .NE. 0.0) THEN
            RELERR = FOURU*(1.0+FOURU)
            TEMP = 0.0
            ABSERR = MAX(ABSERR,TEMP)
          ELSE
            ABSERR=FOURU*TEMP
          END IF
          RETURN
        END IF
C
C     INPUT PARAMETERS WERE ALL ACCEPTABLE.
C
        CRASH = .FALSE.
C
C COMPUTE  YP  ON FIRST CALL.
C
        IF (START) THEN
C
C         INITIALIZE THE IDEAL ERROR USED FOR STEP SIZE ESTIMATION.
C
          IDLERR=SQRT(SQRT(ABSERR))
C
C         INITIALIZE STARTING POINTS FOR THE CONJUGATE GRADIENT
C         ALGORITHM TO ZERO.
C
          DO 10 J=1,2*N+2
            WORK(J)=0.0
  10      CONTINUE
          CALL TANGQS(Y,YP,YPOLD,A,QR,PIVOT,PP,RHOVEC,WORK,
     $              N,LENQR,IFLAG,NFE,PAR,IPAR)
          IF (IFLAG .GT. 0) RETURN
        END IF
C
C ***** COMPUTE PREDICTOR POINT Z0 *****
C
  20    IF (START) THEN
C
C         COMPUTE Z0 WITH LINEAR PREDICTOR USING Y, YP --
C         Z0 = Y+H*YP.
C
          CALL DCOPY(NP1,Y,1,Z0,1)
          CALL DAXPY(NP1,H,YP,1,Z0,1)
C
        ELSE
C
C         COMPUTE Z0 WITH CUBIC PREDICTOR.
C
          DO 30 I=1,NP1
            Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H)
  30      CONTINUE
C
        END IF
C
C ***** END OF PREDICTOR SECTION *****
C
C ***** NEWTON ITERATION *****
C
        DO 140 ITCNT = 1,LITFH
C
C SET STARTING POINTS FOR CONJUGATE GRADIENT ALGORITHM.
C
        DO 40 J=ZU,ZU+2*N+1
          WORK(J) = 0.0
  40    CONTINUE
C
C COMPUTE QR = [D RHO/DX], RHOVEC=RHO, -PP= (D RHO/D LAMBDA).
C
        LAMBDA = Z0(NP1)
        IF (IFLAG .EQ. -2) THEN
C
C         CURVE TRACKING PROBLEM.
C
          CALL RHOJS(A,LAMBDA,Z0,QR,LENQR,PIVOT,PP,PAR,IPAR)
          CALL RHO(A,LAMBDA,Z0,RHOVEC,PAR,IPAR)
        ELSE IF (IFLAG .EQ. -1) THEN
C
C         ZERO FINDING PROBLEM.
C
          CALL FJACS(Z0,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,LAMBDA,QR,1)
          SIGMA=1.0-LAMBDA
          DO 50 J=1,N
            QR(PIVOT(J))=QR(PIVOT(J))+SIGMA
  50      CONTINUE
          CALL DCOPY(N,Z0,1,RHOVEC,1)
          CALL DAXPY(N,-ONE,A,1,RHOVEC,1)
          CALL F(Z0,PP)
          CALL DSCAL(N,-ONE,PP,1)
          CALL DAXPY(N,ONE,RHOVEC,1,PP,1)
          CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
        ELSE
C
C         FIXED POINT PROBLEM.
C
          CALL FJACS(Z0,QR,LENQR,PIVOT)
          CALL DSCAL(LENQR,-LAMBDA,QR,1)
          DO 60 J=1,N
            QR(PIVOT(J)) = QR(PIVOT(J))+1.0
  60      CONTINUE
          CALL DCOPY(N,Z0,1,RHOVEC,1)
          CALL DAXPY(N,-ONE,A,1,RHOVEC,1)
          CALL F(Z0,PP)
          CALL DAXPY(N,-ONE,A,1,PP,1)
          CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1)
        END IF
        RHOVEC(NP1) = 0.0
        NFE = NFE+1
C
C SOLVE SYSTEM TO FIND NEWTON STEP  DZ.
C
          CALL PCGQS(N,QR,LENQR,PIVOT,PP,YP,RHOVEC,DZ,
     $         WORK(PCGWK),IFLAG)
          IF (IFLAG .GT. 0) RETURN
C
C TAKE STEP.
C
          CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1)
C
C CHECK FOR CONVERGENCE.
C
          XSTEP=DNRM2(NP1,DZ,1)
          IF (XSTEP .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) THEN
             GO TO 160
          END IF
C
  140   CONTINUE
C
C ***** END OF NEWTON LOOP *****
C
C ***** DIDN'T CONVERGE OR TANGENT AT NEW POINT DID NOT MAKE *****
C       AN ANGLE SMALLER THAN 60 DEGREES WITH  YPOLD --
C       TRY AGAIN WITH A SMALLER H
C
  150   FAILED = .TRUE.
        HFAIL = H
        IF (H .LE. FOURU*(1.0 + S)) THEN
          IFLAG = 6
          RETURN
        ELSE
          H = .5 * H
        END IF
        GO TO 20
C
C ***** END OF CONVERGENCE FAILURE SECTION *****
C
C ***** CONVERGED -- MOP UP AND RETURN *****
C
C COMPUTE TANGENT AT Z0.
C
  160   CALL TANGQS(Z0,T,YP,A,QR,PIVOT,PP,RHOVEC,WORK,N,
     $       LENQR,IFLAG,NFE,PAR,IPAR)
        IF (IFLAG .GT. 0) RETURN
C
C CHECK THAT COMPUTED TANGENT  T  MAKES AN ANGLE NO LARGER THAN
C 60 DEGREES WITH CURRENT TANGENT  YP.  (I.E., COS OF ANGLE < .5)
C IF NOT, STEP SIZE WAS TOO LARGE, SO THROW AWAY Z0, AND TRY
C AGAIN WITH A SMALLER STEP.
C
        ALPHA = DDOT(NP1,T,1,YP,1)
        IF (ALPHA .LT. 0.5) GOTO 150
        ALPHA = ACOS(ALPHA)
C
C COMPUTE CORRECTOR DISTANCE.
C
      IF (START) THEN
        CALL DCOPY(NP1,Y,1,WORK(PCGWK),1)
        CALL DAXPY(NP1,H,YP,1,WORK(PCGWK),1)
      ELSE
        DO 170 I=1,NP1
          WORK(PCGWK+I-1)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H)
  170   CONTINUE
      ENDIF
        CALL DAXPY(NP1,-ONE,Z0,1,WORK(PCGWK),1)
        CORDIS=DNRM2(NP1,WORK(PCGWK),1)
C
C SET UP VARIABLES FOR NEXT CALL.
C
        CALL DCOPY(NP1,Y,1,YOLD,1)
        CALL DCOPY(NP1,Z0,1,Y,1)
        CALL DCOPY(NP1,YP,1,YPOLD,1)
        CALL DCOPY(NP1,T,1,YP,1)
C
C UPDATE ARCLENGTH   S = S + ||Y-YOLD||.
C
        HTEMP = HOLD
        CALL DAXPY(NP1,-ONE,YOLD,1,Z0,1)
        HOLD = DNRM2(NP1,Z0,1)
        S = S+HOLD
C
C COMPUTE IDEAL ERROR FOR STEP SIZE ESTIMATION.
C
        IF (ITCNT .LE. 1) THEN
          THETA = 8.0
        ELSE IF (ITCNT .EQ. 4) THEN
          THETA = 1.0
        ELSE
          OMEGA=XSTEP/CORDIS
          IF (ITCNT .LT. 4) THEN
            LK = 4*ITCNT-7
            IF (OMEGA .GE. WRGE(LK)) THEN
              THETA = 1.0
            ELSE IF (OMEGA .GE. WRGE(LK+1)) THEN
              THETA = ACOF(LK) + ACOF(LK+1)*LOG(OMEGA)
            ELSE IF (OMEGA .GE. WRGE(LK+2)) THEN
              THETA = ACOF(LK+2) + ACOF(LK+3)*LOG(OMEGA)
            ELSE
              THETA = 8.0
            END IF
          ELSE IF (ITCNT .GE. 7) THEN
            THETA = 0.125
          ELSE
            LK = 4*ITCNT - 16
            IF (OMEGA .GT. WRGE(LK)) THEN
              LST = 2*ITCNT - 1
              THETA = ACOF(LST) + ACOF(LST+1)*LOG(OMEGA)
            ELSE
              THETA = 0.125
            END IF
          END IF
        END IF
        IDLERR=THETA*IDLERR
C
C     IDLERR SHOULD BE NO BIGGER THAN 1/2 PREVIOUS STEP.
C
        IDLERR = MIN(.5*HOLD,IDLERR)
C
C COMPUTE OPTIMAL STEP SIZE.
C   WK = APPROXIMATE CURVATURE = 2*SIN(ALPHA/2)/HOLD  WHERE
C        ALPHA = ARCCOS(YP*YPOLD).
C   GAMMA = EXPECTED CURVATURE FOR NEXT STEP, COMPUTED BY
C        EXTRAPOLATING FROM CURRENT CURVATURE  WK, AND LAST
C        CURVATURE  WKOLD.  GAMMA  IS FURTHER REQUIRED TO BE
C        POSITIVE.
C
        WKOLD = WK
        WK = 2.0*ABS(SIN(.5*ALPHA))/HOLD
        IF (START) THEN
           GAMMA = WK
        ELSE
           GAMMA = WK + HOLD/(HOLD+HTEMP)*(WK-WKOLD)
        END IF
        GAMMA = MAX(GAMMA, 0.01*ONE)
        H = SQRT(2.0*IDLERR/GAMMA)
C
C     ENFORCE RESTRICTIONS ON STEP SIZE SO AS TO ENSURE STABILITY.
C        HMIN <= H <= HMAX, BMIN*HOLD <= H <= BMAX*HOLD.
C
        H = MIN(MAX(SSPAR(1),SSPAR(3)*HOLD,H),SSPAR(4)*HOLD,SSPAR(2))
        IF (FAILED) H = MIN(HFAIL,H)
        START = .FALSE.
C
C ***** END OF MOP UP SECTION *****
C
        RETURN
C
C ***** END OF SUBROUTINE STEPQS *****
        END


* Example from the C source of Andreas Podelski
*
* In case : I = K -1, there are no bound violations,
* but we have to set at least :
* setproperty SEMANTICS_FIX_POINT_OPERATOR "derivative"
* activate TRANSFORMERS_INTER_FULL
* #activate PRECONDITIONS_INTER_FULL
* so that PIPS can prove it
*
* In case : I = K, there are bound violations

      SUBROUTINE INSERTIONSORT(A, N)
      REAL A(0:N-1), X
      INTEGER N

      INTEGER I,K

      DO 100 K=1,N-1
         X = A(K)
         I = K
C         I = K-1
         DO WHILE ((I .GE. 0).AND.( A(I) .GT. X))
            A(I+1) = A(I)
            I = I-1
         ENDDO
         A(I+1)=X
 100  CONTINUE

      END


! in order to caculate different funciont f(x),
! this module is used to define f(x)
! you can also add other f(x)
MODULE function_mod
    IMPLICIT NONE
    PRIVATE
    PUBLIC::fun
CONTAINS
    SUBROUTINE fun(k,x,y)
        REAL(8),INTENT(IN):: x
        REAL(8),INTENT(INOUT) ::y
        INTEGER(4)::k ! k is used to select the function
!-------------------------------------------------------
    SELECT CASE (k)
        CASE(1)
            y=1/(1+x)
        CASE(2)
            y=log(1+x)/(1+x*x)
        CASE(3)
            y=log(1+x)/x
        CASE(4)
            y=sin(x)/x
    END SELECT
!-------------------------------------------------------
    END SUBROUTINE
END MODULE


! Created by EverLookNeverSee@GitHub on 6/11/20
! For more information see FCS/img/Exercise_12.png

program main
    implicit none
    ! declaring and initializing variables
    integer :: i
    real :: tmp
    real, dimension(50) :: y
    y = [(i, i = 1, 50)]
    ! calculating and replacing smoothing of thr data
    do i = 2, 49
        tmp = (y(i - 1) + y(i) + y(i + 1)) / 3.0
        y(i) = tmp
    end do
    ! printing results
    print *, y
end program main