! ------------------------------------------------------------------------------
! DIFFUSION_COEFFICIENTS
! Compute atomic diffusion coefficients, according to Paquette et al. 1986
!
! This function only calculates the first order coefficients at the moment,
! but calculating the second order corrections (as well as the coefficient
! for thermodiffusion) is not difficult.
! ------------------------------------------------------------------------------
! Input:
!  * rho:      Density [g/cm^3]
!  * T:        Temperature
!  * abund:    Abundance struct
! Output:
!  * Ddiff(9): Diffusion coefficients [cm^2/s] for the 9 isotopes H, He, C,
!              n, O, Ne, Mg, Si and Fe.
! ------------------------------------------------------------------------------
subroutine diffusion_coefficients(rho, T, abund, Ddiff, Nref)
   use real_kind
   use constants
   use paquette_coefficients
   use atomic_data
   use eostate_types

   implicit none
  ! Input and output variables
   real(double), intent(in) :: rho, T
   type(abundance), intent(in) :: abund
   real(double), intent(out) :: Ddiff(9)
   integer, intent(in) :: Nref            ! Reference abundance (H)
  ! Local variables
  ! Lengthscales for the plasma
   real(double) :: lambda_I2, lambda_D2, lambda2
  ! Baryon density
   real(double) :: Nb
  ! Convenience, to precalculate as much as possible
   real(double) :: kT, gamma2
  ! Collision integrals Omega (eqn. (18) in Paquette et al)
   real(double) :: OMEGA1(3), OMEGA22
  ! Dimensionless collision integrals (eqn. (65) in Paquette et al)
   real(double) :: F1(3), F22
  ! Local variables
   real(double) :: psi_st, eps_st, gamma_st2, A, e_psi_st
   real(double) :: dpsi_n1, dpsi_n
   integer :: i, j, n
  ! Local copy of struct variables
   real(double) :: NA(9), NIO, NZZ, AVM, Ne

   na = abund%na
   nio = abund%nio
   nzz = abund%nzz
   avm = abund%avm
   na = abund%na
   Ne = abund%ne

   Nb = rho/(AVM*AMU)
   kT = BOLTZM*T

  !     Typical distance between ions (squared)
   lambda_I2 = (3.0/(CPI4*Nb*NIO))**(2.0D0*C3RD)
  !     Debye length (squared)
   lambda_D2 = (kT/(CPI4 * ECHAR**2 * Nb * (NZZ+Ne)))
  !     Use max of lambda_i and lambda_D as typical distance
   lambda2 = MAX(lambda_D2, lambda_I2)
  !     Precompute some factors
   gamma2 = (4.0*kT/(ECHAR**2*KZN(Nref)))**2*lambda2
   do i=1, 9
      gamma_st2 = gamma2/KZN(i)**2
     !        Reduced mass of the two particles
      A = (CAN(i)*CAN(Nref)/(CAN(i)+CAN(Nref)))
     !        Units of Omega: length^2 * velocity
      eps_st = CPI4*lambda2/gamma_st2 * SQRT(2.0D0*kT/(CPI4 * AMU*A))
     !        Find interpolation interval for dimensionless collision integral
      e_psi_st = log(1.0D0+gamma_st2)
      psi_st = log(e_psi_st)
     !        Evaluate the collision integral, for repulsive coefficients
      if (psi_st < 3.0D0) then
        !           Use spline interpolation to evaluate the collision integrals
        !           Determine interval in the table
         n = MIN(50, 1+floor((psi_st +7d0)/0.2d0))
         dpsi_n1 = (-7.0D0 + 0.2D0*(n+1)) - psi_st
         dpsi_n = psi_st - (-7.0D0 + 0.2D0*n)
         do j=1,3
            F1(j) = exp(DC(1,n,j)*dpsi_n1**3 + DC(2,n,j)*dpsi_n**3  &
                + DC(3,n,j)*dpsi_n1    + DC(4,n,j)*dpsi_n)
         end do
         F22 = exp(DD(1,n)*dpsi_n1**3 + DD(2,n)*dpsi_n**3  &
             + DD(3,n)*dpsi_n1    + DD(4,n)*dpsi_n)
      else
         F1(1) = 1.00141D0*e_psi_st - 3.18209D0
         F1(2) = 0.99559D0*e_psi_st - 1.29553D0
         F1(3) = 1.99814D0*e_psi_st - 0.64413D0
         F22   = 1.99016D0*e_psi_st - 4.56958D0
      end if
      OMEGA1(:) = eps_st*F1(:)
      OMEGA22   = eps_st*F22

     !        Diffusion coefficient
      Ddiff(i) = 3.0*kT/(16.0*rho*(NA(Nref)+NA(i))*A*OMEGA1(1))
   end do
end subroutine diffusion_coefficients

! ------------------------------------------------------------------------------
! COMPUTE_FULL_DIFFUSION_COEFFS
! Compute atomic diffusion coefficients, according to Paquette et al. (1986)
! This is essentially the same as the above subroutine, but it computes
! extra terms needed for the Burgers formalism.
! The output are the resistance coefficients in Burgers equations K_ij,
! z_ij, z'_ij and z''_ij. It is also possible to output diffusion
! coefficients D_ij and thermal diffusion coeffcient A_th used in
! Cowling&Chapman formalism, note Ath(NN,i) is Ath_ei.
! ------------------------------------------------------------------------------
! Input:
! (rho         - Density [g/cm^3])
!  T           - Temperature [k]
!  NN          - Number of species (NN = electrons)
!  CAN(i)      - Mass numbers for species [amu]
!  KZN(i)      - Average charge of species [e]
!  NA(i)       - Number densities of species [cm^-3]
! Output:
!  Kdiff(i,j)  - Coefficient for Burgers equations
!  Zdiff(i,j)  - Coefficient for Burgers equations
!  Zdiff1(i,j) - Coefficient for Burgers equations
!  Zdiff2(i,j) - Coefficient for Burgers equations
! ------------------------------------------------------------------------------
!subroutine compute_full_diffusion_coeffs(rho, T, NN, CAN1, KZN1, NA1, Kdiff, Zdiff, Zdiff1, Zdiff2)  !Rho not used
subroutine compute_full_diffusion_coeffs(T, NN, CAN1, KZN1, NA1, Kdiff, Zdiff, Zdiff1, Zdiff2)
   use real_kind
   use constants
   use paquette_coefficients

   implicit none
  ! Input and output variables
   integer, intent(in) :: NN
   real(double), intent(in) :: T, CAN1(NN), KZN1(NN), NA1(NN)
   real(double), intent(out) :: Kdiff(NN,NN), Zdiff(NN,NN), Zdiff1(NN,NN), Zdiff2(NN,NN)

  ! Local variables
  ! Lengthscales for the plasma
   real(double) :: lambda_I2, lambda_D2, lambda2

  ! Ion density
   real(double) :: NI

  ! Convenience, to precalculate as much as possible
   real(double) :: kT, gamma2

  ! Collision integrals Omega (eqn. (18) in Paquette et al)
   real(double) :: OMEGA1(3), OMEGA22, OMEGA2(NN)

  ! Dimensionless collision integrals (eqn. (65) in Paquette et al)
   real(double) :: F1(3), F22

  ! Local variables
  !real(double) :: Ddiff(NN,NN), Ath(NN, NN)
   real(double) :: psi_st, eps_st, gamma_st2, A, e_psi_st
   real(double) :: AA, BB, CC, EE, Ps, Pt, Pst, Qs, Qt, Qst, Ss
   real(double) :: St, Ms, Mt, Xs, Xt
  !real(double) :: Xe, Me, Pe, Se, Qe, Qet, DELTA
   real(double) :: dpsi_n1, dpsi_n
   integer :: i, j, n, Nref
   real(double) :: NZZ, Ne
   real(double) :: kz(NN)

   F22 = 0.0d0  ! Always defined

   Ne = NA1(NN)
   NI = 0.0D0
   NZZ = 0.0D0
   do i = 1, NN-1
      NI = NI + NA1(i)
      NZZ = NZZ + KZN1(i)**2 * NA1(i)
   end do

  ! Charge, bearing in mind that some species might be neutral.
  ! In this case, we simply treat them as singly ionised.
  ! TODO: we could include a fudge-factor to scale the singly ionised cross
  ! section.
   kz = kzn1
   where (kz == 0) kz = 1

   kT = BOLTZM*T
  ! Typical distance between ions (squared)
   lambda_I2 = (3.0D0/(CPI4*NI))**(2.0D0/3.0D0)
  ! Debye length (squared)
   lambda_D2 = (kT/(CPI4 * ECHAR**2 * (Ne + NZZ)))
  ! Use max of lambda_i and lambda_d as typical distance
   lambda2 = MAX(lambda_D2, lambda_I2)

  ! First evaluate the collision intergrals OMEGA22_SS, that appear in Ps (eq (9) of Paquette 1986)
   do i = 1, NN
      gamma2 = (4.0D0*kT/(ECHAR**2*KZ(i)))**2*lambda2
      gamma_st2 = gamma2/KZ(i)**2

     ! Reduced mass of the two particles [amu]
      A = 0.5d0 * CAN1(i)

     ! Units of Omega: length^2 * velocity
      eps_st = CPI4*lambda2/gamma_st2 * SQRT(2.0D0*kT/(CPI4 * AMU*A))

     ! Find interpolation interval for dimensionless collision integral
     ! Use boundary value if out of range (may never happen)
      e_psi_st = log(1.0D0+gamma_st2)
      psi_st = MAX(-7.0d0, log(e_psi_st))

     ! Evaluate the collision integral
      if (psi_st <= 3.0D0) then
        ! Use spline interpolation to evaluate the collision integrals
        ! Determine interval in the table
         n = MIN(50, 1+floor((psi_st +7d0)/0.2d0))
         dpsi_n1 = (-7.2D0 + 0.2D0*(n+1)) - psi_st
         dpsi_n = psi_st - (-7.2D0 + 0.2D0*n)

        ! repulsive potential (ion-ion or electron-electron)
         F22 = exp(DD(1,n)*dpsi_n1**3 + DD(2,n)*dpsi_n**3  &
             + DD(3,n)*dpsi_n1    + DD(4,n)*dpsi_n)
      else if (psi_st > 3.0D0 .and. psi_st < 4.0d0) then
        ! repulsive potential (ion-ion or electron-electron)
         F22   = 1.99016D0*e_psi_st - 4.56958D0
      else
        ! repulsive and attractive coeffcients are the same in this range
         F22   = 1.99016D0*e_psi_st - 4.56958D0
      end if
      OMEGA2(i) = eps_st*F22
   end do    ! i

   do Nref = 1, NN
      gamma2 = (4.0D0*kT/(ECHAR**2*KZ(Nref)))**2 * lambda2
      do i = 1, NN
         gamma_st2 = gamma2/KZ(i)**2

        ! Reduced mass of the two particles:
         A = (CAN1(i)*CAN1(Nref)/(CAN1(i)+CAN1(Nref)))        ! in units of AMU

        ! Units of Omega: length^2 * velocity:
         eps_st = CPI4*lambda2/gamma_st2 * SQRT(2.0D0*kT/(CPI4 * AMU*A))

        ! Find interpolation interval for dimensionless collision integral:
         e_psi_st = log(1.0D0+gamma_st2)
         psi_st = log(e_psi_st)

        ! Evaluate the collision integral:
         if (psi_st <= 3.0D0) then

           ! If psi_st falls outside range of Paquette fit, then just take border value, will probably never happen:
            psi_st = MAX(-7.D0, psi_st)

           ! Use spline interpolation to evaluate the collision integrals
           ! Determine interval in the table
            n = MIN(50, 1+floor((psi_st +7d0)/0.2d0))
            dpsi_n1 = (-7.2D0 + 0.2D0*(n+1)) - psi_st
            dpsi_n = psi_st - (-7.2D0 + 0.2D0*n)
            if ((Nref==NN.and.Nref/=i) .or. (i==NN.and.Nref/=i)) then
              ! attractive potential (electron-ion)
               do j=1,3
                  F1(j) = exp(DCAT(1,n,j)*dpsi_n1**3 + DCAT(2,n,j)*dpsi_n**3  &
                      + DCAT(3,n,j)*dpsi_n1    + DCAT(4,n,j)*dpsi_n)
               end do
               F22 = exp(DDAT(1,n)*dpsi_n1**3 + DDAT(2,n)*dpsi_n**3  &
                   + DDAT(3,n)*dpsi_n1    + DDAT(4,n)*dpsi_n)
              ! repulsive potential (ion-ion or electron-electron)
            else
               do j=1,3
                  F1(j) = exp(DC(1,n,j)*dpsi_n1**3 + DC(2,n,j)*dpsi_n**3  &
                      + DC(3,n,j)*dpsi_n1    + DC(4,n,j)*dpsi_n)
               end do
               F22 = exp(DD(1,n)*dpsi_n1**3 + DD(2,n)*dpsi_n**3  &
                   + DD(3,n)*dpsi_n1    + DD(4,n)*dpsi_n)
            end if
         else if (psi_st > 3.0D0.and.psi_st < 4.0d0) then
            if ((Nref==NN.and.Nref/=i) .or. (i==NN.and.Nref/=i)) then
              ! attractive potential (electron-ion)
               F1(1) = 1.01101D0*e_psi_st - 3.19815D0
               F1(2) = 1.04230D0*e_psi_st - 1.89637D0
               F1(3) = 2.15672D0*e_psi_st - 2.81038D0
               F22   = 2.08699D0*e_psi_st - 5.81444D0
            else
              ! repulsive potential (ion-ion or electron-electron)
               F1(1) = 1.00141D0*e_psi_st - 3.18209D0
               F1(2) = 0.99559D0*e_psi_st - 1.29553D0
               F1(3) = 1.99814D0*e_psi_st - 0.64413D0
               F22   = 1.99016D0*e_psi_st - 4.56958D0
            end if
         else if (psi_st.ge.4.0D0) then
           ! repulsive and attractive coeffcients are the same in this range
            F1(1) = 1.00141D0*e_psi_st - 3.18209D0
            F1(2) = 0.99559D0*e_psi_st - 1.29553D0
            F1(3) = 1.99814D0*e_psi_st - 0.64413D0
            F22   = 1.99016D0*e_psi_st - 4.56958D0
         end if
         OMEGA1(:) = eps_st*F1(:)
         OMEGA22   = eps_st*F22                ! for particle species Nref & k

        ! Binary diffusion coefficient for Chapman and Cowling formalism (first approximation)
        !Ddiff(Nref, i) = 3.0D0*kT/(16.0D0*(NA1(Nref)+NA1(i))*(A*AMU)*OMEGA1(1))

         AA = OMEGA22/(5.D0*OMEGA1(1))
         BB = (5.D0*OMEGA1(2)-OMEGA1(3))/(5.D0*OMEGA1(1))
         CC = 2.D0*OMEGA1(2)/(5.D0*OMEGA1(1))-1.D0
         Xs = NA1(Nref)/(NA1(i)+NA1(Nref))                ! number concentration of reference species Nref
         Xt = NA1(i)/(NA1(i)+NA1(Nref))                   ! number concentration of species i
         Ms = CAN1(Nref)/(CAN1(Nref)+CAN1(i))
         Mt = CAN1(i)/(CAN1(Nref)+CAN1(i))
         Pst = 3.0D0*(Ms - Mt)**2 + 4.D0*Ms*Mt*AA
         EE = kT/(8.D0*Ms*Mt*OMEGA1(1))
         Ps = 8.D0*Ms*EE*OMEGA2(Nref)/(5.D0*kT)
         Pt = 8.D0*Mt*EE*OMEGA2(i)/(5.D0*kT)
         Ss = Ms*Ps-Mt*(3.D0*(Mt-Ms)+4.D0*Ms*AA)
         St = Mt*Pt-Ms*(3.D0*(Ms-Mt)+4.D0*Mt*AA)
         Qs = Ps*(6.D0*Mt*Mt + 5.D0*Ms*Ms - 4.D0*Ms*Ms*BB + 8.D0*Ms*Mt*AA)
         Qt = Pt*(6.D0*Ms*Ms + 5.D0*Mt*Mt - 4.D0*Mt*Mt*BB + 8.D0*Mt*Ms*AA)
         Qst = 3.D0*(Ms-Mt)**2*(5.D0-4.D0*BB) + 4.D0*Ms*Mt*AA*(11.D0-4.D0*BB) + 2.D0*Ps*Pt
        !DELTA = 5.0D0*CC*CC*(Ms*Ms*Ps*Xs*Xs + Mt*Mt*Pt*Xt*Xt + Pst*Xs*Xt)/(Xs*Xs*Qs + Xt*Xt*Qt + Xs*Xt*Qst)

        ! second approximation
        !Ddiff(Nref, i) = Ddiff(Nref, i)/(1.0D0 - DELTA)

        ! thermal coefficients
        !Ath(Nref,i) = 5.D0*CC*(Xs*Ss-Xt*St)/(Xs**2*Qs+Xt**2*Qt+Xs*Xt*Qst)
        ! resistance coefficients for Burgers equations
         Kdiff(Nref, i) = 16.D0/3.D0*NA1(Nref)*NA1(i)*(A*AMU)*OMEGA1(1)
         Zdiff(Nref, i) = -CC
         Zdiff1(Nref, i) = -2.D0*BB+2.5D0
         Zdiff2(Nref, i) = 5.D0*AA
      end do !i
   end do !k=Nref

