! ------------------------------------------------------------------------------
!
! Main Program mtclim
!
! author: Johannes Brenner
!
! created: 03.08.2016
! last update: 30.05.2017
!
! ------------------------------------------------------------------------------
!
program main
!
use mo_kind,      only: i4, dp
use mo_ansi_colors, only: color, c_red, c_green
use mo_mtclim
!
!----------------------------------------
! variable declarations
!
integer(i4)                         :: i
real(dp), dimension(:), allocatable :: parameterset
! path namelists
character(len=*), parameter :: fileini = "ini"
character(len=*), parameter :: fileparameters = "parameters"
! ini namefile
! input, output file names
character(265)        :: in_meteo, outprefix
namelist / io_ini / in_meteo, outprefix
!
! controls
integer(i4) :: nhead, ndays
integer(i4) :: indewpt, outhum, inyear, lwrad, netlwrad
!
namelist / control_ini / nhead, ndays, indewpt, outhum, inyear, lwrad, netlwrad
!
! site characteristics
real(dp)              :: base_elev,base_isoh,site_lat,site_elev,site_slp,site_asp
real(dp)              :: site_isoh,site_ehoriz,site_whoriz,tmax_lr,tmin_lr
!
namelist / parameters_ini / base_elev,base_isoh,site_lat,site_elev,site_slp,site_asp,&
site_isoh,site_ehoriz,site_whoriz,tmax_lr,tmin_lr
!
! parameters
!
real(dp)      :: TBASE,ABASE,C,B0,B1,B2,RAIN_SCALAR,DIF_ALB,SC_INT,SC_SLOPE, &
SNOW_TCRIT,SNOW_TRATE,TDAYCOEF,LWAVE_COR
namelist / parameters / TBASE,ABASE,C,B0,B1,B2,RAIN_SCALAR,DIF_ALB,SC_INT,SC_SLOPE, &
     SNOW_TCRIT,SNOW_TRATE,TDAYCOEF,LWAVE_COR
!
! read namelists in ini file
!
integer(i4),  dimension(:), allocatable :: yday         !/* array of yearday values */
real(dp),     dimension(:), allocatable :: tmax         !/* array of base maximum temperature values */
real(dp),     dimension(:), allocatable :: tmin         !/* array of base minimum temperature values */
real(dp),     dimension(:), allocatable :: prcp         !/* array of base daily precipitation values */
!real(dp),     dimension(:), allocatable :: swrad_obs    !/* array of observed incoming shortwave radiation values */
!real(dp),     dimension(:), allocatable :: lwrad_obs    !/* array of observed incoming longwave radiation values */
!real(dp),     dimension(:), allocatable :: netlwrad_obs !/* array of observed net outgoing longtwave radiation values */
!real(dp),     dimension(:), allocatable :: tdew        !/* array of base dewpoint temperature values */
real(dp),     dimension(:), allocatable :: s_tmax       !/* array of site tmax values */
real(dp),     dimension(:), allocatable :: s_tmin       !/* array of site tmin values */
real(dp),     dimension(:), allocatable :: s_tday       !/* array of site daylight temperature values */
real(dp),     dimension(:), allocatable :: s_prcp       !/* array of site prcp values */
real(dp),     dimension(:), allocatable :: s_hum        !/* array of site humidity values (VPD or VP, Pa) */
real(dp),     dimension(:), allocatable :: s_srad       !/* array of site shortwave radiation values */
real(dp),     dimension(:), allocatable :: s_srad_dif   !/* array of site shortwave diffuse radiation values */
real(dp),     dimension(:), allocatable :: s_lrad       !/* array of site longwave radiation values */
real(dp),     dimension(:), allocatable :: s_lradnet    !/* array of site net longwave radiation values */
real(dp),     dimension(:), allocatable :: s_dayl       !/* array of site daylength values */
real(dp),     dimension(:), allocatable :: s_swe        !/* array of site snow water equivalent values (cm) */
!
logical     :: isgood, allgood
allgood = .true.
!
Write(*,*) ''
Write(*,*) 'Test mo_mtclim.f90'
!
! read out namefiles
!
open(700, file=fileini)
read(700, nml=io_ini)
read(700, nml=control_ini)
read(700, nml=parameters_ini)
close(700)
!
open(700, file=fileparameters)
read(700, nml=parameters)
close(700)
!
allocate(parameterset(14))
!
parameterset(1) = TBASE
parameterset(2) = ABASE
parameterset(3) = C
parameterset(4) = B0
parameterset(5) = B1
parameterset(6) = B2
parameterset(7) = RAIN_SCALAR
parameterset(8) = DIF_ALB
parameterset(9) = SC_INT
parameterset(10) = SC_SLOPE
parameterset(11) = SNOW_TCRIT
parameterset(12) = SNOW_TRATE
parameterset(13) = TDAYCOEF
parameterset(14) = LWAVE_COR
!
!----------------------------------------
! inital progress indicator
print *, "Starting MTCLIM version 4.3\n"
!
!----------------------------------------
! allocate space in the data arrays for input and output data
!
!allocate(year(ndays))
allocate(yday(ndays))
allocate(tmax(ndays))
allocate(tmin(ndays))
allocate(prcp(ndays))
!
!allocate(swrad_obs(ndays))
!allocate(lwrad_obs(ndays))
!allocate(netlwrad_obs(ndays))
!
allocate(s_swe(ndays))
!
allocate(s_tmin(ndays))
allocate(s_tmax(ndays))
allocate(s_tday(ndays))
!
allocate(s_hum(ndays))
allocate(s_srad(ndays))
allocate(s_srad_dif(ndays))
allocate(s_lrad(ndays))
allocate(s_lradnet(ndays))
allocate(s_dayl(ndays))
!
!---------------------------------------
! read meteorological data from input file into data arrays
!---------------------------------------
! read meteorological data from input file into data arrays
open(unit=1234, file=in_meteo, status='old', action='read')
do i=1, ndays
   read(1234, '(i3,f9.2,f9.2,f9.2)') yday(i), tmax(i), tmin(i), prcp(i)
enddo
close(1234)
!
!----------------------------------------
! estimate daily air temperatures
call calc_tair(tmin, tmax, ndays, site_elev, base_elev, TDAYCOEF, tmin_lr, tmax_lr, s_tmax, s_tmin, s_tday)
print *, "Completed calc_tair()"
!
!----------------------------------------
! estimate daily precipitation
s_prcp = calc_prcp(prcp, ndays, site_isoh, base_isoh)
print *, "Completed calc_prcp()"
!----------------------------------------
! estimate daily snowpack
s_swe = snowpack(s_tmin, s_prcp, yday, ndays, SNOW_TCRIT, SNOW_TRATE)
print *, "Completed snowpack()"
!
!----------------------------------------
! estimate srad and humidity with iterative algorithm
! without Tdew input data, an iterative estimation of shortwave radiation and humidity is required
call calc_srad_humidity_iterative( &
     yday, s_tmax, s_tmin, s_tday, s_prcp, s_swe, &
     s_hum, s_srad, s_srad_dif ,s_lrad, s_lradnet, s_dayl, &
     ndays=ndays, outhum=outhum, lwrad=lwrad, netlwrad=netlwrad, &
     site_lat=site_lat, site_elev=site_elev, site_asp=site_asp, site_slp=site_slp, &
     site_ehoriz=site_ehoriz, site_whoriz=site_whoriz,&
     TBASE=TBASE, ABASE=ABASE, C=C, B0=B0, B1=B1, B2=B2, &
     RAIN_SCALAR=RAIN_SCALAR, DIF_ALB=DIF_ALB, LWAVE_COR=LWAVE_COR)

print *, "Completed radiation algorithm"
!----------------------------------------
! write output file
open(unit=1234, file=outprefix, status='unknown', action='write')
write(1234, '(A3,A9,A9,A9,A9,A9,A9,A9,A9,A9,A9)') "yd", "tmax", "tmin", "tday", "prcp", "VPD", &
     "swrad", "swrad_dif", "lwrad", "lwradnet", "daylen"
write(1234, '(A3,A9,A9,A9,A9,A9,A9,A9,A9,A9,A9)') " ","(deg C)", "(deg C)", "(deg C)", "(cm)", "(Pa)", &
     "(W m-2)", "(W m-2)", "(W m-2)", "(W m-2)", "(s)"
   do i=1, ndays
      write(1234, '(i3,f9.2,f9.2,f9.2,f9.2,f9.2,f9.2,f9.2,f9.2,f9.2,f9.2)') yday(i), s_tmax(i), s_tmin(i), s_tday(i),&
           s_prcp(i), s_hum(i), s_srad(i), s_srad_dif(i), s_lrad(i), s_lradnet(i), s_dayl(i)
   end do
close(unit=1234)
print *, "Results written in ", outprefix

!----------------------------------------
! test mtclim eval
!call eval_mtclim (parameterset, yday, tmin, tmax, prcp, ndays, &
!     outhum, lwrad, netlwrad &
!     s_tmax, s_tmin, s_tday, s_prcp, &
!     s_hum, s_srad, s_srad_dif, s_lrad, s_lradnet, s_dayl, &
!     site_elev, base_elev, tmin_lr, tmax_lr, site_isoh, base_isoh, &
!     site_lat, site_asp, site_slp, site_ehoriz, site_whoriz)

!----------------------------------------
! test mtclim objective swrad
!if (observ .eq. 1_i4) then
!   print *, "RMSE is ", objective_swrd(parameterset)
!end if
!
!----------------------------------------
! free previously allocated memory before returning
!
deallocate(yday)
deallocate(tmax)
deallocate(tmin)
deallocate(prcp)
!
deallocate(s_swe)
!
deallocate(s_tmin)
deallocate(s_tmax)
deallocate(s_tday)
!
deallocate(s_hum)
deallocate(s_srad)
deallocate(s_srad_dif)
deallocate(s_lrad)
deallocate(s_lradnet)
deallocate(s_dayl)
!
!------------------------------------------
isgood = .true.
! Finish
allgood = allgood .and. isgood
  if (allgood) then
     write(*,*) 'mo_mtclim ', color('o.k.', c_green)
  else
     write(*,*) 'mo_mtclim ', color('failed!', c_red)
  endif
!
end program main


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine filter(dgdxglob,nobject,nk,nodedesi,ndesi,
     &           objectset,xo,yo,zo,x,y,z,nx,ny,nz,neighbor,r,
     &           ndesia,ndesib,xdesi,distmin)
!
!     Filtering of sensitivities
!
      implicit none
!
      character*81 objectset(5,*)

      integer nobject,nk,nodedesi(*),nnodesinside,i,actdir,
     &        ndesi,j,m,neighbor(ndesi+6),nx(ndesi),
     &        ny(ndesi),nz(ndesi),istat,ndesia,ndesib
!
      real*8 dgdxglob(2,nk,nobject),xo(ndesi),yo(ndesi),zo(ndesi),
     &       x(ndesi),y(ndesi),z(ndesi),filterrad,r(ndesi+6),
     &       filterval(ndesi),nominator,denominator,distmin,
     &       xdesi(3,ndesi),scalar,pi,sigma
!
!     Calculate filtered sensitivities
!
!     Check if direction weighting is turned on
!
      if(objectset(2,1)(14:16).eq.'DIR') then
         actdir=1
      else
         actdir=0
      endif
!
!     Assign filter radius (taken from first defined object function)
!
      read(objectset(2,1)(21:40),'(f20.0)',iostat=istat) filterrad
!
!     For the GAUSS filter search in the 3sigma distance
!
      if(objectset(2,1)(1:5).eq.'GAUSS') then
         sigma=filterrad
         filterrad=3*filterrad
      endif
!
      do j=ndesia,ndesib
!
         call near3d_se(xo,yo,zo,x,y,z,nx,ny,nz,xo(j),yo(j),zo(j),
     &        ndesi,neighbor,r,nnodesinside,filterrad)
!
!        Calculate function value of the filterfunction CONST
!
         if(objectset(2,1)(1:5).eq.'CONST') then
            do i=1,nnodesinside
               filterval(i)=1.0d0
            enddo
!
!        Calculate function value of the filterfunction LIN
!
         elseif(objectset(2,1)(1:3).eq.'LIN') then
            do i=1,nnodesinside
               filterval(i)=(1-dsqrt(r(i))/filterrad)*filterrad
            enddo
!
!        Calculate function value of the filterfunction QUAD
!
         elseif(objectset(2,1)(1:4).eq.'QUAD') then
            do i=1,nnodesinside
               filterval(i)=(-1*(1+dsqrt(r(i))/filterrad)
     &                      *(-1+dsqrt(r(i))/filterrad))*filterrad
            enddo
!
!        Calculate function value of the filterfunction CUB
!
         elseif(objectset(2,1)(1:5).eq.'CUBIC') then
            do i=1,nnodesinside
               filterval(i)=(2*(dsqrt(r(i))/filterrad)**3
     &                      -3*(dsqrt(r(i))/filterrad)**2+1)*filterrad
            enddo
!
!        Calculate function value of the filterfunction GAUSS
!
         elseif(objectset(2,1)(1:5).eq.'GAUSS') then
            pi=4.d0*datan(1.d0)
            do i=1,nnodesinside
               filterval(i)=1/(dsqrt(2*pi)*sigma)*exp(-(dsqrt(r(i))**2)
     &                      /(2*sigma**2))
            enddo
         endif
!
!        Calculate filtered sensitivity
!
         do m=1,nobject
            if(objectset(1,m)(4:13).eq.'MEMBERSIZE') cycle
            if(objectset(1,m)(1:9).eq.'FIXGROWTH') cycle
            if(objectset(1,m)(1:12).eq.'FIXSHRINKAGE') cycle
            nominator=0.d0
            denominator=0.d0
            do i=1,nnodesinside
               if(actdir.eq.1) then
                  scalar=(xdesi(1,j)*xdesi(1,neighbor(i))
     &                +xdesi(2,j)*xdesi(2,neighbor(i))
     &                +xdesi(3,j)*xdesi(3,neighbor(i)))/(distmin**2)
