c
c     dpoco factors a double precision symmetric positive definite
c     matrix and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dpofa is slightly faster.
c     to solve  a*x = b , follow dpoco by dposl.
c     to compute  inverse(a)*c , follow dpoco by dposl.
c     to compute  determinant(a) , follow dpoco by dpodi.
c     to compute  inverse(a) , follow dpoco by dpodi.
c
c     on entry
c
c        a       double precision(lda, n)
c                the symmetric matrix to be factored.  only the
c                diagonal and upper triangle are used.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix  r  so that  a = trans(r)*r
c                where  trans(r)  is the transpose.
c                the strict lower triangle is unaltered.
c                if  info .ne. 0 , the factorization is not complete.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.  if info .ne. 0 , rcond is unchanged.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c                if  info .ne. 0 , z  is unchanged.
c
c        info    integer
c                = 0  for normal return.
c                = k  signals an error condition.  the leading minor
c                     of order  k  is not positive definite.
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dpofa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,dreal,dsign
c
      subroutine dpoco(a,lda,n,rcond,z,info)
      integer lda,n,info
      double precision a(lda,*),z(*)
      double precision rcond
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer i,j,jm1,k,kb,kp1
c
c
c     find norm of a using only upper half
c
      do 30 j = 1, n
         z(j) = dasum(j,a(1,j),1)
         jm1 = j - 1
         if (jm1 .lt. 1) go to 20
         do 10 i = 1, jm1
            z(i) = z(i) + dabs(a(i,j))
   10    continue
   20    continue
   30 continue
      anorm = 0.0d0
      do 40 j = 1, n
         anorm = dmax1(anorm,z(j))
   40 continue
c
c     factor
c
      call dpofa(a,lda,n,info)
      if (info .ne. 0) go to 180
c
c        rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c        estimate = norm(z)/norm(y) where  a*z = y  and  a*y = e .
c        the components of  e  are chosen to cause maximum local
c        growth in the elements of w  where  trans(r)*w = e .
c        the vectors are frequently rescaled to avoid overflow.
c
c        solve trans(r)*w = e
c
         ek = 1.0d0
         do 50 j = 1, n
            z(j) = 0.0d0
   50    continue
         do 110 k = 1, n
            if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
            if (dabs(ek-z(k)) .le. a(k,k)) go to 60
               s = a(k,k)/dabs(ek-z(k))
               call dscal(n,s,z,1)
               ek = s*ek
   60       continue
            wk = ek - z(k)
            wkm = -ek - z(k)
            s = dabs(wk)
            sm = dabs(wkm)
            wk = wk/a(k,k)
            wkm = wkm/a(k,k)
            kp1 = k + 1
            if (kp1 .gt. n) go to 100
               do 70 j = kp1, n
                  sm = sm + dabs(z(j)+wkm*a(k,j))
                  z(j) = z(j) + wk*a(k,j)
                  s = s + dabs(z(j))
   70          continue
               if (s .ge. sm) go to 90
                  t = wkm - wk
                  wk = wkm
                  do 80 j = kp1, n
                     z(j) = z(j) + t*a(k,j)
   80             continue
   90          continue
  100       continue
            z(k) = wk
  110    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
c
c        solve r*y = w
c
         do 130 kb = 1, n
            k = n + 1 - kb
            if (dabs(z(k)) .le. a(k,k)) go to 120
               s = a(k,k)/dabs(z(k))
               call dscal(n,s,z,1)
  120       continue
            z(k) = z(k)/a(k,k)
            t = -z(k)
            call daxpy(k-1,t,a(1,k),1,z(1),1)
  130    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
c
         ynorm = 1.0d0
c
c        solve trans(r)*v = y
c
         do 150 k = 1, n
            z(k) = z(k) - ddot(k-1,a(1,k),1,z(1),1)
            if (dabs(z(k)) .le. a(k,k)) go to 140
               s = a(k,k)/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  140       continue
            z(k) = z(k)/a(k,k)
  150    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
         ynorm = s*ynorm
c
c        solve r*z = v
c
         do 170 kb = 1, n
            k = n + 1 - kb
            if (dabs(z(k)) .le. a(k,k)) go to 160
               s = a(k,k)/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  160       continue
            z(k) = z(k)/a(k,k)
            t = -z(k)
            call daxpy(k-1,t,a(1,k),1,z(1),1)
  170    continue
c        make znorm = 1.0
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
         ynorm = s*ynorm
c
         if (anorm .ne. 0.0d0) rcond = ynorm/anorm
         if (anorm .eq. 0.0d0) rcond = 0.0d0
  180 continue
      return
      end


!----------------------------------------------------------------
! (c) Copyright, 2016 by the Regents of the University of California.
! PhysConstclass: physical constants class in CONSTANTS module of
!                 DATA STRUCTURE layer.
! Version: 1.0
! Author: Ji Qiang, LBNL
! Description: This class defines the physical constant parameters used
!              in the simulation.
! Comments:
!----------------------------------------------------------------
      module PhysConstclass
        implicit none

        !physical parameters and constants ---------------------
        double precision :: Pi
        double precision :: Clight !speed of light in vaccum
        double precision :: Scxl !length scale
        double precision :: Rad2deg !conversion factor from radian to degree
        double precision :: Epsilon0 !permittivity of vacuum
        double precision :: Scfreq !time scale
      contains
        subroutine construct_PhysConst(freq)
        double precision, intent(in) :: freq

        Clight = 299792458.0d0
        Pi = 2*asin(1.0d0)
        Scxl = Clight/(2*pi*freq)
        Rad2deg = 180.0d0/Pi
        Epsilon0 = 8.854187817d-12
        Scfreq = freq

        end subroutine construct_PhysConst

      end module PhysConstclass


	FUNCTION PC_PWTR  ( tdb, tdt, pb, pt, pwb )
C************************************************************************
C* PC_PWTR								*
C*									*
C* This function computes precipitable water. 				*
C*									*
C* REAL PC_PWTR  ( TDB, TDT, PB, PT, PWB )				*
C*									*
C* Input parameters:							*
C*	TDB		REAL		Bottom dewpoint			*
C*	TDT		REAL		Top dewpoint 			*
C*	PB		REAL		Bottom pressure			*
C*	PT		REAL		Top pressure			*
C*	PWB		REAL		Bottom precipitable water	*
C*									*
C* Output parameters:							*
C*	PC_PWTR		REAL		Precipitable water		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/84						*
C* M. desJardins/GSFC	10/87	Fixed typing errors			*
C* M. desJardins/GSFC	10/87	Multiply by 100. to convert to mm.	*
C* J. Whistler/SSAI	 2/91	Changed wrong variable to PWB		*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
        INCLUDE 'GEMPRM.PRM'
        INCLUDE 'ERMISS.FNC'
C------------------------------------------------------------------------
	IF ( ( .not. ERMISS (tdb) ) .and. ( .not. ERMISS (tdt) ) .and.
     +	     ( .not. ERMISS  (pb) ) .and. ( .not. ERMISS  (pt) ) )  THEN
C
C*	    Compute the average mixing ratio.  Note that the mixing
C*	    ratio is divided by 1000. since PR_MIXR computes g/kg.
C
	    rmb  = PR_MIXR ( tdb, pb )
	    rmt  = PR_MIXR ( tdt, pt )
	    rmav = ( rmb + rmt ) / 2.0 / 1000.
	    PC_PWTR = 100. * rmav * ( pb - pt ) / GRAVTY + pwb
	  ELSE
	    PC_PWTR = pwb
	END IF
C*
	RETURN
	END


program fisher_estimate

  USE healpix_types

	implicit none
	integer(i4b)::i,jlo,l
	integer,parameter :: lmax=3000
	real(dp), parameter ::fsky=1d0,thetaFWHM=1d0*0.000290888209d0
	real(dp), allocatable, dimension(:,:)::Cl
	real(dp), allocatable, dimension(:,:,:)::CovMatrix,CovMatrixInv

	real(dp), allocatable, dimension(:):: xa,ya,y2a,deltaCl,deltaCl_pol,y_pol,y_pol2,x_pol !! variable for spline the TT spectrum and EE
	real(dp), allocatable, dimension(:):: xTE,yTE,yTE2,deltaClTE!! variable for spline the TE spectrum
    LOGICAL ::OK_FLAG
	character(len=128) :: filename
	integer  :: ios,err,istat
	real(dp)::logCl,logCl_pol,fisher,fisher_pol,fisherTE, variance,variance_pol
	filename='/home/manzotti/Software/camb/test_scalCls.dat'

write(*,*),filename
	open(unit=10, file=filename, iostat=ios, &
     status="old", action="read", form='formatted')
	if ( ios /= 0 ) stop "Error opening file name"
  write(*,*) 'here'

	allocate(CovMatrix(3,3,lmax),CovMatrixInv(3,3,lmax), stat=err)
	if (err /= 0) print *, "array: Allocation request denied"
	allocate(cl(lmax,4), stat=err)
	if (err /= 0) print *, "array: Allocation request denied"
	allocate(xa(lmax),ya(lmax),y2a(lmax),deltaCl(lmax),y_pol(lmax)&
             ,y_pol2(lmax),deltaCl_pol(lmax),yTE(lmax),yTE2(lmax),deltaClTE(lmax),stat=err)
	if (err /= 0) print *, "array: Allocation request denied"
	!! read the Cl from camb

	do i = 1, lmax, 1

		read(10, *) cl(i,1),cl(i,2),cl(i,3),cl(i,4)
		if ( istat /= 0 ) stop "Read error in file 10"
	end do

!	write(*,*) cl(10,1),cl(10,2)

!! normalize CAMB
	do i = 1, lmax, 1
		l=cl(i,1)
		cl(i,2)=cl(i,2)*(twopi/(l*(l+1)))!/(7.4311e12)
		cl(i,3)=cl(i,3)*(twopi/(l*(l+1)))!/(7.4311e12)
		cl(i,4)=cl(i,4)*(twopi/(l*(l+1)))!/(7.4311e12)

	end do
	write(*,*) cl(10,1),cl(10,2),cl(10,3),cl(10,4)

	!!! spline the TT spectrum

	xa=log(cl(:,1)) !log(l)
	ya=log(cl(:,1)**2*cl(:,2)) !log (l^2 Cl)
	call spline(xa,ya,lmax,1.d32,1.d32,y2a)

!!! spline the EE spectrum

	xa=log(cl(:,1)) !log(l)
	y_pol=log(cl(:,1)**2*cl(:,3)) !log (l^2 CEE)
 !       write(*,*) shape(y_pol),shape(xa),shape(y_pol2)
	call spline(xa,y_pol,lmax,1.d32,1.d32,y_pol2)

!!! spline the TE spectrum
!!! note: numerical problematic cause it change SIGN. This is not implemented directly in a logaritmic fashion

	xa=log(cl(:,1)) !log(l)
	yTE=(cl(:,1))**2*(cl(:,4)) !log (l^2 CEE)
!        write(*,*) shape(yTE),shape(xa),shape(yTE2)
	call spline(xa,yTE,lmax,1.d32,1.d32,yTE2)

!!write(*,*) yTE,y_pol2

!stop

!	write(*,*) shape(y2a),y2a(10)
	write(*,*) 'power spectrum TT&EE&TE splined'
