      program AnimatedPendulum
**********************************************
*       Program:    Simple_Pendulum_Solver   *
*       Written_By: Brian Downing            *
*                   Fordham University       *
*       Date:       October 23rd, 1990       *
**********************************************

        Implicit None
*
*       Declare double precision variables.
*
        double precision a,g,l,t,dt,w,Pi,Theta,ThetaM
*
*       Initialize some constant values.
*
        Pi = 4.0*ATAN(1.0)
*
*       Clear screen and then prompt for real numbers for variables.
*
        Call CLS
        write(5,100)
        read*,dt

        write(5,200)
        read*,Theta

        write(5,300)
        read*,l

*
*       Initialize other variables.
*
        g  = 9.81
        ThetaM = Theta*Pi/180.0
        Theta  = ThetaM
        t  = 0.0
        w  = 0.0
        a  = (-g/l)*DSIN(Theta)
*
*       Loop until finished (angle.eq.-Theta_naught .or. omega = 0)?
*
        Call EnterGraphicsMode
        do while (.true.)
            a = (-g/l)*DSIN(Theta)
            w = w + a*dt
            Theta = Theta + w*dt
            t = t + dt
            Call PlotBall(Theta)
            if (Theta.le.(-ThetaM)) goto 10
        enddo
10      continue
*
*       Print out final results.
*
        print*,'Finished calculations.'
        write(5,20)a,w,Theta,t
*
*       Program format statements.
*
20      format(1x,'Acceleration',T15,'= ',D12.4/
     1         1x,'Omega',T15,'= ',D12.4/
     2         1x,'Theta',T15,'= ',D12.4/
     3         1x,'Time',T15,'= ',D12.4/)
100     format(1x,'Enter real number for delta time in seconds: ',$)
200     format(1x,'Enter real number for Theta in degrees: ',$)
300     format(1x,'Enter real number for Length in meters: ',$)
      Call ExitGraphicsMode
      End


module constants_mod

! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
!   Bruce Wyman
! </CONTACT>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!    Defines useful constants for Earth.
! </OVERVIEW>

! <DESCRIPTION>
!   Constants are defined as real parameters.
!   Constants are accessed through the "use" statement.
! </DESCRIPTION>

implicit none
private

character(len=128) :: version='$Id: constants.f90,v 13.0 2006/03/28 21:37:37 fms Exp $'
character(len=128) :: tagname='$Name: latest $'
!dummy variable to use in HUGE initializations
real :: realnumber

!------------ physical constants ---------------
! <DATA NAME="RADIUS" UNITS="m" TYPE="real" DEFAULT="6371.e3">
!   radius of the earth
! </DATA>
! <DATA NAME="OMEGA" UNITS="1/s" TYPE="real" DEFAULT="7.292e-5">
!   rotation rate of the planet (earth)
! </DATA>
! <DATA NAME="GRAV" UNITS="m/s^2" TYPE="real" DEFAULT="9.80">
!   acceleration due to gravity
! </DATA>
! <DATA NAME="RDGAS" UNITS="J/kg/deg" TYPE="real" DEFAULT="287.04">
!   gas constant for dry air
! </DATA>
! <DATA NAME="KAPPA" TYPE="real" DEFAULT="2./7.">
!   RDGAS / CP_AIR
! </DATA>
! <DATA NAME="CP_AIR" UNITS="J/kg/deg" TYPE="real" DEFAULT="RDGAS/KAPPA">
!   specific heat capacity of dry air at constant pressure
! </DATA>
! <DATA NAME="CP_OCEAN" UNITS="J/kg/deg" TYPE="real" DEFAULT="3989.24495292815">
!   specific heat capacity taken from McDougall (2002) "Potential Enthalpy ..."
! </DATA>
! <DATA NAME="RHO0" UNITS="kg/m^3" TYPE="real" DEFAULT="1.035e3">
!   average density of sea water
! </DATA>
! <DATA NAME="RHO0R" UNITS="m^3/kg" TYPE="real" DEFAULT="1.0/RHO0">
!   reciprocal of average density of sea water
! </DATA>
! <DATA NAME="RHO_CP" UNITS="J/m^3/deg" TYPE="real" DEFAULT="RHO0*CP_OCEAN">
!   (kg/m^3)*(cal/kg/deg C)(joules/cal) = (joules/m^3/deg C)
! </DATA>

real, public, parameter :: RADIUS = 6371.0e3
real, public, parameter :: OMEGA  = 7.292e-5
real, public, parameter :: GRAV   = 9.80
real, public, parameter :: RDGAS  = 287.04
real, public, parameter :: KAPPA  = 2./7.
real, public, parameter :: CP_AIR = RDGAS/KAPPA
real, public, parameter :: CP_OCEAN = 3989.24495292815
real, public, parameter :: RHO0    = 1.035e3
real, public, parameter :: RHO0R   = 1.0/RHO0
real, public, parameter :: RHO_CP  = RHO0*CP_OCEAN

!------------ water vapor constants ---------------
! <DATA NAME="RVGAS" UNITS="J/kg/deg" TYPE="real" DEFAULT="461.50">
!   gas constant for water vapor
! </DATA>
! <DATA NAME="CP_VAPOR" UNITS="J/kg/deg" TYPE="real" DEFAULT="4.0*RVGAS">
!   specific heat capacity of water vapor at constant pressure
! </DATA>
! <DATA NAME="DENS_H2O" UNITS="kg/m^3" TYPE="real" DEFAULT="1000.">
!   density of liquid water
! </DATA>
! <DATA NAME="HLV" UNITS="J/kg" TYPE="real" DEFAULT="2.500e6">
!   latent heat of evaporation
! </DATA>
! <DATA NAME="HLF" UNITS="J/kg" TYPE="real" DEFAULT="3.34e5">
!   latent heat of fusion
! </DATA>
! <DATA NAME="HLS" UNITS="J/kg" TYPE="real" DEFAULT="2.834e6">
!   latent heat of sublimation
! </DATA>
! <DATA NAME="TFREEZE" UNITS="degK" TYPE="real" DEFAULT="273.16">
!   temp where fresh water freezes
! </DATA>

real, public, parameter :: RVGAS = 461.50
real, public, parameter :: CP_VAPOR = 4.0*RVGAS
real, public, parameter :: DENS_H2O = 1000.
real, public, parameter :: HLV = 2.500e6
real, public, parameter :: HLF = 3.34e5
real, public, parameter :: HLS = HLV + HLF
real, public, parameter :: TFREEZE = 273.16

!-------------- radiation constants -----------------

! <DATA NAME="WTMAIR" UNITS="AMU" TYPE="real" DEFAULT="2.896440E+01">
!  molecular weight of air
! </DATA>
! <DATA NAME="WTMH2O" UNITS="AMU" TYPE="real" DEFAULT="1.801534E+01">
!  molecular weight of water
! </DATA>
! <DATA NAME="WTMO3" UNITS="AMU" TYPE="real" DEFAULT="47.99820E+01">
!   molecular weight of ozone
! </DATA>
! <DATA NAME="DIFFAC" TYPE="real" DEFAULT="1.660000E+00">
! diffusivity factor
! </DATA>
! <DATA NAME="SECONDS_PER_DAY" UNITS="seconds" TYPE="real" DEFAULT="8.640000E+04">
! seconds in a day
! </DATA>
! <DATA NAME="AVOGNO" UNITS="atoms/mole" TYPE="real" DEFAULT="6.023000E+23">
!  Avogadro's number
! </DATA>
! <DATA NAME="PSTD" UNITS="dynes/cm^2" TYPE="real" DEFAULT="1.013250E+06">
!  mean sea level pressure
! </DATA>
! <DATA NAME="PSTD_MKS" UNITS="Newtons/m^2" TYPE="real" DEFAULT="101325.0">
!  mean sea level pressure
! </DATA>

real, public, parameter :: WTMAIR = 2.896440E+01
real, public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !pjp OK to change value because not used yet.
real, public, parameter :: WTMO3  = 47.99820E+01
real, public, parameter :: DIFFAC = 1.660000E+00
real, public, parameter :: SECONDS_PER_DAY  = 8.640000E+04
real, public, parameter :: AVOGNO = 6.023000E+23
real, public, parameter :: PSTD   = 1.013250E+06
real, public, parameter :: PSTD_MKS    = 101325.0
!real, public, parameter :: REARTH  = 6.356766E+08 !pjp Not used anywhere.

! <DATA NAME="RADCON" UNITS="deg sec/(cm day)" TYPE="real" DEFAULT="((1.0E+02*GRAV)/(1.0E+04*CP_AIR))*SECONDS_PER_DAY">
!  factor used to convert flux divergence to heating rate in degrees per day
! </DATA>
! <DATA NAME="RADCON_MKS" UNITS="deg sec/(m day)" TYPE="real" DEFAULT="(GRAV/CP_AIR)*SECONDS_PER_DAY">
!  factor used to convert flux divergence to heating rate in degrees per day
! </DATA>
! <DATA NAME="O2MIXRAT" TYPE="real" DEFAULT="2.0953E-01">
! mixing ratio of molecular oxygen in air
! </DATA>
! <DATA NAME="RHOAIR" UNITS="kg/m^3" TYPE="real" DEFAULT="1.292269">
!  reference atmospheric density
! </DATA>
! <DATA NAME="ALOGMIN" TYPE="real" DEFAULT="-50.0">
!  minimum value allowed as argument to log function
! </DATA>

real, public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0E+04*CP_AIR))*SECONDS_PER_DAY
real, public, parameter :: RADCON_MKS  = (GRAV/CP_AIR)*SECONDS_PER_DAY
real, public, parameter :: O2MIXRAT    = 2.0953E-01
real, public, parameter :: RHOAIR      = 1.292269
real, public, parameter :: ALOGMIN     = -50.0

!------------ miscellaneous constants ---------------
! <DATA NAME="STEFAN" UNITS="W/m^2/deg^4" TYPE="real" DEFAULT="5.6734e-8">
!   Stefan-Boltzmann constant
! </DATA>
! <DATA NAME="VONKARM"  TYPE="real" DEFAULT="0.40">
!   Von Karman constant
! </DATA>
! <DATA NAME="PI" TYPE="real" DEFAULT="3.14159265358979323846">
!    ratio of circle circumference to diameter
! </DATA>
! <DATA NAME="RAD_TO_DEG"  TYPE="real" DEFAULT="180.0/PI">
!   degrees per radian
! </DATA>
! <DATA NAME="DEG_TO_RAD"  TYPE="real" DEFAULT="PI/180.0">
!   radians per degree
! </DATA>
! <DATA NAME="RADIAN"  TYPE="real" DEFAULT="180.0/PI">
!   equal to RAD_TO_DEG. Named RADIAN for backward compatability.
! </DATA>
! <DATA NAME="C2DBARS" UNITS="dbars" TYPE="real" DEFAULT="1.e-4">
!   converts rho*g*z (in mks) to dbars: 1dbar = 10^4 (kg/m^3)(m/s^2)m
! </DATA>
! <DATA NAME="KELVIN" TYPE="real" DEFAULT="273.15">
!   degrees Kelvin at zero Celsius
! </DATA>
! <DATA NAME="EPSLN" TYPE="real" DEFAULT="1.0e-40">
!   a small number to prevent divide by zero exceptions
! </DATA>

real, public, parameter :: STEFAN  = 5.6734e-8
real, public, parameter :: VONKARM = 0.40
real, public, parameter :: PI      = 3.14159265358979323846
real, public, parameter :: RAD_TO_DEG=180./PI
real, public, parameter :: DEG_TO_RAD=PI/180.
real, public, parameter :: RADIAN  = RAD_TO_DEG
real, public, parameter :: C2DBARS = 1.e-4
real, public, parameter :: KELVIN  = 273.15
real, public, parameter :: EPSLN   = 1.0e-40
!-----------------------------------------------------------------------
! version and tagname published
! so that write_version_number can be called for constants_mod by fms_init
public :: version, tagname
!-----------------------------------------------------------------------
public :: constants_init

contains

subroutine constants_init

! dummy routine.

end subroutine constants_init

end module constants_mod

! <INFO>

!   <FUTURE>
!   1.  Renaming of constants.
!   </FUTURE>
!   <FUTURE>
!   2.  Additional constants.
!   </FUTURE>
!   <NOTE>
!    Constants have been declared as type REAL, PARAMETER.
!
!    The value a constant can not be changed in a users program.
!    New constants can be defined in terms of values from the
!    constants module using a parameter statement.

!
!    The name given to a particular constant may be changed.

!
!    Constants can be used on the right side on an assignment statement
!    (their value can not be reassigned).
!
!
!<TESTPROGRAM NAME="EXAMPLE">
!

