module envelopes
  use utils,only: fp,ip
  use constants,only: pi

  implicit none

  type, abstract :: envelope

   contains
     procedure(value_at_interface),deferred :: value_at
     procedure(set_parameters_interface),deferred :: set_parameters
  end type envelope

  abstract interface
     function value_at_interface(this,t) result(y)
       use utils,only:fp,ip
       import envelope
       class(envelope), intent(in) :: this
       real(fp), intent(in) :: t
       complex(fp) :: y
     end function value_at_interface
  end interface

  abstract interface
     subroutine set_parameters_interface(this,parameter_array)
       use utils,only:fp,ip
       import envelope
       class(envelope), intent(inout) :: this
       complex(fp),dimension(:),intent(in) :: parameter_array
     end subroutine set_parameters_interface
  end interface

  type :: envelope_container
     class(envelope),pointer :: obj
  end type envelope_container

  type,extends(envelope) :: constant_envelope
  complex(fp) :: A
contains
  procedure :: value_at=>value_at_constant_envelope
  procedure :: initialize=>initialize_constant_envelope
  procedure :: set_parameters=>set_parameters_constant_envelope
end type constant_envelope

type,extends(envelope) :: gaussian_envelope
   complex(fp) :: A
   real(fp) :: sigma,t0
   real(fp) :: cutoff
   real(fp) :: trnc_point,trnc_point_s
 contains
   procedure :: value_at=>value_at_gaussian_envelope
   procedure :: initialize=>initialize_gaussian_envelope
   procedure :: set_t0=>set_t0_gaussian_envelope
   procedure :: set_A=>set_A_gaussian_envelope
   procedure :: set_parameters=>set_parameters_gaussian_envelope
end type gaussian_envelope

type,extends(envelope) :: rectangular_envelope
   complex(fp) :: A
   real(fp) :: duration,t0
 contains
   procedure :: value_at=>value_at_rectangular_envelope
   procedure :: initialize=>initialize_rectangular_envelope
   procedure :: set_parameters=>set_parameters_rectangular_envelope
end type rectangular_envelope

type,extends(envelope) :: dummy_envelope
 contains
   procedure :: value_at=>value_at_dummy_envelope
   procedure :: initialize=>initialize_dummy_envelope
   procedure :: set_parameters=>set_parameters_dummy_envelope
end type dummy_envelope

type,extends(envelope) :: lorenzian_envelope
   complex(fp) :: A
   real(fp) :: Gamma,t0
 contains
   procedure :: value_at=>value_at_lorenzian_envelope
   procedure :: initialize=>initialize_lorenzian_envelope
   procedure :: set_parameters=>set_parameters_lorenzian_envelope
end type lorenzian_envelope

type,extends(envelope) :: flat_gaussian_envelope
   complex(fp) :: A
   real(fp) :: sigma,t0,saturation_start,saturation_end
 contains
   procedure :: value_at=>value_at_flat_gaussian_envelope
   procedure :: initialize=>initialize_flat_gaussian_envelope
   procedure :: set_parameters=>set_parameters_flat_gaussian_envelope
end type flat_gaussian_envelope

type,extends(envelope) :: inverse_cosh_envelope
   complex(fp) :: A
   real(fp) :: ts,t0,sigma,cutoff,trnc_point
 contains
   procedure :: value_at=>value_at_inverse_cosh_envelope
   procedure :: initialize=>initialize_inverse_cosh_envelope
   procedure :: set_parameters=>set_parameters_inverse_cosh_envelope
end type inverse_cosh_envelope

type,extends(inverse_cosh_envelope) :: inverse_sqrt_cosh_envelope
 contains
   procedure :: value_at=>value_at_inverse_sqrt_cosh_envelope
   procedure :: initialize=>initialize_inverse_sqrt_cosh_envelope
   procedure :: initialize_inverse_sqrt_cosh_envelope
   procedure :: set_parameters=>set_parameters_inverse_sqrt_cosh_envelope
end type inverse_sqrt_cosh_envelope

type,extends(inverse_sqrt_cosh_envelope) :: inverse_sqrt_cosh_envelope_dfa
   class(envelope),pointer :: target_envelope
   real(fp) :: eps,delta,tis,dt,g
 contains
   procedure :: value_at=>value_at_inverse_sqrt_cosh_envelope_dfa
   procedure :: initialize_inverse_sqrt_cosh_envelope_dfa
   procedure :: set_parameters=>set_parameters_inverse_sqrt_cosh_envelope_dfa
end type inverse_sqrt_cosh_envelope_dfa

type,extends(envelope) :: general_dfa
   real(fp) :: eps,delta,tis,dt,g
   class(envelope),pointer :: shift_envelope
   class(envelope),pointer :: target_envelope
 contains
   procedure :: value_at=>value_at_general_dfa
   procedure :: initialize=>initialize_general_dfa
   procedure :: set_parameters=>set_parameters_general_dfa
   procedure :: set_delta => set_delta_general_dfa
end type general_dfa

type,extends(envelope) :: general_dfa_01
   real(fp) :: eps,delta,tis,dt,g
   class(envelope),pointer :: shift_envelope
   class(envelope),pointer :: target_envelope
 contains
   procedure :: value_at=>value_at_general_dfa_01
   procedure :: initialize=>initialize_general_dfa_01
   procedure :: set_parameters=>set_parameters_general_dfa_01
   procedure :: set_delta => set_delta_general_dfa_01
end type general_dfa_01

type,extends(envelope) :: general_dfa_12
   real(fp) :: eps,delta,tis,dt,g
   class(envelope),pointer :: shift_envelope
   class(envelope),pointer :: target_envelope
 contains
   procedure :: value_at=>value_at_general_dfa_12
   procedure :: initialize=>initialize_general_dfa_12
   procedure :: set_parameters=>set_parameters_general_dfa_12
   procedure :: set_delta => set_delta_general_dfa_12
end type general_dfa_12

type,extends(envelope) :: gaussian_linear_fractional_stirap
   complex(fp) :: A
   real(fp) :: sigma,t0,t2
   real(fp) :: cutoff
   real(fp) :: trnc_point
 contains
   procedure :: value_at=>value_at_gaussian_linear_fractional_stirap
   procedure :: initialize=>initialize_gaussian_linear_fractional_stirap
   procedure :: set_t0=>set_t0_gaussian_linear_fractional_stirap
   procedure :: set_A=>set_A_gaussian_linear_fractional_stirap
   procedure :: set_parameters=>set_parameters_gaussian_linear_fractional_stirap
end type gaussian_linear_fractional_stirap

type,extends(envelope) :: linear_zero_area_pulse
   real(fp) :: t0,tf
   complex(fp) :: A
 contains
   procedure :: value_at=>value_at_linear_zero_area_pulse
   procedure :: initialize=>initialize_linear_zero_area_pulse
   procedure :: set_parameters=>set_parameters_linear_zero_area_pulse
end type linear_zero_area_pulse

type,extends(envelope) :: two_photon_linear_zero_area_pulse
   real(fp) :: t0,tf
   complex(fp) :: A
   real(fp) :: phase_shift
 contains
   procedure :: value_at=>value_at_two_photon_linear_zero_area_pulse
   procedure :: initialize=>initialize_two_photon_linear_zero_area_pulse
   procedure :: set_parameters=>set_parameters_two_photon_linear_zero_area_pulse
end type two_photon_linear_zero_area_pulse

type,extends(envelope) :: two_photon_linear_trnc_pulse
   real(fp) :: t0,tf
   complex(fp) :: A,A2
   real(fp) :: phase_shift
 contains
   procedure :: value_at=>value_at_two_photon_linear_trnc_pulse
   procedure :: initialize=>initialize_two_photon_linear_trnc_pulse
   procedure :: set_parameters=>set_parameters_two_photon_linear_trnc_pulse
end type two_photon_linear_trnc_pulse

type,extends(envelope) :: exp_polinom
   real(fp) :: t0,td,trnc_point,cutoff,n
   complex(fp) :: A
 contains
   procedure :: value_at=>value_at_exp_polinom
   procedure :: initialize=>initialize_exp_polinom
   procedure :: set_parameters=>set_parameters_exp_polinom
end type exp_polinom

type,extends(envelope) :: polynomial_envelope
   complex(fp),dimension(:),allocatable :: A
   real(fp) :: trnc_point
 contains
   procedure :: value_at=>value_at_polynomial_envelope
   procedure :: initialize=>initialize_polynomial_envelope
   procedure :: set_parameters=>set_parameters_polynomial_envelope
end type polynomial_envelope

type,extends(envelope) :: sqrt_polynomial_envelope
   complex(fp),dimension(:),allocatable :: A
   real(fp) :: trnc_point
 contains
   procedure :: value_at=>value_at_sqrt_polynomial_envelope
   procedure :: initialize=>initialize_sqrt_polynomial_envelope
   procedure :: set_parameters=>set_parameters_sqrt_polynomial_envelope
end type sqrt_polynomial_envelope

type,extends(envelope) :: lr_envelope_01
   class(envelope),pointer :: alpha,beta,dalpha,dbeta,Omega02
   complex(fp) :: factor
   real(fp) :: trnc_point
 contains
   procedure :: value_at=>value_at_lr_envelope_01
   procedure :: initialize=>initialize_lr_envelope_01
   procedure :: set_parameters=>set_parameters_lr_envelope_01
end type lr_envelope_01

type,extends(envelope) :: lr_envelope_12
   class(envelope),pointer :: alpha,beta,dalpha,dbeta,Omega02
   complex(fp) :: factor
   real(fp) :: trnc_point
 contains
   procedure :: value_at=>value_at_lr_envelope_12
   procedure :: initialize=>initialize_lr_envelope_12
   procedure :: set_parameters=>set_parameters_lr_envelope_12
end type lr_envelope_12

type,extends(envelope) :: sa_stirap_det_02
   real(fp) :: dt,delta,phi,A_factor,csr
   type(envelope_container),dimension(:),allocatable :: d01,d12
   integer(ip) :: nenv01,nenv12,env_cont_size_01,env_cont_size_12

 contains
   procedure :: value_at=>value_at_sa_stirap_det_02
   procedure :: initialize=>initialize_sa_stirap_det_02
   procedure :: set_parameters=>set_parameters_sa_stirap_det_02
   procedure :: add_envelope_01 => add_envelope_01_sa_stirap_det_02
   procedure :: add_envelope_12 => add_envelope_12_sa_stirap_det_02
   !procedure :: set_delta => set_delta_sa_stirap_det_02
end type sa_stirap_det_02

type,extends(envelope) :: sa_stirap_det_01
   real(fp) :: delta,dt
   class(envelope),pointer :: e01,e12
 contains
   procedure :: value_at=>value_at_sa_stirap_det_01
   procedure :: initialize=>initialize_sa_stirap_det_01
   procedure :: set_parameters=>set_parameters_sa_stirap_det_01
   procedure :: set_delta => set_delta_sa_stirap_det_01
end type sa_stirap_det_01

type,extends(envelope) :: sa_stirap_det_12
   real(fp) :: delta,dt
   class(envelope),pointer :: e01,e12
 contains
   procedure :: value_at=>value_at_sa_stirap_det_12
   procedure :: initialize=>initialize_sa_stirap_det_12
   procedure :: set_parameters=>set_parameters_sa_stirap_det_12
   procedure :: set_delta => set_delta_sa_stirap_det_12
end type sa_stirap_det_12

