c     Introduced by Ben Allanach to provide a wrapper to C class
      subroutine dilogwrap(a, b, c, d)

      implicit none

      double precision a, b, c, d
      complex*16 x, l, pCSPEN

      x = dcmplx(a, b)
      l = pCSPEN(x)

      c = dble(l)
      d = dimag(l)

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     SPENCE-FUNKTION KOMPLEX, FREI NACH HOLLIK                     C
C---------------------------------------------------------------------C
C     20.07.83    LAST CHANGED 10.05.89        ANSGAR DENNER        C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      FUNCTION pCSPEN(ZZ)

      COMPLEX*16 pCSPEN,W,SUM,ZZ,Z,U
      DOUBLE PRECISION RZ,AZ,A1
      DOUBLE PRECISION B(9)
C     BEACHTE:                 B(N)=B2N
C     B(1)=1./6.
C     B(2)=-1./30.
C     B(3)=1./42.
C     B(4)=-1./30.
C     B(5)=5./66.
C     B(6)=-691./2730.
C     B(7)=7./6.
C     B(8)=-3617./510.
C     B(9)=43867./798.
C     PI=3.1415926535897932384
C     PI*PI/6.=1.6449..., PI*PI/3=3.28986...

      B(1)=0.1666666666666666666666666667d0
      B(2)=-0.0333333333333333333333333333d0
      B(3)=0.0238095238095238095238095238d0
      B(4)=-0.0333333333333333333333333333d0
      B(5)=0.0757575757575757575757575758d0
      B(6)=-0.2531135531135531135531135531d0
      B(7)=1.1666666666666666666666666667d0
      B(8)=-7.09215686274509804d0
      B(9)=54.97117794486215539d0

c     write(*,*) 'z:',z
      Z =ZZ*DCMPLX(1D0)
      RZ=DREAL(Z)
      AZ=CDABS(Z)
      A1=CDABS(1D0-Z)
c     write(*,*)'z, rz, az, a1:',z,rz,az,a1
C     IF((SNGL(RZ) .EQ. 0.0) .AND. (SNGL(DIMAG(Z)) .EQ. 0.0)) THEN
C     ---> CHANGED  10.5.89
      IF(AZ .LT. 1D-20) THEN
         pCSPEN=-CDLOG(1D0-Z)
c     write(*,*) 'cspen:', cspen
         RETURN
      END IF
      IF((SNGL(RZ) .EQ. 1.0) .AND. (SNGL(DIMAG(Z)) .EQ. 0.0)) THEN
         pCSPEN=1.64493406684822643D0
c     write(*,*) 'cspen:', cspen
         RETURN
      END IF
      IF(RZ.GT.5D-1) GOTO 20
      IF(AZ.GT.1D0) GOTO 10
      W=-CDLOG(1D0-Z)
      SUM=W-0.25D0*W*W
      U=W
      IF(CDABS(U).LT.1D-10) GOTO 2
c     write(*,*) 'u:',u
c     write(*,*) 'sum:',sum
      DO 1 K=1,9
         U=U*W*W/DFLOAT(2*K*(2*K+1))
         IF(CDABS(U*B(K)/SUM).LT.1D-20) GOTO 2
         SUM=SUM+U*B(K)
 1    CONTINUE
 2    pCSPEN=SUM
c     write(*,*) 'cspen:', cspen
      RETURN
 10   W=-CDLOG(1D0-1D0/Z)
      SUM=W-0.25D0*W*W
      U=W
      IF(CDABS(U).LT.1D-10) GOTO 12

      DO 11 K=1,9
         U=U*W*W/DFLOAT(2*K*(2*K+1))
         IF(CDABS(B(K)*U/SUM).LT.1D-20) GOTO 12
         SUM=SUM+U*B(K)
 11   CONTINUE
 12   pCSPEN=-SUM-1.64493406684822643D0-.5D0*CDLOG(-Z)**2
c     write(*,*) 'cspen:', cspen
      RETURN
 20   IF(A1.GT.1D0) GOTO 30
      W=-CDLOG(Z)
      SUM=W-0.25D0*W*W
      U=W
      IF(CDABS(U).LT.1D-10) GOTO 22
      DO 21 K=1,9
         U=U*W*W/DFLOAT(2*K*(2*K+1))
         IF(CDABS(U*B(K)/SUM).LT.1D-20) GOTO 22
         SUM=SUM+U*B(K)
 21   CONTINUE
 22   pCSPEN=-SUM+1.64493406684822643D0-CDLOG(Z)*CDLOG(1D0-Z)
c     write(*,*) 'cspen:', cspen
      RETURN
 30   W=CDLOG(1D0-1D0/Z)
      SUM=W-0.25D0*W*W
      U=W
      IF(CDABS(U).LT.1D-10) GOTO 32
      DO 31 K=1,9
         U=U*W*W/DFLOAT(2*K*(2*K+1))
         IF(CDABS(U*B(K)/SUM).LT.1D-20) GOTO 32
         SUM=SUM+U*B(K)
 31   CONTINUE
 32   pCSPEN=SUM+3.28986813369645287D0
     *     +.5D0*CDLOG(Z-1D0)**2-CDLOG(Z)*CDLOG(1D0-Z)
c     write(*,*) 'cspen:', cspen
      END


      subroutine DSVALA ( K, N, T, NDERIV, BDIF, X, SVALUE)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DSVALA Krogh  Changes to use M77CON
c>> 1993-01-12 DSVALA CLL Bringing basis computation inline.
c>> 1992-11-12 C. L. Lawson, JPL Saving LEFTI.
c>> 1992-11-02 C. L. Lawson, JPL
c>> 1988-03-16 C. L. Lawson, JPL
c
c     A spline function is defined by the contents of K, N, and T().
c     Given array BDIF(,) containing B-spline coefficients and
c     differences of these, this subroutine computes and stores into
c     SVALUE(1:NDERIV+1) the value and derivatives through order NDERIV
c     of the spline function evaluated at the abcissa, X.
c     Derivatives of order .ge. K will be zero.
c
c     The subroutine, BSPLPP, given on pp. 140-141 of
c     A PRACTICAL GUIDE TO SPLINES by Carl De Boor, Springer-Verlag,
c     1978, has been recoded as separate subroutines: DSTOT (or DSTOP)
c     calling DSDIF and DSVALA.  This subroutine has the functionality
c     of lines 72-103 of BSPLPP in the book.
c     ------------------------------------------------------------------
c--D replaces "?": ?SVALA, ?SFIND
c     Both versions use IERM1, IERV1
c     ------------------------------------------------------------------
      integer KMAX
      parameter(KMAX=20)
      integer I, ID, J, JP1, K, KP1MN, L, LEFT, LEFTI, LEFTPL
      integer MODE, N, NDER, NDERIV
      double precision BDIF(N,NDERIV+1), DELTAL(KMAX), DELTAR(KMAX)
      double precision ONE, SAVED, SVALUE(NDERIV+1)
      double precision T(N+K), TERM, VNIKX(KMAX), X, ZERO
      parameter(ONE = 1.0d0, ZERO = 0.0d0)
      save LEFTI
      data LEFTI / 1/
c     ------------------------------------------------------------------
      if(K .gt. KMAX) then
         call IERM1('DSVALA',1,2,'Require KORDER .le. KMAX.',
     *   'KORDER',K,',')
         call IERV1('KMAX',KMAX,'.')
         return
      endif
      do 5 I=1,NDERIV+1
         SVALUE(I) = ZERO
    5 continue
      call DSFIND(T, K, N+1, X, LEFTI, MODE)
C
c     LEFTI has been found so that [T(LEFTI), T(LEFTI+1)] is the
c     reference interval for the polynomial piece to be used in
c     evaluating at X.
c
      NDER = min(NDERIV, K-1)
      KP1MN = K-NDER
c
c        Compute values of KP1MN basis functions of order KP1MN at X.
c        Store these in VNIKX(1:KP1MN).  Here KP1MN .ge. 1.
c
      VNIKX(1) = ONE
      do 27 J = 1, KP1MN-1
         JP1 = J + 1
         DELTAR(J) = T(LEFTI+J) - X
         DELTAL(J) = X - T(LEFTI+1-J)
         SAVED = ZERO
         do 26 I=1,J
            TERM = VNIKX(I)/(DELTAR(I) + DELTAL(JP1-I))
            VNIKX(I) = SAVED + DELTAR(I)*TERM
            SAVED = DELTAL(JP1-I)*TERM
   26    continue
         VNIKX(JP1) = SAVED
   27 continue
c
c        Loop on ID.  For each value of ID, evaluate the derivative of
c        order ID-1 at X, and store it in SVALUE(ID).
c        Then, if ID > 1, update basis function values
c        in VNIKX() to the next higher order. (From order J to JP1).
c
      do 55 ID = NDER+1, 1, -1
         LEFT = LEFTI - KP1MN
         do 52 L=1,KP1MN
            LEFTPL = LEFT+L
            SVALUE(ID) = VNIKX(L)*BDIF(LEFTPL,ID) + SVALUE(ID)
   52    continue
         if (ID .gt. 1) then
            J = KP1MN
            JP1 = J + 1
            DELTAR(J) = T(LEFTI+J) - X
            DELTAL(J) = X - T(LEFTI+1-J)
            SAVED = ZERO
            do 54 I=1,J
               TERM = VNIKX(I)/(DELTAR(I) + DELTAL(JP1-I))
               VNIKX(I) = SAVED + DELTAR(I)*TERM
               SAVED = DELTAL(JP1-I)*TERM
   54       continue
            VNIKX(JP1) = SAVED
         endif
         KP1MN = KP1MN+1
   55 continue
      return
      end


! A collection of functions to compute various moist thermodynamic quantities

! Rodrigo Caballero Augi 2000, 2005

! References: Bolton (1980), Mon. Wea. Rev. 108, 1046-1053
!             Bohren and Albrecht (1998), "Atmospheric Thermodynamics"
!             Flatau et al (1992), J. App. Met . 31, 1507-1513.

!------------------------------------------------------------------------
subroutine tdew(km,jm,im,p,q,t)

! compute dew point temperature tdew  [K]
! at pressure p [mb] and specific humidity q [g/kg]
! Use Bolton eqn (11)
!
  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: p,q
  real(8), dimension(km,jm,im), intent(out) :: t

! Local
  real(8) :: Rv, Rd, eps
  real(8), dimension(km,jm,im) :: r,es,loges

  Rv  = 461.5
  Rd  = 287.04
  eps = Rd/Rv
  r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]
  es = p*r/(r+eps*1.e3)   ! vapor pressure of water vap
  loges = log(es)

  t = ( 243.5*loges-440.8 )/( 19.48-loges ) + 273.15

end subroutine tdew
!------------------------------------------------------------------------
subroutine tstar(km,jm,im,T,p,q,Ts)

! compute saturation point temperature Ts [K]
! (i.e. temperature at lifting condensation level)
! given temperature T [K], pressure p [mb], specific humidity q [g/kg].
! Use Bolton eqn (12)

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: T,p,q
  real(8), dimension(km,jm,im), intent(out) :: Ts

! Local
  real(8) :: Rv, Rd, eps, oneoverk
  real(8), dimension(km,jm,im) :: r,th,c,e

  Rv  = 461.5
  Rd  = 287.04
  eps = Rd/Rv
  oneoverk = 3.504 ! Cp/Rd
  r = q/(1.e3 - q)  ! water vap. mixing ratio [kg/kg]

!  call theta(km,jm,im,t,p,q,th)
!  c=log( r/(r+eps*1.e3)/t**oneoverk / 1.7743e-8 )
!  ts=217.8*c/(12.992-c) + 273.15
  e = p*r/(r+eps)
  Ts = 2840./( 3.5*log(t) - log(e) - 4.805) + 55.

end subroutine tstar
!------------------------------------------------------------------------
subroutine theta(km,jm,im, Rd, Rv, cpd, cpv, p0, p, T, q, th)

! compute potential temperature  theta [K]
! given temperature t [K], pressure p [mb], specific humidity q [g/kg].

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: p0,Rd,Rv,cpd,cpv
  real(8), dimension(km,jm,im), intent(in)  :: T,p,q
  real(8), dimension(km,jm,im), intent(out) :: th

! Local
  real(8) :: eps
  real(8), dimension(km,jm,im) :: cp,R,kappa

  eps   = Rd/Rv
  R     = Rd * (1.+ (1.-eps)/eps*q*1.e-3)
  cp    = cpd * (1. + (cpv/cpd-1.)*q*1.e-3)
  kappa = R/cp

  th = T*(p0/p)**kappa

end subroutine theta
!------------------------------------------------------------------------
subroutine theta_old(km,jm,im,t,p,q,th)

! compute potential temperature  theta [K]
! given temperature t [K], pressure p [mb], specific humidity q [g/kg].
! Use Bolton eqn (7)

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: t,p,q
  real(8), dimension(km,jm,im), intent(out) :: th

! Local
  real(8) :: ak
  real(8), dimension(km,jm,im) :: r

  ak=0.2854 ! R_(dry air)/Cp
  r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]

  th = t*(1000./p)**( ak*(1.-0.28e-3*r) )

end subroutine theta_old
!------------------------------------------------------------------------
subroutine thetae(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,p0,p,T,wt,the)

