MODULE korc_velocity_distribution
  !! @note Module containing subroutines to initialize the velocity
  !! distribution of the simulated particles. @endnote
  USE korc_types
  USE korc_constants
  USE korc_HDF5
  USE korc_hpc
  use korc_fields
  use korc_rnd_numbers
  use korc_hammersley_generator

  use korc_avalanche
  use korc_experimental_pdf
  use korc_energy_pdfs
  use korc_simple_equilibrium_pdf

  IMPLICIT NONE

  PUBLIC :: initial_gyro_distribution,&
       thermal_distribution,&
       initial_energy_pitch_dist
  PRIVATE :: fth_3V,&
       random_norm,&
       gyro_distribution

CONTAINS

  FUNCTION fth_3V(Vth,V)
    !! @note Function used to sample the probability density function of a
    !! thermal plasma in the 3-dimensional velocity space. @endnote
    !! This function returns \(f_{T_e}(v) = \exp{\left( v^2/2v_{T_e}^2 \right)}\),
    !! where \(v_{T_e} = \sqrt{T_e/m_e}\) is
    !! the temperature of the thermal electrons, and \(v = |\mathbf{v}|\)
    !! is the speed of the sampled electron.
    REAL(rp), DIMENSION(3), INTENT(IN) 	:: V
    !! Velocity of the sampled electron \(\mathbf{v}\).
    REAL(rp), INTENT(IN) 			:: Vth
    !! Thermal velocity of the background electrons \(v_{T_e}\).
    REAL(rp) 				:: fth_3V
    !! Value of \(f_{T_e}(v)\).

    fth_3V = EXP(-0.5_rp*DOT_PRODUCT(V,V)/Vth**2.0_rp)
  END FUNCTION fth_3V

  FUNCTION random_norm(mu,sigma)
    !! @note Gaussian random number generator. @endnote
    !! This function returns a deviate of a Gaussian distribution
    !! $$f_G(x;\mu,\sigma) =
    !! \frac{1}{\sigma\sqrt{2\pi}} \exp{\left( -(x-\mu)^2/2\sigma^2 \right)},$$
    !!
    !! with mean \(\mu\), and standard deviation \(\sigma\).
    !!
    !! We use the Inverse Transform Sampling Method for sampling \(x\).
    !! With this method we get \(x = \sqrt{-2\log{(1-y)}}\cos(2\pi z)\),
    !! where \(y\) and \(z\) are uniform random numbers in the interval \([0,1]\).
    REAL(rp), INTENT(IN) 	:: mu
    !! Mean value \(\mu\) of the Gaussian distribution.
    REAL(rp), INTENT(IN) 	:: sigma
    !! Standard deviation \(\sigma\) of the Gaussian distribution.
    REAL(rp) 				:: random_norm
    !! Sampled number \(x\) from the Gaussian distribution \(f_G(x;\mu,\sigma)\).
    REAL(rp) 				:: rand1
    !! Uniform random number in the interval \([0,1]\).
    REAL(rp) 				:: rand2
    !! Uniform random number in the interval \([0,1]\).

    call RANDOM_NUMBER(rand1)
    call RANDOM_NUMBER(rand2)

    random_norm = SQRT(-2.0_rp*LOG(1.0_rp-rand1))*COS(2.0_rp*C_PI*rand2);
  END FUNCTION random_norm

  subroutine thermal_distribution(params,spp)
    !! @note Subroutine that samples a thermal distribution function
    !! of electrons for generating the initial condition of a set of
    !! simulated particles. @endnote
    !! This subroutine uses the Inverse Transform Sampling Method along
    !! with the  Metropolis-Hastings algorithm to generate an
    !! initial condition of the velocity distribution that follows a
    !! 3-dimensional (in velocity space) thermal distribution.
    !! @todo Check that the gyro-distribution is initialized right in
    !! this function.
    TYPE(KORC_PARAMS), INTENT(IN) 	:: params
    !! Core KORC simulation parameters.
    TYPE(SPECIES), INTENT(INOUT) 	:: spp
    !! An instance of the derived type SPECIES containing all the
    !! parameters and simulation variables of the different species
    !! in the simulation.
    REAL(rp) 				:: Vmax
    !! Velocity cutoff where we stop sampling the tail of the thermal
    !! distribution.
    REAL(rp) 				:: vsq
    !!
    REAL(rp) 				:: Vth
    !! Thermal velocity of the sampled distribution \(v_{T_e} =
    !! \sqrt{T_e/m_e}\).
    REAL(rp) 				:: sv
    !! Step to sample the velocity space using the Metropolis-Hastings
    !! algorithm.
    REAL(rp) 				:: ratio
    !! Ratio used to accept or reject a sampling in the Metropolis-Hastings
    !! algorithm.
    REAL(rp) 				:: rand_unif
    !! Uniform random deviate in the interval  \([0,1]\).
    REAL(rp), DIMENSION(3) 		:: V
    !! Sampled velocity.
    REAL(rp), DIMENSION(3) 		:: U
    !! Sampled velocity.
    REAL(rp), DIMENSION(3) 		:: b = (/1.0_rp,0.0_rp,0.0_rp/)
    !! Temporary variable representing a unit vector along the \(x\)-axis.
    INTEGER 				:: ii
    !! Iterator.
    INTEGER 				:: ppp
    !! Number of particles per species.

    Vmax = 0.9_rp
    Vth = SQRT(spp%Eo*ABS(spp%q)/spp%m)
    ppp = spp%ppp

    V = (/0.0_rp,0.0_rp,0.0_rp/)
    sv = Vth/10.0_rp

    ii=2_idef
    do while (ii .LE. 1000_idef)
       U(1) = V(1) + random_norm(0.0_rp,sv)
       do while (ABS(U(1)) .GT. Vmax)
          U(1) = V(1) + random_norm(0.0_rp,sv)
       end do

       U(2) = V(2) + random_norm(0.0_rp,sv)
       do while (ABS(U(2)) .GT. Vmax)
          U(2) = V(2) + random_norm(0.0_rp,sv)
       end do

       U(3) = V(3) + random_norm(0.0_rp,sv)
       do while (ABS(U(3)) .GT. Vmax)
          U(3) = V(3) + random_norm(0.0_rp,sv)
       end do

       ratio = fth_3V(Vth,U)/fth_3V(Vth,V)

       if (ratio .GE. 1.0_rp) then
          V = U
          ii = ii + 1_idef
       else
          call RANDOM_NUMBER(rand_unif)
          if (ratio .GT. rand_unif) then
             V = U
             ii = ii + 1_idef
          end if
       end if
    end do

    spp%vars%V(1,1) = V(1)
    spp%vars%V(1,2) = V(2)
    spp%vars%V(1,3) = V(3)
    ii=2_idef
    do while (ii .LE. ppp)
       U(1) = spp%vars%V(ii-1,1) + random_norm(0.0_rp,sv)
       do while (ABS(U(1)) .GT. Vmax)
          U(1) = spp%vars%V(ii-1,1) + random_norm(0.0_rp,sv)
       end do
       U(2) = spp%vars%V(ii-1,2) + random_norm(0.0_rp,sv)
       do while (ABS(U(2)) .GT. Vmax)
          U(2) = spp%vars%V(ii-1,2) + random_norm(0.0_rp,sv)
       end do
       U(3) = spp%vars%V(ii-1,3) + random_norm(0.0_rp,sv)
       do while (ABS(U(3)) .GT. Vmax)
          U(3) = spp%vars%V(ii-1,3) + random_norm(0.0_rp,sv)
       end do

       ratio = fth_3V(Vth,U)/fth_3V(Vth,spp%vars%V(ii-1,:))

       if (ratio .GE. 1.0_rp) then
          spp%vars%V(ii,1) = U(1)
          spp%vars%V(ii,2) = U(2)
          spp%vars%V(ii,3) = U(3)
          ii = ii + 1_idef
       else
          call RANDOM_NUMBER(rand_unif)
          if (ratio .GT. rand_unif) then
             spp%vars%V(ii,1) = U(1)
             spp%vars%V(ii,2) = U(2)
             spp%vars%V(ii,3) = U(3)
             ii = ii + 1_idef
          end if
       end if
    end do

    do ii=1_idef,ppp
       vsq = spp%vars%V(ii,1)*spp%vars%V(ii,1)             &
            + spp%vars%V(ii,2)*spp%vars%V(ii,2)             &
            + spp%vars%V(ii,3)*spp%vars%V(ii,3)
       spp%vars%g(ii) = 1.0_rp/SQRT(1.0_rp - vsq)
       spp%vars%eta(ii) = ACOS(spp%vars%V(ii,1)/SQRT(vsq))
    end do

    spp%go = spp%Eo/(spp%m*C_C**2)
    spp%etao = 90.0_rp
  end subroutine thermal_distribution

  subroutine initial_energy_pitch_dist(params,spp)
    !! @note Subroutine that calls subroutines of different modules to
    !! initialize the energy and pitch-angle distribution in various ways. @endnote
    TYPE(KORC_PARAMS), INTENT(IN) 				:: params
    !! Core KORC simulation parameters.
    TYPE(SPECIES), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)       :: spp
    !! An instance of the derived type SPECIES containing all the parameters and
    !! simulation variables of the different species in the simulation.
    INTEGER 							:: ii
    !! Species iterator.
    INTEGER 							:: mpierr
    !! MPI error status.

    do ii=1_idef,params%num_species

       if (params%mpi_params%rank .EQ. 0) then
          write(output_unit_write,'(/,"* * * * * SPECIES: ",I2," * * * * * * * * * * *")') ii
          write(output_unit_write,'("Particles per MPI process: ",I16)') spp(ii)%ppp
          write(output_unit_write,'("Energy distribution is: ",A20)') &
               TRIM(spp(ii)%energy_distribution)
          write(output_unit_write,'("Pitch-angle distribution is: ",A20)') &
               TRIM(spp(ii)%pitch_distribution)
          write(output_unit_write,'("Spatial distribution is: ",A20)') &
               TRIM(spp(ii)%spatial_distribution)
          write(output_unit_write,'("* * * * * * * * * * * * * * * * * * * * * *",/)')
       end if

       SELECT CASE (TRIM(spp(ii)%energy_distribution))
       CASE ('MONOENERGETIC')
          spp(ii)%go = (spp(ii)%Eo + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)

          spp(ii)%vars%g = spp(ii)%go ! Monoenergetic
          spp(ii)%Eo_lims = (/spp(ii)%Eo, spp(ii)%Eo /)

       CASE ('THERMAL')
          call thermal_distribution(params,spp(ii))

          spp(ii)%Eo_lims = (/spp(ii)%m*C_C**2*MINVAL(spp(ii)%vars%g) - &
               spp(ii)%m*C_C**2, &
               spp(ii)%m*C_C**2*MAXVAL(spp(ii)%vars%g) - spp(ii)%m*C_C**2 /)
       CASE ('AVALANCHE')
          call get_avalanche_distribution(params,spp(ii)%vars%g, &
               spp(ii)%vars%eta,spp(ii)%go,spp(ii)%etao)
          spp(ii)%Eo = spp(ii)%m*C_C**2*spp(ii)%go - spp(ii)%m*C_C**2
          spp(ii)%Eo_lims = (/spp(ii)%m*C_C**2*MINVAL(spp(ii)%vars%g) &
               - spp(ii)%m*C_C**2, &
               spp(ii)%m*C_C**2*MAXVAL(spp(ii)%vars%g) - spp(ii)%m*C_C**2 /)
       CASE ('HOLLMANN')
          call get_Hollmann_distribution(params,spp(ii))