!	logCl=logl2Cl(10._dp)
!	write(*,*) 'power spectrum splined'!,logl2Cl(11._dp),dlnl2Cldlogl(11d0)

	!!! prepare for fishere elements, compute deltaCl

	!!! deltaCl=sqrt(2/(2l+1)fsky) (Cl+Nl) we need delta cl squared

        !! COMPUTE OUTPUT ANS PRINT

        !cl(i,2) C^T
        !cl(i,3) C^E
        !cl(i,4) C^TE

do i=2,lmax,1
  CovMatrix(1,1,i)=cl(i,2)**2 !! TT TT variance look 9807130v2
  CovMatrix(1,2,i)=cl(i,2)*cl(i,4) !! TT TE variance
  CovMatrix(2,1,i)=CovMatrix(1,2,i)
  CovMatrix(1,3,i)=cl(i,4)**2 !! TT EE variance
  CovMatrix(3,1,i)=CovMatrix(1,3,i)
  CovMatrix(2,2,i)=(cl(i,4)**2+cl(i,2)*cl(i,3)) !! TE TE variance
  CovMatrix(2,3,i)=(cl(i,3)*cl(i,4)) !! TE EE
  CovMatrix(3,2,i)=CovMatrix(2,3,i)
  CovMatrix(3,3,i)=cl(i,3)**2 !! EE EE
  CovMatrix(:,:,i)=2/(2*cl(i,1)+1)*CovMatrix(:,:,i)
enddo
 !! EE EE
open(unit=30, file='variancenonoisenofsky_fisher.txt')

!! fisher elements  sum_l 1/deltaC (deriv)^2
	fisher=0d0
        fisher_pol=0d0
        fisherTE=0d0
            write(*,*) 'fisher', fisher

	do i = 100, lmax, 1

		!! invert the 3 by 3 covariance matrix
write(*,*) 'i', i
write(*,*) CovMatrix(1,:,i)
write(*,*) CovMatrix(2,:,i)
write(*,*) CovMatrix(3,:,i)
write(*,*) ''
		call m33inv(CovMatrix(:,:,i),CovMatrixInv(:,:,i),OK_FLAG)
if ( OK_FLAG .neqv. .true. ) stop "Something wrong while inverting the matrix"

write(*,*) CovMatrixInv(1,:,i)
write(*,*) CovMatrixInv(2,:,i)
write(*,*) CovMatrixInv(3,:,i)
write(*,*) ''

	fisher = fisher+cl(i,2)*cl(i,2)*(dlnl2Cldlogl2(DBLE(i),ya,y2a))*(dlnl2Cldlogl2(DBLE(i),ya,y2a))*CovMatrixInv(1,1,i)& !TTTT
	+(cl(i,3)*cl(i,3)*(dlnl2Cldlogl2(DBLE(i),y_pol,y_pol2))*(dlnl2Cldlogl2(DBLE(i),y_pol,y_pol2))*CovMatrixInv(3,3,i))& !EEEE
	+(cl(i,4)*cl(i,4)*(dlnl2Cldlogl2(DBLE(i),yTE,yTE2))/((cl(i-1,1))**2*(cl(i-1,4)))*&
    (dlnl2Cldlogl2(DBLE(i),yTE,yTE2))/((cl(i-1,1))**2*(cl(i-1,4)))*CovMatrixInv(2,2,i))& !TETE
	+(cl(i,4)*cl(i,2)*(dlnl2Cldlogl2(DBLE(i),yTE,yTE2))/((cl(i-1,1))**2*(cl(i-1,4)))&
    *(dlnl2Cldlogl2(DBLE(i),ya,y2a))*CovMatrixInv(1,2,i))& !TETT
	+(cl(i,3)*cl(i,2)*(dlnl2Cldlogl2(DBLE(i),y_pol,y_pol2))*(dlnl2Cldlogl2(DBLE(i),ya,y2a))*CovMatrixInv(1,3,i))& !EETT
	+(cl(i,3)*cl(i,4)*(dlnl2Cldlogl2(DBLE(i),y_pol,y_pol2))*(dlnl2Cldlogl2(DBLE(i),yTE,yTE2))&
    /((cl(i-1,1))**2*(cl(i-1,4)))*CovMatrixInv(2,3,i)) !EETE

write(*,*) 'fisher', fisher

		fisher_pol=fisher_pol+(1/(2d0/((2*cl(i,1)+1))))*(dlnl2Cldlogl2(DBLE(i),y_pol,y_pol2))**2!*(cl(i,3))**2
		fisherTE=fisherTE+(1/(2d0/((2*cl(i,1)+1))))*(dlnl2Cldlogl2(DBLE(i),ya,y2a))**2!*(cl(i,4))**2

		write(30,*) cl(i,1),1/fisher,1/fisher_pol,1/fisherTE

	end do
        close(30)
!! now get variance of the parameter from  fisher

	open(unit=20, file='derivatives2.txt')

	do i = 1, lmax, 1

		write(20,*) cl(i,1),(dlnl2Cldlogl2(DBLE(i),ya,y2a)),logl2Cl(dble(i)),&
        (dlnl2Cldlogl2(DBLE(i),yTE,yTE2))/(cl(i-1,1)**2*cl(i-1,4)),logl2Cl_pol(dble(i)),(dlnl2Cldlogl2(DBLE(i),y_pol,y_pol2))
	end do
	close(unit=20)

	variance=(1/fisher)

	write(*,*) 'your variance is sigma=',variance

	if (allocated(cl)) deallocate(cl, stat=err)
	if (err /= 0) print *, "array: Deallocation request denied"

	Contains

		!!! the two functions to get lnl2Cl from spline

real(DP) FUNCTION logl2Cl(ak)
  IMPLICIT none
  real(dp) :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=a*ya(jlo)+b*ya(jlo+1)+((a**3-a)*y2a(jlo)+(b**3-b)*y2a(jlo+1))*(h**2)/6.
  logl2Cl = y
  100 return
END FUNCTION logl2Cl

	real(DP) FUNCTION logl2Cl_pol(ak)
  IMPLICIT none
  real(dp) :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=a*y_pol(jlo)+b*y_pol(jlo+1)+((a**3-a)*y_pol2(jlo)+(b**3-b)*y_pol2(jlo+1))*(h**2)/6.
  logl2Cl_pol = y
  100 return
END FUNCTION logl2Cl_pol

DOUBLE PRECISION FUNCTION dlnl2Cldlogl(ak)
  IMPLICIT none
  DOUBLE PRECISION :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=(ya(jlo+1)-ya(jlo))/h+(-(3.*a**2-1.)*y2a(jlo)+(3.*b**2-1.)*y2a(jlo+1))*h/6.
  dlnl2Cldlogl = y
  return
	END FUNCTION dlnl2Cldlogl

DOUBLE PRECISION FUNCTION dlnl2Cldlogl2(ak,ya,ya2)
  IMPLICIT none
  DOUBLE PRECISION :: a,b,h,x,y,ak
  Double precision, dimension(:)::ya2,ya
  x  =  log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=(ya(jlo+1)-ya(jlo))/h+(-(3.*a**2-1.)*ya2(jlo)+(3.*b**2-1.)*ya2(jlo+1))*h/6.
  dlnl2Cldlogl2 = y
  return
END FUNCTION dlnl2Cldlogl2

 FUNCTION M33DET (A) RESULT (DET)

      IMPLICIT NONE

      DOUBLE PRECISION, INTENT(IN)  :: A(:,:)

      DOUBLE PRECISION :: DET

if (size(A).ne.9) then
         write(*,*) 'Dimension of the matrix- function do not agree'
         STOP
      END IF

      DET =   A(1,1)*A(2,2)*A(3,3)  &
            - A(1,1)*A(2,3)*A(3,2)  &
            - A(1,2)*A(2,1)*A(3,3)  &
            + A(1,2)*A(2,3)*A(3,1)  &
            + A(1,3)*A(2,1)*A(3,2)  &
            - A(1,3)*A(2,2)*A(3,1)

      RETURN

      END FUNCTION M33DET

SUBROUTINE M33INV (A, AINV, OK_FLAG)

      IMPLICIT NONE

      DOUBLE PRECISION, INTENT(IN)  :: A(:,:)
      DOUBLE PRECISION, INTENT(OUT)  :: AINV(:,:)
      LOGICAL, INTENT(OUT) :: OK_FLAG

      DOUBLE PRECISION, PARAMETER :: EPS = 1.0D-50
      DOUBLE PRECISION :: DET
      DOUBLE PRECISION, DIMENSION(3,3) :: COFACTOR

      if (size(A).ne.9) then
         write(*,*) 'Dimension of the matrix- function do not agree'
           STOP
        END IF

      DET =   A(1,1)*A(2,2)*A(3,3)  &
            - A(1,1)*A(2,3)*A(3,2)  &
            - A(1,2)*A(2,1)*A(3,3)  &
            + A(1,2)*A(2,3)*A(3,1)  &
            + A(1,3)*A(2,1)*A(3,2)  &
            - A(1,3)*A(2,2)*A(3,1)
write(*,*) 'det', det
      IF (ABS(DET) .LE. EPS) THEN
         AINV = 0.0D0
         OK_FLAG = .FALSE.
         RETURN
      END IF

      COFACTOR(1,1) = +(A(2,2)*A(3,3)-A(2,3)*A(3,2))
      COFACTOR(1,2) = -(A(2,1)*A(3,3)-A(2,3)*A(3,1))
      COFACTOR(1,3) = +(A(2,1)*A(3,2)-A(2,2)*A(3,1))
      COFACTOR(2,1) = -(A(1,2)*A(3,3)-A(1,3)*A(3,2))
      COFACTOR(2,2) = +(A(1,1)*A(3,3)-A(1,3)*A(3,1))
      COFACTOR(2,3) = -(A(1,1)*A(3,2)-A(1,2)*A(3,1))
      COFACTOR(3,1) = +(A(1,2)*A(2,3)-A(1,3)*A(2,2))
      COFACTOR(3,2) = -(A(1,1)*A(2,3)-A(1,3)*A(2,1))
      COFACTOR(3,3) = +(A(1,1)*A(2,2)-A(1,2)*A(2,1))

      AINV = TRANSPOSE(COFACTOR) / DET

      OK_FLAG = .TRUE.

      RETURN

      END SUBROUTINE M33INV

	end program fisher_estimate


program logistic_map
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    integer, parameter :: nr_x_values = 100, nr_r_values = 200, nr_iterations = 10000
    real, parameter :: x_min = 0.0_DP, x_max = 1.0_DP, &
                       r_min = 0.5_DP, r_max = 4.0_DP
    real(kind=DP), dimension(nr_x_values, nr_r_values) :: X, R, result
    real :: delta_x, delta_r
    integer :: i, j

    ! initialize X
    delta_x = (x_max - x_min)/nr_x_values
    X(:, 1) = [ (x_min + i*delta_x, i=1, nr_x_values) ]
    do i = 2, nr_r_values
        X(:, i) = X(:, 1)
    end do

    ! initialize R
    delta_r = (r_max - r_min)/nr_r_values
    R(1, :) = [ (r_min + i*delta_r, i=1, nr_r_values) ]
    do i = 2, nr_x_values
        R(i, :) = R(1, :)
    end do

    ! compute result
    result = iterate_map(X, R, nr_iterations)
    do i = 1, nr_x_values
        do j = 1, nr_r_values
            print *, R(i, j), result(i, j)
        end do
    end do