! compute equivalent potential temperature the [K]
! given temperature t [K], pressure p [mb],
! total water mixing ratio [g/kg].
! Use Bohren+Albrecht (6.119) and (6.122), p.293

  implicit none
  integer, intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: p0,Rd,Rv,lv0,cpv,cpd,cl
  real(8), dimension(km,jm,im), intent(in)  :: p,T,wt
  real(8), dimension(km,jm,im), intent(out) :: the

! Local
  integer :: k,j,i
  real(8), dimension(km,jm,im)  :: esat,wsat,lv,cp,T1,p1,wt1
  real(8) :: eps,q,Tst,pst

  eps = Rd/Rv

  T1 = T
  p1 = p
  wt1 = wt
  call ws(km,jm,im,Rd,Rv,T,p,wsat)
  do i=1,im
     do j=1,jm
        do k=1,km
           ! if wt was not specified, set it to wsat
           if (wt(k,j,i) < 0.)  then
              wt1(k,j,i) = wsat(k,j,i)
           ! if parcel unsaturated, bring to LCL
           else if (wt(k,j,i) < wsat(k,j,i))  then
              q = wt(k,j,i)/(1.+wt(k,j,i)*1.e-3)
              call tstar(1,1,1,T(k,j,i),p(k,j,i),q,Tst) ! gives T at LCL
              pst = p(k,j,i)*(Tst/T(k,j,i))**(cpd/Rd)   ! gives p at LCL
              T1(k,j,i) = Tst
              p1(k,j,i) = pst
           endif
        enddo
     enddo
  enddo
  call es(km,jm,im,T1,esat)
  call ws(km,jm,im,Rd,Rv,T1,p1,wsat)
  lv  = lv0 + (cpv-cl)*(T1-273.15)
  cp  = cpd+wt1*1.e-3*cl
  the = T1*((p1-esat)/p0)**(-Rd/cp)*exp(lv*wsat*1.e-3/cp/T1)

end subroutine thetae
!------------------------------------------------------------------------
subroutine thetaes(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,p0,p,T,thes)

! compute saturation equivalent potential temperature thes [K]
! given temperature T [K] and pressure p [mb]
! Use Bohren+Albrecht (6.123), p.293

  implicit none
  integer, intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: p0,Rd,Rv,lv0,cpv,cpd,cl
  real(8), dimension(km,jm,im), intent(in)  :: p,T
  real(8), dimension(km,jm,im), intent(out) :: thes

! Local
  integer :: k,j,i
  real(8), dimension(km,jm,im)  :: esat,wsat,lv,cp
  real(8) :: eps,q,Tst,pst

  eps = Rd/Rv

  call es(km,jm,im,T,esat)
  call ws(km,jm,im,Rd,Rv,T,p,wsat)
  wsat = wsat * 1.e-3 ! g/kg -> kg/kg
  lv  = lv0 + (cpv-cl)*(T-273.15)
  cp  = cpd + wsat*cl
  thes = T*((p-esat)/p0)**(-Rd/cp)*exp(lv*wsat/cp/T)

end subroutine thetaes
!------------------------------------------------------------------------
subroutine thetae_old(km,jm,im,t,p,q,the)

! compute equivalent potential temperature thetae [K]
! given temperature t [K], pressure p [mb], specific humidity q [g/kg].
! Use Bolton eqn (38)

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: t,p,q
  real(8), dimension(km,jm,im), intent(out) :: the

! Local
  real(8), dimension(km,jm,im) :: r,th,ts

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

  the = th * exp( (3.376/ts-0.00254)*r*(1.+0.81e-3*r) )

end subroutine thetae_old
!------------------------------------------------------------------------
subroutine es(km,jm,im,T,e)

! Compute saturation partial pressure of water vapor es [mb]
! at temperature T [K].
! Use Bohren+Albrecht p. 198

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: T
  real(8), dimension(km,jm,im), intent(out) :: e

! Local
  real(8) :: T0

  T0 = 273.15
  e  = 6.11 * exp( 6808.*(1./T0 - 1./T) - 5.09*log(T/T0) )

end subroutine es
!------------------------------------------------------------------------
subroutine esflatau(km,jm,im,T,i,e)

! Compute saturation partial pressure of water vapor es [mb]
! at temperature T [K].
! Use 8th oRder polynomial fit of Flatau et al (1992), Table 4

! i=1 => vapour pressure over water (valid -85C < t < 70C)
! i=2 => vapour pressure over ice (valid -90C < t < 0C)

  implicit none
  integer,intent(in)                       :: km,jm,im,i
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: T
  real(8), dimension(km,jm,im), intent(out) :: e

! Local
  integer :: n
  real(8) :: t0
  real(8), dimension(9,2) :: a

  data a / 6.11239921,    0.443987641,  0.142986287e-1,  0.264847430e-3, &
       0.302950461e-5, 0.206739458e-7, 0.640689451e-10,-0.952447341e-13, &
       -0.976195544e-15,                                                 &
       6.11147274,    0.503160820, 0.188439774e-1,  0.420895665e-3,  &
   0.615021634e-5, 0.602588177e-7, 0.385852041e-9, 0.146898966e-11,  &
   0.252751365e-14 /

  t0=273.15

  e = a(9,i)
  do n=8,1,-1
     e = e*(t-t0) + a(n,i)
  enddo

end subroutine esflatau
!------------------------------------------------------------------------
subroutine qs(km,jm,im,Rd,Rv,T,p,q)

! Compute saturation specific humidity qs [g/kg]
! given temperature T [K] and total (air+vapor) pressure p [mb]
! use Bohren+Albrecht p. 186

  implicit none
  integer,intent(in)                        :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: Rd,Rv
  real(8), dimension(km,jm,im), intent(in)  :: T,p
  real(8), dimension(km,jm,im), intent(out) :: q

! Local
  real(8) :: eps
  real(8), dimension(km,jm,im) :: e

  eps=Rd/Rv
  call es(km,jm,im,T,e)
  q = eps*e/(p+e*(eps-1.)) * 1.e3

end subroutine qs
!------------------------------------------------------------------------
subroutine qsflatau(km,jm,im,Rd,Rv,T,p,i,q)

! Compute saturation specific humidity qs [g/kg]
! given temperature T [K] and total (air+vapor) pressure p [mb]
! Use 8th oRder polynomial fit of Flatau et al (1992), Table 4

! i=1 => sat. mix. rat. over water (valid -85C < t < 70C)
! i=2 => sat. mix. rat. over ice (valid -90C < t < 0C)

  implicit none
  integer,intent(in)                        :: km,jm,im,i
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: Rd,Rv
  real(8), dimension(km,jm,im), intent(in)  :: T,p
  real(8), dimension(km,jm,im), intent(out) :: q

! Local
  real(8) :: eps
  real(8), dimension(km,jm,im) :: e

  eps=Rd/Rv
  call esflatau(km,jm,im,T,i,e)
  q = eps*e/(p+e*(eps-1.)) * 1.e3
!  q = eps*e/p * 1.e3

end subroutine qsflatau
!------------------------------------------------------------------------
subroutine ws(km,jm,im,Rd,Rv,T,p,w)

! Compute saturation water vapor mass mixing ratio  ws [g/kg]
! given temperature T [K] and total (air+vapor) pressure p [mb]
! use Bohren+Albrecht p. 186

  implicit none
  integer,intent(in)                        :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: Rd,Rv
  real(8), dimension(km,jm,im), intent(in)  :: T,p
  real(8), dimension(km,jm,im), intent(out) :: w

! Local
  real(8) :: eps
  real(8), dimension(km,jm,im) :: e

  eps=Rd/Rv
  call es(km,jm,im,T,e)
  w = eps*e/(p-e) * 1.e3

end subroutine ws
!------------------------------------------------------------------------
subroutine wsflatau(km,jm,im,Rd,Rv,T,p,i,w)

! Compute saturation water vapor mass mixing ratio ws [g/kg]
! given temperature T [K] and total (air+vapor) pressure p [mb]
! Use 8th oRder polynomial fit of Flatau et al (1992), Table 4

! i=1 => sat. mix. rat. over water (valid -85C < t < 70C)
! i=2 => sat. mix. rat. over ice (valid -90C < t < 0C)

  implicit none
  integer,intent(in)                        :: km,jm,im,i
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: Rd,Rv
  real(8), dimension(km,jm,im), intent(in)  :: T,p
  real(8), dimension(km,jm,im), intent(out) :: w

! Local
  real(8) :: eps
  real(8), dimension(km,jm,im) :: e

  eps=Rd/Rv
  call esflatau(km,jm,im,t,i,e)
  w = eps*e/(p-e) * 1.e3

end subroutine wsflatau
!------------------------------------------------------------------------
subroutine pdryadiab(km,jm,im,t,theta,q,p)

! compute pressure level pdryadiab [mb] at which temperature is t [K]
! on the dry (i.e. unsaturated) adiabat identified by
! potential temperature theta [K] and mixing ratio q [g/kg].
! Use Bolton eqn (7)

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: t,theta,q
  real(8), dimension(km,jm,im), intent(out) :: p

! Local
  real(8) :: oneoverk
  real(8), dimension(km,jm,im) :: r

  oneoverk=3.504 ! Cp/R_(dry air)
  r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]

  p = 1000.*(t/theta)**( oneoverk/(1.-0.28e-3*r) )

end subroutine pdryadiab
!------------------------------------------------------------------------
subroutine tdryadiab(km,jm,im,theta,p,q,T)

! Compute temperature T [K] at level p [mb]
! on the dry (i.e. unsaturated) adiabat identified by
! potential temperature theta [K] and mixing ratio q [g/kg].
! Use Bolton eqn (7)

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), dimension(km,jm,im), intent(in) :: theta,p,q
  real(8), dimension(km,jm,im), intent(out) :: T

! Local
  real(8) :: ak
  real(8), dimension(km,jm,im) :: r

  ak=0.2854 ! R_(dry air)/Cp
  r = q/(1.e3 - q) * 1.e3 ! water vap. mixing ratio [g/kg]

  T = theta*(1000./p)**( -ak*(1.-0.28e-3*r) )

end subroutine tdryadiab
!------------------------------------------------------------------------
subroutine tmoistadiab(km,jm,im,thetaes,p,t)

! Compute temperature [K] at level p [mb]
! on the moist (i.e. saturated) pseudo-adiabat identified
! by saturation equivalent potential temperature thetaes [K].
! Do it by varying t until
! delthetae := thetaes - thetae(t,p,qs(t,p)) = 0
! Use Bolton, eqn (43)

  implicit none
  integer,intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                      :: thetaes
  real(8), dimension(km,jm,im), intent(in) :: p
  real(8), dimension(km,jm,im), intent(out) :: t

! Local
  integer :: i,j,k
  real(8) :: tmin,tmax,f1,f2,delthetae,ridder
  real(8), dimension(10) :: params
  external delthetae,ridder
  logical success

do i=1,im
   do j=1,jm
      do k=1,km
         params = 0.
         params(1) = thetaes
         params(2) = p(k,j,i)
         ! bracket zero crossing to within 2K
         tmin = 50.
         tmax = 51.
         f1 = delthetae(params,tmin)
         f2 = delthetae(params,tmax)
1        continue
         if(tmax.gt.500.) goto 2
         if(f1*f2.lt.0.) goto 3
         tmax = tmax+1.
         f2 = delthetae(params,tmax)
         goto 1
2        stop 'tmoistadiab(): cannot bracket root'
3        continue
         tmin = tmax-2.
         !  refine estimate using Ridder's method
         t(k,j,i) = ridder(success,delthetae, params, tmin, tmax, 0.0001)
         if (.not.success) stop 'tmoistadiab(): root not bracketed'
      enddo
   enddo
enddo

end subroutine tmoistadiab
!-----------------------------------------------------------------------
real(8) function delthetae(params,t)

  implicit none
  real(8)                :: p,t,q,thetaes,the
  real(8), dimension(10) :: params
  external qs,thetae

  thetaes   = params(1)
  p         = params(2)
  call qs(1,1,1,t,p,q)
  call thetae_old(1,1,1,t,p,q,the)
  delthetae = thetaes - the

end function delthetae
!------------------------------------------------------------------------
real(8) function ridder(success,func,params,xmin,xmax,acc)

! Find zero crossing of func(x) in range xmin < x < xmax with accuracy acc
! Use Ridder's method (Numerical Recipes)

  implicit real*8 (a-h,o-z)
  real*8 params(10),xmin,xmax,acc
  logical success
  external func

  maxit=60  ! max number of iterations
  success=.true.

  fl=func(params,xmin)
  fh=func(params,xmax)

  if((fl.gt.0..and.fh.lt.0.).or.(fl.lt.0..and.fh.gt.0.))then
     xl=xmin
     xh=xmax
     ridder=-1.11e30
     do j=1,maxit
        xm=0.5*(xl+xh)
        fm=func(params,xm)
        s=sqrt(fm**2-fl*fh)
        if(s.eq.0.)return
        xnew=xm+(xm-xl)*(sign(1.,real(fl-fh))*fm/s)
        if (abs(xnew-ridder).le.acc) return
        ridder=xnew
        fnew=func(params,ridder)
        if (fnew.eq.0.) return
        if(sign(fm,fnew).ne.fm) then
           xl=xm
           fl=fm
           xh=ridder
           fh=fnew
        else if(sign(fl,fnew).ne.fl) then
           xh=ridder
           fh=fnew
        else if(sign(fh,fnew).ne.fh) then
           xl=ridder
           fl=fnew
        else
            stop 'never get here in ridder'
        endif
        if(abs(xh-xl).le.acc) return
     enddo
     stop 'ridder exceed maximum iterations maxit'
  else if (fl.eq.0.) then
     ridder=xmin
  else if (fh.eq.0.) then
     ridder=xmax
  else
     success=.false.
  endif