!          spp(ii)%Eo = spp(ii)%m*C_C**2*spp(ii)%go - spp(ii)%m*C_C**2
          spp(ii)%go = (spp(ii)%Eo + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)
          spp(ii)%Eo_lims = (/spp(ii)%m*C_C**2*MINVAL(spp(ii)%vars%g) &
               - spp(ii)%m*C_C**2, &
               spp(ii)%m*C_C**2*MAXVAL(spp(ii)%vars%g) - spp(ii)%m*C_C**2 /)
       CASE ('EXPERIMENTAL-GAMMA')
          call get_experimentalG_distribution(params,spp(ii)%vars%g, &
               spp(ii)%vars%eta, &
               spp(ii)%go,spp(ii)%etao)
          spp(ii)%Eo = spp(ii)%m*C_C**2*spp(ii)%go - spp(ii)%m*C_C**2
          spp(ii)%Eo_lims = (/spp(ii)%m*C_C**2*MINVAL(spp(ii)%vars%g) &
               - spp(ii)%m*C_C**2, &
               spp(ii)%m*C_C**2*MAXVAL(spp(ii)%vars%g) - spp(ii)%m*C_C**2 /)
       CASE ('GAMMA')
          call get_gamma_distribution(params,spp(ii)%vars%g,spp(ii)%go)

          spp(ii)%Eo = spp(ii)%m*C_C**2*spp(ii)%go - spp(ii)%m*C_C**2
          spp(ii)%Eo_lims = (/spp(ii)%m*C_C**2*MINVAL(spp(ii)%vars%g) &
               - spp(ii)%m*C_C**2, &
               spp(ii)%m*C_C**2*MAXVAL(spp(ii)%vars%g) - spp(ii)%m*C_C**2 /)
       CASE ('UNIFORM')
          spp(ii)%Eo = spp(ii)%Eo_lims(1)
          spp(ii)%go = (spp(ii)%Eo + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)

          call generate_2D_hammersley_sequence(params%mpi_params%rank, &
               params%mpi_params%nmpi,spp(ii)%vars%g,spp(ii)%vars%eta)

          spp(ii)%vars%g = (spp(ii)%Eo_lims(2) - &
               spp(ii)%Eo_lims(1))*spp(ii)%vars%g/(spp(ii)%m*C_C**2) + &
               (spp(ii)%Eo_lims(1) + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)
       CASE ('AVALANCHE-4D')
          spp(ii)%go = (spp(ii)%Eo + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)
          spp(ii)%vars%g = spp(ii)%go
          ! Monoenergy from input file until sampled in Avalanche_4D
       CASE ('HOLLMANN-3D')
          spp(ii)%go = (spp(ii)%Eo + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)
          spp(ii)%vars%g = spp(ii)%go
          ! Monoenergy from input file until sampled in Hollmann_3D
       CASE ('HOLLMANN-3D-PSI')
          spp(ii)%go = (spp(ii)%Eo + spp(ii)%m*C_C**2)/(spp(ii)%m*C_C**2)
          spp(ii)%vars%g = spp(ii)%go
          ! Monoenergy from input file until sampled in Hollmann_3D
       CASE DEFAULT
          ! Something to be done
       END SELECT

       call MPI_BARRIER(MPI_COMM_WORLD,mpierr)

       SELECT CASE (TRIM(spp(ii)%pitch_distribution))
       CASE ('MONOPITCH')
          spp(ii)%vars%eta = spp(ii)%etao ! Mono-pitch-angle

          if(spp(ii)%spatial_distribution.ne.'SPONG-3D') then
             spp(ii)%etao_lims = (/spp(ii)%etao , spp(ii)%etao/)
          end if

       CASE ('THERMAL')
          spp(ii)%etao_lims = (/MINVAL(spp(ii)%vars%eta), &
               MAXVAL(spp(ii)%vars%eta)/)
       CASE ('AVALANCHE')
          spp(ii)%etao_lims = (/MINVAL(spp(ii)%vars%eta), &
               MAXVAL(spp(ii)%vars%eta)/)
       CASE ('HOLLMANN')
!          spp(ii)%vars%eta = spp(ii)%etao
!          spp(ii)%etao_lims = (/MINVAL(spp(ii)%vars%eta), &
!               MAXVAL(spp(ii)%vars%eta)/)
       CASE ('EXPERIMENTAL-GAMMA')
          spp(ii)%etao_lims = (/MINVAL(spp(ii)%vars%eta), &
               MAXVAL(spp(ii)%vars%eta)/)
       CASE ('UNIFORM')
          spp(ii)%etao = spp(ii)%etao_lims(1)

          spp(ii)%vars%eta = (spp(ii)%etao_lims(2) - &
               spp(ii)%etao_lims(1))*spp(ii)%vars%eta + spp(ii)%etao_lims(1)
       CASE ('SIMPLE-EQUILIBRIUM')
          call get_equilibrium_distribution(params,spp(ii)%vars%eta, &
               spp(ii)%go,spp(ii)%etao)

          spp(ii)%etao_lims = (/MINVAL(spp(ii)%vars%eta),&
               MAXVAL(spp(ii)%vars%eta)/)
       CASE ('AVALANCHE-4D')
          spp(ii)%vars%eta = spp(ii)%etao
          !Monopitch from input file until sampled in Avalanche_4D
       CASE ('HOLLMANN-3D')
          spp(ii)%vars%eta = spp(ii)%etao
          !Monopitch from input file until sampled in Hollmann_3D
       CASE ('HOLLMANN-3D-PSI')
          spp(ii)%vars%eta = spp(ii)%etao
          !Monopitch from input file until sampled in Hollmann_3D
       CASE ('SPONG-3D')
          spp(ii)%vars%eta = spp(ii)%etao
          !Monopitch from input file until sampled in Spong_3D
       CASE DEFAULT
          ! Something to be done
       END SELECT

       call MPI_BARRIER(MPI_COMM_WORLD,mpierr)
    end do
  end subroutine initial_energy_pitch_dist

  subroutine gyro_distribution(params,F,spp)
    !! @Note Subroutine that initializes the gyro-angle distribution
    !! of the particles. @endnote
    !! When evolving the particles in the 6-D phase space, in addition to
    !! the position (3 degrees of freedom), energy (one degree of freedom),
    !! pitch angle (one degree of freedom), we need to define the gyro-angle
    !! of the particle (one degree of freedom), which is given by the pitch
    !! angle and the direction of the local magnetic field. By default, this
    !! subroutine generates a uniform gyro-angle distribution.
    !! @note Notice that all the simulation variables are normalized
    !! here. @endnote
    TYPE(KORC_PARAMS), INTENT(IN) 	:: params
    !! Core KORC simulation parameters.
    TYPE(FIELDS), INTENT(IN) 		:: F
    !! An instance of the KORC derived type FIELDS. This structure
    !! has the information of the magnetic field.
    TYPE(SPECIES), INTENT(INOUT) 		:: spp
    !! An instance of the derived type SPECIES containing all the
    !! parameters and
    !! simulation variables of the different species in the simulation.
    REAL(rp), DIMENSION(:,:), ALLOCATABLE	:: b1
    !! Basis vector pointing along the local magnetic field, that is,
    !!  along \(\mathbf{b} = \mathbf{B}/B\).
    REAL(rp), DIMENSION(:,:), ALLOCATABLE	:: b2
    !! Basis vector perpendicular to b1
    REAL(rp), DIMENSION(:,:), ALLOCATABLE	:: b3
    !! Basis vector perpendicular to b1 and b2.
    REAL(rp), DIMENSION(:), ALLOCATABLE 	:: Vo
    !! Initial particle speed.
    REAL(rp), DIMENSION(:), ALLOCATABLE 	:: V1
    !!  Velocity component along b1.
    REAL(rp), DIMENSION(:), ALLOCATABLE 	:: V2
    !! Velocity component along b2.
    REAL(rp), DIMENSION(:), ALLOCATABLE 	:: V3
    !! Velocity component along b3.
    REAL(rp), DIMENSION(:), ALLOCATABLE 	:: theta
    !! Uniform random number in the interval \([0,2\pi]\)
    !! representing the gyro-angle.
    INTEGER 				:: jj
    !! Particle iterator.

    ALLOCATE(Vo(spp%ppp))
    ALLOCATE(V1(spp%ppp))
    ALLOCATE(V2(spp%ppp))
    ALLOCATE(V3(spp%ppp))
    ALLOCATE(b1(spp%ppp,3))
    ALLOCATE(b2(spp%ppp,3))
    ALLOCATE(b3(spp%ppp,3))

    ALLOCATE( theta(spp%ppp) )

    ! * * * * INITIALIZE VELOCITY * * * *

    call init_random_seed()
    call RANDOM_NUMBER(theta)
    theta = 2.0_rp*C_PI*theta

    if (spp%spatial_distribution.eq.'TRACER') theta=2.0*C_PI

    Vo = SQRT( 1.0_rp - 1.0_rp/(spp%vars%g(:)**2) )
    V1 = Vo*COS(C_PI*spp%vars%eta/180.0_rp)
    V2 = Vo*SIN(C_PI*spp%vars%eta/180.0_rp)*COS(theta)
    V3 = Vo*SIN(C_PI*spp%vars%eta/180.0_rp)*SIN(theta)

    call unitVectors(params,spp%vars%X,F,b1,b2,b3,spp%vars%flagCon, &
         spp%vars%cart,spp%vars%hint)
    !! Call to subroutine [[unitVectors]] in [[korc_fields]].

    !write(output_unit_write,*) 'X',spp%vars%X
    !write(output_unit_write,*) 'b-hat',b1

    do jj=1_idef,spp%ppp
       if ( spp%vars%flagCon(jj) .EQ. 1_idef ) then
          spp%vars%V(jj,1) = V1(jj)*b1(jj,1) + V2(jj)*b2(jj,1) + V3(jj)*b3(jj,1)
          spp%vars%V(jj,2) = V1(jj)*b1(jj,2) + V2(jj)*b2(jj,2) + V3(jj)*b3(jj,2)
          spp%vars%V(jj,3) = V1(jj)*b1(jj,3) + V2(jj)*b2(jj,3) + V3(jj)*b3(jj,3)
       end if
    end do

!    write(output_unit_write,'("Vx: ",E17.10)') spp%vars%V(:,1)
!    write(output_unit_write,'("Vy: ",E17.10)') spp%vars%V(:,2)
!    write(output_unit_write,'("Vz: ",E17.10)') spp%vars%V(:,3)

    DEALLOCATE(theta)
    DEALLOCATE(Vo)
    DEALLOCATE(V1)
    DEALLOCATE(V2)
    DEALLOCATE(V3)
    DEALLOCATE(b1)
    DEALLOCATE(b2)
    DEALLOCATE(b3)
  end subroutine gyro_distribution

  subroutine initial_gyro_distribution(params,F,spp)
    !! @note Subroutine that works as an interface for initializing various
    !! gyro-angle distributions for the different simulated particle
    !! species. @endnote
    !! @todo At this moment this subroutine only calls the subroutine
    !! to generate
    !! a uniform gyro-angle distribution. This will be modified later. @endtodo
    TYPE(KORC_PARAMS), INTENT(IN) 				:: params
    !! Core KORC simulation parameters.
    TYPE(FIELDS), INTENT(IN) 					:: F
    !! An instance of the KORC derived type FIELDS. This structure has
    !! the information of the magnetic field.
    TYPE(SPECIES), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)     :: spp
    !! An instance of the derived type SPECIES containing all the parameters
    !! and simulation variables of the different species in the simulation.
    INTEGER 							:: ss
    !! Species iterator.

    do ss=1_idef,params%num_species
       SELECT CASE (TRIM(spp(ss)%energy_distribution))
       CASE ('THERMAL')
          !Nothing, all was done in initialize_particles through
          !thermal_distribution
       CASE DEFAULT
          call gyro_distribution(params,F,spp(ss))
       END SELECT
    end do
  end subroutine initial_gyro_distribution