contains
  !#########################################################
  function value_at_constant_envelope(this,t) result(y)
    use utils,only:fp,ip
    class(constant_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    y = this%A
  end function value_at_constant_envelope
  !---------------------------------------------------------
  subroutine initialize_constant_envelope(this,A_in)
    use utils,only:fp,ip
    class(constant_envelope) :: this
    complex(fp), intent(in) :: A_in
    this%A = A_in
  end subroutine initialize_constant_envelope
  !---------------------------------------------------------
  subroutine set_parameters_constant_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(constant_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect in set_parameters_constant_envelope.'
       call exit(1)
    end if
    this%A = parameter_array(1)
  end subroutine set_parameters_constant_envelope
  !#########################################################
  function value_at_gaussian_envelope(this,t) result(y)
    use utils,only:fp,ip
    class(gaussian_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: value_at_cutoff
    if(this%cutoff<=0.0_fp) then
       y = this%A*exp(-(t-this%t0)**2/(2*this%sigma**2))
    else
       if(t < (this%t0 - this%cutoff*this%sigma) .or. t > (this%t0 + this%cutoff*this%sigma) .or. &
            t > this%trnc_point .or. t < this%trnc_point_s) then
          y = 0.0_fp
       else
          value_at_cutoff = exp(-this%cutoff**2/2.0_fp)
          y = this%A/(1 - value_at_cutoff)*(exp(-(t-this%t0)**2/(2*this%sigma**2)) - value_at_cutoff)
       end if
    end if
  end function value_at_gaussian_envelope
  !---------------------------------------------------------
  subroutine initialize_gaussian_envelope(this,A,sigma,t0,cutoff,trnc_point,trnc_point_s)
    use utils,only:fp,ip
    implicit none
    class(gaussian_envelope) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: sigma,t0
    real(fp),optional,intent(in) :: cutoff,trnc_point,trnc_point_s
    this%A = A
    this%sigma = sigma
    this%t0 = t0
    if(present(cutoff)) then
       this%cutoff = cutoff
    else
       this%cutoff = -1.0_fp
    end if
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(trnc_point)
    end if

    if(present(trnc_point_s)) then
       this%trnc_point_s = trnc_point_s
    else
       this%trnc_point_s = -huge(trnc_point)
    end if
  end subroutine initialize_gaussian_envelope
  !---------------------------------------------------------
  subroutine set_t0_gaussian_envelope(this,t0)
    implicit none
    class(gaussian_envelope) :: this
    real(fp),intent(in) :: t0
    this%t0 = t0
  end subroutine set_t0_gaussian_envelope
  !---------------------------------------------------------
  subroutine set_A_gaussian_envelope(this,A)
    implicit none
    class(gaussian_envelope) :: this
    real(fp),intent(in) :: A
    this%A = A
  end subroutine set_A_gaussian_envelope
  !---------------------------------------------------------
  subroutine set_parameters_gaussian_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(gaussian_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 3) then
       write(*,*) 'Number of parameters incorrect in set_parameters_gaussian_envelope.'
       call exit(1)
    end if
    this%A = parameter_array(1)
    this%sigma = real(parameter_array(2))
    this%t0 = real(parameter_array(3))
    if(size(parameter_array) == 4) then
       this%cutoff = real(parameter_array(4))
    end if
    if(size(parameter_array) == 5) then
       this%trnc_point = real(parameter_array(5))
    end if
    if(size(parameter_array) == 6) then
       this%trnc_point_s = real(parameter_array(6))
    end if
  end subroutine set_parameters_gaussian_envelope
    !#########################################################
  function value_at_gaussian_linear_fractional_stirap(this,t) result(y)
    use utils,only:fp,ip
    class(gaussian_linear_fractional_stirap), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: f
    if(t>this%trnc_point) then
       if(t<this%trnc_point+this%t2) then
          f = this%A*exp(-(this%trnc_point-this%t0)**2/(2*this%sigma**2))
          y = -f/this%t2*t + f + f*this%trnc_point/this%t2
       else
          y = 0.0_fp
       endif
    else
       y = this%A*exp(-(t-this%t0)**2/(2*this%sigma**2))
    endif
    !write(*,*) y
  end function value_at_gaussian_linear_fractional_stirap
  !---------------------------------------------------------
  subroutine initialize_gaussian_linear_fractional_stirap(this,A,sigma,t0,cutoff,trnc_point,t2)
    use utils,only:fp,ip
    implicit none
    class(gaussian_linear_fractional_stirap) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: sigma,t0
    real(fp),optional,intent(in) :: cutoff,trnc_point,t2
    this%A = A
    this%sigma = sigma
    this%t0 = t0
    if(present(cutoff)) then
       this%cutoff = cutoff
    else
       this%cutoff = -1.0_fp
    end if
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(trnc_point)
    end if
    if(present(t2)) then
       this%t2 = t2
    else
       this%t2 = 0.0_fp
    end if

  end subroutine initialize_gaussian_linear_fractional_stirap
  !---------------------------------------------------------
  subroutine set_t0_gaussian_linear_fractional_stirap(this,t0)
    implicit none
    class(gaussian_linear_fractional_stirap) :: this
    real(fp),intent(in) :: t0
    this%t0 = t0
  end subroutine set_t0_gaussian_linear_fractional_stirap
  !---------------------------------------------------------
  subroutine set_A_gaussian_linear_fractional_stirap(this,A)
    implicit none
    class(gaussian_linear_fractional_stirap) :: this
    real(fp),intent(in) :: A
    this%A = A
  end subroutine set_A_gaussian_linear_fractional_stirap
  !---------------------------------------------------------
  subroutine set_parameters_gaussian_linear_fractional_stirap(this,parameter_array)
    use utils,only:fp,ip
    class(gaussian_linear_fractional_stirap), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 3) then
       write(*,*) 'Number of parameters incorrect in set_parameters_gaussian_envelope.'
       call exit(1)
    end if
    this%A = parameter_array(1)
    this%sigma = real(parameter_array(2))
    this%t0 = real(parameter_array(3))
    if(size(parameter_array) == 4) then
       this%cutoff = real(parameter_array(4))
    end if
    if(size(parameter_array) == 5) then
       this%trnc_point = real(parameter_array(5))
    end if
    if(size(parameter_array) == 6) then
       this%t2 = real(parameter_array(6))
    end if
  end subroutine set_parameters_gaussian_linear_fractional_stirap
  !#########################################################
  function value_at_rectangular_envelope(this,t) result(y)
    use utils,only:fp,ip
    implicit none
    class(rectangular_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    if(t >= this%t0 .and. (t<= this%t0 + this%duration)) then
       y = this%A
    else
       y = (0.0_fp,0.0_fp)
    endif
  end function value_at_rectangular_envelope
  !---------------------------------------------------------
  subroutine initialize_rectangular_envelope(this,A,duration,t0)
    use utils,only:fp,ip
    class(rectangular_envelope) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: duration,t0
    this%A = A
    this%duration = duration
    this%t0 = t0
  end subroutine initialize_rectangular_envelope
  !---------------------------------------------------------
  subroutine set_parameters_rectangular_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(rectangular_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 3) then
       write(*,*) 'Number of parameters incorrect in set_parameters_gaussian_envelope.'
       call exit(1)
    end if
    this%A = parameter_array(1)
    this%duration = real(parameter_array(2))
    this%t0 = real(parameter_array(3))
  end subroutine set_parameters_rectangular_envelope
  !#########################################################
  function value_at_dummy_envelope(this,t) result(y)
    use utils,only:fp,ip
    implicit none
    class(dummy_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    y = (0.0_fp,0.0_fp)
  end function value_at_dummy_envelope
  !---------------------------------------------------------
  subroutine initialize_dummy_envelope(this)
    use utils,only:fp,ip
    class(dummy_envelope) :: this
  end subroutine initialize_dummy_envelope
  !---------------------------------------------------------
  subroutine set_parameters_dummy_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(dummy_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
  end subroutine set_parameters_dummy_envelope
  !#########################################################
  function value_at_lorenzian_envelope(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    implicit none
    class(lorenzian_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    !y=this%A*0.5_fp/pi*this%Gamma/((t-this%t0)**2+0.5_fp*this%Gamma**2) ! Definition from Wolfram
    !y=this%A*0.5_fp*this%Gamma**2/((t-this%t0)**2+0.5_fp*this%Gamma**2) ! Max(y) = A
    !y=this%A*this%Gamma**2/((t-this%t0)**2+this%Gamma**2) ! Max(y) = A, Gamma = 0.5*FWHM
    y=this%A*this%Gamma**2/((t-this%t0)**2+this%Gamma**2) - this%A*this%Gamma**2/((0.0_fp-this%t0)**2+this%Gamma**2) ! Max(y) = A, Gamma = 0.5*FWHM
    !write(*,*) y
  end function value_at_lorenzian_envelope
  !---------------------------------------------------------
  subroutine initialize_lorenzian_envelope(this,A,Gamma,t0)
    use utils,only:fp,ip
    class(lorenzian_envelope) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: Gamma,t0
    this%A = A
    this%Gamma = Gamma
    this%t0 = t0
  end subroutine initialize_lorenzian_envelope
  !---------------------------------------------------------
  subroutine set_parameters_lorenzian_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(lorenzian_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 3) then
       write(*,*) 'Number of parameters incorrect in set_parameters_gaussian_envelope.'
       call exit(1)
    end if
    this%A = parameter_array(1)
    this%Gamma = real(parameter_array(2))
    this%t0 = real(parameter_array(3))
  end subroutine set_parameters_lorenzian_envelope
  !#########################################################
  function value_at_inverse_cosh_envelope(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    implicit none
    class(inverse_cosh_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    if(t<this%t0-this%cutoff) then
       y = 0.0_fp
    elseif(t > this%t0+this%cutoff .or. t > this%trnc_point) then
       y = 0.0_fp
    else
       !y = this%A*this%ts/(this%sigma**2*cosh(this%ts*(t-this%t0)/this%sigma**2))
       y = this%A/cosh(this%ts*(t-this%t0)/this%sigma**2)
    end if
  end function value_at_inverse_cosh_envelope
  !---------------------------------------------------------
  subroutine initialize_inverse_cosh_envelope(this,A,ts,t0,sigma,cutoff,trnc_point)
    use utils,only:fp,ip
    class(inverse_cosh_envelope) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: ts,sigma,t0
    real(fp), optional,intent(in) :: cutoff,trnc_point
    this%A = A
    this%ts = ts
    this%sigma = sigma
    this%t0 = t0
    if(present(cutoff)) then
       this%cutoff = cutoff
    else
       this%cutoff = huge(1.0_fp)
    end if

    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(1.0_fp)
    end if
  end subroutine initialize_inverse_cosh_envelope
  !---------------------------------------------------------
  subroutine set_parameters_inverse_cosh_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(inverse_cosh_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) > 0) then
       this%A = parameter_array(1)
    endif
    if(size(parameter_array) > 1) then
       this%ts = real(parameter_array(2))
    endif
    if(size(parameter_array) > 2) then
       this%sigma = real(parameter_array(3))
    endif
    if(size(parameter_array) > 3) then
       this%t0 = real(parameter_array(4))
    end if
    if(size(parameter_array) > 4) then
       this%cutoff = real(parameter_array(5))
    end if
    if(size(parameter_array) > 5) then
       this%trnc_point = real(parameter_array(6))
    end if
  end subroutine set_parameters_inverse_cosh_envelope
  !#########################################################
  function value_at_inverse_sqrt_cosh_envelope(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    implicit none
    class(inverse_sqrt_cosh_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    if(abs(this%A)>0.0_fp) then
       y = sqrt(abs(this%inverse_cosh_envelope%value_at(t)/this%A))*this%A
    else
       y = 0.0_fp
    end if
  end function value_at_inverse_sqrt_cosh_envelope
  !---------------------------------------------------------
  subroutine initialize_inverse_sqrt_cosh_envelope(this,A,ts,t0,sigma,cutoff,trnc_point)
    use utils,only:fp,ip
    class(inverse_sqrt_cosh_envelope) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: ts,sigma,t0
    real(fp), optional,intent(in) :: cutoff,trnc_point
    real(fp) :: cutoff_temp,trnc_point_temp
    if(present(cutoff)) then
       cutoff_temp = cutoff
    else
       cutoff_temp = huge(1.0_fp)
    end if
    if(present(trnc_point)) then
       trnc_point_temp = trnc_point
    else
       trnc_point_temp = huge(1.0_fp)
    end if

    call this%inverse_cosh_envelope%initialize(A,ts,t0,sigma,cutoff_temp,trnc_point_temp)
  end subroutine initialize_inverse_sqrt_cosh_envelope
  !---------------------------------------------------------
  subroutine set_parameters_inverse_sqrt_cosh_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(inverse_sqrt_cosh_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%inverse_cosh_envelope%set_parameters(parameter_array)
  end subroutine set_parameters_inverse_sqrt_cosh_envelope
  !#########################################################
  function value_at_inverse_sqrt_cosh_envelope_dfa(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(inverse_sqrt_cosh_envelope_dfa), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: Omega,dt_c,phi
    integer(ip) :: ii,nis
    real(fp),dimension(:),allocatable :: x,r

    nis = ceiling((t - this%tis)/this%dt)+1
    dt_c = (t - this%tis)/(nis-1)
    allocate(x(nis),r(nis))

    do ii=1,nis
       x(ii) = this%tis + (ii-1)*dt_c
       r(ii) = (abs(this%target_envelope%value_at(x(ii)))*2.0_fp)**2*(1-this%g**2)/(4.0_fp*this%delta)
    end do
    phi = trapz(x,r)
    !write(*,*) phi
    !write(*,*) r
    !write(*,*) nis,x(nis)
    !open(11,file="phi_test.dat",position="append")
    !write(11,*) phi
    !close(11)
    y = this%inverse_sqrt_cosh_envelope%value_at(t)*exp((0.0_fp,1.0_fp)*phi)
  end function value_at_inverse_sqrt_cosh_envelope_dfa
  !---------------------------------------------------------
  subroutine initialize_inverse_sqrt_cosh_envelope_dfa(this,A,ts,t0,sigma,cutoff,trnc_point,target_envelope, eps,delta,g,tis,dt)
    use utils,only:fp,ip
    class(inverse_sqrt_cosh_envelope_dfa) :: this
    class(envelope),intent(in),target :: target_envelope
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: ts,sigma,t0
    real(fp), intent(in) :: eps,delta,tis,dt,g
    real(fp), optional,intent(in) :: cutoff,trnc_point
    real(fp) :: cutoff_temp,trnc_point_temp
    if(present(cutoff)) then
       cutoff_temp = cutoff
    else
       cutoff_temp = huge(1.0_fp)
    end if
    if(present(trnc_point)) then
       trnc_point_temp = trnc_point
    else
       trnc_point_temp = huge(1.0_fp)
    end if

    call this%inverse_sqrt_cosh_envelope%initialize(A,ts,t0,sigma,cutoff_temp,trnc_point_temp)
    this%target_envelope => target_envelope
    this%eps = eps
    this%delta = delta
    this%g = g
    this%tis = tis
    this%dt = dt
  end subroutine initialize_inverse_sqrt_cosh_envelope_dfa
  !---------------------------------------------------------
  subroutine set_parameters_inverse_sqrt_cosh_envelope_dfa(this,parameter_array)
    use utils,only:fp,ip
    class(inverse_sqrt_cosh_envelope_dfa), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%inverse_sqrt_cosh_envelope%set_parameters(parameter_array)
  end subroutine set_parameters_inverse_sqrt_cosh_envelope_dfa
  !#########################################################
  function value_at_general_dfa(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(general_dfa), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: Omega,dt_c,phi
    integer(ip) :: ii,nis
    real(fp),dimension(:),allocatable :: x,r
    real(fp) :: int_r

    nis = ceiling((t - this%tis)/this%dt)+1
    dt_c = (t - this%tis)/(nis-1)
    allocate(x(nis),r(nis))

    int_r = 4.0_fp*((-1*this%g**2)/(4.0_fp*(this%eps-this%delta)) + (+1)/(4.0_fp*this%delta))

    do ii=1,nis
       x(ii) = this%tis + (ii-1)*dt_c
       !r(ii) = (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(1-this%g**2)/(4.0_fp*this%delta)
       !r(ii) = (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(-1*this%g**2)/(4.0_fp*(this%eps-this%delta)) +&
       !     (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(+1)/(4.0_fp*this%delta)

       r(ii) = abs(this%shift_envelope%value_at(x(ii)))**2*int_r

    end do
    phi = trapz(x,r)
    phi = phi*0.5_fp ! Additional 1/2 for two-photon pulse
    !write(*,*) phi
    !write(*,*) r
    !write(*,*) nis,x(nis)
    !open(11,file="phi_test.dat",position="append")
    !write(11,*) phi
    !close(11)
    !y = this%target_envelope%value_at(t)*exp(-(0.0_fp,1.0_fp)*phi)
    !fixed
    y = this%target_envelope%value_at(t)*exp((0.0_fp,1.0_fp)*phi)
  end function value_at_general_dfa
  !---------------------------------------------------------
  subroutine set_delta_general_dfa(this,delta)
    use utils,only:fp,ip
    implicit none
    class(general_dfa), intent(inout) :: this
    real(fp), intent(in) :: delta
    this%delta = delta
  end subroutine set_delta_general_dfa
  !---------------------------------------------------------
  subroutine initialize_general_dfa(this,shift_envelope,target_envelope,eps,delta,tis,dt,g)
    use utils,only:fp,ip
    class(general_dfa) :: this
    class(envelope),intent(in),target :: target_envelope,shift_envelope
    real(fp), intent(in) :: eps,delta,tis,dt,g

    this%target_envelope => target_envelope
    this%shift_envelope => shift_envelope
    this%eps = eps
    this%delta = delta
    this%g = g
    this%tis = tis
    this%dt = dt
  end subroutine initialize_general_dfa
  !---------------------------------------------------------
  subroutine set_parameters_general_dfa(this,parameter_array)
    use utils,only:fp,ip
    class(general_dfa), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%target_envelope%set_parameters(parameter_array)
  end subroutine set_parameters_general_dfa
  !#########################################################
  function value_at_general_dfa_01(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(general_dfa_01), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: Omega,dt_c,phi
    integer(ip) :: ii,nis
    real(fp),dimension(:),allocatable :: x,r
    real(fp) :: int_r

    nis = ceiling((t - this%tis)/this%dt)+1
    dt_c = (t - this%tis)/(nis-1)
    allocate(x(nis),r(nis))

    int_r = 4.0_fp*((1*this%g**2)/(4.0_fp*(this%eps-this%delta)) + (+2)/(4.0_fp*this%delta))

    do ii=1,nis
       x(ii) = this%tis + (ii-1)*dt_c
       ! Corrections from the first oder pertubation theory. Assumes \delta = 2 \Delta
       !r(ii) = (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(this%g**2+2)/(4.0_fp*this%delta)
       !r(ii) = (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(+1*this%g**2)/(4.0_fp*(this%eps-this%delta)) +&
       !     (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(+2)/(4.0_fp*this%delta)
       r(ii) = abs(this%shift_envelope%value_at(x(ii)))**2*int_r

    end do
    phi = trapz(x,r)
    !phi = -0.5*ph
    !phi = 0.5*phi
    !write(*,*) x
    !write(*,*) r
    !write(*,*) nis,x(nis)
    !open(11,file="phi_test.dat",position="append")
    !write(11,*) phi
    !close(11)
    !y = this%target_envelope%value_at(t)*exp(-(0.0_fp,1.0_fp)*phi)
    !fixed
    y = this%target_envelope%value_at(t)*exp((0.0_fp,1.0_fp)*phi)
  end function value_at_general_dfa_01
  !---------------------------------------------------------
  subroutine set_delta_general_dfa_01(this,delta)
    use utils,only:fp,ip
    implicit none
    class(general_dfa_01), intent(inout) :: this
    real(fp), intent(in) :: delta
    this%delta = delta
  end subroutine set_delta_general_dfa_01
  !---------------------------------------------------------
  subroutine initialize_general_dfa_01(this,shift_envelope,target_envelope,eps,delta,tis,dt,g)
    use utils,only:fp,ip
    class(general_dfa_01) :: this
    class(envelope),intent(in),target :: target_envelope,shift_envelope
    real(fp), intent(in) :: eps,delta,tis,dt,g

    this%target_envelope => target_envelope
    this%shift_envelope => shift_envelope
    this%eps = eps
    this%delta = delta
    this%g = g
    this%tis = tis
    this%dt = dt
  end subroutine initialize_general_dfa_01
  !---------------------------------------------------------
  subroutine set_parameters_general_dfa_01(this,parameter_array)
    use utils,only:fp,ip
    class(general_dfa_01), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%target_envelope%set_parameters(parameter_array)
  end subroutine set_parameters_general_dfa_01
  !#########################################################
  function value_at_general_dfa_12(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(general_dfa_12), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: Omega,dt_c,phi
    integer(ip) :: ii,nis
    real(fp),dimension(:),allocatable :: x,r
    real(fp) :: int_r

    nis = ceiling((t - this%tis)/this%dt)+1
    dt_c = (t - this%tis)/(nis-1)
    allocate(x(nis),r(nis))

    int_r = 4.0_fp*((-2*this%g**2)/(4.0_fp*(this%eps-this%delta)) + (-1)/(4.0_fp*this%delta))

    do ii=1,nis
       x(ii) = this%tis + (ii-1)*dt_c
       !r(ii) = (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(-2*this%g**2-1)/(4.0_fp*this%delta)
       !r(ii) = (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(-2*this%g**2)/(4.0_fp*(this%eps-this%delta)) +&
       !    (abs(this%shift_envelope%value_at(x(ii)))*2.0_fp)**2*(-1)/(4.0_fp*this%delta)
       r(ii) = abs(this%shift_envelope%value_at(x(ii)))**2*int_r

    end do
    phi = trapz(x,r)
    !phi = -0.5*phi
    !write(*,*) phi
    !write(*,*) r
    !write(*,*) nis,x(nis)
    !open(11,file="phi_test.dat",position="append")
    !write(11,*) phi
    !close(11)
    !y = this%target_envelope%value_at(t)*exp(-(0.0_fp,1.0_fp)*phi)
    !fixed
    y = this%target_envelope%value_at(t)*exp((0.0_fp,1.0_fp)*phi)
  end function value_at_general_dfa_12
  !---------------------------------------------------------
  subroutine set_delta_general_dfa_12(this,delta)
    use utils,only:fp,ip
    implicit none
    class(general_dfa_12), intent(inout) :: this
    real(fp), intent(in) :: delta
    this%delta = delta
  end subroutine set_delta_general_dfa_12
  !---------------------------------------------------------
  subroutine initialize_general_dfa_12(this,shift_envelope,target_envelope,eps,delta,tis,dt,g)
    use utils,only:fp,ip
    class(general_dfa_12) :: this
    class(envelope),intent(in),target :: target_envelope,shift_envelope
    real(fp), intent(in) :: eps,delta,tis,dt,g

    this%target_envelope => target_envelope
    this%shift_envelope => shift_envelope
    this%eps = eps
    this%delta = delta
    this%g = g
    this%tis = tis
    this%dt = dt
  end subroutine initialize_general_dfa_12
  !---------------------------------------------------------
  subroutine set_parameters_general_dfa_12(this,parameter_array)
    use utils,only:fp,ip
    class(general_dfa_12), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%target_envelope%set_parameters(parameter_array)
  end subroutine set_parameters_general_dfa_12
  !#########################################################
  function value_at_flat_gaussian_envelope(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    implicit none
    class(flat_gaussian_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    y = saturation_curve(real(this%A*exp(-(t-this%t0)**2/(2*this%sigma**2))),&
         this%saturation_start,this%saturation_end)
    !write(*,*) y
  end function value_at_flat_gaussian_envelope
  !---------------------------------------------------------
  function saturation_curve(current_value,saturation_start,saturation_end) result(y)
    implicit none
    real(fp), intent(in) :: current_value,saturation_start,saturation_end
    real(fp) :: y
    if(current_value>saturation_start) then
       y = saturation_start + (saturation_end-saturation_start)&
            *(1-exp(-(current_value-saturation_start)/(saturation_end-saturation_start)))
    else
       y = current_value
    end if
  end function saturation_curve
  !---------------------------------------------------------
  subroutine initialize_flat_gaussian_envelope(this,A,sigma,t0)
    use utils,only:fp,ip
    use constants, only:pi
    class(flat_gaussian_envelope) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: sigma,t0
    this%A = A
    this%sigma = sigma
    this%t0 = t0
    this%saturation_start = 0.015e9*(2*pi)
    this%saturation_end = 0.02e9*(2*pi)
  end subroutine initialize_flat_gaussian_envelope
  !---------------------------------------------------------
  subroutine set_parameters_flat_gaussian_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(flat_gaussian_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 3) then
       write(*,*) 'Number of parameters incorrect in set_parameters_gaussian_envelope.'
       call exit(1)
    end if
    this%A = parameter_array(1)
    this%sigma = real(parameter_array(2))
    this%t0 = real(parameter_array(3))
    !this%saturation_start = real(parameter_array(4))
    !this%saturation_end = real(parameter_array(5))
  end subroutine set_parameters_flat_gaussian_envelope
  !#########################################################
  function value_at_linear_zero_area_pulse(this,t) result(y)
    use utils,only:fp,ip
    class(linear_zero_area_pulse), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    if(t>this%t0 .and.  t<this%t0+this%tf) then

       if(t<this%t0+this%tf/4.0_fp) then
          y = this%A*(t-this%t0)/this%tf*4.0_fp
       elseif(t <this%t0 + this%tf*0.75_fp) then
          y = this%A*(1 - (t-this%t0 - this%tf*0.25_fp)/this%tf*4.0_fp)
       elseif(t  < this%t0 + this%tf) then
          y = this%A*(-1 + (t -this%t0 - this%tf*0.75_fp)/this%tf*4.0_fp)
       endif
    else
       y = 0.0_fp
    endif
  end function value_at_linear_zero_area_pulse
  !---------------------------------------------------------
  subroutine initialize_linear_zero_area_pulse(this,A,t0,tf)
    use utils,only:fp,ip
    class(linear_zero_area_pulse) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: t0,tf
    this%A = A
    this%t0 = t0
    this%tf = tf
  end subroutine initialize_linear_zero_area_pulse
  !---------------------------------------------------------
  subroutine set_parameters_linear_zero_area_pulse(this,parameter_array)
    use utils,only:fp,ip
    class(linear_zero_area_pulse), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect in set_parameters_constant_envelope.'
       call exit(1)
    else
       this%A = parameter_array(1)
       if(size(parameter_array) > 1) then
          this%t0 = real(parameter_array(2),kind=fp)
       endif
       if(size(parameter_array) > 2) then
          this%tf = real(parameter_array(3),kind=fp)
       endif
    end if
  end subroutine set_parameters_linear_zero_area_pulse
  !#########################################################
  function value_at_two_photon_linear_zero_area_pulse(this,t) result(y)
    use utils,only:fp,ip
    class(two_photon_linear_zero_area_pulse), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    if(t>this%t0 .and.  t<this%t0+this%tf) then

       if(t<this%t0+this%tf/4.0_fp) then
          y = this%A*sqrt((t-this%t0)/this%tf*4.0_fp)
       elseif(t <this%t0 + this%tf*0.5_fp) then
          y = this%A*sqrt((1 - (t-this%t0 - this%tf*0.25_fp)/this%tf*4.0_fp))
       elseif(t  < this%t0 + this%tf*0.75_fp) then
          y = this%A*exp(-cmplx(0.0_fp,this%phase_shift,kind=fp))*sqrt((t -this%t0 - this%tf*0.5_fp)/this%tf*4.0_fp)
       elseif(t  < this%t0 + this%tf) then
          y = this%A*exp(-cmplx(0.0_fp,this%phase_shift,kind=fp))*sqrt((1- (t -this%t0 - this%tf*0.75_fp)/this%tf*4.0_fp))
       endif
    else
       y = 0.0_fp
    endif
  end function value_at_two_photon_linear_zero_area_pulse
  !---------------------------------------------------------
  subroutine initialize_two_photon_linear_zero_area_pulse(this,A,t0,tf,phase_shift)
    use utils,only:fp,ip
    class(two_photon_linear_zero_area_pulse) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: t0,tf,phase_shift
    this%A = A
    this%t0 = t0
    this%tf = tf
    this%phase_shift = phase_shift
  end subroutine initialize_two_photon_linear_zero_area_pulse
  !---------------------------------------------------------
  subroutine set_parameters_two_photon_linear_zero_area_pulse(this,parameter_array)
    use utils,only:fp,ip
    class(two_photon_linear_zero_area_pulse), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect in set_parameters_constant_envelope.'
       call exit(1)
    else
       this%A = parameter_array(1)
       if(size(parameter_array) > 1) then
          this%t0 = real(parameter_array(2),kind=fp)
       endif
       if(size(parameter_array) > 2) then
          this%tf = real(parameter_array(3),kind=fp)
       endif
       if(size(parameter_array) > 3) then
          this%phase_shift = real(parameter_array(4),kind=fp)
       endif
    end if
  end subroutine set_parameters_two_photon_linear_zero_area_pulse
  !#########################################################
  function value_at_two_photon_linear_trnc_pulse(this,t) result(y)
    use utils,only:fp,ip
    class(two_photon_linear_trnc_pulse), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    real(fp) :: t1,t2,t0
    t1 = this%tf/2.0_fp + this%t0
    t2 = this%t0 + this%tf
    t0 = this%t0

    if(t>this%t0 .and.  t<this%t0+this%tf) then

       if(t<t1) then
          y = this%A*sqrt(1 - (t - t0)/(t1-t0))
       elseif(t<0.5_fp*(t1+t2)) then
          y = this%A2*exp(-cmplx(0.0_fp,this%phase_shift,kind=fp))*sqrt((t - t1)/(t2 - 0.5_fp*(t1+t2)))
       else
          y = this%A2*exp(-cmplx(0.0_fp,this%phase_shift,kind=fp))*sqrt(1 - (t - (t1+t2)/2.0_fp)/(t2 - 0.5_fp*(t2+t1)))
       endif
    else
       y = 0.0_fp
    endif
  end function value_at_two_photon_linear_trnc_pulse
  !---------------------------------------------------------
  subroutine initialize_two_photon_linear_trnc_pulse(this,A,t0,tf,phase_shift,A2)
    use utils,only:fp,ip
    class(two_photon_linear_trnc_pulse) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: t0,tf,phase_shift
    complex(fp),intent(in),optional :: A2
    this%A = A
    this%t0 = t0
    this%tf = tf
    this%phase_shift = phase_shift
    if(present(A2)) then
       this%A2 = A2
    else
       this%A2 = A
    endif
  end subroutine initialize_two_photon_linear_trnc_pulse
  !---------------------------------------------------------
  subroutine set_parameters_two_photon_linear_trnc_pulse(this,parameter_array)
    use utils,only:fp,ip
    class(two_photon_linear_trnc_pulse), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect in set_parameters_constant_envelope.'
       call exit(1)
    else
       this%A = parameter_array(1)
       if(size(parameter_array) > 1) then
          this%t0 = real(parameter_array(2),kind=fp)
       endif
       if(size(parameter_array) > 2) then
          this%tf = real(parameter_array(3),kind=fp)
       endif
       if(size(parameter_array) > 3) then
          this%phase_shift = real(parameter_array(4),kind=fp)
       endif
       if(size(parameter_array) > 4) then
          this%A2 = real(parameter_array(5),kind=fp)
       endif
    end if
  end subroutine set_parameters_two_photon_linear_trnc_pulse
  !#########################################################
  function value_at_exp_polinom(this,t) result(y)
    use utils,only:fp,ip
    class(exp_polinom), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    !write(*,*) this%t0,this%n,this%td,this%cutoff,this%trnc_point,this%A
    if(t <= this%trnc_point .and. t >= this%t0-this%cutoff*this%td &
         .and. t <= this%t0+this%cutoff*this%td) then
       y = this%A*exp(-(t - this%t0)**this%n/(2*this%td**this%n))
    else
       y = 0.0_fp
    end if
    !write(*,*) y
  end function value_at_exp_polinom
  !---------------------------------------------------------
  subroutine initialize_exp_polinom(this,A,td,t0,n,cutoff,trnc_point)
    use utils,only:fp,ip
    class(exp_polinom) :: this
    complex(fp), intent(in) :: A
    real(fp), intent(in) :: t0,td,n
    real(fp), intent(in), optional :: cutoff,trnc_point
    this%A = A
    this%t0 = t0
    this%td = td
    this%n = n
    if(present(cutoff)) then
       this%cutoff = cutoff
    else
       this%cutoff = huge(1.0_fp)
    end if
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(1.0_fp)
    endif
  end subroutine initialize_exp_polinom
  !---------------------------------------------------------
  subroutine set_parameters_exp_polinom(this,parameter_array)
    use utils,only:fp,ip
    class(exp_polinom), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect.'
       call exit(1)
    else
       this%A = parameter_array(1)
       if(size(parameter_array) > 1) then
          this%td = real(parameter_array(2),kind=fp)
       endif
       if(size(parameter_array) > 2) then
          this%t0 = real(parameter_array(3),kind=fp)
       endif
       ! if(size(parameter_array) > 3) then
       !    this%n = real(parameter_array(4),kind=fp)
       ! endif
       if(size(parameter_array) > 3) then
          this%cutoff = real(parameter_array(4),kind=fp)
       endif
       if(size(parameter_array) > 4) then
          this%trnc_point = real(parameter_array(5),kind=fp)
       endif
    end if
  end subroutine set_parameters_exp_polinom
  !#########################################################
  function value_at_polynomial_envelope(this,t) result(y)
    use utils,only:fp,ip
    class(polynomial_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    integer(ip) :: ii,ll

    ll = size(this%A)
    y = 0.0_fp
    if(t>this%trnc_point) then
       y = 0.0_fp
    else
       do ii=1,ll
          if(t>0.0_fp) then
             y = y + this%A(ii)*t**(ii-1)
          end if
       end do
    end if
  end function value_at_polynomial_envelope
  !---------------------------------------------------------
  subroutine initialize_polynomial_envelope(this,A,trnc_point)
    use utils,only:fp,ip
    class(polynomial_envelope) :: this
    complex(fp),dimension(:), intent(in) :: A
    real(fp), intent(in),optional ::trnc_point
    allocate(this%A(size(A)))
    this%A = A
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(1.0_fp)
    endif
  end subroutine initialize_polynomial_envelope
  !---------------------------------------------------------
  subroutine set_parameters_polynomial_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(polynomial_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect.'
       call exit(1)
    else
       if(size(parameter_array) > size(this%A)) then
          this%A = real(parameter_array(1:size(this%A)))
       else
          this%A(1:size(parameter_array)) = parameter_array
       end if
    end if
  end subroutine set_parameters_polynomial_envelope
  !#########################################################
  function value_at_sqrt_polynomial_envelope(this,t) result(y)
    use utils,only:fp,ip
    class(sqrt_polynomial_envelope), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    integer(ip) :: ii,ll

    ll = size(this%A)
    y = 0.0_fp
    if(t>this%trnc_point) then
       y = 0.0_fp
    else
       do ii=1,ll
          if(t>0.0_fp) then
             y = y + this%A(ii)*t**(ii-1)
          end if
       end do
    end if
    y = sqrt(y)
  end function value_at_sqrt_polynomial_envelope
  !---------------------------------------------------------
  subroutine initialize_sqrt_polynomial_envelope(this,A,trnc_point)
    use utils,only:fp,ip
    class(sqrt_polynomial_envelope) :: this
    complex(fp),dimension(:), intent(in) :: A
    real(fp), intent(in),optional ::trnc_point
    allocate(this%A(size(A)))
    this%A = A
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(1.0_fp)
    endif
  end subroutine initialize_sqrt_polynomial_envelope
  !---------------------------------------------------------
  subroutine set_parameters_sqrt_polynomial_envelope(this,parameter_array)
    use utils,only:fp,ip
    class(sqrt_polynomial_envelope), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) < 1) then
       write(*,*) 'Number of parameters incorrect.'
       call exit(1)
    else
       if(size(parameter_array) > size(this%A)) then
          this%A = real(parameter_array(1:size(this%A)))
       else
          this%A(1:size(parameter_array)) = parameter_array
       end if
    end if
  end subroutine set_parameters_sqrt_polynomial_envelope
  !#########################################################
  function value_at_lr_envelope_01(this,t) result(y)
    use utils,only:fp,ip
    class(lr_envelope_01), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    integer(ip) :: ii,ll

    if(t>this%trnc_point) then
       y = 0.0_fp
    else
       y = this%factor*(this%dalpha%value_at(t)*sin(this%alpha%value_at(t))*&
            tan(this%beta%value_at(t)) - this%dbeta%value_at(t)*&
            cos(this%alpha%value_at(t)) - exp((0.0,1.0)*PI/2)*this%Omega02%value_at(t)*&
            sin(this%alpha%value_at(t))*tan(this%beta%value_at(t)))
    end if
  end function value_at_lr_envelope_01
  !---------------------------------------------------------
  subroutine initialize_lr_envelope_01(this,alpha,beta,dalpha,dbeta,Omega02,factor,trnc_point)
    use utils,only:fp,ip
    class(lr_envelope_01) :: this
    class(envelope),target :: alpha,beta,dalpha,dbeta,Omega02
    complex(fp),intent(in) :: factor
    real(fp),intent(in),optional :: trnc_point
    this%alpha => alpha
    this%beta => beta
    this%dbeta => dbeta
    this%dalpha => dalpha
    this%Omega02 => Omega02
    this%factor = factor
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(1.0_fp)
    end if
  end subroutine initialize_lr_envelope_01
  !---------------------------------------------------------
  subroutine set_parameters_lr_envelope_01(this,parameter_array)
    use utils,only:fp,ip
    class(lr_envelope_01), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) > 0) then
       this%factor = parameter_array(1)
    end if
    if(size(parameter_array) > 1) then
       this%trnc_point = real(parameter_array(2))
    end if
  end subroutine set_parameters_lr_envelope_01
  !#########################################################
  function value_at_lr_envelope_12(this,t) result(y)
    use utils,only:fp,ip
    class(lr_envelope_12), intent(in) :: this
    real(fp), intent(in) :: t
    complex(fp) :: y
    integer(ip) :: ii,ll
    if(t > this%trnc_point) then
       y = 0.0_fp
    else
       y = this%factor*(this%dalpha%value_at(t)*cos(this%alpha%value_at(t))*&
            tan(this%beta%value_at(t)) + this%dbeta%value_at(t)*&
            sin(this%alpha%value_at(t)) - exp((0.0,1.0)*PI/2)*this%Omega02%value_at(t)*&
            cos(this%alpha%value_at(t))*tan(this%beta%value_at(t)))
    end if
  end function value_at_lr_envelope_12
  !---------------------------------------------------------
  subroutine initialize_lr_envelope_12(this,alpha,beta,dalpha,dbeta,Omega02,factor,trnc_point)
    use utils,only:fp,ip
    class(lr_envelope_12) :: this
    class(envelope),target :: alpha,beta,dalpha,dbeta,Omega02
    complex(fp),intent(in) :: factor
    real(fp),intent(in),optional :: trnc_point
    this%alpha => alpha
    this%beta => beta
    this%dbeta => dbeta
    this%dalpha => dalpha
    this%Omega02 => Omega02
    this%factor = factor
    if(present(trnc_point)) then
       this%trnc_point = trnc_point
    else
       this%trnc_point = huge(1.0_fp)
    end if
  end subroutine initialize_lr_envelope_12
  !---------------------------------------------------------
  subroutine set_parameters_lr_envelope_12(this,parameter_array)
    use utils,only:fp,ip
    class(lr_envelope_12), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    if(size(parameter_array) > 0) then
       this%factor = parameter_array(1)
    end if
    if(size(parameter_array) > 1) then
       this%trnc_point = real(parameter_array(2))
    end if
  end subroutine set_parameters_lr_envelope_12
  !#########################################################
  function value_at_sa_stirap_det_01(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(sa_stirap_det_01), intent(in) :: this
    real(fp), intent(in) :: t
    real(fp) :: theta,dphi,phi0,phi1,t0,t1,Omega010,Omega011
    real(fp) :: Omega120,Omega121,value
    complex(fp) :: y
    real(fp) :: phase

    t0 = t-this%dt/2.0_fp
    t1 = t+this%dt/2.0_fp

    Omega010 = abs(this%e01%value_at(t0)*2)
    Omega011 = abs(this%e01%value_at(t1)*2)

    Omega120 = abs(this%e12%value_at(t0)*2)
    Omega121 = abs(this%e12%value_at(t1)*2)

    theta = atan(this%e01%value_at(t)/this%e12%value_at(t))
    phi0 = atan(sqrt(Omega010**2 + Omega120**2)/(sqrt(Omega010**2 + Omega120**2 + this%delta**2) + this%delta))
    phi1 = atan(sqrt(Omega011**2 + Omega121**2)/(sqrt(Omega011**2 + Omega121**2 + this%delta**2) + this%delta))
    dphi = (phi1-phi0)/this%dt

    y = this%e01%value_at(t)
    phase = atan2(aimag(y),real(y))
    if(this%e12%value_at(t) /= 0.0_fp) then
       y = y + exp((0.0_fp,1.0_fp)+(0.0_fp,1.0_fp)*phase)*sin(theta)*dphi
    endif
  end function value_at_sa_stirap_det_01
  !---------------------------------------------------------
  subroutine set_delta_sa_stirap_det_01(this,delta)
    use utils,only:fp,ip
    implicit none
    class(sa_stirap_det_01), intent(inout) :: this
    real(fp), intent(in) :: delta
    this%delta = delta
  end subroutine set_delta_sa_stirap_det_01
  !---------------------------------------------------------
  subroutine initialize_sa_stirap_det_01(this,e01,e12,delta,dt)
    use utils,only:fp,ip
    class(sa_stirap_det_01) :: this
    class(envelope),intent(in),target :: e01,e12
    real(fp), intent(in) :: delta,dt

    this%e01 => e01
    this%e12 => e12

    this%delta = delta
    this%dt = dt

  end subroutine initialize_sa_stirap_det_01
  !---------------------------------------------------------
  subroutine set_parameters_sa_stirap_det_01(this,parameter_array)
    use utils,only:fp,ip
    class(sa_stirap_det_01), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%e01%set_parameters(parameter_array)
    !write(*,*) parameter_array
  end subroutine set_parameters_sa_stirap_det_01
  !#########################################################
  function value_at_sa_stirap_det_02(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(sa_stirap_det_02), intent(in) :: this
    real(fp), intent(in) :: t
    real(fp) :: dphi,phi0,phi1,t0,t1
    complex(fp) :: Omega120,Omega121,value,Omega010,Omega011
    complex(fp) :: y
    real(fp) :: phase01,phase12
    real(fp) :: theta0,theta1,dtheta
    integer(ip) :: ii
    class(envelope),pointer :: env

    t0 = t-this%dt/2.0_fp
    t1 = t+this%dt/2.0_fp

    Omega011 = (0.0_fp,0.0_fp)
    Omega121 = (0.0_fp,0.0_fp)
    Omega010 = (0.0_fp,0.0_fp)
    Omega120 = (0.0_fp,0.0_fp)

    ! In this code Omega means the raw coupling, not Rabi rate
    do ii=1,this%nenv01
       env => this%d01(ii)%obj
       Omega010 = Omega010 + env%value_at(t0)
       Omega011 = Omega011 + env%value_at(t1)
    end do
    do ii=1,this%nenv12
       env => this%d12(ii)%obj
       Omega120 = Omega120 + env%value_at(t0)
       Omega121 = Omega121 + env%value_at(t1)
    end do

    ! if(abs(Omega120) .eq. 0.0_fp .and. abs(Omega010) .eq. 0.0_fp) then
    !    theta0 = 0.0_fp
    ! else
    !    theta0 = atan2(abs(Omega120),abs(Omega010))
    ! end if

    !     if(abs(Omega121) .eq. 0.0_fp .and. abs(Omega011) .eq. 0.0_fp) then
    !    theta1 = 0.0_fp
    ! else
    !    theta1 = atan2(abs(Omega121),abs(Omega011))
    ! end if

    if((abs(Omega120) > tiny(0.0_fp) .and. abs(Omega010) > tiny(0.0_fp)) .and. &
         (abs(Omega121) > tiny(0.0_fp) .and. abs(Omega011) > tiny(0.0_fp))) then
       theta0 = atan2(abs(Omega120)*this%csr,abs(Omega010))
       theta1 = atan2(abs(Omega121)*this%csr,abs(Omega011))
       dtheta = (theta1-theta0)/this%dt
    else
       dtheta = 0.0_fp
    endif

    if(abs(Omega010) .eq. 0.0_fp) then
       phase01 = 0.0_fp
    else
       phase01 = atan2(aimag(Omega010),real(Omega010))
    endif

    if(abs(Omega120) .eq. 0.0_fp) then
       phase12 = 0.0_fp
    else
       phase12 = atan2(aimag(Omega120),real(Omega120))
    endif

    dtheta = (theta1-theta0)/this%dt
    y = this%A_factor*sqrt(this%delta*abs(dtheta))*exp((0.0_fp,1.0_fp)*(this%phi+0.5_fp*(phase01+phase12)))
    !y = sqrt(this%delta*abs(dtheta))*exp((0.0_fp,1.0_fp)*this%phi)
     ! if(abs(y) > 0.0_fp) then
     !    write(*,*) dtheta,abs(y)
     ! end if
  end function value_at_sa_stirap_det_02
  !---------------------------------------------------------
  subroutine add_envelope_01_sa_stirap_det_02(this,envelope_in)
    use utils,only:fp,ip
    class(sa_stirap_det_02),intent(inout) :: this
    class(envelope),intent(in),target :: envelope_in
    type(envelope_container),allocatable,dimension(:) :: temp_cont
    if(this%nenv01 >= this%env_cont_size_01) then
       allocate(temp_cont(this%nenv01))
       temp_cont = this%d01(1:this%nenv01)
       deallocate(this%d01)
       allocate(this%d01(this%nenv01*2))
       this%d01(1:this%nenv01) = temp_cont
       deallocate(temp_cont)
       this%env_cont_size_01 = size(this%d01)
       !write(*,*) 'Extending space for envelopes. New size is', this%env_cont_size,'.'
    end if
    this%nenv01 = this%nenv01 + 1
    this%d01(this%nenv01)%obj => envelope_in
  end subroutine add_envelope_01_sa_stirap_det_02
  !---------------------------------------------------------
  subroutine add_envelope_12_sa_stirap_det_02(this,envelope_in)
    use utils,only:fp,ip
    class(sa_stirap_det_02),intent(inout) :: this
    class(envelope),intent(in),target :: envelope_in
    type(envelope_container),allocatable,dimension(:) :: temp_cont
    if(this%nenv12 >= this%env_cont_size_12) then
       allocate(temp_cont(this%nenv12))
       temp_cont = this%d12(1:this%nenv12)
       deallocate(this%d12)
       allocate(this%d12(this%nenv12*2))
       this%d12(1:this%nenv12) = temp_cont
       deallocate(temp_cont)
       this%env_cont_size_12 = size(this%d12)
       !write(*,*) 'Extending space for envelopes. New size is', this%env_cont_size,'.'
    end if
    this%nenv12 = this%nenv12 + 1
    this%d12(this%nenv12)%obj => envelope_in
  end subroutine add_envelope_12_sa_stirap_det_02
  !---------------------------------------------------------
  subroutine initialize_sa_stirap_det_02(this,delta,dt,phi,A_factor,csr)
    use utils,only:fp,ip
    class(sa_stirap_det_02) :: this
    !class(signal),intent(in),target :: d01,d12
    !type(envelope_container),dimension(:),pointer :: d01,d12
    real(fp), intent(in) :: dt,delta,phi,A_factor,csr
    integer(ip) :: initial_env_cont_size
    !this%d01 => d01
    !this%d12 => d12
    this%dt = dt
    this%delta = delta
    this%phi = phi
    this%A_factor = A_factor
    this%csr = csr
    !this%nenv01 => nenv01
    !this%nenv12 => nenv12

    initial_env_cont_size = 2
    this%nenv01 = 0
    allocate(this%d01(initial_env_cont_size))
    this%env_cont_size_01 = initial_env_cont_size
    this%nenv12 = 0
    allocate(this%d12(initial_env_cont_size))
    this%env_cont_size_12 = initial_env_cont_size
  end subroutine initialize_sa_stirap_det_02
  !---------------------------------------------------------
  subroutine set_parameters_sa_stirap_det_02(this,parameter_array)
    use utils,only:fp,ip
    class(sa_stirap_det_02), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array

    if(size(parameter_array) < 4) then
       write(*,*) 'Number of parameters incorrect in set_parameters_constant_sa_stirap_det_02.'
       call exit(1)
    end if
    this%delta = real(parameter_array(1))
    this%dt = real(parameter_array(2))
    this%phi = real(parameter_array(3))
    this%A_factor = real(parameter_array(4))
  end subroutine set_parameters_sa_stirap_det_02
  !#########################################################
  function value_at_sa_stirap_det_12(this,t) result(y)
    use utils,only:fp,ip
    use constants,only:pi
    use linfuncs,only:trapz
    implicit none
    class(sa_stirap_det_12), intent(in) :: this
    real(fp), intent(in) :: t
    real(fp) :: theta,dphi,phi0,phi1,t0,t1,Omega010,Omega011
    real(fp) :: Omega120,Omega121,value
    complex(fp) :: y
    real(fp) :: phase

    t0 = t-this%dt/2.0_fp
    t1 = t+this%dt/2.0_fp

    Omega010 = abs(this%e01%value_at(t0)*2)
    Omega011 = abs(this%e01%value_at(t1)*2)

    Omega120 = abs(this%e12%value_at(t0)*2)
    Omega121 = abs(this%e12%value_at(t1)*2)

    theta = atan(this%e01%value_at(t)/this%e12%value_at(t))
    phi0 = atan(sqrt(Omega010**2 + Omega120**2)/(sqrt(Omega010**2 + Omega120**2 + this%delta**2) + this%delta))
    phi1 = atan(sqrt(Omega011**2 + Omega121**2)/(sqrt(Omega011**2 + Omega121**2 + this%delta**2) + this%delta))
    dphi = (phi1-phi0)/this%dt

    y = this%e12%value_at(t)
    phase = atan2(aimag(y),real(y))

    if(this%e12%value_at(t) /= 0.0_fp) then

       y = y + exp((0.0_fp,1.0_fp)+(0.0_fp,1.0_fp)*phase)*(-cos(theta)*dphi)
    end if
  end function value_at_sa_stirap_det_12
  !---------------------------------------------------------
  subroutine set_delta_sa_stirap_det_12(this,delta)
    use utils,only:fp,ip
    implicit none
    class(sa_stirap_det_12), intent(inout) :: this
    real(fp), intent(in) :: delta
    this%delta = delta
  end subroutine set_delta_sa_stirap_det_12
  !---------------------------------------------------------
  subroutine initialize_sa_stirap_det_12(this,e01,e12,delta,dt)
    use utils,only:fp,ip
    class(sa_stirap_det_12) :: this
    class(envelope),intent(in),target :: e01,e12
    real(fp), intent(in) :: delta,dt

    this%e01 => e01
    this%e12 => e12

    this%delta = delta
    this%dt = dt
  end subroutine initialize_sa_stirap_det_12
  !---------------------------------------------------------
  subroutine set_parameters_sa_stirap_det_12(this,parameter_array)
    use utils,only:fp,ip
    class(sa_stirap_det_12), intent(inout) :: this
    complex(fp),dimension(:),intent(in) :: parameter_array
    call this%e12%set_parameters(parameter_array)
    !write(*,*) parameter_array
  end subroutine set_parameters_sa_stirap_det_12
  !#########################################################
end module envelopes


!include "num_to_txt.f90"

program main
!Variable declaration
implicit none
integer(kind=8)               :: ni, nit, lt, intv, intvt, intt, inttt
integer                       :: i, j, k, x, y, le, side1, side2, size, count, radij, mrad, range1&
&, range2, answer
double precision              :: u, delez, tempz, tempi, tempk, ls, ena, dva, tri, stiri, jay, c, start, finish
double precision, allocatable :: temp(:), v(:,:), enm(:,:), cvm(:,:)
integer, allocatable          :: s0(:,:), enke0(:), nbar(:), tarr(:), s0out(:,:,:)
character(len=30)             :: str, strl, intname, tempzzi, tempzzd, tempkzi, tempkzd, tempizi&
&, tempizd, lszi, lszd, jayzi, jayzd, czi, czd, lattice, pwd
!2D polaron model with nearest neighbour strain and cutoff Coulomb interaction between polarons located on a uniformly charged plate in the shape of a rhombus
!(periodic boundary conditions) influenced by an external field- Jaka Vodeb
!ENTER THE WORKING DIRECTORY:
pwd=""
!Interface
call CPU_TIME(start)
open (10,file=""//trim(pwd)//"input.txt")
!Do you want to read a premade configuration?
read(10,*) answer
!The lattice topology
read(10,*) lattice
!The initial temperature of the system
read(10,*) tempz
!The final temperature of the system
read(10,*) tempk
!The temperature interval of the system
read(10,*) tempi
!The interaction name
read(10,*) intname
!The nearest-neighbour coupling
read(10,*) jay
!The screened Coulomb interaction magnitude
read(10,*) c
!The radius of the interaction
read(10,*) radij
!The movement radius of the local update scheme
read(10,*) mrad
!Characteristic length of the screened Coulomb
read(10,*) ls
!The number of sites on each side of the paralelogram
read(10,*) side1
read(10,*) side2
!Total number of sites
size=side1*side2
!The number of fractions of polaron occupation and sites in the system to evaluate
read(10,*) le
allocate (nbar(le))
!Enter the fractions to be evaluated
do i=1,le
! i-th fraction
  read(10,*) delez
  nbar(i)=idnint(delez*dble(size))
end do
!At 0.1 temperature relaxation of system measured at 5*10^5 for 30, 1*10^6 for 60 and 5*10^6 for 120 as the number of sites on the side of the rhombic lattice.
!Enter the number of sweeps at each temperature
read(10,*) nit
!Enter the sampling interval in sweeps
read(10,*) intvt
!Enter the thermalization interval in sweeps
read(10,*) inttt
close(10)
lt=idnint(dabs(tempk-tempz)/dabs(tempi))
ena=1.
dva=2.
tri=3.
stiri=4.
allocate (s0(side1,side1))
s0=0
do i = 1, side1
   do j = 1, side1
       s0(i,j) = MINVAL((/ABS(i-j), ABS(i-j+side1), ABS(i-j-side1)/))
   end do
end do
range1 = MAXVAL(s0)
deallocate(s0)
allocate (s0(side2,side2))
do i = 1, side2
   do j = 1, side2
       s0(i,j) = MINVAL((/ABS(i-j), ABS(i-j+side2), ABS(i-j-side2)/))
   end do
end do
range2 = MAXVAL(s0)
deallocate(s0)
allocate (s0(side1,side2))
!Array allocation
allocate (temp(lt))
allocate (v(-range1:range1,-range2:range2))
allocate (enke0(1))
allocate (enm(lt,3))
allocate (cvm(lt,3))
allocate (s0out(lt,side1,side2))
do i=1,lt
  temp(i)=tempz+dble(i)*tempi
end do
do i=-range1,range1
    do j=-range2,range2
        if (lattice == 'tri') then
            u=dsqrt((dble(i)+dble(j)/dva)*(dble(i)+dble(j)/dva)+tri*dble(j)*dble(j)/stiri)
        else if (lattice == 'sq') then
            u=dsqrt(dble(i)*dble(i)+dble(j)*dble(j))
        else
            print *, 'THE LATTICE PARAMETER DOESNT MATCH ANY OF THE AVAILABLE OPTIONS!'
            go to 20
        end if
        if (u>dble(0).and.u<=dble(radij)) then
            if (u<=1.1) then
                v(i,j)=-jay
            else
                v(i,j)=c*dexp(-u/ls)/u
            end if
        else
            v(i,j)=0.
        end if
    end do
end do
!Seeding the random numbers
call random_seed
!Zacetek zanke, ki tece po vseh zeljenih delezih polaronov v sistemu
do i=1,le
    ni=nit*nbar(i)
    intv=intvt*nbar(i)
    intt=inttt*nbar(i)
    !Conversion of parameters to strings for output
    call dec2str (tempz, tempzzi, tempzzd)
    call dec2str (tempk, tempkzi, tempkzd)
    call dec2str (tempi, tempizi, tempizd)
    call dec2str (ls, lszi, lszd)
    call dec2str (jay, jayzi, jayzd)
    call dec2str (c, czi, czd)
    !Array allocation
    deallocate(enke0)
    !deallocate(nicle0)
    allocate (enke0(2*nbar(i)))
    !allocate (nicle0(2*(size-nbar(i))))
    if (answer==1) then
        count=1
        !index=1
        enke0=0
        s0=0
        allocate(tarr(side2))
        open(10,file=""//trim(pwd)//"konf_int_barr_1_radij_24_ls_4_5_side1_&
		&91_side2_104_N_728_ni_30000000_tempz_1_000000000000000E-002_tempk_8_999999999999999E-003_tempi_-1_000000000000000E-0&
		&03.dat")
        do j=1,side1
            read(10,*) tarr
            do k=1,side2
                if (tarr(k)==1) then
                    enke0(count)=j
                    enke0(count+1)=k
                    count=count+2
                    s0(j,k)=1
                !else
                    !nicle0(index)=j
                    !nicle0(index+1)=k
                    !index=index+2
                end if
            end do
        end do
        close(10)
    else if (answer==0) then
        !Initializing the particles in the left upper corner of the system
        count=1
        x=1
        y=1
        s0=0
        do while (y<=side2)
            do while (x<=side1)
                if (count<2*nbar(i)) then
                    enke0(count)=x
                    enke0(count+1)=y
                    s0(x,y)=1
                    x=x+1
                    count=count+2
                else
                    go to 30
                end if
            end do
            x=1
            y=y+1
        end do
    else
        !print *, 'WRONG ANSWER!'
        go to 20
    end if
    !Calling particle dynamics
30  call spini(lt, temp, v, side1, side2, range1, range2, ni, intv, intt, nbar(i), enke0, s0, mrad, enm, cvm, s0out)
    !Writing output
    open(10,file=""//trim(pwd)//"konf_latt&
    &_"//trim(lattice)//"_int_"//trim(intname)//"_J_"//trim(jayzi)//"_"//trim(jayzd)//"_C_&
    &"//trim(czi)//"_"//trim(czd)//"_radij_"//trim(str(radij))//"_mrad_"//trim(str(mrad))//"_ls&
    &_"//trim(lszi)//"_"//trim(lszd)//"_side1_"//trim(str(side1))//"_side2_"//trim(str(side2))//"_&
    &N_"//trim(str(nbar(i)))//"_ni_"//trim(strl(nit))//"_intv_"//trim(strl(intvt))//"_intt&
    &_"//trim(strl(inttt))//"_tempz_"//trim(tempzzi)//"_"//trim(tempzzd)//"_tempk_"//trim(tempkzi)//"&
    &_"//trim(tempkzd)//"_tempi_"//trim(tempizi)//"_"//trim(tempizd)//".dat")
    do j=1,side1
        write(10,*)(s0out(lt,j,k),k=1,side2)
    end do
    close(10)
    open(10,file=""//trim(pwd)//"all_konf_latt&
    &_"//trim(lattice)//"_int_"//trim(intname)//"_J_"//trim(jayzi)//"_"//trim(jayzd)//"_C_&
    &"//trim(czi)//"_"//trim(czd)//"_radij_"//trim(str(radij))//"_mrad_"//trim(str(mrad))//"_ls&
    &_"//trim(lszi)//"_"//trim(lszd)//"_side1_"//trim(str(side1))//"_side2_"//trim(str(side2))//"_&
    &N_"//trim(str(nbar(i)))//"_ni_"//trim(strl(nit))//"_intv_"//trim(strl(intvt))//"_intt&
    &_"//trim(strl(inttt))//"_tempz_"//trim(tempzzi)//"_"//trim(tempzzd)//"_tempk_"//trim(tempkzi)//"&
    &_"//trim(tempkzd)//"_tempi_"//trim(tempizi)//"_"//trim(tempizd)//".dat")
    do x=1,lt
      do j=1,side1
          write(10,*)(s0out(x,j,k),k=1,side2)
      end do
    end do
    close(10)
    open(10,file=""//trim(pwd)//"en_latt&
    &_"//trim(lattice)//"_int_"//trim(intname)//"_J_"//trim(jayzi)//"_"//trim(jayzd)//"_C_&
    &"//trim(czi)//"_"//trim(czd)//"_radij_"//trim(str(radij))//"_mrad_"//trim(str(mrad))//"_ls&
    &_"//trim(lszi)//"_"//trim(lszd)//"_side1_"//trim(str(side1))//"_side2_"//trim(str(side2))//"&
    &_N_"//trim(str(nbar(i)))//"_ni_"//trim(strl(nit))//"_intv_"//trim(strl(intvt))//"_intt&
    &_"//trim(strl(inttt))//"_tempz_"//trim(tempzzi)//"_"//trim(tempzzd)//"_tempk&
    &_"//trim(tempkzi)//"_"//trim(tempkzd)//"_tempi_"//trim(tempizi)//"_"//trim(tempizd)//".dat")
    do j=1,lt
        write (10,*) (enm(j,k),k=1,3)
    end do
    close (10)
    open(10,file=""//trim(pwd)//"cv_latt&
    &_"//trim(lattice)//"_int_"//trim(intname)//"_J_"//trim(jayzi)//"_"//trim(jayzd)//"_C&
    &_"//trim(czi)//"_"//trim(czd)//"_radij_"//trim(str(radij))//"_mrad_"//trim(str(mrad))//"_&
    &ls_"//trim(lszi)//"_"//trim(lszd)//"_side1_"//trim(str(side1))//"_side2_"//trim(str(side2))//"_&
    &N_"//trim(str(nbar(i)))//"_ni_"//trim(strl(nit))//"_intv_"//trim(strl(intvt))//"_intt&
    &_"//trim(strl(inttt))//"_tempz_"//trim(tempzzi)//"_"//trim(tempzzd)//"_tempk_"//trim(tempkzi)//"&
    &_"//trim(tempkzd)//"_tempi_"//trim(tempizi)//"_"//trim(tempizd)//".dat")
    do j=1,lt
        write (10,*) (cvm(j,k),k=1,3)
    end do
    close (10)
    end do
20 radij=0
call CPU_TIME(finish)
print *, finish-start
end program main

subroutine spini(lt, temp, v, side1, side2, range1, range2, ni, intv, intt, nbar, enke, s0, mrad, enm, cvm, s0out)
!Variable declaration
implicit none
integer(kind=8)               :: ni, i, j, k, lt, intv, intt, ns
integer                       :: o, p, x, side1, side2, xr, yr, nbar, count, range1, range2, mrad
integer                       :: enke(2*nbar), s0(side1,side2), s0out(lt,side1,side2)
double precision              :: v(2*range1+1,2*range2+1), temp(lt), enm(lt,3), cvm(lt,3)
double precision, allocatable :: ar(:)
double precision              :: u, deltaen, t, faktor, nbardi, en, cv, enerr, cverr
!Particle dynamics start
ns=(ni-intt)/intv
allocate(ar(ns))
nbardi=1./dble(nbar)
do j=1,lt
  count=1
  t=temp(j)
  do i=1,ni
    if (i > intt .and. mod(i,intv)==0 .and. count<=ns) then
      call energija(nbar, range1, range2, side1, side2, enke, v, u)
      ar(count)=u*nbardi
      count=count+1
    end if
    !Particle hole exchange in within the local update scheme
    call RANDOM_NUMBER(u)
    x=1+2*floor(nbar*u)
    call RANDOM_NUMBER(u)
    xr=enke(x)-mrad+floor((2*mrad+1)*u)
    if (xr<=0) then
        xr=xr+side1
    else if (xr>side1) then
        xr=xr-side1
    else
        continue
    end if
    call RANDOM_NUMBER(u)
    yr=enke(x+1)-mrad+floor((2*mrad+1)*u)
    if (yr<=0) then
        yr=yr+side2
    else if (yr>side2) then
        yr=yr-side2
    else
        continue
    end if
    if (s0(xr,yr)==0) then
        call faktorfe(x, xr, yr, side1, side2, nbar, range1, range2, enke, v, faktor)
        deltaen=faktor
        call faktorfn(x, enke(x), enke(x+1), side1, side2, nbar, range1, range2, enke, v, faktor)
        deltaen=deltaen+faktor
        !Metropolis part of the Monte Carlo algorithm
        if (deltaen<=0.) then
            s0(xr,yr)=1
            s0(enke(x),enke(x+1))=0
            enke(x)=xr
            enke(x+1)=yr
        else
            call random_number(u)
            if (u<dexp(-deltaen/t)) then
                s0(xr,yr)=1
                s0(enke(x),enke(x+1))=0
                enke(x)=xr
                enke(x+1)=yr
            else
                continue
            end if
        end if
    else
        continue
    end if
  !End of dynamics
  end do
  cv=0.
  cverr=0.
  do i=1,10000
    en=0.
    enerr=0.
    do k=1,ns
      call random_number(u)
      x=1+floor(ns*u)
      en=en+ar(x)
      enerr=enerr+ar(x)*ar(x)
    end do
    en=en/dble(ns)
    enerr=enerr/dble(ns)
    cv=cv+dble(nbar)*(enerr-en*en)/t/t
    cverr=cverr+nbar*(enerr-en*en)/t/t*nbar*(enerr-en*en)/t/t
  end do
  cv=cv/dble(10000)
  cverr=cverr/dble(10000)
  cverr=dsqrt(cverr-cv*cv)
  en=0.
  enerr=0.
  do i=1,ns
    en=en+ar(i)
    enerr=enerr+ar(i)*ar(i)
  end do
  en=en/dble(ns)
  enerr=enerr/dble(ns)
  cv=nbar*(enerr-en*en)/t/t
  enerr=dsqrt((enerr-en*en)/dble(ns-1))
  enm(j,1)=t
  enm(j,2)=en
  enm(j,3)=enerr
  cvm(j,1)=t
  cvm(j,2)=cv
  cvm(j,3)=cverr
  do o=1,side1
    do p=1,side2
      s0out(j,o,p)=s0(o,p)
    end do
  end do
  !End of temperature loop
end do
end subroutine spini

subroutine energija(nbar, range1, range2, side1, side2, enke, v, en)
implicit none
integer          :: i, j, nbar, range1, range2, side1, side2, di, dj
integer          :: enke(2*nbar)
double precision :: en
double precision :: v(2*range1+1,2*range2+1)
en=0.
do i=1,2*nbar,2
    do j=i+2,2*nbar,2
        di=enke(j)-enke(i)
        if (di>range1) then
            di=di-side1
        else if (di<-range1) then
            di=di+side1
        end if
        dj=enke(j+1)-enke(i+1)
        if (dj>range2) then
            dj=dj-side2
        else if (dj<-range2) then
            dj=dj+side2
        end if
        en=en+v(di+range1+1,dj+range2+1)
    end do
end do
    end subroutine

subroutine faktorfe(x, xr, yr, side1, side2, nbar, range1, range2, enke, v, faktor)
implicit none
integer          :: i, x, xr, yr, di, dj, side1, side2, nbar, range1, range2, enke(2*nbar)
double precision :: faktor, v(2*range1+1,2*range2+1)
faktor=0.
do i=1,x-2,2
    di=enke(i)-xr
    if (di>range1) then
        di=di-side1
    else if (di<-range1) then
        di=di+side1
    end if
    dj=enke(i+1)-yr
    if (dj>range2) then
        dj=dj-side2
    else if (dj<-range2) then
        dj=dj+side2
    end if
    faktor=faktor+v(di+range1+1,dj+range2+1)
end do
do i=x+2,2*nbar,2
    di=enke(i)-xr
    if (di>range1) then
        di=di-side1
    else if (di<-range1) then
        di=di+side1
    end if
    dj=enke(i+1)-yr
    if (dj>range2) then
        dj=dj-side2
    else if (dj<-range2) then
        dj=dj+side2
    end if
    faktor=faktor+v(di+range1+1,dj+range2+1)
end do
end subroutine

subroutine faktorfn(x, xk, yk, side1, side2, nbar, range1, range2, enke, v, faktor)
implicit none
integer          :: i, x, xk, yk, di, dj, side1, side2, nbar, range1, range2, enke(2*nbar)
double precision :: faktor, v(2*range1+1,2*range2+1)
faktor=0.
do i=1,x-2,2
    di=enke(i)-xk
    if (di>range1) then
        di=di-side1
    else if (di<-range1) then
        di=di+side1
    end if
    dj=enke(i+1)-yk
    if (dj>range2) then
        dj=dj-side2
    else if (dj<-range2) then
        dj=dj+side2
    end if
    faktor=faktor-v(di+range1+1,dj+range2+1)
end do
do i=x+2,2*nbar,2
    di=enke(i)-xk
    if (di>range1) then
        di=di-side1
    else if (di<-range1) then
        di=di+side1
    end if
    dj=enke(i+1)-yk
    if (dj>range2) then
        dj=dj-side2
    else if (dj<-range2) then
        dj=dj+side2
    end if
    faktor=faktor-v(di+range1+1,dj+range2+1)
end do
end subroutine

subroutine dec2str(decin, si, sd)
double precision :: decin
character(len=*) :: si, sd
character*30 :: s
character*30 :: strr
s=strr(decin)
call SplitString(s,si,sd,".")
call ReplaceText(sd,"0","",sd)
end subroutine

!Integer to string
character(len=30) function str(k)
  integer, intent(in) :: k
  write (str,*) k
  str = adjustl(str)
end function str

!Long integer to string
character(len=30) function strl(k)
  integer(kind=8), intent(in) :: k
  write (strl,*) k
  strl = adjustl(strl)
end function strl

!Real to string
character(len=30) function strr(k)
  integer, parameter  :: ikind=selected_real_kind(p=15)
  real (kind=ikind)   :: k
  write (strr, '(F16.8)') k
  strr = adjustl(strr)
end function strr

!String split at a specified character
subroutine SplitString(instring, string1, string2, delim)
implicit none
character(len=*)              :: instring,delim
character(len=*), intent(out) :: string1,string2
integer                       :: index
instring = trim(instring)
index = scan(instring,delim)
string1 = instring(1:index-1)
string2 = instring(index+1:)
end subroutine SplitString

!Replace characters
subroutine ReplaceText (s,text,rep,outs)
!Variable declaration
implicit none
character(len=*) :: s,text,rep
character(len=*) :: outs
integer          :: i, nt, nr
!In case of only zeros in input the output is 0
if (scan(outs,"123456789")==0) then
  outs="0"
else
  outs = s
  nt = len_trim(text)
  nr = len_trim(rep)
  do i=len(outs),1,-1
    if (scan(outs(i:len(outs)),"123456789")/=0) then
      continue
    else
      outs = outs(:i-1) // rep(:nr) // outs(i+nt:)
    end if
  end do
end if
end subroutine ReplaceText


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... file helmsph.f
!
!     this file contains a program for solving the Helmholtz
!     equation with constant 1.0 on a ten degree grid on the full sphere
!
! ... required spherepack files
!
!     islapec.f, shaec.f, shsec.f, type_SpherepackUtility.f, type_RealPeriodicFastFourierTransform.f
!
! ... description
!
!     let theta be latitude and phi be east longitude in radians.
!     and let
!
!
!       x = cos(theta)*sin(phi)
!       y = cos(theta)*cos(phi)
!       z = sint(theta)
!
!     be the cartesian coordinates corresponding to theta and phi.
!     on the unit sphere.  The exact solution
!
!        ue(theta, phi) = (1 + x*y)*exp(z)
!
!     is used to set the right hand side and compute error.
!
!
program helmsph

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        Sphere, &
        Regularsphere, &
        GaussianSphere, &
        wp, & ! Working precision
        ip    ! Integer precision

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), pointer   :: solver

    ! Cast to gaussian case
    allocate (GaussianSphere :: solver)
    call test_helmholtz_inversion(solver)
    deallocate (solver)

    ! Cast to regular case
    allocate (RegularSphere :: solver)
    call test_helmholtz_inversion(solver)
    deallocate (solver)

contains

    subroutine test_helmholtz_inversion(sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLONS = 36
        integer(ip), parameter        :: NLATS = NLONS/2 + 1
        integer(ip)                   :: i, j ! Counters
        real(wp)                      :: exact_solution(NLATS, NLONS)
        real(wp)                      :: approximate_solution(NLATS, NLONS)
        real(wp)                      :: source_term(NLATS, NLONS)
        real(wp), parameter           :: ONE = 1.0_wp
        real(wp), parameter           :: TWO = 2.0_wp
        real(wp), parameter           :: SIX = 6.0_wp
        real(wp), parameter           :: HELMHOLTZ_CONSTANT = ONE
        character(len=:), allocatable :: error_previous_platform

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            !  Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (error_previous_platform, source='     discretization error = 2.325553e-14')

            type is (RegularSphere)

            ! Initialize regular sphere
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (error_previous_platform, source='     discretization error = 1.202313e-14')
        end select

        !  Set right hand side as helmholtz operator
        !  applied to ue = (1+x*y)*exp(z)
        associate (&
            ue => exact_solution, &
            rhs => source_term, &
            radial => sphere_type%unit_vectors%radial &
           )
            do j=1, NLONS
                do i=1, NLATS
                    associate (&
                        x => radial(i, j)%x, &
                        y => radial(i, j)%y, &
                        z => radial(i, j)%z &
                       )
                        ue(i, j) = (ONE + x * y) * exp(z)
                        rhs(i, j) = -(x * y * ((z**2) + SIX * (z + ONE)) + z*(z + TWO)) * exp(z)
                    end associate
                end do
            end do
        end associate

        ! Solve Helmholtz equation on the sphere
        associate (&
            xlmbda => HELMHOLTZ_CONSTANT, &
            rhs => source_term, &
            u => approximate_solution &
           )
            call sphere_type%invert_helmholtz(xlmbda, rhs, u)
        end associate

        !  Compare ue with u
        associate (&
            u => approximate_solution, &
            ue => exact_solution &
           )
            associate (err2 => norm2(u-ue))

                ! Print earlier output from platform with 64-bit floating point
                ! arithmetic followed by the output from this computer
                write (stdout, '(/a)') '     helmsph *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Helmholtz approximation on a ten degree grid'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') error_previous_platform
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6/)') '     discretization error = ', err2
            end associate
        end associate

        !  Release memory
        call sphere_type%destroy()
        deallocate (error_previous_platform)

    end subroutine test_helmholtz_inversion

end program helmsph


!
      subroutine avstrp(x,nx,lstrip,xf,nxf)
!
!   Copyright Goverment of Canada
!   Department of Fisheries and Oceans
!   Institute of Ocean Sciences
!   Sidney, B.C.
!
!   Name: avstrp
!
!   Purpose: To filter using the simple moving average technique.
!
!   Input:    x      an equally spaced time series.
!             nx     the number of points in X
!             lstrip number of consecutive x values in each average (<=nx)
!
!   Output:   xf     the lowpassed x values.
!             nxf    number of points in xf.
!
!
!  Written by: MEDS Ottawa
!              Changed to T&C Apollo system by Anne Ballantyne.
!
!	Apollo references deleted by Mike Foreman
!
!      include '/tctree/sources/dsee/tcf/tcf_header_defs.h'
!     Modified by Joseph Zhang Oct 2006
!     Bad values of time series are > 9998 (the filtered results are 9999 in this case)
!     The first point of xf() corresponds to the average of first lstrip points
!     The last point of xf() corresponds to the average of last lstrip points
!     The time stamp of 1st point of xf() is t0+(lstrip-1)*dt/2 (t0 is the starting time)

      integer, intent(in) :: nx,lstrip
      integer, intent(out) :: nxf
      real, intent(in) :: x(nx)
      real, intent(out) :: xf(nx)

      integer mxf,nbad,i,inew,lsm1
      real    big, sum, xold, xnew

      if(nx<lstrip) then
        write(*,*)'Make sure nx >= lstrip in filter avstrp'
        stop
      endif

      lsm1 = lstrip-1
      mxf = nx - lstrip +1
!      big = SHORT_PAD*1.0
      big = 9998.
      nbad = 0
      sum = 0.0
      do i = 1, lsm1
       if(x(i).gt.big) then
         nbad = nbad + 1
       else
         sum = sum + x(i)
       endif
      end do

      xold = 0.0
      do i = 1, mxf
        inew = i+lstrip-1
        xnew = x(inew)
        if(xnew.gt.big) then
          nbad = nbad + 1
        else
          sum = sum + xnew
        endif
        if(xold.gt.big) then
          nbad = nbad - 1
        else
          sum = sum - xold
        endif
        xold = x(i)
        if (nbad.gt.0) then
          xf(i) = big+1
        else
          xf(i) = sum/lstrip
        endif
!	write(6,*) ' i,nbad,xnew,xf(i)=',i,nbad,xnew,xf(i)
      end do

      nxf = mxf

      return
      end


module mod_cublas_sgemm

  use iso_fortran_env, only: rk => real32
  use cudafor
  use cublas

  implicit none

  private

  public :: cublas_sgemm, matmul

  contains

    subroutine cublas_sgemm (a, b, c, transa, transb, alpha, beta)

      ! Input/output variables
      real(rk),     intent(in)           :: a(:, :), b(:, :)
      real(rk),     intent(inout)        :: c(:, :)
      real(rk),     intent(in), optional :: alpha, beta
      character(1), intent(in), optional :: transa, transb

      ! Local variables
      real(rk) :: o_alpha, o_beta
      integer  :: m, n, k, lda, ldb, ldc

      ! GPU variables
      type(cublasHandle)            :: handle
      real(rk), device, allocatable :: dA(:, :), dB(:, :), dC(:, :)
      integer                       :: itransa, itransb
      integer                       :: ierr, istat

      intrinsic max, present, size

      if ( present(alpha) ) then
        o_alpha = alpha
      else
        o_alpha = 1
      endif

      if ( present(beta) ) then
        o_beta = beta
      else
        o_beta = 0
      endif

      if ( present(transa) ) then
        if ( transa == 'N' .or. transa == 'n' ) then
          itransa = 0
        else
          itransa = 1
        end if
      else
          itransa = 0
      endif

      if ( present(transb) ) then
        if ( transb == 'N' .or. transb == 'n' ) then
          itransb = 0
        else
          itransb = 1
        end if
      else
          itransb = 0
      endif

      if ( itransa == 0 ) then
          k = size(a, 2)
      else
          k = size(a, 1)
      endif

      lda = max( 1, size(a, 1) )
      ldb = max( 1, size(b, 1) )
      ldc = max( 1, size(c, 1) )

      m = size(c, 1)
      n = size(c, 2)

      allocate ( dA, source = a )
      allocate ( dB, source = b )
      allocate ( dC, source = c )

      handle = cublasGetHandle ()

      istat = cublasSgemm_v2 (handle, itransa, itransb, &
                              m, n, k, o_alpha, dA, lda, dB, ldb, o_beta, dC, ldc)

      ierr = cudathreadsynchronize ()

      c = dC

    end subroutine

    function matmul (a, b) result (c)

      real(rk), intent(in)  :: a(:, :), b(:, :)
      real(rk), allocatable :: c(:, :)

      allocate ( c(size(a, 1), size(b, 2)) )

      call cublas_sgemm (a, b, c, 'N', 'N', 1.0e0, 0.0e0)

    end function

end module

program test_cublas

  use iso_fortran_env, only: rk => real32
  use mod_cublas_sgemm

  implicit none

  real(rk), allocatable :: a(:, :), b(:, :), c(:, :)
  integer i, j, m, n, k

  m = 8000
  n = 6000
  k = 5000

  allocate ( a(m, k), source = 1.0e0 )
  allocate ( b(k, n), source = 2.0e0 )
  !allocate ( c(m, n), source = 3.0e0 )

  !call cublas_sgemm (a, b, c, 'N', 'N', 1.0e0, 0.0e0)
  c = matmul(a, b)

  print *, repeat('=', 80)
  do i = 1, 5
    print '(*(f16.2))', [( c(i, j), j = 1, 5 )]
  end do
  print *, repeat('=', 80)

end


! Copyright 2017, UT-Battelle, LLC
!
! SPDX-License-Identifier: BSD-3-Clause
! License-Filename: LICENSE
program main

#include "ForTrilinosSimpleInterface_config.hpp"
#include "ForTrilinos.h"

  use ISO_FORTRAN_ENV
  use, intrinsic :: ISO_C_BINDING

#ifdef HAVE_MPI
  use mpi
#endif

#include "ForTrilinos.h"
  use fortrilinos
  use forteuchos
  use fortpetra
  use fortest

  implicit none

  integer(int_type) :: my_rank, num_procs

  integer(global_size_type) :: n_global
  integer(size_type) :: n, max_entries_per_row, lda, num_eigen = 1
  integer(int_type) :: num_eigen_int
  integer(int_type) :: row_nnz

  integer :: ierr
  integer(local_ordinal_type) :: i
  integer(global_ordinal_type) :: offset
  real(scalar_type) :: one = 1.0

  type(TeuchosComm) :: comm
  type(ParameterList) :: plist
  type(TrilinosEigenSolver) :: eigen_handle
  type(TpetraMap) :: map
  type(TpetraCrsMatrix) :: A
  type(TpetraMultiVector) :: X

  real(scalar_type), dimension(:), allocatable :: evalues, evectors
  integer(global_ordinal_type), dimension(:), allocatable :: cols
  real(scalar_type), dimension(:), allocatable :: vals

  n = 50

#ifdef HAVE_MPI
  ! Initialize MPI subsystem
  call MPI_INIT(ierr)
  if (ierr /= 0) then
    write(*,*) "MPI failed to init"
    stop 1
  endif

  comm = create_TeuchosComm(MPI_COMM_WORLD)
#else
  comm = create_TeuchosComm()
#endif

  my_rank = comm%getRank()
  num_procs = comm%getSize()

  write(*,*) "Processor ", my_rank, " of ", num_procs

  ! Read in the parameterList
  plist = create_ParameterList("Anasazi"); FORTRILINOS_CHECK_IERR()
  call load_from_xml(plist, "davidson.xml"); FORTRILINOS_CHECK_IERR()

  num_eigen_int = num_eigen
  call plist%set("NumEV", num_eigen_int); FORTRILINOS_CHECK_IERR()

  ! ------------------------------------------------------------------
  ! Step 0: Construct tri-diagonal matrix
  n_global = -1
  map = create_TpetraMap(n_global, n, comm); FORTRILINOS_CHECK_IERR()

  max_entries_per_row = 3
  A = create_TpetraCrsMatrix(map, max_entries_per_row, TpetraDynamicProfile)

  allocate(cols(max_entries_per_row))
  allocate(vals(max_entries_per_row))
  offset = n * my_rank
  do i = 1, n
    row_nnz = 1
    if (i .ne. 1 .or. my_rank > 0) then
      cols(row_nnz) = offset + i-1
      vals(row_nnz) = -1.0
      row_nnz = row_nnz + 1
    end if
    cols(row_nnz) = offset + i
    vals(row_nnz) = 2.0
    row_nnz = row_nnz + 1
    if (i .ne. n .or. my_rank .ne. num_procs-1) then
      cols(row_nnz) = offset + i+1
      vals(row_nnz) = -1.0
      row_nnz = row_nnz + 1
    end if

    call A%insertGlobalValues(offset + i, cols(1:row_nnz-1), vals(1:row_nnz-1)); FORTRILINOS_CHECK_IERR()
  end do
  call A%fillComplete(); FORTRILINOS_CHECK_IERR()

  ! The solution
  allocate(evalues(num_eigen))
  X = create_TpetraMultiVector(map, num_eigen)

  ! Step 0: crate a handle
  eigen_handle = create_TrilinosEigenSolver(); FORTRILINOS_CHECK_IERR()

  ! ------------------------------------------------------------------
  ! Explicit setup and solve
  ! ------------------------------------------------------------------
  ! Step 1: initialize a handle
  call eigen_handle%init(comm); FORTRILINOS_CHECK_IERR()

  ! Step 2: setup the problem
  call eigen_handle%setup_matrix(A); FORTRILINOS_CHECK_IERR()

  ! Step 3: setup the solver
  call eigen_handle%setup_solver(plist); FORTRILINOS_CHECK_IERR()

  ! Step 4: solve the system
  call eigen_handle%solve(evalues, X); FORTRILINOS_CHECK_IERR()

  ! FIXME: Check the solution
  if (size(evalues) /= num_eigen) then
    write(error_unit, '(A)') 'The number of returned eigenvalues does not match!'
    stop 1
  end if
  write(*,*) "Computed eigenvalues: ", evalues(1)

  ! Step 5: clean up
  call eigen_handle%finalize(); FORTRILINOS_CHECK_IERR()

  call eigen_handle%release(); FORTRILINOS_CHECK_IERR()
  call plist%release(); FORTRILINOS_CHECK_IERR()
  call X%release(); FORTRILINOS_CHECK_IERR()
  call A%release(); FORTRILINOS_CHECK_IERR()
  call map%release(); FORTRILINOS_CHECK_IERR()
  call comm%release(); FORTRILINOS_CHECK_IERR()
  deallocate(evalues)
  deallocate(cols)
  deallocate(vals)

#ifdef HAVE_MPI
  ! Finalize MPI must be called after releasing all handles
  call MPI_FINALIZE(ierr)
#endif

end program


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
! Test the fix for PR45081 in which derived type array valued intrinsics failed
! to simplify, which caused an ICE in trans-array.c
!
! Contributed by Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
!
  module m
    implicit none
    integer :: i
    type t
      integer :: i
    end type t
    type(t), dimension(4), parameter :: t1  = [( t(i), i = 1, 4)]
    type(t), dimension(4), parameter :: t2  = [( t(i), i = 8, 11)]
    type(t), dimension(2,2), parameter :: a = reshape ( t1, [ 2, 2 ] )
    type(t), dimension(2,2), parameter :: b = transpose (a)
    type(t), dimension(4), parameter :: c = reshape ( b, [ 4 ] )
    type(t), dimension(2), parameter :: d = pack ( c, [.false.,.true.,.false.,.true.])
    type(t), dimension(4), parameter :: e = unpack (d, [.false.,.true.,.false.,.true.], t2)
    type(t), dimension(4,2), parameter :: f = spread (e, 2, 2)
    type(t), dimension(8), parameter :: g = reshape ( f, [ 8 ] )
    integer, parameter :: total = sum(g%i)
  end module m

    use m
    integer :: j
    j = total
  end
! { dg-final { scan-tree-dump-times "j = 50" 1 "original" } }