!    use constants_mod, only:  TFREEZE, grav_new => GRAV
!    real, parameter :: grav_inv = 1.0 / grav_new
!    tempc(:,:,:) = tempk(:,:,:) - TFREEZE
!    geopotential(:,:) = height(:,:) * grav_new
!

!</TESTPROGRAM>
!   </NOTE>

! </INFO>


module damageModelsNewLib
use funcAux

implicit none

contains

subroutine getH(H,Hder,r,damagePar)
	real*8 , intent(out) :: H, Hder
	real*8, intent(in) :: r , damagePar(:)
	integer  :: damageModel

	damageModel = nint(damagePar(2))

	select case(damageModel)

		case(1)
			call exp1Reg(H,Hder,r,damagePar)

		case(2)
			call exp2Reg(H,Hder,r,damagePar)

		case(3)
			call LinReg(H,Hder,r,damagePar)

		case(4)
			call exp3dinf(H,Hder,r,damagePar)
		case default

			H = 0.0d0

	end select

end subroutine

subroutine exp1Reg(H,Hder,r,damagePar)
	real*8 , intent(out) :: H , Hder
	real*8, intent(in) :: r , damagePar(:)
	real*8 :: r0, Gf, lmu, H0

	r0 = damagePar(3)
	Gf = damagePar(4)
	lmu = damagePar(5)

!~ 	H0 =  (0.5d0-Gf/(r0*r0*lmu))**(-1.0d0)
!~ 	write(0,*) 'H0 == ' ,  H0

	H0 =  -r0*r0*lmu/Gf

	H = H0*dexp(H0*(r- r0)/r0)

	Hder = H*(H0/r0)

end subroutine

subroutine exp2Reg(H,Hder,r,damagePar)
	real*8 , intent(out) :: H , Hder
	real*8, intent(in) :: r , damagePar(:)
	real*8 :: r0, Gf, lmu, beta

	r0 = damagePar(3)
	Gf = damagePar(4)
	lmu = damagePar(5)

	beta = 0.5*(-r0 + dsqrt((4.0d0*Gf/lmu)-r0*r0))
	write(0,*) beta

	H = dexp(-(r- r0)/beta)*(1.0d0 - r/beta)
	Hder = - dexp(-(r-r0)/beta)*(2.0d0 - r/beta)/beta

	write(0,*) r0,Gf,lmu

	pause

end subroutine

subroutine LinReg(H,Hder,r,damagePar)
	real*8 , intent(out) :: H, Hder
	real*8, intent(in) :: r , damagePar(:)
	real*8 :: r0, Gf, lmu, H0

	r0 = damagePar(3)
	Gf = damagePar(4)
	lmu = damagePar(5)

	H0 = (1.0 - 2.0*Gf/(r0*r0*lmu))**(-1.0)

	H = H0
	Hder = 0.0d0

	write(0,*) r0,Gf,lmu

	pause

end subroutine

subroutine exp3dinf(H,Hder,r,damagePar)
	real*8 , intent(out) :: H , Hder
	real*8, intent(in) :: r , damagePar(:)
	real*8 :: r0, dinf, alpha, E

	r0 = damagePar(3)
	alpha = damagePar(4)
	dinf = damagePar(5)

	E = dexp(-alpha*(r- r0)/r0)

	H = E*dinf*(1.0d0 - alpha*r/r0) + 1.0d0 - dinf

	Hder = - (alpha*E*dinf/r0)*(2.0d0 - alpha*r/r0)

	write(0,*) r0,alpha, dinf

	pause

end subroutine

end module


	FUNCTION PR_TMST  ( thte, pres, tguess )
C************************************************************************
C* PR_TMST 								*
C*									*
C* This function computes TMST from THTE, PRES, TGUESS.  TMST is the	*
C* parcel temperature at level PRES on a specified moist adiabat 	*
C* (THTE).  The computation is an iterative Newton-Raphson technique	*
C* of the form:								*
C*	                                                                *
C*   x = x(guess) + [ f( x ) - f( x(guess) ) ] / f'( x(guess) )		*
C*	                                                                *
C*     f' is approximated with finite differences			*
C*     f' = [ f( x(guess) + 1 ) - f( x(guess) ) ] / 1			*
C*	                                                                *
C* If TGUESS is 0, a reasonable first guess will be made.		*
C*									*
C* Convergence is not guaranteed for extreme input values.  If the	*
C* computation does not converge after 100 iterations, the missing	*
C* data value will be returned.						*
C*	                                                                *
C* REAL PR_TMST  ( THTE, PRES, TGUESS )                        		*
C*									*
C* Input parameters:							*
C*	THTE   		REAL		Equivalent potential temp in K	*
C*	PRES       	REAL    	Pressure in millibars		*
C*	TGUESS   	REAL    	First guess temperature in K	*
C*									*
C* Output parameters:							*
C*	PR_TMST		REAL		Parcel temperature in Kelvin	*
C**									*
C* Log:									*
C* P. Kocin		1980    Orginal source				*
C* M. Goodman/RDS	 9/84	Modified prologue			*
C* G. Huffman/GSC	 8/88	Recode (retain Newton-Raphson concept);	*
C*				use Mark Handel (MIT) first guess	*
C* M. desJardins/GSFC	 8/90	Move tguess into temp variable		*
C* M. Linda/GSC		 9/97	Corrected right border of prologue	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( thte ) .or. ERMISS ( pres )
     +	      .or. ERMISS ( tguess ) .or. ( thte .le. 0. )
     +        .or. ( pres .le. 0 ) .or. ( tguess .lt. 0. ) )  THEN
	    PR_TMST = RMISSD
	    RETURN
	END IF
C
C*	Move tguess into another variable.
C
	tg = tguess
C
C*	If TGUESS is passed as 0. it is computed from an MIT scheme.
C
	IF  ( tg .eq. 0. )  tg =
     *  	(thte - .5 * ( MAX ( thte-270., 0. ) ) ** 1.05 )
     *  		* ( pres / 1000. ) ** .2
C
C*	Set convergence and initial guess in degrees C.
C
	epsi = .01
	tgnu = PR_TMKC ( tg )
C
C*	Set a limit of 100 iterations.  Compute TENU, TENUP, the
C*	THTE's at, one degree above the guess temperature.
C
	DO  i = 1, 100
	  tgnup = tgnu + 1.
	  tenu = PR_THTE ( pres, tgnu, tgnu )
	  tenup = PR_THTE ( pres, tgnup, tgnup )
C
C*	  Check that the THTE's exist.
C
	  IF  ( ( ERMISS ( tenu ) ) .or. ( ERMISS ( tenup ) ) )  THEN
	      PR_TMST = RMISSD
	      RETURN
	  END IF
C
C*	  Compute the correction, DELTG; return on convergence.
C
	  cor  = ( thte - tenu ) / ( tenup - tenu )
	  tgnu = tgnu + cor
	  IF  ( ( cor .lt. epsi ) .and. ( -cor .lt. epsi ) )  THEN
	      PR_TMST = PR_TMCK ( tgnu )
	      RETURN
	  END IF
	END DO
C
C*	Failed to converge - return missing.
C
	PR_TMST = RMISSD
	RETURN
	END


c
c************************
c
        subroutine chdec(b,a,n,ier)

c       cholesky decomposition of real symmetric matrix; b is input
c       matrix of order n in symmetric storage mode (requires array of
c       length n*(n+1)/2 in calling routine); a is output (in same form)
c       of lower triangular matrix

        real a(*),b(*)

        ier=0

        do 30 i=1,n
        ii=(i-1)*i/2

           do 15 j=1,i-1
           jj=(j-1)*j/2
           t=b(ii+j)
           i1=ii

              do 10 k=1,j-1
              i1=i1+1
              jj=jj+1
10            t=t-a(i1)*a(jj)

15         a(ii+j)=t/a(jj+1)

        i1=ii
        t=b(ii+i)

           do 20 k=1,i-1
           i1=i1+1
20         t=t-a(i1)*a(i1)

        if(t.lt.0) then
           ier=-1
           return
           end if

30      a(ii+i)=sqrt(t)

        return
        end


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Mon Jun  3 18:07:59
!
!a=./f && make $a && OMP_NUM_THREADS=2 $a
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none f.f08 -o f
!  -7.80250048E-06         350          10
!   90.0000000              90         180         270         360
!   19.9999962              10          20          30
!
!Compilation finished at Mon Jun  3 18:07:59

program average_angles
  !real(kind=8), parameter :: TAU = 6.283185307179586232 ! http://tauday.com/
  !integer, dimension(13), parameter :: test_data = (/2,350,10, 4,90,180,270,360, 3,10,20,30, 0/)
  !integer :: i, j, n
  !complex(kind=16) :: some
  !real(kind=8) :: angle
  real, parameter :: TAU = 6.283185307179586232 ! http://tauday.com/
  integer, dimension(13), parameter :: test_data = (/2,350,10, 4,90,180,270,360, 3,10,20,30, 0/)
  integer :: i, j, n
  complex :: some
  real :: angle
  i = 1
  n = int(test_data(i))
  do while (0 .lt. n)
    some = 0
    do j = 1, n
      angle = (TAU/360)*test_data(i+j)
      some = some + cmplx(cos(angle), sin(angle))
    end do
    some = some / n
    write(6,*)(360/TAU)*atan2(aimag(some), real(some)),test_data(i+1:i+n)
    i = i + n + 1
    n = int(test_data(i))
  end do
end program average_angles


!********************************************************************************
!   UNITY: Compare FPML against Polzers and AMVW on roots of unity.
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 11 Novemeber 2018
!********************************************************************************
! The speed and accuracy of FPML is compared against Polzeros and AMVW for
! computing the roots of unity via the polynomial z^n-1.
!********************************************************************************
program unity
    use fpml
    use poly_zeroes
    implicit none
    ! read in variables
    character(len=32)                           :: arg
    integer                                     :: flag, startDegree, endDegree, itnum
    ! testing variables
    integer                                     :: deg, it, j, clock_rate, clock_start, clock_stop
    real(kind=dp), parameter                    :: pi = 3.141592653589793_dp
    real(kind=dp), dimension(:,:), allocatable  :: results
    complex(kind=dp), dimension(:), allocatable :: exact_roots
    ! FPML variables
    integer, parameter                          :: nitmax=30
    integer, dimension(:), allocatable          :: conv
    real(kind=dp), dimension(:), allocatable    :: berr, cond
    complex(kind=dp), dimension(:), allocatable :: p, roots
    ! Polzeros variables
    integer                                     :: iter
    logical, dimension(:), allocatable          :: h
    real(kind=dp), dimension(:), allocatable    :: radius
    complex(kind=dp), dimension(:), allocatable :: zeros
    ! AMVW variables
    real(kind=dp), dimension(:), allocatable    :: residuals
    complex(kind=dp), dimension(:), allocatable :: coeffs, eigs

    ! read in optional arguments
    call get_command_argument(1,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') startDegree
    else
        startDegree=80
    end if
    call get_command_argument(2,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') endDegree
    else
        endDegree=5120
    end if
    call get_command_argument(3,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') itnum
    else
        itnum=128
    end if

    ! Testing: roots of unity
    open(unit=1,file="data_files/unity.dat")
    write(1,'(A)') 'Degree, FPML_time, FPML_err, Polzeros_time, Polzeros_err, AMVW_time, AMVW_err'
    allocate(results(itnum,6))
    deg=startDegree
    do while(deg<=endDegree)
        write(1,'(I10)', advance='no') deg
        write(1,'(A)', advance='no') ','
        allocate(exact_roots(deg))
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
        allocate(zeros(deg), radius(deg), h(deg+1))
        allocate(coeffs(deg+1), eigs(deg), residuals(deg))
        ! polynomial and roots
        p(1) = -1.0_dp
        p(2:deg) = 0.0_dp
        p(deg+1) = 1.0_dp
        coeffs = (/ (p(deg-j+1), j=0,deg)/)
        exact_roots = (/ (cmplx(cos(2*pi*j/deg),sin(2*pi*j/deg),kind=dp), j=1,deg)/)
        do it=1,itnum
            ! FPML
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main(p, deg, roots, berr, cond, conv, nitmax)
            call system_clock(count=clock_stop)
            results(it,1) = dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,2) = maxrel_fwderr(roots, exact_roots, deg)
            ! Polzeros
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call polzeros(deg, p, eps, big, small, nitmax, zeros, radius, h, iter)
            call system_clock(count=clock_stop)
            results(it,3)=dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,4) = maxrel_fwderr(zeros, exact_roots, deg)
            ! AMVW
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call z_poly_roots(deg, coeffs, eigs, residuals, flag)
            call system_clock(count=clock_stop)
            results(it,5)=dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,6) = maxrel_fwderr(eigs, exact_roots, deg)
        end do
        deallocate(exact_roots, p, roots, berr, cond, conv, zeros, radius, h, coeffs, eigs, residuals)
        ! write results to file
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,1))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,2))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,3))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,4))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,5))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)') sum(results(1:itnum,6))/itnum
        ! update deg and itnum
        deg=2*deg
        itnum=itnum/2
    end do
    deallocate(results)
    ! close file
    close(1)