c                  if(objectset(1,m)(1:4).eq.'MASS') then
c                     scalar=1.d0
c                  endif
                  if(scalar.lt.0.d0) then
                     scalar=0.d0
                  endif
                  nominator=nominator+filterval(i)*scalar*
     &                dgdxglob(1,nodedesi(neighbor(i)),m)
                  denominator=denominator+filterval(i)
               else
                  nominator=nominator+filterval(i)*
     &                dgdxglob(1,nodedesi(neighbor(i)),m)
                  denominator=denominator+filterval(i)
               endif
            enddo
            dgdxglob(2,nodedesi(j),m)=nominator/denominator
         enddo
      enddo
!
      return
      end


      FUNCTION SPHBRU(N,X)
      IMPLICIT REAL*8(A-H,O-Z)
      DATA TOL/1.D-14/
      I=0
      BB=1.D0
   10 CONTINUE
      I=I+1
      FAC=1.D0
      DO 100 J=1,I
      FAC=FAC/DFLOAT(J)
  100 CONTINUE
      FACD=1.D0
      DO 110 J=1,I
      FACD=FACD/(2.D0*DFLOAT(N)+3.D0+2.D0*DFLOAT(J-1))
  110 CONTINUE
      DBB=(X*X/2.D0)**I*FAC*FACD
      BB=BB+DBB*(-1.D0)**I
      IF(DBB.LT.TOL) GO TO 99
      GO TO 10
   99 SPHBRU=BB
      RETURN
      END


subroutine parabola( nmin, nmax, para, a, deltaa, a6, al, flat )

! Colella and Woodward, JCompPhys 54, 174-201 (1984) eq 1.5-1.8,1.10
!
! parabola calculates the parabolas themselves. call paraset first
! for a given grid-spacing to set the constants, which can be reused
! each time parabola is called.
!
! flatening coefficients are calculated externally in flaten.
! nmin/nmax are indicies over which the parabolae are calculated
!-----------------------------------------------------------------------
! GLOBALS
use sweepsize

IMPLICIT NONE

! LOCALS
integer :: n, nmin, nmax
real(kind=8) :: onemfl
real(kind=8), dimension(maxsweep) :: a, deltaa, a6, al, flat, da, ar, diffa, scrch1, scrch2, scrch3
real(kind=8), dimension(maxsweep,5) :: para

!----------------------------------------------------------------------
  do n = nmin-2, nmax+1
    diffa(n) = a(n+1) - a(n)
  enddo

!                                                       Equation 1.7 of C&W
!     da(j) = D1 * (a(j+1) - a(j)) + D2 * (a(j) - a(j-1))
  do n = nmin-1, nmax+1
   da(n) = para(n,4) * diffa(n) + para(n,5) * diffa(n-1)
   da(n) = sign( min(abs(da(n)), 2.0*abs(diffa(n-1)), 2.0*abs(diffa(n))), da(n) )
  enddo

!     zero out da(n) if a(n) is a local max/min
  do n = nmin-1, nmax+1
    if(diffa(n-1)*diffa(n) < 0.0) da(n) = 0.0
  enddo

!                                                       Equation 1.6 of C&W
!     a(j+.5) = a(j) + C1 * (a(j+1)-a(j)) + C2 * dma(j+1) + C3 * dma(j)
! MONOT: Limit ar(n) to the range defined by a(n) and a(n+1)

  do n = nmin-1, nmax
    ar(n) = a(n) + para(n,1)*diffa(n) + para(n,2)*da(n+1) + para(n,3)*da(n)
!    ar(n) = max(ar(n),min(a(n),a(n+1)))
!    ar(n) = min(ar(n),max(a(n),a(n+1)))
    al(n+1) = ar(n)
  enddo

! eqn. 4.1 - flaten interpolation in zones with a shock ( flat(n)->1. )

  do n = nmin, nmax
    onemfl= 1.0 - flat(n)
    ar(n) = flat(n) * a(n) + onemfl * ar(n)
    al(n) = flat(n) * a(n) + onemfl * al(n)
  enddo

! MONOTONICITY constraints:

! compute delta_a, a_6
! MONOT: if a is a local max/min, flaten zone structure ar,al -> a.
! MONOT: compute monotonized values using eq. 1.10 of C&W
!        if parabola exceeds al/ar, reset ar/al so that slope -> 0.
! Recalculate delta_a and a_6

do n = nmin, nmax
  deltaa(n) = ar(n) - al(n)
  a6(n)     = 6. * (a(n) - .5 * (al(n) + ar(n)))
  scrch1(n) = (ar(n) - a(n)) * (a(n)-al(n))
  scrch2(n) = deltaa(n) * deltaa(n)
  scrch3(n) = deltaa(n) * a6(n)
enddo

do n = nmin, nmax
  if(scrch1(n) <= 0.0) then
    ar(n) = a(n)
    al(n) = a(n)
  endif
  if(scrch2(n) < +scrch3(n)) al(n) = 3. * a(n) - 2. * ar(n)
  if(scrch2(n) < -scrch3(n)) ar(n) = 3. * a(n) - 2. * al(n)
enddo

do n = nmin, nmax
  deltaa(n)= ar(n) - al(n)
  a6(n) = 6. * (a(n) - .5 * (al(n) + ar(n)))
enddo

return
end

!#######################################################################

subroutine paraset( nmin, nmax, para, dx, xa )

! Colella and Woodward, JCompPhys 54, 174-201 (1984) eq 1.6, 1.7
!
! paraset sets up constants which are re-used each time we want to
! interpolate a parabola on a quantity. First pull out constants
! A, B, and C, and then compute all the equations in terms of those quantities.
! The quantities calculated here are stored in a array para, to be read by parabola()
! nmin/nmax are index range for which one will calculate parabolae
!-----------------------------------------------------------------------------------
! GLOBALS
use sweepsize

IMPLICIT NONE

! LOCALS
integer :: n, nmin, nmax
real(kind=8), dimension(maxsweep,5) :: para
real(kind=8), dimension(maxsweep) :: dx, xa, a, b, c, d, ai, bi, ci

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

do n = nmin-2, nmax+1
  a (n) = dx(n) + dx(n+1)
  ai(n) = 1.0/a(n)
  b (n) = a(n) + dx(n)
  bi(n) = 1.0/b(n)
  c (n) = a(n) + dx(n+1)
  ci(n) = 1.0/c(n)
enddo

!                                        constants for equation 1.6
!     a(j+.5) = a(j) + C1 * (a(j+1)-a(j)) + C2 * da(j+1) + C3 * da(j)

do n = nmin-1, nmax
  d(n)      = 1. / (a(n-1) + a(n+1))
  para(n,1) = dx(n) * ai(n) + 2. * dx(n+1) * dx(n) * d(n) * ai(n) * ( a(n-1) * bi(n) - a(n+1) * ci(n) )
  para(n,2) = - d(n) * dx(n)   * a(n-1) * bi(n)
  para(n,3) =   d(n) * dx(n+1) * a(n+1) * ci(n)
enddo

!                                        constants for equation 1.7
!     da(j) = D1 * (a(j+1) - a(j)) + D2 * (a(j) - a(j-1))

do n = nmin-1, nmax+1
  d(n) = dx(n) / ( a(n-1) + dx(n+1) )
  para(n,4) = d(n) * b(n-1) * ai(n)
  para(n,5) = d(n) * c(n)   * ai(n-1)
enddo

return
end


!!!************************************************************
!!!*						                	                *
!!!*                     K Epsilon 1D      	         	    *
!!!*							        	                    *
!!!*                Author: Dr. Andrea Boghi  		        *
!!!*							        	                    *
!!!*								                            *
!!!************************************************************

Program main_K_epsilon
    implicit none
    real*8,allocatable :: y(:),U(:),kt(:),eps(:),detady(:),d2etady2(:)
    real*8,allocatable :: U0(:),kt0(:),eps0(:)
    real*8,allocatable :: nut(:),f2(:),dnutdy(:),dUdy(:),dnutdeta(:),dUdeta(:)
    real*8,allocatable :: tau_mu(:),tau_R(:),Pk(:),Tk(:),Dk(:)
    real*8,allocatable :: Peps(:),Teps(:),Deps(:),epseps(:)
    integer j,ny,iter,niter
    real*8  Re_tau,dy_min,sigmak,sigmae,Ce1,Ce2,Cmu,f1,alphaU,alphaKt,alphaeps
    real*8 resU,resK,resE,deta,aU_w,aU_e,sU,aK_w,aK_e,sK,aE_w,aE_e,sE, conv_fac
    logical flag

    open(1,file='imp_ke_var.dat')
    read(1,*) flag
    read(1,*) ny
    read(1,*) niter
    read(1,*) Re_tau
    read(1,*) dy_min
    read(1,*) alphaU
    read(1,*) alphaKt
    read(1,*) alphaeps
    close(1)

    print*, ' niter =', niter, ' ny =', ny
    print*, ' Re_tau =', Re_tau, ' flag =', flag

    allocate(y(1:ny),U(1:ny),kt(1:ny),eps(1:ny),nut(1:ny),dnutdy(1:ny),dUdy(1:ny),f2(1:ny))
    allocate(U0(1:ny),kt0(1:ny),eps0(1:ny),detady(1:ny),d2etady2(1:ny),dnutdeta(1:ny),dUdeta(1:ny))

    call initialization(flag,ny,Re_tau,dy_min,y,detady,d2etady2,U,Kt,eps,deta)

    call nagano_takawa_k_epsilon_constants(sigmak,sigmae,Ce1,Ce2,Cmu,f1)

    conv_fac = 1.d0
    open(11,file='residuals_momentum_var.csv')
    write(11,*) '"iter","resU","resK","resE"'

    do iter=1,niter

        U0 = U
        Kt0 = kt
        eps0 = eps

        call nagano_takawa_k_epsilon_functions(nut,f2,ny,y,kt,eps,Cmu)
        call ddeta(ny,nut,dnutdeta,deta)
        dnutdy = dnutdeta*detady
        call ddeta(ny,U,dUdeta,deta)
        dUdy = dUdeta*detady
        U(1) = 0.d0
        !call u_coefficients(aU_w,aU_e,sU,nut(1),dnutdy(1),deta,Re_tau,d2etady2(1),detady(1))
        !U(1) =  sU + (aU_e + aU_w)*U(2) + 2.d0*aU_w*dy
        Kt(1) = 0.d0
        eps(1) = 2.d0*( ( (-3.d0*dsqrt(dabs(Kt(1)))+4.d0*dsqrt(dabs(Kt(2)))-dsqrt(dabs(Kt(3))))/(2.d0*deta) )*detady(1) )**2.d0
        do j =2,ny-1
            call u_coefficients(aU_w,aU_e,sU,nut(j),dnutdy(j),deta,Re_tau,d2etady2(j),detady(j))
            U(j) =  sU + aU_e*U(j+1) + aU_w*U(j-1)
            call K_coefficients(aK_w,aK_e,sK,eps(j),nut(j),dnutdy(j),dUdy(j),deta,sigmak,d2etady2(j),detady(j))
            Kt(j) = sK + aK_e*Kt(j+1) + aK_w*Kt(j-1)
            call E_coefficients(aE_w,aE_e,sE,eps(j),Kt(j),nut(j),dnutdy(j),dUdy(j),deta,sigmae,Ce1,f1,Ce2,f2(j),d2etady2(j), &
            detady(j))
            eps(j) = sE + aE_e*eps(j+1) + aE_w*eps(j-1)
        enddo
        call u_coefficients(aU_w,aU_e,sU,nut(ny),dnutdy(ny),deta,Re_tau,d2etady2(ny),detady(ny))
        U(ny) =  sU + (aU_e + aU_w)*U(ny-1)
        call K_coefficients(aK_w,aK_e,sK,eps(ny),nut(ny),dnutdy(ny),dUdy(ny),deta,sigmak,d2etady2(ny),detady(ny))
        Kt(ny) = sK + (aK_e + aK_w)*Kt(ny-1)
        call E_coefficients(aE_w,aE_e,sE,eps(ny),Kt(ny),nut(ny),dnutdy(ny),dUdy(ny),deta,sigmae,Ce1,f1,Ce2,f2(ny),d2etady2(ny), &
        detady(ny))
        eps(ny) = sE + (aE_e + aE_w)*eps(ny-1)

        call residuals(ny,U,U0,resU)
        call residuals(ny,Kt,Kt0,resK)
        call residuals(ny,eps,eps0,resE)
        write(11,102) conv_fac*iter,',',resU,',',resK,',',resE

        U = dabs(alphaU*U +(1.d0-alphaU)*U0)
        Kt = dabs(alphaKt*Kt +(1.d0-alphaKt)*Kt0)
        eps = dabs(alphaeps*eps +(1.d0-alphaeps)*eps0)
        print*, ' completed =', 100*real(iter)/real(niter), ' resU = ', resU, ' resK = ', resK, ' resE = ', resE

    enddo
    close(11)

    open(1,file='point_ke_var.dat',form='unformatted')
    write(1) y,detady,d2etady2,U,Kt,eps,nut,f2
    close(1)

    allocate(tau_mu(1:ny),tau_R(1:ny),Pk(1:ny),Tk(1:ny),Dk(1:ny))
    allocate(Peps(1:ny),Teps(1:ny),Deps(1:ny),epseps(1:ny))

    call output_fields(ny,U,Kt,eps,nut,f1,f2,deta,sigmaK,sigmaE,Ce1,Ce2,tau_mu,tau_R,Pk,Tk,Dk,Peps,Teps,Deps,epseps,detady,d2etady2)

    open(14,file='momentumNT_var.csv',form='formatted')
    write(14,*) '"y","U","k","epsilon","nut","tau_mu","tau_R","Pk","Tk","Dk","Peps","Teps","Deps","epsEps"'
    do j=1,ny
       write(14,101) y(j),',',U(j),',',Kt(j),',',eps(j),',',nut(j),',',tau_mu(j),',',tau_R(j),',',Pk(j),',',Tk(j),',',Dk(j),',', &
       Peps(j),',',Teps(j),',',Deps(j),',',epsEps(j)
    enddo
    close(14)

    101 format(e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10, &
    A,e18.10)

    102 format(e18.10,A,e18.10,A,e18.10,A,e18.10)

    end

!!!*************************************************
!!!*						         	             *
!!!*            initialization                        *
!!!*								                 *
!!!*************************************************

