! Compute the analytic solution for the multigroup radiating sphere
! problem.  We follow the problem outline from Swesty and Myra (2009).
!
! The output from this is the radiation energy density as a function
! of energy group at a specified distance (r_obs) from the radiating
! sphere, at a time of t_obs.

module constants_module

  ! fundamental constants
  use amrex_fort_module, only : rt => amrex_real
  real(rt)        , parameter :: h_planck =  6.62606957e-27_rt  ! erg s
  real(rt)        , parameter :: k_B = 1.3806488e-16_rt  ! erg / K
  real(rt)        , parameter :: c_light = 2.99792458e10_rt  ! cm / s
  real(rt)        , parameter :: ev2erg = 1.602176487e-12_rt ! erg/eV
  real(rt)        , parameter :: pi = 3.14159265358979323846e0_rt

  ! problem parameters

  ! we will specify the opacity as kappa = kapp_0 (nu_0 / nu)**3
  ! where nu_0 is a reference frequency
  !
  ! Swesty and Myra (2009) only say that the "opacity of the material
  ! is proportional to 1/E**3", but they don't give the proportionality
  ! constant.  The output depends critically on the constant.  Eric
  ! says that they used kappa = 1.e13 * (1.5e-6 MeV / E)**3
  !
  ! Converting 1.5e-6 MeV to a frequency gives nu_0 = 3.63e14 Hz
  real(rt)        , parameter :: nu_0 = 3.6e14  ! ref. freq (Hz)
  real(rt)        , parameter :: kappa_0 = 1.e13  ! scattering opacity (1/cm)

  ! specify the energy groups.  Ultimately we will work in terms of
  ! frequency, but we set the limits in terms of energy.
  integer, parameter :: ngroups_derive = 60          ! number of groups to compute
  real(rt)        , parameter :: E_min = 0.5e0_rt*ev2erg ! min group energy (erg)
  real(rt)        , parameter :: E_max = 306e3_rt*ev2erg ! max group energy (erg)

  ! instead of computing the group structure based on the above, read the group
  ! structure in from group_structure.dat
  logical, parameter :: use_group_file = .true.

  ! geometry parameters
  real(rt)        , parameter :: R_sphere = 0.02e0_rt ! sphere radius (cm)
  real(rt)        , parameter :: r_obs = 0.06e0_rt  ! observer location (cm)

  ! physical parameters
  real(rt)        , parameter :: T_0 = 50.e0_rt*ev2erg/k_B ! ambient temp (K)
  real(rt)        , parameter :: T_sphere = 1500.e0_rt*ev2erg/k_B ! sphere temp (K

  ! output time (t_obs = 1.e-12_rt is a good value to try)
  real(rt)        , parameter :: t_obs = 1.e-12_rt  ! observation time (s)

end module constants_module

function safe_print(x) result (sx)
  use amrex_fort_module, only : rt => amrex_real
  implicit none
  real(rt)         :: x, sx
  sx = x
  if (x < 1.e-99_rt) sx = 0.e0_rt

  return
end function safe_print

function planck(nu,T) result (B)

  ! the Planck function for a Blackbody (actually, energy density,
  ! B = (4 pi / c) I, where I is the normal Planck function
  !
  ! nu = frequency (Hz)
  ! T  = temperature (K)

  ! see Swesty and Myra (2009), eq. 23, but note that we are working
  ! in Hz here, so we have units of erg / cm^3 / Hz, where they
  ! have units of erg / cm^3 / MeV.  As a result, we have one
  ! less factor of h_planck.
  use constants_module
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: nu, T
  real(rt)         :: B

  B = (8.e0_rt*pi*h_planck*nu**3/c_light**3)/(exp(h_planck*nu/(k_B*T)) - 1.e0_rt)

  return
end function planck

function F_radsphere(r,t,nu) result (F)

  ! the function F(r,t) as defined in Swesty and Myra
  !
  ! r      = position
  ! t      = time (s)
  ! nu     = frequency (Hz)

  use constants_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: r, t, nu

  real(rt)         :: E, kappa, erfc_term1, erfc_term2, F

  real(rt)         :: sferfc, sfexp, arg1

  ! to guard against over/underflows, we define some 'safe' functions
  ! (they come from Eric)
  sferfc(arg1) = erfc(max(-26.0e0_rt,min(26.0e0_rt,arg1)))
  sfexp(arg1) = exp(max(-650.0e0_rt,min(650.0e0_rt,arg1)))

  kappa = kappa_0*(nu_0/nu)**3

  erfc_term1 = sferfc(sqrt(3.e0_rt*kappa/(4.e0_rt*c_light*t))*(r - R_sphere) - &
                      sqrt(c_light*t*kappa))

  erfc_term2 = sferfc(sqrt(3.e0_rt*kappa/(4.e0_rt*c_light*t))*(r - R_sphere) + &
                    sqrt(c_light*t*kappa))

  F = 0.5*(sfexp(-sqrt(3.e0_rt)*kappa*(r - R_sphere))*erfc_term1 + &
           sfexp( sqrt(3.e0_rt)*kappa*(r - R_sphere))*erfc_term2)

  return

end function F_radsphere

program analytic

  ! compute the analytic solution to the radiating sphere, as given
  ! by Swesty and Myra (2009), Eq. 76.

  use constants_module

  implicit none

  integer :: ngroups
  real(rt)        , allocatable :: nu_groups(:), dnu_groups(:), xnu(:)
  real(rt)         :: alpha
  real(rt)         :: E, F
  real(rt)         :: F_radsphere, planck
  real(rt)         :: safe_print
  integer :: n

  character(len=256) :: header_line
  integer :: ipos

  if (use_group_file) then
     ! open the file
     open(unit=10,file="group_structure.dat")

     ! read in the number of groups
     read(10,fmt='(a256)') header_line
     ipos = index(header_line, "=") + 1
     read (header_line(ipos:),*) ngroups

     allocate (nu_groups(ngroups), dnu_groups(ngroups))

     ! skip the next header line
     read(10,*) header_line

     ! read in the group centers and weights (widths)
     do n = 1, ngroups
        read(10,*) nu_groups(n), dnu_groups(n)
     enddo

  else
     ngroups = ngroups_derive
     allocate(nu_groups(ngroups),dnu_groups(ngroups),xnu(ngroups+1))

     ! try to mimic the way the groups are setup in RadMultiGroup.cpp

     ! do geometrically spaced group BOUNDARIES
     xnu(1) = E_min/h_planck
     alpha = (E_max/E_min)**(1.e0_rt/(ngroups))

     do n = 2, ngroups+1
        xnu(n) = alpha*xnu(n-1)
     enddo

     do n = 1, ngroups
        nu_groups(n) = 0.5e0_rt*(xnu(n) + xnu(n+1))
     enddo

     do n = 1, ngroups
        if (n == 1) then
           dnu_groups(n) = 0.5e0_rt*(nu_groups(2) - nu_groups(1))

        else if (n < ngroups) then
           dnu_groups(n) = 0.5e0_rt*(nu_groups(n+1) - nu_groups(n-1))

        else
           dnu_groups(n) = 0.5e0_rt*(nu_groups(n) - nu_groups(n-1))
        endif

     enddo

  endif

  ! debug -- print out the group structure
  !do n = 1, ngroups
  !   print *, nu_groups(n), dnu_groups(n)
  !enddo

  ! compute the analytic radiating sphere solution for each point
1000 format(1x, i3, 4(1x,g20.10))

  print *, "# group, group center (Hz), analytic sol. (erg/cm^3/Hz), &
       &analytic sol. * group width (erg/cm^3), ambient BB spectrum (erg/cm^3/Hz)"
  do n = 1, ngroups
     F = F_radsphere(r_obs,t_obs,nu_groups(n))
     E = planck(nu_groups(n),T_0) + &
          (R_sphere/r_obs)*(planck(nu_groups(n),T_sphere) - &
                            planck(nu_groups(n),T_0))*F
     write(*,1000) n, nu_groups(n), &
          safe_print(E*dnu_groups(n)), safe_print(E)

  enddo

end program analytic


! Name: Arpit Kumar Jain Roll No: 180122009
PROGRAM PIB_Tunneling_HW5
    IMPLICIT NONE

    ! Declaration of Variables
    COMPLEX, PARAMETER:: iota = (0., 1.)
    REAL, ALLOCATABLE:: potential(:), x(:), probabilityDensity(:)
    COMPLEX, ALLOCATABLE:: psi(:)
    REAL:: xmax, xmin, dx, E, k, maxima, minima, Pavg, transmissionProbability
    INTEGER:: nx, i

    ! nx is number of grid points
    nx = 1000
    xmax = 10.000
    xmin = 0.000
    dx = 0.010
    ALLOCATE(potential(0:nx), x(0:nx), psi(0:nx), probabilityDensity(0:nx))

    ! Defining grid points
    DO i = 0, nx
        x(i) = xmin + (i)*dx
    ENDDO

    ! Potential Array with barrier
    DO i = 0, nx
        IF(x(i) .LT. 4) THEN
            potential(i) = 0.00
        ELSE IF(x(i) .LE. 5) THEN
            potential(i) = 9.00
        ELSE
            potential(i) = 0.00
        ENDIF
    ENDDO

    ! Calculation of transmission_probability for E = 1 eV to 26 eV with deltaE = 0.1 eV
    OPEN(UNIT = 20, FILE = 'transmission_probability.txt')

        ! Initialize E to 1.0 eV
        E = 1.000
        ! Loop till E is less than 26.1 eV means till E = 26.000 eV
        DO WHILE(E .LT. 26.100)

            ! k = sqrt(2mE/hbar**2) and m = hbar = 1 so
            k = sqrt(2*E)

            ! ψ0 = exp(−ikx) = 1 because x = 0.00
            psi(0) = (1., 0.)

            ! ψ1 = exp(−ik×dx)
            psi(1) = EXP(-iota * k * dx)

            ! Calculate all other ψ(j+1) with ψ(j) and ψ(j-1) with finite-difference method
            DO i = 1, nx-1
                psi(i+1) = (2 - 2 * (E - potential(i)) * dx * dx) * psi(i) - psi(i-1)
            ENDDO

            ! probability density =  |ψ x ψ*|
            probabilityDensity = abs(psi * conjg(psi))

            ! Calculate maxima and minima of probabilityDensity curve after 600th point
            ! (Far away point so no effect of barrier)
            maxima = 0.0
            minima = 100000.0
            DO i = 600, nx
                maxima = max(maxima, probabilityDensity(i))
                minima = min(minima, probabilityDensity(i))
            ENDDO

            Pavg = (maxima + minima) / 2.0
            transmissionProbability = 2.0 / (1 + Pavg)

            ! Write transmissionProbability in file named 'transmission_probability.txt'
            WRITE(20, 10) E, transmissionProbability
            10 FORMAT(f6.3, 3x, f5.3)

            ! If our Energy is 9.000 than write this probabilityDensity in file named 'probability_density.txt'
            ! E = 9.0000012 there is some digit at 6th digit so direct (E .EQ. 9.0) does not work
            IF (abs(E - 9.000) < 0.0001) THEN
                OPEN(UNIT = 21, FILE = 'probability_density.txt')
                ! WRITE(*, *) "plot '-' using 1:2 with lines"
                    DO i = 0, nx
                        WRITE(21, 11) x(i), probabilityDensity(i)
                        11 FORMAT(f6.3, 3x, f6.3)
                    ENDDO
                CLOSE(21)
            ENDIF

            ! Increase E by 0.100 (deltaE)
            E = E + 0.100
        ENDDO
    CLOSE(20)
    ! CALL execute_command_line('gnuplot -p plot.gnu')

END PROGRAM PIB_Tunneling_HW5

5. Home Assignment-2 on Tunneling/Arpit_HW5.f90


subroutine sky_to_patch(inmap,npix,npatch,patch,numpa,lp)
Implicit none

integer, intent (inout) :: npatch,npix,lp,numpa
real, intent (in) :: inmap(npix)
Real ,intent (out) :: patch(numpa,lp,lp)
integer :: nside,i,j,k,face_num,nn,boi,np,nf,pow,n,xp,yp,pa
integer,allocatable :: a(:),p(:),q(:)
real  ns,base,di,x,y

base=2.0
di=npatch     !tedade morabbaA dar zelE
pa=di**2        !tedade morabbaA dar face
!numpa=12*pa
!npix=12*nside**2
nside = int(sqrt(npix/12.))
ns=nside
np=nside**2
!lp=ns/di        !tedad pixele zelE har morabba
n=log(ns)/log(base)

allocate(a(n),p(n),q(n))
do i=0,npix-1
	boi=i
	x=0 ;y=0
	nf=int(boi/np)+1
	boi=boi-(nf-1)*np
	do j=1,n
		pow=np/(4**(j-1))
		a(j)=int((boi*4)/pow)
		boi=boi-(a(j)*pow/4)
		if (a(j)==0) then
		  p(j)=1
		  q(j)=1
		end if
		if (a(j)==1) then
		  p(j)=1
		  q(j)=2
		end if
		if (a(j)==2) then
		  p(j)=2
		  q(j)=1
		end if
		if (a(j)==3) then
		  p(j)=2
		  q(j)=2
		end if
		x=x+(nside/2**j)*(p(j)-1)
		y=y+(nside/2**j)*(q(j)-1)

	end do   ! j
	!           call pix2xy_nest(nside,x,y,nf,i)
	!		  x=x
	!		  y=y
	! x & y are positions in face 'nf'
	npatch=int(x/real(lp))+di*int(y/real(lp))+1  !the number of patch in face
	nn=(nf-1)*pa+npatch  !the number of patch
	xp=MOD(x,real(lp))+1.0   !position in patch
	yp=MOD(y,real(lp))+1.0

	patch(nn,xp,yp)=inmap(i+1)

end do  !i

end

subroutine patch_to_sky(patch,inmap,npix,npatch,numpa,lp)
Implicit none

integer, intent (inout) :: npatch,npix,lp,numpa
Real ,intent (in) :: patch(numpa,lp,lp)
real, intent (out) :: inmap(npix)
integer :: nside,i,j,k,face_num,nn,boi,np,nf,pow,n,nloop,xp,yp,pa
integer :: ip,jp,nface
integer,allocatable :: a(:),p(:),q(:)
Real ,allocatable :: face(:,:)
real :: ns,base,di,x,y

base=2.0
di=npatch     !tedade morabbaA dar zelE
pa=di**2        !tedade morabbaA dar face
!numpa=12*pa
!npix=12*nside**2
nside = int(sqrt(npix/12.))
ns=nside
np=nside**2
!lp=ns/di        !tedad pixele zelE har morabba
n=log(ns)/log(base)
nloop=log(ns)/log(base)

allocate(a(n),p(n),q(n))
allocate(face(nside,nside))

do nface=1,12
!      np=mod(nface-1,pa)+1
!floor((nface-0.05)/pa)+1
  do np=1,pa
    do j=1,lp
      do i=1,lp
        face(i+int(lp*floor((np-0.05)/di)),j+int(lp*(mod(np-1.,di)))) = patch(pa*(nface-1)+np,i,j)
      end do
    end do
  end do

  do i=1,nside
    do j=1,nside
      ns=nside
      np=0
      ip=i
      jp=j
      do k=1,nloop
        np=(int((ip*2-0.01)/ns)+2*int((jp*2-0.01)/ns))*(ns/2)**2+np
        ns=ns/2
        ip=ip-int((ip-0.01)/ns)*ns
        jp=jp-int((jp-0.01)/ns)*ns
      end do !k
      np=np+(nface-1)*nside**2
      inmap(np+1)=face(j,i)
    end do !j
  end do !i
end do !face

end


module quaff_conversion_factors_m
    implicit none

    ! SI Scaling
    double precision, parameter :: CENTI_PER_BASE = 100.0d0
    double precision, parameter :: MILLI_PER_BASE = 1.0d3
    double precision, parameter :: MICRO_PER_BASE = 1.0d6
    double precision, parameter :: BASE_PER_KILO = 1.0d3
    double precision, parameter :: KILO_PER_BASE = 1.0d0 / BASE_PER_KILO
    double precision, parameter :: BASE_PER_MEGA = 1.0d6
    double precision, parameter :: MEGA_PER_BASE = 1.0d0 / BASE_PER_MEGA

    ! Length
    double precision, parameter :: METERS_PER_INCH = 0.0254d0
    double precision, parameter :: INCHES_PER_METER = 1.0d0 / METERS_PER_INCH
    double precision, parameter :: INCHES_PER_FOOT = 12.0d0
    double precision, parameter :: FEET_PER_INCH = 1.0d0 / INCHES_PER_FOOT
    double precision, parameter :: CENTIMETERS_PER_METER = CENTI_PER_BASE
    double precision, parameter :: METERS_PER_CENTIMETER = 1.0d0 / CENTIMETERS_PER_METER
    double precision, parameter :: FEET_PER_METER = INCHES_PER_METER * FEET_PER_INCH
    double precision, parameter :: MICROINCHES_PER_METER = INCHES_PER_METER * MICRO_PER_BASE
    double precision, parameter :: MICROMETERS_PER_METER = MICRO_PER_BASE
    double precision, parameter :: MILLIMETERS_PER_METER = MILLI_PER_BASE

    ! Mass
    double precision, parameter :: KILOGRAMS_PER_POUND = 0.45359237d0 ! Taken from NIST (https://www.nist.gov/physical-measurement-laboratory/nist-guide-si-footnotes#f22)
    double precision, parameter :: POUNDS_PER_KILOGRAM = 1.0d0 / KILOGRAMS_PER_POUND
    double precision, parameter :: GRAMS_PER_KILOGRAM = BASE_PER_KILO
    double precision, parameter :: OUNCES_PER_POUND = 16.0d0
    double precision, parameter :: POUNDS_PER_TON = 2000.0d0
    double precision, parameter :: TONS_PER_POUND = 1.0d0 / POUNDS_PER_TON
    double precision, parameter :: OUNCES_PER_KILOGRAM = POUNDS_PER_KILOGRAM * OUNCES_PER_POUND
    double precision, parameter :: TONS_PER_KILOGRAM = TONS_PER_POUND * POUNDS_PER_KILOGRAM

    ! Temperature
    double precision, parameter :: CELSIUS_KELVIN_DIFFERENCE = 273.15d0
    double precision, parameter :: FAHRENHEIT_RANKINE_DIFFERENCE = 459.67d0
    double precision, parameter :: RANKINE_PER_KELVIN = 9.0d0 / 5.0d0

    ! Amount
    double precision, parameter :: AVOGADROS_NUMBER = 6.022140857d23

    ! Angle
    double precision, parameter :: PI = 3.14159265359d0
    double precision, parameter :: DEGREES_PER_RADIAN = 180.0d0 / PI

    ! Time
    double precision, parameter :: SECONDS_PER_MINUTE = 60.0d0
    double precision, parameter :: MINUTES_PER_HOUR = 60.0d0
    double precision, parameter :: HOURS_PER_DAY = 24.0d0
    double precision, parameter :: DAYS_PER_HOUR = 1.0d0 / HOURS_PER_DAY
    double precision, parameter :: SECONDS_PER_HOUR = SECONDS_PER_MINUTE * MINUTES_PER_HOUR
    double precision, parameter :: MICROSECONDS_PER_SECOND = MICRO_PER_BASE
    double precision, parameter :: MILLISECONDS_PER_SECOND = MILLI_PER_BASE
    double precision, parameter :: MINUTES_PER_SECOND = 1.0d0 / SECONDS_PER_MINUTE
    double precision, parameter :: HOURS_PER_SECOND = 1.0d0 / SECONDS_PER_HOUR
    double precision, parameter :: DAYS_PER_SECOND = DAYS_PER_HOUR * HOURS_PER_SECOND
    double precision, parameter :: DAYS_PER_YEAR = 365.25
    double precision, parameter :: SECONDS_PER_YEAR = SECONDS_PER_MINUTE * MINUTES_PER_HOUR * HOURS_PER_DAY * DAYS_PER_YEAR
    double precision, parameter :: YEARS_PER_SECOND = 1.0d0 / SECONDS_PER_YEAR

    ! Area
    double precision, parameter :: SQUARE_CENTIMETERS_PER_SQUARE_METER = CENTIMETERS_PER_METER**2
    double precision, parameter :: SQUARE_INCHES_PER_SQUARE_METER = INCHES_PER_METER**2
    double precision, parameter :: SQUARE_FEET_PER_SQUARE_METER = FEET_PER_METER**2

    ! Volume
    double precision, parameter :: CUBIC_CENTIMETERS_PER_CUBIC_METER = CENTIMETERS_PER_METER**3
    double precision, parameter :: CUBIC_MILLIMETERS_PER_CUBIC_METER = MILLIMETERS_PER_METER**3
    double precision, parameter :: LITERS_PER_CUBIC_METER = 1.0d3

    ! Density
    double precision, parameter :: GRAMS_PER_CUBIC_METER_PER_KILOGRAMS_PER_CUBIC_METER = GRAMS_PER_KILOGRAM
    double precision, parameter :: POUNDS_PER_CUBIC_FOOT_PER_KILOGRAMS_PER_CUBIC_METER = &
                POUNDS_PER_KILOGRAM / FEET_PER_METER**3

    ! Molar Mass
    double precision, parameter :: GRAMS_PER_MOL_PER_KILOGRAMS_PER_MOL = BASE_PER_KILO

    ! Speed
    double precision, parameter :: CENTIMETERS_PER_SECOND_PER_METERS_PER_SECOND = CENTIMETERS_PER_METER
    double precision, parameter :: FEET_PER_SECOND_PER_METERS_PER_SECOND = FEET_PER_METER

    ! Acceleration
    double precision, parameter :: GRAVITY = 9.80665d0 ! m/s^2 according to Wikipedia
    double precision, parameter :: CENTIMETERS_PER_SQUARE_SECOND_PER_METERS_PER_SQUARE_SECOND = CENTIMETERS_PER_METER
    double precision, parameter :: FEET_PER_SQUARE_SECOND_PER_METERS_PER_SQUARE_SECOND = FEET_PER_METER

    ! Force
    ! Note: 1 N = 1 (kg m)/s^2
    double precision, parameter :: DYNES_PER_NEWTON = &
            GRAMS_PER_KILOGRAM * CENTIMETERS_PER_SQUARE_SECOND_PER_METERS_PER_SQUARE_SECOND
    double precision, parameter :: KILOPONDS_PER_NEWTON = 1.0d0 / GRAVITY ! 1 kp = 1 kg * gravity
    double precision, parameter :: MILLINEWTONS_PER_NEWTON = MILLI_PER_BASE
    double precision, parameter :: POUNDS_PER_NEWTON = POUNDS_PER_KILOGRAM / GRAVITY ! 1 lbf = 1 lbm * gravity

    ! Energy
    ! Note: 1 J = 1 (N m)
    double precision, parameter :: JOULES_PER_CALORIE = 4.1868d0 ! Taken from NIST for "IT" (https://www.nist.gov/physical-measurement-laboratory/nist-guide-si-footnotes#f09)
    double precision, parameter :: BTU_PER_JOULE = 1.05505585262d3 ! Taken from NIST for "IT" (https://www.nist.gov/physical-measurement-laboratory/nist-guide-si-footnotes#f09)
    double precision, parameter :: CALORIES_PER_JOULE = 1.0d0 / JOULES_PER_CALORIE
    double precision, parameter :: KILOJOULES_PER_JOULE = KILO_PER_BASE
    double precision, parameter :: MEGABTU_PER_JOULE = MEGA_PER_BASE * BTU_PER_JOULE
    double precision, parameter :: MEGAWATT_DAYS_PER_JOULE = MEGA_PER_BASE * DAYS_PER_SECOND
    double precision, parameter :: POUNDS_FORCE_FOOT_PER_NEWTON_METER = POUNDS_PER_NEWTON * FEET_PER_METER

    ! Power
    ! Note: 1 W = 1 J/s
    double precision, parameter :: BTU_PER_HOUR_PER_WATT = BTU_PER_JOULE * SECONDS_PER_HOUR
    double precision, parameter :: CALORIES_PER_SECOND_PER_WATT = CALORIES_PER_JOULE
    double precision, parameter :: MEGABTU_PER_HOUR_PER_WATT = MEGA_PER_BASE * BTU_PER_HOUR_PER_WATT
    double precision, parameter :: MEGAWATTS_PER_WATT = MEGA_PER_BASE

    ! Pressure
    ! Note: 1 Pa = 1 N/m^2
    double precision, parameter :: DYNES_PER_SQUARE_CENTIMETER_PER_PASCAL = DYNES_PER_NEWTON / SQUARE_CENTIMETERS_PER_SQUARE_METER
    double precision, parameter :: KILOPASCALS_PER_PASCAL = KILO_PER_BASE
    double precision, parameter :: KILOPONDS_PER_SQUARE_CENTIMETER_PER_PASCAL = &
            KILOPONDS_PER_NEWTON / SQUARE_CENTIMETERS_PER_SQUARE_METER
    double precision, parameter :: MEGAPASCALS_PER_PASCAL = MEGA_PER_BASE
    double precision, parameter :: POUNDS_PER_SQUARE_INCH_PER_PASCAL = POUNDS_PER_NEWTON / SQUARE_INCHES_PER_SQUARE_METER
    double precision, parameter :: PASCALS_PER_BAR = 100000.0d0
    double precision, parameter :: BAR_PER_PASCAL = 1.0d0 / PASCALS_PER_BAR
    double precision, parameter :: PASCALS_PER_ATMOSPHERE = 101325.0d0
    double precision, parameter :: ATMOSPHERES_PER_PASCAL = 1.0d0 / PASCALS_PER_ATMOSPHERE
    double precision, parameter :: KILOPOUNDS_PER_SQUARE_INCH_PER_PASCAL = &
            POUNDS_PER_SQUARE_INCH_PER_PASCAL / 1000.0d0

    ! Dynamic Viscosity
    double precision, parameter :: MEGAPASCAL_SECONDS_PER_PASCAL_SECOND = MEGA_PER_BASE

    ! Enthalpy
    double precision, parameter :: KILOJOULES_PER_KILOGRAM_PER_JOULES_PER_KILOGRAM = KILO_PER_BASE

    ! Burnup
    double precision, parameter :: MEGAWATT_DAYS_PER_TON_PER_WATT_SECONDS_PER_KILOGRAM = &
            MEGA_PER_BASE * DAYS_PER_SECOND / TONS_PER_KILOGRAM

    ! Thermal Conductivity
    double precision, parameter :: CAL_PER_SEC_CM_K_PER_WATTS_PER_METER_KELVIN = &
            CALORIES_PER_SECOND_PER_WATT / CENTIMETERS_PER_METER
    double precision, parameter :: WATTS_PER_CENTIMETER_KELVIN_PER_WATTS_PER_METER_KELVIN = &
            METERS_PER_CENTIMETER
    double precision, parameter :: BTU_PER_HOUR_FEET_RANKINE_PER_WATTS_PER_METER_KELVIN = &
            BTU_PER_HOUR_PER_WATT  / (FEET_PER_METER * RANKINE_PER_KELVIN)

    ! Energy Per Amount
    double precision, parameter :: KILOJOULES_PER_MOL_PER_JOULES_PER_MOL = &
            KILO_PER_BASE

    ! Energy Per Temperature Amount
    double precision, parameter :: KILOJOULES_PER_KELVIN_MOL_PER_JOULES_PER_KELVIN_MOL = &
            KILO_PER_BASE

    ! Specific Heat
    double precision, parameter :: BTU_PER_POUNDS_RANKINE_PER_JOULES_PER_KILOGRAM_KELVIN = &
            BTU_PER_JOULE / POUNDS_PER_KILOGRAM / RANKINE_PER_KELVIN

    ! convective heat transfer
    double precision, parameter :: BTU_PER_HR_SQ_FT_RANKINE_PER_WATTS_PER_SQUARE_METER_KELVIN = &
            BTU_PER_HOUR_PER_WATT / SQUARE_FEET_PER_SQUARE_METER / RANKINE_PER_KELVIN

    ! thermal expansion coefficient
    double precision, parameter ::  PER_RANKINE_PER_KELVIN = &
            1 / RANKINE_PER_KELVIN

    ! fluence
    double precision, parameter ::  PARTICLES_PER_SQUARE_CENTIMETER_PER_PARTICLES_PER_SQUARE_METER = &
            1 / SQUARE_CENTIMETERS_PER_SQUARE_METER
    ! fluence
    double precision, parameter ::  MEGAPASCAL_ROOT_METER_PER_PASCAL_ROOT_METER = &
            MEGA_PER_BASE
    double precision, parameter :: KSI_ROOT_INCH_PER_PASCAL_ROOT_METER = &
            KILO_PER_BASE * POUNDS_PER_SQUARE_INCH_PER_PASCAL / sqrt(INCHES_PER_METER)

end module


     SUBROUTINE similarity(xx,yy,simfx)!! similarity function calculation. Can be used to estimate periodicity of the signal
                                       !! by providing the same signal as the xx,yy input.
     implicit none
     real(kind=8), intent(in):: xx(niter),yy(niter)
     real(kind=8), intent(out):: simfx(imaxlag)
     real(kind=8):: simsum, sqm1,sqm2
     integer:: i,j

     simfx=0.d0

     do i=1,imaxlag
       simsum=0.d0; sqm1=0.d0; sqm2=0.d0
       do j=1,niter-i
        simsum=simsum+(xx(j)-yy(j+i))**2
        sqm1=sqm1+xx(j)**2/dfloat(niter-i)
        sqm2=sqm2+yy(j)**2/dfloat(niter-i)
       enddo
      simfx(i)=(simsum/dfloat(niter-i))/sqrt(sqm1*sqm2)
     enddo

     RETURN
     end SUBROUTINE similarity


! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.
!
! Find the sum of all the primes below two million.
module Problem10

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 10. Summation of primes.'

        write (*, '(A, I)') 'Sum 1: ', sum1()
    end subroutine

    pure function sum1()
        integer(8), parameter        :: limit = 2000000
        integer(8), dimension(limit) :: list

        integer(8) :: sum1
        integer(8) :: index
        integer(8) :: iterator

        ! initial value
        sum1     = 0
        iterator = 1

        ! fill the list of prime numbers
        do index = 2, limit
            if (isPrime(index)) then
                list(iterator) = index
                sum1 = sum1 + index

                iterator = iterator + 1
            end if
        end do
    end function

    pure function isPrime(number)
        integer(8), intent(in) :: number

        integer(8) devider
        logical(8) isPrime

        ! initial value
        isPrime = .true.

        do devider = 2, sqrt(real(number))
            if (mod(number, devider) .eq. 0) then
                isPrime = .false.
                exit
            end if
        end do
    end function
end module


      subroutine csalbr(xtau,xalb)
!*
!Description: routine used to compute the spherical albedo of a pure
!molecular atmosphere of optical depth xtau

!Input parameters:

!	float xtau:   the optical depth of the pure molecular
!	atmosphere (unitless).

!Output Parameters:

!	float xalb:   the spherical albedo (unitless).

!Revision History:
!$LOG: CSLABR.f,v1.0$

!Original version: Wed Dec 13 09:33:38 EST 1995
!E. VERMOTE (eric@kratmos.gsfc.nasa.gov)

!Developer Header:

!DEVELOPPERS:  Eric F Vermote, eric@kratmos.gsfc.nasa.gov, 301-286-6232

!References and Credits:

!Design Notes: This is a 6S routine.
!END****************************************************************************
*/
      real xtau,xalb,fintexp3
      xalb=(3*xtau-fintexp3(xtau)*(4+2*xtau)+2*exp(-xtau))
      xalb=xalb/(4.+3*xtau)
      return
      end
      real function fintexp3(xtau)
!*
!Description: this function returns the exponential integral of the third
! order for value xtau. It is used by CSALBR routine.

!Input parameters:

!	float xtau:   argument (unitless).

!Output Parameters:

!	float fintexp3: The exponential integral of order 3.

!Revision History:
!$LOG: CSLABR.f,v1.0$

!Original version: Wed Dec 13 09:33:38 EST 1995
!E. VERMOTE (eric@kratmos.gsfc.nasa.gov)

!Developer Header:

!DEVELOPPERS:  Eric F Vermote, eric@kratmos.gsfc.nasa.gov, 301-286-6232

!References and Credits:

!Design Notes: This is a 6S routine.
!END****************************************************************************
*/
      real xx,xtau,fintexp1
      xx=(exp(-xtau)*(1.-xtau)+xtau*xtau*fintexp1(xtau))/2.
      fintexp3=xx
      return
      end
      real function fintexp1(xtau)
!*
!Description: this function returns the exponential integral of the third
! order for value xtau. It is used by CSALBR routine.

!Input parameters:

!	float xtau:   argument (unitless).

!Output Parameters:

!	float fintexp1: The exponential integral of order 1 for xtau.

!Revision History:
!$LOG: CSLABR.f,v1.0$

!Original version: Wed Dec 13 09:33:38 EST 1995
!E. VERMOTE (eric@kratmos.gsfc.nasa.gov)

!Developer Header:

!DEVELOPPERS:  Eric F Vermote, eric@kratmos.gsfc.nasa.gov, 301-286-6232

!References and Credits:

!Design Notes: This is a 6S routine.
!END****************************************************************************
*/
c accuracy 2e-07... for 0<xtau<1
      real xx,a(0:5),xtau,xftau
      integer i
      data (a(i),i=0,5) /-.57721566,0.99999193,-0.24991055,
     c                  0.05519968,-0.00976004,0.00107857/
      xx=a(0)
      xftau=1.
      do i=1,5
      xftau=xftau*xtau
      xx=xx+a(i)*xftau
      enddo
      fintexp1=xx-log(xtau)
      return
      end


!> \file mo_constants.f90

!> \brief Provides computational, mathematical, physical, and file constants

!> \details Provides computational constants like epsilon, mathematical constants such as Pi,
!> physical constants such as the Stefan-Boltzmann constant, and file units for some standard streams
!> such as standard in.

!> \author Matthias Cuntz
!> \date Nov 2011

module mo_constants

  !  This module contains basic and derived constants
  !
  !  Written  Nov 2011, Matthias Cuntz
  !  Modified Mar 2014, Matthias Cuntz                   - iso_fortran_env
  !           Jun 2018, Matthias Cuntz, Johannes Brenner - constants for standard atmosphere (mtclim)

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2011-2018 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  use mo_kind, only: sp, dp
  use, intrinsic :: iso_fortran_env, only: input_unit, output_unit, error_unit

  implicit none

  public

  ! Computational
  !> epsilon(1.0) in double precision
  real(dp), parameter :: eps_dp = epsilon(1.0_dp)
  !> epsilon(1.0) in single precision
  real(sp), parameter :: eps_sp = epsilon(1.0_sp)

  ! Mathematical
  !> pi in double precision
  real(dp), parameter :: pi_dp        = 3.141592653589793238462643383279502884197_dp    ! pi
  !> pi in single precision
  real(sp), parameter :: pi_sp        = 3.141592653589793238462643383279502884197_sp
  !> pi/2 in double precision
  real(dp), parameter :: pio2_dp      = 1.57079632679489661923132169163975144209858_dp  ! pi/2
  !> pi/2 in single precision
  real(sp), parameter :: pio2_sp      = 1.57079632679489661923132169163975144209858_sp
  !> 2*pi in double precision
  real(dp), parameter :: twopi_dp     = 6.283185307179586476925286766559005768394_dp    ! 2*pi
  !> 2*pi in single precision
  real(sp), parameter :: twopi_sp     = 6.283185307179586476925286766559005768394_sp
  !> square root of 2 in double precision
  real(dp), parameter :: sqrt2_dp     = 1.41421356237309504880168872420969807856967_dp  ! sqrt(2)
  !> square root of 2 in single precision
  real(sp), parameter :: sqrt2_sp     = 1.41421356237309504880168872420969807856967_sp
  !> 1/3 in double precision
  real(dp), parameter :: onethird_dp  = 0.3333333333333333333333333333333333333_dp      ! 1/3
  !> 1/3 in single precision
  real(sp), parameter :: onethird_sp  = 0.3333333333333333333333333333333333333_sp
  !> 2/3 in double precision
  real(dp), parameter :: twothird_dp  = 1.0_dp - onethird_dp                            ! 2/3
  !> 2/3 in single precision
  real(sp), parameter :: twothird_sp  = 1.0_sp - onethird_sp
  !> degree to radian conversion (pi/180) in double precision
  real(dp), parameter :: deg2rad_dp   = pi_dp/180._dp            ! deg2rad
  !> degree to radian conversion (pi/180) in single precision
  real(sp), parameter :: deg2rad_sp   = pi_sp/180._sp
  !> radian to degree conversion (180/pi) in double precision
  real(dp), parameter :: rad2deg_dp   = 180._dp/pi_dp            ! rad2deg
  !> radian to degree conversion (180/pi) in single precision
  real(sp), parameter :: rad2deg_sp   = 180._sp/pi_sp
  !> arc to radian conversion (180/pi) in double precision
  real(dp), parameter :: arc2rad_dp   = pi_dp/12._dp             ! arc2rad
  !> arc to radian conversion (180/pi) in single precision
  real(sp), parameter :: arc2rad_sp   = pi_sp/12._sp
  ! seconds per radian of hour angle in single precision
  real(dp), parameter :: secperrad_dp = 13750.9871_dp            ! secperrad
  ! seconds per radian of hour angle in single precision
  real(sp), parameter :: secperrad_sp = 13750.9871_sp

  ! Physical
  !> seconds per day [s] in double precision
  real(dp), parameter :: secday_dp      = 86400._dp               ! secday [s]
  !> seconds per day [s] in single precision
  real(sp), parameter :: secday_sp      = 86400._sp
  !> psychrometric constant [kPa K^-1] in double precision
  real(dp), parameter :: psychro_dp     = 0.0646_dp               ! psychrometric constant [kPa c-1]
  !> psychrometric constant [kPa K^-1] in sibgle precision
  real(sp), parameter :: psychro_sp     = 0.0646_sp
  !> gravity accelaration [m^2 s^-1] in double precision
  real(dp), parameter :: gravity_dp     = 9.81_dp                 ! gravity acceleration [m^2/s]
  !> gravity accelaration [m^2 s^-1] in single precision
  real(sp), parameter :: gravity_sp     = 9.81_sp
  !>  solar constant in [J m^-2 s^-1] in double precision
  real(dp), parameter :: solarconst_dp  = 1367._dp                ! solar constant in [W m-2 = kg s-3]
  !>  solar constant in [J m^-2 s^-1] in single precision
  real(sp), parameter :: solarconst_sp  = 1367._sp
  !> specific heat for vaporization of water in [J m-2 mm-1] in double precision
  real(dp), parameter :: specheatet_dp  = 2.45e06_dp              ! specific heat in [W s m-2 mm-1 = kg s-2 mm-1]
  !> specific heat for vaporization of water in [J m-2 mm-1] in single precision
  real(sp), parameter :: specheatet_sp  = 2.45e06_sp
  !> standard temperature [k] in double precision
  real(dp), parameter :: T0_dp          = 273.15_dp               ! celcius <-> kelvin [K]
  !> standard temperature [k] in single precision
  real(sp), parameter :: T0_sp          = 273.15_sp
  !> stefan-boltzmann constant [W m^-2 K^-4] in double precision
  real(dp), parameter :: sigma_dp       = 5.67e-08_dp             ! stefan-boltzmann constant [w/m^2/k^4]
  !> stefan-boltzmann constant [W m^-2 K^-4] in single precision
  real(sp), parameter :: sigma_sp       = 5.67e-08_sp
  ! earth radius [m] in double precision
  real(dp), parameter :: radiusearth_dp = 6371228._dp
  ! earth radius [m] in single precision
  real(sp), parameter :: radiusearth_sp = 6371228._sp
  ! radians of earth orbit per julian day
  real(dp), parameter :: radperday_dp   = 0.017214_dp
  ! radians of earth orbit per julian day
  real(sp), parameter :: radperday_sp   = 0.017214_sp
  ! minimum declination (radians)
  real(dp), parameter :: mindecl_dp     = -0.4092797_dp
  ! minimum declination (radians)
  real(sp), parameter :: mindecl_sp     = -0.4092797_sp
  ! julian day offset of winter solstice
  real(dp), parameter :: daysoff_dp     = 11.25_dp
  ! julian day offset of winter solstice
  real(sp), parameter :: daysoff_sp     = 11.25_sp
  ! molecular weight of air (kg mol-1)
  real(dp), parameter :: Ma_dp          = 28.9644e-3_dp
  ! molecular weight of air (kg mol-1)
  real(sp), parameter :: Ma_sp          = 28.9644e-3_sp
  ! molecular weight of water (kg mol-1)
  real(dp), parameter :: Mw_dp          = 18.0148e-3_dp
  ! molecular weight of water (kg mol-1)
  real(sp), parameter :: Mw_sp          = 18.0148e-3_sp
  ! unitless ratio of molec weights (mw/ma)
  real(dp), parameter :: epsair_dp      = Mw_dp/Ma_dp
  ! unitless ratio of molec weights (mw/ma)
  real(sp), parameter :: epsair_sp      = Mw_sp/Ma_sp
  ! gas law constant (m3 pa mol-1 K-1)
  real(dp), parameter :: R_dp           = 8.3143_dp
  ! gas law constant (m3 pa mol-1 K-1)
  real(sp), parameter :: R_sp           = 8.3143_sp
  ! standard temperature lapse rate (-K m-1)
  real(dp), parameter :: lr_std_dp      = 0.0065_dp
  ! standard temperature lapse rate (-K m-1)
  real(sp), parameter :: lr_std_sp      = 0.0065_sp

  !> Standard atmosphere
  !> standard pressure [Pa] in double precision
  real(dp), parameter :: p0_dp    = 101325._dp      ! standard pressure [Pa]
  !> standard pressure [Pa] in single precision
  real(sp), parameter :: p0_sp    = 101325._sp
  !> standard density  [kg m^-3] in double precision
  real(dp), parameter :: rho0_dp  = 1.225_dp        ! standard air density
  !> standard density  [kg m^-3] in single precision
  real(sp), parameter :: rho0_sp  = 1.225_sp
  !> specific heat capacity of air [J kg^-1 K^-1] in double precision
  real(dp), parameter :: cp0_dp   = 1005.0_dp       ! standard specific heat of air
  !> specific heat capacity of air [J kg^-1 K^-1] in single precision
  real(sp), parameter :: cp0_sp   = 1005.0_sp
  !> standard temp at 0.0 m elevation (K)           ! standard temperature at 0 m asl
  real(dp), parameter :: T_std_dp = 288.15_dp
  !> standard temp at 0.0 m elevation (K)
  real(sp), parameter :: T_std_sp = 288.15_sp

  ! Numerical Recipes
  !> pi in double precision
  real(dp), parameter :: pi_d    = 3.141592653589793238462643383279502884197_dp      ! pi
  !> pi in single precision
  real(sp), parameter :: pi      = 3.141592653589793238462643383279502884197_sp
  !> pi/2 in double precision
  real(dp), parameter :: pio2_d  = 1.57079632679489661923132169163975144209858_dp    ! pi/2
  !> pi/2 in single precision
  real(sp), parameter :: pio2    = 1.57079632679489661923132169163975144209858_sp
  !> 2*pi in double precision
  real(dp), parameter :: twopi_d = 6.283185307179586476925286766559005768394_dp      ! 2*pi
  !> 2*pi in single precision
  real(sp), parameter :: twopi   = 6.283185307179586476925286766559005768394_sp
  !> square root of 2 in double precision
  real(dp), parameter :: sqrt2_d = 1.41421356237309504880168872420969807856967_dp    ! sqrt(2)
  !> square root of 2 in single precision
  real(sp), parameter :: sqrt2   = 1.41421356237309504880168872420969807856967_sp
  !> Euler's constant in double precision
  real(dp), parameter :: euler_d = 0.5772156649015328606065120900824024310422_dp     ! Euler
  !> Euler's constant in single precision
  real(sp), parameter :: euler   = 0.5772156649015328606065120900824024310422_sp

  ! Standard file units
  !> standard input file unit
  ! integer, parameter :: nin  = 5   ! standard input stream
  integer, parameter :: nin  = input_unit   ! standard input stream
  !> standard output file unit
  ! integer, parameter :: nout = 6   ! standard output stream
  integer, parameter :: nout = output_unit   ! standard output stream
  !> standard error file unit
  ! integer, parameter :: nerr = 0   ! error output stream
  integer, parameter :: nerr = error_unit   ! error output stream
  !> standard file unit for namelist
  integer, parameter :: nnml = 100 ! namelist unit

end module mo_constants


subroutine smooth1(v, n)
  implicit none
  integer :: i, n
  real, intent(inout) :: v(n)

  do i = 2, n-1
    v(i) = (v(i-1) + v(i) + v(i+1)) / 3.0
  enddo
  return
end subroutine smooth1

subroutine smooth2(v, nx, ny)
  implicit none
  integer :: x,y, nx,ny
  real, intent(inout) :: v(nx, ny)

  do x = 2, nx-1
    do y = 2, ny-1
      v(x,y) = (v(x-1,y-1) + v(x+0,y-1) + v(x+1,y-1) + &
                v(x-1,y+0) + v(x+0,y+0) + v(x+1,y+0) + &
                v(x-1,y+1) + v(x+0,y+1) + v(x+1,y+1)) / 9.0
!      if(x == 5 .AND. y == 5) then
!       print *, '5,5;2:', v(x,y)
!     endif
    enddo
  enddo
end subroutine smooth2

program loops
  implicit none
  real,allocatable :: values(:)
  real,allocatable :: arr2d(:,:)
  integer :: i,j
  integer :: nx

  allocate(values(10))
  do i = 1, 10
    values(i) = real(i)**2
  enddo
  call smooth1(values, 10)
  print *,'blah:',values(3)
  deallocate(values)

  nx = 1092
  allocate(arr2d(nx,30))
  do i = 1,nx
    do j = 1,30
      arr2d(i,j) = i*j*rand(0)
    enddo
  enddo
  print *, '2d-before(5,5):', arr2d(5,5)
  call smooth2(arr2d, nx, 30)
  print *, '2d(5,5):', arr2d(5,5)
  deallocate(arr2d)
end program loops


!> @brief       Example for interpolation from one grid to another grid
program test_regrid
    use fplus_regrid

    ! local variables
    real (kind=8), dimension(:), allocatable :: inarray1
    real (kind=8), dimension(:), allocatable :: outarray1
    real (kind=8), dimension(:,:), allocatable :: inarray2
    real (kind=8), dimension(:,:), allocatable :: outarray2
    real (kind=8), dimension(:,:,:), allocatable :: inarray3
    real (kind=8), dimension(:,:,:), allocatable :: outarray3
    real (kind=8), dimension(:,:,:,:), allocatable :: inarray4
    real (kind=8), dimension(:,:,:,:), allocatable :: outarray4
    integer :: err

    ! test 1d
    print*, "FROM SMALLER TO LARGER GRID"
    print*, "--------------------------------------------------------------------------------------"
    allocate(inarray1(4))
    allocate(outarray1(5))
    inarray1 = (/1,2,2,1/)
    print*, "Uniform Linear"
    err = regrid(inarray1, outarray1)
    print*, "Errorcode: ", err
    print*, inarray1
    print*, outarray1

    print*, "Non-Uniform Linear"
    err = regrid(inarray1, outarray1, (/1.0_8,2.0_8,3.0_8,4.0_8/), (/1.5_8,2.0_8,2.9_8,3.0_8,4.0_8/))
    print*, "Errorcode: ", err
    print*, inarray1
    print*, outarray1

    deallocate(inarray1, outarray1)
    allocate(inarray1(4))
    allocate(outarray1(5))
    inarray1 = (/1,2,2,1/)
    print*, "Uniform Cubic"
    err = regrid(inarray1, outarray1, intpol=(/3/))
    print*, "Errorcode: ", err
    print*, inarray1
    print*, outarray1

    print*, "Non-Uniform Cubic"
    err = regrid(inarray1, outarray1, (/1.0_8,2.0_8,3.0_8,4.0_8/), (/1.5_8,2.0_8,2.9_8,3.0_8,4.0_8/), intpol=(/3/))
    print*, "Errorcode: ", err
    print*, inarray1
    print*, outarray1

    print*, ""
    print*, "FROM LARGER TO SMALLER GRID"
    print*, "--------------------------------------------------------------------------------------"
    deallocate(inarray1, outarray1)
    allocate(inarray1(5), outarray1(4))
    inarray1 = (/1,2,3,2,1/)
    print*, "Uniform Linear"
    err = regrid(inarray1, outarray1)
    print*, "Errorcode: ", err
    print*, inarray1
    print*, outarray1

    print*, "Uniform Cubic"
    err = regrid(inarray1, outarray1, intpol=(/3/))
    print*, "Errorcode: ", err
    print*, inarray1
    print*, outarray1

    ! test 2d
    print*, ""
    print*, "FROM SMALLER TO LARGER GRID (2-d)"
    print*, "--------------------------------------------------------------------------------------"
    allocate(inarray2(3,3), outarray2(4,4))
    inarray2 = 1
    inarray2(2,2) = 2
    print*, "Uniform Linear"
    err = regrid(inarray2, outarray2)
    print*, "Errorcode: ", err
    print*, inarray2(1,:)
    print*, inarray2(2,:)
    print*, inarray2(3,:)
    print*, ""
    print*, outarray2(1,:)
    print*, outarray2(2,:)
    print*, outarray2(3,:)
    print*, outarray2(4,:)

    print*, ""
    print*, "FROM LARGER TO SMALLER GRID (2-d)"
    print*, "--------------------------------------------------------------------------------------"
    deallocate(inarray2, outarray2)
    allocate(inarray2(5,5), outarray2(4,4))
    inarray2 = 1
    inarray2(3,3) = 2
    print*, "Uniform Linear"
    err = regrid(inarray2, outarray2)
    print*, "Errorcode: ", err
    print*, inarray2(1,:)
    print*, inarray2(2,:)
    print*, inarray2(3,:)
    print*, inarray2(4,:)
    print*, inarray2(5,:)
    print*, ""
    print*, outarray2(1,:)
    print*, outarray2(2,:)
    print*, outarray2(3,:)
    print*, outarray2(4,:)

    print*, "Uniform Cubic"
    err = regrid(inarray2, outarray2, intpol=(/3,3/))
    print*, "Errorcode: ", err
    print*, inarray2(1,:)
    print*, inarray2(2,:)
    print*, inarray2(3,:)
    print*, inarray2(4,:)
    print*, inarray2(5,:)
    print*, ""
    print*, outarray2(1,:)
    print*, outarray2(2,:)
    print*, outarray2(3,:)
    print*, outarray2(4,:)

end program


c-----------------------------------------------------------------------------
c     Computes Sum(i=1,n) x(i)*H_i(t) where the H_i are Hicks-Henne
c     functions
c-----------------------------------------------------------------------------
      subroutine hickshenne_b(n, x, xb, hb, t)
      implicit none
      integer n
      real    x(*), xb(*), hb, t

      integer i
      real    h, HicksHenneFunc

      do i=1,n
         xb(i) = xb(i) + hb*HicksHenneFunc(n, i, t)
      enddo

      return
      end


program cmp_test
  use mod_testing, only: assert, initialize_tests, report_tests
  use compare, only: eq, gt, lt, ge, le, setTol
  use iso_fortran_env, only: real32, real64
  implicit none

  logical,dimension(:),allocatable :: tests
  logical :: test_failed
  integer :: n,ntests

  real, dimension(:), allocatable :: r_alloc_arr1, r_alloc_arr2
  real, dimension(10) :: r_dim10_arr1, r_dim10_arr2
  real, dimension(5) :: r_dim5_arr1, r_dim5_arr2

  real(kind=real64), dimension(:), allocatable :: r64_alloc_arr1, r64_alloc_arr2

  n = 1
  ntests = 38
  call initialize_tests(tests,ntests)

!
! helper function setTol test
!

  tests(n) = assert(eq(setTol(1e-8),setTol()) .eqv. .true., 'Default tolerance')
  n = n + 1
  tests(n) = assert(eq(setTol(1e-6),setTol()) .eqv. .false., 'Not equal to default tolerance')
  n = n + 1
  tests(n) = assert(eq(setTol(1e-6),setTol(0.000001)) .eqv. .true., 'Equal not default tolerance')
  n = n + 1
  tests(n) = assert(eq(setTol(1e-6),0.000001) .eqv. .true., 'Equal bare word not default tolerance')
  n = n + 1
  tests(n) = assert(eq(setTol(1e-6),1e-6) .eqv. .true., 'Equal exponent notation not default tolerance')
  n = n + 1

!
! Real tests
!

  tests(n) = assert(eq(1.0,1.0,1e-6) .eqv. .true., 'Real equal: 1.0 == 1.0')
  n = n + 1
  tests(n) = assert(eq(1.0,2.0) .eqv. .false., 'Real not equal: 1.0 /= 2.0')
  n = n + 1
  tests(n) = assert(eq(1.0,1.0000000001) .eqv. .true., 'Real not equal in tolerance: 1.0 == 1.0000000001')
  n = n + 1
  tests(n) = assert(eq(1.0,1.000001) .eqv. .false., 'Real not equal out of tolerance: 1.0 /= 1.000001')
  n = n + 1
  tests(n) = assert(ge(1.0,0.9999) .eqv. .true., 'Real greater/equal out of tolerance: 1.0 /= 0.9999')
  n = n + 1
  tests(n) = assert(ge(1.0,1.1) .eqv. .false., 'Real not greater/equal: 1.0 >= 1.1')
  n = n + 1
  tests(n) = assert(ge(1.0,1.0) .eqv. .true., 'Real greater/equal equal: 1.0 >= 1.0')
  n = n + 1
  tests(n) = assert(le(1.0,1.0) .eqv. .true., 'Real less/equal equal: 1.0 <= 1.0')
  n = n + 1
  tests(n) = assert(le(1.0,1.00000001) .eqv. .true., 'Real less/equal in tolerance: 1.0 <= 1.00000001')
  n = n + 1
  tests(n) = assert(lt(1.0,2.0) .eqv. .true., 'Real less: 1.0 < 2.0')
  n = n + 1
  tests(n) = assert(gt(2.0,1.0) .eqv. .true., 'Real greater: 2.0 > 1.0')
  n = n + 1
  tests(n) = assert(gt(2.0,1.9999999999) .eqv. .false., 'Real not greater in tolerance: 2.0 > 1.9999999999')
  n = n + 1
  tests(n) = assert(lt(1.99999999999,2.0) .eqv. .false., 'Real not less in tolerance: 1.99999999999 < 2.0')
  n = n + 1

!
! Real array equality tests
!
  r_dim10_arr1 = 0.0
  r_dim10_arr2 = 0.0
  r_dim5_arr1 = 0.0
  r_dim5_arr2 = 0.0
  r_alloc_arr1 = (/0.0,0.0,0.0,0.0,0.0/)
  r_alloc_arr2 = (/0.0,0.0,0.0,0.0,0.0/)

  tests(n) = assert(eq(r_alloc_arr1, r_alloc_arr2) .eqv. .true., 'Equal allocatable same size')
  n = n + 1

  r_alloc_arr2 = (/1.0,2.0,3.0/)
  tests(n) = assert(eq(r_alloc_arr1, r_alloc_arr2) .eqv. .false., 'Allocatable different size')
  n = n + 1

  tests(n) = assert(eq(r_dim10_arr1,r_dim10_arr2) .eqv. .true., 'Fixed same size')
  n = n + 1
  tests(n) = assert(eq(r_dim10_arr1, r_dim5_arr1) .eqv. .false., 'Fixed different size')
  n = n + 1
  tests(n) = assert(eq(r_dim5_arr1, r_alloc_arr1) .eqv. .true., 'Fixed and alloc same size')
  n = n + 1

  r_dim5_arr1 = 1.0
  tests(n) = assert(eq(r_dim5_arr1,r_dim5_arr2) .eqv. .false., 'Fixed same size different values')
  n = n + 1

!
! Real64 tests
!
  tests(n) = assert(eq(1.0_real64, 1.0_real64), 'Real64 equal')
  n = n + 1
  tests(n) = assert(eq(1.000000000000000000001_real64, 1.000000000000001_real64, 1e-12), 'Real64 equal tolerance')
  n = n + 1

!
! Real64 array equality tests
!
  r64_alloc_arr1 = (/1.0,0.1,0.0,0.0,0.0,0.0/)
  r64_alloc_arr2 = (/1.0,0.1,0.0,0.0,0.0,0.0/)

  tests(n) = assert(eq(r64_alloc_arr1,r64_alloc_arr2), 'Real64 array equal')
  n = n + 1
  tests(n) = assert(eq(r64_alloc_arr1,r64_alloc_arr2,1e-2), 'Real64 array tolerance equal')
  n = n + 1

!
! Complex tests
!

  tests(n) = assert(eq((1.0,0.0),(1.0,0.0)) .eqv. .true., 'Complex equal: (1.0,0.0) == (1.0,0.0)')
  n = n + 1
  tests(n) = assert(.not. eq((1.0,0.0),(0.0,-1.0)) .eqv. .true., 'Complex not equal: (1.0,0.0) /= (0.0,-1.0)')
  n = n + 1
  tests(n) = assert(gt((1.0,0.0),(0.0,-1.0)) .eqv. .true., 'Complex greater: (1.0,0.0) > (0.0,-1.0)')
  n = n + 1
  tests(n) = assert(gt((1.0,0.0),(0.99999999,0.0)) .eqv. .false., 'Complex not greater: (1.0,0.0) /> (0.999999999,0.0)')
  n = n + 1
  tests(n) = assert(lt((1.0,0.0),(1.5,0.0)) .eqv. .true., 'Complex less: (1.0,0.0) < (1.5,0.0)')
  n = n + 1
  tests(n) = assert(ge((1.0,0.0),(0.1,0.0)) .eqv. .true., 'Complex greater/equal: (1.0,0.0) >= (0.1,0.0)')
  n = n + 1
  tests(n) = assert(ge((1.0,0.0),(0.99999999,0.0)) .eqv. .true., 'Complex greater/equal: (1.0,0.0) >= (0.999999999,0.0)')
  n = n + 1
  tests(n) = assert(le((1.0,0.0),(2.0,0.0)) .eqv. .true., 'Complex less/equal: (1.0,0.0) <= (2.0,0.0)')
  n = n + 1
  tests(n) = assert(le((1.0,0.0),(0.99999999,0.0)) .eqv. .true., 'Complex less/equal: (1.0,0.0) <= (0.999999999,0.0)')
  n = n + 1
  tests(n) = assert(le((2.0,0.0),(1.0,0.0)) .eqv. .false., 'Complex not less/equal: (2.0,0.0) <= (1.0,0.0)')
  n = n + 1

  test_failed = .false.
  call report_tests(tests,test_failed)
  if(test_failed)stop 1

end program cmp_test


C   File: array-to-func_06.f
C   This test is an example of passing arrays to a function (subroutine)
C   then pass the array to another function under the nested loop.
C
C   The code was sampled from SIR-Gillespie.f

      subroutine update_mean_var(MeanS, VarS, k, n, runs)
      integer, parameter :: Tmax = 100
      integer k, n, runs
      double precision, dimension(0:Tmax) :: MeanS, VarS

      MeanS(k) = MeanS(k) + (n - MeanS(k))/(runs+1)
      VarS(k) = VarS(k) + runs/(runs+1) * (n-MeanS(k))*(n-MeanS(k))

      return
      end subroutine update_mean_var

      subroutine gillespie(MeanS, VarS)
      integer, parameter :: Tmax = 100
      integer runs, sample, i, j

      double precision, dimension(0:Tmax) :: MeanS, VarS
      double precision, dimension(0:Tmax) :: samples

      do i = 0, Tmax
        samples(i) = i
      end do

      do runs = 0, Tmax
        j = 0
        do while (j .le. Tmax)
          call update_mean_var(MeanS, VarS, j, sample, runs)
          j = j + 1
        end do
        sample = samples(runs)
      end do

      end subroutine gillespie

      program main
      implicit none

      integer, parameter :: Tmax = 100
      double precision, dimension(0:Tmax) :: MeanS, VarS

      call gillespie(MeanS, VarS)

      end program main


subroutine interpolate(q, qp, qm, order, n)
  !
  ! Interpolate q from tracer point to U-point for abritary order
  !
  ! - if order%2 == 1 (upwind biased)
  !    qp and qm are the right and left interpolations
  !    qp(i) and qm(i+1) are the value that go with u(i)
  !
  ! - if order%2 == 0 (centered)
  !    only qp is returned, qp takes values from i=1..n-1
  !    qp(i) is the centered value for u(i)
  !

  implicit none

  integer, intent(in):: n, order

  real*8, dimension(n), intent(in) :: q
  real*8, dimension(n), intent(out) :: qm, qp

  !f2py intent(inplace):: q, qm, qp

  integer:: i

  real*8:: c1,c2,c3, b1, b2, b3, b4, b5, d1, e1,e2

  ! second order
  d1 = 0.5
  ! third order
  c1 = -1./6.
  c2 =  5./6.
  c3 =  2./6.
  ! fourth order
  e1 = -1./12
  e2 = 7./12.
  ! fifth order
  b1 = 2./60.
  b2 = -13./60.
  b3 = 47./60.
  b4 = 27./60.
  b5 = -3./60.

  if (order.eq.5) then
     !
     i=1
     qp(i) = q(i)
     qm(i) = q(i)
     !
     i=2
     qp(i) = c1*q(i-1) + c2*q(i) + c3*q(i+1)
     qm(i) = c3*q(i-1) + c2*q(i) + c1*q(i+1)
     !
     do i=3,n-2
        qp(i) = b1*q(i-2) + b2*q(i-1) + b3*q(i) + b4*q(i+1) + b5*q(i+2)
        qm(i) = b5*q(i-2) + b4*q(i-1) + b3*q(i) + b2*q(i+1) + b1*q(i+2)
     enddo
     !
     i=n-1
     qp(i) = c1*q(i-1) + c2*q(i) + c3*q(i+1)
     qm(i) = c3*q(i-1) + c2*q(i) + c1*q(i+1)
     !
     i=n
     qp(i) = q(i)
     qm(i) = q(i)
     !
  elseif (order.eq.3) then
     !
     i=1
     qp(i) = q(i)
     qm(i) = q(i)
     !
     do i=2,n-1
        qp(i) = c1*q(i-1) + c2*q(i) + c3*q(i+1)
        qm(i) = c3*q(i-1) + c2*q(i) + c1*q(i+1)
     enddo
     !
     i=n
     qp(i) = q(i)
     qm(i) = q(i)
     !
  !1st order
  elseif (order.eq.1) then
     !
     do i=1,n
        qp(i) = q(i)
        qm(i) = q(i)
     enddo
     !
  ! 2nd order
  elseif (order.eq.2) then
     !
     do i=1,n-1
        qp(i)=0.5*(q(i)+q(i+1))
     enddo
     !
  ! 4th order
  elseif (order.eq.4) then
     !
     i=1
     qp(i)=e2*(q(i)+q(i+1))+e1*(q(i+2))
     !
     do i=2,n-2
        qp(i)=e2*(q(i)+q(i+1))+e1*(q(i-1)+q(i+2))
     enddo
     !
     i=n-1
     qp(i)=e2*(q(i)+q(i+1))+e1*(q(i-1))
     !
  endif

end subroutine interpolate


      REAL FUNCTION rsimp(mrad,f,r,irn,dx)
c.....................................................rsimp

      IMPLICIT NONE
c===================
c     radial integration via simpson
C     ..
C     .. Scalar Arguments ..
      INTEGER,INTENT (IN) :: mrad
      REAL dx
      INTEGER irn
C     ..
C     .. Array Arguments ..
      REAL f(mrad),r(mrad)
C     ..
C     .. Local Scalars ..
      REAL s
      INTEGER i,isw,nl,np
C     ..
      isw = 0
      rsimp = 0.0
      IF (irn.LE.2) RETURN
      IF (irn/2*2.EQ.irn) isw = 1
      np = irn - isw
      s = f(1)*r(1) + f(np)*r(np)
      nl = np - 1
      DO 10 i = 2,nl,2
         s = s + 4.0*f(i)*r(i)
   10 CONTINUE
      nl = nl - 1
      IF (nl.LT.3) GO TO 30
      DO 20 i = 3,nl,2
         s = s + 2.0*f(i)*r(i)
   20 CONTINUE
   30 s = s*dx/3.0
      IF (isw.EQ.1) GO TO 40
      rsimp = s
      RETURN
   40 rsimp = s + (f(irn)*r(irn)+f(irn-1)*r(irn-1))*0.50*dx
      RETURN
      END


PROGRAM hero

! Nick Stoke's program to find the roots and weights for half-Hermite
! integration.   Converted to quadruple-precision by Alan Miller
! Latest revision - 15 November 1997

USE quadruple_precision
IMPLICIT NONE
TYPE (quad)          :: f(60), g(60), h(3, 3), hi, xx(40), x, x1, x2, xd, &
                        xw(40)
REAL (dp), PARAMETER :: zero = 0.0_dp, half = 0.5_dp, one = 1.0_dp
INTEGER              :: i, i1, i1j, il1, j, j1, k, l, m, n1

!     OPEN files for output

OPEN(8, FILE='absciss.dat')
OPEN(9, FILE='weights.dat')

!     Set I1 = 60, J1 = no. of iterations = 40, N1 = no. of points.

i1 = 60
j1 = 40
n1 = 20
DO i = 1,60
  f(i) = quad(zero, zero)
  g(i) = quad(zero, zero)
END DO

!     Iterative formation of recurrence relation coefficients.

DO j = 1, j1
  i1j = i1-j
  DO i = 2,i1j
    hi = quad(DBLE(i-1), zero)
    f(i) = hi/DBLE(6) + f(i)*(g(i)*(g(i-1)-g(i)) + half +  &
           f(i)-f(i+1)) / (3.d0*f(i) - 1.5D0*hi)
    g(i-1) = SQRT(hi - half - f(i) - f(i-1))
  END DO
END DO

il1 = i1-1
DO i = 2, il1
  f(i) = SQRT(f(i))
END DO

!     Find the zeroes by Newton's method, evaluating the polynomials
!     by recurrence.

DO j = 1, n1
  x = quad(zero, zero)
  x1 = quad(zero, zero)
  DO k = 1, j
    l = 0
    DO
      h(2,1) = quad(one, zero)
      h(2,2) = quad(zero, zero)
      h(3,2) = quad(zero, zero)
      h(3,1) = quad(zero, zero)
      DO m = 1, j
        DO i = 2, 3
          h(i,3) = h(i,2)
          h(i,2) = h(i,1)
          h(i,1) = (h(i,2)*(g(m)-x) - h(i,3)*f(m) - (i-2)*h(i-1,2))/f(m+1)
        END DO
      END DO

      xd = -h(2,1)/h(3,1)
      x = x+xd
      IF(ABS(xd%hi) > 1.d-12) CYCLE
      l = l+1
      IF(l > 1) EXIT
    END DO
    xw(k) = - quad(half, zero) / (h(2,2)*h(3,1)*g(1)*f(j+1))

!   XW = Weights.

    xx(k) = x
    x2 = x1
    x1 = SQRT(x)
    x = x1 + x1 - x2
    x = x*x
  END DO
  WRITE(8,10) j, xx(1:j)%hi
  WRITE(9,10) j, xw(1:j)%hi
END DO
STOP

10 FORMAT(i3, "  ", 3(e21.15, ", ") / ("     ", 3(e21.15, ", ")) )
END PROGRAM hero


! Discrete one-dimensional laplacian
!
! Implemented as convolution with [1, -2, 1]. This is a
! centered, depth 1 stencil
program laplace
implicit none

integer i
parameter (n=10)
real a(0:imax)
real b(0:imax)

do  i = 1, (n-1)
 != stencil readOnce, centered(depth=1, dim=1) :: a
 b(i) = a(i-1) - 2*a(i) + a(i+1)
end do

end


      subroutine easter(year,month,day)
c Easter sunday
c
c Input
c   year
c Output
c   month
c   day
c
c See:
c Jean Meeus, "Astronomical Formulae for Calculators",
c 4th edition, Willmann-Bell, 1988, p.31
      implicit integer(a-z)
      a=mod(year,19)
      b=year/100
      c=mod(year,100)
      d=b/4
      e=mod(b,4)
      f=(b+8)/25
      g=(b-f+1)/3
      h=mod(19*a+b-d-g+15,30)
      i=c/4
      k=mod(c,4)
      l=mod(32+2*e+2*i-h-k,7)
      m=(a+11*h+22*l)/451
      n=h+l-7*m+114
      month=n/31
      day=mod(n,31)+1
      end


program main

use euler
use ISO_FORTRAN_ENV

implicit none

        integer (int64), parameter :: maximum = 600851475143_int64;
        integer (int64) :: largest, i

        i = 1
        largest = 0

        do while (i ** 2 < maximum)

                if((mod(maximum, i) == 0) .AND. isprime(i)) then
                        largest = i
                endif

                call inc(i, 1_int64);

        end do

        call printint(largest);

end program main


C NCLFORTSTART
      SUBROUTINE DFOURINFO(X,NPTS,NHRET,NHAR,SCLPHA,AMP,PHA,PCV,A,B,
     +     AMPX,PHAX,PCVX,WRK,LWRK)
      IMPLICIT NONE

C NCL:   finfo = fourier_info(x, nhret, sclpha)

c perform a fourier analysis on a series of data points
c return the amplitude, phase and % variance explained

c input
      INTEGER NPTS,NHRET
      DOUBLE PRECISION X(NPTS),SCLPHA
c output
      DOUBLE PRECISION AMP(NHRET),PHA(NHRET),PCV(NHRET)
      INTEGER LWRK,NHAR
      DOUBLE PRECISION WRK(LWRK)
      DOUBLE PRECISION A(*), B(*), AMPX(*),PHAX(*),PCVX(*)
C NCLEND

c local
      INTEGER NH,NHX
      DOUBLE PRECISION ANOT,SCALE
C      DOUBLE PRECISION WRK(3*NPTS+15)
C      DOUBLE PRECISION A(NPTS/2),B(NPTS/2)
C      DOUBLE PRECISION AMPX(NPTS/2),PHAX(NPTS/2),PCVX(NPTS/2)

C      NHAR = NPTS/2
C      LWRK = 3*NPTS + 15

      CALL DFINFO(X,NPTS,NHAR,ANOT,A,B,WRK,LWRK,AMPX,PHAX,PCVX)

      NHX = NHRET
      IF (NHRET.GT.NHAR) NHX = NHAR

      SCALE = SCLPHA
      IF (SCALE.EQ.0.0D0) SCALE = 1.0D0

      DO NH = 1,NHX
          AMP(NH) = AMPX(NH)
          PHA(NH) = PHAX(NH)*SCALE
          PCV(NH) = PCVX(NH)
      END DO

      RETURN
      END
c ------------------------------------------------------------------
      SUBROUTINE DFINFO(X,NPTS,NHAR,ANOT,A,B,WRK,LWRK,AMP,PHASE,PCVAR)
      IMPLICIT NONE

c calculate the amplitude ,phase and % variance explained per harmonic
c .   of the fourier series.

      INTEGER NPTS,NHAR,LWRK
      DOUBLE PRECISION X(NPTS)
      DOUBLE PRECISION ANOT,A(*),B(*),AMP(*),PHASE(*),PCVAR(*)
      DOUBLE PRECISION WRK(LWRK)
c local
      INTEGER N
      DOUBLE PRECISION W,VARTOT,EPS

      W   = DBLE(NPTS)/ (8.D0*ATAN(1.D0))
      EPS = 1.D-12

      DO N = 1,NHAR
          A(N) = 0.0D0
          B(N) = 0.0D0
      END DO

      CALL DEZFFTI(NPTS,WRK)
      CALL DEZFFTF(NPTS,X,ANOT,A,B,WRK)

      VARTOT = 0.D0
      DO N = 1,NHAR
          AMP(N) = SQRT(A(N)*A(N)+B(N)*B(N))

          IF (A(N).EQ.0.D0 .AND. B(N).EQ.0.D0) THEN
              PHASE(N) = 0.D0
          ELSE
              PHASE(N) = ATAN2(B(N),A(N))*W/DBLE(N)
              IF (PHASE(N).LT.0.0D0) THEN
                  PHASE(N) = PHASE(N) + DBLE(NPTS)/DBLE(N)
              END IF
          END IF

          VARTOT = VARTOT + 0.5D0*AMP(N)*AMP(N)
          PCVAR(N) = 0.D0
      END DO

      IF (VARTOT.GT.EPS) THEN
          DO N = 1,NHAR
              PCVAR(N) = ((0.5D0*AMP(N)*AMP(N))/VARTOT)*100.D0
          END DO
      ELSE
         DO N = 1,NHAR
            AMP(N)   = 0.0D0
            PHASE(N) = 0.0D0
            PCVAR(N) = 0.0D0
         END DO
      END IF

      RETURN
      END


module gauss_mod
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    use :: quad_mod
    implicit none

    private
    type, public, extends(quad_type) :: gen_gauss_type
        private
        real(kind=dp) :: precision
        real(kind=dp), dimension(:), allocatable :: ws, xs
    contains
        private
        procedure, public :: init_gen_gauss
        procedure :: init_vectors
        procedure, public :: integrate
        procedure, public :: print_params
    end type gen_gauss_type

    real(kind=dp), parameter :: pi = 3.1415926535897932384626_dp, &
                                default_precision = 1.0e-10_dp

    integer, parameter :: nr_points = 10

    type, public, extends(gen_gauss_type) :: gauss_type
    contains
        private
        procedure, public :: init => init_gauss10
    end type gauss_type

contains

    subroutine init_gauss10(self)
        implicit none
        class(gauss_type), intent(inout) :: self
        call self%init_vectors(nr_points)
        self%ws(1)  = 0.2955242247147529; self%xs(1)  = -0.1488743389816312
        self%ws(2)  = 0.2955242247147529; self%xs(2)  =  0.1488743389816312
        self%ws(3)  = 0.2692667193099963; self%xs(3)  = -0.4333953941292472
        self%ws(4)  = 0.2692667193099963; self%xs(4)  =  0.4333953941292472
        self%ws(5)  = 0.2190863625159820; self%xs(5)  = -0.6794095682990244
        self%ws(6)  = 0.2190863625159820; self%xs(6)  =  0.6794095682990244
        self%ws(7)  = 0.1494513491505806; self%xs(7)  = -0.8650633666889845
        self%ws(8)  = 0.1494513491505806; self%xs(8)  =  0.8650633666889845
        self%ws(9)  = 0.0666713443086881; self%xs(9)  = -0.9739065285171717
        self%ws(10) = 0.0666713443086881; self%xs(10) =  0.9739065285171717
    end subroutine init_gauss10

    subroutine init_vectors(self, n, stat)
        implicit none
        class(gen_gauss_type), intent(inout) :: self
        integer, intent(in) :: n
        integer, intent(inout), optional :: stat
        integer :: istat
        allocate(self%xs(n), stat=istat)
        if (istat /= 0) then
            if (present(stat)) then
                stat = istat
                return
            else
                stop 'can not allocate x values'
            end if
        end if
        allocate(self%ws(n), stat=istat)
        if (istat /= 0) then
            if (present(stat)) then
                stat = istat
                return
            else
                stop 'can not allocate w values'
            end if
        end if
    end subroutine init_vectors

    subroutine init_gen_gauss(self, n, precision, stat)
        implicit none
        class(gen_gauss_type), intent(inout) :: self
        integer, intent(in) :: n
        real(kind=dp), intent(in), optional :: precision
        integer, intent(inout), optional :: stat
        integer :: istat, i
        real(kind=dp) :: z, z1, pp
        if (present(precision)) then
            self%precision = precision
        else
            self%precision = default_precision
        end if
        call self%init_vectors(n)
        do i = 1, n
            z = cos(pi*(i - 0.25_dp)/(n + 0.5_dp))
            call compute_zs(z, z1, pp, n)
            do while ((z - z1) > self%precision)
                call compute_zs(z, z1, pp, n)
            end do
            self%xs(i) = -z
            self%ws(i) = 2.0_dp/((1.0_dp - z**2)*pp**2)
        end do

    contains

        subroutine compute_zs(z, z1, pp, n)
            implicit none
            real(kind=dp), intent(inout) :: z
            real(kind=dp), intent(out) :: z1, pp
            integer, intent(in) :: n
            integer :: i
            real(kind=dp) :: p1, p2, p3
            p1 = 1.0_dp
            p2 = 0.0_dp
            do i = 1, n
                p3 = p2
                p2 = p1
                p1 = ((2*i - 1)*z*p2 - (i - 1)*p3)/i
            end do
            pp = n*(z*p1 - p2)/(z**2 - 1.0_dp)
            z1 = z
            z = z1 - p1/pp
        end subroutine compute_zs

    end subroutine init_gen_gauss

    function integrate(self, f, a, b) result(r)
        use :: quad_func_interface
        implicit none
        class(gen_gauss_type), intent(in) :: self
        procedure(quad_func_type) :: f
        real(kind=dp), intent(in) :: a, b
        real(kind=dp) :: r
        real(kind=dp) :: x, delta
        integer :: i
        x = 0.5*(a + b)
        delta = 0.5*(b - a)
        r = 0.0_dp
        do i = 1, size(self%xs)
            r = r + self%ws(i)*f(x + self%xs(i)*delta)
        end do
        r = r*delta
    end function integrate

    subroutine print_params(self)
        implicit none
        class(gen_gauss_type), intent(in) :: self
        integer :: i
        do i = 1, size(self%xs)
            print '(2F20.15)', self%xs(i), self%ws(i)
        end do
    end subroutine print_params

end module gauss_mod


      subroutine DGED(A,LDA,N,IPVT,DET)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-05-25 DGED Krogh Minor change for making .f90 version.
c>> 1996-03-30 DGED Krogh  Added external statement.
C>> 1994-10-20 DGED Krogh  Changes to use M77CON
C>> 1992-04-14 DGED CLL Using (*) in dimensions rather than (1).
C>> 1990-01-19 CLL added test to avoid looping when some A(I,I) = 0.
C>> 1987-08-20 DGED   Lawson  Initial code.
c--D replaces "?": ?GED
C
C     DGED computes the determinant of the matrix A
C     using the LU factorization of A given in the array A().
c     ------------------------------------------------------------------
c                        Subroutine arguments
C
C     A(,)  [in]  An array of size at least N x N.  On entry must
c            contain the LU factors of an N x N  matrix, A.  It is
c            expected that this factorization will have been computed by
c            use of _GEFA, either directly or indirectly via use of
c            _GEFCO, _GEFS or _GEFSC.  This subr will not alter the
c            contents of A(,)
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the original matrix, A.
C
C     IPVT()  [in]  An integer array of length at least N, containg a
c           record of the row interchanges made during factorization of
c           A.
C
C     DET() [out]  Array of length 2.  On return will contain a
c           representation of the determinant of A of the form
C                DETERMINANT = DET(1) * 10.0**DET(2)
C           DET(2) will be integer valued: plus, minus or zero.
c           If the determinant is zero then DET(1) = 0.0 and DET(2) = 0.
c           If the determinant is nonzero the scaling chosen will not be
c           determined exclusively by the value of the determinant, but
c           will tend to choose DET(2) = 0.0 when the determinant is not
c           extremely large or small in magnitude.  This is a change
c           from the normalization used in LINPACK.
c     ------------------------------------------------------------------
c                       Machine dependent values
c
c     The following values are set depending on the machine underflow
c     and overflow limits.
c           FBIG   = 10.0**STEP
c           FSMALL = 10.0**(-STEP) = 1.0/FBIG
c           TBIG   = FBIG/10.0 = 10.0**(STEP-1)
c           TSMALL = FSMALL*10.0 = 10.0**(-(STEP-1)) = 1.0/TBIG
c
c     where STEP is a positive integer value chosen so that FBIG**2 is
c     slightly smaller than the overflow limit and FBIG**(-2) is
c     slightly larger than the underflow limit.
c     If one wanted a machine-independent version of this code, one
c     could set STEP small enough so that FBIG**2 and FBIG**(-2) will
c     not be off-scale for any "reasonable" computer.  For instance one
c     might set STEP = 10.  However, setting STEP as large as possible
c     reduces the number of scaling multiplications and increases the
c     likelihood that the subroutine will be able to set DET(2) = zero.
c     These parameters added by C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
c     Subprograms referenced: D1MACH
C     ------------------------------------------------------------------
      external D1MACH
      integer LDA,N,IPVT(*),  I, K
      double precision D1MACH
      double precision A(LDA,*),DET(2), ONE, ZERO, DT1, ATERM
      double precision STEP, TBIG, TSMALL, FBIG, FSMALL, TEN, DT2
      logical FIRST
      parameter(ONE = 1.0D0, ZERO = 0.0D0, TEN = 10.0D0)
      save FIRST,STEP,FBIG,FSMALL,TBIG,TSMALL
      data FIRST / .true. /
C     ------------------------------------------------------------------
c                                     Set machine-dependent values.
      if(FIRST) then
         FIRST = .false.
         K = min(log10(D1MACH(2)/TEN), -log10(D1MACH(1)*TEN)) / 2
         STEP = K-1
         FBIG = TEN**STEP
         FSMALL = ONE/FBIG
         TBIG = FBIG/TEN
         TSMALL = FSMALL * TEN
      endif
C                                         Initialize DT1 and DT2.
         DT1 = ONE
         DT2 = ZERO
c                                         Begin main loop.
         do 150 I = 1, N
            if (IPVT(I) .NE. I) DT1 = -DT1
            ATERM = A(I,I)
            if(ATERM .eq. ZERO) then
               DT1 = ZERO
               DT2 = ZERO
               go to 160
            endif
c
c              Scale ATERM, if necessary, to bring its magnitude into
c              the range from TSMALL to TBIG.
c
            if( abs(ATERM) .ge. TBIG) then
   10          ATERM = ATERM * FSMALL
               DT2 = DT2 + STEP
               if( abs(ATERM) .ge. TBIG) go to 10
            elseif(abs(ATERM) .le. TSMALL) then
   20          ATERM = ATERM * FBIG
               DT2 = DT2 - STEP
               if( abs(ATERM) .le. TSMALL) go to 20
            endif
c
c              Scale DT1, if necessary, to bring its magnitude into
c              the range from TSMALL to TBIG.
c
            if (abs(DT1) .ge. TBIG) then
               DT1 = DT1 * FSMALL
               DT2 = DT2 + STEP
            elseif (abs(DT1) .lt. TSMALL) then
               DT1 = DT1 * FBIG
               DT2 = DT2 - STEP
            endif
c                                         Update the determinant value.
            DT1 = ATERM*DT1
            if (DT1 .eq. ZERO) then
               DT2 = ZERO
               go to 160
            endif
  150    continue
  160 continue
      DET(1) = DT1
      DET(2) = DT2
      return
      end


program anova

! The present code is for c-anova in 3 dimension. However extenstion in N dimension is easy.
! The trucation dimension is 2.
! Author: Pavan Mehta, AMIMechE
! Reseatch Engineer, M2P2 lab, CNRS UMR 7340, France
! Email: mehtapavanp@gmail.com

implicit none

integer :: i,j,k, anc1, anc2, anc3, N1, N2, N3

parameter (N1=10)
parameter (N2=10)
parameter (N3=10)

double precision F(N1,N2,N3), F_1(N1), F_2(N2), F_3(N3), F_12(N1,N2)
double precision F_13(N1,N3), F_23(N2,N3), Error(N1,N2,N3), f_0, F_anova(N1,N1,N3)

write(*,*) "Author: Pavan Mehta"
write(*,*) "Research Engineer - M2P2 Lab"
write(*,*) "Email: mehtapavanp@gmail.com"

!Setting up the Anchors

!anchor in first dimesnion = anc1
!anchor in second dimesnion = anc2
!anchor in third dimesnion = anc3

anc1 = N1/2 ! N1 is even, similarly for N2 and N3
anc2 = N2/2
anc3 = N3/2

!**********************************************************
! Test Function evaluation
!**********************************************************

Do i=1, N1

	Do j=1, N2

		Do k=1, N3

			F(i,j,k) =  i**2 + j**2 + k**2

		enddo
	enddo
enddo

!**********************************************************
! c-Anova Decomposition
!**********************************************************

! Mean or zeroth evaluation

f_0 = F(anc1,anc2,anc3)

write(*,*) "Ancored Anova Depcompisition"
write(*,*) "Anchored Points", anc1, anc2, anc3

!Computing first ans Second order term. Simultaiounly preforming c-Anova

Do i=1, N1

	Do j=1, N2

		Do k=1, N3

			!-----------------------------------------------------------------------------------

			!First order Terms

			F_1(i) = F(i,anc2,anc3) - f_0

			F_2(j) = F(anc1,j,anc3) - f_0

			F_3(k) = F(anc1,anc2,k) - f_0

			!-----------------------------------------------------------------------------------

			!Second order Terms

			F_12(i,j) = F(i,j,anc3) - F_1(i) - F_2(j) - f_0

			F_13(i,k) = F(i,anc2,k) - F_1(i) - F_3(k) - f_0

			F_23(j,k) = F(anc1,j,k) - F_2(j) - F_3(k) - f_0

			!-----------------------------------------------------------------------------------

			!Function evaluation using c-Anova

			F_anova(i,j,k) = f_0 + F_1(i) + F_2(j) + F_3(k) + F_12(i,j) + F_13(i,k) + F_23(j,k)

			Error(i,j,k) = F_anova(i,j,k) - F(i,j,k)

			write(*,*) i,j,k, "Error", Error(i,j,k), "=", F_anova(i,j,k), "-", F(i,j,k)

		enddo
	enddo
enddo

end program anova


! parameter (nmax=10)

subroutine RK4(Y,DYDX,N,X,H,YOUT)

  ! Given values for N variables y and their derivatives DYDX known
  ! at X, use the fourth-order Runge-Kutta method to advance the
  ! solution over an interval H and return the incremented variables
  ! as YOUT, which need not be a distinct array from Y.  The user
  ! supplies the subroutine DERIVS(X,Y,DYDX) which returns the
  ! derivatives DYDX at X

  ! Routine taken from Numerical Recipes, 15.1, p. 553

  ! set to the maximum number of functions
  parameter (nmax=10)
  dimension Y(N),DYDX(N),YOUT(N),YT(NMAX),DYT(NMAX),DYM(NMAX)

  hh=h*0.5
  h6=h/6.
  xh=x+hh

  ! first step
  do i=1,n
     yt(i)=y(i)+hh*dydx(i)
  end do
  ! second step
  call derivs(xh,yt,dyt)
  do i=1,n
     yt(i)=y(i)+hh*dyt(i)
  end do
  ! third step
  call derivs(xh,yt,dym)
  do i=1,n
     yt(i)=y(i)+h*dym(i)
     dym(i)=dyt(i)+dym(i)
  end do
  ! fourth step
  call derivs(x+h,yt,dyt)
  do i=1,n
     yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
  end do
  return
end subroutine RK4


! Created by EverLookNeverSee@GitHub on 5/7/20.
! This function takes an integer value as its parameter and
! and thrn returns factorial of n.

function fact(n) result(factorial)
    integer :: n, i
    real :: factorial, temp
    if (n <= 0) then
        factorial = -1.0    ! error
        else if(n == 0) then
        factorial = 1.0     ! factorial of zero
        else
        temp = 1.0
        do i = 2, n
            temp = temp * i
        end do
        factorial = temp
    end if
end function fact


PROGRAM LA_DSYGV_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_SYGV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, INFO, N
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), W(:)
   REAL(WP), ALLOCATABLE :: A(:,:), B(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE(NOUT,*) 'DSYGV ET_Example Program Results.'
   READ(NIN,*) ! SKIP HEADING IN DATA FILE
   READ(NIN,*) N
   ALLOCATE ( A(N,N), B(N,N), W(N), AA(N,N), BB(N,N) )
      DO I = 1, N
        READ(NIN,*) (AA(I, J), J = 1, N)
      ENDDO
      DO I = 1, N
        READ(NIN,*) (BB(I, J), J = 1, N)
      ENDDO
      A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      ENDDO
      WRITE(NOUT,*) 'The matrix B:'
      DO I = 1, N
        WRITE(NOUT,FMT) B(I,:)
      ENDDO
!
   WRITE(NOUT,*) '---------------------------------------------------------'
   WRITE(NOUT,*)
   WRITE ( NOUT, * )'Details of LA_DSYGV LAPACK Subroutine Results.'
   WRITE(NOUT,*)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SYGV(A, B, W, INFO=INFO)'
   WRITE(NOUT,*) 'LA_SYGV computes all the eigenvalues of a real'
   WRITE(NOUT,*) 'symmetric-definite generalized eigenproblem'
   WRITE(NOUT,*) 'A*x = lambda*B*x'
   WRITE(NOUT,*) 'ON ENTRY: A, B'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   B - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, B, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   B - the triangular factor U from the Cholesky'
   WRITE(NOUT,*) '       factorization'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   B=BB
   CALL LA_SYGV(A,B,W,INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYGV:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYGV(A, B, W, JOBZ='V', INFO=INFO)"
   WRITE(NOUT,*) 'LA_SYGV computes all the eigenvalues and eigenvectors'
   WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
   WRITE(NOUT,*) 'A*x = lambda*B*x'
   WRITE(NOUT,*) 'ON ENTRY: A, B'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   B - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, B, W'
   WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
   WRITE(NOUT,*) '       Z**T*B*Z = I'
   WRITE(NOUT,*) '   B - the triangular factor U from the Cholesky'
   WRITE(NOUT,*) '       factorization'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   B=BB
   CALL LA_SYGV(A,B,W,JOBZ='V',INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYGV:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_SYGV:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYGV(A, B, W, JOBZ='V', UPLO='L', INFO=INFO)"
   WRITE(NOUT,*) 'LA_SYGV computes all the eigenvalues and eigenvectors'
   WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
   WRITE(NOUT,*) 'A*x = lambda*B*x'
   WRITE(NOUT,*) 'ON ENTRY: A, B'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) '   B - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, B, W'
   WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
   WRITE(NOUT,*) '       Z**T*B*Z = I'
   WRITE(NOUT,*) '   B - the triangular factor L from the Cholesky'
   WRITE(NOUT,*) '       factorization'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   B=BB
   CALL LA_SYGV(A,B,W,JOBZ='V',UPLO='L',INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYGV:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_SYGV:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYGV(A, B, W, 2, 'V', 'L', INFO)"
   WRITE(NOUT,*) 'LA_SYGV computes all the eigenvalues and eigenvectors'
   WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
   WRITE(NOUT,*) 'A*B*x = lambda*x'
   WRITE(NOUT,*) 'ON ENTRY: A, B'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) '   B - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, B, W'
   WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
   WRITE(NOUT,*) '       Z**T*B*Z = I'
   WRITE(NOUT,*) '   B - the triangular factor L from the Cholesky'
   WRITE(NOUT,*) '       factorization'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   B=BB
   CALL LA_SYGV(A,B,W,2,'V','L',INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYGV:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_SYGV:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_SYGV(A, B, W, 3, 'V', INFO=INFO)"
   WRITE(NOUT,*) 'LA_SYGV computes all the eigenvalues and eigenvectors'
   WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
   WRITE(NOUT,*) 'B*A*x = lambda*x'
   WRITE(NOUT,*) 'ON ENTRY: A, B'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) '   B - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, B, W'
   WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
   WRITE(NOUT,*) '       Z**T*inv(B)*Z = I'
   WRITE(NOUT,*) '   B - the triangular factor U from the Cholesky'
   WRITE(NOUT,*) '       factorization'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   B=BB
   CALL LA_SYGV(A,B,W,3,'V',INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_SYGV:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_SYGV:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
   WRITE(NOUT,*) 'INFO = ',INFO
!
END PROGRAM LA_DSYGV_ET_EXAMPLE


program project2_2
!------------------------------------------------------------------------------------------------
! Fortran program to solve the problem for the following
! special choices of q.
!                 q(v) = 1               Lax-Friedrichs
!                 q(v) = |v|             First-order upwind
!                 q(v) = v^2             Lax-Wendroff
!                 q(v) = 1/3 + 2/3*v^2   Minimum dispersion
! initial condition: u(x,0) = sin(2*PI*x)
! for 0 <= x <= 1 and periodic boundary conditions, u(0,t) = u(1,t).
! uniform grid spacings: 32
! compute to a time T where a*T = 3/2
! using v = 1.0, 0.75, 0.50, 0.25
!
! figure out amplitude and phase errors for each case.
! compute L_1 norm where N = 3/(2*v*Delta x), the final time step.

implicit none

! define variables
integer :: N, nn, i, j, j1, j2, j3, j4, vv
integer, parameter :: M = 32
real :: a, v, Delta_x, Delta_t, &
  pi1, pi2, pi3, pi4, p2_1, p2_2, p2_3, p2_4, amp1, amp2, amp3, amp4, &
  ph1, ph2, ph3, ph4, pherr1, pherr2, pherr3, pherr4, &
  L1_1, L1_2, L1_3, L1_4, s1, s2, s3, s4
real, parameter :: PI = 4. * atan(1.)
real, allocatable, dimension(:,:) :: u1, u2, u3, u4
real, dimension(1:M) :: F1, F2, F3, F4

	write (*, '(/a/a/)') "------------------------------------------------------------",		&
				"Fortran solver to advection equation with 32 grid uniform spacing."
	write (*, '(a)') "Please enter the wave speed:"
  read (*,*) a

  write (*,'(/a)') "Output for amplitudes:"
  call create_file(12)
  write (12, '(2x, a, T20, a, T40, a, T60, a, T80, a)') "v", "Lax-Friedrichs", "First-orderUpwind", &
    "Lax-Wendroff", "MinimumDispersion"

  write (*,'(a)') "Output for phase errors:"
  call create_file(14)
  write (14, '(2x, a, T20, a, T40, a, T60, a, T80, a)') "v", "Lax-Friedrichs", "First-orderUpwind", &
    "Lax-Wendroff", "MinimumDispersion"

  write (*,'(a)') "Output for L_1 norms:"
  call create_file(16)
  write (16, '(2x, a, T20, a, T40, a, T60, a, T80, a)') "v", "Lax-Friedrichs", "First-orderUpwind", &
    "Lax-Wendroff", "MinimumDispersion"

  v = 1.0

  do vv = 1, 4
    write (*, '(/a, f4.2)') "CFL number v = ", v
    ! confine the x in the range of [0,1]
    Delta_x = 1.0/M
    Delta_t = v * Delta_x / a
    ! total time steps
    N = 3.0/2.0/(a*Delta_t)

    ! create arrays storing data for four schemes
    call create_array(M,u1,a,v,N,pi1)
    call create_array(M,u2,a,v,N,pi2)
    call create_array(M,u3,a,v,N,pi3)
    call create_array(M,u4,a,v,N,pi4)

    do nn = 1, N
      ! calculate all fluxes
      do i = 1, M-1
        F1(i) = LaxFriedrichs(u1(i+1,nn), u1(i,nn))
        F2(i) = FirstOrderUpwind(u2(i+1,nn), u2(i,nn))
        F3(i) = LaxWendroff(u3(i+1,nn), u3(i,nn))
        F4(i) = MinimumDispersion(u4(i+1,nn), u4(i,nn))
      end do
      F1(M) = LaxFriedrichs(u1(1,nn), u1(M,nn))
      F2(M) = FirstOrderUpwind(u2(1,nn), u2(M,nn))
      F3(M) = LaxWendroff(u3(1,nn), u3(M,nn))
      F4(M) = MinimumDispersion(u4(1,nn), u4(M,nn))

      ! calculate solution in next time step
      u1(1,nn+1) = u1(1,nn) - v/a * (F1(1) - F1(M))
      u2(1,nn+1) = u2(1,nn) - v/a * (F2(1) - F2(M))
      u3(1,nn+1) = u3(1,nn) - v/a * (F3(1) - F3(M))
      u4(1,nn+1) = u4(1,nn) - v/a * (F4(1) - F4(M))
      ! to obtain the peak value of the solution in 16th time step, which can be used for calculation of amplitude
      if (nn == 15) then
        p2_1 = u1(1,nn+1)
        p2_2 = u2(1,nn+1)
        p2_3 = u3(1,nn+1)
        p2_4 = u4(1,nn+1)
      end if
      ! calculate solution in next time step
      do i = 2, M
        u1(i,nn+1) = u1(i,nn) - v/a * (F1(i) - F1(i-1))
        u2(i,nn+1) = u2(i,nn) - v/a * (F2(i) - F2(i-1))
        u3(i,nn+1) = u3(i,nn) - v/a * (F3(i) - F3(i-1))
        u4(i,nn+1) = u4(i,nn) - v/a * (F4(i) - F4(i-1))
        if (nn == 15) then
          ! to obtain the peak value of the solution in 16th time step
          if (p2_1 < u1(i,nn+1)) then
            p2_1 = u1(i,nn+1)
          end if
          if (p2_2 < u2(i,nn+1)) then
            p2_2 = u2(i,nn+1)
          end if
          if (p2_3 < u3(i,nn+1)) then
            p2_3 = u3(i,nn+1)
          end if
          if (p2_4 < u4(i,nn+1)) then
            p2_4 = u4(i,nn+1)
          end if
          ! to obtain the phase of the point of inflection (u=0)
          if (u1(i,nn+1)<0 .and. u1(i-1,nn+1)>0) then
            ph1 = (u1(i-1,nn+1)/(u1(i-1,nn+1)-u1(i,nn+1)) + (i-2))*Delta_x
          end if
          if (u2(i,nn+1)<0 .and. u2(i-1,nn+1)>0) then
            ph2 = (u2(i-1,nn+1)/(u2(i-1,nn+1)-u2(i,nn+1)) + (i-2))*Delta_x
          end if
          if (u3(i,nn+1)<0 .and. u3(i-1,nn+1)>0) then
            ph3 = (u3(i-1,nn+1)/(u3(i-1,nn+1)-u3(i,nn+1)) + (i-2))*Delta_x
          end if
          if (u4(i,nn+1)<0 .and. u4(i-1,nn+1)>0) then
            ph4 = (u4(i-1,nn+1)/(u4(i-1,nn+1)-u4(i,nn+1)) + (i-2))*Delta_x
          end if
        end if
      end do
      ! calculate solution at the right boundary in next time step
      u1(M+1,nn+1) = u1(1,nn+1)
      u2(M+1,nn+1) = u2(1,nn+1)
      u3(M+1,nn+1) = u3(1,nn+1)
      u4(M+1,nn+1) = u4(1,nn+1)
      ! to obtain the peak value of the solution in 16th time step
      if (nn == 15) then
        if (p2_1 < u1(M+1,nn+1)) then
          p2_1 = u1(M+1,nn+1)
        end if
        if (p2_2 < u2(M+1,nn+1)) then
          p2_2 = u2(M+1,nn+1)
        end if
        if (p2_3 < u3(M+1,nn+1)) then
          p2_3 = u3(M+1,nn+1)
        end if
        if (p2_4 < u4(M+1,nn+1)) then
          p2_4 = u4(M+1,nn+1)
        end if
      end if
    end do

    ! calculate the relative phase error
    pherr1 = (ph1/(0.5 + a * 15.0 * Delta_t) - 1.0) / 15.0
    pherr2 = (ph2/(0.5 + a * 15.0 * Delta_t) - 1.0) / 15.0
    pherr3 = (ph3/(0.5 + a * 15.0 * Delta_t) - 1.0) / 15.0
    pherr4 = (ph4/(0.5 + a * 15.0 * Delta_t) - 1.0) / 15.0

    ! calculate the amplitude using two peak values in two time steps
    amp1 = (p2_1/pi1)**(1.0/15.0)
    amp2 = (p2_2/pi2)**(1.0/15.0)
    amp3 = (p2_3/pi3)**(1.0/15.0)
    amp4 = (p2_4/pi4)**(1.0/15.0)

    ! calculate the L_1 error norms
    s1 = 0.; s2 = 0.; s3 = 0.; s4 = 0.
    do j = 1, M+1
      s1 = s1 + abs(u1(j,N+1) - sin(2*PI*((j-1)*Delta_x-1.5)))
      s2 = s2 + abs(u2(j,N+1) - sin(2*PI*((j-1)*Delta_x-1.5)))
      s3 = s3 + abs(u3(j,N+1) - sin(2*PI*((j-1)*Delta_x-1.5)))
      s4 = s4 + abs(u4(j,N+1) - sin(2*PI*((j-1)*Delta_x-1.5)))
    end do
    L1_1 = s1 / (M+1)
    L1_2 = s2 / (M+1)
    L1_3 = s3 / (M+1)
    L1_4 = s4 / (M+1)

    write (12, '(2x, f4.2, T20, f8.5, T40, f8.5, T60, f8.5, T80, f8.5)') v, amp1, amp2, amp3, amp4
    write (14, '(2x, f4.2, T20, f11.7, T40, f11.7, T60, f11.7, T80, f11.7)') v, pherr1, pherr2, pherr3, pherr4
    write (16, '(2x, f4.2, T20, f8.4, T40, f8.4, T60, f8.4, T80, f8.4)') v, L1_1, L1_2, L1_3, L1_4
    write (*,'(a)') "Output for Lax-Friedrichs:"
    call output(u1,M,N,17+vv)
    write (*,'(a)') "Output for First-order Upwind:"
    call output(u2,M,N,21+vv)
    write (*,'(a)') "Output for Lax-Wendroff:"
    call output(u3,M,N,25+vv)
    write (*,'(a)') "Output for Minimum Dispersion:"
    call output(u4,M,N,29+vv)

    v = v - 0.25

  end do

  write (*, '(/2x, a)') "Amplitudes output successfully done!"
  write (*, '(2x, a)') "Phase errors output successfully done!"
  write (*, '(2x, a)') "L_1 norms output successfully done!"

contains
  ! create solution array
  subroutine create_array(M,u,a,v,N,peak)
    implicit none
    integer :: alstat_1, i
    integer, intent(in) :: M
    integer, intent(out) :: N
    real, intent(in) :: a, v
    real, intent(out) :: peak
    real, allocatable, dimension(:,:), intent(out) :: u

    ! allocate two dimension array for storing the points of the grid
    allocate (u(1:(M+1), 1:N+1), stat = alstat_1)
    if (alstat_1 /= 0) then
      write (*, '(2x, a, /a)') "Error, unable to allocate memory. ", "Program terminated."
      stop
    end if
    ! initialize the array
    u = 0.
    ! initialize the peak value on the boundary curve
    peak = 0.
    ! initial condition
    do i = 1, M
      u(i,1) = sin(2*PI*(i-1)*Delta_x)
      if (peak < u(i,1)) then
        peak = u(i,1)
      end if
    end do
    ! periodic boundary condition
    u(M+1,1) = u(1,1)
  end subroutine create_array

  ! interface flux function for four schemes
  function LaxFriedrichs(u11,u12)
    real :: u11, u12, LaxFriedrichs
    LaxFriedrichs = 1.0/2.0*(f(u11)+f(u12)) - 1.0/2.0*a/v*(u11-u12)
  end function LaxFriedrichs

  function FirstOrderUpwind(u21,u22)
    real :: u21, u22, FirstOrderUpwind
    FirstOrderUpwind = 1.0/2.0*(f(u21)+f(u22)) - abs(v)/2.0*a/v*(u21-u22)
  end function FirstOrderUpwind

  function LaxWendroff(u31,u32)
    real :: u31, u32, LaxWendroff
    LaxWendroff = 1.0/2.0*(f(u31)+f(u32)) - v**2.0/2.0*a/v*(u31-u32)
  end function LaxWendroff

  function MinimumDispersion(u41,u42)
    real :: u41, u42, MinimumDispersion
    MinimumDispersion = 1.0/2.0*(f(u41)+f(u42)) - (1.0/3.0+2.0/3.0*v**2.0)/2.0*a/v*(u41-u42)
  end function MinimumDispersion

  function f(x)
    real :: f, x
    f = a * x
  end function f

  ! solution output subroutine
  subroutine output(u,M,N,file_num)
    implicit none
    character(30) :: wrfile_output
    integer :: wropst_1, i, nn
    integer, intent(in) :: M, N, file_num
    real, allocatable, dimension(:,:), intent(in) :: u

    ! prompt for the errors output file name
    do
      write (*, '(2x, a)', advance = "no") "Output File Name: "

      ! read errors output file name
      read (*,*) wrfile_output

      ! open output file (read access)
      ! if open successful, exit loop
      ! 		otherwise, display error message
      open(file_num, file = wrfile_output, status="new", 					&
            action="write", position="rewind", 					&
            iostat=wropst_1)
      if (wropst_1 == 0) exit
      write (*, '(2x, a, a/, a)') "Unable to create ",					&
                  "output file.", "Please re-enter..."
    end do

    do nn = 1, N+1
      do i = 1, M+1
        write (file_num, '(2x, f10.7)', advance = "no") u(i,nn)
      end do
      write (file_num,*)
    end do

    write (*, '(2x, a)') "Solution output successfully done!"
  end subroutine output

  ! create output file for amplitude, phase error and L_1 norm
  subroutine create_file(file_num)
    implicit none
    character(30) :: wrfile_output
    integer :: wropst_1, file_num
    do
      write (*, '(2x, a)', advance = "no") "Output File Name: "

      ! read errors output file name
      read (*,*) wrfile_output

      ! open output file (read access)
      ! if open successful, exit loop
      ! 		otherwise, display error message
      open(file_num, file = wrfile_output, status="new", 					&
            action="write", position="rewind", 					&
            iostat=wropst_1)
      if (wropst_1 == 0) exit
      write (*, '(2x, a,a/,a)') "Unable to create ",					&
                  "output file.", "Please re-enter..."
    end do
  end subroutine create_file

end program project2_2


Module hs_structure
  Use math_constants
  Implicit None
  Contains

  !Function that calculates the direct correlation function of a Hard Sphere
  !System using Percus-Yevick Closure relationship
  ! c(k,ϕ)
  !Depends only on the wave-vector "k" for "k>=0", and density "ϕ" for "ϕ>0"
  Function c_hs_py(phi,k) result(c)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: c
    Real * 8 :: k_func,ckdum,dum1,dum2,dum3,dum4,dumsin,dumcos
    Real * 8 :: k2,k3,k4,k6
    dum1 = - ( ( 1.d0 + 2.d0 * phi ) ** 2 )
    dum2 = 6.d0 * phi * ( ( 1.d0 + ( phi / 2.d0 ) ) ** 2 )
    dum3 = - 0.5d0 * phi * ( ( 1.d0 + ( 2.d0 * phi ) ) ** 2 )
    dum4 = ( 1.d0 - phi )
    dum4 = dum4 ** 4
    dum1 = dum1 / dum4
    dum2 = dum2 / dum4
    dum3 = dum3 / dum4
    k2 = k * k
    If (k > 0.075d0 ) Then
      dumsin = sin( k )
      dumcos = cos( k )
      k3 = k2 * k
      k4 = k3 * k
      k6 = k4 * k2
      c = ( dum1 * ( dumsin - k * dumcos ) / ( k3 ) ) + &
      & ( dum2 * ( ( ( 2.d0 * k ) * dumsin ) + ( ( - ( k2 ) + 2.d0 ) * dumcos ) - 2.d0 ) / &
      & ( k4 ) ) + ( dum3 * ( ( ( 4.d0 * ( k3 ) - 24.d0 * k ) * dumsin )&
      & + ( ( - ( k4 ) + 12.d0 * ( k2 ) - 24.d0 ) * dumcos ) + 24.d0 ) / ( k6 ))
    Else
      c = dum1 * ( (1.d0 / 3.d0) - ( k2 / 30.d0 ) ) + dum2 * ( 0.25d0 -  ( k2 / 36.d0 ) ) &
      & + dum3 * ( ( 1.d0 / 6.d0 ) - ( k2 / 48.d0 ) )
    End If
    c = c * 4.d0 * pi
    return
  End Function

  !Function that calculates the inverse structure factor of a Hard Sphere system
  !Using Percus-Yevick Closure relationship
  ! S(k,ϕ)
  !Depends only on the wave-vector "k" for "k>=0", and density "ϕ" for "ϕ>0"
  Function is_hs_py(phi,k) result(is)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: is
    is = c_hs_py(phi,k)
    is = 1.d0 - 6.d0 * phi * is / pi
    return
  End Function

  !Function that calculates the structure factor of a Hard Sphere system
  !Using Percus-Yevick Closure relationship
  ! S(k,ϕ)
  !Depends only on the wave-vector "k" for "k>=0", and density "ϕ" for "ϕ>0"
  Function s_hs_py(phi,k) result(s)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: s
    s = 1.d0 / is_hs_py(phi,k)
    return
  End Function

  !Function that calculates the direct correlation function of a Hard Sphere
  !System using Verlet-Weiss correction
  ! c(k,ϕ)
  !Depends only on the wave-vector "k" for "k>=0", and density "ϕ" for "ϕ>0"
  Function c_hs_vw(phi,k) result(c)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: c
    Real * 8 :: k_vw,phi_vw
    !Verlet-Weiss correction for the volume fraction
    phi_vw = phi*(1.d0 - (phi / 16.d0))
    !Verlet-Weiss correction for the wave-vector
    k_vw = k * ( ( phi_vw / phi ) ** ( 1.d0 / 3.d0 ) )
    c = c_hs_py(phi_vw,k_vw)
  End Function

  !Function that calculates the inverse structure factor of a Hard Sphere system
  !Using Verlet-Weiss correction
  ! S(k,ϕ)
  !Depends only on the wave-vector "k" for "k>=0", and density "ϕ" for "ϕ>0"
  Function is_hs_vw(phi,k) result(is)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: is
    Real * 8 :: phi_vw, k_vw
    !Verlet-Weiss correction for the volume fraction
    phi_vw = phi*(1.d0 - (phi / 16.d0))
    !Verlet-Weiss correction for the wave-vector
    k_vw = k * ( ( phi_vw / phi ) ** ( 1.d0 / 3.d0 ) )
    is = is_hs_py(phi_vw,k_vw)
    return
  End Function

  !Function that calculates the structure factor of a Hard Sphere system
  !Using Verlet-Weiss correction
  ! S(k,ϕ)
  !Depends only on the wave-vector "k" for "k>=0", and density "ϕ" for "ϕ>0"
  Function s_hs_vw(phi,k) result(s)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: s
    s = 1.d0 / is_hs_vw(phi,k)
    return
  End Function

  !This subroutine writes down the parameters related with structural calculation for
	!a Hard Disk system
	Subroutine writting_hs_p(sys_cond,approx,i_unit)
		Real * 8, dimension(:), intent(in) :: sys_cond
		Integer :: i_unit
		Character(*), intent(in) :: approx
		Real * 8 :: phi
		Integer :: i1
		!System conditions
		phi = sys_cond(1)
		Write(i_unit,*) "### Hard Sphere ###"
		Write(i_unit,*) "Volume Fraction phi = ", phi
		Write(i_unit,*) "###############################"
		Write(i_unit,*) "### Structure Approximation ###"
		Select case (approx)
		case ("PY00")
			Write(i_unit,*) "				Percus-Yevick Wertheim Solution"
		case ("VW00")
			Write(i_unit,*) "				Verlet Weis correction to PY Wertheim solution"
		case Default
			Write(i_unit,*) "				"//approx
		End Select
    Write(i_unit,*) "###############################"
	End Subroutine

  Function P_HS_CS(T,phi) result(P)
    Implicit None
    Real * 8, intent(in) :: T, phi
    Real * 8 :: P
    P = 6.d0 * phi * T * (1.d0 + phi**2 - phi **3) / ( pi * (1.d0 - phi)**3 )
  End Function

End Module


      SUBROUTINE correl(x, y, k, r2, xbar, ybar, sig2x, sig2y)
C     Compute statistical parameters between two vectors:
C       mean for each, variance for each, and correlation between.
C     Uses unbiased estimator of variance.
C     Robert Grumbine 1/22/94.
C     LAST MODIFIED 8 April 1994.

      IMPLICIT none

      INTEGER k
      REAL x(k), y(k)
      REAL r2, xbar, ybar, sig2x, sig2y

      REAL sumx, sumx2, sumxy
C     The above are functions which compute sums of x, x**2, x*y,
C       respectively.
      REAL sx, sy, x2, y2, xy

      sx = sumx(x, k)
      sy = sumx(y, k)
      x2 = sumx2(x, k)
      y2 = sumx2(y, k)
      xy = sumxy(x, y, k)

      xbar = sx/FLOAT(k)
      ybar = sy/FLOAT(k)
      sig2x = (FLOAT(k)*x2-sx*sx)/FLOAT(k)/FLOAT(k-1)
      sig2y = (FLOAT(k)*y2-sy*sy)/FLOAT(k)/FLOAT(k-1)
      r2    = (FLOAT(k)*xy - sx*sy) /
     1    SQRT( (FLOAT(k)*x2-sx*sx)*(FLOAT(k)*y2-sy*sy) )

      RETURN
      END