contains
    !************************************************
    !                       maxrel_fwderr           *
    !************************************************
    ! Compute the maximum relative forward error
    ! in the approximation roots to exact_roots.
    !************************************************
    function maxrel_fwderr(roots, exact_roots, deg) result(res)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: exact_roots(:)
        complex(kind=dp), intent(inout) :: roots(:)
        ! local variables
        integer                         :: i, j, k
        real(kind=dp)                   :: hd, res

        ! main
        res = 0.0_dp
        do i=1,deg
            hd = abs(roots(i)-exact_roots(1))
            j = 1
            do k = 2,deg
                if (hd>abs(roots(i)-exact_roots(k))) then
                    hd = abs(roots(i)-exact_roots(k))
                    j = k
                end if
            end do
            if (res<hd/abs(exact_roots(j))) then
                res = hd/abs(exact_roots(j))
            end if
        end do
        return
    end function maxrel_fwderr
end program unity


! reference: SANDIA REPORT SAND2005-6988
!            Advances in Radiation Modeling in ALEGRA: ......
!            T. A. Brunner, T. Mehlhorn, R. McClarren, & C. J. Kurecka

module blackbody_module

  use fundamental_constants_module, only : a_rad, k_B, hplanck

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , parameter :: pi = 3.1415926535897932384626e0_rt
  real(rt)         :: bk_const = a_rad * 15.e0_rt/pi**4
  !                            = 8 * pi * k**4 / (c**3 * h**3)
  real(rt)         :: magic_const = pi**4/15.e0_rt
  integer, parameter :: Ncoefs = 8
  real(rt)        , dimension(0:Ncoefs) :: coefs =  &
       (/ 1.e0_rt/60.e0_rt, -1.e0_rt/5040.e0_rt, 1.e0_rt/272160.e0_rt, -1.e0_rt/13305600.e0_rt, &
       1.e0_rt/622702080.e0_rt, -691.e0_rt/19615115520000.e0_rt, 1.e0_rt/1270312243200.e0_rt,  &
       -3617.e0_rt/202741834014720000.e0_rt, 43867.e0_rt/107290978560589824000.e0_rt /)
  real(rt)        , parameter :: tol = 1.0e-10_rt

  real(rt)        , parameter :: xmagic = 2.061981e0_rt
  real(rt)        , parameter :: xsmall = 1.e-5_rt
  real(rt)        , parameter :: xlarge = 100.e0_rt

  private
  public :: BdBdTIndefInteg, BIndefInteg, BGroup

  contains

    subroutine BdBdTIndefInteg(T, nu, B, dBdT)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)        , intent(in) :: T, nu
      real(rt)        , intent(out) :: B, dBdT
      real(rt)         :: x, integ, part

      x = hplanck*nu/(k_B*T)

      if (x .gt. xlarge) then
         B = a_rad * T**4
         dBdT = 4.e0_rt * a_rad * T**3
      else if ( x .lt. xsmall) then
         B = 0.e0_rt
         dBdT = 0.e0_rt
      else
         if (x .gt. xmagic) then
            integ = integlarge(x)
         else
            integ = integsmall(x)
         end if
         part = x**4/(exp(x) - 1.e0_rt)
         B = bk_const*T**4 * integ
         dBdT = bk_const*T**3 * (4.*integ - part)
      end if
    end subroutine BdBdTIndefInteg

    function BIndefInteg(T, nu)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)         BIndefInteg
      real(rt)        , intent(in) :: T, nu
      real(rt)         :: x, integ

      x = hplanck*nu/(k_B*T)

      if (x .gt. xlarge) then
         BIndefInteg = a_rad * T**4
      else if ( x .lt. xsmall) then
         BIndefInteg = 0.e0_rt
      else
         if (x .gt. xmagic) then
            integ = integlarge(x)
         else
            integ = integsmall(x)
         end if
         BIndefInteg = bk_const*T**4 * integ
      end if
    end function BIndefInteg

    function BGroup(T, nu0, nu1)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)         BGroup
      real(rt)        , intent(in) :: T, nu0, nu1
      BGroup = BIndefInteg(T,nu1) - BIndefInteg(T,nu0)
    end function BGroup

    function Li(n, z)
      use amrex_fort_module, only : rt => amrex_real
      integer, intent(in) :: n
      real(rt)        , intent(in) :: z
      real(rt)         :: Li, t
      integer :: k
      integer, parameter :: kmax = 18
      Li = z
      do k = 2, kmax
         t = z**k / k**n
         Li = Li + t
         if (t/Li .lt. tol) then
            exit
         end if
      end do
    end function Li

    function integlarge(x)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)        , intent(in) :: x
      real(rt)         :: integlarge, z
      z = exp(-x)
      integlarge = magic_const &
           - (x**3 * Li(1,z) + 3.e0_rt * x**2 * Li(2,z) &
           + 6.e0_rt* x * Li(3,z) + 6.e0_rt * Li(4,z))
    end function integlarge

    function integsmall(x)
      use amrex_fort_module, only : rt => amrex_real
      real(rt)        , intent(in) :: x
      real(rt)         :: integsmall, t
      integer :: i
      real(rt)         :: x2, x3, xfoo
      x2 = x**2
      x3 = x**3
      integsmall = x3/3.e0_rt - x2**2/8.e0_rt
      xfoo = x3
      do i = 0, Ncoefs
         xfoo = xfoo * x2
         t = coefs(i) * xfoo
         integsmall = integsmall + t
         if (abs(t/integsmall) .lt. tol) then
            exit
         end if
      end do
    end function integsmall

end module blackbody_module


!-----------------------------------------------------------------------
      subroutine eval(dimn,x,rslt)
      integer dimn
      real*8 x(3)
      real*8 rslt

      rslt=tanh(x(1)+0.1)
      if (dimn>1) then
        rslt=rslt+atan(x(2)+0.2)
      endif
      if (dimn>2) then
        rslt=rslt+exp(-(x(3)+0.3)*(x(3)+0.3))
      endif

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

      integer ceed,err
      integer x,xq,u,uq,ones,gtposeones
      integer bxl,bug
      integer dimn,d
      integer i
      integer p
      integer q
      parameter(p=8)
      parameter(q=10)
      integer maxdim
      parameter(maxdim=3)
      integer qdimnmax
      parameter(qdimnmax=q**maxdim)
      integer pdimnmax
      parameter(pdimnmax=p**maxdim)
      integer xdimmax
      parameter(xdimmax=2**maxdim)
      integer pdimn,qdimn,xdim

      real*8 xx(xdimmax*maxdim)
      real*8 xxx(maxdim)
      real*8 xxq(pdimnmax*maxdim)
      real*8 uuq(qdimnmax*maxdim)
      real*8 uu(pdimnmax)
      real*8 ggtposeones(pdimnmax)
      real*8 sum1
      real*8 sum2
      integer dimxqdimn
      integer*8 uoffset,xoffset,offset1,offset2,offset3

      character arg*32

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do dimn=1,maxdim
        qdimn=q**dimn
        pdimn=p**dimn
        xdim=2**dimn
        dimxqdimn=dimn*qdimn
        sum1=0
        sum2=0

        do d=0,dimn-1
          do i=1,xdim
            if ((mod(i-1,2**(dimn-d))/(2**(dimn-d-1))).ne.0) then
              xx(d*xdim+i)=1
            else
              xx(d*xdim+i)=-1
            endif
          enddo
        enddo

        call ceedvectorcreate(ceed,xdim*dimn,x,err)
        xoffset=0
        call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,xoffset,err)
        call ceedvectorcreate(ceed,pdimn*dimn,xq,err)
        call ceedvectorsetvalue(xq,0.d0,err)
        call ceedvectorcreate(ceed,pdimn,u,err)
        call ceedvectorcreate(ceed,qdimn*dimn,uq,err)
        call ceedvectorsetvalue(uq,0.d0,err)
        call ceedvectorcreate(ceed,qdimn*dimn,ones,err)
        call ceedvectorsetvalue(ones,1.d0,err)
        call ceedvectorcreate(ceed,pdimn,gtposeones,err)
        call ceedvectorsetvalue(gtposeones,0.d0,err)

        call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,p,&
     &   ceed_gauss_lobatto,bxl,err)
        call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,x,xq,err)

        call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err)
        do i=1,pdimn
          do d=0,dimn-1
            xxx(d+1)=xxq(d*pdimn+i+offset1)
          enddo
          call eval(dimn,xxx,uu(i))
        enddo
        call ceedvectorrestorearrayread(xq,xxq,offset1,err)
        uoffset=0
        call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,uoffset,err)

        call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,p,q,ceed_gauss,bug,err)

        call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_grad,u,uq,err)
        call ceedbasisapply(bug,1,ceed_transpose,ceed_eval_grad,ones,&
     &   gtposeones,err)

        call ceedvectorgetarrayread(gtposeones,ceed_mem_host,ggtposeones,&
     &   offset1,err)
        call ceedvectorgetarrayread(u,ceed_mem_host,uu,offset2,err)
        call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset3,err)
        do i=1,pdimn
          sum1=sum1+ggtposeones(i+offset1)*uu(i+offset2)
        enddo
        do i=1,dimxqdimn
          sum2=sum2+uuq(i+offset3)
        enddo
        call ceedvectorrestorearrayread(gtposeones,ggtposeones,offset1,err)
        call ceedvectorrestorearrayread(u,uu,offset2,err)
        call ceedvectorrestorearrayread(uq,uuq,offset3,err)
        if(abs(sum1-sum2) > 1.0D-10) then
! LCOV_EXCL_START
          write(*,'(A,I1,A,F12.6,A,F12.6)')'[',dimn,'] Error: ',sum1,  ' != ',&
     &     sum2
! LCOV_EXCL_STOP
        endif

        call ceedvectordestroy(x,err)
        call ceedvectordestroy(xq,err)
        call ceedvectordestroy(u,err)
        call ceedvectordestroy(uq,err)
        call ceedvectordestroy(ones,err)
        call ceedvectordestroy(gtposeones,err)
        call ceedbasisdestroy(bxl,err)
        call ceedbasisdestroy(bug,err)
      enddo

      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


subroutine MONOD_NH4(Temp,PAR,NH4,NO3,PO4,mu0,Qnmin,Qpmin,aI0,bI0,KN,KP,DFe,KFe,muNet,QN,QP,theta,SI,Lno3)
! This subroutine calculate nondiatroph phytoplankton growth rates, QN and Theta based on the simplest MONOD equation
use bio_MOD, only: TEMPBOL, Ep, do_IRON, N2fix,thetamax,thetamin
real, intent(in)  :: Temp, PAR,NH4,NO3,PO4,mu0,Qnmin,Qpmin,aI0,bI0,KN,KP,DFe,KFe
real, intent(out) :: QN, QP, theta, SI, Lno3,muNet
real              :: rmax_T,Qnmax,Qpmax,Lpo4

  ! Maximal N:C ratio
   Qnmax=3.*Qnmin
   Qpmax=3.*Qpmin

  ! The maximal growth rate (rmax_T) under temperature tC
   rmax_T = mu0*TEMPBOL(Ep,Temp)

  !The light limitation index (SI)
  ! Unit of aI0_C: (W m-2)-1, different from other models (aI0_Chl)
  ! Include photoinhibition (Platt et al. J Phycol 1980)
  SI = (1d0 - exp(-aI0*PAR/rmax_T))*exp(-bI0*PAR/rmax_T)

  ! Growth rate (d-1) is the product function of temperature, light, and nutrient

  ! Nitrate dependence
  Lno3  = NO3/(NO3 + KN)*(1. - Lnh4)

  if (N2fix) then
     Lpo4 = PO4/(PO4 + KP)
     Lno3 = min(Lno3, Lpo4)
  endif

  if (DO_IRON) then
     Lpo4  = DFe/(DFe + KFe)
     Lno3  = min(Lno3, Lpo4)
  endif
  muNet = rmax_T*Lno3*SI
  QN = Qnmin/(1d0-(1d0-Qnmin/Qnmax)*Lno3)

  if (N2fix) QP=Qpmin/(1d0-(1d0-Qpmin/Qpmax)*(PO4/(PO4+KP)))

  theta  = thetamin+muNet/PAR/aI0*(thetamax-thetamin)   !Unit: gChl/molC
  return
end subroutine


      SUBROUTINE MB04RU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a skew-Hamiltonian matrix,