end subroutine compute_full_diffusion_coeffs

! ------------------------------------------------------------------------------
! DIFFUSION_TERMS_BURGERS
!  Compute the diffusion coefficients by solving the Burgers equations,
!  using the subroutine of Thoul & al. (1994).
! ------------------------------------------------------------------------------
!  Input:
!   rho     - Density [g/cm^3]
!   T       - Temperature [k]
!   NN      - Number of particle species (not counting electrons)
!   n(i)    - Particle number densities [cm^-3]
!   Ne      - Electron number density [cm^-3]
!   grad(i) - radiative acceleration [cm/s^2]
!   Z(i)    - Average charge of particle species (partial ionisation)
!   A(i)    - Baryon number of particle species
!  Output (in cgs units):
!   AP(i)   - Pressure terms in the expression for the diffusion velocity
!   AT(i)   - Temperature terms in the expression for the diffusion velocity
!   AG(i)   - Radiative acceleration terms in the expression for the diffusion velocity
!   AC(i,j) - composition terms in the expression for the diffusion velocity
! ------------------------------------------------------------------------------
subroutine diffusion_terms_burgers(rho,T,NN,n,Ne, grad, Z,A, AP,AT,AG,AC)
   use real_kind
   use constants

   implicit none
   integer, intent(in) :: NN
   real(double), intent(in) :: rho, T, n(NN), Ne, grad(NN), Z(NN), A(NN)
   real(double), intent(out) :: AP(NN), AT(NN), AG(NN), AC(NN, NN)
  !     Local variables
   real(double) :: C(NN+1)      ! Concentration
  !     Permutation of particle numbers, needed because the solver can only
  !     deal with species that have C(i) > 0
   integer :: Ndiff
   integer, allocatable :: NP(:)
   real(double), allocatable :: NX(:), gradx(:), AA(:), ZZ(:)
   real(double), allocatable :: AAP(:), AAT(:), AAG(:), AAC(:, :)
  !     Diffusion coefficients, for Burgers equations
   real(double), allocatable :: Kdiff(:, :), Zdiff(:, :)
   real(double), allocatable :: Zdiff1(:, :), Zdiff2(:, :)
  !     Miscellaneous
   real(double) :: u;
   integer :: i, j

   ! Allocate permutation array
   allocate(NP(NN+1))

  !     Initialise all return values to 0
   AP(:) = 0.0d0
   AT(:) = 0.0d0
   AG(:) = 0.0d0
   AC(:,:) = 0.0d0

  !     Eliminate elements that are not present (or have very small abundances)
   Ndiff = 0
   do i = 1, NN
      if (n(i) > 1.0d-10) then
         Ndiff = Ndiff+1
         NP(Ndiff) = i;
      end if
   end do

  !     We need to have at least two species to calculate diffusion
   if (Ndiff < 2) then
      deallocate(NP)
      return
   end if

  !     We have one additional species: electrons
   Ndiff = Ndiff+1

   ! Allocate memory for the temporary arrays.
   allocate(NX(Ndiff))
   allocate(gradX(Ndiff))
   allocate(AA(Ndiff))
   allocate(ZZ(Ndiff))
   allocate(AAP(Ndiff))
   allocate(AAT(Ndiff))
   allocate(AAG(Ndiff))
   allocate(AAC(Ndiff, Ndiff))
   allocate(Kdiff(Ndiff,Ndiff))
   allocate(Zdiff(Ndiff,Ndiff))
   allocate(Zdiff1(Ndiff,Ndiff))
   allocate(Zdiff2(Ndiff,Ndiff))

  !     Copy data to temporary arrays of appropriate size
   do i = 1, Ndiff-1
      NX(i) = n(NP(i))
      gradX(i) = grad(NP(i)) / (CR*T)
      AA(i) = A(NP(i))
      ZZ(i) = Z(NP(i))
   end do
  !     Add electrons
   NX(Ndiff) = Ne
   AA(Ndiff) = AME/AMU
   ZZ(Ndiff) = -1.0d0
   gradX(Ndiff) = 0.0d0

  !     Concentrations, relative to electrons
   C(1:Ndiff) = NX(1:Ndiff) / Ne

  !     Compute atomic diffusion coefficients, Paquette et al. (1986)
   Kdiff(:,:) = 0.0d0
   Zdiff(:,:) = 0.0d0
   Zdiff1(:,:) = 0.0d0
   Zdiff2(:,:) = 0.0d0

  !call compute_full_diffusion_coeffs(rho, T, Ndiff, AA, ZZ, NX, Kdiff, Zdiff, Zdiff1, Zdiff2)  !Rho not used
   call compute_full_diffusion_coeffs(T, Ndiff, AA, ZZ, NX, Kdiff, Zdiff, Zdiff1, Zdiff2)

  !     Kdiff = kappa, equation (37) of Thoul et al. (1994)
   Kdiff(:,:) = Kdiff(:,:) * T**1.5 / (1.41d-25*NX(Ndiff)**2)

  !     Find pressure, temperature and composition terms for diffusion velocities
   call diffusion_screened(Ndiff, AA, ZZ, C, gradX, Kdiff, Zdiff, Zdiff1, Zdiff2,  &
       AAP(1:Ndiff), AAT(1:Ndiff), AAG(1:Ndiff), AAC(1:Ndiff,1:Ndiff))

  !     Fix units: solar radii, 1e7 k, 1e2 g/cm^2, 6e13 years
   u = (T/1.0D7)**2.5/(rho/1.0D2) * (CRSN*1.0D11)**2/(6.D13*CSY)
   AAP(1:Ndiff) = AAP(1:Ndiff) * u
   AAT(1:Ndiff) = AAT(1:Ndiff) * u
   AAG(1:Ndiff) = AAG(1:Ndiff) * u
   AAC(1:Ndiff,1:Ndiff) = AAC(1:Ndiff,1:Ndiff) * u

  !     Unscramble the results, don't include electrons (we're not treating
  !     them separately anyway)
   do i = 1, Ndiff-1
      AP(NP(i)) = AAP(i)
      AT(NP(i)) = AAT(i)
      AG(NP(i)) = AAG(i)
      do j = 1, Ndiff-1
         AC(NP(i),NP(j)) = AAC(i, j)
      end do
   end do

   deallocate(NP)
   deallocate(NX)
   deallocate(AA)
   deallocate(ZZ)
   deallocate(AAP)
   deallocate(AAT)
   deallocate(AAG)
   deallocate(AAC)
   deallocate(Kdiff)
   deallocate(Zdiff)
   deallocate(Zdiff1)
   deallocate(Zdiff2)
end subroutine diffusion_terms_burgers