subroutine initialization(flag,ny,Re_tau,dy_min,y,detady,d2etady2,U,Kt,eps,deta)
    implicit none
    logical, intent(in) :: flag
    integer, intent(in) :: ny
    real*8, intent(in) :: Re_tau,dy_min
    real*8, intent(out) :: y(1:ny),detady(1:ny),d2etady2(1:ny),U(1:ny),kt(1:ny),eps(1:ny),deta
    integer j
    real*8 Kappa, Cmu,nut(1:ny),f2(1:ny),y_mid

    Kappa = 4.d-1
    Cmu = 9.d-2
    y_mid = 11.635

    !initial conditions
    if (flag) then

        print *,'continuation'

        open(1,file='point_ke_var.dat',form='unformatted')
        read(1) y(1:ny),detady(1:ny),d2etady2(1:ny),U(1:ny),Kt(1:ny),eps(1:ny),nut(1:ny),f2(1:ny)
        close(1)

    else

        print *,'new run'

        call grid(ny,dy_min,Re_tau,y,detady,d2etady2,deta)

        do j=1,ny
            if(y(j)<=y_mid) then
                U(j) = y(j)
                eps(j) = (y(j)*Kappa -y(j)*y(j)*Kappa/Re_tau)/(Kappa*y_mid)**2.d0
                Kt(j) = dsqrt( (y(j)*Kappa -y(j)*y(j)*Kappa/Re_tau)*eps(j)/Cmu )
            else
                U(j) = (1.d0/Kappa)*dlog(y(j)) +5.5d0
                eps(j) = (y(j)*Kappa -y(j)*y(j)*Kappa/Re_tau)/(Kappa*y(j))**2.d0
                Kt(j) = dsqrt( (y(j)*Kappa -y(j)*y(j)*Kappa/Re_tau)*eps(j)/Cmu )
            endif
        enddo

    endif

    end

!!!*************************************************
!!!*						         	             *
!!!*                    ddeta                        *
!!!*								                 *
!!!*************************************************

subroutine  ddeta(ny,A,DA,deta)
    implicit none
    integer, intent(in) :: ny
    real*8, intent(in) :: A(1:ny),deta
    real*8, intent(out) :: DA(1:ny)
    integer j

    DA(1) =  -(3.d0*A(1) -4.d0*A(2) +A(3))/(2.d0*deta)

    do j=2,ny-1
        DA(j) = (A(j+1) -A(j-1))/(2.d0*deta)
    enddo

    DA(ny) = (3.d0*A(ny) -4.d0*A(ny-1) +A(ny-2))/(2.d0*deta)

    end

!!!*************************************************
!!!*						         	             *
!!!*                    d2deta2                        *
!!!*								                 *
!!!*************************************************

subroutine  d2deta2(ny,A,D2A,deta)
    implicit none
    integer, intent(in) :: ny
    real*8, intent(in) :: A(1:ny),deta
    real*8, intent(out) :: D2A(1:ny)
    real*8 deta2
    integer j

    deta2 = deta*deta

    D2A(1) =  (12.d0*a(1) -30.d0*a(2) +24.d0*a(3) -6.d0*a(4))/(6.d0*deta2)

    do j=2,ny-1
        D2A(j) = (a(j+1) - 2.d0*a(j) + a(j-1))/deta2
    enddo

    D2A(ny) = (12.d0*a(ny) -30.d0*a(ny-1) +24.d0*a(ny-2) -6.d0*a(ny-3))/(6.d0*deta2)

    end

!!!***************************************************
!!!*						         	               *
!!!*       Nagano Takawa K - Epsilon Constants 	       	   *
!!!*								                   *
!!!***************************************************

subroutine  nagano_takawa_k_epsilon_constants(sigmak,sigmae,Ce1,Ce2,Cmu,f1)
    implicit none
    real*8, intent(out) :: sigmak,sigmae,Ce1,Ce2,Cmu,f1

    sigmaK= 1.0d0
    sigmae= 1.3d0
    Ce1=1.45d0
    Ce2=1.9d0
    Cmu=0.09d0
    f1=1.d0

    end

!!!***************************************************
!!!*						         	               *
!!!*       Nagano Takawa K - Epsilon Functions 	       	   *
!!!*								                   *
!!!***************************************************

subroutine  nagano_takawa_k_epsilon_functions(nut,f2,ny,y,kt,eps,Cmu)
    implicit none
    integer, intent(in) :: ny
    real*8, intent(in) :: y(1:ny),Kt(1:ny),eps(1:ny),Cmu
    real*8, intent(out) :: nut(1:ny),f2(1:ny)
    real*8 Ret(1:ny), fmu(1:ny), Ret_min, eps_min
    integer j

    eps_min = 1.d-12

    do j=1,ny
        if (eps(j) <= eps_min) then
            Ret(j)= dabs(Kt(j)*Kt(j)/eps_min)
        else
            Ret(j)= dabs(Kt(j)*Kt(j)/eps(j))
        endif
    enddo

    Ret_min = 1.d-12
    do j=1,ny
        if (Ret(j) <= Ret_min) then
            fmu(j)= (1.d0 +4.1d0/Ret_min**0.75d0)*(1.d0 -dexp(-y(j)/26.d0))**2.d0
        else
            fmu(j)= (1.d0 +4.1d0/Ret(j)**0.75d0)*(1.d0 -dexp(-y(j)/26.d0))**2.d0
        endif
    enddo

    do j=1,ny
        nuT(j)= Cmu*fmu(j)*Ret(j)
    enddo

    do j=1,ny
        f2(j)= (1.d0 -0.3d0*dexp(-(Ret(j)/6.5d0)**2.d0))*(1.d0 -dexp(-y(j)/6.d0))**2.d0
    enddo

    end

!!!***************************************************
!!!*						         	               *
!!!*                U coefficients	       	   *
!!!*								                   *
!!!***************************************************
subroutine  u_coefficients(aU_w,aU_e,sU,nut,dnutdy,deta,Re_tau,d2etady2,detady)
    implicit none
    real*8, intent(in) :: nut,dnutdy,deta,Re_tau,d2etady2,detady
    real*8, intent(out) :: aU_w,aU_e,sU
    real*8 dev

    dev = deta*( (1.d0+nut)*d2etady2 + dnutdy*detady )/(4.d0*(1.d0+nut)*(detady)**2.d0)

    aU_w = 5.d-1 - dev
    aU_e = 5.d-1 + dev
    sU = (deta*deta)/(2.d0*Re_tau*(1.d0+nut)*(detady)**2.d0)

    end

!!!***************************************************
!!!*						         	               *
!!!*                K coefficients	       	   *
!!!*								                   *
!!!***************************************************
subroutine  K_coefficients(aK_w,aK_e,sK,eps,nut,dnutdy,dUdy,deta,sigmak,d2etady2,detady)
    implicit none
    real*8, intent(in) :: eps,nut,dnutdy,dUdy,deta,sigmak,d2etady2,detady
    real*8, intent(out) :: aK_w,aK_e,sK
    real*8 dev

    dev = deta*( (sigmak+nut)*d2etady2 + dnutdy*detady )/(4.d0*(sigmak+nut)*detady**2.d0)

    aK_w = 5.d-1 - dev
    aK_e = 5.d-1 + dev
    sK = (nut*dUdy*dUdy - eps)*(deta*deta)/(2.d0*(1.d0+nut/sigmak)*detady**2.d0)

    end

!!!***************************************************
!!!*						         	               *
!!!*                E coefficients	       	   *
!!!*								                   *
!!!***************************************************
subroutine  E_coefficients(aE_w,aE_e,sE,eps,Kt,nut,dnutdy,dUdy,deta,sigmae,Ce1,f1,Ce2,f2,d2etady2,detady)
    implicit none
    real*8, intent(in) :: eps,Kt,nut,dnutdy,dUdy,deta,sigmae,Ce1,f1,Ce2,f2,d2etady2,detady
    real*8, intent(out) :: aE_w,aE_e,sE
    real*8 K_min, Kb, dev
    logical method1

    dev = deta*( (sigmae+nut)*d2etady2 + dnutdy*detady )/(4.d0*(sigmae+nut)*detady**2.d0)

    K_min = 1.d-12

    Kb = (Ce1*f1*nut*dUdy*dUdy -Ce2*f2*eps)*(deta*deta/(2.d0*(1.d0+nut/sigmae)*detady**2.d0))

    method1 = .true.
    if (method1) then
        aE_w = 5.d-1 - dev
        aE_e = 5.d-1 + dev
        if (Kt<=K_min) then
            sE = 0.d0*Kb*eps/K_min
        else
            sE = Kb*eps/Kt
        endif
    else
        aE_w = (5.d-1 - dev)/(1.d0 - Kb/Kt)
        aE_e = (5.d-1 + dev)/(1.d0 - Kb/Kt)
        sE = 0.d0
    endif

    end

!!!*************************************************
!!!*						         	           *
!!!*               output fields                   *
!!!*								               *
!!!*************************************************

subroutine  output_fields(ny,U,Kt,eps,nut,f1,f2,deta,sigmaK,sigmaE,Ce1,Ce2,tau_mu,tau_R,Pk,Tk,Dk,Peps,Teps,Deps,epseps,detady, &
    d2etady2)
    implicit none
    integer, intent(in) :: ny
    real*8, intent(in) :: deta,sigmaK,sigmaE,Ce1,Ce2,f1,f2(1:ny),Kt(1:ny),eps(1:ny),nut(1:ny),U(1:ny),detady(1:ny),d2etady2(1:ny)
    real*8, INTENT(OUT) :: tau_mu(1:ny),tau_R(1:ny),Pk(1:ny),Tk(1:ny),Dk(1:ny)
    real*8, INTENT(OUT) :: Peps(1:ny),Teps(1:ny),Deps(1:ny),epseps(1:ny)
    real*8 dUdy(1:ny),d2Ktdeta2(1:ny),d2epsdeta2(1:ny),dKtdeta(1:ny),depsdeta(1:ny),dnutdy(1:ny),dUdeta(1:ny),dnutdeta(1:ny)

    call ddeta(ny,U,dUdeta,deta)
    dUdy = dUdeta*detady
    call ddeta(ny,nut,dnutdeta,deta)
    dnutdy = dnutdeta*detady

    tau_mu = dUdy
    tau_R = nut*dUdy
    Pk = tau_R*dUdy

    call d2deta2(ny,Kt,d2Ktdeta2,deta)
    call ddeta(ny,Kt,dKtdeta,deta)

    Dk = d2Ktdeta2*detady**2.d0 + dKtdeta*d2etady2
    Tk = (nut/sigmaK)*(d2Ktdeta2*detady**2.d0 + dKtdeta*d2etady2) + (dKtdeta*detady/sigmaK)*dnutdy

    Peps(2:ny) = f1*Ce1*(eps(2:ny)/Kt(2:ny))*Pk(2:ny)
    Peps(1) = Peps(2)

    call d2deta2(ny,eps,D2epsdeta2,deta)
    call ddeta(ny,eps,depsdeta,deta)

    Deps = d2epsdeta2*detady**2.d0 + depsdeta*d2etady2
    Teps = (nut/sigmaE)*(d2epsdeta2*detady**2.d0 + depsdeta*d2etady2) + (depsdeta*detady/sigmaE)*dnutdy
    epsEps(2:ny) = -f2(2:ny)*Ce2*(eps(2:ny)/Kt(2:ny))*eps(2:ny)
    epsEps(1) = epsEps(2)

    end

!!!*************************************************
!!!*						         	           *
!!!*               residuals                   *
!!!*								               *
!!!*************************************************

subroutine  residuals(ny,A,A0,resA)
    implicit none
    integer, intent(in) :: ny
    real*8, intent(in) :: A(1:ny),A0(1:ny)
    real*8, INTENT(OUT) :: resA
    real*8 sumN, sumD
    integer j

    sumN = 0
    do j=1,ny
        sumN = sumN +dabs(A(j)- A0(j))
    enddo

    sumD = 0
    do j=1,ny
        sumD = sumD + dabs(A0(j))
    enddo

    resA = sumN/sumD

    end

!!!*************************************************
!!!*						         	             *
!!!*            grid                       *
!!!*								                 *
!!!*************************************************

subroutine grid(ny,dy_min,Re_tau,y,detady,d2etady2,deta)
    implicit none
    integer, intent(in) :: ny
    real*8, intent(in) :: Re_tau,dy_min
    real*8, intent(out) :: y(1:ny),detady(1:ny),d2etady2(1:ny),deta
    integer j
    real*8 a, b, eta

    deta = Re_tau/(ny-1)

    a = (deta - dy_min)/(Re_tau*deta - deta*deta)
    b = (dy_min*Re_tau - deta*deta)/(Re_tau*deta - deta*deta)

    do j=1,ny
        eta = deta*(j-1)
        y(j) = a*eta**2.d0 + b*eta
        detady(j) = 1.d0/(2.d0*a*eta + b)
        d2etady2(j) = -2.d0*a/(2.d0*a*eta + b)**3.d0
    enddo

    print*, ' dy_max =', y(ny)-y(ny-1), ' dy_min =', y(2)-y(1), ' ratio =', (y(ny)-y(ny-1))/(y(2)-y(1))

    end


program add_and_subtract
!! Adds and subtracts datetimes
use datetime_module, only : timedelta, datetime

implicit none

type (datetime) :: a, b
type (timedelta) :: t

!> add 86400 seconds
a = datetime(2020, 2, 28)
b = a + timedelta(seconds=86400)
if (b /= datetime(2020, 2, 29)) error stop 'expected 2020-02-29'

!> subtract
b = b - timedelta(seconds=35)
if (b /= datetime(2020, 2, 28, 23, 59, 25)) error stop 'expected 2020-02-28T23:59:25'

!> total_seconds is floating point
t = b - b - timedelta(milliseconds=234)

if (abs(t%total_seconds() + 0.234) > 0.0001) error stop 'expected -0.234 seconds'

end program add_and_subtract


module gauss_interface
  interface
    subroutine gauss(a, b, deter)
      real, dimension(:,:), intent(inout) :: a
      real, dimension(:), intent(inout) :: b
      real, intent(inout) :: deter
    end subroutine
  end interface
end module


module optimize

! Optimization algorithms

use types, only: dp
use utils, only: stop_error
implicit none
private
public bisect

interface
    real(dp) function func(n, x)
    import :: dp
    implicit none
    integer, intent(in) :: n
    real(dp), intent(in) :: x
    end function
end interface

contains