C
C                   [  A   G  ]
C             W  =  [       T ] ,
C                   [  Q   A  ]
C
C     where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric
C     matrices, to Paige/Van Loan (PVL) form. That is, an orthogonal
C     symplectic matrix U is computed so that
C
C               T       [  Aout  Gout  ]
C              U W U =  [            T ] ,
C                       [    0   Aout  ]
C
C     where Aout is in upper Hessenberg form.
C     Unblocked version.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     ILO     (input) INTEGER
C             It is assumed that A is already upper triangular and Q is
C             zero in rows and columns 1:ILO-1. ILO is normally set by a
C             previous call to the SLICOT Library routine MB04DS;
C             otherwise it should be set to 1.
C             1 <= ILO <= N+1, if N > 0; ILO = 1, if N = 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Aout and, in the zero part of Aout, information
C             about the elementary reflectors used to compute the
C             PVL factorization.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the strictly lower triangular part
C             of the matrix Q and in columns 2:N+1 the strictly upper
C             triangular part of the matrix G. The parts containing the
C             diagonal and the first superdiagonal of this array are not
C             referenced.
C             On exit, the leading N-by-N+1 part of this array contains
C             in its first N-1 columns information about the elementary
C             reflectors used to compute the PVL factorization and in
C             its last N columns the strictly upper triangular part of
C             the matrix Gout.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     CS      (output) DOUBLE PRECISION array, dimension (2N-2)
C             On exit, the first 2N-2 elements of this array contain the
C             cosines and sines of the symplectic Givens rotations used
C             to compute the PVL factorization.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (N-1)
C             On exit, the first N-1 elements of this array contain the
C             scalar factors of some of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal value
C             of LDWORK.
C             On exit, if INFO = -10,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N-1).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix U is represented as a product of symplectic reflectors
C     and Givens rotations
C
C     U = diag( H(1),H(1) )     G(1)   diag( F(1),F(1) )
C         diag( H(2),H(2) )     G(2)   diag( F(2),F(2) )
C                                ....
C         diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ).
C
C     Each H(i) has the form
C
C           H(i) = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with v(1:i) = 0
C     and v(i+1) = 1; v(i+2:n) is stored on exit in QG(i+2:n,i), and
C     tau in QG(i+1,i).
C
C     Each F(i) has the form
C
C           F(i) = I - nu * w * w'
C
C     where nu is a real scalar, and w is a real vector with w(1:i) = 0
C     and w(i+1) = 1; w(i+2:n) is stored on exit in A(i+2:n,i), and
C     nu in TAU(i).
C
C     Each G(i) is a Givens rotation acting on rows i+1 and n+i+1, where
C     the cosine is stored in CS(2*i-1) and the sine in CS(2*i).
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 40/3 N**3 + O(N) floating point operations
C     and is strongly backward stable.
C
C     REFERENCES
C
C     [1] Van Loan, C.F.
C         A symplectic method for approximating all the eigenvalues of
C         a Hamiltonian matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C     V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DSHPVL).
C     V. Sima, Nov. 2011, Oct. 2012.
C
C     KEYWORDS
C
C     Elementary matrix operations, skew-Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           ILO, INFO, LDA, LDQG, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  ALPHA, C, NU, S, TEMP
C     .. External Subroutines ..
      EXTERNAL          DLARF, DLARFG, DLARTG, DROT, MB01MD, MB01ND,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN
         INFO = -2
      ELSE IF (  LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN
         DWORK(1) = DBLE( MAX( 1, N-1 ) )
         INFO = -10
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04RU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.LE.ILO ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      DO 10 I = ILO, N - 1
C
C        Generate elementary reflector H(i) to annihilate QG(i+2:n,i).
C
         ALPHA = QG(I+1,I)
         CALL DLARFG( N-I, ALPHA, QG(MIN( I+2, N ),I), 1, NU )
         IF ( NU.NE.ZERO ) THEN
            QG(I+1,I) = ONE
C
C           Apply H(i) from both sides to QG(i+1:n,i+1:n).
C           Compute  x := nu * QG(i+1:n,i+1:n) * v.
C
            CALL MB01MD( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I),
     $                   1, ZERO, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C                QG(i+1:n,i+1:n) := QG(i+1:n,i+1:n) + v * x' - x * v'.
C
            CALL MB01ND( 'Lower', N-I, ONE, QG(I+1,I), 1, DWORK, 1,
     $                   QG(I+1,I+1), LDQG )
C
C           Apply H(i) from the right hand side to QG(1:i,i+2:n+1).
C
            CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2),
     $                  LDQG, DWORK )
C
C           Apply H(i) from both sides to QG(i+1:n,i+2:n+1).
C           Compute  x := nu * QG(i+1:n,i+2:n+1) * v.
C
            CALL MB01MD( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I),
     $                   1, ZERO, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C              QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) + v * x' - x * v'.
C
            CALL MB01ND( 'Upper', N-I, ONE, QG(I+1,I), 1, DWORK, 1,
     $                   QG(I+1,I+2), LDQG )
C
C           Apply H(i) from the left hand side to A(i+1:n,i:n).
C
            CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, A(I+1,I),
     $                  LDA, DWORK )
C
C           Apply H(i) from the right hand side to A(1:n,i+1:n).
C
            CALL DLARF( 'Right', N, N-I,  QG(I+1,I), 1, NU, A(1,I+1),
     $                  LDA, DWORK )
         END IF
         QG(I+1,I) = NU
C
C        Generate symplectic Givens rotation G(i) to annihilate
C        QG(i+1,i).
C
         TEMP = A(I+1,I)
         CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) )
C
C        Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)'].
C
         CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, -S )
C
C        Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)].
C
         CALL DROT( I, A(1,I+1), 1, QG(1,I+2), 1, C, S )
C
C        Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right.
C
         CALL DROT( N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, -S )
C
         CS(2*I-1) = C
         CS(2*I)   = S
C
C        Generate elementary reflector F(i) to annihilate A(i+2:n,i).
C
         CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2, N ),I), 1, NU )
         IF ( NU.NE.ZERO ) THEN
            TEMP = A(I+1,I)
            A(I+1,I) = ONE
C
C           Apply F(i) from the left hand side to A(i+1:n,i+1:n).
C
            CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1),
     $                  LDA, DWORK )
C
C           Apply F(i) from the right hand side to A(1:n,i+1:n).
C
            CALL DLARF( 'Right', N, N-I,  A(I+1,I), 1, NU, A(1,I+1),
     $                  LDA, DWORK )
C
C           Apply F(i) from both sides to QG(i+1:n,i+1:n).
C           Compute  x := nu * QG(i+1:n,i+1:n) * v.
C
            CALL MB01MD( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I),
     $                   1, ZERO, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C                QG(i+1:n,i+1:n) := QG(i+1:n,i+1:n) + v * x' - x * v'.
C
            CALL MB01ND( 'Lower', N-I, ONE, A(I+1,I), 1, DWORK, 1,
     $                   QG(I+1,I+1), LDQG )
C
C           Apply F(i) from the right hand side to QG(1:i,i+2:n+1).
C
            CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2),
     $                  LDQG, DWORK )
C
C           Apply F(i) from both sides to QG(i+1:n,i+2:n+1).
C           Compute  x := nu * QG(i+1:n,i+2:n+1) * v.
C
            CALL MB01MD( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I),
     $                   1, ZERO, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C              QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) + v * x' - x * v'.
C
            CALL MB01ND( 'Upper', N-I, ONE, A(I+1,I), 1, DWORK, 1,
     $                   QG(I+1,I+2), LDQG )
            A(I+1,I) = TEMP
         END IF
         TAU(I) = NU
   10 CONTINUE
      DWORK(1) = DBLE( MAX( 1, N-1 ) )
      RETURN
C *** Last line of MB04RU ***
      END


      SUBROUTINE TOCART(U,KEPLER,IANOM,POS,VEL,IERPNT,IERR)
C
C     PURPOSE: TOCART CONVERTS THE KEPLERIAN ELEMENTS OF A VEHICLE
C              IN ORBIT INTO CARTESIAN COORDINATES
C
C
C
C  VAR     DIM  TYPE   I/O   DESCRIPTION
C  ---     ---  ----   ---   -----------
C
C  U       1    R*8     I    CENTRAL BODY GRAVITATION CONSTANT.
C                            EX: U=398601.2 KM**3/SEC**2
C                            LENGTH UNIT IS THE SAME AS SEMI-MAJOR
C                            AXIS UNIT. TIME UNIT IS THE SAME AS
C                            FOR VELOCITY TO BE OUTPUT.
C
C  KEPLER  6    R*8     I    KEPLERIAN ELEMENTS TO BE CONVERTED TO
C                            CARTESIAN COORDINATES. LENGTH UNITS ARE
C                            THE SAME AS FOR U. ANGLE UNITS ARE
C                            RADIANS. ORDER IS: SMA, ECC, INCL, NODE,
C                            ARGP, ANOM(MEAN OR TRUE: SEE IANOM).
C
C  IANOM   1    I*4     I    ANOMALY FLAG.
C                            =0 MEANS KEPLER(6) IS MEAN ANOMALY.
C                            =NON-ZERO MEANS KEPLER(6) IS TRUE ANOMALY.
C
C  POS     3    R*8     O    CARTESIAN POSITION VECTOR. LENGTH UNIT IS
C                            AS FOR U AND ELEM(1).
C
C  VEL     3    R*8     O    CARTESIAN VELOCITY VECTOR. LENGTH UNIT IS
C                            AS FOR R. TIME UNIT IS AS FOR U.
C
C  IERPNT  1    I*4     I    FORTRAN UNIT FOR ERROR MESSAGE. NONE
C                            POSSIBLE IF =0. ERROR MESSAGE IS FOR A
C                            NON-ELLIPSE/CIRCLE INPUT.
C
C  IERR    1    I*4     O    ERROR RETURN FLAG.
C                            =0 NO ERROR.  =1, ERROR.
C
C*******************************************************************
C
C  CODING: TAKEN FROM 580'S MAESTRO PROGRAM.
C          C PETRUZZO 9/81.
C          MODIFICATIONS:
C
C*******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 INCL,NODE,MEAN,KEPLER(6),P(3,2),RTEMP(2),VTEMP(2),MU
      REAL*8 POS(3),VEL(3)
      REAL*8 PI/  3.141592653589793D0    /
      REAL*8 TWOPI/  6.283185307179586D0    /
C
C
C
      MU=U
      SMA=KEPLER(1)
      ECC=KEPLER(2)
      INCL=KEPLER(3)
      NODE=KEPLER(4)
      ARGP=KEPLER(5)
C
C     ERROR CHECKS.
      IERR=0
      IF(ECC.LT.0.D0 .OR. ECC.GE.1.D0) IERR=1
      IF(SMA.LE.0.D0) IERR=1
      IF(IERR.NE.0) GO TO 1400
C
C     WE NEED TRUE ANOMALY FOR CALCULATIONS. BE SURE WE HAVE IT.
      IF(IANOM.EQ.0) GO TO 10
C     KEPLER(6) IS TRUE ANOMALY.
      TRANOM=DMOD(DABS(KEPLER(6)),TWOPI)
      IF(KEPLER(6).LT.0.D0) TRANOM=TWOPI-TRANOM
      GO TO 20
   10 CONTINUE
C     KEPLER(6) IS MEAN ANOMALY.
      MEAN=DMOD(DABS(KEPLER(6)),TWOPI)
      IF(KEPLER(6).LT.0.D0) MEAN=TWOPI-MEAN
      TRANOM=ANOMLY(+1,MEAN,ECC,0,IDUM)
C
   20 CONTINUE
C     BE SURE CONVENTIONS ARE SATISFIED.
      IF(INCL.EQ.0.D0) NODE=0.D0
      IF(ECC.EQ.0.D0) ARGP=0.D0
C
C
C  FORMULATION FROM DOCUMENT X-582-76-77(APRIL 1976), PAGE 3-49.
C  MATH THEORY OF THE G.T.D.S.
C
      COSTRU=DCOS(TRANOM)
      ECANOM=DARCOS(  (COSTRU+ECC)/(1.D0+ECC*COSTRU)  )
      IF(TRANOM.GT.PI) ECANOM=TWOPI-ECANOM
      SINEC=DSIN(ECANOM)
      COSEC=DCOS(ECANOM)
      DUM1=DSQRT(1.D0-ECC*ECC)
      RTEMP(1) = SMA * (COSEC-ECC)
      RTEMP(2) = SMA * DUM1 * SINEC
      DUM2=DSQRT(MU/SMA)/(1.D0-ECC*COSEC)
      VTEMP(1)=-DUM2*SINEC
      VTEMP(2)=DUM2*DUM1*COSEC