contains

    elemental function iterate_map(x0, r, nr_steps) result(xn)
        implicit none
        real(kind=DP), value :: x0, r
        integer, value :: nr_steps
        real(kind=DP) :: xn
        integer :: i

        xn = x0
        do i = 1, nr_steps
            xn = r*xn*(1.0_DP - xn)
        end do
    end function iterate_map

end program logistic_map


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

    implicit none
    real*8, parameter  :: mu_w = 1d0
    real*8, parameter  :: sig_w = 0.0d0
    integer, parameter :: n_w = 5

    real*8, parameter  :: mu_R = 1.22d0
    real*8, parameter  :: sig_R = 0.0d0
    integer, parameter :: n_R = 5

    real*8, parameter  :: beta = 1d0
    real*8, parameter  :: gamma = 0.5d0
    real*8, parameter  :: egam = 1d0-1d0/gamma

    real*8 :: w(1:n_w), weight_w(1:n_w)
    real*8 :: R(1:n_r), weight_R(1:n_r), hga
    real*8 :: a(3,n_w,n_r), c(3,n_w,n_r,n_r)
    real*8 :: wag(3,n_w,n_R,n_R), inc(3,n_w,n_R,n_R), sav(3,n_w,n_R,n_R)

contains

    ! utility function of the household
    function utility(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: utility
        real*8 :: prob
        integer :: iw, ir2, ir3, ic

        ! savings
        a(1,:,:) = 0d0
        a(2,:,:) = x(1)
        ic = 2
        do iw = 1, n_w
            do ir2 = 1, n_R
                a(3, iw, ir2) = x(ic)
                ic = ic+1
            enddo
        enddo

        ! consumption
        c(1,:,:,:) = mu_w - a(2,1,1)
        do iw = 1, n_w
            do ir2 = 1, n_R
                c(2,iw,ir2,:) = R(ir2)*a(2,1,1) + w(iw) - a(3,iw,ir2)
                do ir3 = 1, n_R
                    c(3,iw,ir2,ir3) = R(ir3)*a(3,iw,ir2)
                enddo
            enddo
        enddo
        c = max(c, 1d-10)

        ! expected utility of periods 2 and 3
        utility = 0d0
        do iw = 1, n_w
            do ir2 = 1, n_R
                do ir3 = 1, n_R
                    prob = weight_w(iw)*weight_R(ir2)*weight_R(ir3)
                    utility = utility+prob*(c(2,iw,ir2,1)**egam + &
                              beta*c(3,iw,ir2,ir3)**egam)
                enddo
            enddo
        enddo
        utility = -(c(1,1,1,1)**egam + beta*utility)/egam

    end function

    ! calculates the expected value of x
    function E(x)

        implicit none
        real*8, intent(in) :: x(:,:,:)
        real*8 :: E
        integer :: iw, ir2, ir3

        ! calculate expected value
        E = 0d0
        do iw = 1, n_w
            do ir2 = 1, n_R
                do ir3 = 1, n_R
                    E = E + x(iw, ir2, ir3)*weight_w(iw)*weight_R(ir2)*weight_R(ir3)
                enddo
            enddo
        enddo

    end function

    ! calculates the standard deviation of x
    function Std(x)

        implicit none
        real*8, intent(in) :: x(:,:,:)
        real*8 :: Std
        real*8 :: E
        integer :: iw, ir2, ir3

        ! calculate expected value
        E = 0d0
        do iw = 1, n_w
            do ir2 = 1, n_R
                do ir3 = 1, n_R
                    E = E + x(iw, ir2, ir3)*weight_w(iw)*weight_R(ir2)*weight_R(ir3)
                enddo
            enddo
        enddo

        ! calculate standard deviation
        Std = 0d0
        do iw = 1, n_w
            do ir2 = 1, n_R
                do ir3 = 1, n_R
                    Std = Std + x(iw, ir2, ir3)**2*weight_w(iw)*weight_R(ir2)*weight_R(ir3)
                enddo
            enddo
        enddo
        Std = sqrt(max(Std-E**2, 0d0))

    end function

end module


module inputs
!Inputs to the program.

implicit none

	!m_1(2) = Mass of nucleon 1(2) in MeV
	real(8), parameter, public :: m_1 = 938.926d0
	real(8), parameter, public :: m_2 = 938.926d0

	!q = |q|.
	!T = Isospin. The value is 0 or 1
	real(8), parameter, public :: q = 306.42d0
	integer, parameter, public :: T = 0

	!Pcm = One half the CM momentum.
	!k_fermi_1 and k_fermi_2 = Fermi momentum in fm^(-1) for nucleon 1 and 2.
	!Q_pauli = 0 for medium and 1 for free space.
	real(8), parameter, public :: Pcm = q
	real(8), parameter, public :: k_fermi_1 = 1.4d0
	real(8), parameter, public :: k_fermi_2 = 1.4d0
	real(8), parameter, public :: Q_pauli = 1.0d0

	!n_V_avg = Nodes/weights for phi integrated potential over [0,2pi].
	!n_0_2q,n_2q_inf = Nodes/weights for [0,inf] integral. The interval is split into [0,2q] and [2q,inf].
	!**MAKE SURE n_0_2q IS EVEN**
	!n_theta_k = Nodes/weights for [0,pi] integral
	integer, parameter, public :: n_V_avg = 20
	integer, parameter, public :: n_0_2q = 2
	integer, parameter, public :: n_2q_inf = 2
	integer, parameter, public :: n_theta_k = 2

	!cutoff0_inf = Value for infinity i.e. the [2q,infinity] integral. Used for ^0T isospin = 0.
	!cutoff_inf = Value for infinity i.e. the [2q,infinity] integral. Used on all the others.
	real(8), parameter, public :: cutoff0_inf = 20000.0d0
	real(8), parameter, public :: cutoff_inf = 2000.0d0

end module


*DECK TQLRAT
      SUBROUTINE TQLRAT (N, D, E2, IERR)
C***BEGIN PROLOGUE  TQLRAT
C***PURPOSE  Compute the eigenvalues of symmetric tridiagonal matrix
C            using a rational variant of the QL method.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (TQLRAT-S)
C***KEYWORDS  EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK,
C             QL METHOD
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TQLRAT.
C
C     This subroutine finds the eigenvalues of a SYMMETRIC
C     TRIDIAGONAL matrix by the rational QL method.
C
C     On Input
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E2 contains the squares of the subdiagonal elements of the
C          symmetric tridiagonal matrix in its last N-1 positions.
C          E2(1) is arbitrary.  E2 is a one-dimensional REAL array,
C          dimensioned E2(N).
C
C      On Output
C
C        D contains the eigenvalues in ascending order.  If an
C          error exit is made, the eigenvalues are correct and
C          ordered for indices 1, 2, ..., IERR-1, but may not be
C          the smallest eigenvalues.
C
C        E2 has been destroyed.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C               C. H. Reinsch, Eigenvalues of a real, symmetric, tri-
C                 diagonal matrix, Algorithm 464, Communications of the
C                 ACM 16, 11 (November 1973), pp. 689.
C***ROUTINES CALLED  PYTHAG, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  TQLRAT
C
      INTEGER I,J,L,M,N,II,L1,MML,IERR
      REAL D(*),E2(*)
      REAL B,C,F,G,H,P,R,S,MACHEP
      REAL PYTHAG
      LOGICAL FIRST
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  TQLRAT
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0E0
      B = 0.0E0
      E2(N) = 0.0E0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (ABS(D(L)) + SQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0E0 * S)
         R = PYTHAG(P,1.0E0)
         D(L) = S / (P + SIGN(R,P))
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     .......... RATIONAL QL TRANSFORMATION ..........
         G = D(M)
         IF (G .EQ. 0.0E0) G = B
         H = G
         S = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0E0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
         IF (H .EQ. 0.0E0) GO TO 210
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0E0) GO TO 130
  210    P = D(L) + F
C     .......... ORDER EIGENVALUES ..........
         IF (L .EQ. 1) GO TO 250
C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END


!>----------------------------------------
!! Simple program to test and time sorting routines
!!
!! Generates n random numbers, uses heap_sort to sort them,
!!  Then tests that the sort succeeded and prints timing info
!!
!! Next this is repeated for quick_sort.
!!
!! Initial data show that this implementation of quick_sort is ~2x faster than
!!  the (somewhat naive) implementation of heap_sort
!!
!!----------------------------------------
program test_qm
    use quantile_mapping
    use data_structures
    use basic_stats_mod

    implicit none
    logical :: verbose
    integer*8, parameter :: n = 10000
    real, parameter :: acceptable_error = 1 ! 1e-3 <- use this with more QM segments and train on the complete dataset

    real, allocatable, dimension(:) :: input_data, matching_data

    allocate(input_data(n))
    allocate(matching_data(n))

    verbose = read_verbosity()

    !-------------------------------
    ! SETUP input data
    !-------------------------------
    call random_number(input_data)

    ! first test a simple gain and offset
    call random_number(matching_data)
    matching_data = matching_data * 10 + 3
    call test_mapping(input_data, matching_data, "Gain + Offset")

    ! test a negative gain and offset
    call random_number(matching_data)
    matching_data = (matching_data * (-3)) - 3
    call test_mapping(input_data, matching_data, "Negative Values")

    ! Then test a fourth root transformation
    call random_number(matching_data)
    matching_data = sqrt(sqrt(matching_data)) * 2 + 3.14159
    call test_mapping(input_data, matching_data, "Double sqrt")

    ! Finally test a twentieth power transformation
    call random_number(matching_data)
    matching_data = (matching_data+1) ** 20
    call test_mapping(input_data, matching_data, "To The Twentieth")