real(dp) function bisect(f, a, b, tol, n) result(c)
! Solves f(x) = 0 on the interval [a, b] using the bisection method
procedure(func) :: f
real(dp), intent(in) :: a, b, tol
integer, intent(in) :: n
real(dp) :: a_, b_, fa, fb, fc
a_ = a; b_ = b
fa = f(n, a_)
fb = f(n, b_)
if (fa * fb >= 0) then
    call stop_error("bisect: f(a) and f(b) must have opposite signs")
end if
do while (b_ - a_ > tol)
    c = (a_ + b_) / 2
    fc = f(n, c)
    if (abs(fc) < tiny(1._dp)) return   ! We need to make sure f(c) is not zero below
    if (fa * fc < 0) then
        b_ = c
        fb = fc
    else
        a_ = c
        fa = fc
    end if
end do
c = (a_ + b_)/2
end function

end module


C     File: goto_03.f
C     A simple program with a single top-level backward conditional goto.
C     The program computes and prints out the values of n! for n in [1,10].

      program factorial
      implicit none

      integer i, n, fact

      i = 0
      fact = 1
      n = 10

 111  i = i + 1
      fact = fact * i

      write (*, 10) i, fact

      if (i .lt. n) goto 111

      stop
 10   format('i = ', I3, '; fact = ', I8)

      end program factorial


program akde_mse_test
	use metropolis
	use grid_utils
	use kde
	use distributions
	use mpi_f08
	use omp_lib
	! use iso_fortran_env, only : int64
	implicit none
	integer, parameter :: DP = KIND(0.0D0), DP_SIZE = sizeof(0.0D0), &
	                      INT_SIZE = sizeof(1), d = 1, grid_n = 150
	integer :: world_size, world_rank, run, node_runs, runs, gam, sample_size
	real(kind=DP) :: Ef(grid_n) = 0, Ef2(grid_n) = 0, estimate(grid_n), &
	                 Es(grid_n) = 0, Es2(grid_n) = 0
	real(kind=DP) :: grid(d,grid_n), h, lam
	real(kind=DP), allocatable :: sample(:,:), mu(:,:), w(:), sig(:,:,:), det(:)
	procedure(rn_to_r), pointer :: pdf => comb
	character(len=100) :: filename_suffix
	character(len=10) :: arg
	! variables concerning MPI IO
	integer :: offset_runs
	! includes : d, gam, runs, mu, w, sig, det
	type(MPI_FILE) :: estimator_file
	type(MPI_STATUS) :: estimator_file_stat
	integer :: estimate_file_unit, mu_offset, w_offset, sig_offset, det_offset

	call MPI_INIT()

	! loads the value of gam (kernel count), sample_size, lam (scaling constant),
	! and grid_n respectively, they must all be present when invoking the executable
	call load_command_line_args()
	write(filename_suffix,"('_gam',i0,'_runs',i0,'_lam',f4.2)") gam, runs, lam

	! set up communicators and balance the load between procesess
	call mpi_setup()

	! initialize grid
	!call grid_init_2d(grid, -5.0D0, 5.0D0, -5.0D0, 5.0D0, 50, 50)
	call grid_init_1d(grid,-5.0D0,5.0D0,grid_n)

	! call omp_set_num_threads(4)

	! main cycle - for every run, draw new sample and obtain estimate
	do run=1,node_runs
		call draw_sample(sample, sample_size, d, pdf)
        ! obtain the estimate
		call botev_get_estimate(mu, w, sig, det, d, gam, sample_size, 5.0d0, &
								sample, grid, grid_n, runs, estimate, h)
		Ef = Ef + estimate / runs
		Ef2 = Ef2 + estimate**2 / runs

		call kde_get_estimate(d, sample_size, sample, grid, grid_n, estimate)

		Es = Es + estimate / runs
		Es2 = Es2 + estimate**2 / runs

		! output estimator variables into file
		call append_estimator()

	end do

	! reuse 'run' & 'estimate' to avoid having to declare more one-time
	! variables
	!$OMP PARALLEL DO
	do run=1,grid_n
		estimate(run) = pdf(grid(:,run))
	end do
	!$OMP END PARALLEL DO
	! normalize (this isn't ideal way to go about it)
	estimate = estimate / sum(estimate) * sum(Ef)

	if (world_rank == 0) then
		call MPI_REDUCE(MPI_IN_PLACE, Ef, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
		call MPI_REDUCE(MPI_IN_PLACE, Ef2, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
	else
		call MPI_REDUCE(Ef, Ef, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
		call MPI_REDUCE(Ef2, Ef2, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
	end if

	if (world_rank == 0) then
		call MPI_REDUCE(MPI_IN_PLACE, Es, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
		call MPI_REDUCE(MPI_IN_PLACE, Es2, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
	else
		call MPI_REDUCE(Es, Es, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
		call MPI_REDUCE(Es2, Es2, grid_n, MPI_REAL8, &
		                MPI_SUM, 0, MPI_COMM_WORLD)
	end if

	! output Ef, Ef2, Es, Es2, grid, exact (if available) into file
	if (world_rank == 0) then
		call save_estimate('estimate'//trim(filename_suffix), estimate)
	end if

	! disconnect output files, deallocate memory etc...
	call cleanup()

	call MPI_FINALIZE()

contains

!============= utilities converted to subroutines for convenience =============

	! sets harvest to num/bins or num/bins+1. if called for 'ranks'
	! from 0 to bins-1, 'harvests' sum to 'num'
	subroutine load_command_line_args()

		if (command_argument_count() /= 4) then
			if (world_rank == 0) then
				print*, ' 4 cmd. line arguments need to be passed along &
with the executable : kernel count (int), sample size (int), number of independent &
runs(int), scaling constant (real)'
				print*, ' terminating'
			end if
			call MPI_FINALIZE()
			call exit(1)
		end if

		call get_command_argument(1,arg)
		read(arg,*) gam

		call get_command_argument(2,arg)
		read(arg,*) sample_size

		call get_command_argument(3,arg)
		read(arg,*) runs

		call get_command_argument(4,arg)
		read(arg,*) lam

	end subroutine

	! set up MPI environment (ie. communicators and load balancing between
	! processes)
	subroutine mpi_setup()
		! obtaing rank of each process and their total number
		call MPI_COMM_SIZE(MPI_COMM_WORLD, world_size)
		call MPI_COMM_RANK(MPI_COMM_WORLD, world_rank)

		allocate(mu(d, gam))
		allocate(w(gam))
		allocate(sig(d, d, gam))
		allocate(det(gam))

		! allocate the sample
		allocate(sample(d,sample_size))

		! balance the load between processes
		call load_balance_count(world_rank, world_size, runs, node_runs)

		! for IO purposes, runs need to be strictly ordered.
		! 'offset runs' keeps track about position of node's first run in such
		! ordering (indexed from zero). other runs from the same node
		! follow immediately after
		offset_runs = world_rank * (runs / world_size) + &
					  min(mod(runs, world_size), world_rank)

		mu_offset = 3*INT_SIZE + offset_runs * d * gam * DP_SIZE
		w_offset = mu_offset + (runs * d + offset_runs) * gam * DP_SIZE
		sig_offset = w_offset + (runs + offset_runs * d * d) * gam * DP_SIZE
		det_offset = sig_offset + (runs * d * d + offset_runs) * gam * DP_SIZE

		! connect output files (using MPI IO)
		call MPI_FILE_OPEN(MPI_COMM_WORLD, 'estimator'//trim(filename_suffix), &
		                   ior(MPI_MODE_CREATE, MPI_MODE_WRONLY), &
		                   MPI_INFO_NULL, estimator_file)

		if (world_rank == 0) then
			call MPI_FILE_WRITE(estimator_file, d, 1, MPI_INTEGER, &
					    estimator_file_stat)

			call MPI_FILE_WRITE(estimator_file, gam, 1, MPI_INTEGER, &
					    estimator_file_stat)

			call MPI_FILE_WRITE(estimator_file, runs, 1, MPI_INTEGER, &
					    estimator_file_stat)
		end if

	end subroutine

	! subroutine to clean up after 'mpi_setup' above, it's mostly not neccesary
	! (OS would have done it) but even if nothing else at least leak sanitizer
	! is not fed false positives
	subroutine cleanup()

		deallocate(mu)
		deallocate(w)
		deallocate(sig)
		deallocate(det)

		deallocate(sample)

		call MPI_FILE_CLOSE(estimator_file)

	end subroutine

	! outputs grid_n, Ef, Ef2, Es, Es2, grid, exact (if available) into
	! unformatted binary file (named 'estimate' unless specified otherwise)
	subroutine save_estimate(filename, exact_density)

		real(kind=DP), intent(in), optional :: exact_density(:)
		character(len=*), intent(in) :: filename
		open(newunit=estimate_file_unit, file=filename, access='stream', &
		     form='unformatted', status='replace')

		write(estimate_file_unit) grid_n, Ef, Ef2, Es, Es2, grid

		if (present(exact_density)) write(estimate_file_unit) exact_density

		close(estimate_file_unit)

	end subroutine

	! write estimator variables to predefined locations in output file
	subroutine append_estimator()

		call MPI_FILE_SEEK(estimator_file, int(mu_offset,MPI_OFFSET_KIND), MPI_SEEK_SET)
		call MPI_FILE_WRITE(estimator_file, mu, gam*d, MPI_REAL8, &
		                    estimator_file_stat)

		call MPI_FILE_SEEK(estimator_file, int(w_offset,MPI_OFFSET_KIND), MPI_SEEK_SET)
		call MPI_FILE_WRITE(estimator_file, w, gam, MPI_REAL8, &
		                    estimator_file_stat)

		call MPI_FILE_SEEK(estimator_file, int(sig_offset,MPI_OFFSET_KIND), MPI_SEEK_SET)
		call MPI_FILE_WRITE(estimator_file, sig, gam*d, MPI_REAL8, &
		                    estimator_file_stat)

		call MPI_FILE_SEEK(estimator_file, int(det_offset,MPI_OFFSET_KIND), MPI_SEEK_SET)
		call MPI_FILE_WRITE(estimator_file, det, gam, MPI_REAL8, &
		                    estimator_file_stat)

		mu_offset = mu_offset + d * gam * DP_SIZE
		w_offset = w_offset + gam * DP_SIZE
		sig_offset = sig_offset + d * d * gam * DP_SIZE
		det_offset = det_offset + gam * DP_SIZE

	end subroutine

	pure subroutine load_balance_count(rank, bins, num, harvest)
		integer, intent(in) :: rank, bins, num
		integer, intent(out) :: harvest
		if (rank < mod(num, bins)) then
			harvest = num / bins + 1
		else
			harvest = num / bins
		end if
	end subroutine

end program akde_mse_test


      SUBROUTINE amoeba(p,y,mp,np,ndim,ftol,funk,iter)
      INTEGER iter,mp,ndim,np,NMAX,ITMAX
      REAL ftol,p(mp,np),y(mp),funk
      PARAMETER (NMAX=20,ITMAX=5000)
      EXTERNAL funk
CU    USES amotry,funk
      INTEGER i,ihi,ilo,inhi,j,m,n
      REAL rtol,sum,swap,ysave,ytry,psum(NMAX),amotry
      iter=0
1     do 12 n=1,ndim
        sum=0.
        do 11 m=1,ndim+1
          sum=sum+p(m,n)
11      continue
        psum(n)=sum
12    continue
2     ilo=1
      if (y(1).gt.y(2)) then
        ihi=1
        inhi=2
      else
        ihi=2
        inhi=1
      endif
      do 13 i=1,ndim+1
        if(y(i).le.y(ilo)) ilo=i
        if(y(i).gt.y(ihi)) then
          inhi=ihi
          ihi=i
        else if(y(i).gt.y(inhi)) then
          if(i.ne.ihi) inhi=i
        endif
13    continue
      rtol=2.*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
      if (rtol.lt.ftol) then
        swap=y(1)
        y(1)=y(ilo)
        y(ilo)=swap
        do 14 n=1,ndim
          swap=p(1,n)
          p(1,n)=p(ilo,n)
          p(ilo,n)=swap
14      continue
        return
      endif
      if (iter.ge.ITMAX) pause 'ITMAX exceeded in amoeba'
      iter=iter+2
      ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,-1.0)
      if (ytry.le.y(ilo)) then
        ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,2.0)
      else if (ytry.ge.y(inhi)) then
        ysave=y(ihi)
        ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,0.5)
        if (ytry.ge.ysave) then
          do 16 i=1,ndim+1
            if(i.ne.ilo)then
              do 15 j=1,ndim
                psum(j)=0.5*(p(i,j)+p(ilo,j))
                p(i,j)=psum(j)
15            continue
              y(i)=funk(psum)
            endif
16        continue
          iter=iter+ndim
          goto 1
        endif
      else
        iter=iter-1
      endif
      goto 2
      END

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


program PlanarInterpConvergence

use NumberKindsModule
use UtilitiesModule
use LoggerModule
use PolyMesh2dModule
use ParticlesModule
use EdgesModule
use FacesModule
use STDIntVectorModule
use FieldModule
use BIVARModule

implicit none

type(Logger) :: exeLog

type(PolyMesh2d) :: triMesh
integer(kint), parameter :: meshSeed = TRI_HEX_SEED
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal) :: ampFactor

type(Field) :: scalar
type(Field) :: estGrad, exactGrad, gradError
type(Field) :: est2ndPartials, exact2ndPartials, partialsError
type(Field) :: estLap, exactLap, lapError

real(kreal), parameter :: b = 3.0_kreal
real(kreal), parameter :: xc = 0.0_kreal, yc = 0.0_kreal
real(kreal), parameter :: maxAbsLap = 36.0_kreal
integer(kint), parameter :: nestStart = 5, nestEnd = 5, testSize = nestEnd - nestStart + 1
integer(kint) :: nestCtr
real(kreal) :: estGradError(testSize), estLapError(testSize), interpError(testSize), meshSize(testSize)
real(kreal) :: testStart, testEnd, maxGradMag

integer(kint) :: i, j

integer(kint) :: nTri, nL
integer(kint), allocatable :: ipt(:), ipl(:), iwl(:), iwp(:)
real(kreal), allocatable :: wk(:), partials(:)

integer(kint), parameter :: nn = 501

real(kreal), parameter :: dx = 8.0_kreal / real( nn - 1, kreal)
real(kreal), parameter :: xmin = -4.0_kreal
real(kreal), parameter :: xmax = 4.0_kreal
real(kreal), parameter :: ymin = xmin
real(kreal), parameter :: ymax = xmax

real(kreal) :: x(nn), y(nn)
real(kreal) :: interpScalar(nn,nn), exactScalar(nn,nn)
real(kreal) :: xVecA(3), xVecB(3)
integer(kint) :: inTri(nn,nn)

character(len=MAX_STRING_LENGTH) :: logstring
character(len=MAX_STRING_LENGTH) :: filename
!
!----------------
! PROGRAM START
!----------------
!
call New(exeLog, DEBUG_LOGGING_LEVEL)

nestCtr = 1

do initNest = nestStart, nestEnd

	write(logstring,'(2(A,I3),A)') "test ", nestCtr, ", of ", nestEnd-nestStart +1, "..."

	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,"Interpolation Convergence : ", logString)
	call cpu_time(testStart)
	!
	! build a mesh
	!
	maxNest = initNest
	amrLimit = 0
	ampFactor = 3.0_kreal
	call New(triMesh, meshSeed, initNest, maxNest, amrLimit, ampFactor)
	! define a scalar field on the mesh
	call New(scalar, 1, triMesh%particles%N, "gaussScalar", "n/a")
	call New(estGrad,2, triMesh%particles%N, "estGradient", "n/a")
	call New(exactGrad,2,triMesh%particles%N,"exactGradient","n/a")
	call New(gradError,1,triMesh%particles%N, "gradError", "n/a")
	call New(est2ndPartials,3,triMesh%particles%N, "estPartials","n/a")
	call New(exact2ndPartials,3,triMesh%particles%N,"exactPartials","n/a")
	call New(partialsError,3,triMesh%particles%N, "partialsError","n/a")
	call New(estLap, 1, triMesh%particles%N, "estLaplacian","n/a")
	call New(exactLap,1, triMesh%particles%N,"exactLaplacian", "n/a")
	call New(lapError,1, triMesh%particles%N,"lapError","n/a")

	do i = 1, triMesh%particles%N
		call InsertScalarToField( scalar, Gaussian( [triMesh%particles%x(i), triMesh%particles%y(i)], b) )
		call InsertVectorToField(exactGrad, GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b))
		call InsertVectorToField(exact2ndPartials, Gauss2ndDerivs([triMesh%particles%x(i), triMesh%particles%y(i)], b))
		call InsertScalarToField(exactLap, GaussLap([triMesh%particles%x(i), triMesh%particles%y(i)],b) )
	enddo

	!
	! define uniform mesh to serve as interpolation target
	!
	do i = 1, nn
		x(i) = xmin + dx * (i-1)
		y(i) = ymin + dx * (i-1)
	enddo

	allocate(ipt(6*triMesh%particles%N - 15))  ! triangle vertices : triangle I has vertices at
											   !  	indices ipt(3*I-2), ipt(3*I-1), and ipt(3*I), for I = 1,...,nTri.
	allocate(ipl(6*triMesh%particles%N))	   ! border edges and triangles : border edge I has
											   ! 	endpoint 1, endpoint 2, and triangle index stored at
											   !	ipl(3*I-2), ipl(3*I-1), and ipl(3*I), for I = 1,...,nL.
	allocate(iwl(18*triMesh%particles%N))	! workspace only
	allocate(iwp(triMesh%particles%N))		! workspace only
	allocate(wk(8*triMesh%particles%N))		! workspace only
	!
	!	triangulate particles
	!
	call idtang( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, &
				 nTri, ipt, nL, ipl, iwl, iwp, wk)
	!
	!	locate triangles that contain destination points
	!
	inTri = 0
	do j = 1, nn
		do i = 1, nn
			call idlctn( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, nTri, ipt, nL, ipl, &
						 x(j), y(i), inTri(i,j), iwl, wk )
		enddo
	enddo
	!
	!	estimate partial derivatives at particles
	!
	allocate(partials(5*triMesh%particles%N)) ! partial derivatives : partials of of particle I stored at
											  !		partials(5*I-4:5*I)
	call idpdrv( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, scalar%scalar, nTri, ipt, partials, wk)
	do i = 1, triMesh%particles%N
		call InsertVectorToField( estGrad, partials(5*i-4:5*i-3) )
		call InsertVectorToField( est2ndPartials, partials(5*i-2:5*i))
		call InsertScalarToField( estLap, partials(5*i-2) + partials(5*i))
	enddo

	do i = 1, triMesh%particles%N
		partials(5*i-4:5*i-3) = GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		partials(5*i-2:5*i) = Gauss2ndDerivs( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
	enddo

	!
	! 	interpolate the scalar
	!
	interpScalar = 0.0_kreal
	do j = 1, nn
		do i = 1, nn
			exactScalar(i,j) = Gaussian( [x(j),y(i)], b)
			if ( pointIsOutsideMesh(triMesh, [ x(j), y(i), 0.0_kreal ]) ) then
				interpScalar(i,j) = 0.0_kreal
			else
				call idptip( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, scalar%scalar, &
						 nTri, ipt, nL, ipl, partials, inTri(i,j), x(j), y(i), interpScalar(i,j))
			endif
		enddo
	enddo

	!
	! calculate derivative error at particles
	!
	do i = 1, triMesh%particles%N
		xVecA = 0.0_kreal
		xVecB = 0.0_kreal
		xVecA(1:2) = [estGrad%xComp(i), estGrad%yComp(i)]
		xVecB(1:2) = GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		call InsertScalarToField( gradError, sqrt(sum( xVecA - xVecB)))
		call InsertScalarToField( lapError, estLap%scalar(i) - exactLap%scalar(i))
		xVecA = [est2ndPartials%xComp(i), est2ndPartials%yComp(i), est2ndPartials%zComp(i)]
		xVecB = Gauss2ndDerivs( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		call InsertVectorToField( partialsError, xVecA - xVecB )
	enddo

	maxGradMag = MaxMagnitude(exactGrad)
	meshSize(nestCtr) = MaxEdgeLength(triMesh%edges, triMesh%particles)
	estGradError(nestCtr) = maxval(gradError%scalar)/maxGradMag
	estLapError(nestCtr) = maxval(abs(lapError%scalar))/maxAbsLap
	interpError(nestCtr) = maxval(abs(interpScalar-exactScalar))

	write(6,'(4A24)') "dx", "gradErr-particles", "lapErr-particles", "interp error"
	write(6,'(4F24.10)') meshSize(nestCtr), estGradError(nestCtr), estLapError(nestCtr), interpError(nestCtr)

	write(filename,'(A,I1,A)') 'BivarTestTriMesh', initNest, '.m'
	open(unit=WRITE_UNIT_1,file=filename,status='REPLACE',action='WRITE')
		call WriteParticlesToMatlab(triMesh%particles, WRITE_UNIT_1)
		call WriteFieldToMatlab(scalar, WRITE_UNIT_1)
		call WriteFieldToMatlab(estGrad, WRITE_UNIT_1)
		call WriteFieldToMatlab(exactGrad, WRITE_UNIT_1)
		call WriteFieldToMatlab(estLap, WRITE_UNIT_1)
		call WriteFieldToMatlab(exactLap, WRITE_UNIT_1)
		call WriteFieldToMatlab(gradError, WRITE_UNIT_1)
		call WriteFieldToMatlab(lapError, WRITE_UNIT_1)

		write(WRITE_UNIT_1,'(A)',advance='NO') "xi = ["
		do i = 1, nn - 1
			write(WRITE_UNIT_1,'(F18.12,A)', advance='NO') x(i), ", "
		enddo
		write(WRITE_UNIT_1,'(F18.12,A)') x(nn), "];"
		write(WRITE_UNIT_1, '(A)') "yi = xi; "

		write(WRITE_UNIT_1,'(A)',advance='NO') "interp = ["
		do i = 1, nn - 1
			do j = 1, nn - 1
				write(WRITE_UNIT_1,'(F18.12,A)',advance='NO') interpScalar(i,j), ", "
			enddo
			write(WRITE_UNIT_1,'(F18.12,A)') interpScalar(i,nn), "; ..."
		enddo
		do j = 1, nn - 1
			write(WRITE_UNIT_1,'(F18.12,A)',advance='NO') interpScalar(nn,j), ", "
		enddo
		write(WRITE_UNIT_1,'(F18.12,A)') interpScalar(nn,nn), "];"

	close(WRITE_UNIT_1)

	call cpu_time(testEnd)
	write(6,'(A,I8,A,F12.2,A)') "nParticles = ", triMesh%particles%N, ": elapsed time = ", testEnd-testStart, " seconds."

	!
	! reset for next iteration
	!
	deallocate(partials)
	deallocate(wk)
	deallocate(iwl)
	deallocate(iwp)
	deallocate(ipl)
	deallocate(ipt)
	call Delete(lapError)
	call Delete(exactLap)
	call Delete(estLap)
	call Delete(partialsError)
	call Delete(exact2ndPartials)
	call Delete(est2ndPartials)
	call Delete(gradError)
	call Delete(exactGrad)
	call Delete(estGrad)
	call Delete(scalar)
	call Delete(triMesh)

	call LogMessage(exeLog,TRACE_LOGGING_LEVEL, "test complete for initNest = ", initNest)
	nestCtr = nestCtr + 1
enddo
!
!write(6,'(4A24)') "dx", "gradErr-particles", "lapErr-particles", "interp error"
!do i = 1, testSize
!	write(6,'(4F24.10)') meshSize(i), estGradError(i), estLapError(i), interpError(i)
!enddo
!
!if ((meshSize(1) /= 0.375) .OR. estGradError(1) > 0.3953 .OR. interpError(1) > 0.0003134) then
!    testPass = .FALSE.
!    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, "test result: ", "regression failed at index 1")
!endif
!
!if ((meshSize(2) /= 0.1875) .OR. estGradError(2) > 0.2091 .OR. interpError(2) > 0.0003134) then
!    testPass = .FALSE.
!    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, "test result: ", "regression failed at index 2")
!endif

if ((meshSize(1) /= 0.09375) .OR. estGradError(1) > 0.10728 .OR. interpError(1) > 0.0003134) then
    testPass = .FALSE.
    call LogMessage(exeLog, ERROR_LOGGING_LEVEL, "test result: ", "regression failed at index 3")
endif

if (testPass) call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "test result: ", "PASSED.")

contains

function Gaussian( xy, b )
	real(kreal) :: Gaussian
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b

	Gaussian = exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc)))