C
      COSAP=DCOS(ARGP)
      SINAP=DSIN(ARGP)
      COSNOD=DCOS(NODE)
      SINNOD=DSIN(NODE)
      COSINC=DCOS(INCL)
      SININC=DSIN(INCL)
      P(1,1)= COSAP*COSNOD - SINAP*SINNOD*COSINC
      P(2,1)= COSAP*SINNOD + SINAP*COSNOD*COSINC
      P(3,1)= SINAP*SININC
      P(1,2)=-SINAP*COSNOD - COSAP*SINNOD*COSINC
      P(2,2)=-SINAP*SINNOD + COSAP*COSNOD*COSINC
      P(3,2)= COSAP*SININC
C
      POS(1) = P(1,1)*RTEMP(1) + P(1,2)*RTEMP(2)
      POS(2) = P(2,1)*RTEMP(1) + P(2,2)*RTEMP(2)
      POS(3) = P(3,1)*RTEMP(1) + P(3,2)*RTEMP(2)
      VEL(1) = P(1,1)*VTEMP(1) + P(1,2)*VTEMP(2)
      VEL(2) = P(2,1)*VTEMP(1) + P(2,2)*VTEMP(2)
      VEL(3) = P(3,1)*VTEMP(1) + P(3,2)*VTEMP(2)
      GO TO 9000
C
 1400 CONTINUE
      IF(IERPNT.NE.0) WRITE(IERPNT,1200) SMA,ECC
 1200 FORMAT('0TOCART. BIG ERROR. ELLIPSE NOT INPUT. ARBITRARY ',
     1  'R/V OUTPUT. IGNORE RESULTS. SMA,ECC IN=',G12.5,1X,G23.16)
      DO 1401 I=1,3
      POS(I)=10000.D0
 1401 VEL(I)=1.D0
C
 9000 CONTINUE
      RETURN
      END


program std

  implicit none

  character(len=80) filename

  integer i, j, npts, nfiles

  double precision, allocatable :: file(:)

  double precision :: temp1, temp2

  print*,'enter filename'
  read(*,*) filename

  print*,'how many points'
  read(*,*) npts

  allocate(file(npts))

  open(unit=999,file=trim(filename))
  do i=1,npts
     read(unit=999, FMT=*) file(i)
  end do

  temp1 = 0.
  do i=1,npts
     temp1 = temp1 + file(i)
  end do
  temp1 = temp1 / npts

  temp2 = 0.
  do i=1,npts
     temp2 = temp2 + ( file(i) - temp1 )**2
  end do
  temp2 = sqrt(temp2/npts)

  print*,'mean',temp1
  print*,'standard deviation',temp2
  print*,'standard error',temp2/sqrt(dble(npts))

end program std


subroutine swap(ind,size,x,y)
  integer::x,y,z,size
  integer,dimension(1:size)::ind
  z = ind(x)
  ind(x) = ind(y)
  ind(y) = z
end subroutine swap

subroutine sift_down(a,ind,end,i,size)
  integer::i,size,ln,j,end
  real(kind=8),dimension(1:size)::a
  integer,dimension(1:size)::ind

  j = i
  do while (j .le. (end/2))
     ln = 2*j
     if (ln .lt. end) then
        if ((a(ind(ln+1))) .gt. (a(ind(ln)))) then
           ln = ln+1
        end if
     end if
     if (a(ind(ln)) .gt. a(ind(j))) then
        call swap(ind,size,j,ln)
        j = ln
     else
        j = end
     end if
  end do

  return
end subroutine sift_down

subroutine heapify(a,ind,size)
  integer::size,i
  real(kind=8),dimension(1:size)::a
  integer,dimension(1:size)::ind

  do i = size/2,1,-1
     call sift_down(a,ind,size,i,size)
  end do

end subroutine heapify

subroutine heapsort_index(a,ind,size)
  integer::size,i
  real(kind=8),dimension(1:size)::a
  integer,dimension(1:size)::ind

  do i=1,size
     ind(i)=i
  end do

  call heapify(a,ind,size)

  do i=size,1,-1
     call swap(ind,size,1,i)
     call sift_down(a,ind,i-1,1,size)
  end do

end subroutine heapsort_index


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM PROJ2
C     Project 2: The structure of white dwarf stars
C  COMPUTATIONAL PHYSICS (FORTRAN VERSION)
C  by Steven E. Koonin and Dawn C. Meredith
C  Copyright 1989, Addison-Wesley Publishing Company Inc.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL INIT           !display header screen, setup parameters
5     CONTINUE            !main loop; execute once for each set of param
         CALL PARAM       !get input parameters
         CALL ARCHON      !calculate density, mass and radius of stars
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C calculate the mass(r), density(r) for a range of central densities
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P2'
C Local variables:
      REAL MSTOR(MAXMOD)            !mass of star
      REAL RADIUS(MAXMOD)           !radius of star
      REAL STEP(MAXMOD)             !step size
      REAL RMIN(MAXMOD)             !starting radius
      INTEGER NSTEP(MAXMOD)         !number of radial steps
      REAL RHOSTR(MAXMOD,0:MAXSTP)  !density(r) of star
      INTEGER IMODEL                !index of current model
      INTEGER NLINES                !number of lines printed out
      REAL M,RHO                    !current mass and density
      REAL R                        !current radius
      REAL DR                       !radial step
      REAL EGRAV                    !gravitational energy of star
      REAL EKINT                    !kinetic energy of star
      REAL EXPONT                   !temporary exponent
      REAL RHOCEN                   !central density for this model
      INTEGER IR                    !number of radial steps
      INTEGER DEVICE                !current graphing device
      INTEGER SCREEN                !send to terminal
      INTEGER PAPER                 !make a hardcopy
      INTEGER FILE                  !send to a file
C Functions:
      REAL GAMMA                    !dPressure/dDensity
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     output summary of parameters
      IF (TTERM) CALL PRMOUT(OUNIT,NLINES)
      IF (TFILE) CALL PRMOUT(TUNIT,NLINES)
      IF (GFILE) CALL PRMOUT(GUNIT,NLINES)
C
      DO 20 IMODEL=1,NMODEL                      !loop over central dens
C
C       calculate central density
        EXPONT=FLOAT(IMODEL-1)/FLOAT(NMODEL-1)   !spacing between dens
        RHOCEN=(RHO1/RHO0)*((RHO2/RHO1)**EXPONT) !equal on log scale
C
        DR=((3.0*0.001/RHOCEN)**(1.0/3.0))/3.0   !radial step
        R=DR/10.                                 !begin at finite radius
        RMIN(IMODEL)=R*R0/10.E+08                !starting radius
        STEP(IMODEL)=DR*R0/10.E+08               !step size
C
C       use Taylor expansion to obtain initial conditions
        M=(R**3.0)*(RHOCEN/3.0)                  !initial mass
C       initial density
        RHO=RHOCEN*(1-RHOCEN*R**2.0/6.0/GAMMA(RHOCEN**(1./3.)))
        RHOSTR(IMODEL,0)=RHO*RHO0
C
C       integrate equations and find energies, mass, and radius of star
        CALL INTGRT(M,RHO,R,DR,EGRAV,EKINT,IMODEL,IR,RHOSTR)
C
        MSTOR(IMODEL)=M*M0/10.E+33               !save values for graph
        RADIUS(IMODEL)=R*R0/10.E+08
        NSTEP(IMODEL)=IR
C
        IF (TTERM)                               !text output
     +      CALL TXTOUT(OUNIT,NLINES,R,M,DR,RHOCEN,EKINT,EGRAV,IR)
        IF (TFILE)
     +      CALL TXTOUT(TUNIT,NLINES,R,M,DR,RHOCEN,EKINT,EGRAV,IR)
C
20    CONTINUE
C
      IF (TTERM) CALL PAUSE('to continue...',1)
      IF (TTERM) CALL CLEAR
C
C     graphics output
      IF (GTERM) CALL GRFOUT(SCREEN,MSTOR,RADIUS,STEP,RMIN,NSTEP,RHOSTR)
      IF (GFILE) CALL GRFOUT(FILE,MSTOR,RADIUS,STEP,RMIN,NSTEP,RHOSTR)
      IF (GHRDCP) CALL GRFOUT(PAPER,MSTOR,RADIUS,STEP,RMIN,NSTEP,RHOSTR)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INTGRT(M,RHO,R,DR,EGRAV,EKINT,IMODEL,IR,RHOSTR)
C integrates mass and density beginning with M and RHO at radius R;
C calculates gravitational and kinetic energies
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.P2'
C Passed variables:
      REAL RHOSTR(MAXMOD,0:MAXSTP)!density(r) of star (output)
      INTEGER IMODEL              !index of current model (input)
      REAL M,RHO                  !current mass and density (I/O)
      REAL R                      !current radius (I/O)
      REAL DR                     !radial step (input)
      REAL EGRAV                  !gravitational energy of star (output)
      REAL EKINT                  !kinetic energy of star (output)
      INTEGER IR                  !current lattice point (output)
C Function:
      REAL EPSRHO                 !function in energy density
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      EGRAV=0.0                   !zero sums
      EKINT=0.0
      IR=0
10    IF ((IR .LT. MAXSTP) .AND. (RHO .GT. RHOCUT)) THEN
         IR=IR+1                          !update radial index
         CALL RUNGE(M,RHO,R,DR)           !take a Runge-Kutta step
         IF (RHO .LT. RHOCUT) RHO=RHOCUT  !avoid small densities
         RHOSTR(IMODEL,IR)=RHO*RHO0       !save values for graphing
         EGRAV=EGRAV+M*RHO*R              !contribution to energy integ.
         EKINT=EKINT+R**2*EPSRHO(RHO**(1./3.))
      GOTO 10
      END IF
      EGRAV=-EGRAV*DR*E0                  !unscaled energies
      EKINT=EKINT*DR*E0
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE RUNGE(M,RHO,R,DR)
C take a Runge-Kutta step to integrate mass and density
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Passed variables:
      REAL M,RHO                    !current mass and density (I/O)
      REAL R                        !current radius (input)
      REAL DR                       !radial step (input)
C Local variables:
      REAL DMDR,DRHODR              !radial derivatives of mass and dens
      REAL K1M,K1RHO                !intermediate increments of mass and
      REAL K2M,K2RHO                !                           density
      REAL K3M,K3RHO
      REAL K4M,K4RHO
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL DERS(M,RHO,R,DMDR,DRHODR) !calculate k1's
      K1M=DR*DMDR
      K1RHO=DR*DRHODR
C
      R=R+DR/2.0                     !calculate k2's
      M=M+.5*K1M
      RHO=RHO+.5*K1RHO
      CALL DERS(M,RHO,R,DMDR,DRHODR)
      K2M=DR*DMDR
      K2RHO=DR*DRHODR
C
      M=M+.5*(K2M-K1M)               !calculate k3's
      RHO=RHO+.5*(K2RHO-K1RHO)
      CALL DERS(M,RHO,R,DMDR,DRHODR)
      K3M=DR*DMDR
      K3RHO=DR*DRHODR
C
      R=R+DR/2.0                     !calculate k4's
      M=M+K3M-.5*K2M
      RHO=RHO+K3RHO-.5*K2RHO
      CALL DERS(M,RHO,R,DMDR,DRHODR)
      K4M=DR*DMDR
      K4RHO=DR*DRHODR
C
C     values of mass and density at new radius
      M=M-K3M+(K1M+2.0*K2M+2.0*K3M+K4M)/6.0
      RHO=RHO-K3RHO+(K1RHO+2.0*K2RHO+2.0*K3RHO+K4RHO)/6.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE DERS(M,RHO,R,DMDR,DRHODR)
C calculate the derivatives of mass and density with respect to radius
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Passed variables:
      REAL M,RHO           !current mass and density (input)
      REAL R               !current radius (input)
      REAL DMDR,DRHODR     !radial derivatives of mass and dens (output)
C Functions
      REAL GAMMA           !dPressure/dDensity
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (RHO .GT. 0.0) THEN   !avoid division by zero
          DRHODR=-M*RHO/((R**2)*GAMMA(RHO**(1.0/3.0)))
          DMDR=(R**2)*RHO
      END IF
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      REAL FUNCTION GAMMA(X)
C derivative of pressure with respect to density
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Passed variables:
      REAL X                           !cubed root of density
      GAMMA=X*X/3.0/SQRT(X*X+1)
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      REAL FUNCTION EPSRHO(X)
C function needed in the calculation of the energy
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Passed variables:
      REAL X                          !cubed root of density
C Local variables:
      REAL PART1,PART2                !terms in the function
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PART1=X*(1.0+2.0*X**2)*SQRT(1.0+X**2)
      PART2=LOG(X+SQRT(1.0+X**2))
      EPSRHO=0.375*(PART1-PART2)
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INIT
C initializes constants, displays header screen,
C initializes arrays for input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'MENU.ALL'
      INCLUDE 'PARAM.P2'