!> ------------------------------------------------------------------------------
!! DIFFUSION_SCREENED
!!  Calculate diffusion coefficients by solving Burgers' equations.
!!
!! This routine was originally written by Anne A. Thoul, at the Institute
!! for Advanced Study, Princeton, NJ 08540.
!! See Thoul et al., Ap.j. 421, p. 828 (1994)
!! The subroutines LU_BACK_SUBSTITUTION and LU_DECOMPOSITION are based on
!! Numerical Recipes.
!!
!! \todo FIXME: replace these with LAPACK functions, which are free. See the
!! equivalent subroutine in MESA to see how this should be done.
!!
!! It has been updated to solve the Burgers
!! equations with resistance coefficients from a screened Coulomb
!! potential (Paquette et al 1986) instead of a pure Coulomb potential,
!! by Hu&al 2009
!!
!! The system contains n equations with n unknowns.
!! The equations are: the M momentum equations,
!!                    the M energy equations,
!!                    two constraints: the current neutrality
!!                                     the zero fluid velocity.
!! The unknowns are: the M diffusion velocities,
!!                   the M heat fluxes,
!!                   the electric field E
!!                   the gravitational force g.
!! ------------------------------------------------------------------------------
!!  Input:
!!     M                    - Number of atomic species to consider (+electrons)
!!     A(1:M)               - Atomic mass numbers
!!     Z(1:M)               - Average charge for this species (from Saha equation)
!!     C(1:M)               - Concentrations (by number/electron)
!!     G(1:M)               - radiative acceleration term, -AMU*g_rad(i)/kT
!!     k(1:M, 1:M)          - Relative diffusion coefficients for species i against j
!!     Zdiff(1:M, 1:M)      - Relative diffusion coefficients for species i against j
!!     Zdiff1(1:M, 1:M)     - Relative diffusion coefficients for species i against j
!!     Zdiff2(1:M, 1:M)     - Relative diffusion coefficients for species i against j
!!     See Hu & al. eq (1) and (2) for the definition of these coefficients
!!  Output:
!!     AP(1:M)              - Coefficient for pressure term in diffusion equation
!!     AT(1:M)              - Coefficient for temperature term in diffusion equation
!!     AG(1:M)              - Extra term for radiative levitation in diffusion equation
!!     AX(1:M,1:M)          - Coefficient for composition term in diffusion equation
!!     See (3)  of Thoul et al (1994). Take care of the units!
!! ------------------------------------------------------------------------------
!<
subroutine diffusion_screened(M, A, Z, C, G, k, Zdiff, Zdiff1, Zdiff2, AP, AT, AG, AX)
  ! Note that kappa_st is obtained from the resistance coefficient Kdiff with eq (37) Thoul&al.
  ! The vector AP, AT, and array AX contains the results for the diffusion
  ! coefficients used in eq 3  of Thoul et al (1994). Take care of the units!
  ! Warning: this routine does not allow species with 0 mass fraction,
  ! so make sure you leave them out!

   use real_kind

   implicit none
   integer, intent(in) :: M
   real(double), intent(in) :: A(M), Z(M), C(M), G(M), k(M,M), Zdiff(M,M), Zdiff1(M,M), Zdiff2(M,M)
   real(double), intent(out) :: AP(M), AT(M), AG(M), AX(M,M)
   integer :: n, i, j, L
   integer indx(2*m+2)
   real(double) :: CC, AC
   real(double), allocatable :: XX(:, :), YY(:, :)
   real(double), allocatable :: alpha(:), beta(:), nu(:), gamma(:, :), delta(:, :), ga(:)
   real(double) :: KO, D

  ! The vector C contains the concentrations
  ! CC is the total concentration: CC=sum(C_s)
  ! AC is proportional to the mass density: AC=sum(A_s C_s)
  ! The arrays XX, YY and k are various parameters which appear in
  ! Burgers equations.
  ! The vectors and arrays ALPHA, NU, gamma, DELTA, and GA represent
  ! the "right- and left-hand-sides" of Burgers equations, and later
  ! the diffusion coefficients.

  ! Initialise parameters:
   KO = 2.D0
   n = 2*M + 2

   ! Allocate data structures
   allocate(XX(M, M))
   allocate(YY(M, M))
   allocate(alpha(2*M+2))
   allocate(beta(2*M+2))
   allocate(nu(2*M+2))
   allocate(gamma(2*M+2, 2*M+2))
   allocate(delta(2*M+2, 2*M+2))
   allocate(ga(2*M+2))

  ! Calculate CC and AC:
   cc = sum(C(:))
   ac = dot_product(A(:), C(:))

  ! Calculate the coefficients of the burgers equations
   do i = 1, m
      do j = 1, m
         xx(i,j) = A(j)/(A(i) + A(j))
      end do
   end do
   do i = 1, m
      do j = 1, m
         yy(i,j) = 3.0d0 * xx(j,i) + zdiff1(i,j) * xx(i,j) * A(j)/A(i)
      end do
   end do

  ! Write the burgers equations and the two constraints as
  ! alpha_s dp + nu_s dT + sum_t(not 2 or M) gamma_st dC_t
  !                     = sum_t delta_st w_t
  ! Note that we do *not* eliminate the He gradient, as in the original
  ! subroutine.
   do i = 1, m
      alpha(i) = C(i)/cc
      beta(i) = G(i) * alpha(i) * A(i)
      nu(i) = 0.d0
      gamma(i,1:m) = 0.d0
      do j = 1, m-1
         gamma(i,j) = -C(j)/cc
         if (j == i) then
            gamma(i,j) = gamma(i,j) + 1.d0
         end if
         gamma(i,j) = gamma(i,j)*C(i)/cc
      end do

      gamma(i,m+1:n) = 0.d0
   end do

   alpha(m+1:n) = 0.d0
   beta(m+1:n) = 0.d0
   do i = m+1, n-2
      nu(i) = 2.5d0 * C(i-m)/cc
   end do
   nu(n-1:n) = 0.d0
   gamma(m+1:n,1:n) = 0.d0
   delta(1:n,1:n)=0.d0

   do i = 1, m
      do j = 1, m
         if (j == i) then
            do l = 1, m
               if(l /= i) then
                  delta(i,j) = delta(i,j) - k(i,l)
               end if
            end do
         else
            delta(i,j) = k(i,j)
         end if
      end do

      do j = M+1, n-2
         if(j-M == i) then
            do L = 1, M
               if (L /= i) then
                  delta(i,j) = delta(i,j) + Zdiff(i,L)*XX(i,L)*k(i,L)
               end if
            end do
         else
            delta(i,j) = -Zdiff(i,j-M)*xx(j-M,i)*k(i,j-M)
         end if
      end do

      delta(i,n-1) = C(i)*Z(i)

      delta(i,n) = -C(i)*A(i)
   end do

   do i = M+1, n-2
      do j = 1, M
         if (j == i-M) then
            do L = 1, M
               if (L /= i-M) then        ! pure C potential
                  delta(i,j) = delta(i,j) + 2.5D0*Zdiff(i-M,L)*XX(i-M,L)*k(i-M,L)
               end if
            end do
         else                             ! pure C potential
            delta(i,j) = -2.5D0*Zdiff(i-M,j)*XX(i-M,j)*k(i-M,j)
         end if
      end do

      do j = M+1, n-2
         if (j-M == i-M) then
            do L = 1, M
               if (L /= i-M) then         ! pure C potential
                  delta(i,j) = delta(i,j) - xx(L,i-M)*k(i-M,L)*  &
                      (0.8D0*Zdiff2(i-M,L)*XX(i-M,L) + YY(i-M,L))
               end if
            end do                         ! pure C potential
            delta(i,j) = delta(i,j) - 0.4D0*Zdiff2(i-M,i-M)*k(i-M,i-M)
         else                             ! pure C potential
            delta(i,j) = (3.D0 + Zdiff1(i-M,j-M) - 0.8D0*Zdiff2(i-M,j-M))*k(i-M,j-M)*XX(i-M,j-M)*xx(j-M,i-M)
         end if
      end do

      delta(i,n-1) = 0.D0
      delta(i,n) = 0.D0
   end do

   delta(n-1,1:M) = C(1:M)*Z(1:M)
   delta(n-1,M+1:n) = 0.D0

   delta(n,1:m) = C(1:m)*DNINT(A(1:m)) ! Diffusion velocities are for baryon fractions and not mass fractions
   delta(n,M+1:n) = 0.D0

  ! Invert the system for each possible right-hand-side, i.e.,
  ! if alpha is the r.h.s., we obtain the coefficient A_p
  ! if nu    ---------------------------------------- A_T
  ! if beta  ---------------------------------------- A_g
  ! if gamma(i,j) ----------------------------------- A_Cj
  !
  ! If i=1, we obtain the hydrogen diffusion velocity
  ! If i=2, ------------- helium   ------------------
  ! If i=3,M-1, --------- heavy element -------------
  ! If i=M, ------------- electrons -----------------
  ! Is it necessary to keep the elements in this order? i think not (HH)
  ! For i=M,2M, we get the heat fluxes
  ! For i=n-1, we get the electric field
  ! For i=n, we get the gravitational force g

  ! delta is now LU decomposition of the original matrix
   call lu_decomposition      (delta, n, n, indx, d)

  ! LU decomposition of delta is output to delta
   call lu_back_substitution  (delta, n, n, indx, alpha)
   call lu_back_substitution  (delta, n, n, indx, nu)
   call lu_back_substitution  (delta, n, n, indx, beta)
   do j = 1, n
      ga(1:n) = gamma(1:n,j)
      call lu_back_substitution(delta, n, n, indx, ga)
      gamma(1:n,j) = ga(1:n)
   end do

  ! The results for the coefficients must be multiplied by p/K_0:
   AP(1:M) = alpha(1:M)*KO*AC*CC
   AT(1:M) = nu(1:M)*KO*AC*CC
   AG(1:M) = beta(1:M)*KO*AC*CC
   AX(1:M,1:M) = gamma(1:M,1:M)*KO*AC*CC

   deallocate(XX)
   deallocate(YY)
   deallocate(ALPHA)
   deallocate(beta)
   deallocate(NU)
   deallocate(gamma)
   deallocate(DELTA)
   deallocate(GA)
end subroutine diffusion_screened

subroutine lu_back_substitution(A,n,NP,INDX,B)
   use real_kind
   implicit none

  !     .. Scalar Arguments ..
   integer :: n,NP
  !     ..
  !     .. Array Arguments ..
   real(double) :: A(NP,NP),B(n)
   integer :: INDX(n)
  !     ..
  !     .. Local Scalars ..
   real(double) :: SUM
   integer i,II,j,LL
  !     ..
   II = 0

   do i = 1,n
      LL = INDX(i)
      SUM = B(LL)
      B(LL) = B(i)
      if (II /= 0) then
         do j = II,i - 1
            SUM = SUM - A(i,j)*B(j)
         end do

      else if (SUM /= 0.D0) then
         II = i
      end if

      B(i) = SUM
   end do

   do i = n,1,-1
      SUM = B(i)
      if (i < n) then
         do j = i + 1,n
            SUM = SUM - A(i,j)*B(j)
         end do
      end if

      B(i) = SUM/A(i,i)
   end do
end subroutine lu_back_substitution

subroutine lu_decomposition(A,n,NP,INDX,D)
   use real_kind
   implicit none

  !     .. parameters ..
   real(double), parameter :: TINY=1.0D-20
  !     ..
  !     .. Scalar Arguments ..
   real(double) :: D
   integer :: n,NP
  !     ..
  !     .. Array Arguments ..
   real(double) :: A(NP,NP)
   integer :: INDX(n)
  !     ..
  !     .. Local Scalars ..
   real(double) :: AAMAX,DUM,SUM
   integer :: i,IMAX,j,k
  !     ..
  !     .. Local Arrays ..
   real(double), allocatable :: VV(:)
  !     ..
  !     .. Intrinsic Functions ..
   intrinsic dabs
  !     ..

   allocate(VV(n))

   imax = 1
   D = 1.D0
   do i = 1,n
      AAMAX = 0.D0
      do j = 1,n
         if (abs(A(i,j)) > AAMAX) AAMAX = abs(A(i,j))
      end do
     !if (AAMAX == 0.D0) PAUSE 'Singular matrix.'
      if (AAMAX == 0.D0) write(0,'(A)') 'Singular matrix in lu_decomposition()'  !> \todo Is a reason to stop the code?
      VV(i) = 1./AAMAX
   end do

   do j = 1,n
      if (j > 1) then
         do i = 1,j - 1
            SUM = A(i,j)
            if (i > 1) then
               do k = 1,i - 1
                  SUM = SUM - A(i,k)*A(k,j)
               end do
               A(i,j) = SUM
            end if

         end do
      end if

      AAMAX = 0.D0
      do i = j,n
         SUM = A(i,j)
         if (j > 1) then
            do k = 1,j - 1
               SUM = SUM - A(i,k)*A(k,j)
            end do
            A(i,j) = SUM
         end if

         DUM = VV(i)*abs(SUM)
         if (DUM.GE.AAMAX) then
            IMAX = i
            AAMAX = DUM
         end if

      end do

      if (j /= IMAX) then
         do k = 1,n
            DUM = A(IMAX,k)
            A(IMAX,k) = A(j,k)
            A(j,k) = DUM
         end do
         D = -D
         VV(IMAX) = VV(j)
      end if

      INDX(j) = IMAX
      if (j /= n) then
         if (A(j,j) == 0.D0) A(j,j) = TINY
         DUM = 1./A(j,j)
         do i = j + 1,n
            A(i,j) = A(i,j)*DUM
         end do
      end if

   end do

   if (A(n,n) == 0.D0) A(n,n) = TINY

   deallocate(vv)

end subroutine lu_decomposition


program main
    use LinearSolverClass
    use IOClass
    implicit none

    ! Create Ax=B and solve x = A^(-1) B
    !integer(int32), parameter :: N = 4
    integer(int32), parameter :: NN=10000! rank
    real(real64)  :: t1,t2 ! time measure
    !real(real64) :: A(1:N,1:N), B(1:N), X(1:N) ! A, x and B
    !real(real64) :: Val(1:10)
    !integer(int32) :: index_i(1:10),index_j(1:10)
    real(real64)  ,allocatable :: Val_c(:)
    integer(int32),allocatable :: index_i_c(:),index_j_c(:)
    integer(int32) :: i,m,k,j
    real(real64) :: Amat(NN,NN),bvec(NN),xvec(NN)
    type(LinearSolver_) :: solver ! linear solver instance.
    type(IO_) :: f
    type(Random_) ::rdm

    call rdm%init()
    !call f%open("Amat.txt")
    do i=1,size(Amat,1)
        Amat(i,i)=rdm%random()+10.0d0
    enddo
    do i=1,size(Amat,1)-1
        Amat(i,i+1)=Amat(i,i+1)+rdm%random()+1.0d0
        Amat(i+1,i)=Amat(i+1,i)+rdm%random()+2.0d0
    enddo
    do i=1,NN
        Bvec(i)=rdm%random()+2.0d0
    enddo
    !call f%close()
    xvec(:)=0.0d0
    m=0
    do i=1,size(Amat,1)
        do j=1,size(Amat,1)
            if(Amat(i,j)/=0.0d0 )then
                m=m+1
            endif
        enddo
    enddo
    allocate(val_c(m) )
    allocate(index_i_c(m) )
    allocate(index_j_c(m) )

    m=0
    do i=1,size(Amat,1)
        do j=1,size(Amat,1)
            if(Amat(i,j)/=0.0d0 )then
                m=m+1
                val_c(m)=Amat(i,j)
                index_i_c(m) = i
                index_j_c(m) = j
            endif
        enddo
    enddo
!    ! creating A, x, and B
!    A(1:4,1) = (/  2.0d0, -1.0d0,  0.0d0, 0.0d0 /)
!    A(1:4,2) = (/ -1.0d0,  2.0d0, -2.0d0, 0.0d0 /)
!    A(1:4,3) = (/  0.0d0, -1.0d0,  3.0d0, 2.0d0 /)
!    A(1:4,4) = (/  0.0d0,  0.0d0,  2.0d0, 5.0d0 /)
!
!!    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
!
!    B(1:4)   = (/  1.0d0,  2.0d0,  3.0d0, 4.0d0 /)
!
!    ! CRS-format
!    Val(1:10) = (/  2.0d0, -1.0d0,  -1.0d0,  2.0d0, -2.0d0, -1.0d0, -3.0d0, &
!        2.0d0, 2.0d0,  5.0d0/)
!    index_i(1:10) = (/ 1, 1, 2, 2, 2, 3, 3, 3, 4, 4/)
!    index_j(1:10) = (/ 1, 2, 1, 2, 3, 2, 3, 4, 3, 4/)
    ! import Ax=B into the linear solver instance.
    call solver%import(a = Amat, x = Xvec, b = Bvec)

    ! get a cpu-time
    call cpu_time(t1)
    ! solve Ax=B by Gauss-Jordan
    call solver%solve(Solver="GaussJordan")
    ! get a cpu-time
    call cpu_time(t2)
    ! show result
    ! X is stored in solver%X(:) (solver.x[])
    print *, "Solved by GaussJordan","/",t2-t1," sec."

    ! Similarly ...