contains

    function read_verbosity() result(verbosity)
        implicit none

        integer :: i, count, j
        character(len=1024) :: arg
        logical :: verbosity

        verbosity = .False.
        count = command_argument_count()
        if (count>0) then
            do j=1,count
                call get_command_argument(j, arg)

                if (len_trim(arg)>0) then
                    do i=1,len_trim(arg)
                        if (i<=len("verbose")) then
                            if (arg(i:i)=="verbose"(i:i)) then
                                verbosity = .True.
                            else
                                verbosity = .False.
                            endif
                        else
                            verbosity = .False.
                        endif
                    end do
                endif
                if (verbosity) exit
            end do
        endif
    end function read_verbosity

    subroutine test_mapping(input_data, matching_data, name)
        implicit none
        real, intent(in), dimension(:) :: input_data, matching_data
        character(len=*), intent(in) :: name

        real, allocatable, dimension(:) :: output_data
        integer :: i, start_time, end_time, COUNT_RATE, COUNT_MAX
        integer*8 :: n

        type(qm_correction_type) :: qm

        n = size(matching_data)
        allocate(output_data(n))

        print*, ""
        print*, ""
        print*, "---------------------------"
        print*, trim(name)
        if (verbose) then
            print*, "Input:",sum(input_data)/size(input_data)
            print*, "   min/max",minval(input_data),maxval(input_data)
            print*, "To match:",sum(matching_data)/n
            print*, "   min/max",minval(matching_data),maxval(matching_data)
            print*, "---------------------------"
            if (n < 20) then
                print*, input_data
                print*, "---------------------------"
                print*, matching_data
                print*, "---------------------------"
            endif
        endif

        call system_clock(start_time)
        !-------------------------------
        ! Develop the Quantile mapping
        !-------------------------------
        call develop_qm(input_data(1:size(input_data) / 2), matching_data, qm, &
                        min(300, min(size(input_data) / 2, size(matching_data) / 2)))

        call system_clock(end_time, COUNT_RATE, COUNT_MAX)
        if (start_time>end_time) end_time=end_time+COUNT_MAX
        if (verbose) then
            print*, "Develop_qm timing", (end_time-start_time) / real(COUNT_RATE)
        endif

        !-------------------------------
        ! Now test the quantile mapping
        !-------------------------------
        call system_clock(start_time)
        call apply_qm(input_data, output_data, qm)

        call system_clock(end_time, COUNT_RATE, COUNT_MAX)
        if (start_time>end_time) end_time=end_time+COUNT_MAX

        call show_results(output_data, matching_data, name, &
                          (end_time-start_time) / real(COUNT_RATE))
    end subroutine test_mapping

    subroutine pass_fail(error, name)
        implicit none
        real, intent(in) :: error
        character(len=*), intent(in) :: name

        if (abs(error) < acceptable_error) then
            print*, trim(name), " PASSED"
        else
            print*, trim(name), " FAILED!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
        endif

    end subroutine pass_fail

    !>--------------------------
    !! Print out results from a given sort test
    !!
    !!--------------------------
    subroutine show_results(qmdata, original, name, time)
        implicit none
        real, dimension(:), intent(in) :: qmdata, original
        character(len=*),   intent(in) :: name
        real,               intent(in) :: time
        real :: qm_data_stat, original_stat, error
        integer :: i, n, err

        n = size(qmdata)

        qm_data_stat = sum(qmdata)/n
        original_stat = sum(original)/size(original)
        error = 100.0 * (original_stat - qm_data_stat) / original_stat

        if (verbose) then
            print*, "---------------------------"
            print*, trim(name)
            print*, "Q-Mapped Mean = ",qm_data_stat, "Original Mean = ",original_stat
            print*, "   Error % = ", error
        endif
        call pass_fail(error, "  Mean:")

        qm_data_stat = stddev(qmdata, mean_in=qm_data_stat)
        original_stat = stddev(original, mean_in=original_stat)
        error = 100.0 * (original_stat - qm_data_stat) / original_stat

        if (verbose) then
            print*, "Q-Mapped Stddev = ",qm_data_stat, "Original stddev = ",original_stat
            print*, "   Error % = ", error
            print*, "---------------------------"
            print*, "Q-Mapped Min/Max = ",minval(qmdata),   maxval(qmdata)
            print*, "Original Min/Max = ",minval(original), maxval(original)
            print*, "---------------------------"
            if (n < 20) then
                print*, qmdata
                print*, "---------------------------"
            endif
            print*, "   Elapsed time = ", time
        endif
        call pass_fail(error, "  Stddev:")

    end subroutine show_results

end program test_qm


      program hello
          integer i, s
          s = 0
          do 10 i = 1, 999
              if ((MOD(i,3) .EQ. 0) .OR. (MOD(i,5) .EQ. 0)) then
                  s = s + i
              endif
10        continue
          write(*,*) '',s
      end program hello


c=======================================================================
c
c     subroutine PRbinomial
c
c     This function produces values and greeks of European and American
c     puts and calls following the Cox, Ross, Rubinstein binomial model.
c
c-----------------------------------------------------------------------
      SUBROUTINE PRbinomial(spot, strike, vol, rd, rf, tau, phi, ea,
     &                      convention, quotation, greek, N, crr, info)
c-----------------------------------------------------------------------
c
c INPUT
c   spot   : spot price (>0)                                      double
c   strike : stike price (>0)                                     double
c   vol    : annual volatility (>=0)                              double
c   rd     : domestic risk free rate (>=0)                        double
c            discounting is done as (1+r)^{-T}\n
c   rf     : foreign risk free rate or dividend rate (>=0)        double
c            discounting is done as (1+rf)^{-T}\n
c   tau    : time to maturity (in year)                           double
c   phi    : (1) Call, (-1) Put                                  integer
c   ea     : tree order (=1 or =2)                               integer
c   convention : compounded convention                           integer
c                (0) linear for less than one year,
c                (1) annually compounded,
c                (2) continuously compounded
c   quotation  : system of quotation                             integer
c                (0) domestic,
c                (1) %domestic,
c                (2) foreign,
c                (3) %foreign
c   greek      : type of result                                  integer
c                (0) option pricing,
c                (1) spot delta,
c                (2) gamma,
c                (3) annual theta,
c                (4) vega,
c                (5) rho domestic,
c                (6) rho foreign,
c                (7) derivative wrt strike,
c                (8) second derivative wrt strike, ...
c                (9) duration or derivative wrt to T(time to expiration) = - annual theta, ...
c                (10) leverage = spot * spotdelta / value,
c                (11) vomma or second derivative wrt vol
c   N          : step of the binomial trees                     integer
c
c OUTPUT
c   crr        : result of CRR binomial model                    double
c   info       : diagnostic argument                            integer
c
c----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER phi, ea, convention, quotation, greek, N, info
      DOUBLE PRECISION spot, strike, vol, rd, rf, tau, crr
c
c     external functions
      DOUBLE PRECISION PRCRR
      EXTERNAL PRCRR
c
c
c----------------------------------------------------------------------
c
c     initialization
      info = 0
      crr  = 0
c
c     call
      crr = PRCRR(spot, strike, vol, rd, rf, tau, phi, ea, convention,
     &            quotation, greek, N)
c
      RETURN
      END


      SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
*     ..
*     .. Array Arguments ..
      REAL               AB( LDAB, * )
*     ..
*
*  Purpose
*  =======
*
*  SPBSTF computes a split Cholesky factorization of a real
*  symmetric positive definite band matrix A.
*
*  This routine is designed to be used in conjunction with SSBGST.
*
*  The factorization has the form  A = S**T*S  where S is a band matrix
*  of the same bandwidth as A and the following structure:
*
*    S = ( U    )
*        ( M  L )
*
*  where U is upper triangular of order m = (n+kd)/2, and L is lower
*  triangular of order n-m.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input/output) REAL array, dimension (LDAB,N)
*          On entry, the upper or lower triangle of the symmetric band
*          matrix A, stored in the first kd+1 rows of the array.  The
*          j-th column of A is stored in the j-th column of the array AB
*          as follows:
*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*
*          On exit, if INFO = 0, the factor S from the split Cholesky
*          factorization A = S**T*S. See Further Details.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, the factorization could not be completed,
*               because the updated element a(i,i) was negative; the
*               matrix A is not positive definite.
*
*  Further Details
*  ===============
*
*  The band storage scheme is illustrated by the following example, when
*  N = 7, KD = 2:
*
*  S = ( s11  s12  s13                     )
*      (      s22  s23  s24                )
*      (           s33  s34                )
*      (                s44                )
*      (           s53  s54  s55           )
*      (                s64  s65  s66      )
*      (                     s75  s76  s77 )
*
*  If UPLO = 'U', the array AB holds:
*
*  on entry:                          on exit:
*
*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53  s64  s75
*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76
*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
*
*  If UPLO = 'L', the array AB holds:
*
*  on entry:                          on exit:
*
*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
*  a21  a32  a43  a54  a65  a76   *   s12  s23  s34  s54  s65  s76   *
*  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *
*
*  Array elements marked * are not used by the routine.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, KLD, KM, M
      REAL               AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SSCAL, SSYR, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SPBSTF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      KLD = MAX( 1, LDAB-1 )
*
*     Set the splitting point m.
*
      M = ( N+KD ) / 2
*
      IF( UPPER ) THEN
*
*        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
*
         DO 10 J = N, M + 1, -1
*
*           Compute s(j,j) and test for non-positive-definiteness.
*
            AJJ = AB( KD+1, J )
            IF( AJJ.LE.ZERO )
     $         GO TO 50
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
            KM = MIN( J-1, KD )
*
*           Compute elements j-km:j-1 of the j-th column and update the
*           the leading submatrix within the band.
*
            CALL SSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
            CALL SSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
     $                 AB( KD+1, J-KM ), KLD )
   10    CONTINUE
*
*        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
*
         DO 20 J = 1, M
*
*           Compute s(j,j) and test for non-positive-definiteness.
*
            AJJ = AB( KD+1, J )
            IF( AJJ.LE.ZERO )
     $         GO TO 50
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
            KM = MIN( KD, M-J )
*
*           Compute elements j+1:j+km of the j-th row and update the
*           trailing submatrix within the band.
*
            IF( KM.GT.0 ) THEN
               CALL SSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
               CALL SSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
     $                    AB( KD+1, J+1 ), KLD )
            END IF
   20    CONTINUE
      ELSE
*
*        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
*
         DO 30 J = N, M + 1, -1
*
*           Compute s(j,j) and test for non-positive-definiteness.
*
            AJJ = AB( 1, J )
            IF( AJJ.LE.ZERO )
     $         GO TO 50
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
            KM = MIN( J-1, KD )
*
*           Compute elements j-km:j-1 of the j-th row and update the
*           trailing submatrix within the band.
*
            CALL SSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
            CALL SSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
     $                 AB( 1, J-KM ), KLD )
   30    CONTINUE
*
*        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
*
         DO 40 J = 1, M
*
*           Compute s(j,j) and test for non-positive-definiteness.
*
            AJJ = AB( 1, J )
            IF( AJJ.LE.ZERO )
     $         GO TO 50
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
            KM = MIN( KD, M-J )
*
*           Compute elements j+1:j+km of the j-th column and update the
*           trailing submatrix within the band.
*
            IF( KM.GT.0 ) THEN
               CALL SSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
               CALL SSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
     $                    AB( 1, J+1 ), KLD )
            END IF
   40    CONTINUE
      END IF
      RETURN
*
   50 CONTINUE
      INFO = J
      RETURN
*
*     End of SPBSTF
*
      END


      PROGRAM drddasl4
c>> 2008-10-29 DRDDASL4 Krogh Fixed print output for C.
c>> 2008-10-26 DRDDASL4 Krogh Changed Fortran 90 type statement to F77.
c>> 2008-10-26 DRDDASL4 Krogh Moved Format statements up for C conv.
c>> 2008-10-24 DRDDASL4 Krogh Removed in INCLUDE statement & cDEC$...
c>> 2008-09-17 DRDDASL4 Hanson added starting values for y'
c>> 2008-08-26 DRDDASL4 Hanson added row dimension to evaluator
c>> 2001-10-11 DRDDASL4  R. J. Hanson Example 4 Code, with Download