end function

function GaussGrad(xy, b)
	real(kreal) :: GaussGrad(2)
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	GaussGrad(1) = xy(1)-xc
	GaussGrad(2) = xy(2)-yc
	GaussGrad = -2.0_kreal * GaussGrad * b * b * exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

function GaussLap(xy, b)
	real(kreal) :: GaussLap
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	GaussLap = ( b*b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ) - 1.0_kreal ) * 4.0_kreal * b * b * &
			exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

function Gauss2ndDerivs( xy, b)
	real(kreal) :: Gauss2ndDerivs(3)
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	Gauss2ndDerivs(1) = 2.0_kreal * b * b *(2.0_kreal * b*b *(xy(1)-xc)*(xy(1)-xc) - 1.0_kreal)
	Gauss2ndDerivs(2) = 4.0_kreal * b**4 * (xy(1)-xc)*(xy(2)-yc)
	Gauss2ndDerivs(3) = 2.0_kreal * b * b *(2.0_kreal * b*b * (xy(2)-yc)*(xy(2)-yc) - 1.0_kreal)
	Gauss2ndDerivs = Gauss2ndDerivs * exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

end program


module mod_graph
  implicit none
  integer(8), parameter :: inf = 1000000000000000000_8

  type item
    integer :: id = 0
    integer(8) :: wt = 0_8
  end type

  type priorityqueue
    integer :: num = 0
    type(item), pointer :: heap(:) => null()
  end type

  type edge
    integer :: fm = 0, to = 0, cp = 0, rv = 0
    integer(8) :: wt = 0_8
  end type

  type arraylist
    integer :: num = 0
    type(edge), pointer :: arr(:) => null()
  contains
    procedure :: add => adde
    procedure :: bellman_ford => bellman_ford
  end type

  type graph
    type(arraylist), pointer :: egs(:) => null()
    logical, pointer :: used(:) => null()
  contains
    procedure :: add => add
    procedure :: dijkstra => dijkstra
    procedure :: ford_fulkerson => ford_fulkerson
  end type

  interface graph
    module procedure :: newg
  end interface graph