!    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = Amat, x = Xvec, b = Bvec, val=val_c, index_i=index_i_c, index_j=index_j_c)
    call cpu_time(t1)
    call solver%solve(Solver="GaussSeidel")
    call cpu_time(t2)
    !print *, "Solved by GaussSeidel",solver%X(:),"/",t2-t1," sec."
    print *, "Solved by GaussSeidel","/",t2-t1," sec."

!    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = Amat, x = Xvec, b = Bvec, val=val_c, index_i=index_i_c, index_j=index_j_c)
    call cpu_time(t1)
    call solver%solve(Solver="BiCGSTAB",CRS=.true.)
    call cpu_time(t2)
    !print *, "Solved by BiCGSTAB(CRS)",solver%X(:),"/",t2-t1," sec."
    print *, "Solved by BiCGSTAB(CRS)","/",t2-t1," sec."

!    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = Amat, x = Xvec, b = Bvec, val=val_c, index_i=index_i_c, index_j=index_j_c)
    call cpu_time(t1)
    call solver%solve(Solver="BiCGSTAB",CRS=.false.)
    call cpu_time(t2)
    !print *, "Solved by BiCGSTAB   ",solver%X(:),"/",t2-t1," sec."
    print *, "Solved by BiCGSTAB   ","/",t2-t1," sec."
!    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = Amat, x = Xvec, b = Bvec)
    call cpu_time(t1)
    call solver%solve(Solver="GPBiCG")
    call cpu_time(t2)
    !print *, "Solved by GPBiCG     ",solver%X(:),"/",t2-t1," sec."
    print *, "Solved by GPBiCG     ","/",t2-t1," sec."

    ! Under construction!
    !X(1:3)   = (/  0.0d0,  0.0d0,  0.0d0 /)
    !call solver%import(a = A, x = X, b = B)
    !call cpu_time(t1)
    !call solver%solve(Solver="GPBiCG",preconditioning=.true.)
    !call cpu_time(t2)
    !print *, "Solved by pre-GPBiCG ",solver%X(:),"/",t2-t1," sec."
end program


module ising_framework
    implicit none
contains
    subroutine ising(L, T, next_I, prev_I, MCS, m, chi, C)
    implicit none
    INTEGER (kind=4),intent(in) :: L, MCS, next_I(L), prev_I(L)
    real (kind=8), INTENT(IN) :: T
    real (kind=8), intent(out) :: m, chi, C
    integer (kind=4):: lattice(L,L), i,j,k, delta_E, no_of_probes
    real (kind=8) :: boltzmann_factor(5), E=0.0d0, m_k=0.0d0, magnetizations = 0.0d0, magnetizations2 = 0.0d0, energies=0.0d0,&
             energies2=0.0d0, r

    no_of_probes=(MCS-30000)/100
    lattice = 1

    do i=-8,8,4
        boltzmann_factor(i/4 + 3) = exp(-i / T)
    end do

    magnetizations = 0.0d0
    magnetizations2 = 0.0d0
    energies = 0.0d0
    energies2 = 0.0d0
    do k=1, MCS
        do j=1, L
            do i=1, L
                delta_E = 2 * lattice(i,j) * (lattice(next_I(i),j) + lattice(prev_I(i),j) + &
                                                lattice(i,next_I(j)) + lattice(i, prev_I(j)))
                if (delta_E <= 0) then
                    lattice(i,j) = -lattice(i,j)
                else
                    call random_number(r)
                    if (r <= boltzmann_factor(delta_E/4 + 3)) then
                        lattice(i,j) = -lattice(i,j)
                    end if
                end if
            end do
        end do

        if ((30000 < k) .and. (mod(k,100)==0)) then
            m_k = 0.0d0
            E = 0.0d0
            do j=1,L
                do i=1,L
                    m_k = m_k + lattice(i,j)
                    E = E + lattice(i,j) * (lattice(next_I(i),j) + lattice(i,next_I(j)))
                end do
            end do
            m_k = abs(m_k / L**2)
            magnetizations = magnetizations + m_k
            magnetizations2 = magnetizations2 + m_k**2
            energies = energies + E
            energies2 = energies2 + E**2
        end if
    end do
    m = magnetizations / no_of_probes
    chi = L**2 / T * (magnetizations2 - magnetizations**2 / no_of_probes)/no_of_probes
    C = (energies2 - energies**2 / no_of_probes)/no_of_probes / L**2 / T**2
    end subroutine ising
end module ising_framework

program ising2d
    use ising_framework
    implicit none
    INTEGER (kind=4), PARAMETER :: MCS=230000, L=20, no_of_probes=(MCS-30000)/100
    REAL(kind=8), PARAMETER :: T1=0.5d0, T2=3.5d0, dT=0.1d0
    INTEGER(kind=4) :: next_I(L), prev_I(L), i
    real(kind=8) :: T, m, chi, C

    do i=1,L
        next_I(i) = i+1
        prev_I(i) = i-1
    end do
    next_I(L) = 1
    prev_I(1) = L

    OPEN(1, file="m.dat")
    OPEN(2, file="chi.dat")
    OPEN(3, file="C.dat")

    !trzeba zmienić taktykę z while na for, żeby wrzucić do openmp
    T=T1
    do
        if (T>T2) exit
        T = T + dT
        call ising(L, T, next_I, prev_I, MCS, m, chi, C)
        WRITE(1,*) T, m
        WRITE(2,*) T, chi
        WRITE(3,*) T, C
    end do

end program ising2d


!Program to test EXPONENT and FRACTION intrinsic function.

program test_exponent_fraction
  real x
  integer*4 i
  real*8 y
  integer*8 j
  equivalence (x, i), (y, j)

  x = 3.
  call test_4(x)

  x = 0.
  call test_4(x)

  i = o'00000000001'
  call test_4(x)

  i = o'00010000000'
  call test_4(x)

  i = o'17700000000'
  call test_4(x)

  i = o'00004000001'
  call test_4(x)

  i = o'17737777777'
  call test_4(x)

  i = o'10000000000'
  call test_4(x)

  i = o'0000010000'
  call test_4(x)

  y = 0.5
  call test_8(y)

  y = 0.
  call test_8(y)

  j = o'00000000001'
  call test_8(y)

  y = 0.2938735877D-38
  call test_8(y)

  y = -1.469369D-39
  call test_8(y)

  y = z'7fe00000'
  call test_8(y)

  y = -5.739719D+42
  call test_8(y)
end

subroutine test_4(x)
real*4 x,y
integer z
y = fraction (x)
z = exponent(x)
if (z .gt. 0) then
  y = (y * 2.) * (2. ** (z - 1))
else
  y = (y / 2.) * (2. ** (z + 1))
end if
if (abs (x - y) .gt. abs(x * 1e-6)) call abort()
end

subroutine test_8(x)
real*8 x, y
integer z
y = fraction (x)
z = exponent(x)
if (z .gt. 0) then
  y = (y * 2._8) * (2._8 ** (z - 1))
else
  y = (y / 2._8) * (2._8 ** (z + 1))
end if
if (abs (x - y) .gt. abs(x * 1e-6)) call abort()
end


program leap
 implicit none

 write(*,*) leap_year([1900, 1996, 1997, 2000])

 contains

	pure elemental function leap_year(y) result(is_leap)
	implicit none
	logical :: is_leap
	integer,intent(in) :: y

	is_leap = (mod(y,4)==0 .and. .not. mod(y,100)==0) .or. (mod(y,400)==0)

	end function leap_year

end program leap


      subroutine setprob()
      implicit none

      double precision pi
      common /compi/ pi

      double precision revs_per_second
      common /spherecomm/ revs_per_second

      pi = 4.d0*atan(1.d0)

      revs_per_second = 0.5d0

      end


	SUBROUTINE LICK_SYSTEM(X,Y,N,YS)

c	Transforms sed in (x,y) to Lick/IDS system by applying a gaussian
c	broadening function to artificially simulate the Lick/IDS spectral
c	resolution. The FWHM of the gaussian as a function of wavelength is
c	given in Table 8 of Worthey and Ottaviani (1997, ApJS, 111, 377)

c	Returns smoothed spectrum in array (x,ys)

c	Array declaration
	real x(n),y(n),ys(n),u(10000),g(10000)

c	Number of sigmas to perform integration
	m=6

c	FWHM of STELIB seds = 3 A (Leborgne et al. 2002)
	fwhm_stelib = 3.

c	Perform smoothing
	do i=1,n
	fwhm2 = fwhm_ids(x(i))**2 - fwhm_stelib**2
	fwhm  = sqrt(fwhm2)

c       Note: FWHM = 2*sqrt[2*ln(2)]*sigma = 2.3548*sigma
	sigma=fwhm/2.3548

	xmax=x(i)+m*sigma
	call locate(x,n,xmax,i1)
	m2=i1+1
	m1=2*i-m2
	if (m1.lt.1) m1=1
	if (m2.gt.n) m2=n
	k=0
	do j=m1,m2
	k=k+1
	u(k)=x(j)
	g(k)=y(j)*gauss(x(j),x(i),sigma)
	enddo
	ys(i)=trapz1(u,g,k)
	enddo
	return
	end


!=====================================================================!
!
!=====================================================================!

program main

  use element_class   , only : spring
  use assembler_class , only : assembler
  use linear_algebra  , only : eigvals, solve

  implicit none

  ! Domain and meshing
  real(8), parameter        :: a = 0.0d0, b = 1.0d0
  integer, parameter        :: nelems = 10
  integer                   :: nnodes = nelems + 1
  integer                   :: me, nimages

  real(8)                   :: dx
  integer                   :: lnelems
  integer                   :: e
  integer                   :: leid
  integer                   :: lnode_ids(2)
  real(8)                   :: lnodes(2, 1) = 0.0d0
  real(8), allocatable      :: x(:), rhs(:), mat(:,:), jac(:,:)

  type(spring), allocatable :: springs(:)
  type(assembler)           :: spring_assembler

  integer :: i,j

  !-------------------------------------------------------------------!
  ! Mesh the one dimensional geometry and partition between procs
  !-------------------------------------------------------------------!

  mesh_partition : block

    ! Mesh sizse (element length)
    dx = (b-a)/dble(nelems)

    ! Identify processors
    me      = this_image()
    nimages = num_images()
    if (nimages .gt. nelems) STOP "Too many processors for the problem size"
    if (mod(nelems, nimages) .ne. 0) STOP "Unequal partition. Use different number of processors."

    ! Decompose domain based on procs
    lnelems = nelems/nimages

  end block mesh_partition

  !-------------------------------------------------------------------!
  ! Create elements associated with the mesh
  !-------------------------------------------------------------------!

  elements : block

    ! Create elements locally on each processor
    allocate(springs(lnelems))
    do e = 1, lnelems
       leid        = e
       lnode_ids   = [leid, leid + 1]
       lnodes(:,1) = [dble(lnode_ids - 1)*dx]
       springs(e)  = spring(leid, lnode_ids, lnodes, 1.0d0, me)
       call springs(e) % to_string()
    end do

  end block elements

  !-------------------------------------------------------------------!
  ! Assemble linear system
  !-------------------------------------------------------------------!

  assembly : block

    ! Create an assembler for these elements
    spring_assembler = assembler(springs)
    print *, "created assembler"

    ! Create solution, right hand side, jacobian arrays
    allocate(x(spring_assembler % ndof))
    allocate(rhs(spring_assembler % ndof))
    allocate(jac(spring_assembler % ndof, spring_assembler % ndof))

    call random_number(x) ! assumed solution
    x = 1.0d0
    call spring_assembler % residual(x, rhs)
    call spring_assembler % jacobian(x, jac)

    print *, "res=", rhs
    do i = 1, spring_assembler % ndof
       print *,  ( jac(i,j), j = 1, spring_assembler % ndof )
    enddo

!!$    print *, "jac-vec pdt 1:", matmul(jac, x)
!!$    call spring_assembler % jacobian_vector_product(x, rhs)
!!$    print *, "jac-vec pdt 2:", rhs

    !print *, "exact sol", solve(jac, rhs)

  end block assembly

  !-------------------------------------------------------------------!
  ! Solve the linear system
  !-------------------------------------------------------------------!

  solver: block

    integer, parameter :: max_it = 100000
    real(8), parameter :: max_tol = 1.0d-8
    integer :: iter, flag, i, j
    real(8) :: tol
    real(8), allocatable :: x(:)[:]

    allocate(x(spring_assembler % ndof)[*])
    x = 1.0d0

    call spring_assembler % solve(max_it, max_tol, x, iter, tol, flag)

    print *, "solution", x, "from", this_image()

    !rhs = 0.0d0
    !call spring_assembler % jacobian_vector_product(x, rhs)
    !print *, rhs

  end block solver

  deallocate(springs)

end program main


program newtonmd

implicit none
real:: error
integer::istep,n,i,z,pointer,j, steps, q, points,outputfile,num, kappa
real :: mu1, mu2, stepsize, mu
real:: func
real, dimension (:), allocatable :: w0, muarray
real, dimension (:,:), allocatable :: jarray,c,fx,x0, x1,xf, bin0
character (LEN = 60) :: inputval, filename1, filename2
!CHARACTER*29 :: path ='C:\Users\17029\Desktop\gfortran\datfiles\'

error=1.0e-06
inputval = 'S'
kappa = 0

! initialising n
print*,"Enter the dimension"
READ(*,*)  n

allocate ( x0(n,1) )
allocate ( bin0(n,1) )
allocate ( w0(n) )
allocate ( fx(n,1))
allocate ( x1(n,1))
allocate ( xf(n,1))
allocate ( jarray(n,n) )
allocate ( c(n,n))

print*,"Enter mu1 value"
READ(*,*)  mu1

print*,"Enter mu2 value"
READ(*,*)  mu2

print*,"Enter points value"
READ(*,*)  points

!print*,"Enter the Guess Vector"
!DO i = 1, n
!   READ(*,*)  x0(i,1)
!END DO