C Local parameters:
      CHARACTER*80 DESCRP        !program description
      DIMENSION DESCRP(22)
      INTEGER NHEAD,NTEXT,NGRF   !number of lines for each description
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL SETUP                !get environment parameters
C
C     display header screen
      DESCRP(1)= 'PROJECT 2'
      DESCRP(2)= 'The structure of white dwarf stars'
      NHEAD=2
C
C     text output description
      DESCRP(3)= 'mass, radius, and energy of each star'
      NTEXT=1
C
C     graphics output description
      DESCRP(4)= 'total mass vs. final radius for all models'
      DESCRP(5)= 'density vs. radius for each model'
      NGRF=2
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRF)
C
C     calculate constants
      MEORMP = 1./1836.
C
C     setup menu
      CALL MENU                       !setup constant part of menu
C
      MPRMPT(4)='2) (not used)'
C
      MTYPE(13)=FLOAT
      MPRMPT(13)= 'Enter electron fraction, YE'
      MTAG(13)= 'Electron fraction, YE'
      MLOLIM(13)=.001
      MHILIM(13)=10.
      MREALS(13)=1.0
C
      MTYPE(14)=FLOAT
      MPRMPT(14)= 'Enter central density (gm/cm^3) for the first model'
      MTAG(14)= 'Initial central density (gm/cm^3)'
      MLOLIM(14)=1.E5
      MHILIM(14)=1.E15
      MREALS(14)=1.E5
C
      MTYPE(15)=FLOAT
      MPRMPT(15)= 'Enter central density (gm/cm^3) for the last model'
      MTAG(15)= 'Final central density (gm/cm^3)'
      MLOLIM(15)=1.E5
      MHILIM(15)=1.E15
      MREALS(15)=1.E11
C
      MTYPE(16)=NUM
      MPRMPT(16)= 'Enter the number of models to calculate'
      MTAG(16)= 'Number of models to calculate'
      MLOLIM(16)=1.
      MHILIM(16)=MAXMOD
      MINTS(16)=4.
C
      MTYPE(17)=SKIP
      MREALS(17)=35.
C
      MTYPE(36)=SKIP
      MREALS(36)=60.
C
      MSTRNG(MINTS(75))= 'proj2.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'proj2.grf'
C
      MTYPE(87)=SKIP
      MREALS(87)=90.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PARAM
C gets parameters from screen
C ends program on request
C closes old files
C maps menu variables to program variables
C opens new files
C calculates all derivative parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P2'
      INCLUDE 'MAP.P2'
C Function:
      LOGICAL LOGCVT          !converts 1 and 0 to true and false
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get input from terminal
      CALL CLEAR
      CALL ASK(1,ISTOP)
C
C     stop program if requested
      IF (MREALS(IMAIN) .EQ. STOP) CALL FINISH
C
C     close files if necessary
      IF (TNAME .NE. MSTRNG(MINTS(ITNAME)))
     +     CALL FLCLOS(TNAME,TUNIT)
      IF (GNAME .NE. MSTRNG(MINTS(IGNAME)))
     +     CALL FLCLOS(GNAME,GUNIT)
C
C     set new parameter values
C     physical and numerical:
      YE=MREALS(IYE)
      RHO1=MREALS(IRHO1)
      RHO2=MREALS(IRHO2)
      NMODEL=MINTS(INMODL)
C
C     text output
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
C     files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
      CALL PCHECK
      CALL CLEAR
C
C     calculate parameter dependent quantities
      R0=7.72E+08*YE             !scaling radius
      M0=5.67E+33*(YE**2)        !scaling mass
      RHO0=979000./YE            !scaling density
      E0=YE*MEORMP*9*(M0/1E+31)  !scaling energy
      RHOCUT=1000./RHO0          !nearly zero density
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE PCHECK
C ensure that RHO1 < RHO2
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global parameters:
      INCLUDE 'PARAM.P2'
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'MAP.P2'
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10    IF (RHO1 .GE. RHO2) THEN
          WRITE (OUNIT,15)
          CALL ASK(IRHO1,IRHO2)
          RHO1=MREALS(IRHO1)
          RHO2=MREALS(IRHO2)
      GOTO 10
      END IF
15    FORMAT
     + (' The initial density must be smaller than the final density')
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PRMOUT(MUNIT,NLINES)
C outputs parameters to the specified unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'PARAM.P2'
      INCLUDE 'IO.ALL'
C Passed variables
      INTEGER MUNIT              !unit number for output (input)
      INTEGER NLINES             !number of lines written so far (I/O)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (MUNIT .EQ. OUNIT) CALL CLEAR
C
      WRITE (MUNIT,19)
      WRITE (MUNIT,21)
      WRITE (MUNIT,25)  NMODEL
      WRITE (MUNIT,27)  YE
      WRITE (MUNIT,29)  RHO1,RHO2
      WRITE (MUNIT,19)
C
      IF (MUNIT .NE. GUNIT) THEN       !headers for text output only
        WRITE (MUNIT,31)
        WRITE (MUNIT,32)
        WRITE (MUNIT,33)
      END IF
C
      NLINES = 9
C
19    FORMAT  (' ')
21    FORMAT  (' Output from project 2: ',
     +         'The structure of white dwarf stars ')
25    FORMAT  (' Number of models = ',I3)
27    FORMAT  (' Electron fraction YE= ',1PE9.3)
29    FORMAT  (' First central density=',1PE9.3,
     +         5X,' Final central density=',1PE9.3)
31    FORMAT  (3X,'Step',4X,'Cent Den',1X,'Nstep',3X,'Radius',
     +         5X,'Mass', 7X,'Kin E',6X,'Grav E',7X,'Tot E')
32    FORMAT  (3X,' cm ',4X,'gm/cm^-3',1X,'     ',3X,'  cm  ',
     +         5X,' gm ', 7X,9X,'10^51 ergs ',4X,'     ')
33    FORMAT  (3X,'----',4X,'--------',1X,'-----',3X,'------',
     +         5X,'----', 7X,'-----',6X,'------',7X,'-----')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,NLINES,R,M,DR,RHOCEN,EKINT,EGRAV,IR)
C writes results for one model to the requested unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P2'
C Input variables:
      INTEGER MUNIT                 !unit to which we are writing
      INTEGER NLINES                !number of lines printed out (I/O)
      REAL M,RHO                    !current mass and density
      REAL RHOCEN                   !central density
      REAL R                        !current radius
      REAL DR                       !radial step
      REAL EGRAV                    !gravitational energy of star
      REAL EKINT                    !kinetic energy of star
      INTEGER IR                    !number of radial steps
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear screen and retype headings
      IF ((MOD(NLINES,TRMLIN-4) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue',1)
         CALL CLEAR
         WRITE (MUNIT,31)
         WRITE (MUNIT,32)
         WRITE (MUNIT,33)
      END IF
C
C     write unscaled values to screen
      WRITE (MUNIT,35) DR*R0,RHOCEN*RHO0,IR,
     +                 R*R0,M*M0,EKINT,EGRAV,EKINT+EGRAV
C
C     keep track of printed lines only for terminal output
      IF (MUNIT .EQ. OUNIT) NLINES=NLINES+1
C
31    FORMAT  (3X,'Step',4X,'Cent Den',1X,'Nstep',3X,'Radius',
     +         5X,'Mass', 7X,'Kin E',6X,'Grav E',7X,'Tot E')
32    FORMAT  (3X,' cm ',4X,'gm/cm^-3',1X,'     ',3X,'  cm  ',
     +         5X,' gm ', 7X,9X,'10^51 ergs ',4X,'     ')
33    FORMAT  (3X,'----',4X,'--------',1X,'-----',3X,'------',
     +         5X,'----', 7X,'-----',6X,'------',7X,'-----')
35    FORMAT  (2(1X,1PE8.2),1X,I4,3(2X,1PE9.3),2(2X,1PE10.3))
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFOUT(DEVICE,MSTOR,RADIUS,STEP,RMIN,NSTEP,RHOSTR)
C outputs two plots:  1) total mass vs. final radius of star
C                     2) density vs. radius
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P2'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE                !which device is being used?
      REAL MSTOR(MAXMOD)            !mass of stars
      REAL RADIUS(MAXMOD)           !radius of stars
      REAL STEP(MAXMOD)             !step size
      REAL RMIN(MAXMOD)             !starting radius
      INTEGER NSTEP(MAXMOD)         !number of radial steps
      REAL RHOSTR(MAXMOD,0:MAXSTP)  !density(r) of star
C Local variables
      REAL R,DEN                    !radius and density for one model
      INTEGER IM,IR                 !current model and radius
      DIMENSION R(0:MAXSTP),DEN(0:MAXSTP) !radius and density
      CHARACTER*9 CYE               !electron fraction as charac string
      INTEGER LEN                   !length of string
      INTEGER SCREEN                !send to terminal
      INTEGER PAPER                 !make a hardcopy
      INTEGER FILE                  !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
C     define parameters which are the same for both plots
      IF (DEVICE .NE. FILE) THEN
          NPLOT=2                        !how many plots?
C
          XMIN=0.
          Y0VAL=0.
C
          ILINE=1                      !line and symbol styles
          ISYM=1
          IFREQ=1
          NXTICK=5
          NYTICK=5
C
          CALL CONVRT(YE,CYE,LEN)
          TITLE = 'White Dwarf Stars with electron fraction='//CYE
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
      END IF
C
      DO 20 IPLOT=1,NPLOT
C       define parameters which are different for each plot
        IF (DEVICE .NE. FILE) THEN
          IF (IPLOT .EQ. 1) THEN
             YMIN=MSTOR(1)
             X0VAL=MSTOR(1)
             XMAX=RADIUS(1)
             YMAX=MSTOR(NMODEL)
             NPOINT=NMODEL
             LABEL(1)= 'radius (10**8 cm)'
             LABEL(2)= 'mass (10**33 gm)'
             CALL LNLNAX
          ELSE
             XMAX=RADIUS(1)
             YMAX=RHO2
             YMIN=RHOCUT*RHO0
             X0VAL=RHOCUT*RHO0
             IFREQ=0
             LABEL(1)= 'radius (10**8 cm)'
             LABEL(2)= 'density (gm*cm**(-3))'
             CALL LGLNAX
          END IF
        END IF
C
C       output results
        IF (IPLOT .EQ. 1) THEN
C         total mass vs. final radius
          IF (DEVICE .EQ. FILE) THEN
              WRITE (GUNIT,80)
              WRITE (GUNIT,70) (RADIUS(IM),MSTOR(IM),IM=1,NMODEL)
          ELSE
             CALL XYPLOT (RADIUS,MSTOR)
          END IF
C
        ELSE
C         density(r) vs. r for each model
          DO 30 IM=1,NMODEL
             NPOINT=NSTEP(IM)+1
             DO 40 IR=0,NPOINT-1
                R(IR)=RMIN(IM)+IR*STEP(IM)
                DEN(IR)=RHOSTR(IM,IR)
40           CONTINUE
             IF (DEVICE .EQ. FILE) THEN
                 WRITE (GUNIT,85) IM
                 WRITE (GUNIT,70) (R(IR),DEN(IR),IR=0,NPOINT)
             ELSE
                CALL XYPLOT(R,DEN)
             END IF
30        CONTINUE
        END IF
20    CONTINUE
C
      IPLOT=NPLOT
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)  !end graphing package
      IF (DEVICE .EQ. SCREEN) CALL TMODE        !switch to text mode
C
70    FORMAT (2(5X,E11.3))
80    FORMAT (/,10X,'radius',10X,'mass')
85    FORMAT (/,'  Density vs. radius for model ',I2)
100   FORMAT (/,' Patience, please; output going to a file.')
C
      RETURN
      END


module diffusion_mod
    use, intrinsic :: iso_fortran_env, only : SP => REAL32, error_unit
    implicit none

    public :: diffusion_step