END MODULE korc_velocity_distribution


      REAL             FUNCTION SSI (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 SSI Krogh  Moved external statement up for mangle.
C>> 1995-11-03 SSI Krogh  Removed blanks in numbers for C conversion.
C>> 1994-11-11 SSI Krogh  Declared all vars.
c>> 1994-10-20 SSI Krogh  Changes to use M77CON
c>> 1989-03-14 SSI Original W. V. Snyder at JPL
C
C     COMPUTE THE SINE INTEGRAL OF X =
C     INTEGRAL FROM 0 TO X OF (SIN(T)/T DT).
C
C     FOR ABS(X)<16, USE A CHEBYSHEV SERIES WITH ARGUMENT 2*Z*Z-1 WHERE
C     Z=X/16 TO EVALUATE SI(X)/Z, THEN MULTIPLY THE RESULT BY Z.  THIS
C     AVOIDS STORING ZERO COEFFICIENTS FOR EVEN ORDERS, AND PRESERVES
C     ACCURACY FOR SMALL Z.
C
C     FOR 16.LE.ABS(X).LE.100, USE CHEBYCHEV SERIES WITH ARGUMENT
C     2*Z*Z-1, WHERE Z=16/X ARE USED TO COMPUTE F(X)/X AND G(X)/(X*X).
C     THEN SI(X)=0.5*PI*SIGN(X)-F(X)/X*COS(X)-G(X)/(X*X)*SIN(X).
C
C     WHEN X.GT.100, USE ASYMPTOTIC APPROXIMATIONS FOR F(X)/X AND
C     G(X)/(X*X) AND COMPUTE SI(X) AS ABOVE.
C
C     THIS ALGORITHM YIELDS AT MOST 15 DIGITS OF PRECISION.
C
C--S replaces "?": ?SI, ?CPVAL
C
      INTEGER N
      REAL             X
      EXTERNAL SCPVAL
      REAL             PI2,Z,ZW,FZ,GZ,SCPVAL
      REAL             FT,GT
      REAL             S(23),F(13),G(13)
      DATA PI2/1.57079632679489662E0/
      DATA S/
     * + 0.5E0,                 + 0.5E0,
     1 + 4.052926477680623E0, - 4.063980844911986E0,
     2 + 2.778756381742663E0, - 1.926565091150656E0,
     3 + 1.389308771171888E0, - 0.968322236987086E0,
     4 + 0.530148847916522E0, - 0.211263780976555E0,
     5 + 0.062033679432003E0, - 0.013867445589417E0,
     6 + 0.002436221404749E0, - 0.000345469155569E0,
     7 + 0.000040420271419E0, - 0.000003972908746E0,
     8 + 0.000000332988589E0, - 0.000000024100076E0,
     9 + 0.000000001522370E0, - 0.000000000084710E0,
     A + 0.000000000004185E0, - 0.000000000000185E0,
     B + 0.000000000000007E0/
      DATA F/
     * + 0.5E0,                 + 0.5E0,
     1 + 0.062263729028927E0, - 0.000233756041393E0,
     2 + 0.000002453755677E0, - 0.000000058670317E0,
     3 + 0.000000002356196E0, - 0.000000000136096E0,
     4 + 0.000000000010308E0, - 0.000000000000964E0,
     5 + 0.000000000000107E0, - 0.000000000000014E0,
     6 + 0.000000000000002E0/
      DATA G/
     * + 0.5E0,                 + 0.5E0,
     1 + 0.003862856096703E0, - 0.000042644182622E0,
     2 + 0.000000724995950E0, - 0.000000023468225E0,
     3 + 0.000000001169202E0, - 0.000000000079604E0,
     4 + 0.000000000006875E0, - 0.000000000000717E0,
     5 + 0.000000000000087E0, - 0.000000000000012E0,
     6 + 0.000000000000002E0/
C
      IF (ABS(X).LT.16.0) THEN
         Z = X/16.0
         ZW = Z*Z
         Z = Z*SCPVAL(S,20,ZW)
      ELSE
        IF (ABS(X).LE.100.0) THEN
C           16.LE.ABS(X).LE.100
            Z = 16.0/X
            ZW = Z*Z
            FZ = Z*SCPVAL(F,10,ZW)
            GZ = ZW*SCPVAL(G,10,ZW)
        ELSE
C           ABS(X).GT.100
            FZ = 1.0/X
            FT = FZ
            GZ = FZ/X
            GT = GZ
            Z = GZ
            DO 25 N = 2, 16, 2
               FT = -REAL(N*(N-1))*Z*FT
               GT = -REAL(N*(N+1))*Z*GT
               FZ = FZ + FT
               GZ = GZ + GT
25          CONTINUE
         END IF
         Z = SIGN(PI2,X) - FZ*COS(X) - GZ*SIN(X)
      END IF
C
      SSI = Z
      RETURN
      END


      SUBROUTINE iau_HD2AE ( HA, DEC, PHI, AZ, EL )
*+
*  - - - - - - - - - -
*   i a u _ H D 2 A E
*  - - - - - - - - - -
*
*  Equatorial to horizon coordinates:  transform hour angle and
*  declination to azimuth and altitude.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     HA       d     hour angle (local)
*     DEC      d     declination
*     PHI      d     site latitude
*
*  Returned:
*     AZ       d     azimuth
*     EL       d     altitude (informally, elevation)
*
*  Notes:
*
*  1)  All the arguments are angles in radians.
*
*  2)  Azimuth is returned in the range 0-2pi;  north is zero, and east
*      is +pi/2.  Altitude is returned in the range +/- pi/2.
*
*  3)  The latitude PHI is pi/2 minus the angle between the Earth's
*      rotation axis and the adopted zenith.  In many applications it
*      will be sufficient to use the published geodetic latitude of the
*      site.  In very precise (sub-arcsecond) applications, PHI can be
*      corrected for polar motion.
*
*  4)  The returned azimuth AZ is with respect to the rotational north
*      pole, as opposed to the ITRS pole, and for sub-arcsecond accuracy
*      will need to be adjusted for polar motion if it is to be with
*      respect to north on a map of the Earth's surface.
*
*  5)  Should the user wish to work with respect to the astronomical
*      zenith rather than the geodetic zenith, PHI will need to be
*      adjusted for deflection of the vertical (often tens of
*      arcseconds), and the zero point of HA will also be affected.
*
*  6)  The transformation is the same as Vh = Rz(pi)*Ry(pi/2-phi)*Ve,
*      where Vh and Ve are lefthanded unit vectors in the (az,el) and
*      (ha,dec) systems respectively and Ry and Rz are rotations about
*      first the y-axis and then the z-axis.  (n.b. Rz(pi) simply
*      reverses the signs of the x and y components.)  For efficiency,
*      the algorithm is written out rather than calling other utility
*      functions.  For applications that require even greater
*      efficiency, additional savings are possible if constant terms
*      such as functions of latitude are computed once and for all.
*
*  7)  Again for efficiency, no range checking of arguments is carried
*      out.
*
*  Last revision:   2018 January 2
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION HA, DEC, PHI, AZ, EL

      DOUBLE PRECISION D2PI
      PARAMETER ( D2PI = 6.283185307179586476925287D0 )

      DOUBLE PRECISION SH, CH, SD, CD, SP, CP, X, Y, Z, R, A

*  Useful trig functions.
      SH = SIN(HA)
      CH = COS(HA)
      SD = SIN(DEC)
      CD = COS(DEC)
      SP = SIN(PHI)
      CP = COS(PHI)

*  Az,Alt unit vector.
      X = - CH*CD*SP + SD*CP
      Y = - SH*CD
      Z = CH*CD*CP + SD*SP

*  To spherical.
      R = SQRT(X*X + Y*Y)
      IF ( R.EQ.0D0 ) THEN
         A = 0D0
      ELSE
         A = ATAN2(Y,X)
      END IF
      IF ( A.LT.0D0 ) A = A+D2PI
      AZ = A
      EL = ATAN2(Z,R)

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


! ======================================================================
! PROGRAM FTPSD
! ----------------------------------------------------------------------
      PROGRAM FTPSD
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: NUMBER_OF_TIME_STEPS_BEFORE_WRITE
      INTEGER :: START_FILE
      INTEGER :: END_FILE

      REAL :: RADIUS
      REAL :: GAMMA_FACTOR
      REAL :: CARRIER_FREQUENCY

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_FILE
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE

      COMPLEX :: FOURIER_TRANSFORM

      REAL, ALLOCATABLE, DIMENSION(:) :: ARCLENGTH
      REAL, ALLOCATABLE, DIMENSION(:) :: DENSITY

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) START_FILE

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) END_FILE

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) TIME_STEP_SIZE

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) CARRIER_FREQUENCY

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))
      ALLOCATE(ARCLENGTH(NUMBER_OF_GRID_POINTS))
      ALLOCATE(DENSITY(NUMBER_OF_GRID_POINTS))

!     Main Program:
!     -------------
      DO CURRENT_FILE = START_FILE, END_FILE
      OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='FORMATTED',STATUS='OLD')
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            READ(CURRENT_FILE,*) ARCLENGTH(CURRENT_GRID_POINT), DENSITY(CURRENT_GRID_POINT)
         ENDDO
      CLOSE(UNIT=CURRENT_FILE,STATUS='SAVE')
      FOURIER_TRANSFORM = CMPLX(0.0E0,0.0E0)
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            FOURIER_TRANSFORM = FOURIER_TRANSFORM+CMPLX(DENSITY(CURRENT_GRID_POINT)*ANGULAR_GRID_SPACING_SIZE,0.0E0)*EXP(CMPLX(0.0E0,CARRIER_FREQUENCY*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE))
         ENDDO
         WRITE(500,*) FLOAT(CURRENT_FILE-START_FILE)*TIME_STEP_SIZE, ATAN2(AIMAG(FOURIER_TRANSFORM),REAL(FOURIER_TRANSFORM))
      ENDDO

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)
      DEALLOCATE(ARCLENGTH)
      DEALLOCATE(DENSITY)

      STOP
      ENDPROGRAM FTPSD
! ======================================================================


! $ brew install gcc
! $ gfortran -O3 -o envelopes_f08 envelopes.f08
! $ ./envelopes_f08

function single_trial(cutoff) result(value)
  ! Runs a single trial where an envelope is chosen.  If the chosen envelope has
  ! a value < cutoff, the function will switch envelopes, otherwise it will keep
  ! the envelope it has chosen. Returns the value of the envelope it ultimately
  ! selects.
  implicit none
  double precision :: cutoff, higher_value, lower_value, value
  logical          :: picked_lower

  lower_value = rand() * 100.0d+0
  higher_value = 2 * lower_value
  picked_lower = (rand() < 0.5)
  if ((picked_lower .and. lower_value >= cutoff) .or. &
      (.not. picked_lower .and. higher_value < cutoff)) then
    value = lower_value
  else
    value = higher_value
 end if
end function single_trial

function multi_trial(cutoff) result(expected_value)
  ! Runs many trials at a given cutoff to approximate the expected value.
  implicit none
  integer          :: cutoff, i, num_trials
  double precision :: cutoff64, expected_value, single_trial, total

  num_trials = 10000
  cutoff64 = dble(cutoff)
  total = 0.0d+0
  do i = 1, num_trials
    total = total + single_trial(cutoff64)
  end do
  expected_value = total / dble(num_trials)
end function multi_trial

subroutine print_result(cutoff, expected_value)
  ! Formats the results nicely and outputs them.
  implicit none
  integer            :: cutoff
  double precision   :: expected_value
  character(len=100) :: fmt

  if (cutoff < 10) then
    fmt = "(A, I1, A, F9.6)"
  else if (cutoff < 100) then
    fmt = "(A, I2, A, F9.6)"
  else
    fmt = "(A, I3, A, F9.6)"
  end if
  write (*, fmt) "cutoff=", cutoff, ", expected_value=", expected_value
end subroutine print_result

program envelopes
  ! Approximates the expected value for each integral cutoff value.
  implicit none
  integer          :: cutoff
  double precision :: multi_trial

  call random_seed()
  do cutoff = 0, 200
    call print_result(cutoff, multi_trial(cutoff))
  end do
end program envelopes


    subroutine nscore(nd,vr,tmin,tmax,iwt,wt,tmp,lout,vrg,ierror)
!-----------------------------------------------------------------------

!              Transform Univariate Data to Normal Scores
!              ******************************************

! This subroutibe takes "nd" data "vr(i),i=1,...,nd" possibly weighted
! by "wt(i),i=,...,nd" and returns the normal scores transform N(0,1)
! as "vrg(i),i=1,...,nd".  The extra storage array "tmp" is required
! so that the data can be returned in the same order (just in case
! there are associated arrays like the coordinate location).

! INPUT VARIABLES:

!   nd               Number of data (no missing values)
!   vr(nd)           Data values to be transformed
!   tmin,tmax        data trimming limits
!   iwt              =0, equal weighted; =1, then apply weight
!   wt(nd)           Weight for each data (don't have to sum to 1.0)
!   tmp(nd)          Temporary storage space for sorting
!   lout             if > 0 then transformation table will be written

! OUTPUT VARIABLES:

!   vrg(nd)          normal scores
!   ierror           error flag (0=error free,1=problem)

! EXTERNAL REFERENCES:

!   gauinv           Calculates the inverse of a Gaussian cdf
!   sortem           sorts a number of arrays according to a key array

!-----------------------------------------------------------------------
    parameter(EPSLON=1.0e-20)
    real ::      vr(nd),wt(nd),vrg(nd),tmp(nd)
    real*8 ::    pd

! Sort the data in ascending order and calculate total weight:

    ierror = 0
    twt    = 0.0
    do i=1,nd
        tmp(i) = real(i)
        if(vr(i) >= tmin .AND. vr(i) < tmax) then
            if(iwt == 0) then
                twt = twt + 1.
            else
                twt = twt + wt(i)
            end if
        end if
    end do
    if(nd < 1 .OR. twt < EPSLON) then
        ierror = 1
        return
    end if
    call sortem(1,nd,vr,2,wt,tmp,d,e,f,g,h)

! Compute the cumulative probabilities:

    oldcp = 0.0
    cp    = 0.0
    do i=1,nd
        cp     =  cp + wt(i) / twt
        wt(i)  = (cp + oldcp)/ 2.0
        oldcp  =  cp
        call gauinv(dble(wt(i)),vrg(i),ierr)
        if(lout > 0) write(lout,'(f12.5,1x,f12.5)') vr(i),vrg(i)
    end do

! Get the arrays back in original order:

    call sortem(1,nd,tmp,3,wt,vr,vrg,e,f,g,h)

! Finished:

    return
    end subroutine nscore


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 2 node
!!     line element   (Langrange  interpolation)
module shape_line2n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_line2n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(1)
    real(kind=kreal) :: func(2)
    func(1) = 0.5d0*(1.d0-lcoord(1))
    func(2) = 0.5d0*(1.d0+lcoord(1))
  end subroutine

  subroutine ShapeDeriv_line2n(func)
    real(kind=kreal) :: func(2,1)
    func(1,1) = -0.5d0
    func(2,1) = 0.5d0
  end subroutine

  subroutine Shape2ndDeriv_line2n(func)
    real(kind=kreal) :: func(2,1,1)
    func(:,:,:) = 0.d0
  end subroutine

end module


\ .( LOADING BUBBLE SORT BENCHMARK...) CR

\ A CLASSICAL BENCHMARK OF AN O(N**2) ALGORITHM; BUBBLE SORT
\
\ PART OF THE PROGRAMS GATHERED BY JOHN HENNESSY FOR THE MIPS
\ RISC PROJECT AT STANFORD. TRANSLATED TO FORTH BY MARTY FRAEMAN
\ JOHNS HOPKINS UNIVERSITY/APPLIED PHYSICS LABORATORY.

\ MM FORTH2C DOESN'T HAVE IT !

4 CONSTANT CELL

: MYBOUNDS  OVER + SWAP ;

VARIABLE SEED ( -- ADDR)

: INITIATE-SEED ( -- )  74755 SEED ! ;
: RANDOM  ( -- N )  SEED @ 1309 * 13849 + 65535 AND DUP SEED ! ;

800 CONSTANT ELEMENTS ( -- INT)

CREATE LIST ELEMENTS CELLS ALLOT

: INITIATE-LIST ( -- )
  LIST ELEMENTS CELLS + LIST DO RANDOM I ! CELL +LOOP
;

: DUMP-LIST ( -- )
  LIST ELEMENTS CELLS + LIST DO I @ . CELL +LOOP CR
;

: VERIFY-LIST ( -- )
  LIST ELEMENTS 1- CELLS MYBOUNDS DO
    I 2@ > ABORT" BUBBLE-SORT: NOT SORTED"
  CELL +LOOP
;

: BUBBLE ( -- )
\ ." BUBBLING..." CR
  ELEMENTS 1 DO
    LIST ELEMENTS I - CELLS MYBOUNDS DO
      I 2@ > IF I 2@ SWAP I 2! THEN
    CELL +LOOP
  LOOP
;

: BUBBLE-SORT ( -- )
  INITIATE-SEED
  INITIATE-LIST
  BUBBLE
  VERIFY-LIST
;

: BUBBLE-WITH-FLAG ( -- )
  1 ELEMENTS 1 DO
    -1 LIST ELEMENTS I - CELLS MYBOUNDS DO
      I 2@ > IF I 2@ SWAP I 2! DROP 0 THEN
    CELL +LOOP
    IF LEAVE THEN
  LOOP
;

: BUBBLE-SORT-WITH-FLAG ( -- )
  INITIATE-SEED
  INITIATE-LIST
  BUBBLE-WITH-FLAG
  VERIFY-LIST
;

: MAIN  ( -- )
        BUBBLE-SORT
        BUBBLE-SORT-WITH-FLAG DROP
;


!> @ingroup quick_sort_recursive_dec
!>
!> @brief
!> Run a recursive three way quick sort on a vector of double precision values.
!>
!> @details
!> Run a decending on a vector of double precision values to sort them in the specified order.
!>
!> @param vec
!> The vector double precision values to be sorted.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
pure subroutine quick_sort_recursive_dec_dble(vec)
  ! Arguments
  double precision, intent(inout) :: vec(:)

  ! Variables
  integer :: low
  integer :: high
  integer :: low_eq
  integer :: high_eq
  double precision :: pivot
  double precision :: temp

  ! Go to interchange sort if list is small
  if (size(vec,1) <= max_interchange_sort_size) then
     call interchange_sort_dec_dble(vec)
  else
     ! Initilize values
     low = 1
     high = size(vec,1)
     low_eq = 1
     high_eq = size(vec,1)

     ! Build pivot
     pivot = (vec(low) + vec(high)) / 2
     if ( vec(low) < vec(high)) then
        call swap(vec(low),vec(high))
     end if

     ! Main loop with three way partition
     do
        ! Find pivot points
        do
           low = low + 1
           if (.not. pivot < vec(low)) exit
        end do
        do
           high = high - 1
           if (.not. vec(high) < pivot .or. high == 1) exit
        end do

        ! Exit if they are on the wrong side of the pivot
        if (low >= high) exit

        ! Run main quick sort swap
        call swap(vec(low),vec(high))

        ! Check for if values are equal to pivot, if so swap
        if (.not. vec(high) < pivot) then
           call swap(vec(high),vec(high_eq))
           high_eq = high_eq - 1
        end if

        if (.not. pivot < vec(low)) then
           call swap(vec(low),vec(low_eq))
           low_eq = low_eq + 1
        end if
     end do
     high = low - 1

     ! Move equals to the middle
     do while(1 < low_eq)
        low_eq = low_eq - 1
        call swap(vec(low_eq),vec(high))
        high = high - 1
     end do

     do while(high_eq < size(vec,1))
        high_eq = high_eq + 1
        call swap(vec(high_eq),vec(low))
        low = low + 1
     end do

     ! Recursive calls
     if (size(vec,1) - low > high - 1) then
        if (high > 1) call quick_sort_recursive_dec_dble(vec(:high))
        if (low < size(vec,1)) call quick_sort_recursive_dec_dble(vec(low:))
     else
        if (low < size(vec,1)) call quick_sort_recursive_dec_dble(vec(low:))
        if (high > 1) call quick_sort_recursive_dec_dble(vec(:high))
     end if
  end if
end subroutine quick_sort_recursive_dec_dble


subroutine init_phi(phi, lo, hi, ng, dx, prob_lo, prob_hi) bind(C, name="init_phi")

  implicit none

  integer          :: lo(3), hi(3), ng
  double precision :: phi(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng)
  double precision :: dx(3)
  double precision :: prob_lo(3)
  double precision :: prob_hi(3)

  integer          :: i,j,k
  double precision :: x,y,z,r2

  do k = lo(3), hi(3)
     z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
     do j = lo(2), hi(2)
        y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
        do i = lo(1), hi(1)
           x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

           r2 = ((x-0.25d0)**2 + (y-0.25d0)**2 + (z-0.25d0)**2) / 0.01d0
           phi(i,j,k) = 1.d0 + exp(-r2)

        end do
     end do
  end do

end subroutine init_phi


module fiducial
  use settings,  only: mcp        ! real precision
  use constants, only: const_pi  ! pi
  use numrec
  implicit none
  !values of dm and H used to take into account the fiducial cosmology.
  !Assumes that the fiducial cosmology corresponds to a simple flat LCDM model
  !as the one used for all BOSS measurements.
  real(mcp)       :: save_om_m !used to pass Omega_m to the integrand of D_M(z)
  contains

    subroutine compute_scaling(om_m_fid, h0_fid, z, d_m, hub)!Ariel: added this subroutine
      use camb
      implicit none
      real(kind=mcp), intent(in)  :: om_m_fid, h0_fid, z
      real(kind=mcp), intent(out) :: d_m, hub
      hub  = e(om_m_fid, z)!*h0_fid  !H(z)/100.
      d_m  = dm(om_m_fid, z)!/h0_fid !D_M(z)
    end subroutine compute_scaling

    function e(om_m, z)    !E(z)=H(z)/H_0
      implicit none
      real(kind=mcp)   :: om_m, z
      real(kind=mcp)   :: e2, e, zplus, a
      zplus  = 1._mcp + z
      a      = 1._mcp / zplus
      e2 = om_m/a**3 + (1._mcp- om_m)
      e = sqrt(e2)
    end function e

    function einv(z)
      implicit none
      real(kind=mcp) :: einv, z
      einv = 1._mcp/e(save_om_m, z)
    end function einv

    function dm(om_m, z) !for a flat cosmology dm = r(z)
      implicit none
      real(kind=mcp)   :: dm, om_m, z, ans
      save_om_m = om_m
      call qromb(einv, 0._mcp, z, ans)
      dm = ans*2997.92458_mcp
    end function dm

end module fiducial


Module Trait_functions
!This module provides several functions calculating phytoplankton physiological rates as a function of environmental conditions (e.g., temperature) and traits
implicit none

private

public :: TEMPBOL, temp_Topt, palatability, PHY_C2Vol, PHY_ESD2C

real, parameter :: pi= 3.1415926535

CONTAINS

!Function converting phytoplankton ESD (micron) to Carbon (unit: pmol C per cell) with the parameters obtained from Maranon et al. (2013)
real function PHY_ESD2C(ESD) result(y)
implicit none
real, intent(in)  :: ESD !Phytoplankton ESD (micron)

real, parameter :: a = -0.69
real, parameter :: b = 0.88

real :: Vol = 0d0

!Calculate volume from ESD
Vol = pi/6d0 * ESD**3

!the parameters of a and b are derived from pg C cell-1 to volume; so we need to
!convert the carbon unit from pmol C cell-1 to pg C cell-1

!Calculate carbon (pmol C per cell) from volume
y = 10.d0**a * Vol**b / 12.d0

return
end function PHY_ESD2C

!Function converting phytoplankton carbon to volume (unit: micron^3) with the parameters obtained from Maranon et al. (2013)
pure real function PHY_C2Vol(p_C) result(y)
implicit none
real, intent(in)  :: p_C !Phytoplankton carbon (pmol C/cell)

real, parameter :: a = -0.69
real, parameter :: b = 0.88

!the parameters of a and b are derived from pg C cell-1 to volume; so we need to
!convert the carbon unit from pmol C cell-1 to pg C cell-1

y = (12d0 * p_C/10.d0**a)**(1d0/b)
return
end function

!Function calculating the prey palatability based on Ward et al. L&O 2012 (Eq. A21) and Banas Ecol. Mod. (2011) Table 2
real function palatability(Vpred, Vprey) result(y)
implicit none

!Predator Volume
real, intent(in)  :: Vpred

!Prey Volume
real, intent(in)  :: Vprey

!The actual predator:prey volume ratio
real  :: R_real = 0d0

! Standard deviation of log zooplankton feeding preference
real, parameter  :: SDpref_Z = 0.5

!Optimal prey Volume of the predator
real :: Vprey_opt = 1d3

real :: Xpred, Xprey !ESD of predator and prey
real :: Xprey_opt = 0. !Optimal prey ESD

!Optimal predator:prey volume ratio
real :: R_opt = 1d3

real :: cff = 0d0

!First calculate prey and predator ESD (micron) from volume
Xpred = (6d0*Vpred/pi)**(.33333333333333)
Xprey = (6d0*Vprey/pi)**(.33333333333333)

!Then calculate optimal prey ESD (micron)
Xprey_opt = 0.65 * Xpred**0.56

!Convert prey ESD to volume
Vprey_opt = pi/6d0 * Xprey_opt**3

R_opt  = Vpred/Vprey_opt
R_real = Vpred/Vprey

cff = log(R_real/R_opt)
cff = cff**2/(2.d0 * SDpref_Z**2)

!To avoid underflow
if (cff > 5d2) then
   y = 0d0
else
   y = exp(-cff)
endif
return
end function palatability

pure real function TEMPBOL(Ea,tC)
implicit none
!DESCRIPTION:
!The temperature dependence of plankton rates are fomulated according to the Arrhenuis equation.
! tC: in situ temperature
! Tr: reference temperature
!
!INPUT PARAMETERS:
real, intent (in) :: Ea, tC

! boltzman constant constant [ eV /K ]
real, parameter   :: kb = 8.62d-5, Tr = 15D0

TEMPBOL = exp(-(Ea/kb)*(1D0/(273.15 + tC)-1D0/(273.15 + Tr)))
return
end function TEMPBOL

REAL function temp_Topt(tC, mumax0, Topt_) result(y)
!Function of a rate depending on Temperature and optimal temperature (Topt_) modified from Chen Ecol. Mod. (2022)
IMPLICIT NONE
real, intent(in) :: mumax0    !Maximal rate normalized to an optimal temperature of 15 ºC
real, intent(in) :: tC         !Environmental temperature in ºC
real, intent(in) :: Topt_   !Optimal temperature in ºC

real, parameter   :: Ea0   = 0.98
real, parameter   :: Ed0   = 2.3
real, parameter   :: Ei      = 0.22
real, parameter   :: beta  =-0.2  !Exponent for Ea0
real, parameter   :: phi    = 0.27  !Exponent for Ed
!real, parameter   :: mumax0 = 0.59  !Normalized growth rate for mumax (d-1)

real :: Ed, Ea, mumax

mumax = alloscale(Topt_, mumax0,  Ei)
Ea    = alloscale(Topt_, Ea0,  beta)
Ed    = alloscale(Topt_, Ed0,  phi)
y       = JOHNSON(tC, mumax, Ea, Ed, Topt_)

END function temp_Topt

REAL FUNCTION JOHNSON(tC, mumax, Ea, Ed, Topt_) RESULT(y)
!Temperature function following Dell et al. PNAS (2011) and Chen & Laws L&O (2017)
IMPLICIT NONE
!Both tC and Topt_ are in ºC
real,   intent(in)     :: tC, mumax, Ea, Ed, Topt_
real,   parameter   :: kb   = 8.62D-5
real,   parameter   :: T0   = 273.15D0
real,   parameter   :: Tref = 15D0
real                         :: Eh, x, theta, b

if (Ed .le. 0d0) stop "Ed must be greater than zero!"
Eh = Ed+Ea
x    = TK(TC)
theta = TK(Topt_)
b = x - theta
y = mumax*(Ea/Ed + 1.d0) * exp(Ea*b)/(1.D0+Ea/ED*exp(Eh*b))
return
END FUNCTION JOHNSON

PURE REAL FUNCTION TK(TC)
IMPLICIT NONE
!DESCRIPTION:
!The temperature dependence of plankton rates are fomulated according to the Arrhenuis equation.
! tC: in situ temperature
! Tr: reference temperature
!
!INPUT PARAMETERS:
REAL, INTENT (IN) :: TC
! boltzman constant constant [ eV /K ]
REAL, PARAMETER   :: kb = 8.62d-5, Tr = 15.0

TK = -(1./kb)*(1./(273.15 + tC) - 1./(273.15 + Tr))
return
END FUNCTION TK

PURE REAL FUNCTION alloscale(Topt_, mu0p, alpha)
IMPLICIT NONE
real, intent(in) :: Topt_     !Topt in ºC
real, intent(in) :: mu0p  !Normalized growth rate
real, intent(in) :: alpha    !Exponent of thermal traits normalized to z
alloscale =  mu0p * exp(TK(Topt_) * alpha)
END FUNCTION alloscale

END MODULE


c
c
c   double precision function myatan(y,x)
c   double precision function dmyatandx(y,x)
c   double precision function dmyatandy(y,x)
c
c   double precision function polyarea(x,n)
c   subroutine polyprop(xs,x,n)
c
c   integer function round(x)
c   integer function trunc(x)
c
c   integer function Hs(x)
c
c   double precision function LP(i,m,s)
c   double precision function dLP(i,m,s)
c   double precision function ddLP(i,m,s)
c
c   double precision function dot(a,b,n)
c
c   logical function NaN(x)
c
c   double precision function value(ad,al,au,jpl,jpu,i,j)
c
c   subroutine eliminate_column(A,l,m,n)
c   subroutine eliminate_row(A,l,m,n)
c
c
c
c
c
c
c
c
c
c=======================================================
c (A.9)  myatan(y,x)   takes into account the signs of x and y
c-------------------------------------------------------
      double precision function myatan(y,x)
      implicit none
      double precision x, y, r0, pi, phi
      r0 = 0.d0
      pi = acos(-1.d0)
      phi = atan(y/x)
      if (x.lt.r0) then
        myatan = pi + phi
      elseif ((x.gt.r0).and.(y.lt.r0)) then
        myatan = 2.d0 * pi + phi
      else
        myatan = phi
      endif
      return
      end
c
c=======================================================
c (A.10)  dmyatandx(y,x)   takes into account the signs of x and y
c-------------------------------------------------------
      double precision function dmyatandx(y,x)
      implicit none
      double precision x, y
      dmyatandx = - y / (x*x + y*y)
      return
      end
c
c=======================================================
c (A.11)  dmyatandy(y,x)   takes into account the signs of x and y
c-------------------------------------------------------
      double precision function dmyatandy(y,x)
      implicit none
      double precision x, y
      dmyatandy = x / (x*x + y*y)
      return
      end
c
c=======================================================
c polyarea(x,n)
c-------------------------------------------------------
      double precision function polyarea(x,n)
      implicit none
      integer          n, i
      double precision x(2,*), A, x0(2)
      x0(1) = 0.d0
      x0(2) = 0.d0
      A     = 0.d0
      do i=1, n-1
        A = A + ((x(1,i  )-x0(1))*(x(2,i+1)-x0(2))
     *         - (x(1,i+1)-x0(1))*(x(2,i  )-x0(2))) * 0.5d0
      enddo
      polyarea = A + ((x(1,n)-x0(1))*(x(2,1)-x0(2))
     *              - (x(1,1)-x0(1))*(x(2,n)-x0(2))) * 0.5d0
      return
      end
c
c=======================================================
c polyprop(prop,x,n)
c-------------------------------------------------------
      subroutine polyprop(prop,x,n)
      implicit none
      integer          n, i
      double precision prop(*), x(2,*), x0(2), Dx(2), Ax(2), DA, A
      x0(1) = 0.d0
      x0(2) = 0.d0
      A     = 0.d0
      Ax(1) = 0.d0
      Ax(2) = 0.d0
      do i=1, n-1
        Dx(1) = ((x(1,i) + x(1,i+1)) - 2.d0*x0(1)) / 3.d0
        Dx(2) = ((x(2,i) + x(2,i+1)) - 2.d0*x0(2)) / 3.d0
        DA    = ((x(1,i  )-x0(1))*(x(2,i+1)-x0(2))
     *         - (x(1,i+1)-x0(1))*(x(2,i  )-x0(2))) * 0.5d0
        A     = A     + DA
        Ax(1) = Ax(1) + DA * Dx(1)
        Ax(2) = Ax(2) + DA * Dx(2)
      enddo
      Dx(1) = ((x(1,n) + x(1,1)) - 2.d0*x0(1)) / 3.d0
      Dx(2) = ((x(2,n) + x(2,1)) - 2.d0*x0(2)) / 3.d0
      DA    = ((x(1,n)-x0(1))*(x(2,1)-x0(2))
     *       - (x(1,1)-x0(1))*(x(2,n)-x0(2))) * 0.5d0
      A     = A     + DA
      Ax(1) = Ax(1) + DA * Dx(1)
      Ax(2) = Ax(2) + DA * Dx(2)
      prop(1) = Ax(1) / A  ! centre of gravity, x-coordinate
      prop(2) = Ax(2) / A  ! centre of gravity, y-coordinate
      prop(3) = A          ! area

      Ax(1) = 0.d0
      Ax(2) = 0.d0
      do i=1, n-1
        Dx(1) = ((x(1,i) + x(1,i+1)) - 2.d0*prop(1)) / 3.d0
        Dx(2) = ((x(2,i) + x(2,i+1)) - 2.d0*prop(2)) / 3.d0
        DA    = ((x(1,i  )-prop(1))*(x(2,i+1)-prop(2))
     *         - (x(1,i+1)-prop(1))*(x(2,i  )-prop(2))) * 0.5d0
        Ax(1) = Ax(1) + DA * Dx(1) * Dx(1)
        Ax(2) = Ax(2) + DA * Dx(2) * Dx(2)
      enddo
      Dx(1) = ((x(1,n) + x(1,1)) - 2.d0*prop(1)) / 3.d0
      Dx(2) = ((x(2,n) + x(2,1)) - 2.d0*prop(2)) / 3.d0
      DA    = ((x(1,n)-prop(1))*(x(2,1)-prop(2))
     *       - (x(1,1)-prop(1))*(x(2,n)-prop(2))) * 0.5d0
      A     = A     + DA
      Ax(1) = Ax(1) + DA * Dx(1) * Dx(1)
      Ax(2) = Ax(2) + DA * Dx(2) * Dx(2)
      prop(4) = Ax(1)         ! I_x
      prop(5) = Ax(2)         ! I_y
      prop(6) = Ax(1) + Ax(2) ! I_p
      return
      end
c
c=======================================================
c (A.12) round(x)
c-------------------------------------------------------
      integer function round(x)
      implicit none
      double precision x
      integer          h
      h     = int(2*abs(x))
      h     = h + mod(h,2)
      round = sign(.5d0,x) * h
      return
      end
c=======================================================
c (A.12) trunc(x)
c-------------------------------------------------------
      integer function trunc(x)
      implicit none
      double precision x
      integer          h
      h = int(x)
      if (x.lt.h) then
        trunc = h - 1
      else
        trunc = h
      endif
      return
      end
cc=======================================================
c (A.13) Hs(x)
c-------------------------------------------------------
      integer function Hs(x)
      implicit none
      double precision x
      if (x.gt.1.d-15) then
        Hs = 1
      elseif (x.lt.-1.d-15) then
        Hs = -1
      else
        Hs = 0
      endif
      return
      end
c
c=======================================================
c (A.15) LP(i,m,s)
c
c    evaluate Lagrangian Polynomial i
c
c    0 <= x <= 1,
c    m equally distributed interpolation points
c
c    example: m = 3 -> x1=0.0, x2=0.5, x3=1.0
c-------------------------------------------------------
      double precision function LP(i,m,s)
      implicit none
      integer          i, m, j
      double precision ds, s, si, sj, N
      ds = 1.d0 / real(m-1)
      N  = 1.d0
      si = (i-1) * ds
      do j=1, m
        sj = (j-1) * ds
        if (j.ne.i) N = N * (s-sj) / (si-sj)
      enddo
      LP = N
      return
      end
c
c=======================================================
c (A.16) dLP(i,m,s)
c
c    evaluate first derivative of Lagrangian Polynomial i
c
c    0 <= x <= 1,
c    m equally distributed interpolation points
c
c    example: m = 3 -> x1=0.0, x2=0.5, x3=1.0
c-------------------------------------------------------
      double precision function dLP(i,m,s)
      implicit none
      integer          i, m, j, k
      double precision ds, s, si, sj, sk, dN, h
      save
      ds = 1.d0 / real(m-1)
      dN = 0.d0
      si = (i-1) * ds
      do k=1, m
        if (k.ne.i) then
          sk = (k-1) * ds
          h = 1.d0 / (si-sk)
          do j=1, m
            sj = (j-1) * ds
            if (j.ne.i.and.j.ne.k) h = h *  (s-sj) / (si-sj)
          enddo
          dN = dN + h
        endif
      enddo
      dLP = dN
      return
      end
c
c=======================================================
c (A.17) ddLP(i,m,s)
c
c    evaluate second derivative of Lagrangian Polynomial i
c
c    0 <= x <= 1,
c    m equally distributed interpolation points
c
c    example: m = 3 -> x1=0.0, x2=0.5, x3=1.0
c-------------------------------------------------------
      double precision function ddLP(i,m,s)
      implicit none
      integer          i, m, j, k, l
      double precision ds, s, si, sj, sk, sl, ddN, h
      save
      ds = 1.d0 / real(m-1)
      ddN = 0.d0
      si = (i-1) * ds
      do l=1, m
        if (l.ne.i) then
          sl = (l-1) * ds
          do k=1, m
            if (k.ne.i.and.k.ne.l) then
              sk = (k-1) * ds
              h = 1.d0 / ((si-sk) * (si-sl))
              do j=1, m
                sj = (j-1) * ds
                if (j.ne.i.and.j.ne.k.and.j.ne.l) h = h * (s-sj)/(si-sj)
              enddo
              ddN = ddN + h
            endif
          enddo
        endif
      enddo
      ddLP = ddN
      return
      end
c
c=======================================================
c (A.18) dot(a,b,n)
c
c    dot product of two vectors of dimension n
c
c-------------------------------------------------------
      double precision function dot(a,b,n)
      implicit none
      integer n, i
      double precision a(*), b(*), d
      save
      d = 0.d0
      do i=1, n
        d = d + a(i) * b(i)
      enddo
      dot = d
      return
      end
c
c=======================================================
c (A.18) nan(x)
c
c     check whether x is a well defined number or not
c
c-------------------------------------------------------
      logical function NaN(x)
      implicit none
      double precision x
      character strg*3
      write(strg,'(f3.1)') x
c      write(*,*) strg
      NaN = .false.
      if (strg(1:1).eq.'N'.or.strg(1:1).eq.'n'.or.strg(1:1).eq.'?'.or.
     *    strg(1:1).eq.' ')
     *  NaN = .true.
      return
      end
c
c========================================================================
c
c (D.19)   return value of coefficient A[i,j] in profile matrix
c
c------------------------------------------------------------------------
      double precision function value(ad,al,au,jpl,jpu,i,j)
      implicit none
      integer i, j, jpl(*), jpu(*), n
      double precision ad(*), al(*), au(*)
      if (i.gt.j) then
        if (jpl(i)-jpl(i-1).ge.i-j) then
          value = al(jpl(i)-i+j+1)
        else
          value = 0.d0
        endif
      elseif (i.eq.j) then
        value = ad(i)
      else
        if (jpu(j)-jpu(j-1).ge.j-i) then
          value = au(jpu(j)-j+i+1)
        else
          value = 0.d0
        endif
      endif
      return
      end
c
c=======================================================
c (D.20)   Eliminiere die l-te Spalte aus einer Matrix
c           Matrixdimension:   m x n  ->  m x n-1
c-------------------------------------------------------
      subroutine eliminate_column(A,l,m,n)
      implicit none
      integer i, l, m, n
      double precision A(m*n)
      do i=(l-1)*m+1, l*m
        A(i) = A(i+m)
      enddo
      return
      end
c
c=======================================================
c (D.12)   Eliminiere die l-te Zeile aus einer Matrix
c           Matrixdimension:   m x n  ->  m-1 x n
c-------------------------------------------------------
      subroutine eliminate_row(A,l,m,n)
      implicit none
      integer i, j, l, m, n
      double precision A(m*n)
      do i=1, n
        do j=1, m-1
          A((i-1)*(m-1)+l + j-1) = A((i-1)*(m-1)+l + j-1+i)
        enddo
      enddo
      return
      end
c
c=======================================================


C
C     file hstcrt.f
C
      SUBROUTINE HSTCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                 SOLVES THE STANDARD FIVE-POINT FINITE
C                         DIFFERENCE APPROXIMATION TO THE HELMHOLTZ
C                         EQUATION
C                           (D/DX)(DU/DX) + (D/DY)(DU/DY) + LAMBDA*U
C                           = F(X,Y)
C                         ON A STAGGERED GRID IN CARTESIAN COORDINATES.
C
C USAGE                   CALL HSTCRT (A,B,M,MBDCND,BDA,BDB,C,D
C                                      N,NBDCND,BDC,BDD,ELMBDA,
C                                      F,IDIMF,PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT
C
C                        A,B
C                          THE RANGE OF X, I.E. A .LE. X .LE. B.
C                          A MUST BE LESS THAN B.
C
C                        M
C                          THE NUMBER OF GRID POINTS IN THE
C                          INTERVAL (A,B).  THE GRID POINTS
C                          IN THE X-DIRECTION ARE GIVEN BY
C                          X(I) = A + (I-0.5)DX FOR I=1,2,...,M
C                          WHERE DX =(B-A)/M.  M MUST BE GREATER
C                          THAN 2.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT X = A AND X = B.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN X,
C                               U(M+I,J) = U(I,J).
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               X = A AND X = B.
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               X = A AND THE DERIVATIVE
C                               OF THE SOLUTION WITH RESPECT TO X
C                               IS SPECIFIED AT X = B.
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO X IS SPECIFIED
C                               AT X = A  AND X = B.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO X IS SPECIFIED
C                               AT X = A  AND THE SOLUTION IS
C                               SPECIFIED AT X = B.
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N
C                          THAT SPECIFIES THE BOUNDARY VALUES
C                          (IF ANY) OF THE SOLUTION AT X = A.
C
C                          WHEN MBDCND = 1 OR 2,
C                            BDA(J) = U(A,Y(J)) ,         J=1,2,...,N.
C
C                          WHEN MBDCND = 3 OR 4,
C                            BDA(J) = (D/DX)U(A,Y(J)) ,   J=1,2,...,N.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N
C                          THAT SPECIFIES THE BOUNDARY VALUES
C                          OF THE SOLUTION AT X = B.
C
C                          WHEN MBDCND = 1 OR 4
C                            BDB(J) = U(B,Y(J)) ,        J=1,2,...,N.
C
C                          WHEN MBDCND = 2 OR 3
C                            BDB(J) = (D/DX)U(B,Y(J)) ,  J=1,2,...,N.
C
C                        C,D
C                          THE RANGE OF Y, I.E. C .LE. Y .LE. D.
C                          C MUST BE LESS THAN D.
C
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE INTERVAL
C                          (C,D).  THE UNKNOWNS IN THE Y-DIRECTION
C                          ARE GIVEN BY Y(J) = C + (J-0.5)DY,
C                          J=1,2,...,N, WHERE DY = (D-C)/N.
C                          N MUST BE GREATER THAN 2.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT Y = C   AND Y = D.
C
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN Y, I.E.
C                               U(I,J) = U(I,N+J).
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT Y = C
C                               AND Y = D.
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT Y = C
C                               AND THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               Y = D.
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               Y = C AND Y = D.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               Y = C AND THE SOLUTION IS SPECIFIED
C                               AT Y = D.
C
C                        BDC
C                          A ONE DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT Y = C.
C
C                          WHEN NBDCND = 1 OR 2,
C                            BDC(I) = U(X(I),C) ,        I=1,2,...,M.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDC(I) = (D/DY)U(X(I),C),   I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT Y = D.
C
C                          WHEN NBDCND = 1 OR 4,
C                            BDD(I) = U(X(I),D) ,        I=1,2,...,M.
C
C                          WHEN NBDCND = 2 OR 3,
C                            BDD(I) = (D/DY)U(X(I),D) ,  I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA IS GREATER THAN 0,
C                          A SOLUTION MAY NOT EXIST. HOWEVER,
C                          HSTCRT WILL  ATTEMPT TO FIND A SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE RIGHT SIDE OF THE
C                          HELMHOLTZ EQUATION.  FOR I=1,2,...,M
C                          AND J=1,2,...,N
C
C                            F(I,J) = F(X(I),Y(J)) .
C
C                          F MUST BE DIMENSIONED AT LEAST M X N.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HSTCRT.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.
C                          IDIMF MUST BE AT LEAST M.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          W MAY REQUIRE UP TO 13M + 4N +
C                          M*INT(LOG2(N)) LOCATIONS. THE ACTUAL NUMBER
C                          OF LOCATIONS USED IS COMPUTED BY HSTCRT
C                          AND IS RETURNED IN THE LOCATION W(1).
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (X(I),Y(J)) FOR  I=1,2,...,M, J=1,2,...,N.
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                          BOUNDARY CONDITIONS IS SPECIFIED FOR A
C                          POISSON EQUATION (LAMBDA = 0), A SOLUTION
C                          MAY NOT EXIST.  PERTRB IS A CONSTANT,
C                          CALCULATED AND SUBTRACTED FROM F, WHICH
C                          ENSURES THAT A SOLUTION EXISTS.  HSTCRT
C                          THEN COMPUTES THIS SOLUTION, WHICH IS A
C                          LEAST SQUARES SOLUTION TO THE ORIGINAL
C                          APPROXIMATION.  THIS SOLUTION PLUS ANY
C                          CONSTANT IS ALSO A SOLUTION; HENCE, THE
C                          SOLUTION IS NOT UNIQUE.  THE VALUE OF
C                          PERTRB SHOULD BE SMALL COMPARED TO THE
C                          RIGHT SIDE F.  OTHERWISE, A SOLUTION IS
C                          OBTAINED TO AN ESSENTIALLY DIFFERENT PROBLEM.
C                          THIS COMPARISON SHOULD ALWAYS BE MADE TO
C                          INSURE THAT A MEANINGFUL SOLUTION HAS BEEN
C                          OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT TO NUMBERS 0 AND  6,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR
C
C                          =  1  A .GE. B
C
C                          =  2  MBDCND .LT. 0 OR MBDCND .GT. 4
C
C                          =  3  C .GE. D
C
C                          =  4  N .LE. 2
C
C                         =  5  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C                         =  6  LAMBDA .GT. 0
C
C                         =  7  IDIMF .LT. M
C
C                         =  8  M .LE. 2
C
C                         SINCE THIS IS THE ONLY MEANS OF INDICATING
C                         A POSSIBLY INCORRECT CALL TO HSTCRT, THE
C                         USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF, GENBUN, GNBNAUX, AND POISTG
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN 1977.
C                        RELEASED ON NCAR'S PUBLIC SOFTWARE LIBRARIES
C                        IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS
C                        THE RIGHT SIDE WHEN THE SYSTEM IS SINGULAR
C                        AND CALLS EITHER POISTG OR GENBUN WHICH SOLVES
C                        THE LINEAR SYSTEM OF EQUATIONS.
C
C TIMING                 FOR LARGE M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO M*N*LOG2(N).
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN A
C                        LOSS OF NO MORE THAN FOUR SIGNIFICANT DIGITS
C                        FOR N AND M AS LARGE AS 64.  MORE DETAILED
C                        INFORMATION ABOUT ACCURACY CAN BE FOUND IN
C                        THE DOCUMENTATION FOR PACKAGE POISTG WHICH
C                        SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C REFERENCES             U. SCHUMANN AND R. SWEET,"A DIRECT METHOD
C                        FOR THE SOLUTION OF POISSON'S EQUATION WITH
C                        BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                        ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                        PP. 171-182.
C***********************************************************************
      DIMENSION       F(IDIMF,1) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C
C     CHECK FOR INVALID PARAMETERS.
C
      IERROR = 0
      IF (A .GE. B) IERROR = 1
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2
      IF (C .GE. D) IERROR = 3
      IF (N .LE. 2) IERROR = 4
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5
      IF (IDIMF .LT. M) IERROR = 7
      IF (M .LE. 2) IERROR = 8
      IF (IERROR .NE. 0) RETURN
      NPEROD = NBDCND
      MPEROD = 0
      IF (MBDCND .GT. 0) MPEROD = 1
      DELTAX = (B-A)/FLOAT(M)
      TWDELX = 1./DELTAX
      DELXSQ = 2./DELTAX**2
      DELTAY = (D-C)/FLOAT(N)
      TWDELY = 1./DELTAY
      DELYSQ = DELTAY**2
      TWDYSQ = 2./DELYSQ
      NP = NBDCND+1
      MP = MBDCND+1
C
C     DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = M
      ID3 = ID2+M
      ID4 = ID3+M
      S = (DELTAY/DELTAX)**2
      ST2 = 2.*S
      DO 101 I=1,M
         W(I) = S
         J = ID2+I
         W(J) = -ST2+ELMBDA*DELYSQ
         J = ID3+I
         W(J) = S
  101 CONTINUE
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (111,102,102,104,104),MP
  102 DO 103 J=1,N
         F(1,J) = F(1,J)-BDA(J)*DELXSQ
  103 CONTINUE
      W(ID2+1) = W(ID2+1)-W(1)
      GO TO 106
  104 DO 105 J=1,N
         F(1,J) = F(1,J)+BDA(J)*TWDELX
  105 CONTINUE
      W(ID2+1) = W(ID2+1)+W(1)
  106 GO TO (111,107,109,109,107),MP
  107 DO 108 J=1,N
         F(M,J) = F(M,J)-BDB(J)*DELXSQ
  108 CONTINUE
      W(ID3) = W(ID3)-W(1)
      GO TO 111
  109 DO 110 J=1,N
         F(M,J) = F(M,J)-BDB(J)*TWDELX
  110 CONTINUE
      W(ID3) = W(ID3)+W(1)
  111 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (121,112,112,114,114),NP
  112 DO 113 I=1,M
         F(I,1) = F(I,1)-BDC(I)*TWDYSQ
  113 CONTINUE
      GO TO 116
  114 DO 115 I=1,M
         F(I,1) = F(I,1)+BDC(I)*TWDELY
  115 CONTINUE
  116 GO TO (121,117,119,119,117),NP
  117 DO 118 I=1,M
         F(I,N) = F(I,N)-BDD(I)*TWDYSQ
  118 CONTINUE
      GO TO 121
  119 DO 120 I=1,M
         F(I,N) = F(I,N)-BDD(I)*TWDELY
  120 CONTINUE
  121 CONTINUE
      DO 123 I=1,M
         DO 122 J=1,N
            F(I,J) = F(I,J)*DELYSQ
  122    CONTINUE
  123 CONTINUE
      IF (MPEROD .EQ. 0) GO TO 124
      W(1) = 0.
      W(ID4) = 0.
  124 CONTINUE
      PERTRB = 0.
      IF (ELMBDA) 133,126,125
  125 IERROR = 6
      GO TO 133
  126 GO TO (127,133,133,127,133),MP
  127 GO TO (128,133,133,128,133),NP
C
C     FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION
C     WILL EXIST.
C
  128 CONTINUE
      S = 0.
      DO 130 J=1,N
         DO 129 I=1,M
            S = S+F(I,J)
  129    CONTINUE
  130 CONTINUE
      PERTRB = S/FLOAT(M*N)
      DO 132 J=1,N
         DO 131 I=1,M
            F(I,J) = F(I,J)-PERTRB
  131    CONTINUE
  132 CONTINUE
      PERTRB = PERTRB/DELYSQ
C
C     SOLVE THE EQUATION.
C
  133 CONTINUE
      IF (NPEROD .EQ. 0) GO TO 134
      CALL POISTG (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F,
     1             IERR1,W(ID4+1))
      GO TO 135
  134 CONTINUE
      CALL GENBUN (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F,
     1             IERR1,W(ID4+1))
  135 CONTINUE
      W(1) = W(ID4+1)+3.*FLOAT(M)
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!

!===============================================================
real(8) function bessel_j1(x)
  implicit none
  real(8), intent(in) :: x
  integer, parameter :: order = 30
  real(8) :: c, s
  integer :: m

  c = 0.5 * x
  s = c
  do m = 1, 30
    c = -0.25d0 * x * x / (m * (m + 1)) * c
    s = s + c
  end do
  bessel_j1 = s
  return
end function bessel_j1
!===============================================================
real(8) function sin2cos(t, tw, omega, cep)
  use Global_Variables, only: pi
  implicit none
  real(8), intent(in) :: t, tw, omega, cep
  real(8) :: theta1, theta2

  if ((0 <= t) .and. (t <= tw)) then
    theta1 = pi / tw * t
    theta2 = omega * t + 2 * pi * cep
    sin2cos = sin(theta1) ** 2 * cos(theta2)
  else
    sin2cos = 0.0d0
  endif
  return
end function sin2cos
!===============================================================
subroutine incident_bessel_beam()
  use Global_Variables, only: IWcm2_1, omegaeV_1, tpulsefs_1, Epdir_1, phi_CEP_1, &
                            & NXvacL_m, NXvacR_m, NYvacB_m, NYvacT_m, &
                            & HX_m, HY_m, Ac_m, Ac_new_m, dt, &
                            & pi, c_light
  implicit none
  real(8) :: f0_1, omega_1, tpulse_1, wpulse_1
  integer :: ix_m, iy_m
  real(8) :: lx, ly, x, y, kx, ky, k, vx
  real(8) :: f(3), j, tau

  real(8) bessel_j1, sin2cos

  ! First pulse
  f0_1 = 5.338d-9*sqrt(IWcm2_1)  ! electric field in a.u.
  omega_1 = omegaeV_1 / (2d0*13.6058d0)  ! frequency in a.u.
  tpulse_1 = tpulsefs_1 / 0.02418d0 ! pulse_duration in a.u.
  wpulse_1 = 2*pi/tpulse_1

  lx = (NXvacR_m-NXvacL_m) * HX_m
  ly = (NYvacT_m+1) * HY_m

  ky = 3.8317d0 / ly
  k = omega_1 / c_light

  if (ky > k) then
    call err_finalize('Error: NY,HY is not enough')
  endif

  kx = SQRT(k*k-ky*ky)
  vx = omega_1 / kx

  Ac_m = 0.0
  Ac_new_m = 0.0
  do iy_m = NYvacB_m, NYvacT_m
     y = HY_m * iy_m
     j = bessel_j1(ky * y)
     f = j * f0_1 / 0.58186d0 * Epdir_1
     do ix_m = NXvacL_m-1, 0
       x = ix_m * HX_m
       ! Ac_new_m
       tau = - x / vx
       Ac_new_m(:,ix_m,iy_m) = f * sin2cos(tau, tpulse_1, omega_1, phi_CEP_1)
       ! Ac_m (previous time-step)
       tau = - x / vx - dt
       Ac_m(:,ix_m,iy_m) =  f * sin2cos(tau, tpulse_1, omega_1, phi_CEP_1)
     end do
  end do

  ! impose boundary condition
  Ac_new_m(:,:,NYvacT_m+1) = 0.0d0
  Ac_new_m(2:3,:,NYvacB_m-1) = 0.0d0
  Ac_new_m(1,:,NYvacB_m-1) = Ac_new_m(1,:,NYvacB_m)
  Ac_m(:,:,NYvacT_m+1) = 0.0d0
  Ac_m(2:3,:,NYvacB_m-1) = 0.0d0
  Ac_m(1,:,NYvacB_m-1) = Ac_m(1,:,NYvacB_m)
  return
end subroutine incident_bessel_beam

subroutine read_initial_ac_from_file()
  use Global_Variables, only: SYSName, directory,file_ac_init, &
                            & Ac_m, Ac_new_m
  use communication, only: comm_is_root, comm_bcast, proc_group
  implicit none
  integer :: ix_m, iy_m
  integer :: nx1_m, nx2_m, ny1_m, ny2_m

  write(file_ac_init, "(A,A,'_Ac_init.dat')") trim(directory), trim(SYSname)
  if (comm_is_root(1)) then
    Ac_m = 0.0
    Ac_new_m = 0.0
    open(944, file=trim(file_ac_init))
    read(944, *) nx1_m, nx2_m
    read(944, *) ny1_m, ny2_m
    do iy_m = ny1_m, ny2_m
      do ix_m = nx1_m, nx2_m
        read(944, *) Ac_m(:, ix_m, iy_m), Ac_new_m(:, ix_m, iy_m)
      end do
    end do
    close(944)
  end if
  call comm_bcast(Ac_m, proc_group(1))
  call comm_bcast(Ac_new_m, proc_group(1))
  return
end subroutine


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program mainWGF
    use meshread_mod
    use spherePEC_mod
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh_evl
    complex(8), allocatable :: Esrc(:, :)  ! Source electric field
    complex(8), allocatable :: Eexact(:, :)  ! Exact electric field solution

    real(8) :: ExNormSrc, ExNormTot
    integer :: nEvl

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]
    real(8), parameter :: k0 = 2*PI          ! free-space wavenumber [1/m]

    real(8), parameter :: ep1_r = 1d0          ! upper half-space relative permittivity
    real(8), parameter :: ep1 = ep0*ep1_r     ! upper half-space permittivity [F/m]
    real(8), parameter :: mu1 = mu0           ! upper half-space permeability [H/m]

    real(8), parameter :: w = k0 / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]

    character(len=100), parameter :: file_evl_msh = 'meshes/eval_msh/dome.msh'
    real(8), parameter :: sph_radius = 1d0      ! hemisphere radius

    ! Planewave parameters
    integer, parameter :: n_terms = 100     ! number of terms in Mie series
    real(8), parameter :: alpha = PI/32d0      ! planewave angle of incidence in (0, pi)
    logical, parameter :: TE_mode = .false.  ! planewave mode: TEmode = .true.
                                            !                 TMmode = .false.

    !************************************************************************************

    ! Load eval mesh
    call load_gmsh(file_evl_msh, msh_evl)
    nEvl = size(msh_evl%POS, 1)

    ! Compute source field Esrc
    call halfsphere_on_plane_source_field(alpha, k1, msh_evl, Esrc, TE_mode)

    ! Compute exact solution Es
    print *, "Exact solution"
    call halfsphere_on_plane_scattered_field(msh_evl%POS, k1, sph_radius,  &
                                            alpha, n_terms, Eexact, TE_mode)
    print *, "done"

    ! ExNormSrc
    ExNormSrc = maxval(sqrt(abs(Eexact(:,1))**2+abs(Eexact(:,2))**2+abs(Eexact(:,3))**2))

    ! ExNormTot
    Eexact = Eexact + Esrc
    ExNormTot = maxval(sqrt(abs(Eexact(:,1))**2+abs(Eexact(:,2))**2+abs(Eexact(:,3))**2))

    ! ExNorm
    print *, "ExNormSrc", ExNormSrc
    print *, "ExNormTot", ExNormTot