contains

  function newi(id,wt) result(ret)
    integer, intent(in) :: id
    integer(8), intent(in) :: wt
    type(item) :: ret
    ret%id = id
    ret%wt = wt
  end

  subroutine swapi(a,b)
    type(item), intent(inout) :: a, b
    type(item) :: c
    c = a
    a = b
    b = c
  end

  subroutine appendi(a)
    type(item), pointer, intent(inout) :: a(:)
    integer :: n
    type(item), allocatable :: tmp(:)
    n = size(a)
    allocate(tmp(n))
    tmp = a
    deallocate(a)
    allocate(a(2*n))
    a(1:n) = tmp
    deallocate(tmp)
  end

  function lessi(a,b) result(ret)
    type(item), intent(in) :: a, b
    logical :: ret
    ret = a%wt < b%wt
  end

  subroutine finalizei(pq)
    type(priorityqueue), intent(inout) :: pq
    if (associated(pq%heap)) deallocate(pq%heap)
    pq%num = 0
  end

  subroutine offer(pq,it)
    type(priorityqueue), intent(inout) :: pq
    type(item), intent(in) :: it
    integer :: i, j
    if (.not.associated(pq%heap)) allocate(pq%heap(1))
    if (pq%num == size(pq%heap)) call appendi(pq%heap)
    pq%num = pq%num+1
    pq%heap(pq%num) = it
    i = pq%num
    do while (i > 1)
      j = i/2
      if (lessi(pq%heap(i),pq%heap(j))) call swapi(pq%heap(i),pq%heap(j))
      i = j
    end do
  end

  function poll(pq) result(ret)
    type(priorityqueue), intent(inout) :: pq
    type(item) :: ret
    integer :: n, i, j
    n = pq%num
    ret = pq%heap(1)
    pq%heap(1) = pq%heap(n)
    pq%num = pq%num-1
    i = 1
    do while (2*i < n)
      j = 2*i
      if (j+1 < n .and. lessi(pq%heap(j+1),pq%heap(j))) j = j+1
      if (lessi(pq%heap(j),pq%heap(i))) call swapi(pq%heap(j),pq%heap(i))
      i = j
    end do
  end

  function newe(to,wt,fm,cp,rv) result(ret)
    integer, intent(in) :: to
    integer(8), intent(in) :: wt
    integer, intent(in), optional :: fm, cp, rv
    type(edge) :: ret
    if (present(fm)) ret%fm = fm
    ret%to = to
    ret%wt = wt
    if (present(cp) .and. present(rv)) then
      ret%cp = cp
      ret%rv = rv
    end if
  end

  subroutine appende(a)
    type(edge), pointer, intent(inout) :: a(:)
    integer :: n
    type(edge), allocatable :: tmp(:)
    n = size(a)
    allocate(tmp(n))
    tmp = a
    deallocate(a)
    allocate(a(2*n))
    a(1:n) = tmp
    deallocate(tmp)
  end

  function lesse(a,b) result(ret)
    type(edge), intent(in) :: a, b
    logical :: ret
    ret = a%wt < b%wt
  end

  subroutine finalizee(list)
    type(arraylist), intent(inout) :: list
    if (associated(list%arr)) deallocate(list%arr)
    list%num = 0
  end

  subroutine adde(list,e)
    class(arraylist), intent(inout) :: list
    type(edge), intent(in) :: e
    if (.not.associated(list%arr)) allocate(list%arr(1))
    if (list%num == size(list%arr)) call appende(list%arr)
    list%num = list%num+1
    list%arr(list%num) = e
  end

  function pope(list) result(ret)
    type(arraylist), intent(inout) :: list
    type(edge) :: ret
    ret = list%arr(list%num)
    list%num = list%num-1
  end

  function newg(n) result(ret)
    integer, intent(in) :: n
    type(graph) :: ret
    allocate(ret%egs(n))
  end

  subroutine add(g,fm,to,wt,cp)
    class(graph), intent(inout) :: g
    integer, intent(in) :: fm, to
    integer, intent(in), optional :: cp
    integer(8) :: wt
    if (present(cp)) then
      call adde(g%egs(fm),newe(to,wt,cp=cp,rv=g%egs(to)%num))
      call adde(g%egs(to),newe(fm,wt,cp=0,rv=g%egs(fm)%num-1))
    else
      call adde(g%egs(fm),newe(to,wt))
    end if
  end

  function dijkstra(g,s) result(ret)
    class(graph), intent(in) :: g
    integer, intent(in) :: s
    integer(8) :: ret(size(g%egs))
    type(priorityqueue) :: pq
    type(item) :: it
    type(edge) :: e
    integer :: i
    ret = inf
    ret(s) = 0_8
    call offer(pq,newi(s,ret(s)))
    do while (pq%num > 0)
      it = poll(pq)
      if (it%wt > ret(it%id)) cycle
      do i = 1, g%egs(it%id)%num
        e = g%egs(it%id)%arr(i)
        if (ret(e%to) > ret(it%id)+e%wt) then
          ret(e%to) = ret(it%id)+e%wt
          call offer(pq,newi(e%to,ret(e%to)))
        end if
      end do
    end do
  end

  recursive subroutine dfs_bf(g,u)
    type(graph), intent(inout) :: g
    integer, intent(in) :: u
    integer :: i, v
    g%used(u) = .true.
    do i = 1, g%egs(u)%num
      v = g%egs(u)%arr(i)%to
      if (g%used(v)) cycle
      call dfs_bf(g,v)
    end do
  end

  function bellman_ford(es,s,t) result(ret)
    class(arraylist), intent(in) :: es
    integer, intent(in) :: s, t
    integer(8) :: ret
    integer :: n, i, fm, to, step
    integer(8) :: wt
    logical :: updated
    integer(8), allocatable :: tmp(:)
    type(graph) :: gs, gt
    type(arraylist) :: reach
    n = 0
    do i = 1, es%num
      n = max(n,es%arr(i)%fm,es%arr(i)%to)
    end do
    gs = newg(n)
    gt = newg(n)
    allocate(gs%used(n),gt%used(n))
    gs%used = .false.
    gt%used = .false.
    do i = 1, es%num
      fm = es%arr(i)%fm
      to = es%arr(i)%to
      wt = es%arr(i)%wt
      call add(gs,fm,to,wt)
      call add(gt,to,fm,wt)
    end do
    call dfs_bf(gs,s)
    call dfs_bf(gt,t)
    n = 0
    do i = 1, es%num
      fm = es%arr(i)%fm
      to = es%arr(i)%to
      if (gs%used(fm) .and. gt%used(fm) .and. gs%used(to) .and. gt%used(to)) then
        call adde(reach,es%arr(i))
        n = max(n,fm,to)
      end if
    end do
    deallocate(gs%used,gt%used)
    allocate(tmp(n))
    tmp = inf
    tmp(s) = 0_8
    step = 0
    updated = .true.
    do while (updated)
      updated = .false.
      do i = 1, reach%num
        fm = reach%arr(i)%fm
        to = reach%arr(i)%to
        wt = reach%arr(i)%wt
        if (tmp(to) > tmp(fm)+wt) then
          tmp(to) = tmp(fm)+wt
          updated = .true.
        end if
      end do
      step = step+1
      if (step > n) then
        ret = -inf
        return
      end if
    end do
    ret = tmp(t)
    deallocate(tmp)
  end

  recursive function dfs_ff(g,u,t,f) result(ret)
    class(graph), intent(inout) :: g
    integer, intent(in) :: u, t, f
    integer :: ret
    integer :: i, v, cp, rv
    ret = f
    if (u == t) return
    g%used(u) = .true.
    do i = 1, g%egs(u)%num
      v = g%egs(u)%arr(i)%to
      cp = g%egs(u)%arr(i)%cp
      if (g%used(v) .or. cp <= 0) cycle
      ret = dfs_ff(g,v,t,min(f,cp))
      rv = g%egs(u)%arr(i)%rv
      if (ret > 0) then
        g%egs(u)%arr(i)%cp = g%egs(u)%arr(i)%cp-ret
        g%egs(v)%arr(rv)%cp = g%egs(v)%arr(rv)%cp+ret
        return
      end if
    end do
    ret = 0
  end

  function ford_fulkerson(g,s,t) result(ret)
    class(graph), intent(inout) :: g
    integer, intent(in) :: s, t
    integer :: ret
    integer :: f
    ret = 0
    if (.not.associated(g%used)) allocate(g%used(size(g%egs)))
    do
      g%used = .false.
      f = dfs_ff(g,s,t,1000000000)
      if (f == 0) then
        deallocate(g%used)
        return
      end if
      ret = ret+f
    end do
  end

end module mod_graph


      subroutine mapc2m(xc,yc,xp,yp,zp)
      implicit none

      double precision xc,yc,xp,yp,zp

      double precision ll(2), ur(2)
      logical isperiodic

c     # This constructs mapping in [-1,-1]x[1,1].  To get
c     # something in a box of a different size and location
c     # translate below.

      isperiodic = .false.
      call mapc2m_inclusions(xc,yc,xp,yp,isperiodic)

c     # Map to from [-1,1]x[-1,1] to [ll]x[ur]

c     # The transformation below doesn't do anything, but demonstrates
c     # how to translate and scale the output from the inclusions
c     # maping.
      ll(1) = -1
      ll(2) = -1
      ur(1) = 1
      ur(2) = 1
      call transform(xp,yp,ll,ur)

      zp = 0

      end

      subroutine transform(xp,yp,ll,ur)
      implicit none

      double precision xp,yp,ll(2),ur(2)

      xp = ll(1) + (ur(1) - ll(1))*(xp + 1.d0)/2.d0
      yp = ll(2) + (ur(2) - ll(2))*(yp + 1.d0)/2.d0

      end

      double precision function exact_area()
      implicit none

      exact_area = 4.d0
      end


	FUNCTION PR_CTCF  ( clct )
C************************************************************************
C* PR_CTCF								*
C* 									*
C* This function computes CFRT from CLCT.  CLCT is the numeric total	*
C* cloud cover; CLCT is the WMO fractional cloud cover table.		*
C*									*
C* REAL PR_CTCF  ( CLCT )						*
C*									*
C* Input parameters:							*
C*	CLCT		REAL		WMO fractional cloud cover	*
C*									*
C* Output parameters:							*
C*	PR_CTCF		REAL		Numeric total cloud cover	*
C**									*
C* Log:									*
C* M. desJardins/NMC	10/91						*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		itable (9)
	INCLUDE		'ERMISS.FNC'
C*
	DATA		itable / 0, 3, 6, 8, 9, 2, 5, 7, 0 /
C*
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF ( ERMISS ( clct ) ) THEN
	    PR_CTCF = RMISSD
	    RETURN
	END IF
C
C*	Get fractional cloud cover WMO code.
C
	IF  ( ( clct .gt. 0 ) .and. ( clct .le. 9 ) )  THEN
	    iclct = NINT ( clct )
	    PR_CTCF = itable ( iclct )
	  ELSE
	    PR_CTCF = RMISSD
	END IF
C*
	RETURN
	END


module constants_mod
implicit none

	real(kind=8), parameter :: PK = 1.3806503d-16, PC = 2.99792458d10
	real(kind=8), parameter :: PH = 6.62606876d-27, PI = 3.14159265359d0
	real(kind=8), parameter :: PME = 9.10938188d-28, PE = 4.8032d-10

end module constants_mod

module general_routines_mod
use constants_mod
implicit none
contains