end function ridder

!------------------------------------------------------------------------
subroutine z(km,jm,im,R,g,p0,p,t,zz)

!
  implicit none
  integer, intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: R,g
  real(8), dimension(jm,im), intent(in)     :: p0
  real(8), dimension(km,jm,im), intent(in)  :: p,t
  real(8), dimension(km,jm,im), intent(out) :: zz

! Local
  integer :: k
  real(8), dimension(jm,im) :: dp,pm,Tm

! bottom level
  dp = (p0 - p(km,:,:))
  pm = (p0 + p(km,:,:))/2.
  zz(km,:,:) = R/g * T(km,:,:)/pm * dp

! build up from bottom
  do k=km-1,1,-1
     dp = p(k+1,:,:) - p(k,:,:)
     pm = (p(k+1,:,:) + p(k,:,:))/2.
     Tm = (T(k+1,:,:) + T(k,:,:))/2.
     zz(k,:,:) = zz(k+1,:,:) + R/g * Tm/pm * dp
  enddo

end subroutine z
!------------------------------------------------------------------------
subroutine pseudoadiab(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,p_in0,p00,T00,T_out)

  implicit none
  integer, parameter :: N=10000
  integer, intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  real(8), intent(in)                       :: Rd,Rv,lv0,cpv,cpd,cl
  real(8), dimension(jm,im), intent(in)     :: p00,T00
  real(8), dimension(km,jm,im), intent(in)  :: p_in0
  real(8), dimension(km,jm,im), intent(out) :: T_out

! Local
  integer :: k,j,i,kmin
  real(8) :: eps,dp,e,w,R,lv,cp,T,p,pmax,pmin,delta
  real(8), dimension(jm,im)     :: p0,T0
  real(8), dimension(km,jm,im)  :: p_in

  eps = Rd/Rv
  p0 = log(p00*100.)
  T0 = log(T00)
  p_in = log(p_in0*100.)

  do i=1,im
     do j=1,jm
        pmax = max( p0(j,i), p_in(km,j,i) )
        pmin = min( p0(j,i), p_in(1,j,i) )
        dp = (pmax-pmin)/(N-1.)

        !--- up to top
        T = T0(j,i)
        p = p0(j,i)
        ! check if we're matching any of the required levels
        kmin = minloc(abs(p-p_in(:,j,i)),1)
        delta = abs(p-p_in(kmin,j,i))
        if (delta.le.dp) T_out(kmin,j,i) = T
        do k=1,N
           ! see if we've gone off the top
           p = p - dp
           if (p.lt.pmin) exit
           ! compute new T
           call es(1,1,1,exp(T),e)
           w = eps*e/(exp(p)/100.-e)
           cp = cpd+w*cl
           R = Rd*(1.+(1.-eps)/eps*w/(w+1.))
           lv = lv0 + (cpv-cl)*(exp(T)-273.15)
           T = T - Rd/cp* &
                (1.+lv*w/R/exp(T))/(1.+lv*lv*w/cp/Rv/exp(T)/exp(T)) * dp
           ! check if we're matching any of the required levels
           kmin = minloc(abs(p-p_in(:,j,i)),1)
           delta = abs(p-p_in(kmin,j,i))
           if (delta.le.dp) T_out(kmin,j,i) = T
        enddo

        ! down to bottom
        T = T0(j,i)
        p = p0(j,i)
        do k=1,N
           ! see if we've gone off the bottom
           p = p + dp
           if (p.gt.pmax) exit
           ! compute new value of T
           call es(1,1,1,exp(T),e)
           w = eps*e/(exp(p)/100.-e)
           cp = cpd+w*cl
           R = Rd*(1.+(1.-eps)/eps*w/(w+1.))
           lv = lv0 + (cpv-cl)*(exp(T)-273.15)
           T = T + Rd/cp* &
                (1.+lv*w/R/exp(T))/(1.+lv*lv*w/cp/Rv/exp(T)/exp(T)) * dp
           ! check if we're matching any of the required levels
           kmin = minloc(abs(p-p_in(:,j,i)),1)
           delta = abs(p-p_in(kmin,j,i))
           if (delta.le.dp) T_out(kmin,j,i) = T
        enddo

     enddo
  enddo

  T_out = exp(T_out)

end subroutine pseudoadiab
!------------------------------------------------------------------------
subroutine cape(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,virtual,ml_depth,p_in, T_in, q_in, c)

  implicit none
  integer, intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  integer, intent(in)                       :: virtual
  real(8), intent(in)                       :: ml_depth
  real(8), intent(in)                       :: Rd,Rv,lv0,cpv,cpd,cl
  real(8), dimension(km,jm,im), intent(in)  :: p_in, T_in, q_in
  real(8), dimension(jm,im), intent(out)    :: c

! Local
  integer :: k,j,i
  real(8) :: eps,delT
  real(8), dimension(km,jm,im)  :: q,qp, Tp, Tvp, Tvs
  real(8), dimension(jm,im)  :: T0,q0, pst,Tst
  real(8), dimension(0:km)  :: pint
  real(8), dimension(km)  :: dp, dlnp

  eps = Rd/Rv
  q = max(q_in,q_in*0.) ! take out any negs in q

! get saturation point temp and press Tst, pst for mean parcel in mixed layer
  call mean_parcel(km,jm,im,Rd,cpd,ml_depth,p_in,T_in,q,T0,q0,Tst,pst)

! get the temperature profile of the corresponding moist adiabat
  call pseudoadiab(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,p_in,pst,Tst,Tp)

! get the temperature profile of the corresponding dry adiabat
  do k=1,km
     Tp(k,:,:) = max( Tp(k,:,:), Tst*(p_in(k,:,:)/pst)**(Rd/cpd) )
  end do

! apply virtual temp correction if required
  if (virtual > 0) then
     Tvs = T_in*(1.+ (1.-eps)/eps*q*1.e-3)
     call qs(km,jm,im,Rd,Rv,Tp,p_in,qp)
     do k=1,km
        qp(k,:,:) = min( qp(k,:,:), q0)
     end do
     Tvp = Tp*(1.+ (1.-eps)/eps*qp*1.e-3)
  endif

! integrate to get CAPE
  c = 0.
  do i=1,im
     do j=1,jm
        pint(1:km-1) = (p_in(2:km,j,i)+p_in(1:km-1,j,i))/2.
        pint(0) = 0.
        pint(km) = p_in(km,j,i)+(p_in(km,j,i)-p_in(km-1,j,i))/2.
        dp = pint(1:km)-pint(0:km-1)
        dlnp = dp/p_in(:,j,i)
        do k=1,km
           if (virtual == 0) then
              delT = Tp(k,j,i)-T_in(k,j,i)
           else
              delT = Tvp(k,j,i)-Tvs(k,j,i)
           endif
           if ( delT > 0. ) then
              c(j,i) = c(j,i) + Rd*delT*dlnp(k)
           endif
        enddo
     enddo
  enddo

end subroutine cape
!------------------------------------------------------------------------
subroutine cine(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,virtual,ml_depth,p_in, T_in, q_in, c)

  implicit none
  integer, intent(in)                       :: km,jm,im
!f2py intent(hide) km,jm,im
  integer, intent(in)                       :: virtual
  real(8), intent(in)                       :: ml_depth
  real(8), intent(in)                       :: Rd,Rv,lv0,cpv,cpd,cl
  real(8), dimension(km,jm,im), intent(in)  :: p_in, T_in, q_in
  real(8), dimension(jm,im), intent(out)    :: c

! Local
  integer :: k,j,i
  real(8) :: eps,delT
  real(8), dimension(km,jm,im)  :: q,qp, Tp, Tvp, Tvs
  real(8), dimension(jm,im)  :: T0,q0, pst,Tst
  real(8), dimension(0:km)  :: pint
  real(8), dimension(km)  :: dp, dlnp

  eps = Rd/Rv
  q = max(q_in,q_in*0.) ! take out any negs in q

! get saturation point temp and press Tst, pst for mean parcel in mixed layer
  call mean_parcel(km,jm,im,Rd,cpd,ml_depth,p_in,T_in,q,T0,q0,Tst,pst)

! get the temperature profile of the corresponding moist adiabat
  call pseudoadiab(km,jm,im,Rd,Rv,lv0,cpd,cpv,cl,p_in,pst,Tst,Tp)

! get the temperature profile of the corresponding dry adiabat
  do k=1,km
     Tp(k,:,:) = max( Tp(k,:,:), Tst*(p_in(k,:,:)/pst)**(Rd/cpd) )
  end do

! apply virtual temp correction if required
  if (virtual > 0) then
     Tvs = T_in*(1.+ (1.-eps)/eps*q*1.e-3)
     call qs(km,jm,im,Rd,Rv,Tp,p_in,qp)
     do k=1,km
        qp(k,:,:) = min( qp(k,:,:), q0)
     end do
     Tvp = Tp*(1.+ (1.-eps)/eps*qp*1.e-3)
  endif

  ! integrate to get CINE
  c = 0.
  do i=1,im
     do j=1,jm
        pint(1:km-1) = (p_in(2:km,j,i)+p_in(1:km-1,j,i))/2.
        pint(0) = 0.
        pint(km) = p_in(km,j,i)+(p_in(km,j,i)-p_in(km-1,j,i))/2.
        dp = pint(1:km)-pint(0:km-1)
        dlnp = dp/p_in(:,j,i)
        inner_loop: do k=km,1,-1
           if (virtual == 0) then
              delT = Tp(k,j,i)-T_in(k,j,i)
           else
              delT = Tvp(k,j,i)-Tvs(k,j,i)
           endif
           if ( delT < 0. ) then
              c(j,i) = c(j,i) + Rd*delT*dlnp(k)
           else
              exit inner_loop
           endif
           enddo inner_loop
     enddo
  enddo

  c = -c

end subroutine cine
!------------------------------------------------------------------------
subroutine mean_parcel(km,jm,im,Rd,cpd,ml_depth,p,T,q,T0,q0,Tst,pst)

! compute mean thermodyn properties over layer of depth ml_depth above ground

  implicit none
  integer, intent(in)                       :: km,jm,im
  real(8), intent(in)                       :: ml_depth
  real(8), intent(in)                       :: Rd,cpd
  real(8), dimension(km,jm,im), intent(in)  :: p, T, q
  real(8), dimension(jm,im), intent(out)    :: Tst,pst,T0,q0

! Local
  integer :: k,j,i
  real(8) :: dp
  real(8), dimension(5,jm,im)  :: p5,T5,q5,theta5
  real(8), dimension(jm,im)  :: p0

! if mixed layer depth is 0, use surface values
  if (ml_depth == 0.) then
     p0 = p(km,:,:)
     T0 = T(km,:,:)
     q0 = q(km,:,:)

  else
! compute new pressure grid, equispaced over 5 layers from ground to top
     dp = ml_depth/5.
     do k=1,5
        p5(k,:,:) = p(km,:,:) - dp*(5-k)
     end do

! interpolate T, q onto new pressure grid
     do i=1,im
        do j=1,jm
           call interpol(p(:,j,i),T(:,j,i),km,p5(:,j,i),T5(:,j,i),5)
           call interpol(p(:,j,i),q(:,j,i),km,p5(:,j,i),q5(:,j,i),5)
        end do
     end do

! average conserved quantities over mixed layer
     p0 = p(km,:,:)
     do k=1,5
        theta5(k,:,:) = T5(k,:,:)*( p5(k,:,:)/p0 )**(Rd/cpd)
     end do
     do i=1,im
        do j=1,jm
           T0(j,i) = sum(theta5(:,j,i))/5.
           q0(j,i) = sum(q5(:,j,i))/5.
        end do
     end do

  endif

! compute saturation point pressure and temp
  call tstar(1,jm,im,T0,p0,q0,Tst)
  pst = p0*(Tst/T0)**(cpd/Rd)

end subroutine mean_parcel
!--------------------------------------------------------------------------
subroutine interpol(xin,yin,nin,xout,yout,nout)

  real xin(nin),yin(nin),xout(nout),yout(nout),spl(2000)

  yp1=1.e30
  ypn=1.e30
  call spline(xin,yin,nin,yp1,ypn,spl)

  do n=1,nout
     call splint(xin,yin,spl,nin,xout(n),yout(n))
  enddo

end subroutine interpol
!------------------------------------------------------------------------
SUBROUTINE spline(x,y,n,yp1,ypn,y2)
  INTEGER n,NMAX
  REAL yp1,ypn,x(n),y(n),y2(n)
  PARAMETER (NMAX=500)
  INTEGER i,k
  REAL p,qn,sig,un,u(NMAX)
  if (yp1.gt..99e30) then
     y2(1)=0.
     u(1)=0.
  else
     y2(1)=-0.5
     u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
  endif
  do  i=2,n-1
     sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
     p=sig*y2(i-1)+2.
     y2(i)=(sig-1.)/p
     u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))&
          /(x(i+1)-x(i-1))-sig*u(i-1))/p
  enddo
     if (ypn.gt..99e30) then
        qn=0.
        un=0.
     else
        qn=0.5
        un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
     endif
     y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
     do  k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
     enddo