print*,"Enter the aeta Vector"
DO i = 1, n
   READ(*,*)  w0(i)
END DO

!print*,"Enter kappa value, Enter -1 for all"
!READ(*,*)  kappa

stepsize = (mu2-mu1)/(points+1)
allocate ( muarray(points + 2))

muarray(1) = mu1
do i = 2,(points+1)
muarray(i) = muarray(i-1) + stepsize
end do
muarray(points+2) = mu2
outputfile = 1

do num = 0, (2**(n) -1)

write(filename1, '("Output",I0,".dat")') outputfile
filename2=  filename1

print*, "this work 2"
call dectobin_gen(n,bin0,num)

print*, 'this works'
print*, bin0

!if ( sum(bin0) /=  kappa) CYCLE

x0 = bin0
print*, "this works 3"
open(90, file=filename2,action="write",POSITION="APPEND")

q = 1
do while ( q /= (points + 3))

mu = muarray(q)

pointer= 1

xf = x0

!do while(   ((abs(NORM2(xf)-NORM2(x1))/abs(NORM2(xf))) > 0.00001) )

!do while(   (pointer /= 70) .or. ((abs(NORM2(xf)-NORM2(x0))/abs(NORM2(x0))) == 0 )   )

do while( pointer /= 70 )

z = 1

print*, x0

!! generating jacobian

call Jac(x0, mu, n, w0, jarray)

do i = 1,n
do j = 1,n
   print*, i,j,jarray(i,j)
end do
end do

!! generating it's inverse
print*, "generating inverse"

call inverse(jarray,c,n)

print*,'c is', c

!! generating fx(x0)

do while (z /= n+1  )
call eqn(x0, w0, z, n, mu, func)
fx(z,1) = func
z = z+1
end do

print*, fx

!! computing x1

x1 = x0 - matmul(c,fx)

!!do i = 1,n
!!do j = 1,n
!!   print*, i,j,c(i,j)
!!end do
!!end do

!!print*,'fx is', fx

!!print*,'c*fx is', matmul(c, fx)

!!print*, size(c), size(fx)

!!print*, '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
!!print*, x1
!!print*, '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'

x0 = x1
pointer = pointer + 1
end do

   write(90, '(F8.5,X)', advance='no') muarray(q)

   do j=1,n
      write(90, '(F8.5,X)', advance='no') x1(j,1)
   end do

   write(90, *) ''  ! this gives you the line break

q = q+1

end do

outputfile = outputfile + 1
close(90)
end do

end program

!!!!!!!!!! SUBROUTINES !!!!!!!!!!!!!

subroutine eqn(x0, w0, i, n, mu, f)

integer, intent(in):: n
real :: mu
real, DIMENSION(1:n) :: x0
real, DIMENSION(1:n) :: w0
real, intent(out):: f
integer:: i
real :: sumn

call sum(x0, w0, i, n, sumn)

print*,'sum = ', sumn
print*, 'mu =', mu

f = ((x0(i))**2) - (x0(i)) - (mu*sumn)

return
END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine sum(x0, w0, i, n, sumn)

integer, intent(in):: n
real, DIMENSION(n,1) :: x0
real, DIMENSION(1:n) :: w0
real, intent(out):: sumn
integer:: i, p,k

k = i

p = k

sumn = 0

do while (k /= n)
sumn = sumn + (x0(p,1) - x0((k + 1),1))/(w0(p) - w0((k+1)) )
k = k + 1
end do

k = p

do while (k /= 1)
sumn = sumn + (x0(p,1) - x0((k - 1),1))/(w0(p) - w0((k-1)) )
k = k -1
end do

return
end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine Jac(x0, mu, n, w0, jind)

integer :: n, j , i, k
real, DIMENSION(n,1) :: x0
real, DIMENSION(1:n) :: w0
real, DIMENSION(1:n, 1:n) :: jind
real :: mu, sumnaeta

print*, 'n value is ', n

j = 1

i = 1

do while( i /= n+1 )

do j = 1,n

print*, i, j

if (i == j) then
k = i
call sumaeta(w0, k, n, sumnaeta)
print*, 'once'
jind(i,j) =  2*(x0(i,1)) - 1 - (mu*sumnaeta)
end if

if(i /= j) then
print*, 'twice'
jind(i,j) =  mu/(w0(i)-w0(j))
end if

end do

i = i +1
end do

end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine dectobin_gen(n,bin0,num)

integer :: n,num,i,temp
real, DIMENSION(n,1) :: bin0

do i = 1,n

bin0(i,1) = 0

end do

temp= num

do i=1,n

if (mod(temp,2)==1) bin0(i,1)=1

temp   =   temp/2

if (temp==0) exit

end do

end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine sumaeta( w0, i, n, sumnaeta)

integer :: n
real, DIMENSION(1:n) :: w0
real :: sumnaeta, sumn
integer:: i, p

p = i

sumn = 0

do while (i /= n)
sumn = sumn + (1/(w0(p)-w0(i+1)))
i = i + 1
end do

i = p

do while (i /= 1)
sumn = sumn + (1/(w0(p) - w0(i-1)))
i = i -1
end do

sumnaeta = sumn