! ---------------------------------------------------------
! Given x(:) and y(:) which tabulate a function and the derivative at the boundary points
! this function returns the second derivative of the spline at each point
! ---------------------------------------------------------
		subroutine splin1(x,y,yp1,ypn,y2)
		real*8, INTENT(IN) :: x(:), y(:), yp1, ypn
		real*8, INTENT(INOUT) :: y2(size(x))
		integer :: n, i, k
		real*8 :: p, qn, sig, un, u(size(x))

			n = size(x)

			if (yp1 > .99d30) then
				y2(1) = 0.d0
				u(1) = 0.d0
			else
				y2(1) = -0.5d0
				u(1) = (3.d0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
			endif

			do i = 2, n-1
				sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
				p = sig * y2(i-1)+2.d0
				y2(i) = (sig-1.d0)/p
				u(i) = (6.d0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/&
					(x(i+1)-x(i-1))-sig*u(i-1))/p
			enddo
			if (ypn > .99d30) then
				qn = 0.d0
				un = 0.d0
			else
				qn = 0.5d0
				un = (3.d0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
			endif

			y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.d0)

			do k = n-1, 1, -1
				y2(k) = y2(k)*y2(k+1)+u(k)
			enddo

		end subroutine splin1

! ---------------------------------------------------------
! Given xa(:) and ya(:) which tabulate a function, returns the interpolation using
! splines of vector x(:) in y(:)
! ---------------------------------------------------------
		subroutine spline(xa,ya,x,y)
		real*8, INTENT(INOUT) :: y(:)
		real*8, INTENT(IN) :: xa(:), ya(:), x(:)
		real*8 :: y2a(size(xa))
		integer :: n_x, n, i, k, khi, klo
		real*8 :: a, b, h, extrap

			n = size(xa)
			n_x = size(x)
			call splin1(xa,ya,1.d30,1.d30,y2a)

			do i = 1, n_x

! Downward extrapolation
				if (x(i) < xa(1)) then
!					y(i) = ya(1)
					y(i) = ya(1) + (ya(1)-ya(2))/(xa(1)-xa(2)) * (xa(1) - x(i))
				else

! Upward extrapolation
				if (x(i) > xa(n)) then
!					y(i) = ya(n)
					y(i) = ya(n) + (ya(n)-ya(n-1)) / (xa(n)-xa(n-1)) * (x(i) - xa(n))
				else
! In range
						klo = 1
						khi = n
1						if(khi-klo > 1) then
							k = (khi+klo)/2
							if (xa(k) > x(i)) then
								khi = k
							else
								klo = k
							endif
							go to 1
						endif

						h = xa(khi)-xa(klo)

						if (h == 0.d0) then
							print *, 'bad xa input in spline'
							stop
						endif
						a = (xa(khi)-x(i))/h
						b = (x(i)-xa(klo))/h

						y(i) = a*ya(klo)+b*ya(khi)+((a**3.d0-a)*y2a(klo)+(b**3.d0-b)*y2a(khi))*(h**2.d0)/6.d0

					endif
				endif
			enddo

		end subroutine spline

! ---------------------------------------------------------
! Given xa(:) and ya(:) which tabulate a function z(nxmny), returns the interpolation using
! spline interpolation in 2D
! ---------------------------------------------------------
	function interpol_2d(xa,ya,z,x0,y0)
	real(kind=8) :: interpol_2d
	real(kind=8) :: xa(:), ya(:), z(:,:), x0, y0, res(1), xin(1)
	real(kind=8), allocatable :: temp(:)
	integer :: nx, ny, j
		nx = size(xa)
		ny = size(ya)
		allocate(temp(nx))
		do j = 1, nx
			xin(1) = y0
			call spline(ya,z(j,:),xin,res)
			temp(j) = res(1)
		enddo

		xin(1) = x0
		call spline(xa,temp,xin,res)

		interpol_2d = res(1)

	end function interpol_2d

!-----------------------------------------------------------------
! This subroutine calculates the atomic partition function for a Mg
!	t: array with the temperature
!	u1: partition function for the neutral element (also an array of the same size as t)
!	u2: partition function for the 1st ionization (also an array of the same size as t)
!	u3: partition function for the 2nd ionization (also an array of the same size as t)
!     A. D. Wittmann, Goettingen (1975).(1974, solar phys. 35, 11)
!-----------------------------------------------------------------
	subroutine partition_atomic_mg(t, u1, u2, u3)
	real(kind=8) :: t(:), u1(size(t)), u2(size(t)), u3(size(t))
	real(kind=8), allocatable :: x(:), y(:), coeff(:), zz(:)
	integer :: n, i

		n = size(t)
		allocate(x(n))
		allocate(y(n))

		x = alog(5040.e0/real(t))
		y = 1.d-3*t

		u1 = 1.d0+exp(-4.027262-x*(6.173172+x*(2.889176+x*(2.393895+.784131*x))))
		where(t > 8.d3)
			u1 = 2.757+t*(-7.8909e-4+t*7.4531e-8)
		endwhere
		u2 = 2.d0+exp(-7.721172-x*(7.600678+x*(1.966097+.212417*x)))
		where(t > 2.d4)
			u2 = 7.1041+t*(-1.0817e-3+t*4.7841d-8)
		endwhere
		u3 = 1.d0

		deallocate(x)
		deallocate(y)

	end subroutine partition_atomic_mg

!-----------------------------------------------------------------
! Calculates the ratio between two ionization stages using the Saha equation
!-----------------------------------------------------------------
	function saha(t, pe, ul ,uu, chi)
	real(kind=8) :: t(:), pe(:), ul(:), uu(:), chi, saha(size(t))
	real(kind=8) :: constant

		constant = 2.d0 * (2.d0*PI*PME)**(1.5d0) / PH**3 * PK**(2.5d0)
		saha = constant * uu / ul * t**2.5d0 * 10.d0**(-5040.d0*chi/t) / pe

	end function saha

!-----------------------------------------------------------------
! Return the ionization potentials and abundances of Mg
!-----------------------------------------------------------------
	subroutine get_ionpot_abundance_mg(ionization_pot1, ionization_pot2, abundance)
	real(kind=8) :: ionization_pot1, ionization_pot2, abundance

		ionization_pot1 = 7.64400d0
		ionization_pot2 = 15.0300d0
		abundance = 10.d0**(7.53-12.d0)

	end subroutine get_ionpot_abundance_mg

end module general_routines_mod

module background_opacity_mod
use constants_mod
use general_routines_mod
implicit none
contains

!-----------------------------------------------------------------
! Calculates the negative hydrogen (H-) free-free continuum absorption coefficient per
! hydrogen atom (cm^2)
!  REF: John 1989 A&A 193, 189
!  INPUT:
!		T : temperature in K (1400 < T < 100080)
!		Pe: electron pressure
!		lambda: wavelength in A (greater than 1880 A)
!-----------------------------------------------------------------
	function hminus_ff(T, Pe, lambda_in)
	real(kind=8) :: hminus_ff, T, Pe, lambda_in
	real(kind=8), dimension(6) :: a1, b1, c1, d1, e1, f1, com1
	real(kind=8), dimension(4) :: a2, b2, c2, d2, e2, f2, com2
	real(kind=8) :: lambda, theta, result

		a1 = (/0.d0,2483.346d0,-3449.889d0,2200.04d0,-696.271d0,88.283d0/)
		b1 = (/0.d0,285.827d0,-1158.382d0,2427.719d0,-1841.4d0,444.517d0/)
      c1 = (/0.d0,-2054.291d0,8746.523d0,-13651.105d0,8624.97d0,-1863.864d0/)
      d1 = (/0.d0,2827.776d0,-11485.632d0,16755.524d0,-10051.53d0,2095.288d0/)
      e1 = (/0.d0,-1341.537d0,5303.609d0,-7510.494d0,4400.067d0,-901.788d0/)
      f1 = (/0.d0,208.952d0,-812.939d0,1132.738d0,-655.02d0,132.985d0/)
      a2 = (/518.1021d0,473.2636d0,-482.2089d0,115.5291d0/)
      b2 = (/-734.8666d0,1443.4137d0,-737.1616d0,169.6374d0/)
      c2 = (/1021.1775d0,-1977.3395d0,1096.8827d0,-245.649d0/)
      d2 = (/-479.0721d0,922.3575d0,-521.1341d0,114.243d0/)
      e2 = (/93.1373d0,-178.9275d0,101.7963d0,-21.9972d0/)
      f2 = (/-6.4285d0,12.36d0,-7.0571d0,1.5097d0/)

! Transform wavelength to microns
		lambda = lambda_in / 1.d4
		theta = 5040.d0 / T

		result = 0.d0

		if (lambda < 0.3645) then
			com2 = a2*lambda**2 + b2 + c2/lambda + d2/lambda**2 + e2/lambda**3 + f2/lambda**4
         result = com2(1) * theta**1 + com2(2)*theta**1.5 + com2(3)*theta**2 + com2(4)*theta**2.5
		else
			com1 = a1*lambda**2 + b1 + c1/lambda + d1/lambda**2 + e1/lambda**3 + f1/lambda**4
         result = com1(1) * theta**1 + com1(2)*theta**1.5 + com1(3)*theta**2 + com1(4)*theta**2.5 + &
				com1(5)*theta**3 + com1(6)*theta**3.5
		endif

		hminus_ff = 1.d-29 * result * Pe

	end function hminus_ff

!-----------------------------------------------------------------
! Calculates the negative hydrogen (H-) free-free continuum absorption coefficient per
! hydrogen atom (cm^2)
!  REF: John 1989 A&A 193, 189
!  INPUT:
!		T : temperature in K (1400 < T < 100080)
!		Pe: electron pressure
!		lambda: wavelength in A (greater than 1880 A)
!-----------------------------------------------------------------
	function hminus_table(T, Pe, lambda_in)
	real(kind=8) :: hminus_table, T, Pe, lambda_in
	real(kind=8), dimension(9,17) :: obs
	real(kind=8) :: l_obs(17), theta_obs(9), theta, l, result

		l_obs = (/0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0,1.2,1.4,1.6,1.65,1.8,2.0,2.5,3.0/)
		theta_obs = (/0.5,0.6,0.8,1.0,1.2,1.4,1.6,1.8,2.0/)

		obs(:,1) = (/1.676,3.135,9.077,22.41,50.0,104.0,205.6,390.8,720.0/)
		obs(:,2) = (/2.850,5.355,15.54,38.38,85.65,178.2,352.2,669.3,1233.0/)
		obs(:,3) = (/3.985,7.548,22.05,54.55,121.8,253.4,500.8,951.7,1753.0/)
		obs(:,4) = (/4.925,9.423,27.83,69.12,154.5,321.7,635.9,1208.0,2226.0/)
		obs(:,5) = (/5.594,10.81,32.32,80.78,181.1,377.4,76.4,1419.0,2614.0/)
		obs(:,6) = (/5.960,11.61,35.16,88.53,199.3,416.1,823.7,1566.0,2887.0/)
		obs(:,7) = (/6.033,11.83,36.22,91.90,207.8,435.1,862.7,1642.0,3027.0/)
		obs(:,8) = (/5.832,11.48,35.49,90.72,206.2,433.1,860.3,1639.0,3024.0/)
		obs(:,9) = (/5.400,10.64,33.11,85.18,194.5,410.0,816.4,1558.0,2877.0/)
		obs(:,10) = (/4.017,7.819,24.29,62.94,144.9,307.5,615.3,1178.0,2181.0/)
		obs(:,11) = (/2.332,4.254,12.49,31.86,73.21,155.7,312.5,600.3,1114.0/)
		obs(:,12) = (/0.998,1.321,2.318,4.244,8.038,15.37,29.17,54.38,99.32/)
		obs(:,13) = (/0.915,1.103,1.456,1.785,2.086,2.362,2.638,2.894,3.137/)
		obs(:,14) = (/1.083,1.308,1.727,2.117,2.470,2.800,3.122,3.424,3.708/)
		obs(:,15) = (/1.335,1.610,2.124,2.610,3.029,3.466,3.862,4.237,4.584/)
		obs(:,16) = (/2.076,2.494,3.283,4.029,4.677,5.379,5.984,6.570,7.122/)
		obs(:,17) = (/2.966,3.562,4.685,5.720,6.694,7.605,8.463,9.276,10.06/)

		theta = 5040.d0 / T
		l = lambda_in / 1.d4

		result = interpol_2d(theta_obs,l_obs,obs,theta,l)

		hminus_table = 1.d-27 * result * Pe

	end function hminus_table

!-----------------------------------------------------------------
! Calculates the negative hydrogen (H-) bound-free continuum absorption coefficient per
! hydrogen atom (cm^2)
!  REF: John 1989 A&A 193, 189 (with a couple of mistakes)
!  INPUT:
!		T : temperature in K
!		Pe: electron pressure
!		lambda: wavelength in A (greater than 1250 A)
!-----------------------------------------------------------------
	function hminus_bf(T, Pe, lambda_in)
	real(kind=8) :: hminus_bf, T, Pe, lambda_in
	real(kind=8) :: lambda, lambda0, alpha, cte, cc(6), sigma, com, result

		lambda0 = 1.6419d0
		alpha = PH*PC/PK * 1.d4
		cte = 0.75d-18
		cc = (/152.519d0,49.534d0,-118.858d0,92.536d0,-34.194d0,4.982d0/)

! Transform wavelength to microns
		lambda = lambda_in / 1.d4

		if (lambda < lambda0) then
			com = 1.d0/lambda - 1.d0/lambda0
			sigma = cc(1) + cc(2)*com**0.5 + cc(3)*com**1 + cc(4)*com**1.5 + cc(5)*com**2 + cc(6)*com**2.5
			sigma = sigma * lambda**3 * com**1.5
			result = T**(-2.5) * exp(alpha/(T*lambda0)) * (1.d0 - exp(-alpha/(T*lambda)))
			result = result * cte * sigma
		else
			result = 0.d0
		endif

		hminus_bf = result * Pe

	end function hminus_bf

!-----------------------------------------------------------------
! Calculates the continuum absorption coefficient per
! hydrogen atom (cm^2) due to Thomson scattering (scattering with free electrons)
!  INPUT:
!		Pe: electron pressure
!		PH: neutral H atoms partial pressure
!-----------------------------------------------------------------
	function thomson(Pel, PH)
	real(kind=8) :: thomson, Pel, PH
	real(kind=8) :: cte

		cte = 8.d0*PI/3.d0 * (PE/PC)**4 / PME**2
		thomson = cte * (Pel/PH)

	end function thomson

!-----------------------------------------------------------------
! Calculates the hydrogen (H) bound-free and free-free continuum absorption coefficient per
! hydrogen atom (cm^2)
!  REF: Landi Degl'Innocenti 1976, A&ASS, 25, 379
!  INPUT:
!		T : temperature in K (T < 12000)
!		lambda: wavelength in A
!-----------------------------------------------------------------
	function hydrogen(T, lambda_in)
	real(kind=8) :: hydrogen, T, lambda_in
	real(kind=8) :: r, c1, c2, cte, theta1, theta2, theta3, sum, gff
	integer :: i, n0

		r = 1.096776d-3
		c1 = 1.5777216d5
		c2 = 1.438668d8
		cte = 1.045d-26

		theta1 = c1 / T
		theta2 = c2 / (lambda_in * T)
		theta3 = 2.d0*theta1

! Lowest level which can be photoionized
		n0 = 1 + floor(sqrt(r*lambda_in))

! Sum over states that can be photoionized
		if (n0 <= 8) then
			sum = exp(theta1 / n0**2) / n0**3
			do i = n0+1, 8
				sum = sum + exp(theta1 / i**2) / i**3
			enddo
			sum = sum + (0.117d0 + exp(theta1/81.d0)) / theta3
		else
			sum = (0.117d0 + exp(theta1/n0**2)) / theta3
		endif

! Approximate the value of the Gaunt factor G_ff from Mihalas Eq (80) @ theta=1, x=0.5
		gff = (1.d0-exp(-theta2)) * exp(-theta1) * lambda_in**3

		hydrogen = cte * gff * sum

	end function hydrogen

!-----------------------------------------------------------------
! Calculates the Rayleigh scattering on hydrogen (H) per
! hydrogen atom (cm^2)
!  REF: Landi Degl'Innocenti 1976, A&ASS, 25, 379 (he quotes Dalgarno (1962) but the polynomial has a mistake)
!  INPUT:
!		lambda: wavelength in A
!-----------------------------------------------------------------
	function rayleigh_h(lambda_in)
	real(kind=8) :: rayleigh_h, lambda_in
	real(kind=8) :: c(3)

		c = (/5.799d-13,1.422d-6,2.784d0/)

		rayleigh_h = (c(1)+(c(2)+c(3)/lambda_in**2) / lambda_in**2) / lambda_in**4

	end function rayleigh_h

!-----------------------------------------------------------------
! Calculates the Rayleigh scattering on molecular hydrogen (H2) per
! hydrogen atom (cm^2)
!  REF: Landi Degl'Innocenti 1976, A&ASS, 25, 379 (he quotes Dalgarno & Williams (1962) ApJ 136, 960)
!  INPUT:
!		lambda: wavelength in A
!		PH: hydrogen partial pressure
!		PH2: molecular hydrogen partial pressure
!-----------------------------------------------------------------
	function rayleigh_h2(PH, PH2, lambda_in)
	real(kind=8) :: rayleigh_h2, PH, PH2, lambda_in
	real(kind=8) :: c(3)

		c = (/8.14d-13,1.28d-6,1.61d0/)

		rayleigh_h2 = (c(1)+(c(2)+c(3)/lambda_in**2) / lambda_in**2) / lambda_in**4 * (PH2/PH)

	end function rayleigh_h2

!-----------------------------------------------------------------
! Calculates the bound-free and free-free absorption coefficient of neutral Mg
! per H particle (not per H atom, so remember to multiply by nH_tot
!  INPUT:
!		T : temperature (K)
!		Pe: electron pressure
!		lambda: wavelength in A (from 1900 to 9000 A)
!-----------------------------------------------------------------
	function magnesium(T, Pe, lambda_in)
	real(kind=8) :: magnesium, T, Pe, lambda_in
	real(kind=8) :: lambda(29), cMg(29,9), temin, temax, testep, result
	real(kind=8), dimension(1) :: temper, u1, u2, u3, Pelec, n1overn0, n2overn1, n0overn
	real(kind=8) :: ionization_pot1, ionization_pot2, abundance
	integer :: nlambda, ix(1), iy

		temin = 4000.d0
		temax = 12000.d0
		testep = 1000.d0
		nlambda = 29

		lambda = (/1.900d3,2.200d3,2.513d3,2.514d3,2.900d3,3.300d3,3.756d3,3.757d3,4.000d3,4.400d3,&
			4.884d3,4.885d3,5.200d3,5.504d3,5.505d3,6.000d3,6.549d3,6.550d3,6.900d3,7.234d3,7.235d3,&
			7.260d3,7.291d3,7.292d3,7.700d3,8.113d3,8.114d3,8.500d3,9.000d3/)

! Table equispaced in temperature from 4000 K to 12000 K in steps of 1000 K
		cmg(:,1) = (/2.587d-20,3.910d-20,5.626d-20,7.319d-23,9.530d-23,&
        1.024d-22,9.561d-23,9.338d-24,1.097d-23,1.400d-23,1.831d-23,&
        1.594d-23,1.856d-23,2.131d-23,2.124d-23,2.617d-23,3.237d-23,&
        1.962d-23,2.245d-23,2.537d-23,1.778d-23,1.795d-23,1.815d-23,&
        1.748d-24,1.944d-24,2.162d-24,1.868d-24,2.116d-24,2.466d-24/)

      cmg(:,2) = (/1.251d-19,1.892d-19,2.723d-19,9.667d-22,1.268d-21,1.389d-21,&
        1.349d-21,2.756d-22,3.232d-22,4.117d-22,5.365d-22,4.908d-22,&
        5.718d-22,6.571d-22,6.556d-22,8.088d-22,1.002d-21,6.424d-22,&
        7.352d-22,8.307d-22,5.936d-22,5.990d-22,6.057d-22,8.915d-23,&
        1.005d-22,1.131d-22,1.029d-22,1.166d-22,1.360d-22/)

      cmg(:,3) = (/3.583d-19,5.425d-19,7.810d-19,5.606d-21,7.419d-21,8.323d-21,&
        8.449d-21,2.683d-21,3.147d-21,4.007d-21,5.217d-21,4.887d-21,&
        5.698d-21,6.553d-21,6.541d-21,8.079d-21,1.002d-20,6.692d-21,&
        7.660d-21,8.656d-21,6.304d-21,6.361d-21,6.433d-21,1.280d-21,&
        1.455d-21,1.648d-21,1.539d-21,1.745d-21,2.037d-21/)

      cmg(:,4) = (/7.611d-19,1.154d-18,1.661d-18,2.029d-20,2.711d-20,3.114d-20,&
        3.296d-20,1.381d-20,1.621d-20,2.064d-20,2.687d-20,2.552d-20,&
        2.978d-20,3.427d-20,3.422d-20,4.231d-20,5.252d-20,3.622d-20,&
        4.147d-20,4.687d-20,3.476d-20,3.507d-20,3.547d-20,8.834d-21,&
        1.009d-20,1.147d-20,1.088d-20,1.235d-20,1.443d-20/)

		cmg(:,5) = (/1.342d-18,2.037d-18,2.934d-18,5.454d-20,7.355d-20,8.633d-20,&
        9.477d-20,4.763d-20,5.594d-20,7.131d-20,9.288d-20,8.900d-20,&
        1.039d-19,1.197d-19,1.195d-19,1.479d-19,1.838d-19,1.301d-19,&
        1.490d-19,1.685d-19,1.271d-19,1.283d-19,1.297d-19,3.838d-20,&
        4.397d-20,5.018d-20,4.808d-20,5.459d-20,6.383d-20/)

      cmg(:,6) = (/2.090d-18,3.177d-18,4.579d-18,1.198d-19,1.630d-19,1.950d-19,&
        2.207d-19,1.258d-19,1.478d-19,1.886d-19,2.458d-19,2.370d-19,&
        2.769d-19,3.191d-19,3.187d-19,3.950d-19,4.913d-19,3.556d-19,&
        4.074d-19,4.607d-19,3.530d-19,3.562d-19,3.603d-19,1.222d-19,&
        1.403d-19,1.605d-19,1.549d-19,1.760d-19,2.059d-19/)

      cmg(:,7) = (/2.990d-18,4.548d-18,6.558d-18,2.282d-19,3.127d-19,3.804d-19,&
        4.415d-19,2.753d-19,3.237d-19,4.134d-19,5.392d-19,5.222d-19,&
        6.107d-19,7.042d-19,7.035d-19,8.727d-19,1.087d-18,8.017d-19,&
        9.187d-19,1.039d-18,8.080d-19,8.154d-19,8.247d-19,3.122d-19,&
        3.549d-19,4.118d-19,3.995d-19,4.541d-19,5.317d-19/)

      cmg(:,8) = (/4.015d-18,6.115d-18,8.819d-18,3.909d-19,5.391d-19,6.651d-19,&
        7.882d-19,5.253d-19,6.183d-19,7.904d-19,1.032d-18,1.003d-18,&
        1.173d-18,1.354d-18,1.353d-18,1.680d-18,2.093d-18,1.571d-18,&
        1.801d-18,2.039d-18,1.606d-18,1.621d-18,1.639d-18,6.794d-19,&
        7.834d-19,8.991d-19,8.765d-19,9.959d-19,1.167d-18/)

      cmg(:,9) = (/5.146d-18,7.844d-18,1.132d-17,6.177d-19,8.563d-19,1.069d-18,&
        1.290d-18,9.045d-19,1.065d-18,1.363d-18,1.781d-18,1.736d-18,&
        2.033d-18,2.346d-18,2.345d-18,2.915d-18,3.636d-18,2.769d-18,&
        3.177d-18,3.597d-18,2.868d-18,2.895d-18,2.928d-18,1.309d-18,&
        1.512d-18,1.738d-18,1.698d-18,1.932d-18,2.265d-18/)

		if (lambda_in < lambda(1) .or. lambda_in > lambda(29)) then
			result = 0.d0
		else
			ix = minloc(abs(lambda_in-lambda))
			iy = nint((T-temin) / testep) + 1
			if (T <= temin) then
				iy = 1
			endif
			if (T >= temax) then
				iy = 9
			endif
			result = cmg(ix(1),iy)
			temper = T
			Pelec = Pe
			call partition_atomic_mg(temper, u1, u2, u3)
			call get_ionpot_abundance_mg(ionization_pot1, ionization_pot2, abundance)
			n1overn0 = saha(temper, Pelec, u1, u2, ionization_pot1)
			n2overn1 = saha(temper, Pelec, u2, u3, ionization_pot2)
			n0overn = 1.d0 / (1.d0 + n1overn0 + n2overn1 * n1overn0)
			result = result * abundance * n0overn(1)
		endif

		magnesium = result

	end function magnesium

!-----------------------------------------------------------------
! Calculates the background opacity due to various species
! INPUT :
!	T : temperature in K
!	Pe : electron pressure
!	PH, PH2 : hydrogen and H2 partial pressures in dyn*cm^-2
!	lambda_in : wavelength in A
! OUTPUT :
!  Background opacity in cm^-1 including the following contributions:
!   H- free-free
!   H- bound-free
!   H bound-free + free-free
!   Thomson scattering
!   Rayleign scattering by H and H2
!   Mg bound-free + free-free
!-----------------------------------------------------------------
	function background_opacity(T, Pe, PH, PHminus, PHplus, PH2, PH2plus, lambda_in)
	real(kind=8) :: background_opacity, T, Pe, PH, PHminus, PHplus, PH2, PH2plus, lambda_in
	real(kind=8) :: factor, H_per_volume
	real(kind=8) :: contrib1, contrib2, contrib3, contrib4, contrib5, contrib6, contrib7, caca

		factor = 1.d0 + (PHminus + PHplus + 2.d0*(PH2+PH2plus)) / PH

		contrib1 = hminus_ff(T, Pe, lambda_in)
		contrib2 = hminus_bf(T, Pe, lambda_in)
		contrib3 = hydrogen(T, lambda_in)
		contrib4 = thomson(Pe, PH)
		contrib5 = rayleigh_h(lambda_in)
 		contrib6 = rayleigh_h2(PH, PH2, lambda_in)

! Magnesium opacity is per total H atom. For this reason, we multiply by factor
! because nH*factor=nH_tot
		contrib7 = magnesium(T, Pe, lambda_in) * factor

		background_opacity = PH / (PK*T) * &
			(contrib1 + contrib2 + contrib3 + contrib4 + contrib5 + contrib6 + contrib7)

	end function background_opacity

end module background_opacity_mod


      SUBROUTINE newton_co( np, x, y, a )
*
* Newton interpolation
*
*   Reference: Cheney and Kincaid, Numerical Mathematics and
*              Computing, 1980, Brooks/Cole Publishing Company
*              Monterey, California. */
*
*
      INTEGER np
      REAL x(*), y(*), a(*)
*
      INTEGER i, j
*
      DO i = 1, np
         a(i) = y(i)
      ENDDO
*
      DO j=1, np-1
         DO i=np,j+1,-1
            a(i) = (a(i) - a(i-1)) / (x(i) - x(i-j))
         ENDDO
      ENDDO
      RETURN
      END


program arrays
    implicit none
    integer :: i
    real, dimension(3) :: vector1, vector2

    vector1 = [ 3.0, 5.0, 7.0 ]
    vector2 = [ (0.5*i - 1.0, i=1, 3) ]
    print *, vector1
    print *, vector2
    print *, vector1 + vector2
    print *, vector1*vector2
    print *, dot_product(vector1, vector2)
    print *, size(vector1)
    print *, sum(vector1)
end program arrays


PROGRAM F026

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER (LEN=2000) :: BASE_NUMBER
    CHARACTER (LEN=8)    :: BASE_SUB_NUMBER

    CHARACTER (LEN=:), ALLOCATABLE :: TEMP_SUB_STR_001, TEMP_SUB_STR_002
    CHARACTER (LEN=:), ALLOCATABLE :: TEMP_SUB_STR_01,  TEMP_SUB_STR_02

    INTEGER :: I_MAX = 0
    INTEGER :: N     = 80

    INTEGER :: I, J, CARRY_VAL, FIND_LENGTH, QUOTIENT

    TEMP_SUB_STR_01  = ""
    TEMP_SUB_STR_02  = ""
    TEMP_SUB_STR_001 = ""
    TEMP_SUB_STR_002 = ""

    DO I = 11, 999

        IF (MOD(I, 2) == 0) CYCLE
        IF (MOD(I, 5) == 0) CYCLE
        IF (MOD(I, 7) == 0) CYCLE

        BASE_NUMBER = REPEAT("0", 2000);
        BASE_NUMBER(1:1) = '1';

        CARRY_VAL = 0
        DO J = 1, 2000, 5

            BASE_SUB_NUMBER = ACHAR(0)
            WRITE (BASE_SUB_NUMBER, '(I0.3)') CARRY_VAL
            BASE_SUB_NUMBER(4:8) = BASE_NUMBER(J:J+4)
            READ (BASE_SUB_NUMBER, *) QUOTIENT
            CARRY_VAL = MOD(QUOTIENT, I)
            QUOTIENT  = FLOOR (FLOAT(QUOTIENT) / FLOAT(I))

            WRITE (BASE_SUB_NUMBER, '(I0.5)') QUOTIENT
            BASE_NUMBER(J:J+4) = BASE_SUB_NUMBER(1:5)

        END DO

        J = 1
        DO WHILE (BASE_NUMBER(J:J) == '0')
            J = J + 1
        END DO

        FIND_LENGTH = N;

        DO WHILE (J <= (2001 - FIND_LENGTH))

            DEALLOCATE(TEMP_SUB_STR_001)
            ALLOCATE(CHARACTER (LEN=FIND_LENGTH) :: TEMP_SUB_STR_001)
            TEMP_SUB_STR_001 = BASE_NUMBER(J:J+FIND_LENGTH-1)

            DEALLOCATE(TEMP_SUB_STR_002)
            ALLOCATE(CHARACTER (LEN=(2001-FIND_LENGTH-J)) :: TEMP_SUB_STR_002)
            TEMP_SUB_STR_002 = BASE_NUMBER(J+FIND_LENGTH:2000)

            IF (INDEX(TEMP_SUB_STR_002, TEMP_SUB_STR_001) /= 0) THEN

                DEALLOCATE(TEMP_SUB_STR_01)
                ALLOCATE(CHARACTER (LEN=10) :: TEMP_SUB_STR_01)
                TEMP_SUB_STR_01 = TEMP_SUB_STR_001(1:10)

                DEALLOCATE(TEMP_SUB_STR_02)
                ALLOCATE(CHARACTER (LEN=(FIND_LENGTH-10)) :: TEMP_SUB_STR_02)
                TEMP_SUB_STR_02 = TEMP_SUB_STR_001(11:FIND_LENGTH)

                IF (INDEX(TEMP_SUB_STR_02, TEMP_SUB_STR_01) == 0) THEN

                    N = FIND_LENGTH
                    FIND_LENGTH = FIND_LENGTH + 1

                    IF (TEMP_SUB_STR_002(INDEX(TEMP_SUB_STR_002, TEMP_SUB_STR_001):) == TEMP_SUB_STR_002) THEN
                        I_MAX = I
                        EXIT
                    ELSE
                        CYCLE
                    END IF

                END IF

            END IF

            J = J + 1

        END DO

    END DO

    PRINT ('(I0)'), I_MAX

END PROGRAM F026


subroutine spline(x,y,n,yp1,ypn,y2)
!
implicit none
!
! PARAMETER definitions
!
integer,parameter :: nmax = 100
!
! Dummy arguments
!
integer :: n
real :: yp1,ypn
real,dimension(n) :: x,y,y2
!
! Local variables
!
integer :: i,k
real :: p,qn,sig,un
real,dimension(nmax) :: u
!
! + + + argument definitions + + +
!     n -
!     x -
!     y -
!     y2 -
!     yp1 -
!     ypn -

!     + + + parameter definitions + + +
!     nmax -

! + + + local variables

!     + + + local variable definitions + + +
!     i - loop control variable
!     k - loop control variable
!     p -
!     qn -
!     sig -
!     u -
!     un -

if (yp1>.99E30) then
  y2(1) = 0.
  u(1) = 0.
else
  y2(1) = -0.5
  u(1) = (3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
end if
do i = 2,n - 1
  sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
  p = sig*y2(i-1) + 2.
  y2(i) = (sig-1.)/p
  u(i) = (6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))          &
       & /(x(i+1)-x(i-1))-sig*u(i-1))/p
end do
if (ypn>.99E30) then
  qn = 0.
  un = 0.
else
  qn = 0.5
  un = (3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
end if
y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.)
do k = n - 1,1, - 1
  y2(k) = y2(k)*y2(k+1) + u(k)
end do
!       debug lines. remove after debugging.
!        do i=1,n
!                write(56,*)x(i),y(i),y2(i)
!        end do
!
end subroutine spline