end program


module quadrature_mc

contains

function quad_mc(g, a, b, ndim, npoints)

    implicit none
    real(kind=8),external :: g
    integer, intent(in) :: ndim, npoints
    real(kind=8), intent(in) :: a(ndim), b(ndim)
    real(kind=8) :: quad_mc

    integer :: i

    real(kind=4), allocatable :: r(:), rr(:)
    real(kind=8) :: gsum, volume
    real(kind=8), allocatable :: x(:)

    allocate(r(ndim*npoints))
    allocate(x(ndim), rr(ndim))

    gsum = 0.d0

    volume = product(b-a)

    call random_number(r)
    do i=1,npoints
        rr = r((i-1)*ndim + 1 : i*ndim)  ! next ndim elements of r
        x = a + rr*(b-a)   ! sets ndim elements of x elementwise
        gsum = gsum + g(x,ndim)
        enddo
    quad_mc = volume * gsum /  npoints

    deallocate(x,r,rr)

end function quad_mc

end module quadrature_mc


module Mbinning

  use, intrinsic :: iso_c_binding, only: dp=>C_DOUBLE

  contains

  integer function test(a,b)
    implicit none
    integer, intent(in) :: a,b
    test = a+b
    return
  end function test

  ! the matrix, vector sizes go to the end of the call list
  ! since we do not have to provide them in python
  ! automatic detection
  subroutine binMatrix_r(inMatrix, vec1, vec2, outMatrix, inX, inY, vec1length, vec2length)
    implicit none
    integer, intent(in) :: inX, inY, vec1length, vec2length

    real(dp), dimension(inX, inY), intent(in) :: inMatrix
    real(dp), dimension(vec1length, vec2length), intent(inout) :: outMatrix

    integer, dimension(vec1length), intent(in) :: vec1
    integer, dimension(vec2length), intent(in) :: vec2

    integer :: i,j
    integer :: ii,jj
    real(dp) :: tempsum
    integer :: vecsum

    integer :: xbegin, xend
    integer :: ybegin, yend

    ! check vector lengths

    vecsum = 0
    do i=1,vec1length
      vecsum = vecsum + vec1(i)
    enddo

    if (vecsum /= inX) then
      write(*,*) 'WARNING: inMatrix x-size inconsistent with x vector'
    endif

    vecsum = 0
    do i=1,vec2length
      vecsum = vecsum + vec2(i)
    enddo

    if (vecsum /= inY) then
      write(*,*) 'WARNING: inMatrix y-size inconsistent with y vector'
    endif

    ! we scan through the coarse grid
     do j=1,vec2length
       do i=1,vec1length

         ! determine index ranges
         xbegin = 1
         do ii=1,i-1
           xbegin = xbegin + vec1(ii)
         enddo
         xend = xbegin + vec1(i) - 1

         ybegin = 1
         do jj=1,j-1
           ybegin = ybegin + vec2(jj)
         enddo
         yend = ybegin + vec2(j) - 1

         ! index through the coarse grid and sum all elements
         tempsum = 0
         do jj=ybegin,yend
           do ii=xbegin,xend
             tempsum = tempsum + inMatrix(ii,jj)
           enddo
         enddo

         outMatrix(i,j) = tempsum

       enddo
     enddo

  end subroutine

  subroutine binMatrix_c(inMatrix, vec1, vec2, outMatrix, inX, inY, vec1length, vec2length)
    implicit none
    integer, intent(in) :: inX, inY, vec1length, vec2length

    complex(dp), dimension(inX, inY), intent(in) :: inMatrix
    complex(dp), dimension(vec1length, vec2length), intent(inout) :: outMatrix

    integer, dimension(vec1length), intent(in) :: vec1
    integer, dimension(vec2length), intent(in) :: vec2

    integer :: i,j
    integer :: ii,jj
    complex(dp) :: tempsum
    integer :: vecsum

    integer :: xbegin, xend
    integer :: ybegin, yend

    ! check vector lengths

    vecsum = 0
    do i=1,vec1length
      vecsum = vecsum + vec1(i)
    enddo

    if (vecsum /= inX) then
      write(*,*) 'WARNING: inMatrix x-size inconsistent with x vector'
    endif

    vecsum = 0
    do i=1,vec2length
      vecsum = vecsum + vec2(i)
    enddo

    if (vecsum /= inY) then
      write(*,*) 'WARNING: inMatrix y-size inconsistent with y vector'
    endif

    ! we scan through the coarse grid
     do j=1,vec2length
       do i=1,vec1length

         ! determine index ranges
         xbegin = 1
         do ii=1,i-1
           xbegin = xbegin + vec1(ii)
         enddo
         xend = xbegin + vec1(i) - 1

         ybegin = 1
         do jj=1,j-1
           ybegin = ybegin + vec2(jj)
         enddo
         yend = ybegin + vec2(j) - 1

         ! index through the coarse grid and sum all elements
         tempsum = 0
         do jj=ybegin,yend
           do ii=xbegin,xend
             tempsum = tempsum + inMatrix(ii,jj)
           enddo
         enddo

         outMatrix(i,j) = tempsum

       enddo
     enddo

  end subroutine