end SUBROUTINE spline
!  (C) Copr. 1986-92 Numerical Recipes Software
!---------------------------------------------------------------------------
SUBROUTINE splint(xa,ya,y2a,n,x,y)
  INTEGER n
  REAL x,y,xa(n),y2a(n),ya(n)
  INTEGER k,khi,klo
  REAL a,b,h
  klo=1
  khi=n
1 if (khi-klo.gt.1) then
     k=(khi+klo)/2
     if(xa(k).gt.x)then
        khi=k
     else
        klo=k
     endif
     goto 1
  endif
  h=xa(khi)-xa(klo)
  if (h.eq.0.) stop 'bad xa input in splint'
  a=(xa(khi)-x)/h
  b=(x-xa(klo))/h
  y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

END SUBROUTINE splint
!  (C) Copr. 1986-92 Numerical Recipes Software


!*******************************************************************************
!> author: Jacob Williams
!
!  Test for the [[slsqp_module]].

    program slsqp_test_2

    use slsqp_module
    use slsqp_kinds

    implicit none

    integer,parameter               :: n = 3                    !! number of optimization variables
    integer,parameter               :: m = 2                    !! total number of constraints
    integer,parameter               :: meq = 1                  !! number of equality constraints
    integer,parameter               :: max_iter = 100           !! maximum number of allowed iterations
    real(wp),dimension(n),parameter :: xl = [-10.0_wp, -10.0_wp, -10.0_wp]  !! lower bounds
    real(wp),dimension(n),parameter :: xu = [ 10.0_wp,  10.0_wp,  10.0_wp]  !! upper bounds
    real(wp),parameter              :: acc = 1.0e-7_wp          !! tolerance
    integer,parameter               :: linesearch_mode = 1      !! use inexact linesearch.

    type(slsqp_solver)    :: solver      !! instantiate an slsqp solver
    real(wp),dimension(n) :: x           !! optimization variable vector
    integer               :: istat       !! for solver status check
    logical               :: status_ok   !! for initialization status check
    integer               :: iterations  !! number of iterations by the solver

    x = [1.0_wp, 2.0_wp, 3.0_wp] ! initial guess

    call solver%initialize(n,m,meq,max_iter,acc,test_func,test_grad,&
                            xl,xu,linesearch_mode=linesearch_mode,status_ok=status_ok,&
                            report=report_iteration,&
                            alphamin=0.1_wp, alphamax=0.5_wp) !to limit search steps

    if (status_ok) then
        call solver%optimize(x,istat,iterations)
        write(*,*) ''
        write(*,*) 'solution   :', x
        write(*,*) 'istat      :', istat
        write(*,*) 'iterations :', iterations
        write(*,*) ''
    else
        error stop 'error calling slsqp.'
    end if

    ! Solution is: x = [1,1,1], f = 3

    contains

    subroutine test_func(me,x,f,c)

        !!  Compute the objective function and constraints
        !!
        !!  Minimize:
        !!
        !!   * \( f = x_1^2 + x_2^2 + x_3 \)
        !!
        !!  Subject to:
        !!
        !!   * \( c_1 = x_1 x_2 - x_3 = 0 \)
        !!   * \( c_2 = x_3 - 1 \ge 0 \)

        implicit none

        class(slsqp_solver),intent(inout) :: me
        real(wp),dimension(:),intent(in)  :: x   !! optimization variable vector
        real(wp),intent(out)              :: f   !! value of the objective function
        real(wp),dimension(:),intent(out) :: c   !! the constraint vector `dimension(m)`,
                                                 !! equality constraints (if any) first.

        f = x(1)**2 + x(2)**2 + x(3)  !objective function

        c(1) = x(1)*x(2) - x(3)       !equality constraint (==0)
        c(2) = x(3) - 1.0_wp          !inequality constraint (>=0)

    end subroutine test_func

    subroutine test_grad(me,x,g,a)

        !! compute the gradients.

        implicit none

        class(slsqp_solver),intent(inout)   :: me
        real(wp),dimension(:),intent(in)    :: x    !! optimization variable vector
        real(wp),dimension(:),intent(out)   :: g    !! objective function partials w.r.t x `dimension(n)`
        real(wp),dimension(:,:),intent(out) :: a    !! gradient matrix of constraints w.r.t. x `dimension(m,n)`

        g(1) = 2.0_wp*x(1)
        g(2) = 2.0_wp*x(2)
        g(3) = 1.0_wp

        a(1,1) = x(2)
        a(1,2) = x(1)
        a(1,3) = -1.0_wp

        a(2,1) = 0.0_wp
        a(2,2) = 0.0_wp
        a(2,3) = 1.0_wp

    end subroutine test_grad

    subroutine report_iteration(me,iter,x,f,c)

        !! report an iteration (print to the console).

        use, intrinsic :: iso_fortran_env, only: output_unit

        implicit none

        class(slsqp_solver),intent(inout) :: me
        integer,intent(in)                :: iter
        real(wp),dimension(:),intent(in)  :: x
        real(wp),intent(in)               :: f
        real(wp),dimension(:),intent(in)  :: c

        !write a header:
        if (iter==0) then
            write(output_unit,'(*(A20,1X))') 'iteration', &
                                             'x(1)', 'x(2)', 'x(3)', &
                                             'f(1)', 'c(1)', 'c(2)'
        end if

        !write the iteration data:
        write(output_unit,'(I20,1X,(*(F20.16,1X)))') iter,x,f,c

    end subroutine report_iteration

    end program slsqp_test_2
!*******************************************************************************


      SUBROUTINE polcoe(x,y,n,cof)
      INTEGER n,NMAX
      REAL cof(n),x(n),y(n)
      PARAMETER (NMAX=15)
      INTEGER i,j,k
      REAL b,ff,phi,s(NMAX)
      do 11 i=1,n
        s(i)=0.
        cof(i)=0.
11    continue
      s(n)=-x(1)
      do 13 i=2,n
        do 12 j=n+1-i,n-1
          s(j)=s(j)-x(i)*s(j+1)
12      continue
        s(n)=s(n)-x(i)
13    continue
      do 16 j=1,n
        phi=n
        do 14 k=n-1,1,-1
          phi=k*s(k+1)+x(j)*phi
14      continue
        ff=y(j)/phi
        b=1.
        do 15 k=n,1,-1
          cof(k)=cof(k)+b*ff
          b=s(k)+x(j)*b
15      continue
16    continue
      return
      END

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


c
c
c
c     =================================================
      double precision function fdisc(blockno,xc,yc)
c     =================================================
      implicit none

      double precision xc,yc
      integer blockno

      double precision x0, y0, alf, beta, r0
      integer idisc
      common/cdisc/ x0,y0,alf,beta,r0,idisc

      double precision x, y, f1,f2

c
c     # for computing cell averages for initial data that has a
c     # discontinuity along some curve.  fdisc should be negative to the
c     # left of the curve and positive to the right
c     # idisc specifies the nature of the discontinuity for two
c     # particular cases (a straight line and circle) but this routine
c     # can be modified for any other curve.
c

      x = xc
      y = yc

      go to (10,20,30,40) idisc
c
   10 continue
c     # straight line through (x0,y0) with normal (alf,beta) pointing
c     # into right state
c
      fdisc = (x-x0)*alf + (y-y0)*beta
      return
c
   20 continue
c     # circle of radius r0:
      fdisc = (x-x0)**2 + (y-y0)**2 - r0**2
      return

   30 continue
      f1 = (x-x0)**2 + (y-y0+0.5d0)**2 - r0**2
      f2 = (x-x0)**2 + (y-y0-0.5d0)**2 - r0**2
      if (f1 .lt. 0) then
         fdisc = f1
      elseif (f2 .lt. 0) then
         fdisc = f2
      else
         fdisc = min(f1,f2)
      endif
      return

   40 continue
      f1 = (x-x0)**2 + (y-y0+0.5d0)**2 - (r0/sqrt(2.d0))**2
      f2 = (x-x0)**2 + (y-y0-0.5d0)**2 - (r0/sqrt(2.d0))**2
      if (f1 .lt. 0) then
         fdisc = f1
      elseif (f2 .lt. 0) then
         fdisc = f2
      else
         fdisc = min(f1,f2)
      endif

      return
      end


C ************************************************************
C Source for the library implementing a bias function that
C populates the large pt tale of the leading jet.
C
C The two options of this subroutine, that can be set in
C the run card are:
C    > (double precision) ptj_bias_target_ptj : target ptj value
C    > (double precision) ptj_bias_enhancement_power : exponent
C
C Schematically, the functional form of the enhancement is
C    bias_wgt = [ptj(evt)/mean_ptj]^enhancement_power
C ************************************************************
C
C The following lines are read by MG5aMC to set what are the
C relevant parameters for this bias module.
C
C  parameters = {'ptj_bias_target_ptj': 1000.0,
C               'ptj_bias_enhancement_power': 4.0}
C

      subroutine bias_wgt(p, original_weight, bias_weight)
          implicit none
C
C Parameters
C
          include '../../maxparticles.inc'
          include '../../nexternal.inc'

C
C Arguments
C
          double precision p(0:3,nexternal)
          double precision original_weight, bias_weight
C
C local variables
C
          integer i
          double precision ptj(nexternal)
          double precision max_ptj
c
c local variables defined in the run_card
c
          double precision ptj_bias_target_ptj
          double precision ptj_bias_enhancement_power
C
C Global variables
C
C
C Mandatory common block to be defined in bias modules
C
          double precision stored_bias_weight
          data stored_bias_weight/1.0d0/
          logical impact_xsec, requires_full_event_info
C         We only want to bias distributions, but not impact the xsec.
          data impact_xsec/.False./
C         Of course this module does not require the full event
C         information (color, resonances, helicities, etc..)
          data requires_full_event_info/.False./
          common/bias/stored_bias_weight,impact_xsec,
     &                requires_full_event_info
C
C Accessingt the details of the event
C
          logical is_a_j(nexternal),is_a_l(nexternal),
     &            is_a_b(nexternal),is_a_a(nexternal),
     &            is_a_onium(nexternal),is_a_nu(nexternal),
     &            is_heavy(nexternal),do_cuts(nexternal)
          common/to_specisa/is_a_j,is_a_a,is_a_l,is_a_b,is_a_nu,
     &                      is_heavy,is_a_onium,do_cuts

C
C    Setup the value of the parameters from the run_card
C
      include '../bias.inc'

C --------------------
C BEGIN IMPLEMENTATION
C --------------------

          do i=1,nexternal
            ptj(i)=-1.0d0
            if (is_a_j(i)) then
              ptj(i)=sqrt(p(1,i)**2+p(2,i)**2)
            endif
          enddo

          max_ptj=-1.0d0
          do i=1,nexternal
            max_ptj = max(max_ptj,ptj(i))
          enddo
          if (max_ptj.lt.0.0d0) then
            bias_weight = 1.0d0
            return
          endif

          bias_weight = (max_ptj/ptj_bias_target_ptj)
     &                                      **ptj_bias_enhancement_power

          return

      end subroutine bias_wgt


MODULE PRECOMPUTATION

USE MPI
USE BASIS
USE MESH, ONLY: NEL_TOTAL
USE PARAM, ONLY: N, M

IMPLICIT NONE

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: GL_POINT_ALL  ! GUASS LEGENDRE POINTS
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: GL_W_ALL  ! GUASS LEGENDRE WEIGHTS
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: GLL_POINT_ALL ! GUASS LEGENDRE LOBATTO POINT
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: GLL_W_ALL  ! GUASS LEGENDRE LOBATTO WEIGHTS

CONTAINS

SUBROUTINE

    IMPLICIT NONE

    INTEGER :: I

    ALLOCATE(GL_POINT_ALL(M+1))

    !-------------------------------------------------------------------
    DO I=1, NEL_TOTAL
        !Gauss Legendre quadrature nodes and weights
        CALL GL(N)

        CALL GLL(N)
    ENDDO
    !-------------------------------------------------------------------

END MODULE PRECOMPUTATION


program i
  integer::a=3*4 + 5/6
end program i


    Program dstedc_example

!     DSTEDC Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dsbtrd, dstedc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Integer :: i, ifail, info, j, kd, ldab, ldz, lgn, liwork, lwork, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ab(:, :), d(:), e(:), work(:), z(:, :)
      Real (Kind=dp) :: rdum(1)
      Integer :: idum(1)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: ceiling, log, max, min, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'DSTEDC Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kd
      ldab = kd + 1
      ldz = n
      lgn = ceiling(log(real(n,kind=dp))/log(2.0E0_dp))
      Allocate (ab(ldab,n), d(n), e(n-1), z(ldz,n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      liwork = -1
      Call dstedc('V', n, d, e, z, ldz, rdum, lwork, idum, liwork, info)

!     Make sure that there is enough workspace.
      lwork = max(1+3*n+2*n*lgn+4*n*n, nint(rdum(1)))
      liwork = max(6+6*n+5*n*lgn, idum(1))
      Allocate (work(lwork), iwork(liwork))

!     Read the upper or lower triangular part of the band matrix A
!     from data file

      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(kd+1+i-j,j), j=i, min(n,i+kd))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-kd), i)
        End Do
      End If