contains

    subroutine init_system(n, temp, new_temp)
        implicit none
        integer, value :: n
        real(kind=SP), dimension(:, :), allocatable, intent(out) :: temp
        real(kind=SP), dimension(:, :), allocatable, intent(out) :: new_temp
        integer :: istat

        allocate (temp(n, n), new_temp(n, n), stat=istat)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: can not allocate arrays'
            stop 1
        end if
        temp(1, :) = 1.0_SP
        temp(2:, :) = 0.0_SP
        new_temp = temp
        !$acc enter data copyin(temp, new_temp)
    end subroutine init_system

    subroutine diffusion_step(temp, new_temp, error)
        implicit none
        real(kind=SP), dimension(:, :), intent(in) :: temp
        real(kind=SP), dimension(:, :), intent(out) :: new_temp
        real(kind=SP) :: error
        integer :: i, j

        error = 0.0_SP
        !$acc kernels present(temp, new_temp)
        do j = 2, size(temp, 2) - 1
            do i = 2, size(temp, 1) - 1
                new_temp(i, j) = 0.25_SP*(temp(i - 1, j) + temp(i, j - 1) + &
                                          temp(i + 1, j) + temp(i, j + 1))
                error = max(error, abs(new_temp(i, j) - temp(i, j)))
            end do
        end do
        !$acc end kernels
    end subroutine diffusion_step

    subroutine swap(temp, new_temp)
        implicit none
        real(kind=SP), dimension(:, :), intent(in) :: temp
        real(kind=SP), dimension(:, :), intent(out) :: new_temp
        integer :: i, j

        !$acc kernels present(temp, new_temp)
        do j = 1, size(temp, 2)
            do i = 1, size(temp, 1)
                new_temp(i, j) = temp(i, j)
            end do
        end do
        !$acc end kernels
    end subroutine swap

    subroutine dealloc_system(temp, new_temp)
        real(kind=SP), dimension(:, :), allocatable, intent(inout) :: temp, new_temp

        !$acc exit data delete(temp, new_temp)
        deallocate (temp, new_temp)
    end subroutine dealloc_system

    subroutine print_system(temp)
        implicit none
        real(kind=SP), dimension(:, :), intent(in) :: temp
        integer :: i

        do i = 1, size(temp, 1)
             print '(*(E10.3))', temp(i, :)
         end do
    end subroutine print_system

end module diffusion_mod