end module Mbinning


module ExampleOperators
  use Precision
  use AbstractOperators
  use DVectors

  private

  !! Derived type describing the 1d-Laplacian
  !! with periodic boundary conditions
  type, public, extends(abstract_operator) :: Laplacian
   contains
     procedure, public, pass :: init => init_LP
     !! procedure overrided
     procedure, public, pass :: apply =>  apply_LP
  end type Laplacian

  !! Derived type describing the 1d-Laplacian
  !! with periodic boundary conditions
  type, public, extends(abstract_operator) :: DiagonalMatrix
     double precision, allocatable :: coefficients(:)
   contains
     procedure, public, pass :: init => init_DM
     procedure, public, pass :: kill => kill_DM
     !! procedure overrided
     procedure, public, pass :: apply =>  apply_DM
  end type DiagonalMatrix

contains

  !! constructor
  subroutine init_LP(this, nnode)
    implicit none
    class(Laplacian),                intent(inout) :: this
    integer,                         intent(in   ) :: nnode

    !! the set domain/codomain operator dimension
    this%nrow = nnode
    this%ncol = nnode
    this%is_symmetric=.True.

  end subroutine init_LP

  !! apply tridiagonal operator
  subroutine apply_LP(this,vec_in,vec_out,ierr)
    implicit none
    class(Laplacian), intent(inout) :: this
    class(dvector),   intent(in   ) :: vec_in
    class(dvector),   intent(inout) :: vec_out
    integer,          intent(inout) :: ierr
    !local
    double precision :: sign=1.0d0, val
    integer :: i_row

    !! first row
    i_row=1
    val = 2*vec_in%get(i_row) + sign* vec_in%get(i_row+1)
    call vec_out%set(i_row,val)

    !! middle rowsuse DVectors
    do i_row=2,this%nrow-1
       val = sign * vec_in%get(i_row-1) + 2*vec_in%get(i_row) + sign* vec_in%get(i_row+1)
       call vec_out%set(i_row,val)
    end do

    !! last row
    i_row=this%nrow
    val = sign* vec_in%get(i_row-1) + 2*vec_in%get(i_row)
    call vec_out%set(i_row,val)

    ierr=0
  end subroutine apply_LP

  !! constructor
  subroutine init_DM(this, size)
    class(DiagonalMatrix),  intent(inout) :: this
    integer,                intent(in   ) :: size

    this%nrow = size
    this%ncol = size
    this%is_symmetric=.True.

    allocate(this%coefficients(size))

  end subroutine init_DM

  !! destructor
  subroutine kill_DM(this)
    class(DiagonalMatrix),  intent(inout) :: this

    this%nrow = 0
    this%ncol = 0
    this%is_symmetric=.False.

    deallocate(this%coefficients)

  end subroutine kill_DM

  !! apply diagonal matrix
  subroutine apply_DM(this,vec_in,vec_out,ierr)
    implicit none
    class(DiagonalMatrix),  intent(inout) :: this
    class(dvector),         intent(in   ) :: vec_in
    class(dvector),         intent(inout) :: vec_out
    integer,                intent(inout) :: ierr
    !local
    integer :: i_row
    double precision :: val

    do i_row=1,this%nrow
       val=vec_in%get(i_row)*this%coefficients(i_row)
       call vec_out%set(i_row,val)
    end do
    ierr=0

  end subroutine apply_DM