c     Solve Enright and Pryce stiff test problem E5.
c     The equation is presented as y'= F(t,y), y_0 given.
c     This is solved by defining the residual function
c     f(t,y,y')=F(t,y)-y'.  Variational equations, with respect
c     to model parameters b0,b1,b2,b3, and b4, are integrated together
c     with state equations.  The block structure of the linear algebra
c     solve step is used.  The first NSTATE are state equations,
c     and the remaining blocks are for the variational equations.

c     Reverse communication is used for the evaluation and
c     linear solve steps.

c--D replaces "?": DR?DASL4, ?DASLX, ?DASSF4, ?COPY, ?GEFA, ?GESL, ?DOT
      INTEGER nstate,nvareq,neq,nepoch
      PARAMETER  (nstate=4,nvareq=5)
c     Set number of equations:
      PARAMETER  (neq=nstate+nvareq*nstate)
c     Set number of constraints.
      INTEGER maxcon
      PARAMETER  (maxcon=0)
c     Work space sizes:
      INTEGER liw
      PARAMETER  (liw=30+neq)
c.....The work space does not need the NEQ**2-size additional
c.....array piece because linear algebra is done in user work space.
c     This is flagged by INFO(5)=-6.
      INTEGER lrw
      PARAMETER  (lrw=45+(5+2*maxcon+4)*neq)
      PARAMETER  (nepoch=10)
      INTEGER i,j,k,l,info(16),idid,ires,ier,iwork(liw),ipvt(nstate),
     & ival(3)

      DOUBLE PRECISION t,y(neq),yprime(neq),rtol(neq),atol(neq),
     & rwork(lrw),tout(nepoch),b0,b1,b2,b3,b4,ddot,cj

      INTEGER ndig
      DOUBLE PRECISION tol
c++S Default NDIG = 3
c++  Default NDIG = 8
c++ Substitute for NDIG below
      PARAMETER  (ndig=8)
      PARAMETER  (tol=10.d0**(-ndig))

      EXTERNAL ddassf4

      DOUBLE PRECISION delta(nstate),gy(nstate,nstate),
     & gp(nstate,nvareq),yp(nstate,nvareq),ypp(nstate,nvareq),
     & d(nstate,nstate)

  120 FORMAT (20x,'Example Results for a Stiff ODE Problem, E5.'/16x,
     & 'Five additional variational equations are integrated.'//10x,
     & 'T',12x,'y_1',11x,'y_2',11x,'y_3',11x,'y_4')
  130 FORMAT (13x,'No. of Residual Evaluations',6x,'Factorizations',6x,
     & 'No. of User Solves'/'Reverse Communication-',i9,15x,i9,13x,i9/)

c     Tolerances:
      DO 10 i=1,nstate
        atol(i)=tol
        rtol(i)=tol
   10 CONTINUE
c  Put more emphasis on relative error for the variational equations.
c  (How to set these tolerances depends on the problem.)
      DO 20 i=nstate+1,neq
        atol(i)=0
        rtol(i)=tol
   20 CONTINUE

c     Setup options:
      DO 30 i=1,16
        info(i)=0
   30 CONTINUE

c     Use partial derivatives and reverse communication
c     Do the linear algebra ourselves
      info(5)=-6

c     Set output points for integration:
      tout(1)=0.d0
      tout(2)=1.d-3
      DO 40 i=3,nepoch
        tout(i)=10*tout(i-1)
   40 CONTINUE
c     Have reverse communiation for f, and partials,
c     solver, and storage of partials.
      b0=1.76d-03
      b1=7.89d-10
      b2=1.1d+07
      b3=1.13d+09
      b4=1.13d+03
c     Set initial conditions for state and variational equations:
      y(1)=0.d0
      yprime(1)=0.d0
      CALL dcopy (neq, y, 0, y, 1)
      CALL dcopy (neq, yprime, 0, yprime, 1)
      y(1)=b0
      y(nstate+1)=1.d0

c     Set the initial value of YPRIME(*):
      yprime(1)=-b1*b0
      yprime(2)=b1*b0
      yprime(3)=b1*b0

      yprime(nstate+1)=-b1
      yprime(nstate+2)=b1
      yprime(nstate+3)=b1

      yprime(2*nstate+1)=-b0
      yprime(2*nstate+2)=b0
      yprime(2*nstate+3)=b0
c     Count residuals, factorizations and solves.
      ival(1)=0
      ival(2)=0
      ival(3)=0
c     Print heading.
      WRITE (*,120)
c     Allow more than nominal number of steps.
      info(12)=5000
      DO 110 L=2,nepoch
        t=tout(L-1)
c     Branch here to re-enter routine.
   50   CALL ddaslx (ddassf4, neq, t, y, yprime, tout(L), info, rtol,
     &   atol, idid, rwork, lrw, iwork, liw)
c     When IDID == 4 the code returned for reverse communication.
c     Otherwise the integration has finished up to this output point.
        IF (idid.ne.4) GO TO 100
c     Get flag for user action:
        ires=iwork(3)

c     Will need partials for IRES=1,2:
        IF (ires.le.2) THEN
          gy(1,1)=0.d0
          gp(1,1)=0.d0
          CALL dcopy (nstate**2, gy, 0, gy, 1)
          CALL dcopy (nstate*nvareq, gp, 0, gp, 1)

c     Evaluate DG/DY matrix:

          gy(4,1)=b2*y(3)
          gy(1,1)=-b1-gy(4,1)
          gy(2,1)=b1
          gy(3,1)=b1-gy(4,1)

          gy(1,2)=0.d0
          gy(3,2)=-b3*y(3)
          gy(2,2)=gy(3,2)
          gy(4,2)=0.d0

          gy(1,3)=-b2*y(1)
          gy(2,3)=-b3*y(2)
          gy(3,3)= gy(1,3)+gy(2,3)
          gy(4,3)=-gy(1,3)

          gy(1,4)=0.d0
          gy(2,4)=0.d0
          gy(3,4)= b4
          gy(4,4)=-b4

c     Evaluate DG/DP matrix:
          gp(1,2)=-y(1)
          gp(2,2)= y(1)
          gp(3,2)= y(1)

          gp(1,3)=-y(1)*y(3)
          gp(3,3)=-y(1)*y(3)

          gp(2,4)=-y(2)*y(3)
          gp(3,4)= y(2)*y(3)

          gp(3,5)= y(4)
          gp(4,5)=-y(4)

c     Extract DY/DP:
          CALL dcopy (nstate*nvareq, y(nstate+1), 1, yp, 1)
c     Extract (DY/DP)':
          CALL dcopy (nstate*nvareq, yprime(nstate+1), 1, ypp, 1)
        END IF

c     Evaluate state and variational equations.
        IF (ires.eq.1) THEN
c     Count residual evaluations.
          ival(1)=ival(1)+1
          delta(1)=-b1*y(1)-b2*y(1)*y(3)-yprime(1)
          delta(2)= b1*y(1)-b3*y(2)*y(3)-yprime(2)
          delta(3)= b1*y(1)-b2*y(1)*y(3)+b4*y(4)-b3*y(2)*y(3)-yprime(3)
          delta(4)= b2*y(1)*y(3)-b4*y(4)-yprime(4)

c     Compute matrix arithmetic, DG/DY * DY/DP + DG/DP:
c     Update DG/DP = DG/DP - D (Y')/DP:
          DO 70 j=1,nvareq
            DO 60 i=1,nstate
              gp(i,j)=gp(i,j)+ddot(nstate,gy(i,1),nstate,yp(1,j),1)-
     &         ypp(i,j)
   60       CONTINUE
   70     CONTINUE
c     Move the results where the integrator uses them:
          CALL dcopy (nstate, delta, 1, rwork(iwork(4)), 1)
          CALL dcopy (nstate*nvareq, gp, 1, rwork(iwork(4)+nstate), 1)
          GO TO 50

        END IF

        IF (ires.eq.2) THEN
c     Evaluate partial matrix, DG/DY-C*I_4.
c     Each of the NSTATE vectors has this
c     matrix as a diagonal block.  The C value
c     is located in RWORK(1).
c     There are NVAREQ+1 such vectors.
c     Taking advantage of this fact allows the
c     corrector equation to be factored and solved
c     using a system of size equal to the number of
c     state vector components.
          CALL dcopy (nstate**2, gy, 1, d, 1)
          cj=rwork(1)
          DO 80 i=1,nstate
            d(i,i)=d(i,i)-cj
   80     CONTINUE
c     Factor the 4 by 4 matrix using the Linpack code.
c     Count factorizations.
          ival(2)=ival(2)+1
c     This is where savings occur, compared to solving a full system.
          CALL dgefa (d, nstate, nstate, ipvt, ier)
c     This passes the error code, after factorization,
c     back to the integrator.
          iwork(3)=ier
          GO TO 50
        END IF
c     Solve with NVAREQ+1 right-hand sides using the Linpack code.
c     This is where savings occur, compared to solving a full system.
        IF (ires.eq.4) THEN
c     Count solves.
          ival(3)=ival(3)+1
c     Index to place solutions of corrector equations.
          k=iwork(4)
          DO 90 j=1,nvareq+1
            CALL dgesl (d, nstate, nstate, ipvt, rwork(k), 0)
            k=k+nstate
   90     CONTINUE

          GO TO 50
        END IF
  100   CONTINUE
c     Print time, state and variational equation results.
c%% printf("%14.4e%14.4e%14.4e%14.4e%14.4e\n",
c%%   Tout[l], y[0], y[1], y[2], y[3]);
c%% for(_n=4L; _n < sizeof(y)/sizeof(double); _n+=4)
c%%   printf("              %14.4e%14.4e%14.4e%14.4e\n",
c%%     y[_n], y[_n+1], y[_n+2], y[_n+3]);
        WRITE (*,'(1P,5D14.4/(14x,4D14.4))') tout(L),y
  110 CONTINUE
      WRITE (*,130) ival
      END

      SUBROUTINE ddassf4 (t, y, yprime, delta, d, ldd, cj, ires, rwork,
     & iwork)

c     Dummy routine for reverse communication:
c     This is a double precision version.
      DOUBLE PRECISION t,y(*),yprime(*),delta(*),d(ldd,*),cj,rwork(*)
      INTEGER ires,iwork(*),ldd

c     This is the setup call.  It can be ignored since
c     all problem information is provided using reverse communication.
      IF (ires.eq.0) THEN
        RETURN
      END IF
c     Other values of IRES will not occur.
      END


      SUBROUTINE DPTTRF( N, D, E, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  DPTTRF computes the factorization of a real symmetric positive
*  definite tridiagonal matrix A.
*
*  If the subdiagonal elements of A are supplied in the array E, the
*  factorization has the form A = L*D*L**T, where D is diagonal and L
*  is unit lower bidiagonal; if the superdiagonal elements of A are
*  supplied, it has the form A = U**T*D*U, where U is unit upper
*  bidiagonal.  (The two forms are equivalent if A is real.)
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the n diagonal elements of the tridiagonal matrix
*          A.  On exit, the n diagonal elements of the diagonal matrix
*          D from the L*D*L**T factorization of A.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, the (n-1) off-diagonal elements of the tridiagonal
*          matrix A.
*          On exit, the (n-1) off-diagonal elements of the unit
*          bidiagonal factor L or U from the factorization of A.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the leading minor of order i is not
*                positive definite; if i < N, the factorization could
*                not be completed, while if i = N, the factorization was
*                completed, but D(N) = 0.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   DI, EI
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DPTTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Compute the L*D*L' (or U'*D*U) factorization of A.
*
      DO 10 I = 1, N - 1
*
*        Drop out of the loop if d(i) <= 0: the matrix is not positive
*        definite.
*
         DI = D( I )
         IF( DI.LE.ZERO )
     $      GO TO 20
*
*        Solve for e(i) and d(i+1).
*
         EI = E( I )
         E( I ) = EI / DI
         D( I+1 ) = D( I+1 ) - E( I )*EI
   10 CONTINUE
*
*     Check d(n) for positive definiteness.
*
      I = N
      IF( D( I ).GT.ZERO )
     $   GO TO 30
*
   20 CONTINUE
      INFO = I
*
   30 CONTINUE
      RETURN
*
*     End of DPTTRF
*
      END
      SUBROUTINE SPTTRF( N, D, E, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  SPTTRF computes the factorization of a real symmetric positive
*  definite tridiagonal matrix A.
*
*  If the subdiagonal elements of A are supplied in the array E, the
*  factorization has the form A = L*D*L**T, where D is diagonal and L
*  is unit lower bidiagonal; if the superdiagonal elements of A are
*  supplied, it has the form A = U**T*D*U, where U is unit upper
*  bidiagonal.  (The two forms are equivalent if A is real.)
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  D       (input/output) REAL array, dimension (N)
*          On entry, the n diagonal elements of the tridiagonal matrix
*          A.  On exit, the n diagonal elements of the diagonal matrix
*          D from the L*D*L**T factorization of A.
*
*  E       (input/output) REAL array, dimension (N-1)
*          On entry, the (n-1) off-diagonal elements of the tridiagonal
*          matrix A.
*          On exit, the (n-1) off-diagonal elements of the unit
*          bidiagonal factor L or U from the factorization of A.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the leading minor of order i is not
*                positive definite; if i < N, the factorization could
*                not be completed, while if i = N, the factorization was
*                completed, but D(N) = 0.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               DI, EI
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'SPTTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Compute the L*D*L' (or U'*D*U) factorization of A.
*
      DO 10 I = 1, N - 1
*
*        Drop out of the loop if d(i) <= 0: the matrix is not positive
*        definite.
*
         DI = D( I )
         IF( DI.LE.ZERO )
     $      GO TO 20
*
*        Solve for e(i) and d(i+1).
*
         EI = E( I )
         E( I ) = EI / DI
         D( I+1 ) = D( I+1 ) - E( I )*EI
   10 CONTINUE
*
*     Check d(n) for positive definiteness.
*
      I = N
      IF( D( I ).GT.ZERO )
     $   GO TO 30
*
   20 CONTINUE
      INFO = I
*
   30 CONTINUE
      RETURN
*
*     End of SPTTRF
*
      END


! ---------------------- BEGIN QROMB SUITE ------------------------
      SUBROUTINE qromb(func,a,b,ss)
      INTEGER JMAX,JMAXP,K,KM
      REAL a,b,func,ss,EPS
      EXTERNAL func
      PARAMETER (EPS=1.e-6, JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1)
!U    USES polint,trapzd
      INTEGER j
      REAL dss,h(JMAXP),s(JMAXP)
      h(1)=1.
      do 11 j=1,JMAX
        call trapzd(func,a,b,s(j),j)
        if (j.ge.K) then
          call polint(h(j-KM),s(j-KM),K,0.,ss,dss)
          if (abs(dss).le.EPS*abs(ss)) return
        endif
        s(j+1)=s(j)
        h(j+1)=0.25*h(j)
11    continue
      call error(' Too many steps in qromb') ! mod. by RBH
      END

      SUBROUTINE trapzd(func,a,b,s,n)
      INTEGER n
      REAL a,b,s,func
      EXTERNAL func
      INTEGER it,j
      REAL del,sum,tnm,x
      if (n.eq.1) then
        s=0.5*(b-a)*(func(a)+func(b))
      else
        it=2**(n-2)
        tnm=it
        del=(b-a)/tnm
        x=a+0.5*del
        sum=0.
        do 11 j=1,it
          sum=sum+func(x)
          x=x+del
11      continue
        s=0.5*(s+(b-a)*sum/tnm)
      endif
      return
      END

      SUBROUTINE polint(xa,ya,n,x,y,dy)
      INTEGER n,NMAX
      REAL dy,x,y,xa(n),ya(n)
      PARAMETER (NMAX=10)
      INTEGER i,m,ns
      REAL den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
      ns=1
      dif=abs(x-xa(1))
      do 11 i=1,n
        dift=abs(x-xa(i))
        if (dift.lt.dif) then
          ns=i
          dif=dift
        endif
        c(i)=ya(i)
        d(i)=ya(i)
11    continue
      y=ya(ns)
      ns=ns-1
      do 13 m=1,n-1
        do 12 i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          if(den.eq.0.)call error(' denominator = 0 in polint') ! mod. by RBH
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
12      continue
        if (2*ns.lt.n-m)then
          dy=c(ns+1)
        else
          dy=d(ns)
          ns=ns-1
        endif
        y=y+dy
13    continue
      return
      END

      subroutine error(str)
!-----
!	RBH code (3/99)
!-----
      character str*(*)
      write(6,*)str
      stop
      end
! ----------------------- END QROMB SUITE ---------------

!----------------- BEGIN QMIDPNT -----------------------------
      SUBROUTINE qmidpnt(func,a,b,s)
!Dates: 02/09/00 - latest version of qtrap, with midpnt substituted for trapzd
      INTEGER JMAX
      REAL a,b,func,s,EPS
      EXTERNAL func
      PARAMETER (EPS=1.e-6, JMAX=12)
!U    USES midpnt
      INTEGER j
      REAL olds
      olds=-1.e30
      do j=1,JMAX
        call midpnt(func,a,b,s,j)
        if (j.gt.5) then
          if (abs(s-olds).lt.EPS*abs(olds).or.(s.eq.0..and.olds.eq.0.))
     *          return
        endif
        olds=s
      end do
      call error(' too many steps in qmidpnt')
      END
!----------------- END QMIDPNT -----------------------------

!----------------- BEGIN MIDPNT -----------------------------
      SUBROUTINE midpnt(func,a,b,s,n)
      INTEGER n
      REAL a,b,s,func
      EXTERNAL func
      INTEGER it,j
      REAL ddel,del,sum,tnm,x
      if (n.eq.1) then
        s=(b-a)*func(0.5*(a+b))
      else
        it=3**(n-2)
        tnm=it
        del=(b-a)/(3.*tnm)
        ddel=del+del
        x=a+0.5*del
        sum=0.
        do 11 j=1,it
          sum=sum+func(x)
          x=x+ddel
          sum=sum+func(x)
          x=x+del
11      continue
        s=(s+(b-a)*sum/tnm)/3.
      endif
      return
      END
!----------------- END MIDPNT -----------------------------

! --------------------------- BEGIN LOCATE ------------------
      SUBROUTINE locate(xx,n,x,j)
      INTEGER j,n
      REAL x,xx(n)
      INTEGER jl,jm,ju
      jl=0
      ju=n+1
10    if(ju-jl.gt.1)then
        jm=(ju+jl)/2
        if((xx(n).ge.xx(1)).eqv.(x.ge.xx(jm)))then
          jl=jm
        else
          ju=jm
        endif
      goto 10
      endif
      if(x.eq.xx(1))then
        j=1
      else if(x.eq.xx(n))then
        j=n-1
      else
        j=jl
      endif
      return
      END
! --------------------------- END LOCATE ------------------

      SUBROUTINE odeint(ystart,nvar,x1,x2,eps,h1,hmin,nok,nbad,derivs)

!  6/01/95 - D. Boore removed rkqs from the list of calling arguments
!            and from the external statement.
!  2/09/03 - Set kmax = 0

      INTEGER nbad,nok,nvar,KMAXX,MAXSTP,NMAX
      REAL eps,h1,hmin,x1,x2,ystart(nvar),TINY
      EXTERNAL derivs
      PARAMETER (MAXSTP=10000,NMAX=50,KMAXX=200,TINY=1.e-30)
      INTEGER i,kmax,kount,nstp
      REAL dxsav,h,hdid,hnext,x,xsav,dydx(NMAX),xp(KMAXX),y(NMAX),
     *yp(NMAX,KMAXX),yscal(NMAX)
      COMMON /path/ kmax,kount,dxsav,xp,yp
      x=x1
      h=sign(h1,x2-x1)
      nok=0
      nbad=0
      kount=0
      kmax = 0
      do 11 i=1,nvar
        y(i)=ystart(i)
11    continue
      if (kmax.gt.0) xsav=x-2.*dxsav
      do 16 nstp=1,MAXSTP
        call derivs(x,y,dydx)
        do 12 i=1,nvar
          yscal(i)=abs(y(i))+abs(h*dydx(i))+TINY
12      continue
        if(kmax.gt.0)then
          if(abs(x-xsav).gt.abs(dxsav)) then
            if(kount.lt.kmax-1)then
              kount=kount+1
              xp(kount)=x
              do 13 i=1,nvar
                yp(i,kount)=y(i)
13            continue
              xsav=x
            endif
          endif
        endif
        if((x+h-x2)*(x+h-x1).gt.0.) h=x2-x
        call rkqs(y,dydx,nvar,x,h,eps,yscal,hdid,hnext,derivs)
        if(hdid.eq.h)then
          nok=nok+1
        else
          nbad=nbad+1
        endif
        if((x-x2)*(x2-x1).ge.0.)then
          do 14 i=1,nvar
            ystart(i)=y(i)
14        continue
          if(kmax.ne.0)then
            kount=kount+1
            xp(kount)=x
            do 15 i=1,nvar
              yp(i,kount)=y(i)
15          continue
          endif
          return
        endif
        if(abs(hnext).lt.hmin)
     :    call error(' stepsize smaller than minimum in odeint')
        h=hnext
16    continue
      call error(' too many steps in odeint')
      return
      END
! --------------- END ODEINT ---------------------------------

! --------------- BEGIN RKQS ---------------------------------
      SUBROUTINE rkqs(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)
      INTEGER n,NMAX
      REAL eps,hdid,hnext,htry,x,dydx(n),y(n),yscal(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
!U    USES derivs,rkck
      INTEGER i
      REAL errmax,h,htemp,xnew,yerr(NMAX),ytemp(NMAX),SAFETY,PGROW,
     *PSHRNK,ERRCON
      PARAMETER (SAFETY=0.9,PGROW=-.2,PSHRNK=-.25,ERRCON=1.89e-4)
      h=htry
1     call rkck(y,dydx,n,x,h,ytemp,yerr,derivs)
      errmax=0.
      do 11 i=1,n
        errmax=max(errmax,abs(yerr(i)/yscal(i)))
11    continue
      errmax=errmax/eps
      if(errmax.gt.1.)then
        htemp=SAFETY*h*(errmax**PSHRNK)
        h=sign(max(abs(htemp),0.1*abs(h)),h)
        xnew=x+h
        if(xnew.eq.x) call error(' stepsize underflow in rkqs')
        goto 1
      else
        if(errmax.gt.ERRCON)then
          hnext=SAFETY*h*(errmax**PGROW)
        else
          hnext=5.*h
        endif
        hdid=h
        x=x+h
        do 12 i=1,n
          y(i)=ytemp(i)
12      continue
        return
      endif
      END
! --------------- END RKQS ---------------------------------

! --------------- BEGIN RKCK ---------------------------------
      SUBROUTINE rkck(y,dydx,n,x,h,yout,yerr,derivs)
      INTEGER n,NMAX
      REAL h,x,dydx(n),y(n),yerr(n),yout(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
!U    USES derivs
      INTEGER i
      REAL ak2(NMAX),ak3(NMAX),ak4(NMAX),ak5(NMAX),ak6(NMAX),
     *ytemp(NMAX),A2,A3,A4,A5,A6,B21,B31,B32,B41,B42,B43,B51,B52,B53,
     *B54,B61,B62,B63,B64,B65,C1,C3,C4,C6,DC1,DC3,DC4,DC5,DC6
      PARAMETER (A2=.2,A3=.3,A4=.6,A5=1.,A6=.875,B21=.2,B31=3./40.,
     *B32=9./40.,B41=.3,B42=-.9,B43=1.2,B51=-11./54.,B52=2.5,
     *B53=-70./27.,B54=35./27.,B61=1631./55296.,B62=175./512.,
     *B63=575./13824.,B64=44275./110592.,B65=253./4096.,C1=37./378.,
     *C3=250./621.,C4=125./594.,C6=512./1771.,DC1=C1-2825./27648.,
     *DC3=C3-18575./48384.,DC4=C4-13525./55296.,DC5=-277./14336.,
     *DC6=C6-.25)
      do 11 i=1,n
        ytemp(i)=y(i)+B21*h*dydx(i)
11    continue
      call derivs(x+A2*h,ytemp,ak2)
      do 12 i=1,n
        ytemp(i)=y(i)+h*(B31*dydx(i)+B32*ak2(i))
12    continue
      call derivs(x+A3*h,ytemp,ak3)
      do 13 i=1,n
        ytemp(i)=y(i)+h*(B41*dydx(i)+B42*ak2(i)+B43*ak3(i))
13    continue
      call derivs(x+A4*h,ytemp,ak4)
      do 14 i=1,n
        ytemp(i)=y(i)+h*(B51*dydx(i)+B52*ak2(i)+B53*ak3(i)+B54*ak4(i))
14    continue
      call derivs(x+A5*h,ytemp,ak5)
      do 15 i=1,n
        ytemp(i)=y(i)+h*(B61*dydx(i)+B62*ak2(i)+B63*ak3(i)+B64*ak4(i)+
     *B65*ak5(i))
15    continue
      call derivs(x+A6*h,ytemp,ak6)
      do 16 i=1,n
        yout(i)=y(i)+h*(C1*dydx(i)+C3*ak3(i)+C4*ak4(i)+C6*ak6(i))
16    continue
      do 17 i=1,n
        yerr(i)=h*(DC1*dydx(i)+DC3*ak3(i)+DC4*ak4(i)+DC5*ak5(i)+DC6*
     *ak6(i))
17    continue
      return
      END
! --------------- END RKCK ---------------------------------

!  ------------------- BEGIN GASDEV --------------------------
      FUNCTION gasdev(idum)
      INTEGER idum
      REAL gasdev
!U    USES ran1
      INTEGER iset
      REAL fac,gset,rsq,v1,v2,ran1
      SAVE iset,gset
      DATA iset/0/
      if (idum.lt.0) iset=0
      if (iset.eq.0) then
1       v1=2.*ran1(idum)-1.
        v2=2.*ran1(idum)-1.
        rsq=v1**2+v2**2
        if(rsq.ge.1..or.rsq.eq.0.)goto 1
        fac=sqrt(-2.*log(rsq)/rsq)
        gset=v1*fac
        gasdev=v2*fac
        iset=1
      else
        gasdev=gset
        iset=0
      endif
      return
      END
!  ------------------- END GASDEV --------------------------

!  ------------------- BEGIN RAN1 --------------------------
      FUNCTION ran1(idum)
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      REAL ran1,AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,
     *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
      INTEGER j,k,iv(NTAB),iy
      SAVE iv,iy
      DATA iv /NTAB*0/, iy /0/
      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran1=min(AM*iy,RNMX)
      return
      END
!  ------------------- END RAN1 --------------------------

!  ------------------- BEGIN REALFT --------------------------
      SUBROUTINE realft(data,n,isign)
      INTEGER isign,n
      REAL data(n)
!U    USES four1
      INTEGER i,i1,i2,i3,i4,n2p3
      REAL c1,c2,h1i,h1r,h2i,h2r,wis,wrs
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      theta=3.141592653589793d0/dble(n/2)
      c1=0.5
      if (isign.eq.1) then
        c2=-0.5
        call four1(data,n/2,+1)
      else
        c2=0.5
        theta=-theta
      endif
      wpr=-2.0d0*sin(0.5d0*theta)**2
      wpi=sin(theta)
      wr=1.0d0+wpr
      wi=wpi
      n2p3=n+3
      do 11 i=2,n/4
        i1=2*i-1
        i2=i1+1
        i3=n2p3-i2
        i4=i3+1
        wrs=sngl(wr)
        wis=sngl(wi)
        h1r=c1*(data(i1)+data(i3))
        h1i=c1*(data(i2)-data(i4))
        h2r=-c2*(data(i2)+data(i4))
        h2i=c2*(data(i1)-data(i3))
        data(i1)=h1r+wrs*h2r-wis*h2i
        data(i2)=h1i+wrs*h2i+wis*h2r
        data(i3)=h1r-wrs*h2r+wis*h2i
        data(i4)=-h1i+wrs*h2i+wis*h2r
        wtemp=wr
        wr=wr*wpr-wi*wpi+wr
        wi=wi*wpr+wtemp*wpi+wi
11    continue
      if (isign.eq.1) then
        h1r=data(1)
        data(1)=h1r+data(2)
        data(2)=h1r-data(2)
      else
        h1r=data(1)
        data(1)=c1*(h1r+data(2))
        data(2)=c1*(h1r-data(2))
        call four1(data,n/2,-1)
      endif
      return
      END
!  ------------------- END REALFT --------------------------

!  ------------------- BEGIN FOUR1 --------------------------
      SUBROUTINE four1(data,nn,isign)
      INTEGER isign,nn
      REAL data(2*nn)
      INTEGER i,istep,j,m,mmax,n
      REAL tempi,tempr
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      n=2*nn
      j=1
      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        goto 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      goto 2
      endif
      return
      END
!  ------------------- END FOUR1 --------------------------

! ------------------ BEGIN SORT --------------------------
      SUBROUTINE sort(n,arr)
      INTEGER n,M,NSTACK
      REAL arr(n)
      PARAMETER (M=7,NSTACK=50)
      INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
      REAL a,temp
      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do 12 j=l+1,ir
          a=arr(j)
          do 11 i=j-1,l,-1
            if(arr(i).le.a)goto 2
            arr(i+1)=arr(i)
11        continue
          i=l-1
2         arr(i+1)=a
12      continue
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        temp=arr(k)
        arr(k)=arr(l+1)
        arr(l+1)=temp
        if(arr(l).gt.arr(ir))then
          temp=arr(l)
          arr(l)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l+1).gt.arr(ir))then
          temp=arr(l+1)
          arr(l+1)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l).gt.arr(l+1))then
          temp=arr(l)
          arr(l)=arr(l+1)
          arr(l+1)=temp
        endif
        i=l+1
        j=ir
        a=arr(l+1)
3       continue
          i=i+1
        if(arr(i).lt.a)goto 3
4       continue
          j=j-1
        if(arr(j).gt.a)goto 4
        if(j.lt.i)goto 5
        temp=arr(i)
        arr(i)=arr(j)
        arr(j)=temp
        goto 3
5       arr(l+1)=arr(j)
        arr(j)=a
        jstack=jstack+2

!        if(jstack.gt.NSTACK)pause 'NSTACK too small in sort'  ! replaced with code below on 11/02/12
                                                               ! because "pause" produced a compile error
                                                               ! with the Unix Fortran compiler
        if(jstack.gt.NSTACK) then
          print *,' NSTACK too small in sort; QUIT!!!'
          stop
        end if

        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      END
! ------------------ END SORT --------------------------


subroutine bsplvb ( t, jhigh, index, x, left, biatx )

!*****************************************************************************80
!
!! BSPLVB evaluates B-splines at a point X with a given knot sequence.
!
!  Discusion:
!
!    BSPLVB evaluates all possibly nonzero B-splines at X of order
!
!      JOUT = MAX ( JHIGH, (J+1)*(INDEX-1) )
!
!    with knot sequence T.
!
!    The recurrence relation
!
!                     X - T(I)               T(I+J+1) - X
!    B(I,J+1)(X) = ----------- * B(I,J)(X) + --------------- * B(I+1,J)(X)
!                  T(I+J)-T(I)               T(I+J+1)-T(I+1)
!
!    is used to generate B(LEFT-J:LEFT,J+1)(X) from B(LEFT-J+1:LEFT,J)(X)
!    storing the new values in BIATX over the old.
!
!    The facts that
!
!      B(I,1)(X) = 1  if  T(I) <= X < T(I+1)
!
!    and that
!
!      B(I,J)(X) = 0  unless  T(I) <= X < T(I+J)
!
!    are used.
!
!    The particular organization of the calculations follows
!    algorithm 8 in chapter X of the text.
!
!  Modified:
!
!    14 February 2007
!
!  Author:
!
!    Carl DeBoor
!
!  Reference:
!
!    Carl DeBoor,
!    A Practical Guide to Splines,
!    Springer, 2001,
!    ISBN: 0387953663.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) T(LEFT+JOUT), the knot sequence.  T is assumed to
!    be nondecreasing, and also, T(LEFT) must be strictly less than
!    T(LEFT+1).
!
!    Input, integer JHIGH, INDEX, determine the order
!    JOUT = max ( JHIGH, (J+1)*(INDEX-1) )
!    of the B-splines whose values at X are to be returned.
!    INDEX is used to avoid recalculations when several
!    columns of the triangular array of B-spline values are
!    needed, for example, in BVALUE or in BSPLVD.
!    If INDEX = 1, the calculation starts from scratch and the entire
!    triangular array of B-spline values of orders
!    1, 2, ...,JHIGH is generated order by order, that is,
!    column by column.
!    If INDEX = 2, only the B-spline values of order J+1, J+2, ..., JOUT
!    are generated, the assumption being that BIATX, J,
!    DELTAL, DELTAR are, on entry, as they were on exit
!    at the previous call.  In particular, if JHIGH = 0,
!    then JOUT = J+1, that is, just the next column of B-spline
!    values is generated.
!    Warning: the restriction  JOUT <= JMAX (= 20) is
!    imposed arbitrarily by the dimension statement for DELTAL
!    and DELTAR, but is nowhere checked for.
!
!    Input, real ( kind = 8 ) X, the point at which the B-splines
!    are to be evaluated.
!
!    Input, integer LEFT, an integer chosen so that
!    T(LEFT) <= X <= T(LEFT+1).
!
!    Output, real ( kind = 8 ) BIATX(JOUT), with BIATX(I) containing the
!    value at X of the polynomial of order JOUT which agrees
!    with the B-spline B(LEFT-JOUT+I,JOUT,T) on the interval
!    (T(LEFT),T(LEFT+1)).
!
  implicit none

  integer, parameter :: jmax = 20

  integer jhigh

  real ( kind = 8 ) biatx(jhigh)
  real ( kind = 8 ), save, dimension ( jmax ) :: deltal
  real ( kind = 8 ), save, dimension ( jmax ) :: deltar
  integer i
  integer index
  !integer, save :: j = 1
  integer :: j
  integer left
  real ( kind = 8 ) saved
  real ( kind = 8 ) t(left+jhigh)
  real ( kind = 8 ) term
  real ( kind = 8 ) x

  if ( index == 1 ) then
    j = 1
    biatx(1) = 1.0D+00
    if ( jhigh <= j ) then
      return
    end if
  end if

  if ( t(left+1) <= t(left) ) then
    print*,'x=',x
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BSPLVB - Fatal error!'
    write ( *, '(a)' ) '  It is required that T(LEFT) < T(LEFT+1).'
    write ( *, '(a,i8)' ) '  But LEFT = ', left
    write ( *, '(a,g14.6)' ) '  T(LEFT) =   ', t(left)
    write ( *, '(a,g14.6)' ) '  T(LEFT+1) = ', t(left+1)
    stop
  end if

!  do
  do j = 1, jhigh - 1

    deltar(j) = t(left+j) - x
    deltal(j) = x - t(left+1-j)

    saved = 0.0D+00
    do i = 1, j
      term = biatx(i) / ( deltar(i) + deltal(j+1-i) )
      biatx(i) = saved + deltar(i) * term
      saved = deltal(j+1-i) * term
    end do

    biatx(j+1) = saved
!    j = j + 1

 !   if ( jhigh <= j ) then
 !     exit
 !   end if

  end do

  return
end subroutine bsplvb


program coerce
use,intrinsic:: iso_fortran_env, stderr=>error_unit
implicit none (type, external)

real(real32) :: four32 = 2._real32 * 2._real32, four32coerce = 2*2
real(real64) :: four64 = 2._real64 * 2._real64, four64coerce = 2*2
real(real128) :: four128 = 2._real128 * 2._real128, four128coerce = 2*2

print *,compiler_version()

if (four32 /= four32coerce) then
  write(stderr,*) 'expected real32 did not coerce: ', four32coerce
  error stop
endif
print *,'real(real32) = 4: ', four32coerce

if (four64 /= four64coerce) then
  write(stderr,*) 'expected real64 did not coerce: ', four64coerce
  error stop
endif
print *,'real(real64) = 4: ', four64coerce

if (four128 /= four128coerce) then
  write(stderr,*) 'expected real128 did not coerce: ', four128coerce
  error stop
endif
print *,'real(real128) = 4: ', four128coerce

!> what about through procedures

if (4*atan(1._real64) /= 4._real64 * atan(1._real64)) error stop 'function coerce'

if (2._real32 * 2._real64 /= 4._real64) error stop 'multiply upscale coerce'
!! this does not equal if value is float like 2.1_real32 * 2.1_real64

if (4._real64 / 2 /= 2._real64) error stop 'divide coerce'

end program


 !--------------------------------------------------------------------------
 !                            INPOLY
 !   Function to tell if a point is inside a polygon or not.
 !--------------------------------------------------------------------------
 !   Copyright (c) 1995-1996 Galacticomm, Inc.  Freeware source code.
 !
 !   Please feel free to use this source code for any purpose, commercial
 !   or otherwise, as long as you don't restrict anyone else's use of
 !   this source code.  Please give credit where credit is due.
 !
 !   Point-in-polygon algorithm, created especially for World-Wide Web
 !   servers to process image maps with mouse-clickable regions.
 !
 !   Home for this file:  http://www.gcomm.com/develop/inpoly.c
 !
 !                                       6/19/95 - Bob Stein & Craig Yap
 !                                       stein@gcomm.com
 !                                       craig@cse.fau.edu
 !--------------------------------------------------------------------------
 !   Modified by:
 !   Aris Gerakis, apr. 1998: 1.  translated to Fortran
 !                            2.  made it work with real coordinates
 !                            3.  now resolves the case where point falls
 !                                on polygon border.
 !   Aris Gerakis, nov. 1998: Fixed error caused by hardware arithmetic
 !   Aris Gerakis, july 1999: Now all borderline cases are valid
 !--------------------------------------------------------------------------
 !   Glossary:
 !   function inpoly: true=inside, false=outside (is target point inside
 !                    a 2D polygon?)
 !   poly(*,2):  polygon points, [0]=x, [1]=y
 !   npoints: number of points in polygon
 !   xt: x (horizontal) of target point
 !   yt: y (vertical) of target point
 !--------------------------------------------------------------------------

logical function inpoly (poly, npoints, xt, yt)

implicit none

! Declare arguments:

integer :: npoints
real    :: poly(7, 2), xt, yt

! Declare local variables:

real    :: xnew, ynew, xold, yold, x1, y1, x2, y2
integer :: i
logical :: inside, on_border

inside = .false.
on_border = .false.

if (npoints < 3)  then
  inpoly = .false.
  return
end if

xold = poly(npoints,1)
yold = poly(npoints,2)

do i = 1 , npoints
  xnew = poly(i,1)
  ynew = poly(i,2)

  if (xnew > xold)  then
    x1 = xold
    x2 = xnew
    y1 = yold
    y2 = ynew
  else
    x1 = xnew
    x2 = xold
    y1 = ynew
    y2 = yold
  end if

  ! The outer IF is the 'straddle' test and the 'vertical border' test.
  ! The inner IF is the 'non-vertical border' test and the 'north' test.

  ! The first statement checks whether a north pointing vector crosses
  ! (stradles) the straight segment.  There are two possibilities, depe-
  ! nding on whether xnew < xold or xnew > xold.  The '<' is because edge
  ! must be "open" at left, which is necessary to keep correct count when
  ! vector 'licks' a vertix of a polygon.

  if ((xnew < xt .and. xt <= xold) .or. (.not. xnew < xt .and. &
     .not. xt <= xold)) then
    ! The test point lies on a non-vertical border:
    if ((yt-y1)*(x2-x1) == (y2-y1)*(xt-x1)) then
      on_border = .true.
    ! Check if segment is north of test point.  If yes, reverse the
    ! value of INSIDE.  The +0.001 was necessary to avoid errors due
    ! arithmetic (e.g., when clay = 98.87 and sand = 1.13):
    elseif ((yt-y1)*(x2-x1) < (y2-y1)*(xt-x1) + 0.001) then
      inside = .not.inside ! cross a segment
    endif
  ! This is the rare case when test point falls on vertical border or
  ! left edge of non-vertical border. The left x-coordinate must be
  ! common.  The slope requirement must be met, but also point must be
  ! between the lower and upper y-coordinate of border segment.  There
  ! are two possibilities,  depending on whether ynew < yold or ynew >
  ! yold:
  elseif ((xnew == xt .or. xold == xt) .and. (yt-y1)*(x2-x1) == &
    (y2-y1)*(xt-x1) .and. ((ynew <= yt .and. yt <= yold) .or. &
    (.not. ynew < yt .and. .not. yt < yold))) then
    on_border = .true.
  endif

  xold = xnew
  yold = ynew

enddo

! If test point is not on a border, the function result is the last state
! of INSIDE variable.  Otherwise, INSIDE doesn't matter.  The point is
! inside the polygon if it falls on any of its borders:

if (.not. on_border) then
   inpoly = inside
else
   inpoly = .true.
endif

return

end function inpoly


      PROGRAM TEST
      USE FMZM
      USE FM_DOUBLE_INT
      USE FM_QUAD_INT
      USE FM_QUAD_REAL

      IMPLICIT NONE

!  This program illustrates the use of the three modules for using FM, IM, or ZM variables
!  with double and quadruple length integer and real variables supplied by the compiler.

!  These would be needed for cases where the user's program uses all three precisions,
!  single, double, quad.  Then using a compiler switch to automatically make 64-bits the
!  default would not work.

!  The variables used to select the kind of integers and floating-point real and complex
!  numbers to be used, DOUBLE_INT, QUAD_INT, and QUAD_FP, are defined in the three modules.

      INTEGER ::               J, J1, J2
      INTEGER (DOUBLE_INT) ::  K, K1, K2
      INTEGER (QUAD_INT) ::    L, L1, L2

      REAL ::                  A1, A2
      REAL (KIND(1.0D0)) ::    B1, B2
      REAL (QUAD_FP) ::        C1, C2

      COMPLEX ::               R1, R2
      COMPLEX (KIND(1.0D0)) :: S1, S2
      COMPLEX (QUAD_FP) ::     T1, T2

      TYPE(FM) ::              F1, REL_ERROR
      TYPE(ZM) ::              Z1, Z2

!             For a simple example calculation, sum several pieces of the harmonic series,
!             1/n + 1/(n+1) + ... + 1/(n+10**5).

!             n = 10**2  for single precision,
!             n = 10**13 for double precision,
!             n = 10**29 for quad precision.

!             In each case, use type(fm) to get a more accurate sum and compute the relative
!             error for the other sum.

      J1 = 10**2
      J2 = J1 + 10**5
      A1 = 0
      F1 = 0
      DO J = J1, J2
         A2 = J
         A1 = A1 + 1/A2

         F1 = F1 + 1/TO_FM(J)
      ENDDO
      REL_ERROR = ABS( (F1-A1)/F1 )
      WRITE (*,"(/A,ES15.7/)") ' Relative error for the single precision real sum = ',  &
                               TO_QUAD(REL_ERROR)

      K1 = 10_DOUBLE_INT**13
      K2 = K1 + 10**5
      B1 = 0
      F1 = 0
      DO K = K1, K2
         B2 = K
         B1 = B1 + 1/B2

         F1 = F1 + 1/TO_FM(K)
      ENDDO
      REL_ERROR = ABS( (F1-B1)/F1 )
      WRITE (*,"(/A,ES15.7/)") ' Relative error for the double precision real sum = ',  &
                               TO_QUAD(REL_ERROR)

      L1 = 10_QUAD_INT**29
      L2 = L1 + 10**5
      C1 = 0
      F1 = 0
      DO L = L1, L2
         C2 = L
         C1 = C1 + 1/C2

         F1 = F1 + 1/TO_FM(L)
      ENDDO
      REL_ERROR = ABS( (F1-C1)/F1 )
      WRITE (*,"(/A,ES15.7/)") ' Relative error for the quad precision real sum   = ',  &
                               TO_QUAD(REL_ERROR)

!             Do a similar sum using complex numbers.
!             1/sqrt(n+i) + 1/sqrt(n+1+i) + ... + 1/sqrt(n+10**4+i).

!             n = 10**2  for single precision,
!             n = 10**13 for double precision,
!             n = 10**29 for quad precision.

!             In each case, use type(zm) to get a more accurate sum and compute the relative
!             error for the other sum.

      J1 = 10**2
      J2 = J1 + 10**4
      R1 = 0
      Z1 = 0
      Z2 = TO_ZM(' i ')
      DO J = J1, J2
         R2 = J + CMPLX(0.0, 1.0)
         R1 = R1 + 1/SQRT(R2)

         Z1 = Z1 + 1/SQRT(J+Z2)
      ENDDO
      REL_ERROR = ABS( (Z1-R1)/Z1 )
      WRITE (*,"(/A,ES15.7/)") ' Relative error for the single precision complex sum = ',  &
                               TO_QUAD(REL_ERROR)

      K1 = 10_DOUBLE_INT**13
      K2 = K1 + 10**4
      S1 = 0
      Z1 = 0
      Z2 = TO_ZM(' i ')
      DO K = K1, K2
         S2 = K + CMPLX(0.0D0, 1.0D0, KIND(1.0D0))
         S1 = S1 + 1/SQRT(S2)

         Z1 = Z1 + 1/SQRT(K+Z2)
      ENDDO
      REL_ERROR = ABS( (Z1-S1)/Z1 )
      WRITE (*,"(/A,ES15.7/)") ' Relative error for the double precision complex sum = ',  &
                               TO_QUAD(REL_ERROR)

      L1 = 10_QUAD_INT**29
      L2 = L1 + 10**4
      T1 = 0
      Z1 = 0
      Z2 = TO_ZM(' i ')
      DO L = L1, L2
         T2 = L + CMPLX(0.0_QUAD_FP, 1.0_QUAD_FP, QUAD_FP)
         T1 = T1 + 1/SQRT(T2)

         Z1 = Z1 + 1/SQRT(L+Z2)
      ENDDO
      REL_ERROR = ABS( (Z1-T1)/Z1 )
      WRITE (*,"(/A,ES15.7/)") ' Relative error for the quad precision complex sum   = ',  &
                               TO_QUAD(REL_ERROR)

      END PROGRAM TEST