return
end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 subroutine inverse(a,c,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer n
real :: a(n,n), c(n,n)
real :: L(n,n), U(n,n), b(n), d(n), x(n)
real :: coeff
integer i, j, k

! step 0: initialization for matrices L and U and b
! Fortran 90/95 aloows such operations on matrices
L=0.0
U=0.0
b=0.0

! step 1: forward elimination
do k=1, n-1
   do i=k+1,n
      coeff=a(i,k)/a(k,k)
      L(i,k) = coeff
      do j=k+1,n
         a(i,j) = a(i,j)-coeff*a(k,j)
      end do
   end do
end do

! Step 2: prepare L and U matrices
! L matrix is a matrix of the elimination coefficient
! + the diagonal elements are 1.0
do i=1,n
  L(i,i) = 1.0
end do
! U matrix is the upper triangular part of A
do j=1,n
  do i=1,j
    U(i,j) = a(i,j)
  end do
end do

! Step 3: compute columns of the inverse matrix C
do k=1,n
  b(k)=1.0
  d(1) = b(1)
! Step 3a: Solve Ld=b using the forward substitution
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    end do
  end do
! Step 3b: Solve Ux=d using the back substitution
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    end do
    x(i) = x(i)/u(i,i)
  end do
! Step 3c: fill the solutions x(n) into column k of C
  do i=1,n
    c(i,k) = x(i)
  end do
  b(k)=0.0
end do
end subroutine inverse

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


          program demo_selected_real_kind
          implicit none
            integer,parameter :: p6 = selected_real_kind(6)
            integer,parameter :: p10r100 = selected_real_kind(10,100)
            integer,parameter :: r400 = selected_real_kind(r=400)
            real(kind=p6) :: x
            real(kind=p10r100) :: y
            real(kind=r400) :: z

            print *, precision(x), range(x)
            print *, precision(y), range(y)
            print *, precision(z), range(z)
          end program demo_selected_real_kind


!*************************************************
!	no common
!*************************************************

module mod_qrdec

	implicit none

contains
!=========
subroutine QRDEC(z_lc,y_lc, detl, nkdata, njtotal, njmt, u, lb, jmtt, ind)

	implicit none

	integer, intent(in) :: nkdata, njtotal, njmt, ind
	real(8), intent(inout) :: z_lc(nkdata, njmt), y_lc(njtotal)
	integer, intent(out) :: lb(njmt), jmtt
	real(8), intent(out) :: detl, u(njtotal)

	integer :: i, k, kk
	real(8) :: eps, sm, b, sl

	eps  = 1.d-12
	detl = 0.d0
	jmtt = 1
	lb   = 0

	do k = 1, njmt

		sm = 0.d0

		do i = jmtt, njtotal
			u(i) = z_lc(i,k)
			sm = sm + u(i) * u(i)
		end do

		b = dsqrt(sm)

		if(b < eps) cycle
		if(u(jmtt) > 0.d0) b = -b

		u(jmtt) = u(jmtt) - b

		do kk = k+1, njmt

			sl = 0.d0

			do i = jmtt, njtotal
				sl = sl + z_lc(i,kk) * u(i)
			end do

			sl = sl / u(jmtt) / b

			do i = jmtt, njtotal
				z_lc(i,kk) = z_lc(i,kk) + u(i) * sl
			end do

		end do

		z_lc(jmtt,k) = b
		detl = detl + dlog(dabs(b))

		if(ind /= 0) then

			sl = 0.d0

			do i = jmtt, njtotal
				sl = sl + y_lc(i) * u(i)
			end do

			sl = sl / u(jmtt) / b

			do i = jmtt, njtotal
				y_lc(i) = y_lc(i) + u(i) * sl
			end do

		end if

		lb(k) = jmtt
		jmtt = jmtt + 1

	end do

	jmtt = jmtt - 1

return
end subroutine QRDEC

!==========
subroutine RINV(x_lc, y_lc, z_lc, nkdata, jmtt, ind)

	implicit none

	integer, intent(in) :: nkdata, jmtt, ind
	real(8), intent(in) :: y_lc(jmtt), z_lc(nkdata, jmtt)
	real(8), intent(inout) :: x_lc(jmtt)

	integer :: k, j
	real(8) :: uf

	if(ind == 0) then
		do k = jmtt, 1, -1

			uf = y_lc(k)

			do j = k+1, jmtt
				uf = uf - x_lc(j) * z_lc(k,j)
			end do

			x_lc(k) = uf / z_lc(k,k)

		end do
		return
	end if

	do k = ind, jmtt

		uf = y_lc(k)

		do j = ind, k-1
			uf = uf - x_lc(j) * z_lc(j,k)
		end do

		x_lc(k) = uf / z_lc(k,k)

	end do

return
end subroutine RINV

end module mod_qrdec


C
C-----------------------------------------------------------------------------
C
      double precision function alfa(alfa0,qsq )
C
C-----------------------------------------------------------------------------
C
C	This function returns the 1-loop value of alpha.
C
C	INPUT:
C		qsq   = Q^2
C
C-----------------------------------------------------------------------------
C
      implicit none
      double precision  qsq,alfa0
c
c constants
c
      double precision  One, Three, Pi,zmass
      parameter( One = 1.0d0, Three = 3.0d0 )
      parameter( Pi = 3.14159265358979323846d0 )
      parameter( zmass = 91.188d0 )
cc
      alfa = alfa0 / ( 1.0d0 - alfa0*dlog( qsq/zmass**2 ) /Three /Pi )
ccc
      return
      end

C
C-----------------------------------------------------------------------------
C
      double precision function alfaw(alfaw0,qsq,nh )
C
C-----------------------------------------------------------------------------
C
C	This function returns the 1-loop value of alpha_w.
C
C	INPUT:
C		qsq = Q^2
C               nh  = # of Higgs doublets
C
C-----------------------------------------------------------------------------
C
      implicit none
      double precision  qsq, alphaw, dum,alfaw0
      integer  nh, nq
c
c	  include
c

c
c constants
c
      double precision  Two, Four, Pi, Twpi, zmass,tmass
      parameter( Two = 2.0d0, Four = 4.0d0 )
      parameter( Pi = 3.14159265358979323846d0 )
      parameter( Twpi = 3.0d0*Four*Pi )
      parameter( zmass = 91.188d0,tmass=174d0 )
cc
      if ( qsq.ge.tmass**2 ) then
         nq = 6
      else
         nq = 5
      end if
      dum = ( 22.0d0 - Four*nq - nh/Two ) / Twpi
      alfaw = alfaw0 / ( 1.0d0 + dum*alfaw0*dlog( qsq/zmass**2 ) )
ccc
      return
      end

C-----------------------------------------------------------------------------
C
      DOUBLE PRECISION FUNCTION ALPHAS(Q)
C     wrapper to the lhapdf alphaS
C-----------------------------------------------------------------------------
      IMPLICIT NONE
c
      include 'alfas.inc'
      REAL*8 Q,alphasPDF
      external alphasPDF

c timing statistics
c      include "timing_variables.inc"

c     This function takes 20 micro seconds to run, so it is ok to profile
c     it with the 0.3 ms function cpu_time.
c      call cpu_time(tbefore)
      ALPHAS=alphasPDF(Q)
c      call cpu_time(tAfter)

c      tPDF = tPDF + (tAfter-tBefore)

      RETURN
      END

C-----------------------------------------------------------------------------
C
      double precision function mfrun(mf,scale,asmz,nloop)
C
C-----------------------------------------------------------------------------
C
C	This function returns the 2-loop value of a MSbar fermion mass
C       at a given scale.
C
C	INPUT: mf    = MSbar mass of fermion at MSbar fermion mass scale
C	       scale = scale at which the running mass is evaluated
C	       asmz  = AS(MZ) : this is passed to alphas(scale,asmz,nloop)
C              nloop = # of loops in the evolution
C
C
C
C	EXTERNAL:      double precision alphas(scale,asmz,nloop)
C
C-----------------------------------------------------------------------------
C
      implicit none
C
C     ARGUMENTS
C
      double precision  mf,scale,asmz
      integer           nloop
C
C     LOCAL
C
      double precision  beta0, beta1,gamma0,gamma1
      double precision  A1,as,asmf,l2
      integer  nf
C
C     EXTERNAL
C
      double precision  alphas
      external          alphas
c
c     CONSTANTS
c
      double precision  One, Two, Three, Pi
      parameter( One = 1.0d0, Two = 2.0d0, Three = 3.0d0 )
      parameter( Pi = 3.14159265358979323846d0)
      double precision tmass
      parameter(tmass=174d0)
cc
C
C
      if ( mf.gt.tmass ) then
         nf = 6
      else
         nf = 5
      end if

      beta0 = ( 11.0d0 - Two/Three *nf )/4d0
      beta1 = ( 102d0  - 38d0/Three*nf )/16d0
      gamma0= 1d0
      gamma1= ( 202d0/3d0  - 20d0/9d0*nf )/16d0
      A1    = -beta1*gamma0/beta0**2+gamma1/beta0
      as    = alphas(scale)
      asmf  = alphas(mf)
      l2    = (1+ A1*as/Pi)/(1+ A1*asmf/Pi)

      mfrun = mf * (as/asmf)**(gamma0/beta0)

      if(nloop.eq.2) mfrun =mfrun*l2
ccc
      return
      end


!> \brief \b CROTG
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!  CROTG constructs a plane rotation
!     [  c         s ] [ a ] = [ r ]
!     [ -conjg(s)  c ] [ b ]   [ 0 ]
!  where c is real, s is complex, and c**2 + conjg(s)*s = 1.
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> The computation uses the formulas
!>    |x| = sqrt( Re(x)**2 + Im(x)**2 )
!>    sgn(x) = x / |x|  if x /= 0
!>           = 1        if x  = 0
!>    c = |a| / sqrt(|a|**2 + |b|**2)
!>    s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
!> When a and b are real and r /= 0, the formulas simplify to
!>    r = sgn(a)*sqrt(|a|**2 + |b|**2)
!>    c = a / r
!>    s = b / r
!> the same as in CROTG when |a| > |b|.  When |b| >= |a|, the
!> sign of c and s will be different from those computed by CROTG
!> if the signs of a and b are not the same.
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX
!>          On entry, the scalar a.
!>          On exit, the scalar r.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is COMPLEX
!>          The scalar b.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL
!>          The scalar c.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is COMPLEX
!>          The scalar s.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
!  =====================================================================
subroutine CROTG( a, b, c, s )
   integer, parameter :: wp = kind(1.e0)
!
!  -- Reference BLAS level1 routine --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Constants ..
   real(wp), parameter :: zero = 0.0_wp
   real(wp), parameter :: one  = 1.0_wp
   complex(wp), parameter :: czero  = 0.0_wp
!  ..
!  .. Scaling constants ..
   real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( &
      minexponent(0._wp)-1, &
      1-maxexponent(0._wp) &
   )
   real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( &
      1-minexponent(0._wp), &
      maxexponent(0._wp)-1 &
   )
   real(wp), parameter :: rtmin = sqrt( real(radix(0._wp),wp)**max( &
      minexponent(0._wp)-1, &
      1-maxexponent(0._wp) &
   ) / epsilon(0._wp) )
   real(wp), parameter :: rtmax = sqrt( real(radix(0._wp),wp)**max( &
      1-minexponent(0._wp), &
      maxexponent(0._wp)-1 &
   ) * epsilon(0._wp) )
!  ..
!  .. Scalar Arguments ..
   real(wp) :: c
   complex(wp) :: a, b, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
   complex(wp) :: f, fs, g, gs, r, t
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, aimag, conjg, max, min, real, sqrt
!  ..
!  .. Statement Functions ..
   real(wp) :: ABSSQ
!  ..
!  .. Statement Function definitions ..
   ABSSQ( t ) = real( t )**2 + aimag( t )**2
!  ..
!  .. Executable Statements ..
!
   f = a
   g = b
   if( g == czero ) then
      c = one
      s = czero
      r = f
   else if( f == czero ) then
      c = zero
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         g2 = ABSSQ( g )
         d = sqrt( g2 )
         s = conjg( g ) / d
         r = d
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = ABSSQ( gs )
         d = sqrt( g2 )
         s = conjg( gs ) / d
         r = d*u
      end if
   else
      f1 = max( abs(real(f)), abs(aimag(f)) )
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( f1 > rtmin .and. f1 < rtmax .and. &
          g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         f2 = ABSSQ( f )
         g2 = ABSSQ( g )
         h2 = f2 + g2
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = f2*p
         s = conjg( g )*( f*p )
         r = f*( h2*p )
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, f1, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = ABSSQ( gs )
         if( f1*uu < rtmin ) then
!
!           f is not well-scaled when scaled by g1.
!           Use a different scaling for f.
!
            v = min( safmax, max( safmin, f1 ) )
            vv = one / v
            w = v * uu
            fs = f*vv
            f2 = ABSSQ( fs )
            h2 = f2*w**2 + g2
         else
!
!           Otherwise use the same scaling for f and g.
!
            w = one
            fs = f*uu
            f2 = ABSSQ( fs )
            h2 = f2 + g2
         end if
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = ( f2*p )*w
         s = conjg( gs )*( fs*p )
         r = ( fs*( h2*p ) )*u
      end if
   end if
   a = r
   return
end subroutine


! This file is part of HolmMHD
! Copyright (C) 2019 Daniel Verscharen (d.verscharen@ucl.ac.uk)
!All rights reserved.
!
!Redistribution and use in source and binary forms, with or without
!modification, are permitted provided that the following conditions are met:
!
!1. Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!2. Redistributions in binary form must reproduce the above copyright notice,
!   this list of conditions and the following disclaimer in the documentation
!   and/or other materials provided with the distribution.
!
!THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
!ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
!WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
!DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
!ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
!(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
!LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
!ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
!(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!The views and conclusions contained in the software and documentation are those
!of the authors and should not be interpreted as representing official policies,
!either expressed or implied, of the HolmMHD project.

double precision function divF(F,quant,i,j,k,wvel)
! Calculate the divergence of F at the point (i,j,k)
! F is a vector with F(comp,i,j,k)
use globals
implicit none

double precision :: F(3,-1:Nx+2,-1:Ny+2,-1:Nz+2),quant(-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: wvel(3,-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: fph,fmh,flimitp,flimitm,r,fpl,fml
double precision :: top,bot
integer :: i,j,k

! Hybrid scheme with flux limiter:

!!! DERIVATIVE IN X-DIRECTION:
! This is the van Leer flux limiter:
top=quant(i,j,k)-quant(i-1,j,k)
bot=quant(i+1,j,k)-quant(i,j,k)
r=top*bot/(bot*bot+1.d-10)
!flimitp=(r+abs(r))/(1.d0+abs(r))	! van Leer limiter
flimitp=max(0.d0,min(1.d0,r)) !min-mod limiter

top=quant(i-1,j,k)-quant(i-2,j,k)
bot=quant(i,j,k)-quant(i-1,j,k)
r=top*bot/(bot*bot+1.d-10)
!flimitm=(r+abs(r))/(1.d0+abs(r))
flimitm=max(0.d0,min(1.d0,r))

! This is the lower order part (Rusanov):
fpl=0.5d0*(F(1,i,j,k)+F(1,i+1,j,k))-0.5d0*max(wvel(1,i,j,k),wvel(1,i+1,j,k))*(quant(i+1,j,k)-quant(i,j,k))
fml=0.5d0*(F(1,i-1,j,k)+F(1,i,j,k))-0.5d0*max(wvel(1,i,j,k),wvel(1,i-1,j,k))*(quant(i,j,k)-quant(i-1,j,k))

! This is the higher order part (fourth-order centered):

fph=(7.d0/12.d0)*(F(1,i,j,k)+F(1,i+1,j,k)) - (1.d0/12.d0)*(F(1,i-1,j,k)+F(1,i+2,j,k))
fmh=(7.d0/12.d0)*(F(1,i-1,j,k)+F(1,i,j,k)) - (1.d0/12.d0)*(F(1,i-2,j,k)+F(1,i+1,j,k))
!divF=((fpl-0.5d0*flimitp*(fpl-fph))-(fml-0.5d0*flimitm*(fml-fmh)))/dx
divF=((fpl-flimitp*(fpl-fph))-(fml-flimitm*(fml-fmh)))/dx

!!! DERIVATIVE IN Y-DIRECTION:
! This is the van Leer flux limiter:
top=quant(i,j,k)-quant(i,j-1,k)
bot=quant(i,j+1,k)-quant(i,j,k)
r=top*bot/(bot*bot+1.d-10)
!flimitp=(r+abs(r))/(1.d0+abs(r))
flimitp=max(0.d0,min(1.d0,r))

top=quant(i,j-1,k)-quant(i,j-2,k)
bot=quant(i,j,k)-quant(i,j-1,k)
r=top*bot/(bot*bot+1.d-10)
!flimitm=(r+abs(r))/(1.d0+abs(r))
flimitm=max(0.d0,min(1.d0,r))

! This is the lower order part (Rusanov):
fpl=0.5d0*(F(2,i,j,k)+F(2,i,j+1,k))-0.5d0*max(wvel(2,i,j,k),wvel(2,i,j+1,k))*(quant(i,j+1,k)-quant(i,j,k))
fml=0.5d0*(F(2,i,j-1,k)+F(2,i,j,k))-0.5d0*max(wvel(2,i,j,k),wvel(2,i,j-1,k))*(quant(i,j,k)-quant(i,j-1,k))

! This is the higher order part(fourth-order centered):
fph=(7.d0/12.d0)*(F(2,i,j,k)+F(2,i,j+1,k)) - (1.d0/12.d0)*(F(2,i,j-1,k)+F(2,i,j+2,k))
fmh=(7.d0/12.d0)*(F(2,i,j-1,k)+F(2,i,j,k)) - (1.d0/12.d0)*(F(2,i,j-2,k)+F(2,i,j+1,k))
!divF=divF+((fpl-0.5d0*flimitp*(fpl-fph))-(fml-0.5d0*flimitm*(fml-fmh)))/dy
divF=divF+((fpl-flimitp*(fpl-fph))-(fml-flimitm*(fml-fmh)))/dy

!!! DERIVATIVE IN Z-DIRECTION:
! This is the van Leer flux limiter:

top=quant(i,j,k)-quant(i,j,k-1)
bot=quant(i,j,k+1)-quant(i,j,k)
r=top*bot/(bot*bot+1.d-10)
!flimitp=(r+abs(r))/(1.d0+abs(r))
flimitp=max(0.d0,min(1.d0,r))

top=quant(i,j,k-1)-quant(i,j,k-2)
bot=quant(i,j,k)-quant(i,j,k-1)
r=top*bot/(bot*bot+1.d-10)
!flimitm=(r+abs(r))/(1.d0+abs(r))
flimitm=max(0.d0,min(1.d0,r))

! This is the lower order part (Rusanov):
! We may possibly need a factor 0.5 instead of 0.25:
fpl=0.5d0*(F(3,i,j,k)+F(3,i,j,k+1))-0.5d0*max(wvel(3,i,j,k),wvel(3,i,j,k+1))*(quant(i,j,k+1)-quant(i,j,k))
fml=0.5d0*(F(3,i,j,k-1)+F(3,i,j,k))-0.5d0*max(wvel(3,i,j,k),wvel(3,i,j,k-1))*(quant(i,j,k)-quant(i,j,k-1))

! This is the higher order part(fourth-order centered):
fph=(7.d0/12.d0)*(F(3,i,j,k)+F(3,i,j,k+1)) - (1.d0/12.d0)*(F(3,i,j,k-1)+F(3,i,j,k+2))
fmh=(7.d0/12.d0)*(F(3,i,j,k-1)+F(3,i,j,k)) - (1.d0/12.d0)*(F(3,i,j,k-2)+F(3,i,j,k+1))
!divF=divF+((fpl-0.5d0*flimitp*(fpl-fph))-(fml-0.5d0*flimitm*(fml-fmh)))/dz
divF=divF+((fpl-flimitp*(fpl-fph))-(fml-flimitm*(fml-fmh)))/dz

end function


!=========================================================================
! SUBRUTINA PARA EL CALCULO DE FUERZAS DE INTERACCION Y ENERGIA DE LA
! CONFIGURACION PARA LA SIMULACION DE DINAMICA BROWNIANA
!
! AUTOR : MARTIN ALEJANDRO PAREDES SOSA
!=========================================================================

Subroutine Fuerza(L)
  Use cte
  Implicit None
  Real :: EnePot, U, U2, U3                                            !ENERGIA
  Real :: FXI, FYI, FZI, fxij, fyij, fzij                          !FUERZAS TEMP
  Real :: xij, yij, zij, rij                                       !POSICIONES
  Real :: Pres, Pres1

  Integer :: i, j, L                                               !CONTADORES ("L" CONTADOR DE LA CONFIGURACION)
  Logical :: Ctrl1, Ctrl2

  !INICIALIZANDO
  EnePot = 0.0
  FX = 0.0
  FY = 0.0
  FZ = 0.0

  Pres1 = 0.0

  Parti1: Do i = 1, N - 1

     FXI = FX(i)
     FYI = FY(i)
     FZI = FZ(i)

     Parti2: Do j = i + 1, N

        !SEPARACION
        xij = X(i) - X(j)
        yij = Y(i) - Y(j)
        zij = Z(i) - Z(j)

        !CONDICION DE IMAGEN MINIMA
        xij = xij - BoxL * Anint( xij / BoxL )
        yij = yij - BoxL * Anint( yij / BoxL )
        zij = zij - BoxL * Anint( zij / BoxL )

        !DISTANCIA
        rij = sqrt( xij*xij + yij*yij + zij*zij )

        !TRASLAPES
        Ctrl1 = rij .LE. 1.0
        Traslape : If(Ctrl1) Then

           Write(*,*) "TRASLAPE", i, j

        End If Traslape

        !IMPLEMENTACION DEL POTENCIAL
        Ctrl2 = rij .LT. RCut
        Potencial: If(Ctrl2) Then

           U = Exp( -YukZk * rij )
           U2 = YukA * U  * (YukZk * rij + 1.0 ) / (rij**3)
           U3 = U2 * rij * rij
           EnePot = (YukA * U) / rij + EnePot

           fxij = xij * U2
           fyij = yij * U2
           fzij = zij * U2

           FXI = FXI + fxij
           FYI = FYI + fyij
           FZI = FZI + fzij

           FX(j) = FX(j) - fxij
           FY(j) = FY(j) - fyij
           FZ(j) = FZ(j) - fzij

           !PRECALCULO DE PRESION
           Pres1 = Pres1 + U3

        End If Potencial

     End Do Parti2

     !GUARDANDO FUERZA
     FX(i) = FXI
     FY(i) = FYI
     FZ(i) = FZI

  End Do Parti1

  !CALCULO DE PRESION
  Pres = dens + (dens / (3.0 * real(N) ) ) * Pres1

  !GUADANDO TERMALIZACION (ENERGIA POR PARTICULA)
  Write(3,*) L , EnePot / Real(N), Pres

  If( mod(L , iPrint) == 0 ) Then
     Write(*,*) L , EnePot / Real(N) , Pres                           !MONITOREO EN PANTALLA
  End If

End Subroutine Fuerza


!     ============================================
    subroutine setaux(maxmx,maxmy,num_ghost,mx,my,xlower,ylower,dxc,dyc, &
    num_aux,aux,Rsphere)
!     ============================================

!     # Set auxiliary arrays for shallow water equations on the sphere.

!     # On input: (xc(i),yc(j)) gives uniformly spaced computational grid.
!     # On output: he aux array has the following elements:
!         1  kappa = ratio of cell area to dxc*dyc
!         2  enx = x-component of normal vector to left edges in tangent plane
!         3  eny = y-component of normal vector to left edges in tangent plane
!         4  enz = z-component of normal vector to left edges in tangent plane
!         5  etx = x-component of tangent vector to left edges in tangent plane
!         6  ety = y-component of tangent vector to left edges in tangent plane
!         7  etz = z-component of tangent vector to left edges in tangent plane
!         8  enx = x-component of normal vector to bottom edges in tangent plane
!         9  eny = y-component of normal vector to bottom edges in tangent plane
!        10  enz = z-component of normal vector to bottom edges in tangent plane
!        11  etx = x-component of tangent vector to bottom edges in tangent plane
!        12  ety = y-component of tangent vector to bottom edges in tangent plane
!        13  etz = z-component of tangent vector to bottom edges in tangent plane
!        14  erx = x-component of unit vector in radial direction at cell ctr
!        15  ery = y-component of unit vector in radial direction at cell ctr
!        16  erz = z-component of unit vector in radial direction at cell ctr

    implicit double precision (a-h,o-z)
    parameter (maxm3 = 1005)
    dimension xc(-3:maxm3), yc(-3:maxm3)
    dimension xp(-3:maxm3,-3:maxm3), yp(-3:maxm3,-3:maxm3)
    dimension zp(-3:maxm3,-3:maxm3)
    dimension theta(-3:maxm3,-3:maxm3), phi(-3:maxm3,-3:maxm3)
    dimension aux(num_aux,1-num_ghost:maxmx+num_ghost,1-num_ghost:maxmy+num_ghost)

!f2py integer intent(in) maxmx
!f2py integer intent(in) maxmy
!f2py integer intent(in) num_ghost
!f2py integer intent(in) mx
!f2py integer intent(in) my
!f2py double precision intent(in) xlower
!f2py double precision intent(in) ylower
!f2py double precision intent(in) dx
!f2py double precision intent(in) dy
!f2py integer optional, intent(in)  num_aux
!f2py intent(in,out) aux
!f2py double precision intent(in) Rsphere

    pi = 4.d0*datan(1.d0)

    if (num_ghost > 4) then
        write(6,*)'***  increase size of local arrays in setaux ***'
        stop
    endif

    if (mx+num_ghost+1 > 1005 .OR. my+num_ghost+1 > 1005) then
        write(6,*)'***  increase size of 1005 in setaux ***'
        stop
    endif

!     # Set xc and yc so that (xc(i),yc(j)) is the
!     # lower left corner of (i,j) cell in computational space:

    do 10 i=1-num_ghost,mx+num_ghost+1
        xc(i) = xlower + (i-1.d0) * dxc
    10 END DO

    do 12 j=1-num_ghost,my+num_ghost+1
        yc(j) = ylower + (j-1.d0) * dyc
    12 END DO

!     # compute cell corners on sphere and angles phi, theta
!     # related to latitude and longitude

    do 15 j=1-num_ghost,my+num_ghost+1
        do 15 i=1-num_ghost,mx+num_ghost+1

        !           # map computational point to (xp,yp,zp) on sphere:
            call mapc2p(xc(i),yc(j),xp(i,j),yp(i,j),zp(i,j),Rsphere)

        !           # compute longitude theta from positive x axis:
            r = dsqrt(xp(i,j)**2 + yp(i,j)**2)

        !            theta(i,j) = atan2(xp(i,j),yp(i,j))

            if (r > 1.d-4) then
                theta(i,j) = dacos(xp(i,j)/r)
            elseif (yp(i,j) > 0.d0) then
                theta(i,j) = 0.d0
            endif
            if (yp(i,j) < 0.d0) then
                theta(i,j) = -theta(i,j)
            endif
        !           # compute phi, angle down from north pole:
            if (zp(i,j) > 0.d0) then
                phi(i,j) = pi/2.d0 - dacos(r/Rsphere)
            else
                phi(i,j) = pi/2.d0 + dacos(r/Rsphere)
            endif
    15 END DO

    do 20 j=1-num_ghost,my+num_ghost
        do 20 i=1-num_ghost,mx+num_ghost

        !           # compute normal and tangent vectors to left edges (in tangent plane)

        !           # tangent vector is edges vector:
            etx = xp(i,j+1) - xp(i,j)
            ety = yp(i,j+1) - yp(i,j)
            etz = zp(i,j+1) - zp(i,j)
            aux(5,i,j) = etx
            aux(6,i,j) = ety
            aux(7,i,j) = etz

        !           # normal to sphere in radial direction at midpoint of edges:
            erx = 0.5d0*(xp(i,j) + xp(i,j+1))
            ery = 0.5d0*(yp(i,j) + yp(i,j+1))
            erz = 0.5d0*(zp(i,j) + zp(i,j+1))

        !           # normal to edges in tangent plane is cross product of et and er:
            enx = ety*erz - etz*ery
            eny = etz*erx - etx*erz
            enz = etx*ery - ety*erx
            ennorm = dsqrt(enx**2 + eny**2 + enz**2)
            aux(2,i,j) = enx/ennorm
            aux(3,i,j) = eny/ennorm
            aux(4,i,j) = enz/ennorm

        !           # compute normal and tangent vectors to bottom edges (in tang. pl.)

        !           # tangent vector is edges vector:
            etx = xp(i+1,j) - xp(i,j)
            ety = yp(i+1,j) - yp(i,j)
            etz = zp(i+1,j) - zp(i,j)
            aux(11,i,j) = etx
            aux(12,i,j) = ety
            aux(13,i,j) = etz

        !           # normal to sphere in radial direction at midpoint of edges:
            erx = 0.5d0*(xp(i,j) + xp(i+1,j))
            ery = 0.5d0*(yp(i,j) + yp(i+1,j))
            erz = 0.5d0*(zp(i,j) + zp(i+1,j))

        !           # normal to edges in tangent plane is cross product of er and et:
            enx = ery*etz - erz*ety
            eny = erz*etx - erx*etz
            enz = erx*ety - ery*etx
            ennorm = dsqrt(enx**2 + eny**2 + enz**2)
            aux(8,i,j) = enx/ennorm
            aux(9,i,j) = eny/ennorm
            aux(10,i,j) = enz/ennorm

        !           # normal to sphere in radial direction at cell centers:
            xcm = xlower+(i-0.5)*dxc
            ycm = ylower+(j-0.5)*dyc
            call mapc2p(xcm,ycm,xpm,ypm,zpm,Rsphere)

            aux(14,i,j) = xpm
            aux(15,i,j) = ypm
            aux(16,i,j) = zpm

        !           # compute area of physical cell from four corners:
        !           # find area on the sphere of two spherical triangles obtained
        !           # by subdividing rectangle.  See
        !           #    http://mathforum.org/library/drmath/view/65316.html

        !           # corners are labeled
        !           #      1: (i,j)      2: (i+1,j)    3: (i,j+1)    4: (i+1,j+1)

            beta12 = dsin(phi(i,j))*dsin(phi(i+1,j))* &
            dcos(theta(i,j) - theta(i+1,j)) &
            + dcos(phi(i,j))*dcos(phi(i+1,j))
            beta23 = dsin(phi(i,j+1))*dsin(phi(i+1,j))* &
            dcos(theta(i,j+1) - theta(i+1,j)) &
            + dcos(phi(i,j+1))*dcos(phi(i+1,j))
            beta13 = dsin(phi(i,j+1))*dsin(phi(i,j))* &
            dcos(theta(i,j+1) - theta(i,j)) &
            + dcos(phi(i,j+1))*dcos(phi(i,j))
            beta24 = dsin(phi(i+1,j+1))*dsin(phi(i+1,j))* &
            dcos(theta(i+1,j+1) - theta(i+1,j)) &
            + dcos(phi(i+1,j+1))*dcos(phi(i+1,j))
            beta34 = dsin(phi(i+1,j+1))*dsin(phi(i,j+1))* &
            dcos(theta(i+1,j+1) - theta(i,j+1)) &
            + dcos(phi(i+1,j+1))*dcos(phi(i,j+1))

        !           # great circles distances between corners:
            d12 = Rsphere * dacos(beta12)
            d23 = Rsphere * dacos(beta23)
            d13 = Rsphere * dacos(beta13)
            d24 = Rsphere * dacos(beta24)
            d34 = Rsphere * dacos(beta34)

            s123 = 0.5d0 * (d12 + d23 + d13)
            s234 = 0.5d0 * (d23 + d34 + d24)

        !           # spherical excess for each triangle:
            t123 = dtan(s123/2.d0)*dtan((s123-d12)/2.d0) &
            *dtan((s123-d23)/2.d0)*dtan((s123-d13)/2.d0)
            t123 = dmax1(t123,0.d0)
            E123 = 4.d0*datan(sqrt(t123))

            t234 = dtan(s234/2.d0)*dtan((s234-d23)/2.d0) &
            *dtan((s234-d34)/2.d0)*dtan((s234-d24)/2.d0)
            t234 = dmax1(t234,0.d0)
            E234 = 4.d0*datan(sqrt(t234))

        !           area = Rsphere**2 * (E123 + E234)
            area = (E123 + E234)

        !           # capacity kappa:
            aux(1,i,j) = area / (dxc*dyc)

    20 END DO

    return
    end subroutine setaux


\ Program to calculate big factorial
\ Michel Jean - December 2021 v1.0

create result 10000 cells allot \ Size of the result
variable result_size
variable carry
variable product
variable x
variable input

: calcul ( -- )
    0 carry !
    result_size @ 0 do
    i cells result + @ x @  * carry @ + product !
    product @ 10 mod result i cells + !
    product @ 10 / carry !
    loop

    begin
    carry @ 0 > while
    carry @ 10 mod result result_size @ cells + !
    carry @ 10 / carry !
    result_size @ 1+ result_size !
    repeat
;
: output ( -- )
    ." The factorial of " input ? ." is : " cr
    result_size @ 1- result_size !
    begin
    result_size @ 0 >= while
    result_size @ cells result + ?
    result_size @ 1- result_size !
    result_size 30 mod 0 = if cr then \ input by line
    repeat
;
: factorial ( -- )
    input !
    1 result 0 cells + !
    1 result_size !
    2 x !

    begin
     x @ input @ <= while
       calcul
    x @ 1+ x !
     repeat
    output
;


	FUNCTION PR_VSKN  ( vsbk )
C************************************************************************
C* PR_VSKN								*
C*									*
C* This function computes VSBN from VSBK.  The following equation is	*
C* used:  								*
C*									*
C*                VSBN  =  .54 * VSBK	                 		*
C*									*
C* REAL PR_VSKN  ( VSBK )						*
C*									*
C* Input parameters:							*
C*	VSBK		REAL		Visibility in kilometers        *
C*									*
C* Output parameters:							*
C*	PR_VSKN		REAL		Visibility in nautical miles    *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	5/97	                      			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for invalid data.
C
	IF  ( ERMISS ( vsbk ) )  THEN
	    PR_VSKN = RMISSD
	  ELSE
C
C*	    Do the conversion.
C
	    PR_VSKN = .54 * vsbk
	END IF
C*
	RETURN
	END


! MD5 of template: 3549e07e97deb67e68b2b72e1c3d3ba3
! 3D vector related routines
!
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module type_vector3d

  implicit none
  save

  private

  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

  public :: vector3d_sp
  type vector3d_sp
     real(sp) :: x,y,z
  end type vector3d_sp

  public :: vector3d_dp
  type vector3d_dp
     real(dp) :: x,y,z
  end type vector3d_dp

  public :: operator(.eq.)
  interface operator(.eq.)
     module procedure equal_sp
     module procedure equal_dp
  end interface operator(.eq.)

  public :: operator(+)
  interface operator(+)
     module procedure add_vector3d_sp
     module procedure add_vector3d_dp
  end interface operator(+)

  public :: operator(-)
  interface operator(-)
     module procedure sub_vector3d_sp
     module procedure sub_vector3d_dp
     module procedure minus_vector3d_sp
     module procedure minus_vector3d_dp
  end interface operator(-)

  public :: operator(.dot.)
  interface operator(.dot.)
     module procedure dot_product_sp
     module procedure dot_product_dp
  end interface operator(.dot.)

  public :: operator(.cross.)
  interface operator(.cross.)
     module procedure cross_product_sp
     module procedure cross_product_dp
  end interface operator(.cross.)

  public :: operator(*)
  interface operator(*)
     module procedure scalar_vector3d_mult_sp
     module procedure scalar_vector3d_mult_dp
     module procedure vector3d_scalar_mult_sp
     module procedure vector3d_scalar_mult_dp
  end interface operator(*)

  public :: operator(/)
  interface operator(/)
     module procedure scalar_vector3d_div_sp
     module procedure scalar_vector3d_div_dp
     module procedure vector3d_scalar_div_sp
     module procedure vector3d_scalar_div_dp
  end interface operator(/)

  public :: vector3d_to_angle3d
  interface vector3d_to_angle3d
     module procedure vector3d_to_angle3d_sp
     module procedure vector3d_to_angle3d_dp
  end interface vector3d_to_angle3d

  public :: angle3d_to_vector3d
  interface angle3d_to_vector3d
     module procedure angle3d_to_vector3d_sp
     module procedure angle3d_to_vector3d_dp
  end interface angle3d_to_vector3d

  public :: random_sphere_vector3d
  interface random_sphere_vector3d
     module procedure random_sphere_vector3d_sp
     module procedure random_sphere_vector3d_dp
  end interface random_sphere_vector3d

contains

  !**********************************************************************!
  ! Test equality
  !**********************************************************************!

  logical function equal_dp(a, b) result(e)

    implicit none

    type(vector3d_dp),intent(in) :: a, b

    e = a%x == b%x .and. a%y == b%y .and. a%z == b%z

  end function equal_dp

  !**********************************************************************!
  ! Vector addition
  !**********************************************************************!

  type(vector3d_dp) function add_vector3d_dp(a,b) result(v)

    implicit none

    type(vector3d_dp),intent(in) :: a,b

    v%x = a%x + b%x
    v%y = a%y + b%y
    v%z = a%z + b%z

  end function add_vector3d_dp

  !**********************************************************************!
  ! Vector subtraction
  !**********************************************************************!

  type(vector3d_dp) function sub_vector3d_dp(a,b) result(v)

    implicit none

    type(vector3d_dp),intent(in) :: a,b

    v%x = a%x - b%x
    v%y = a%y - b%y
    v%z = a%z - b%z

  end function sub_vector3d_dp

  !**********************************************************************!
  ! Unary minus for vectors
  !**********************************************************************!

  type(vector3d_dp) function minus_vector3d_dp(a) result(v)

    implicit none

    type(vector3d_dp),intent(in) :: a

    v%x = -a%x
    v%y = -a%y
    v%z = -a%z

  end function minus_vector3d_dp

  !**********************************************************************!
  ! Vector dot product
  !**********************************************************************!

  real(dp) function dot_product_dp(a,b) result(p)

    implicit none

    type(vector3d_dp),intent(in) :: a,b

    p = a%x*b%x + a%y*b%y + a%z*b%z

  end function dot_product_dp

  !**********************************************************************!
  ! Vector cross product
  !**********************************************************************!

  type(vector3d_dp) function cross_product_dp(a,b) result(p)

    implicit none

    type(vector3d_dp),intent(in) :: a,b

    p%x = a%y*b%z - a%z*b%y
    p%y = a%z*b%x - a%x*b%z
    p%z = a%x*b%y - a%y*b%x

  end function cross_product_dp

  !**********************************************************************!
  ! Scalar * Vector
  !**********************************************************************!

  type(vector3d_dp) function scalar_vector3d_mult_dp(a,b) result(v)

    implicit none

    real(dp),intent(in)          :: a
    type(vector3d_dp),intent(in) :: b

    v%x = a * b%x
    v%y = a * b%y
    v%z = a * b%z

  end function scalar_vector3d_mult_dp

  type(vector3d_dp) function vector3d_scalar_mult_dp(a,b) result(v)

    implicit none

    type(vector3d_dp),intent(in) :: a
    real(dp),intent(in)        :: b

    v%x = a%x * b
    v%y = a%y * b
    v%z = a%z * b

  end function vector3d_scalar_mult_dp

  !**********************************************************************!
  ! Scalar / Vector
  !**********************************************************************!

  type(vector3d_dp) function scalar_vector3d_div_dp(a,b) result(v)

    implicit none

    real(dp),intent(in)          :: a
    type(vector3d_dp),intent(in) :: b

    v%x = a / b%x
    v%y = a / b%y
    v%z = a / b%z

  end function scalar_vector3d_div_dp

  type(vector3d_dp) function vector3d_scalar_div_dp(a,b) result(v)

    implicit none

    type(vector3d_dp),intent(in) :: a
    real(dp),intent(in)          :: b

    v%x = a%x / b
    v%y = a%y / b
    v%z = a%z / b

  end function vector3d_scalar_div_dp

  !**********************************************************************!
  ! Vector to angle and vice-versa
  !**********************************************************************!

  subroutine vector3d_to_angle3d_dp(v,a)

    use type_angle3d

    implicit none

    type(vector3d_dp),intent(in) :: v
    ! input 3d vector

    type(angle3d_dp),intent(out) :: a
    ! output 3d angle

    real(dp) :: small_r,big_r

    small_r = sqrt( v%x * v%x + v%y * v%y )
    big_r   = sqrt( v%x * v%x + v%y * v%y + v%z * v%z )

    a%cosp = v%x / small_r
    a%sinp = v%y / small_r

    a%cost = v%z / big_r
    a%sint = small_r / big_r

  end subroutine vector3d_to_angle3d_dp

  subroutine angle3d_to_vector3d_dp(a,v)

    use type_angle3d

    implicit none

    type(angle3d_dp),intent(in) :: a
    ! input 3d angle

    type(vector3d_dp),intent(out) :: v
    ! output 3d vector

    v%x = a%sint * a%cosp
    v%y = a%sint * a%sinp
    v%z = a%cost

  end subroutine angle3d_to_vector3d_dp

  !**********************************************************************!
  ! Random position on a unit sphere
  !**********************************************************************!

  subroutine random_sphere_vector3d_dp(v)
    use lib_random
    implicit none
    type(vector3d_dp),intent(out) :: v
    real(dp) :: mu,phi,radius_cut
    call random_sphere(mu,phi)
    radius_cut = sqrt(1._dp-mu*mu)
    v%x = radius_cut * cos(phi)
    v%y = radius_cut * sin(phi)
    v%z = mu
  end subroutine random_sphere_vector3d_dp

  !**********************************************************************!
  ! Test equality
  !**********************************************************************!

  logical function equal_sp(a, b) result(e)

    implicit none

    type(vector3d_sp),intent(in) :: a, b

    e = a%x == b%x .and. a%y == b%y .and. a%z == b%z

  end function equal_sp

  !**********************************************************************!
  ! Vector addition
  !**********************************************************************!

  type(vector3d_sp) function add_vector3d_sp(a,b) result(v)

    implicit none

    type(vector3d_sp),intent(in) :: a,b

    v%x = a%x + b%x
    v%y = a%y + b%y
    v%z = a%z + b%z

  end function add_vector3d_sp

  !**********************************************************************!
  ! Vector subtraction
  !**********************************************************************!

  type(vector3d_sp) function sub_vector3d_sp(a,b) result(v)

    implicit none

    type(vector3d_sp),intent(in) :: a,b

    v%x = a%x - b%x
    v%y = a%y - b%y
    v%z = a%z - b%z

  end function sub_vector3d_sp

  !**********************************************************************!
  ! Unary minus for vectors
  !**********************************************************************!

  type(vector3d_sp) function minus_vector3d_sp(a) result(v)

    implicit none

    type(vector3d_sp),intent(in) :: a

    v%x = -a%x
    v%y = -a%y
    v%z = -a%z

  end function minus_vector3d_sp

  !**********************************************************************!
  ! Vector dot product
  !**********************************************************************!

  real(sp) function dot_product_sp(a,b) result(p)

    implicit none

    type(vector3d_sp),intent(in) :: a,b

    p = a%x*b%x + a%y*b%y + a%z*b%z

  end function dot_product_sp

  !**********************************************************************!
  ! Vector cross product
  !**********************************************************************!

  type(vector3d_sp) function cross_product_sp(a,b) result(p)

    implicit none

    type(vector3d_sp),intent(in) :: a,b

    p%x = a%y*b%z - a%z*b%y
    p%y = a%z*b%x - a%x*b%z
    p%z = a%x*b%y - a%y*b%x

  end function cross_product_sp

  !**********************************************************************!
  ! Scalar * Vector
  !**********************************************************************!

  type(vector3d_sp) function scalar_vector3d_mult_sp(a,b) result(v)

    implicit none

    real(sp),intent(in)          :: a
    type(vector3d_sp),intent(in) :: b

    v%x = a * b%x
    v%y = a * b%y
    v%z = a * b%z

  end function scalar_vector3d_mult_sp

  type(vector3d_sp) function vector3d_scalar_mult_sp(a,b) result(v)

    implicit none

    type(vector3d_sp),intent(in) :: a
    real(dp),intent(in)        :: b

    v%x = a%x * b
    v%y = a%y * b
    v%z = a%z * b

  end function vector3d_scalar_mult_sp

  !**********************************************************************!
  ! Scalar / Vector
  !**********************************************************************!

  type(vector3d_sp) function scalar_vector3d_div_sp(a,b) result(v)

    implicit none

    real(sp),intent(in)          :: a
    type(vector3d_sp),intent(in) :: b

    v%x = a / b%x
    v%y = a / b%y
    v%z = a / b%z

  end function scalar_vector3d_div_sp

  type(vector3d_sp) function vector3d_scalar_div_sp(a,b) result(v)

    implicit none

    type(vector3d_sp),intent(in) :: a
    real(sp),intent(in)          :: b

    v%x = a%x / b
    v%y = a%y / b
    v%z = a%z / b

  end function vector3d_scalar_div_sp

  !**********************************************************************!
  ! Vector to angle and vice-versa
  !**********************************************************************!

  subroutine vector3d_to_angle3d_sp(v,a)

    use type_angle3d

    implicit none

    type(vector3d_sp),intent(in) :: v
    ! input 3d vector

    type(angle3d_sp),intent(out) :: a
    ! output 3d angle

    real(sp) :: small_r,big_r

    small_r = sqrt( v%x * v%x + v%y * v%y )
    big_r   = sqrt( v%x * v%x + v%y * v%y + v%z * v%z )

    a%cosp = v%x / small_r
    a%sinp = v%y / small_r

    a%cost = v%z / big_r
    a%sint = small_r / big_r

  end subroutine vector3d_to_angle3d_sp

  subroutine angle3d_to_vector3d_sp(a,v)

    use type_angle3d

    implicit none

    type(angle3d_sp),intent(in) :: a
    ! input 3d angle

    type(vector3d_sp),intent(out) :: v
    ! output 3d vector

    v%x = a%sint * a%cosp
    v%y = a%sint * a%sinp
    v%z = a%cost

  end subroutine angle3d_to_vector3d_sp

  !**********************************************************************!
  ! Random position on a unit sphere
  !**********************************************************************!

  subroutine random_sphere_vector3d_sp(v)
    use lib_random
    implicit none
    type(vector3d_sp),intent(out) :: v
    real(sp) :: mu,phi,radius_cut
    call random_sphere(mu,phi)
    radius_cut = sqrt(1._sp-mu*mu)
    v%x = radius_cut * cos(phi)
    v%y = radius_cut * sin(phi)
    v%z = mu
  end subroutine random_sphere_vector3d_sp

end module type_vector3d


MODULE triangle_class
!
!   This module implements a triangle class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
USE shape_class                  ! USE parent class
IMPLICIT NONE

! Type definition
TYPE,PUBLIC,EXTENDS(shape) :: triangle

   ! Additional instance variables.
   REAL :: s = 0               ! Length of side

CONTAINS

   ! Bound procedures
   PROCEDURE,PUBLIC :: initialize => initialize_sub
   PROCEDURE,PUBLIC :: area => get_area_fn
   PROCEDURE,PUBLIC :: perimeter => get_perimeter_fn
   PROCEDURE,PUBLIC :: to_string => to_string_fn

END TYPE triangle

! Restrict access to the actual procedure names
PRIVATE :: initialize_sub, get_area_fn, get_perimeter_fn
PRIVATE :: to_string_fn

! Now add methods
CONTAINS

   SUBROUTINE initialize_sub(this,s)
   !
   ! Initialize the triangle object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(triangle) :: this             ! Triangle object
   REAL,INTENT(IN) :: s                ! Length of side

   ! Initialize the triangle
   this%s = s

   END SUBROUTINE initialize_sub

   REAL FUNCTION get_area_fn(this)
   !
   ! Return the area of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(triangle) :: this             ! Triangle object

   ! Calculate area
   get_area_fn = SQRT(3.0) / 4.0 * this%s**2

   END FUNCTION get_area_fn

   REAL FUNCTION get_perimeter_fn(this)
   !
   ! Return the perimeter of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(triangle) :: this             ! Triangle object

   ! Calculate perimeter
   get_perimeter_fn = 3.0 * this%s

   END FUNCTION get_perimeter_fn

   CHARACTER(len=50) FUNCTION to_string_fn(this)
   !
   ! Return the a character description of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(triangle) :: this             ! Triangle object

   ! Return description
   WRITE (to_string_fn,'(A,F6.2)') 'Equilateral triangle of side ', &
      this%s

   END FUNCTION to_string_fn

END MODULE triangle_class


!##############################################################################
! PROGRAM CalcUtil
!
! ## Calculate utility of household for different values of c1 and c2
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog01_16m.f90"

program CalcUtil

    use Globals
    use UtilFunc

    implicit none
    real*8 :: c1, c2, util
    integer :: j

    ! initialize parameters
    beta = 0.9d0
    eta = 2d0

    ! calculate utility for different consumption pairs
    ! between 0.3 and 0.7
    do j = 0, 20
        c1 = 0.3d0 + (0.7d0-0.3d0)/20*dble(j)
        c2 = 1d0-c1
        util = utility(c1, c2)
        write(*,'(3f10.4)')c1, c2, util
    enddo

end program