end module ExampleOperators


      COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 CDOTC  Krogh   Declared all vars.
C>> 1985-08-02 CDOTC  Lawson  Initial code.
C
C     RETURNS THE DOT PRODUCT FOR COMPLEX CX AND CY, USES CONJUGATE(CX)
C     CDOTC = SUM FOR I = 0 TO N-1 OF CONJ(CX(LX+I*INCX))*CY(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
      INTEGER N, INCX, INCY, KX, KY, I, NS
      COMPLEX CX(*),CY(*)
C
      CDOTC = (0.,0.)
      IF(N .LE. 0)RETURN
      IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20
      KX = 1
      KY = 1
      IF(INCX.LT.0) KX = 1+(1-N)*INCX
      IF(INCY.LT.0) KY = 1+(1-N)*INCY
          DO 10 I = 1,N
          CDOTC = CDOTC + CONJG(CX(KX))*CY(KY)
          KX = KX + INCX
          KY = KY + INCY
   10     CONTINUE
      RETURN
   20 CONTINUE
      NS = N*INCX
          DO 30 I=1,NS,INCX
          CDOTC = CONJG(CX(I))*CY(I) + CDOTC
   30     CONTINUE
      RETURN
      END


! This code is part of Radiative Transfer for Energetics (RTE)
!
! Contacts: Robert Pincus and Eli Mlawer
! email:  rrtmgp@aer.com
!
! Copyright 2015-2018,  Atmospheric and Environmental Research and
! Regents of the University of Colorado.  All right reserved.
!
! Use and duplication is permitted under the terms of the
!    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
! -------------------------------------------------------------------------------------------------
!
! test for mo_rte_spherical_correction module
! Igor Polonsky
! ipolonsk@aer.com
!
! reads test data file ref_data.dat
!

program test_bending
   use mo_rte_spherical_correction
   use mo_rte_kind, only: wp, wl
	implicit none

integer, parameter      :: nlev = 97 ! number of vertical levels
real(wp),parameter      :: RE = 6371.23 ! in [km]

real(wp), dimension(nlev)   :: temp, hum, RefIndex
!  no refraction
real(wp), dimension(nlev)   :: mu      ! solar zenith angle cosine
real(wp), dimension(nlev)   :: SZ      ! solar zenith angle
real(wp), dimension(nlev)   :: refSZ   ! reference solar zenith angle
!  with refraction
real(wp), dimension(nlev)   :: muRef      ! solar zenith angle cosine
real(wp), dimension(nlev)   :: SZref      ! solar zenith angle
real(wp), dimension(nlev)   :: refSZref   ! reference solar zenith angle
real(wp), dimension(nlev)   :: alt, p

real(wp), dimension(nlev)   :: refMu, refMuRef

logical(wl)             :: top_at_1     ! TOA atnosphere at index 1
logical(wl)             :: isError

integer                 :: jj
real(wp)                :: g0, zsurf, mu0, wavenumber, refRefIndex
!
! read meterological profile
open(100, file='ref_data.dat', action='read', status='old')
!  skip comments
do jj=1,5
	read(100,*)
enddo

do jj=1,nlev
	read(100,*) alt(jj), p(jj), temp(jj), hum(jj), szRef(jj), refSZref(jj)
enddo
!  convert to [g/g]
hum=hum*1e-3
close(100)

! initial condition
!  solar zenith anle is 90 at surface
!  wavelength is 500 nm

mu0 = cos(acos(-1d0)/180_wp*90_wp)
wavenumber = 1e4/0.5

top_at_1 = p(1) < p(2)
!  compute index of refraction

call indexRefraction(nlev, temp, p, hum, wavenumber, RefIndex)

if (top_at_1)  then
   refRefIndex = RefIndex(nlev)
   zsurf = alt(nlev)
else
   refRefIndex = RefIndex(1)
   zsurf = alt(1)
endif

! compute solar zenith cosine without effect of refraction
call spherical_angles(nlev, zsurf, RE, alt, mu0, mu)

! compute solar zenith cosine including the effect of refraction
call spherical_angles(nlev, zsurf, RE, alt, mu0, muRef, refRefIndex, RefIndex)

! print out results
print *, ' altitude    SZA cosine    SZA cosine        SZA        SZA      Refractivity'
print *, '             no refrac.    with refrac.     no ref.   with ref.   (n-1)*1e6'
print *, '     [km]                                   [deg]      [deg]     [ppm]'

do jj=1, nlev
	print '(4x, f6.3, 2(2x,E12.4), 3(4x, F7.2))', alt(jj), mu(jj), muRef(jj), 180_wp/acos(-1.)*acos(mu(jj)), &
	     & 180_wp/acos(-1.)*acos(muRef(jj)), (RefIndex(jj) - 1.)*1e6
enddo
print *,''
print *, 'Compare with reference:'

!  compare with reference vaules
SZ = 180_wp/acos(-1.)*acos(mu)
isError = any(abs(SZ-szRef) > 1e-6)

if (isError) then
	print *, 'bias in solar zenith angle (no refration)'
   print *, "level     angle       ref.angle        bias"
	do jj =1, nlev
      if (abs(SZ(jj)-szRef(jj)) > 1e-6) &
           print "(I6, 3(F12.6, 2x)  )", jj, SZ(jj), szRef(jj), SZ(jj) - szRef(jj)
	enddo
else
	print *, '  solar zenith angle (no refration)  : PASSED'
endif

SZref = 180_wp/acos(-1.)*acos(muRef)

if (any(abs(SZref-refSZref) > 1e-6)) then
	print *, 'bias in solar zenith angle (with refration)'
   print *, "level     angle       ref.angle        bias"
	do jj =1, nlev
		if (abs(SZref(jj)-refSZref(jj)) > 1e-6) print "(I6, 3(F12.6, 2x)  )", jj, SZref(jj), &
                      refSZref(jj), SZref(jj) - refSZref(jj)
	enddo
else
	print *, '  solar zenith angle (with refration): PASSED'
endif
end program test_bending