!     Reduce A to tridiagonal form T = (Z**T)*A*Z, and form Z
      Call dsbtrd('V', uplo, n, kd, ab, ldab, d, e, z, ldz, work, info)

!     Calculate all the eigenvalues and eigenvectors of A,
!     from T and Z
      Call dstedc('V', n, d, e, z, ldz, work, lwork, iwork, liwork, info)

      If (info==0) Then

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) d(1:n)

        Write (nout, *)
        Flush (nout)

!       Standardize the eigenvectors so that first elements are non-negative.
        Do i = 1, n
          If (z(1,i)<0.0_dp) Then
            z(1:n, i) = -z(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!               =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

      Else
        Write (nout, 110) 'Failure in DSTEDC. INFO = ', info
      End If

100   Format ((3X,8F8.4))
110   Format (1X, A, I10)
    End Program


     program demo_poly
     use M_calcomp, only : plots, poly, plot
     implicit none
     real              :: xstart, ystart
     real              :: side_length
     real              :: number_of_sides
     real              :: angle
     integer           :: i
        call plots(0.0,10.0,0.0,10.0)
        call plot(0.001,0.001,-3) ! move origin a bit so lines on edge OK
        call poly(0.0,0.0,10.0,4.0,0.0) ! 10 inch square
        side_length=2.35
        xstart=(10.0-side_length)/2.0
        ystart=0.5
        angle=0.0
        do i = 3,12
           number_of_sides=real(i)
           call poly(xstart,ystart,side_length,number_of_sides,angle)
        enddo
        call plot(0.0,0.0,999)
     end program demo_poly


C******************** START FILE FLINT_Z.FOR ; GROUP SIGS2 ********************
C==============================================================================
C
C  FLINT_Z
C   INTERPOLATE ON A 2D ARRAY
C
       SUBROUTINE FLINT_Z(X,Y,F,N,MTX,XMIN,XMAX,XLR,NX,YMIN,YMAX,YLR,
     > NY,IWARN)
C
C============
C idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER n,nx,ny,it,iwarn,ix,iy,ixp1,iyp1
C============
C idecl:  explicitize implicit REAL declarations:
      REAL*8 f,mtx,x,y,xmin,xmax,xlr,ymin,ymax,ylr,zx,zy,zzx,zlogx,
     > zzy,zlogy,zf00,zf01,zf10,zf11
C============
      DIMENSION MTX(NX,NY)
      DIMENSION X(N)
      DIMENSION Y(N)
      DIMENSION F(N)
c
c Interpolates the table MTX(NX,NY) to find the value at (x,y).
c If XLR>0, then the X grid is equally spaced on a logarithmic scale:
c
c   X(i) = XMIN * (exp(XLR)) ** ( (i-1)/(NX-1) )
c
c   So X(i) ranges from XMIN to XMIN*exp(XLR), and XLR=log(xmax/xmin).
c
c For XLR<=0, the X grid is equally spaced on a linear scale from
c XMIN to XMAX.
c
c For YLR>0, Y is logarithmically spaced from YMIN to YMIN*exp(YLR)
c and for YLR<=0, Y is linearly spaced from YMIN to YMAX.
C
C Modified 7/26/00 (PCR) - vectorized.
C
      integer idebug
      common/flint_debug/ idebug
C
C
      iwarn=0
C
      do 70 it=1,n
C
         ZX=X(it)
         ZY=Y(it)
C
         if(zx .lt. xmin .or. zx/xmin .le. 0.0) then
            zzx=0.0D0
         else

            IF(XLR.GT.0.0D0) THEN
               ZLOGX=log(ZX/XMIN)
               ZZX=1.0D0+ZLOGX/XLR * (NX-1)
            ELSE
               ZZX=1.0D0+(ZX-XMIN)/(XMAX-XMIN) * (NX-1)
            ENDIF

         endif
C
         if(zy .lt. ymin .or. zy/ymin .le. 0.0) then
            zzy=0.0D0
         else

            IF(YLR.GT.0.0D0) THEN
               ZLOGY=log(ZY/YMIN)
               ZZY=1.0D0+ZLOGY/YLR * (NY-1)
            ELSE
               ZZY=1.0D0+(ZY-YMIN)/(YMAX-YMIN) * (NY-1)
            ENDIF

         endif
C
         IX=ZZX
         IY=ZZY
C  CHECK FOR POINT OUT OF BOUNDS OF ARRAY
         IF(IX.GE.1) GO TO 10
C
         IF(ZX.LT.(XMIN - 5.0D-7)) THEN
            IWARN=1
         ENDIF
         IX=1
         ZZX=1.0D0
C
 10      CONTINUE
         IF(IY.GE.1) GO TO 20
C
         IF(ZY.LT.(YMIN - 5.0D-7)) THEN
            IWARN=1
         ENDIF
         IY=1
         ZZY=1.0D0
C
 20      CONTINUE
         IF(IX.LT.NX) GO TO 30
C
         IF(ZX.GT.(XMAX + 5.0D-7)) THEN
            IWARN=1
         ENDIF
         IX=NX-1
         ZZX=NX
C
 30      CONTINUE
         IF(IY.LT.NY) GO TO 40
C
         IF(ZY.GT.(YMAX + 5.0D-7)) THEN
            IWARN=1
         ENDIF
         IY=NY-1
         ZZY=NY
C
C---------------------------
C  OK
C
 40      CONTINUE
         IXP1=IX+1
         IYP1=IY+1
         ZZX=ZZX-IX
         ZZY=ZZY-IY
         ZF00=(1.D0-ZZX)*(1.D0-ZZY)
         ZF01=(1.D0-ZZX)*ZZY
         ZF10=ZZX*(1.D0-ZZY)
         ZF11=ZZX*ZZY
C
C  INTERPOLATE
C
         F(it)=ZF00*MTX(IX,IY)+ZF01*MTX(IX,IYP1)+
     >      ZF10*MTX(IXP1,IY)+ZF11*MTX(IXP1,IYP1)
c
         if(idebug.eq.99) then
            write(6,*) 'flin1_z:  zx,zy=',zx,zy,' ix,iy=',ix,iy
            write(6,*) '  mtx(ix,iy:iyp1) = ',mtx(ix,iy:iyp1)
            write(6,*) '  mtx(ixp1,iy:iyp1) = ',mtx(ixp1,iy:iyp1)
            write(6,*) '  it,F(it)=',it,F(it)
         endif
C
 70   continue
C
      idebug=0  ! clear debug flag
C
      END
C
C******************** END FILE FLINT.FOR ; GROUP SIGS2 ************************
! 26Jul2000 fgtok -s r8_precision.sub "r8con.csh conversion"


submodule (m_Sort) sm_introsort
  !! introsort and argIntrosort routines

  use m_swap, only: swap
  use m_partition, only: partition, argPartition
  use m_medianOf3, only: medianOf3, argMedianOf3

  implicit none

  integer(i32), parameter :: minimumLengthForInsertion = 16

  contains
  !====================================================================!
  module procedure introsort_r1D
    !! Interfaced with introsort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth = 2*idnint(log(dble(right)))
  call r_introsort_r1D(this,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_introsort_r1D(this,left,right,maxDepth)
  !====================================================================!
  real(r32) :: this(:)
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  integer(i32) :: imid,iPivot
  integer(i32) :: N
  N = right - left + 1
  if (N < minimumLengthForInsertion) then
    call InsertionSort(this,left,right)
    return
  end if
  if (maxDepth == 0) then
    call heapsort_r1D(this(left:right))
    return
  end if
  imid = left + N/2
  call medianOf3(this, left, imid, right)
  call swap(this(left), this(imid))
  call partition(this,left,right,iPivot)
  call r_introsort_r1D(this,left,iPivot-1,maxDepth-1)
  call r_introsort_r1D(this,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure introsort_d1D
    !! Interfaced with introsort()
  !====================================================================!
  integer(i32) :: left,right,maxDepth
  left=1
  right=size(this)
  maxDepth = 2*idnint(log(dble(right)))
  call r_introsort_d1D(this,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_introsort_d1D(this,left,right,maxDepth)
  !====================================================================!
  real(r64) :: this(:)
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  integer(i32) :: imid,iPivot
  integer(i32) :: N
  N = right - left + 1
  if (N < minimumLengthForInsertion) then
    call InsertionSort(this,left,right)
    return
  end if
  if (maxDepth == 0) then
    call heapsort_d1D(this(left:right))
    return
  end if
  imid = left + N/2
  call medianOf3(this, left, imid, right)
  call swap(this(left), this(imid))
  call partition(this,left,right,iPivot)
  call r_introsort_d1D(this,left,iPivot-1, maxDepth-1)
  call r_introsort_d1D(this,iPivot+1,right, maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure introsort_i1D
    !! Interfaced with introsort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth=2*idnint(log(dble(right)))
  call r_introsort_i1D(this,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_introsort_i1D(this,left,right,maxDepth)
  !====================================================================!
    integer(i32) :: this(:)
    integer(i32) :: left,right
    integer(i32) :: maxDepth
    integer(i32) :: imid,iPivot
    integer(i32) :: N
    N=right-left + 1
    if (N < minimumLengthForInsertion) then
      call InsertionSort(this,left,right)
      return
    end if
    if (maxDepth == 0) then
      call heapsort_i1D(this(left:right))
      return
    end if
    iMid = (left+right)/2
    call medianOf3(this, left, imid, right)
    call swap(this(left), this(imid))
    call partition(this,left,right,iPivot)
    call r_introsort_i1D(this,left,iPivot-1,maxDepth-1)
    call r_introsort_i1D(this,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure introsort_id1D
    !! Interfaced with introsort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth=2*idnint(log(dble(right)))
  call r_introsort_id1D(this,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_introsort_id1D(this,left,right,maxDepth)
  !====================================================================!
    integer(i64) :: this(:)
    integer(i32) :: left,right
    integer(i32) :: maxDepth
    integer(i32) :: imid,iPivot
    integer(i32) :: N
    N=right-left + 1
    if (N < minimumLengthForInsertion) then
      call InsertionSort(this,left,right)
      return
    end if
    if (maxDepth == 0) then
      call heapsort_id1D(this(left:right))
      return
    end if
    imid = left + N/2
    call medianOf3(this, left, imid, right)
    call swap(this(left), this(imid))
    call partition(this,left,right,iPivot)
    call r_introsort_id1D(this,left,iPivot-1,maxDepth-1)
    call r_introsort_id1D(this,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argIntrosort_r1D
    !! Interfaced with argIntrosort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth=2*idnint(log(dble(right)))
  call r_argIntrosort_r1D(this,i,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_argIntrosort_r1D(this,idx,left,right,maxDepth)
  !====================================================================!
  real(r32) :: this(:)
  integer(i32) :: idx(:)
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  integer(i32) :: imid,iPivot
  integer(i32) :: N
  N=right-left + 1
  if (N < minimumLengthForInsertion) then
    call argInsertionSort(this,idx,left,right)
    return
  end if
  if (maxDepth == 0) then
    call argHeapsort_r1D(this, idx(left:right))
    return
  end if
  imid = left + N/2
  call argMedianOf3(this, idx, left, imid, right)
  call swap(idx(left), idx(imid))
  call argPartition(this,idx,left,right,iPivot)
  call r_argIntrosort_r1D(this,idx,left,iPivot-1,maxDepth-1)
  call r_argIntrosort_r1D(this,idx,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argIntrosort_d1D
    !! Interfaced with argIntrosort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth=2*idnint(log(dble(right)))
  call r_argIntrosort_d1D(this,i,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_argIntrosort_d1D(this,idx,left,right,maxDepth)
  !====================================================================!
  real(r64) :: this(:)
  integer(i32) :: idx(:)
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  integer(i32) :: imid,iPivot
  integer(i32) :: N
  N = right - left + 1
  if (N < minimumLengthForInsertion) then
    call argInsertionSort(this,idx,left,right)
    return
  end if
  if (maxDepth == 0) then
    call argHeapsort_d1D(this, idx(left:right))
    return
  end if
  imid = left + N/2
  call argMedianOf3(this, idx, left, imid, right)
  call swap(idx(left), idx(imid))
  call argPartition(this,idx,left,right,iPivot)
  call r_argIntrosort_d1D(this,idx,left,iPivot-1,maxDepth-1)
  call r_argIntrosort_d1D(this,idx,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argIntrosort_i1D
    !! Interfaced with argIntrosort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth=2*idnint(log(dble(right)))
  call r_argIntrosort_i1D(this,i,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_argIntrosort_i1D(this,idx,left,right,maxDepth)
  !====================================================================!
  integer(i32) :: this(:)
  integer(i32) :: idx(:)
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  integer(i32) :: imid,iPivot
  integer(i32) :: N
  N=right - left + 1
  if (N < minimumLengthForInsertion) then
    call argInsertionSort(this,idx,left,right)
    return
  end if
  if (maxDepth == 0) then
    call argHeapsort_i1D(this, idx(left:right))
    return
  end if
  imid = left + N/2
  call argMedianOf3(this, idx, left, imid, right)
  !call swap(idx(left), idx(imid))
  call argPartition(this,idx,left,right,iPivot)
  call r_argIntrosort_i1D(this,idx,left,iPivot-1,maxDepth-1)
  call r_argIntrosort_i1D(this,idx,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argIntrosort_id1D
    !! Interfaced with argIntrosort()
  !====================================================================!
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  left=1
  right=size(this)
  maxDepth=2*idnint(log(dble(right)))
  call r_argIntrosort_id1D(this,i,left,right,maxDepth)
  end procedure
  !====================================================================!
  !====================================================================!
  recursive subroutine r_argIntrosort_id1D(this,idx,left,right,maxDepth)
  !====================================================================!
  integer(i64) :: this(:)
  integer(i32) :: idx(:)
  integer(i32) :: left,right
  integer(i32) :: maxDepth
  integer(i32) :: imid,iPivot
  integer(i32) :: N
  N = right - left + 1
  if (N < minimumLengthForInsertion) then
    call argInsertionSort(this,idx,left,right)
    return
  end if
  if (maxDepth == 0) then
    call argHeapsort_id1D(this, idx(left:right))
    return
  end if
  imid = left + N/2
  call argMedianOf3(this, idx, left, imid, right)
  call swap(idx(left), idx(imid))
  call argPartition(this,idx,left,right,iPivot)
  call r_argIntrosort_id1D(this,idx,left,iPivot-1,maxDepth-1)
  call r_argIntrosort_id1D(this,idx,iPivot+1,right,maxDepth-1)
  end subroutine
  !====================================================================!
end submodule


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
c
      program testfft
      implicit none
c
c --- local variables
c
      integer i,ier,iflag,j,k1,mx,ms,nj
      parameter (mx=10 000)
      real(8):: xj(mx), sk(mx)
      real(8):: err,eps,pi
      parameter (pi=3.141592653589793d0)
      complex(8) :: cj(mx),cj0(mx),cj1(mx)
      complex(8) :: fk0(mx),fk1(mx)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
      ms = 90
      nj = 128
      do k1 = -nj/2, (nj-1)/2
         j = k1+nj/2+1
         xj(j) = pi * dcos(-pi*j/nj)
         cj(j) = dcmplx( dsin(pi*j/nj), dcos(pi*j/nj))
      enddo
c
c     --------------------------------------------------
c     start tests
c     --------------------------------------------------
c
      iflag = 1
      print*,' Start 1D testing: ', ' nj =',nj, ' ms =',ms
      do i = 1,3
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
       print*,' '
       print*,' Requested precision eps =',eps
       print*,' '
c
c     -----------------------
c     call 1D Type1 method
c     -----------------------
c
         call dirft1d1(nj,xj,cj,iflag, ms,fk0)
         call nufft1d1f90(nj,xj,cj,iflag,eps, ms,fk1,ier)
         call errcomp(fk0,fk1,ms,err)
         print *,' ier = ',ier
         print *,' type 1 error = ',err
c
c     -----------------------
c     call 1D Type2 method
c     -----------------------
c
         call dirft1d2(nj,xj,cj0,iflag, ms,fk0,ier)
         call nufft1d2f90(nj,xj,cj1,iflag, eps, ms,fk0,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 2 error = ',err
c
c     -----------------------
c     call 1D Type3 method
c     -----------------------
         do k1 = 1, ms
            sk(k1) = 48d0*dcos(k1*pi/ms)
         enddo
         call dirft1d3(nj,xj,cj,iflag, ms,sk,fk0)
         call nufft1d3f90(nj,xj,cj,iflag,eps, ms,sk,fk1,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex(8) :: fk0(n), fk1(n)
      real(8) :: salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


program newton
	real*8 a,b,t,dt
	a=0.0;b=3.0
	t=1.0;e=0.01
	dt=1.0

	open(13,file="Newton")
	write(13,"(A12,A12)")"t-t0","t"
	do while(dt>=e)
		dt=(((3*t**2-2)/(6*t))**2)**0.5
		t=t-(3*t**2-2)/(6*t)
		write(13,"(f12.6,f12.6)")dt,t
	end do
	write(13,*)t,t**3-2*t+1,e
end program newton


      SUBROUTINE RENPAR6(A,N,K,M)
      INTEGER N,K,M,A(N)
      DIMENSION WORK(100,100)
      K = M * M
      DO I = 1,N
         DO J = 1,N
            WORK(J,K) = J + K
         ENDDO

         CALL INC1(K)

         DO J = 1,N
            WORK(J,K) = J * J - K * K
            A(I) = A(I) + WORK(J,K) + WORK(J,K-1)
         ENDDO
      ENDDO
      END

      SUBROUTINE INC1(I)
      I = I + 1
      END

      SUBROUTINE RENPAR6_2(A,N,K,M)
      INTEGER N,K,M,A(N)
      DIMENSION WORK(100,100)
      K0 = M * M
      DO I = 1,N
         K = K0+I-1
         DO J = 1,N
            WORK(J,K) = J + K
         ENDDO

         CALL INC1(K)

         DO J = 1,N
            WORK(J,K) = J * J - K * K
            A(I) = A(I) + WORK(J,K) + WORK(J,K-1)
         ENDDO
      ENDDO
      END


      program power04

C     Check constant power

      i = 3**2
      n = 2
      i = 4**n
      m = 3
      i = m**3
      i = n**m

      print *, i

      end


program main

  use bml

  implicit none
  integer, parameter :: dp = kind(1.0d0)
  type(bml_matrix_t) :: hmat_bml
  real(dp), allocatable :: H(:,:)
  character(20) :: bml_type
  real(dp) :: numthresh
  integer :: i,j,hdim,mdim

  write(*,*)''
  write(*,*)'Example Fortran BML 1: Read a dense matrix form file, convert to bml_ellpack'
  write(*,*)'; get bml parameters N,M and type; and print the bml matrix'
  write(*,*)''

  open(1,file='hamiltonian.dat')
  read(1,*)hdim
  mdim = hdim/2
  bml_type = "ellpack"
  numthresh = 0.05_dp

  allocate(H(hdim,hdim))

  H=0.0_dp

  do i=1,hdim
     do j=1,hdim
        read(1,*)H(i,j)
     enddo
  enddo

  call bml_zero_matrix(bml_type,bml_element_real,dp,hdim,mdim,hmat_bml)

  call bml_convert_from_dense(bml_type,H,hmat_bml,numthresh,mdim)

  write(*,*)''
  write(*,*)"bml_type = ", bml_get_type(hmat_bml)
  write(*,*)"N = ", bml_get_N(hmat_bml)
  write(*,*)"M = ", bml_get_M(hmat_bml)
  write(*,*)''

  !The printing routine starts from 0.
  call bml_print_matrix("hmat_bml",hmat_bml,0,6,0,6)

end program main


RECURSIVE FUNCTION prtrng(q, v, r) RESULT(prob)

! N.B. Argument IFAULT has been removed.

! Code converted using TO_F90 by Alan Miller
! Date: 1999-04-02  Time: 20:07:46

IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)

REAL (dp), INTENT(IN)  :: q
REAL (dp), INTENT(IN)  :: v
REAL (dp), INTENT(IN)  :: r
REAL (dp)              :: prob

!   Algorithm AS 190  Appl. Statist. (1983) Vol.32, No. 2

!   Evaluates the probability from 0 to q for a studentized range
!   having v degrees of freedom and r samples.

!   Uses subroutine ALNORM = algorithm AS66.

!   Arrays vw and qw store transient values used in the quadrature
!   summation.  Node spacing is controlled by step.  pcutj and pcutk control
!   truncation.  Minimum and maximum number of steps are controlled by
!   jmin, jmax, kmin and kmax.  Accuracy can be increased by use of a finer
!   grid - Increase sizes of arrays vw and qw, and jmin, jmax, kmin, kmax and
!   1/step proportionally.

REAL (dp) :: vw(30), qw(30)
REAL (dp) :: g, gmid, r1, c, h, v2, gstep, pk1, pk2, gk, pk
REAL (dp) :: w0, pz, x, hj, ehj, pj
INTEGER   :: ifault, j, jj, jump, k
REAL (dp), PARAMETER :: pcutj = 0.00003_dp, pcutk = 0.0001_dp, step = 0.45_dp, &
                        vmax = 120.0_dp, zero = 0.0_dp, fifth = 0.2_dp,  &
                        half = 0.5_dp, one = 1.0_dp, two = 2.0_dp,   &
                        cv1 = 0.193064705_dp, cv2 = 0.293525326_dp,  &
                        cvmax = 0.39894228_dp, cv(4) = (/ 0.318309886_dp,  &
                        -0.268132716D-2, 0.347222222D-2, 0.833333333D-1 /)
INTEGER, PARAMETER   :: jmin = 3, jmax = 15, kmin = 7, kmax = 15

!        Check initial values

prob = zero
ifault = 0
IF (v < one .OR. r < two) ifault = 1
IF (q <= zero .OR. ifault == 1) GO TO 99

!        Computing constants, local midpoint, adjusting steps.

g = step * r ** (-fifth)
gmid = half * LOG(r)
r1 = r - one
c = LOG(r * g * cvmax)
IF(v > vmax) GO TO 20

h = step * v ** (-half)
v2 = v * half
IF (v == one) c = cv1
IF (v == two) c = cv2
IF (.NOT. (v == one .OR. v == two)) c = SQRT(v2)  &
    * cv(1) / (one + ((cv(2) / v2 + cv(3)) / v2 + cv(4)) / v2)
c = LOG(c * r * g * h)

!        Computing integral
!        Given a row k, the procedure starts at the midpoint and works
!        outward (index j) in calculating the probability at nodes
!        symmetric about the midpoint.  The rows (index k) are also
!        processed outwards symmetrically about the midpoint.  The
!        centre row is unpaired.

20 gstep = g
qw(1) = -one
qw(jmax + 1) = -one
pk1 = one
pk2 = one
DO  k = 1, kmax
  gstep = gstep - g
  21 gstep = -gstep
  gk = gmid + gstep
  pk = zero
  IF (pk2 <= pcutk .AND. k > kmin) GO TO 26
  w0 = c - gk * gk * half
  pz = alnorm(gk, .true.)
  x = alnorm(gk - q, .true.) - pz
  IF (x > zero) pk = EXP(w0 + r1 * LOG(x))
  IF (v > vmax) GO TO 26

  jump = -jmax
  22 jump = jump + jmax
  DO  j = 1, jmax
    jj = j + jump
    IF (qw(jj) > zero) GO TO 23
    hj = h * j
    IF (j < jmax) qw(jj + 1) = -one
    ehj = EXP(hj)
    qw(jj) = q * ehj
    vw(jj) = v * (hj + half - ehj * ehj * half)

    23 pj = zero
    x = alnorm(gk - qw(jj), .true.) - pz
    IF (x > zero) pj = EXP(w0 + vw(jj) + r1 * LOG(x))
    pk = pk + pj
    IF (pj > pcutj) CYCLE
    IF (jj > jmin .OR. k > kmin) EXIT
  END DO
  h = -h
  IF (h < zero) GO TO 22

  26 prob = prob + pk
  IF (k > kmin .AND. pk <= pcutk .AND. pk1 <= pcutk) GO TO 99
  pk2 = pk1
  pk1 = pk
  IF (gstep > zero) GO TO 21
END DO

99 IF (ifault /= 0) WRITE(*, '(a, i3)') ' IFAULT = ', ifault
RETURN

CONTAINS

FUNCTION qtrng(p, v, r) RESULT(quantile)

! N.B. Argument IFAULT has been removed.

REAL (dp), INTENT(IN)  :: p
REAL (dp), INTENT(IN)  :: v
REAL (dp), INTENT(IN)  :: r
REAL (dp)              :: quantile

!   Algorithm AS 190.1  Appl. Statist. (1983) Vol.32, No. 2

!   Approximates the quantile p for a studentized range distribution
!   having v degrees of freedom and r samples for probability 0.9 < p < 0.99.

!   Uses functions  alnorm, ppnd, prtrng and qtrng0 -
!   Algorithms AS 66, AS 241, AS 190 and AS 190.2

REAL (dp) :: q1, p1, q2, p2, d, e1, e2
INTEGER   :: ifault, j, nfault
INTEGER, PARAMETER    :: jmax = 8
REAL (dp), PARAMETER  :: pcut = 0.001_dp, p75 = 0.75_dp, p80 = 0.80_dp,  &
                         p90 = 0.9_dp, p99 = 0.99_dp, p995 = 0.995_dp,   &
                         p175 = 1.75_dp, one = 1.0_dp, two = 2.0_dp,    &
                         five = 5.0_dp, eps = 1.0D-04

!        Check input parameters

ifault = 0
nfault = 0
IF (v < one .OR. r < two) ifault = 1
IF (p < p90 .OR. p > p99) ifault = 2
IF (ifault /= 0) GO TO 99

!        Obtain initial values

q1 = qtrng0(p, v, r)
p1 = prtrng(q1, v, r)
IF (nfault /= 0) GO TO 99
quantile = q1
IF (ABS(p1-p) < pcut) GO TO 99
IF (p1 > p) p1 = p175 * p - p75 * p1
IF (p1 < p) p2 = p + (p - p1) * (one - p) / (one - p1) * p75
IF (p2 < p80) p2 = p80
IF (p2 > p995) p2 = p995
q2 = qtrng0(p2, v, r)
IF (nfault /= 0) GO TO 99

!        Refine approximation

DO  j = 2, jmax
  p2 = prtrng(q2, v, r)
  IF (nfault /= 0) GO TO 99
  e1 = p1 - p
  e2 = p2 - p
  quantile = (q1 + q2) / two
  d = e2 - e1
  IF (ABS(d) > eps) quantile = (e2 * q1 - e1 * q2) / d
  IF(ABS(e1) < ABS(e2)) GO TO 12
  q1 = q2
  p1 = p2
  12   IF (ABS(p1 - p) < pcut * five) GO TO 99
  q2 = quantile
END DO

99 IF (nfault /= 0) ifault = 9
IF (ifault /= 0) WRITE(*, '(a, i4, a)') ' IFAULT = ', ifault, ' from QTRNG'
RETURN
END FUNCTION qtrng

FUNCTION qtrng0(p, v, r) RESULT(initq)

! N.B. Argument IFAULT has been removed.

REAL (dp), INTENT(IN)  :: p
REAL (dp), INTENT(IN)  :: v
REAL (dp), INTENT(IN)  :: r
REAL (dp)              :: initq

!  Algorithm AS 190.2  Appl. Statist. (1983) Vol.32, No.2

!  Calculates an initial quantile p for a studentized range distribution
!  having v degrees of freedom and r samples for probability p, 0.8 < p < 0.995

!  Uses function ppnd - Algorithm AS 241

INTEGER    :: ifault
REAL (dp)  :: q, t
REAL (dp), PARAMETER  :: vmax = 120.0_dp, half = 0.5_dp, one = 1.0_dp,  &
                         four = 4.0_dp, c1 = 0.8843_dp, c2 = 0.2368_dp, &
                         c3 = 1.214_dp, c4 = 1.208_dp, c5 = 1.4142_dp

CALL ppnd16(half + half * p, t, ifault)
IF (v < vmax) t = t + (t * t* t + t) / v / four
q = c1 - c2 * t
IF (v < vmax) q = q - c3 / v + c4 * t / v
initq = t * (q * LOG(r - one) + c5)

RETURN
END FUNCTION qtrng0

FUNCTION alnorm(x, upper) RESULT(fn_val)

!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 1997

REAL (dp), INTENT(IN) :: x
LOGICAL, INTENT(IN)   :: upper
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp, half = 0.5_dp, &
                        con = 1.28_dp
REAL (dp) :: z, y
LOGICAL   :: up

!*** machine dependent constants
REAL (dp), PARAMETER :: ltone = 7.0_dp, utzero = 18.66_dp

REAL (dp), PARAMETER :: p = 0.398942280444_dp, q = 0.39990348504_dp,   &
                        r = 0.398942280385_dp, a1 = 5.75885480458_dp,  &
                        a2 = 2.62433121679_dp, a3 = 5.92885724438_dp,  &
                        b1 = -29.8213557807_dp, b2 = 48.6959930692_dp, &
                        c1 = -3.8052E-8_dp, c2 = 3.98064794E-4_dp,     &
                        c3 = -0.151679116635_dp, c4 = 4.8385912808_dp, &
                        c5 = 0.742380924027_dp, c6 = 3.99019417011_dp, &
                        d1 = 1.00000615302_dp, d2 = 1.98615381364_dp,  &
                        d3 = 5.29330324926_dp, d4 = -15.1508972451_dp, &
                        d5 = 30.789933034_dp

up = upper
z = x
IF(z >=  zero) GO TO 10
up = .NOT. up
z = -z
10 IF(z <= ltone .OR. up .AND. z <= utzero) GO TO 20
fn_val = zero
GO TO 40
20 y = half*z*z
IF(z > con) GO TO 30

fn_val = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
GO TO 40
30 fn_val = r*EXP(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
40 IF(.NOT. up) fn_val = one - fn_val

RETURN
END FUNCTION alnorm

SUBROUTINE ppnd16 (p, normal_dev, ifault)

! ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3

! Produces the normal deviate Z corresponding to a given lower
! tail area of P; Z is accurate to about 1 part in 10**16.

! The hash sums below are the sums of the mantissas of the
! coefficients.   They are included for use in checking
! transcription.

! This ELF90-compatible version by Alan Miller - 20 August 1996
! N.B. The original algorithm is as a function; this is a subroutine

REAL (dp), INTENT(IN)   :: p
INTEGER, INTENT(OUT)    :: ifault
REAL (dp), INTENT(OUT)  :: normal_dev

! Local variables

REAL (dp) :: zero = 0.d0, one = 1.d0, half = 0.5d0, split1 = 0.425d0,  &
             split2 = 5.d0, const1 = 0.180625d0, const2 = 1.6d0, q, r

! Coefficients for P close to 0.5

REAL (dp) :: a0 = 3.3871328727963666080D0, &
             a1 = 1.3314166789178437745D+2, &
             a2 = 1.9715909503065514427D+3, &
             a3 = 1.3731693765509461125D+4, &
             a4 = 4.5921953931549871457D+4, &
             a5 = 6.7265770927008700853D+4, &
             a6 = 3.3430575583588128105D+4, &
             a7 = 2.5090809287301226727D+3, &
             b1 = 4.2313330701600911252D+1, &
             b2 = 6.8718700749205790830D+2, &
             b3 = 5.3941960214247511077D+3, &
             b4 = 2.1213794301586595867D+4, &
             b5 = 3.9307895800092710610D+4, &
             b6 = 2.8729085735721942674D+4, &
             b7 = 5.2264952788528545610D+3
! HASH SUM AB    55.8831928806149014439

! Coefficients for P not close to 0, 0.5 or 1.

REAL (dp) :: c0 = 1.42343711074968357734D0, &
             c1 = 4.63033784615654529590D0, &
             c2 = 5.76949722146069140550D0, &
             c3 = 3.64784832476320460504D0, &
             c4 = 1.27045825245236838258D0, &
             c5 = 2.41780725177450611770D-1, &
             c6 = 2.27238449892691845833D-2, &
             c7 = 7.74545014278341407640D-4, &
             d1 = 2.05319162663775882187D0, &
             d2 = 1.67638483018380384940D0, &
             d3 = 6.89767334985100004550D-1, &
             d4 = 1.48103976427480074590D-1, &
             d5 = 1.51986665636164571966D-2, &
             d6 = 5.47593808499534494600D-4, &
             d7 = 1.05075007164441684324D-9
! HASH SUM CD    49.33206503301610289036

! Coefficients for P near 0 or 1.

REAL (dp) :: e0 = 6.65790464350110377720D0, &
             e1 = 5.46378491116411436990D0, &
             e2 = 1.78482653991729133580D0, &
             e3 = 2.96560571828504891230D-1, &
             e4 = 2.65321895265761230930D-2, &
             e5 = 1.24266094738807843860D-3, &
             e6 = 2.71155556874348757815D-5, &
             e7 = 2.01033439929228813265D-7, &
             f1 = 5.99832206555887937690D-1, &
             f2 = 1.36929880922735805310D-1, &
             f3 = 1.48753612908506148525D-2, &
             f4 = 7.86869131145613259100D-4, &
             f5 = 1.84631831751005468180D-5, &
             f6 = 1.42151175831644588870D-7, &
             f7 = 2.04426310338993978564D-15
! HASH SUM EF    47.52583317549289671629

ifault = 0
q = p - half
IF (ABS(q) <= split1) THEN
  r = const1 - q * q
  normal_dev = q * (((((((a7*r + a6)*r + a5)*r + a4)*r + a3)*r + a2)*r + a1)*r + a0) / &
           (((((((b7*r + b6)*r + b5)*r + b4)*r + b3)*r + b2)*r + b1)*r + one)
  RETURN
ELSE
  IF (q < zero) THEN
    r = p
  ELSE
    r = one - p
  END IF
  IF (r <= zero) THEN
    ifault = 1
    normal_dev = zero
    RETURN
  END IF
  r = SQRT(-LOG(r))
  IF (r <= split2) THEN
    r = r - const2
    normal_dev = (((((((c7*r + c6)*r + c5)*r + c4)*r + c3)*r + c2)*r + c1)*r + c0) / &
             (((((((d7*r + d6)*r + d5)*r + d4)*r + d3)*r + d2)*r + d1)*r + one)
  ELSE
    r = r - split2
    normal_dev = (((((((e7*r + e6)*r + e5)*r + e4)*r + e3)*r + e2)*r + e1)*r + e0) / &
             (((((((f7*r + f6)*r + f5)*r + f4)*r + f3)*r + f2)*r + f1)*r + one)
  END IF
  IF (q < zero) normal_dev = - normal_dev
  RETURN
END IF
RETURN
END SUBROUTINE ppnd16

END FUNCTION prtrng


!********************************************************************************
!   NAN_INF: Test FPML ability to avoid overflow/underflow and produce meaningful results.
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 16 May 2019
!********************************************************************************
! The speed and accuracy of FPML is compared against Polzeros and AMVW for
! computing the roots of the polynomial sum(i+1)x^i.
!********************************************************************************
program nan_inf
    use fpml
    implicit none
    ! testing variables
    integer                                     :: deg, j, k
    real(kind=dp)                               :: a, r
    real(kind=dp), parameter                    :: pi2 = 6.2831853071795864769_dp
    complex(kind=dp), allocatable               :: exact_roots(:)
    ! FPML variables
    integer, parameter                          :: nitmax = 30
    integer, allocatable                        :: conv(:)
    real(kind=dp), allocatable                  :: berr(:), cond(:)
    complex(kind=dp), allocatable               :: p(:), roots(:)

    ! Test 1: p(z) = -a^-1 + az^deg, a = 2.0_dp**(deg)
	write(*,'(A)') 'Test 1: '
    open(unit=1,file="data_files/nan_inf1.dat")
    write(1,'(A)') 'deg, relative forward error, backward error, condition number'
    do deg=1012,1013
        write(1,'(I10,A)',advance='no') deg, ', '
        ! allocate
        allocate(exact_roots(deg), conv(deg), berr(deg), cond(deg), p(deg+1), roots(deg))
        ! polynomial and roots
        a = 2.0_dp**(deg)
        r = 2.0_dp**(-2)
        exact_roots = (/ (r*cmplx(cos(pi2*k/real(deg,kind=dp)),sin(pi2*k/real(deg,kind=dp)),kind=dp), k=1,deg)/)
        p = cmplx(0,0,kind=dp)
        p(1) = cmplx(-a**(-1),0,kind=dp)
        p(deg+1) = cmplx(a,0,kind=dp)
        ! fpml
        call main(p, deg, roots, berr, cond, conv, nitmax)
        ! relative forward error, backward error, and condition number
        write(1,'(ES15.2,ES15.2,ES15.2)') max_rel_err(roots, exact_roots, deg), maxval(berr), maxval(cond)
        ! deallocate
        deallocate(exact_roots, conv, berr, cond, p, roots)
    end do
    ! close file
    close(1)

    ! Test 2: p(z) = 0 + 0z + ... + -a^(-1)z^10 + az^11, a = 2.0_dp**(j)
	write(*,'(A)') 'Test 2: '
    open(unit=1,file="data_files/nan_inf2.dat")
    write(1,'(A)') 'power, relative forward error, backward error, condition number'
    deg = 11
    do j=1012,1013
        write(1,'(I10,A)',advance='no') j, ', '
        ! allocate
        allocate(exact_roots(deg), conv(deg), berr(deg), cond(deg), p(deg+1), roots(deg))
        ! polynomial and roots
        a = 2.0_dp**(j)
        r = 2.0_dp**(-2.0_dp*j)
        exact_roots(1:deg-1) = 0.0_dp
        exact_roots(deg) = r
        p(1:deg-1) = cmplx(0,0,kind=dp)
        p(deg) = cmplx(-a**(-1),0,kind=dp)
        p(deg+1) = cmplx(a,0,kind=dp)
        ! fpml
        call main(p, deg, roots, berr, cond, conv, nitmax)
        ! relative forward error, backward error, and condition number
        write(1,'(ES15.2,ES15.2,ES15.2)') max_rel_err(roots, exact_roots, deg), maxval(berr), maxval(cond)
        ! deallocate
        deallocate(exact_roots, conv, berr, cond, p, roots)
    end do
    ! close file
    close(1)

    ! Test 3: p(z) = -a+a^(-1)z^deg, a = 2.0_dp**(deg)
	write(*,'(A)') 'Test 3: '
    open(unit=1,file="data_files/nan_inf3.dat")
    write(1,'(A)') 'deg, relative forward error, backward error, condition number'
    do deg=1012,1013
        write(1,'(I10,A)',advance='no') deg, ', '
        ! allocate
        allocate(exact_roots(deg), conv(deg), berr(deg), cond(deg), p(deg+1), roots(deg))
        ! polynomial and roots
        a = 2.0_dp**(deg)
        r = 2.0_dp**(2)
        exact_roots = (/ (r*cmplx(cos(pi2*k/real(deg,kind=dp)),sin(pi2*k/real(deg,kind=dp)),kind=dp), k=1,deg)/)
        p = cmplx(0,0,kind=dp)
        p(1) = cmplx(-a,0,kind=dp)
        p(deg+1) = cmplx(a**(-1),0,kind=dp)
        ! fpml
        call main(p, deg, roots, berr, cond, conv, nitmax)
        ! relative forward error, backward error, and condition number
        write(1,'(ES15.2,ES15.2,ES15.2)') max_rel_err(roots, exact_roots, deg), maxval(berr), maxval(cond)
        ! deallocate
        deallocate(exact_roots, conv, berr, cond, p, roots)
    end do
    ! close file
    close(1)

    ! Test 4: p(z) = 0 + 0z + ... + -az^10 + a^(-1)z^11, a = 2.0_dp**(j)
	write(*,'(A)') 'Test 4: '
    open(unit=1,file="data_files/nan_inf4.dat")
    write(1,'(A)') 'power, relative forward error, backward error, condition number'
    deg = 11
    do j=1012,1013
        write(1,'(I10,A)',advance='no') j, ', '
        ! allocate
        allocate(exact_roots(deg), conv(deg), berr(deg), cond(deg), p(deg+1), roots(deg))
        ! polynomial and roots
        a = 2.0_dp**(j)
        r = 2.0_dp**(2.0_dp*j)
        exact_roots(1:deg-1) = 0.0_dp
        exact_roots(deg) = r
        p(1:deg-1) = cmplx(0,0,kind=dp)
        p(deg) = cmplx(-a,0,kind=dp)
        p(deg+1) = cmplx(a**(-1),0,kind=dp)
        ! fpml
        call main(p, deg, roots, berr, cond, conv, nitmax)
        ! relative forward error, backward error, and condition number
        write(1,'(ES15.2,ES15.2,ES15.2)') max_rel_err(roots, exact_roots, deg), maxval(berr), maxval(cond)
        ! deallocate
        deallocate(exact_roots, conv, berr, cond, p, roots)
    end do
    ! close file
    close(1)

    ! Test 5: 0 + 1z + ... + 9z^9 - a^(-1)z^10 + az^11, a = 2.0_dp**(j)
	write(*,'(A)') 'Test 5: '
    open(unit=1,file="data_files/nan_inf5.dat")
    write(1,'(A)') 'power, backward error, condition number'
    deg = 11
    do j=1012,1013
        write(1,'(I10,A)',advance='no') j, ', '
        ! allocate
        allocate(conv(deg), berr(deg), cond(deg), p(deg+1), roots(deg))
        ! polynomial and roots
        a = 2.0_dp**(j)
        p(1:deg-1) = (/ (cmplx(k,0,kind=dp), k=0,deg-2) /)
        p(deg) = cmplx(-a**(-1),0,kind=dp)
        p(deg+1) = cmplx(a,0,kind=dp)
        ! fpml
        call main(p, deg, roots, berr, cond, conv, nitmax)
        ! relative forward error, backward error, and condition number
        write(1,'(ES15.2,ES15.2)') maxval(berr), maxval(cond)
        ! deallocate
        deallocate(conv, berr, cond, p, roots)
    end do
    ! close file
    close(1)

    ! Test 6: 0 + 1z + ... + 9z^9 - az^10 + a(-1)z^11, a = 2.0_dp**(j)
	write(*,'(A)') 'Test 6: '
    open(unit=1,file="data_files/nan_inf6.dat")
    write(1,'(A)') 'power, backward error, condition number'
    deg = 11
    do j=1012,1013
        write(1,'(I10,A)',advance='no') j, ', '
        ! allocate
        allocate(conv(deg), berr(deg), cond(deg), p(deg+1), roots(deg))
        ! polynomial and roots
        a = 2.0_dp**(j)
        p(1:deg-1) = (/ (cmplx(k,0,kind=dp), k=0,deg-2) /)
        p(deg) = cmplx(-a,0,kind=dp)
        p(deg+1) = cmplx(a**(-1),0,kind=dp)
        ! fpml
        call main(p, deg, roots, berr, cond, conv, nitmax)
        ! relative forward error, backward error, and condition number
        write(1,'(ES15.2,ES15.2)') maxval(berr), maxval(cond)
        ! deallocate
        deallocate(conv, berr, cond, p, roots)
    end do
    ! close file
    close(1)

contains

    !************************************************
    !                       max_rel_err             *
    !************************************************
    ! Compute maximum relative error between roots
    ! and exact roots.
    !************************************************
    function max_rel_err(roots, exact_roots, deg) result(res)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: exact_roots(:), roots(:)
        ! local variables
        logical                         :: m(deg)
        integer                         :: i, j, k
        real(kind=dp)                   :: delta, err, res, relerr, rmax
        ! intrinsic procedures
        intrinsic                       :: abs, max, huge

        ! initialize
        m = .True.
        rmax = huge(1.0_dp)
        res = eps
        ! main loop
        do i=1,deg
            ! find corresponding exact root (yet to be matched)
            err = rmax
            do j=1,deg
                if(m(j)) then
                    delta = abs(exact_roots(j) - roots(i))
                    if(delta < err) then
                        err = delta
                        k = j
                    end if
                end if
            end do
            ! mark corresponding root as matched
            m(k) = .False.
            ! calculate relative error on this root and update max
            ! zero roots give unhelpful relative errors, so revert to absolute error
            if(abs(roots(i))<eps .or. abs(exact_roots(k))<eps) then
                relerr = err
            else
                relerr = err/abs(exact_roots(k))
            end if
            res = max(relerr, res)
        end do
        res = max(res,eps)
    end function max_rel_err
end program nan_inf


      PROGRAM polyfit
      IMPLICIT none
      CHARACTER*40 ifile,ofile,cfile,pfile,rfile,MXORDC
      LOGICAL ex
      INTEGER i,nobs,MXOBS
      PARAMETER (MXOBS=100000)
      REAL*8 xobs(MXOBS),yobs(MXOBS)
      INTEGER MXORD,ord,MXCON,ncon
      PARAMETER (MXORD=20,MXCON=21)
      REAL*8 coeff(MXORD),xc(MXCON),yc(MXCON),ypre,res
      INTEGER j,p
C----
C TO-DO:
C Subroutine chkopt(ifile,ofile,cfile,ord,MXORD)
C   check existence of input files
C   check output file defined
C   check ord <= MXORD
C Subroutine readxy(ifile,xobs,yobs,nobs)
C   read in values and number of observations from ifile
C Subroutine readconstr(cfile,xc,yc,ncon)
C   read in constraints if necessary
C----

#ifndef USELAPACK
      write(0,*) 'polyfit: compile with LAPACK to use'
      stop
#endif

C----
C Parse command line
C----
      call gcmdln(ifile,ofile,cfile,xc,yc,ncon,pfile,rfile,ord,p)

C----
C Check for required input files and values
C----
      if (ifile.eq.'none') then
          write(*,*) '!! Error: Input x-y data is not specified'
          call usage('!! Use -f XYFILE to specify input file')
      elseif (ifile.ne.'stdin') then
          inquire(file=ifile,EXIST=ex)
          if (.not.ex) call usage('!! Error: no x-y file: '//ifile)
      endif
      if (ord.lt.0) then
          write(*,*) '!! Error: polynomial order not specified'
          call usage('!! Use -ord ORDER to specify order')
      endif
      if (ofile.eq.'none'.and.p.eq.0) then
          write(*,*) '!! Error: No output file specified'
          call usage('!! Use -o COEFF to specify coefficient file')
      endif
C Check for optional input files and values
      if (cfile.ne.'none') then
          inquire(file=cfile,EXIST=ex)
          if (.not.ex) call usage('!! Error: no constraint file: '
     1                                           //cfile)
      endif
      if (ord.gt.MXORD) then
          write(MXORDC,*) MXORD
          call usage('!! Error: ORD must be <='//MXORDC)
      endif

C----
C Extract observed data from input time series
C----
      if (ifile.ne.'stdin') then
          open(unit=11,file=ifile,status='old')
          i = 1
  101     read(11,*,end=102) xobs(i),yobs(i)
              i = i + 1
              goto 101
  102     continue
          close(11)
          nobs = i - 1
      else
          i = 1
  111     read(*,*,end=112) xobs(i),yobs(i)
              i = i + 1
              goto 111
  112     continue
          nobs = i - 1
      endif
C----
C Check if a constraint file was defined, and compute coefficients
C----
C     Unconstrained least squares fit
      if (cfile.eq.'none'.and.xc(1).lt.-1.0d98) then
          call polylsq(coeff,xobs,yobs,nobs,ord)
C     Constrained least squares fit
      elseif (cfile.eq.'none') then
          call polylsqconstr(coeff,xobs,yobs,nobs,ord,xc,yc,ncon)
      else
          open(unit=13,file=cfile,status='old')
          i = 1
 103      read(13,*,end=104) xc(i),yc(i)
              i = i + 1
              goto 103
 104      continue
          close(13)
          ncon = i - 1
          call polylsqconstr(coeff,xobs,yobs,nobs,ord,xc,yc,ncon)
      endif

C----
C Print coefficients
C----
      if (p.eq.0) then
          open(unit=14,file=ofile,status='unknown')
          write(14,9001)
          do 105 i = 1,ord+1
              write(14,9002) i-1,coeff(i)
  105     continue
          close(14)
      else
          write(*,9001)
          do 106 i = 1,ord+1
              write(*,9002) i-1,coeff(i)
  106     continue
      endif

C----
C Print predicted results
C----
      if (pfile.ne.'none') then
          open(unit=12,file=pfile,status='unknown')
          do 108 i = 1,nobs
              ypre = 0.0d0
              do 107 j = 1,ord+1
                  ypre = ypre + coeff(j)*xobs(i)**(j-1)
  107         continue
              write (12,9003) xobs(i),ypre
  108     continue
          close(12)
      endif

      if (rfile.ne.'none') then
          open(unit=15,file=rfile,status='unknown')
          do 110 i = 1,nobs
              ypre = 0.0d0
              do 109 j = 1,ord+1
                  ypre = ypre + coeff(j)*xobs(i)**(j-1)
  109         continue
              res = yobs(i) - ypre
              write(15,9003) xobs(i),res
  110     continue
      endif

 9001 format('POLY_ORDER      COEFFICIENT')
 9002 format(I10,X,1PE16.6)
 9003 format(2E14.6)

      END

C======================================================================C

      SUBROUTINE gcmdln(ifile,ofile,cfile,xc,yc,ncon,pfile,rfile,ord,p)
      IMPLICIT NONE
      INTEGER MXCON
      PARAMETER (MXCON=21)
      REAL*8 xc(MXCON),yc(MXCON)
      CHARACTER*40 ifile,ofile,cfile,pfile,rfile,tag
      INTEGER i,j,narg,ord,p,ncon
      j = 0
      xc(1) = -1.0d99
      ifile = 'none'
      ofile = 'none'
      cfile = 'none'
      pfile = 'none'
      rfile = 'none'
      p = 0
      ord = -1
      ncon = 0
      narg = iargc()
      if (narg.eq.0) then
          call usage('')
      endif
      i = 0
  101 i = i + 1
      if (i.gt.narg) goto 102
          call getarg(i,tag)
          if (tag(1:4).eq.'-pre') then
              i = i + 1
              call getarg(i,pfile)
          elseif (tag(1:4).eq.'-ord') then
              i = i + 1
              call getarg(i,tag)
              read(tag,'(BN,I5)') ord
          elseif (tag(1:4).eq.'-res') then
              i = i + 1
              call getarg(i,rfile)
          elseif (tag(1:3).eq.'-cf') then
              i = i + 1
              call getarg(i,cfile)
          elseif (tag(1:2).eq.'-c') then
              j = j + 1
              i = i + 1
              call getarg(i,tag)
              read(tag,'(BN,F10.0)') xc(j)
              i = i + 1
              call getarg(i,tag)
              read(tag,'(BN,F10.0)') yc(j)
          elseif (tag(1:2).eq.'-p') then
              p = 1
          elseif (tag(1:2).eq.'-o') then
              i = i + 1
              call getarg(i,ofile)
          elseif (tag(1:2).eq.'-f') then
              i = i + 1
              call getarg(i,ifile)
          elseif (tag(1:2).eq.'-h') then
              call usage(' ')
          else
              call usage('!! Error: No option '//tag)
          endif
          goto 101
  102 continue
      ncon = j
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE usage(str)
      IMPLICIT NONE
      INTEGER lstr
      CHARACTER str*(*)
      if (str.ne.' ') then
          lstr = len(str)
          write(*,*) str(1:lstr)
          write(*,*)
      endif
      write(*,*)
     1 'Usage: polyfit -f XYINPUT -o COEFFS -ord ORDER [-p] ',
     2              '[-c XC YC | -cf CONSTR]'
      write(*,*)
     1 '               [-pre PREDICTED] [-res RESFILE] [-h]'
      write(*,*)
      write(*,*)
     1 '-f XYINPUT         Input X-Y file'
      write(*,*)
     1 '-o COEFFS          File with computed polynomial coefficients'
      write(*,*)
     1 '-ord ORDER         Order of polynomial (integer)'
      write(*,*)
     1 '-p                 Print polynomial coefficients (overrides -o)'
      write(*,*)
     1 '-c XC YC           Define constraint coordinates on command ',
     2                            'line (can use multiple times)'
      write(*,*)
     1 '-cf CONSTR         File with X-Y equality constraints ',
     2                                '(overrides -c)'
      write(*,*)
     1 '-pre PREFILE       Values of polynomial at input ',
     2                                    'X-coordinates'
      write(*,*)
     1 '-res RESFILE       Residual values (observed - predicted)'
      write(*,*)
     1 '-h                 Online help'
      write(*,*)
      STOP
      END