! This file is provided as part of the "projet long" for the "Calcul Scientifique et Analyse de Données" course
! at INP-ENSEEIHT
! Date: 02/2018
! Authors: P. Amestoy, P. Berger, A. Buttari, Y. Diouane, S. Gratton, R. Guivarch, F.H. Rouet, E. Simon
!
! This file contains the driver for testing the developed methods
!
program main
  implicit none
  integer                       :: ierr, m, n, maxit, lwork, i, j, it, n_ev, disp, version, imat, p
  double precision, allocatable :: a(:,:), work(:)
  double precision, allocatable :: w(:), w_aux(:), e_vect(:,:), u(:)
  double precision, allocatable :: e_vals(:), res_ev(:)
  integer, allocatable          :: it_ev(:)
  integer                       :: t_start, t_end, t_rate, len
  double precision              :: time, eps, res, percentage, dummy, accuracy
  double precision, parameter   :: done = 1.d0, dzero = 0.d0
  character (len=20)            :: version_str
  double precision              :: normF_A, workf(1)

  ! external functions
  double precision, external    :: dlange, dnrm2

  !! parameter initializations
  ierr = 0

  !! THOSE ARE THE ONLY VALUES YOU ARE ALLOWED TO MODIFY IN THIS FILE
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  maxit = 30000
  eps = 1d-15
  p = 20
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call parse_args(n, m, version, imat, percentage, disp)

  allocate(a(n,n), e_vals(n), stat=ierr)
  if(ierr .ne.0) then
    write(*,'("Cannot allocate data, Input matrix is too big")')
    stop
  endif

  ! Generate the matrix
  call matgen(imat, a, n, n, e_vals, ierr)

  if(disp >= 1) then
     write(*,'(" ")')
     write(*,'("Here are the first ",i2," eigenvalues: ")', advance='no')min(n,10)
     do i=1, min(n,10)
        write(*,'(f10.3,x)',advance='no') e_vals(i)
     end do
     write(*,'(" ")')

     ! print the spectrum of the matrix in 'spectrum.txt'
     open(20, file='spectrum.txt')
     do i = 1,n
       write(20,'(f10.3,x)') e_vals(i)
     end do
     close(20)
  end if

  write(version_str, "(I2)") version

  normF_A = dlange('f', n, n, a, n, workf)

  write(*,*)
  select case(version)

   case(10)

     write(*,'("Calling LAPACK DSYEV on A")')

     lwork=2*max(1,3*n+n,5*n)
     allocate(w(n), work(lwork), e_vect(n,n), w_aux(n), stat=ierr)
     if(ierr .ne.0) then
        write(*,'("Cannot allocate data, Input matrix is too big for the LAPACK version")')
        stop
     endif

     call system_clock(t_start)
     call dsyev('v', 'u', n, a, n, w_aux, work, lwork, ierr)
      do i=1, n
        e_vect(:, i) = a(:, n-i +1)
        w(i) = w_aux(n-i +1)
      end do
     call system_clock(t_end, t_rate)
     time = real(t_end-t_start)/real(t_rate)

     write(*,'("End of LAPACK DSYEV")')

     m = 10
     n_ev   = m

  case(11)

    write(*,'("Calling the basic deflated power method")')

     allocate(w(m), e_vect(n, m), it_ev(m), res_ev(m), stat=ierr)
     if(ierr .ne.0) then
        write(*,'("Cannot allocate data.")')
        stop
     endif

     call system_clock(t_start)
     call deflated_power_method(n, m, a, percentage, maxit, eps, w, e_vect, n_ev, res_ev, it_ev, ierr)
     call system_clock(t_end, t_rate)
     time = real(t_end-t_start)/real(t_rate)

     write(*,'("End of the basic deflated power method")')

     select case(ierr)
     case(-3)
       write(*,*) "maxit reached : ERROR"
       write(*,*) "hints: increase maxit or decrease eps in main.f90"
     case(-2)
       write(*,*) "allocation problem : ERROR"
     case(-1)
       write(*,*) "parameters consistancy : ERROR"
     case(0)
       write(*,'(" ")')
       write(*,'("percentage ", f5.2, " reached with ", i4, " eigenvalues")') percentage, n_ev
     case(1)
       write(*,'("percentage ", f5.2, " NOT reached with ", i4, " eigenvalues")') percentage, n_ev
     end select

   case(0)

     write(*,'("Calling the basic subspace iteration method v0")')

     allocate(w(m), e_vect(n, m), it_ev(m), stat=ierr)
     if(ierr .ne.0) then
        write(*,'("Cannot allocate data.")')
        stop
     endif

     call random_number(e_vect)

     call system_clock(t_start)
     call subspace_iter_v0(n, m, a, maxit, eps, e_vect, w, res, it, ierr)
     call system_clock(t_end, t_rate)
     time = real(t_end-t_start)/real(t_rate)
     write(*,'("End of the basic subspace iteration method")')

     select case(ierr)
     case(-4)
       write(*,'("Problem in dsyev : ERROR")')
     case(-3)
       write(*,*) "maxit reached : ERROR"
       write(*,*) "hints: increase maxit or decrease eps in main.f90"
     case(-2)
       write(*,*) "allocation problem : ERROR"
     case(-1)
       write(*,*) "parameters consistancy : ERROR"
     case(0)
       write(*,'(" ")')
       write(*,'(i4, " Eigenvalues computed in ", i10, " iterations with a residual of", e10.3 )') m, it, res
     end select

     n_ev = m

   case(1)

     write(*,'("Calling the subspace iteration method v1")')

     allocate(w(m), e_vect(n, m), it_ev(m), res_ev(m), stat=ierr)
     if(ierr .ne.0) then
        write(*,'("Cannot allocate data.")')
        stop
     endif

     call random_number(e_vect)

     call system_clock(t_start)
     call subspace_iter_v1(n, m, a, percentage, maxit, eps, e_vect, w, n_ev, res_ev, it_ev, ierr)
     call system_clock(t_end, t_rate)
     time = real(t_end-t_start)/real(t_rate)

     write(*,'("End the subspace iteration method v1")')

     select case(ierr)
     case(-4)
       write(*,'("Problem in dsyev : ERROR")')
     case(-3)
       write(*,*) "maxit reached : ERROR"
       write(*,*) "hints: increase maxit or decrease eps in main.f90"
     case(-2)
       write(*,*) "allocation problem : ERROR"
     case(-1)
       write(*,*) "parameters consistancy : ERROR"
     case(0)
       write(*,'(" ")')
       write(*,'("percentage ", f5.2, " reached with ", i4, " eigenvalues")') percentage, n_ev
     case(1)
       write(*,'("percentage ", f5.2, " NOT reached with ", i4, " eigenvalues")') percentage, n_ev
     end select

     write(*,*) 'n_ev =', n_ev

  case(2)

     write(*,'("Calling the subspace iteration method v2")')

     allocate(w(m), e_vect(n, m), it_ev(m), res_ev(m), stat=ierr)
     if(ierr .ne.0) then
        write(*,'("Cannot allocate data.")')
        stop
     endif

     call random_number(e_vect)

     call system_clock(t_start)
     call subspace_iter_v2(n, m, a, p, percentage, maxit, eps, e_vect, w, n_ev, res_ev, it_ev, ierr)
     call system_clock(t_end, t_rate)
     time = real(t_end-t_start)/real(t_rate)

     write(*,'("End the subspace iteration method v2")')

     select case(ierr)
     case(-4)
       write(*,'("Problem in dsyev : ERROR")')
     case(-3)
       write(*,*) "maxit reached : ERROR"
       write(*,*) "hints: increase maxit or decrease eps in main.f90"
     case(-2)
       write(*,*) "allocation problem : ERROR"
     case(-1)
       write(*,*) "parameters consistancy : ERROR"
     case(0)
       write(*,'(" ")')
       write(*,'("percentage ", f5.2, " reached with ", i4, " eigenvalues")') percentage, n_ev
     case(1)
       write(*,'("percentage ", f5.2, " NOT reached with ", i4, " eigenvalues")') percentage, n_ev
     end select

     write(*,*) 'n_ev =', n_ev

  case(3)

     write(*,'("Calling the subspace iteration method v3")')

     allocate(w(m), e_vect(n, m), it_ev(m), res_ev(m), stat=ierr)
     if(ierr .ne.0) then
        write(*,'("Cannot allocate data.")')
        stop
     endif

     call random_number(e_vect)

     call system_clock(t_start)
     ! CHANGE to v3 when you are ready to test this version
     call subspace_iter_v2(n, m, a, p, percentage, maxit, eps, e_vect, w, n_ev, res_ev, it_ev, ierr)
     call system_clock(t_end, t_rate)
     time = real(t_end-t_start)/real(t_rate)

     write(*,'("End the subspace iteration method v3")')

     select case(ierr)
     case(-4)
       write(*,'("Problem in dsyev : ERROR")')
     case(-3)
       write(*,*) "maxit reached : ERROR"
       write(*,*) "hints: increase maxit or decrease eps in main.f90"
     case(-2)
       write(*,*) "allocation problem : ERROR"
     case(-1)
       write(*,*) "parameters consistancy : ERROR"
     case(0)
       write(*,'(" ")')
       write(*,'("percentage ", f5.2, " reached with ", i4, " eigenvalues")') percentage, n_ev
     case(1)
       write(*,'("percentage ", f5.2, " NOT reached with ", i4, " eigenvalues")') percentage, n_ev
     end select

     write(*,*) 'n_ev =', n_ev

   case default
     write(*,'("Version is not valid or yet implemented")')

   end select

   if(ierr.ge.0) then
     if(disp >= 1) then
       write(*,'(" ")')
       write(*,'(" ")')
       write(*,'(i4, " First eigenvalues ")') min(n_ev,m)
       write(*,*) "========================="
       do i=1, min(n_ev, m)
         select case(version)
           case(10)
             write(*,'("Eigenvalue ",i4,":",f10.3)') i, w(i)
           case(11)
             write(*,'("Eigenvalue ",i4,":",f10.3, "   accuracy :", e10.3, "   number of iterations : ",i10)') &
            i, w(i), res_ev(i), it_ev(i)
           case(0)
              write(*,'("Eigenvalue ",i4,":",f10.3)') i, w(i)
           case(1)
             write(*,'("Eigenvalue ",i4,":",f10.3, "   accuracy :", e10.3, "   number of iterations : ",i10)') &
            i, w(i), res_ev(i), it_ev(i)
           case(2)
             write(*,'("Eigenvalue ",i4,":",f10.3, "   accuracy :", e10.3, "   number of iterations : ",i10)') &
            i, w(i), res_ev(i), it_ev(i)
         end select
       end do
        write(*,'(" ")')
     end if

     if(disp >= 2) then
       ! check the accuracy ||A*V_i - Lambda_i*V_i||/|Lambda_i| for each pair

       allocate(u(n))
       ! A is lost with DSYEV and power
       if(version >= 10) then
         call matgen(imat, a, n, n, e_vals, ierr)
       end if

       write(*,*)  '||A*V_i - Lambda_i*V_i||/||A||'
       write(*,*)  "=============================="
       do i = 1, min(n_ev, m)
         call dgemv('n', n, n, done, a, n, e_vect(1,i), 1, dzero, u, 1)
         u = u - w(i)*e_vect(:,i)
         write(*, '("Eigenvalue ",i4,":",e10.3)') i, dnrm2(n, u, 1) / normF_A
       end do
       deallocate(u)

       if(disp == 3) then
         ! save eigenvectors in a file
         open(20, file="eigenvectors_"//trim(adjustl(version_str))//".txt")
         do i = 1, n
           do j = 1, min(n_ev, m)
             write(20,'(f10.6,x)', advance='no') e_vect(i, j)
           end do
           write(20, *) ''
         end do
         close(20)
       end if

     end if

  else
     write(*,'("An error was found. IERR=",i4)')ierr
  end if

  deallocate(a, w, stat=ierr)

  if(allocated(e_vect)) deallocate(e_vect, stat=ierr)
  if(allocated(w_aux)) deallocate(w_aux, stat=ierr)
  if(allocated(work)) deallocate(work, stat=ierr)
  if(allocated(res_ev)) deallocate(res_ev, stat=ierr)
  if(allocated(it_ev)) deallocate(it_ev, stat=ierr)

  write(*,*)
  write(*,*) "=================================="
  write(*,*) 'Time = ', time
  write(*,*) "=================================="

  stop

end program main


!
MODULE ConstantsModule
  !
  !  This module provides commonly used constants of all types.
  !
  ! ==================== Other Modules
  !
  USE IntrinsicTypesModule, ONLY : &
       &  RK => REAL_KIND, IK => INTEGER_KIND, LK => LOGICAL_KIND
  !
  IMPLICIT NONE
  !
  PRIVATE RK, IK, LK
  !
  ! ==================== Public Entities
  !
  PUBLIC ! all public
  !
  ! ========== Reals
  !
  !  Values for real constants are prefixed with
  !  "RK_" to indicate the default "REAL KIND".
  !  Below, the values are of the right type because of the
  !  rules for intrinsic assignment.
  !
  !  --- Real form of integers
  !
  REAL(RK), PUBLIC, PARAMETER ::&
       &  RK_ZERO  = 0.0_RK, RK_ONE  = 1.0_RK, RK_TWO = 2.0_RK, &
       &  RK_THREE = 3.0_RK, RK_FOUR = 4.0_RK, RK_SIX = 6.0_RK, &
       &  RK_180   = 180.0_RK
  !
  !  --- Common fractions.
  !
  REAL(RK), PUBLIC, PARAMETER ::&
       &  RK_ONE_HALF = 0.5_RK, RK_ONE_THIRD = RK_ONE/RK_THREE
  !
  !  --- Things related to pi.
  !
  !  The values for pi and various other numbers were  computed to 50
  !  decimal places using `bc'.  They could not be initialized here since
  !  they involve intrinsic functions and would have to be set at run-time.
  !
  REAL(RK), PUBLIC, PARAMETER ::&
       &    RK_PI = 3.14159265358979323846264338327950288419716939937508_RK
  !
  REAL(RK), PUBLIC, PARAMETER ::&
       &       RK_TWO_PI = RK_PI*RK_TWO,  &
       &    RK_PI_OVER_2 = RK_PI/RK_TWO,  &
       &    RK_PI_OVER_3 = RK_PI/RK_THREE,&
       &    RK_PI_OVER_4 = RK_PI/RK_FOUR, &
       &    RK_PI_OVER_6 = RK_PI/RK_SIX,  &
       &  RK_PI_OVER_180 = RK_PI/RK_180,  &
       &  RK_180_OVER_PI = RK_180/RK_PI

  REAL(RK), PUBLIC, PARAMETER ::&             !  For convenience ...
       &  DEGREES_PER_RADIAN = RK_180_OVER_PI,&
       &  RADIANS_PER_DEGREE = RK_PI_OVER_180
  !
  !  --- Architecture-Related Values
  !
  REAL(RK), PUBLIC, PARAMETER :: RK_HUGE = HUGE(RK_ONE)
  !
  !  --- Algebraic Numbers
  !
  !  Various roots, golden section.
  !
  !
  REAL(RK), PUBLIC, PARAMETER ::&
       &   RK_ROOT_2 =&
       &      1.41421356237309504880168872420969807856967187537694_RK,&
       &   RK_ROOT_3 =&
       &      1.73205080756887729352744634150587236694280525381038_RK,&
       &   RK_ROOT_5 =&
       &      2.23606797749978969640917366873127623544061835961152_RK,&
       &   RK_ROOT_7 =&
       &      2.64575131106459059050161575363926042571025918308245_RK
  !
  REAL(RK), PUBLIC, PARAMETER ::&
       &   RK_ROOT_6        = RK_ROOT_2 * RK_ROOT_3,&
       &   RK_ROOT_14       = RK_ROOT_2 * RK_ROOT_7,&
       &   RK_ROOT_3_HALVES = RK_ROOT_3/RK_ROOT_2,&
       &   RK_GOLD          = RK_ONE_HALF * (RK_ROOT_5 + RK_ONE),&
       &   RK_GOLD_CONJ     = RK_ONE_HALF * (RK_ROOT_5 - RK_ONE)
  !
  ! ========== Integers
  !
  INTEGER(IK), PUBLIC, PARAMETER :: &
       &  IK_ZERO = 0_IK, IK_ONE = 1_IK, IK_TWO = 2_IK, IK_THREE = 3_IK,&
       &  IK_FOUR = 4_IK
  !
  ! ========== Logicals
  !
  LOGICAL(LK), PUBLIC, PARAMETER :: &
       &  TRUE = .TRUE., FALSE = .FALSE.
  !
  ! ========== Characters
  !
  !  ASCII numbers of various characters.
  !
  CHARACTER, PUBLIC, PARAMETER ::&
       &  ASCII_TAB  = ACHAR(9),  ASCII_NULL  = ACHAR(0),&
       &  ASCII_BELL = ACHAR(7),  ASCII_BACK  = ACHAR(8),&
       &  ASCII_LF   = ACHAR(10), ASCII_VTAB  = ACHAR(11),&
       &  ASCII_CR   = ACHAR(13), ASCII_SPACE = ACHAR(32)
  !
  CHARACTER(LEN=*), PUBLIC, PARAMETER :: WHITESPACE = ASCII_SPACE//ASCII_TAB
  !
END MODULE ConstantsModule


module logspace

  use types, only: dp

  implicit none

contains

  elemental function log1p(x) result (y)
    real(dp), intent(in) :: x
    real(dp) :: y
    real(dp), volatile :: z

    z = 1.0d0 + x
    if (z == 0) then
       y = log(z)
    else
       y = log(z) - ((z - 1.0d0) - x) / z    ! cancels errors with IEEE arithmetic
    end if
  end function log1p

  function logadd(x, y) result (sum)
    use ieee_constants, only: isneginf

    real(dp), intent(in) :: x, y
    real(dp) :: sum

    if (isneginf(x)) then
       sum = y
    else if (isneginf(y)) then
       sum = x
    else
       sum = max(x, y) + log1p(exp(-abs(x - y)))
    end if
  end function logadd

end module logspace


!*==slagtf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAGTF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, N
!       REAL               LAMBDA, TOL
!       ..
!       .. Array Arguments ..
!       INTEGER            IN( * )
!       REAL               A( * ), B( * ), C( * ), D( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
!> tridiagonal matrix and lambda is a scalar, as
!>
!>    T - lambda*I = PLU,
!>
!> where P is a permutation matrix, L is a unit lower tridiagonal matrix
!> with at most one non-zero sub-diagonal elements per column and U is
!> an upper triangular matrix with at most two non-zero super-diagonal
!> elements per column.
!>
!> The factorization is obtained by Gaussian elimination with partial
!> pivoting and implicit row scaling.
!>
!> The parameter LAMBDA is included in the routine so that SLAGTF may
!> be used, in conjunction with SLAGTS, to obtain eigenvectors of T by
!> inverse iteration.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix T.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (N)
!>          On entry, A must contain the diagonal elements of T.
!>
!>          On exit, A is overwritten by the n diagonal elements of the
!>          upper triangular matrix U of the factorization of T.
!> \endverbatim
!>
!> \param[in] LAMBDA
!> \verbatim
!>          LAMBDA is REAL
!>          On entry, the scalar lambda.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (N-1)
!>          On entry, B must contain the (n-1) super-diagonal elements of
!>          T.
!>
!>          On exit, B is overwritten by the (n-1) super-diagonal
!>          elements of the matrix U of the factorization of T.
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is REAL array, dimension (N-1)
!>          On entry, C must contain the (n-1) sub-diagonal elements of
!>          T.
!>
!>          On exit, C is overwritten by the (n-1) sub-diagonal elements
!>          of the matrix L of the factorization of T.
!> \endverbatim
!>
!> \param[in] TOL
!> \verbatim
!>          TOL is REAL
!>          On entry, a relative tolerance used to indicate whether or
!>          not the matrix (T - lambda*I) is nearly singular. TOL should
!>          normally be chose as approximately the largest relative error
!>          in the elements of T. For example, if the elements of T are
!>          correct to about 4 significant figures, then TOL should be
!>          set to about 5*10**(-4). If TOL is supplied as less than eps,
!>          where eps is the relative machine precision, then the value
!>          eps is used in place of TOL.
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is REAL array, dimension (N-2)
!>          On exit, D is overwritten by the (n-2) second super-diagonal
!>          elements of the matrix U of the factorization of T.
!> \endverbatim
!>
!> \param[out] IN
!> \verbatim
!>          IN is INTEGER array, dimension (N)
!>          On exit, IN contains details of the permutation matrix P. If
!>          an interchange occurred at the kth step of the elimination,
!>          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
!>          returns the smallest positive integer j such that
!>
!>             abs( u(j,j) ) <= norm( (T - lambda*I)(j) )*TOL,
!>
!>          where norm( A(j) ) denotes the sum of the absolute values of
!>          the jth row of the matrix A. If no such j exists then IN(n)
!>          is returned as zero. If IN(n) is returned as positive, then a
!>          diagonal element of U is small, indicating that
!>          (T - lambda*I) is singular or nearly singular,
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the kth argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup auxOTHERcomputational
!
!  =====================================================================
      SUBROUTINE SLAGTF(N,A,Lambda,B,C,Tol,D,In,Info)
      IMPLICIT NONE
!*--SLAGTF160
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , N
      REAL Lambda , Tol
!     ..
!     .. Array Arguments ..
      INTEGER In(*)
      REAL A(*) , B(*) , C(*) , D(*)
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      INTEGER k
      REAL eps , mult , piv1 , piv2 , scale1 , scale2 , temp , tl
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. External Functions ..
      REAL SLAMCH
      EXTERNAL SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Executable Statements ..
!
      Info = 0
      IF ( N<0 ) THEN
         Info = -1
         CALL XERBLA('SLAGTF',-Info)
         RETURN
      ENDIF
!
      IF ( N==0 ) RETURN
!
      A(1) = A(1) - Lambda
      In(N) = 0
      IF ( N==1 ) THEN
         IF ( A(1)==ZERO ) In(1) = 1
         RETURN
      ENDIF
!
      eps = SLAMCH('Epsilon')
!
      tl = MAX(Tol,eps)
      scale1 = ABS(A(1)) + ABS(B(1))
      DO k = 1 , N - 1
         A(k+1) = A(k+1) - Lambda
         scale2 = ABS(C(k)) + ABS(A(k+1))
         IF ( k<(N-1) ) scale2 = scale2 + ABS(B(k+1))
         IF ( A(k)==ZERO ) THEN
            piv1 = ZERO
         ELSE
            piv1 = ABS(A(k))/scale1
         ENDIF
         IF ( C(k)==ZERO ) THEN
            In(k) = 0
            piv2 = ZERO
            scale1 = scale2
            IF ( k<(N-1) ) D(k) = ZERO
         ELSE
            piv2 = ABS(C(k))/scale2
            IF ( piv2<=piv1 ) THEN
               In(k) = 0
               scale1 = scale2
               C(k) = C(k)/A(k)
               A(k+1) = A(k+1) - C(k)*B(k)
               IF ( k<(N-1) ) D(k) = ZERO
            ELSE
               In(k) = 1
               mult = A(k)/C(k)
               A(k) = C(k)
               temp = A(k+1)
               A(k+1) = B(k) - mult*temp
               IF ( k<(N-1) ) THEN
                  D(k) = B(k+1)
                  B(k+1) = -mult*D(k)
               ENDIF
               B(k) = temp
               C(k) = mult
            ENDIF
         ENDIF
         IF ( (MAX(piv1,piv2)<=tl) .AND. (In(N)==0) ) In(N) = k
      ENDDO
      IF ( (ABS(A(N))<=scale1*tl) .AND. (In(N)==0) ) In(N) = N
!
!
!     End of SLAGTF
!
      END SUBROUTINE SLAGTF