      subroutine qqb_hww_tb(p,msq)
      implicit none
c--- Author: J. M. Campbell, June 2011
c--- Implementation of gg -> H -> WW -> leptons,
c--- including both top and bottom quark loops
      include 'constants.f'
      include 'ewcouple.f'
      include 'qcdcouple.f'
      include 'masses.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      include 'anom_higgs.f'
      integer h1,h2,j,k
      double precision p(mxpart,4),msq(fn:nf,fn:nf),msqgg,fac
      double precision mfsq,tau,tauinv,rt,rescale
      double complex Ahiggs(2,2),fachiggs,amphiggs,f,e3De4
!      double complex num_c

      do j=-nf,nf
      do k=-nf,nf
      msq(j,k)=0d0
      enddo
      enddo

      call spinoru(6,p,za,zb)

c--- fill amplitudes with contributions of Higgs: top loop
      mfsq=mt**2
      tau=s(1,2)/(4d0*mfsq)
      tauinv=1d0/tau
      fachiggs=cone/dcmplx(s(1,2)-hmass**2,hmass*hwidth)

!====== SEYMOUR ISA APPROX
!      num_c=dcmplx(hmass**2/s(1,2))
!      fachiggs=num_c/dcmplx(s(1,2)-hmass**2,s(1,2)*hwidth/hmass)

      if (tau .le. 1d0) then
         f=dcmplx(dasin(sqrt(tau))**2)
      elseif (tau .gt. 1d0) then
         rt=sqrt(1d0-tauinv)
         f=-0.25d0*(dcmplx(log((1d0+rt)/(1d0-rt)))-im*pi)**2
      else
         f=czip
      endif
      e3De4=2d0*za(3,5)*zb(6,4)/(s(3,4)*s(5,6))
      amphiggs=mfsq*(cone+(cone-dcmplx(tauinv))*f)*im*e3De4
      Ahiggs(1,1)=fachiggs*amphiggs*za(1,2)/zb(2,1)
      Ahiggs(1,2)=czip
      Ahiggs(2,1)=czip
      Ahiggs(2,2)=fachiggs*amphiggs*zb(1,2)/za(2,1)

c--- fill amplitudes with contributions of Higgs: bottom loop
      mfsq=mb**2
      tau=s(1,2)/(4d0*mfsq)
      tauinv=1d0/tau

      if (tau .le. 1d0) then
         f=dcmplx(dasin(sqrt(tau))**2)
      elseif (tau .gt. 1d0) then
         rt=sqrt(1d0-tauinv)
         f=-0.25d0*(dcmplx(log((1d0+rt)/(1d0-rt)))-im*pi)**2
      else
         f=czip
      endif
      amphiggs=mfsq*(cone+(cone-dcmplx(tauinv))*f)*im*e3De4

      Ahiggs(1,1)=Ahiggs(1,1)+fachiggs*amphiggs*za(1,2)/zb(2,1)
      Ahiggs(2,2)=Ahiggs(2,2)+fachiggs*amphiggs*zb(1,2)/za(2,1)

c--- Rescale for width study
      if((keep_smhiggs_norm).and.(anom_higgs)) then
         rescale=chi_higgs**2
         Ahiggs(:,:)=Ahiggs(:,:)*rescale
      endif

      msqgg=0d0
      do h1=1,2
      do h2=1,2
      msqgg=msqgg+cdabs(Ahiggs(h1,h2))**2
      enddo
      enddo

c--- overall factor from diagrams
      fac=avegg*V*(2d0*gwsq*gsq/(16d0*pisq)*gwsq/2d0)**2
     & *s(3,4)**2/((s(3,4)-wmass**2)**2+(wwidth*wmass)**2)
     & *s(5,6)**2/((s(5,6)-wmass**2)**2+(wwidth*wmass)**2)

      msq(0,0)=msqgg*fac

      return
      end


Module fast_fourier_poisson_module

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

  Implicit None

  Public :: ffp_long_range
  Public :: ffp_sic

  Private

  Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

Contains

  Subroutine ffp_long_range( l, q, r, alpha, FD_order, recip_E, q_grid, pot_grid, ei, f, t_grid, t_recip, error )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

    Use lattice_module        , Only : lattice
    Use charge_grid_module    , Only : charge_grid_calculate, charge_grid_find_range, charge_grid_forces
    Use FFT_module            , Only : fft_fft3d

    Implicit None

    Type( lattice )                    , Intent( In    ) :: l
    Real( wp ), Dimension( 1:     )    , Intent( In    ) :: q
    Real( wp ), Dimension( 1:, 1:  )   , Intent( In    ) :: r
    Real( wp )                         , Intent( In    ) :: alpha
    Integer                            , Intent( In    ) :: FD_order
    Real( wp )                         , Intent(   Out ) :: recip_E
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent(   Out ) :: q_grid
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent(   Out ) :: pot_grid
    Real( wp ), Dimension( 1: )        , Intent(   Out ) :: ei
    Real( wp ), Dimension( 1:, 1: )    , Intent(   Out ) :: f
    Real( wp )                         , Intent(   Out ) :: t_grid
    Real( wp )                         , Intent(   Out ) :: t_recip
    Integer                            , Intent(   Out ) :: error

    Complex( wp ), Dimension( :, :, : ), Allocatable :: sfac
    Complex( wp ), Dimension( :, :, : ), Allocatable :: pot_k

    Real( wp ), Dimension( 1:3 ) :: G

    Real( wp ) :: G_len_sq
    Real( wp ) :: gauss_term

    Integer, Dimension( 1:3 ) :: n_grid
    Integer, Dimension( 1:3 ) :: range_gauss
    Integer, Dimension( 1:3 ) :: iG

    Integer :: iG1, iG2, iG3

    Integer( li ) :: start, finish, rate

    error = 0

    n_grid = Ubound( q_grid ) + 1

    ! Grid the charge
    Call system_clock( start, rate )
    ! First find range of the gaussian along each of the axes of the grid
    Call charge_grid_find_range( l, alpha, n_grid, range_gauss )
    ! Now grid the charge
    Call charge_grid_calculate( l, alpha, q, r, range_gauss, q_grid, error )
    Call system_clock( finish, rate )
    t_grid = Real( finish - start, wp ) / rate

    ! Now calculate the long range term by Fourier transform methods

    ! First calculate the structure factor
    Call system_clock( start, rate )
    Allocate( sfac( 0:n_grid( 1 ) - 1, 0:n_grid( 2 ) - 1, 0:n_grid( 3 ) - 1 ) )
    sfac = q_grid
    Call fft_fft3d( +1, sfac )

    ! Now calculate the potential in fourier space
    Allocate( pot_k( 0:n_grid( 1 ) - 1, 0:n_grid( 2 ) - 1, 0:n_grid( 3 ) - 1 ) )
    Do iG3 = 0, n_grid( 3 ) - 1
       Do iG2 = 0, n_grid( 2 ) - 1
          Do iG1 = 0, n_grid( 1 ) - 1
             iG = [ iG1, iG2, iG3 ]
             If( All( iG == 0 ) ) Then
                pot_k( 0, 0, 0 ) = 0.0_wp
             Else
                Where( iG > n_grid / 2 )
                   iG = iG - n_grid
                End Where
                Call l%get_rec_vec( iG, G )
                G_len_sq = Dot_product( G, G )
                gauss_term = 1.0_wp / G_len_sq
                pot_k( iG1, iG2, iG3 ) = sfac( iG1, iG2, iG3 ) * gauss_term
             End If
          End Do
       End Do
    End Do
    Call fft_fft3d( -1, pot_k )
    pot_grid = Real( pot_k, wp ) / ( pi * Product( n_grid ) )
    Call system_clock( finish, rate )
    t_recip = Real( finish - start, wp ) / rate

    ! Calculate from the potential the long range energy
    ! Two minus signs as a) this is the SCREENED charge
    !                    b) I like to just add up the energies, having to subtract it is confusing
    recip_E = - 0.5_wp * Sum( - q_grid * pot_grid ) * ( l%get_volume() / Product( n_grid ) )

    ! Calculate the forces and energy per site
    Call charge_grid_forces( l, alpha, q, r, range_gauss, q_grid, pot_grid, ei, f )

  End Subroutine ffp_long_range

  Pure Function ffp_sic( q, alpha ) Result( sic )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    Real( wp ), Dimension( : ), Intent( In    ) :: q
    Real( wp )                , Intent( In    ) :: alpha

    Real( wp ) :: sic

    sic = - alpha * Sum( q * q ) / Sqrt( 2.0_wp * pi )

  End Function ffp_sic

End Module fast_fourier_poisson_module


!     ------------------------------------------------------------------
!              T K
!     ------------------------------------------------------------------
!

      DOUBLE PRECISION FUNCTION TK (I, II, J, JJ, K)
      use param_C
      use radial_C
      use nel_C
!
!      PARAMETER (NOD=220)
!
!      PARAMETER (NOD=220)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
!...Translated by Pacific-Sierra Research 77to90  4.3E  00:45:17  11/16/01
!...Switches:
!      COMMON/PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
!     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
!      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX_(1))
!      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
!
      CALL DZK (II, JJ, K)
      CALL YKK (II, JJ, K, 1)
!
      DEN = L(I) + L(J) + 2
      FACT = L(J)
      D = FACT*P(3,I)*P(3,J)*YK(3)/DEN
!
      MX = MIN0(MAX_(I),MAX_(J)) - 1
      DO M = 3, MX
         S = ((-P(M+2,J))+D8*(P(M+1,J)-P(M-1,J))+P(M-2,J))/(D6*H)
         YK(M) = D5*P(M,I)*(S - P(M,J))*YK(M)
      END DO
!
      S1 = D0
      S2 = D0
      DO M = 4, MX, 2
         S1 = S1 + YK(M)
         S2 = S2 + YK(M+1)
      END DO
!
      TK = D + H1*(S2 + D2*S1 + D5*YK(3))
      TK = TK/(K + K + 1)*FINE
      RETURN
      END FUNCTION TK


Module diel_models
Implicit None

contains

!------------------------------------------------------------
! The HS model calls the unmodified version of the AMMF HS
! dielectric theory
!
! rho   : density, reduced with sigma^3
! mu2   : dipole moment squared, reduced with 1 / kT sigma^3
! diel  : output dielectric constant value
! Gkirk : The G1 angular correlation coefficient
! scale : optional scaling of y*g1 in the kirkwood formula
!------------------------------------------------------------
subroutine compute_dielectric_dHS(rho, mu2, diel, Gkirk, scale)
	Use nrtype
	Use dielectric, Only : G1, dielectric_const

	Implicit None
	Real(DP)    :: rho, mu2, scale
	Real(DP)    :: Gkirk, diel
	Intent(IN)  :: rho, mu2
	Intent(OUT) :: diel, Gkirk
	OPTIONAL    :: scale

	if (.NOT. PRESENT(scale)) scale = ONE

        Gkirk =               G1(rho, mu2, ONE)
        diel  = dielectric_const(rho, mu2, ONE, scale)
end subroutine compute_dielectric_dHS

!------------------------------------------------------------
! To model the Stockmayer fluid we use a mapping proposed by
! Theiss, Gross to find a corresponding state where the
! dielectric of the dHS corresponds to that of the Stockmayer
! (SM) fluid.
!
! rho   : density, reduced with sigma^3
! mu2   : dipole moment squared, reduced with 1 / epsilon sigma^3
! Temp  : temperature, reduced using k / epsilon
! diel  : output dielectric constant value
! Gkirk : The G1 angular correlation coefficient
! scale : optional scaling of y*g1 in the kirkwood formula
!
!------------------------------------------------------------
subroutine compute_dielecric_SM(rho, mu2, temp, diel, Gkirk, sigEff, scale)
	Use nrtype
	Use dielectric, Only : G1, dielectric_const
	Use Laguerre,   Only : Laguerre_fast
	Implicit None
	Real(DP)    :: rho, mu2, temp, scale
	Real(DP)    :: Gkirk, diel
	Real(DP)    :: mu2_kT_eff, sigEff, sigScaling, rho_eff
	Intent(IN)  :: rho, mu2, temp
	Intent(OUT) :: diel, Gkirk, sigEff
	OPTIONAL    :: scale

	if (.NOT. PRESENT(scale)) scale = ONE

	call Laguerre_fast(Temp,2*SIX,SIX,sigEff)

	sigScaling = sigEff*sigEff*sigEff
	mu2_kT_eff = (mu2 / temp) !* (1/sigScaling)
	rho_eff    = rho !* sigScaling

        Gkirk  =               G1(rho_eff, mu2_kT_eff, sigEff)
        diel   = dielectric_const(rho_eff, mu2_kT_eff, sigEff, scale)
end subroutine compute_dielecric_SM

End Module diel_models


      program camp
      implicit NONE

      logical FOREVER
      parameter (FOREVER=.true.)
      real*8 lon,lat
      real*8 x,y
      integer p,pmax,ptmp
      parameter (pmax=50000)
      real*8 a(pmax)
      real*8 k(pmax),l(pmax)
      real*8 dk,dl
      parameter (dk=8.0d0)
      parameter (dl=8.0d0)
      integer flag(pmax)
      real*8 Nxk,Nyl
      real*8 z

      do while(FOREVER)

         read(*,*)lon,lat
         if(lon.eq.0.0d0)then
            goto999
         endif
         if((lon.lt.125.0d0).or.(lon.gt.155.0d0)
     &        .or.(lat.lt.20.0d0).or.(lat.gt.50.0d0))then
            write(*,*)'OUT OF THE MODEL REGION'
            goto 992
         endif
         call Lambert(lon,lat,x,y)

         open(unit=90,file='camp_pac.bdy',status='old')
         do p=1,pmax
            read(90,*,END=990)k(p),l(p),a(p),flag(p)
            ptmp=p
         enddo
 990     continue
         close (unit=90)

         z=0.0d0
         do p=1,ptmp
            if(((x-2.0d0*dk.lt.k(p)).and.(x+2.0d0*dk.gt.k(p))).and.
     &           ((y-2.0d0*dl.lt.l(p)).and.(y+2.0d0*dl.gt.l(p))))then
               call spline(x,k(p),dk,Nxk)
               call spline(y,l(p),dl,Nyl)
               z=z+a(p)*Nxk*Nyl
               if(flag(p).eq.0)then
                  z=0.0d0
                  goto 991
               endif
            endif
         enddo
 991     continue
         if(z.gt.100.0d0)then
            z=0.0d0
         endif
         if(z.le.0.0d0)then
            write(*,*)'OUT OF THE MODEL REGION'
            goto 992
         endif
         write(*,*)z
 992     continue
      enddo
 999  continue

      stop
      end

      subroutine spline(s,sj,dsj,N)
      implicit NONE

      real*8 s
      real*8 N
      real*8 sj,dsj
      real*8 sj2
      real*8 M

      sj2=sj+2.0D+00*dsj

      if((s.ge.sj2-4.0D+00*dsj).and.(s.lt.sj2-3.0D+00*dsj))then
         M=(1.0D+00/(24.0D+00*(dsj**4.0d0)))
     &        *((s-sj2+4.0d0*dsj)**3.0d0)
      elseif((s.ge.sj2-3.0d0*dsj).and.(s.lt.sj2-2.0d0*dsj))then
         M=(1.0d0/(24.0d0*(dsj**4.0d0)))
     &        *(((s-sj2+4.0d0*dsj)**2.0d0)*(sj2-2.0d0*dsj-s)
     &        +(s-sj2+4.0d0*dsj)*(s-sj2+3.0d0*dsj)*(sj2-dsj-s)
     &        +(sj2-s)*((s-sj2+3.0d0*dsj)**2.0d0))
      elseif((s.ge.sj2-2.0d0*dsj).and.(s.lt.sj2-dsj))then
         M=(1.0d0/(24.0d0*(dsj**4.0d0)))
     &        *((s-sj2+4.0d0*dsj)*((sj2-dsj-s)**2.0d0)
     &        +(sj2-s)*(s-sj2+3.0d0*dsj)*(sj2-dsj-s)
     &        +((sj2-s)**2.0d0)*(s-sj2+2.0d0*dsj))
      elseif((s.ge.sj2-dsj).and.(s.lt.sj2))then
         M=(1.0d0/(24.0d0*(dsj**4.0d0)))*((sj2-s)**3.0d0)
      else
         M=0.0d0
      endif

      N=4.0d0*dsj*M

      return
      end

      subroutine Lambert(lambda,phi,x,y)
      implicit NONE

      real*8 PI
      parameter (PI=3.1415926535897932d0)
      real*8 phi,lambda
      real*8 phi_0,lambda_0
      real*8 phi_1,phi_2
      real*8 theta
      real*8 n,rho
      real*8 rho_0
      real*8 F
      real*8 R
      real*8 x,y,xtmp,ytmp

      phi_0=35.0d0
      lambda_0=140.0d0
      phi_1=30.0d0
      phi_2=40.0d0
      R=6371.0d0

      phi_0=phi_0*((2.0d0*PI)/360.0d0)
      phi_1=phi_1*((2.0d0*PI)/360.0d0)
      phi_2=phi_2*((2.0d0*PI)/360.0d0)
      lambda_0=lambda_0*((2.0d0*PI)/360.0d0)
      n=log(cos(phi_1)/cos(phi_2))
     &     /log(tan((PI/4.0d0)+(phi_2/2.0d0))
     &     /tan((PI/4.0d0)+(phi_1/2.0d0)))
      F=(cos(phi_1)*(tan((PI/4.0d0)+(phi_1/2.0d0)))**n)/n
      rho_0=R*F/(tan((PI/4.0d0)+(phi_0/2.0d0))**n)
      phi=phi*((2.0d0*PI)/360.0d0)
      lambda=lambda*((2.0d0*PI)/360.0d0)
      rho=R*F/(tan((PI/4.0d0)+(phi/2.0d0))**n)
      theta=n*(lambda-lambda_0)
      xtmp=rho*sin(theta)
      ytmp=rho_0-rho*cos(theta)
      x=-ytmp
      y=-xtmp

      return
      end


subroutine rules2
use fdeclarations

implicit none
do i=1,z
bayh2(i)=bayh1(i)/(bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i))
bayg2(i)=bayg1(i)/(bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i))
baym2(i)=baym1(i)/(bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i))
bayp2(i)=bayp1(i)/(bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i))
bayb2(i)=bayb1(i)/(bayh1(i)+bayg1(i)+baym1(i)+bayp1(i)+bayb1(i))
end do

bgood=eud*bayg2
bmoderate=euc*baym2
bhigh=eue*bayh2
bpoor=eub*bayp2
bbad=eua*bayb2

end subroutine rules2


      SUBROUTINE DROTMGF (DD1,DD2,DX1,DY1,DPARAM)
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*
C     DY2)**T.
C     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
C     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
C     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
C
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2,
     1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1,
     2 DTEMP,DX1,TWO
      DIMENSION DPARAM(5)
          RETURN
      END


module invert
use config, only: ptol
use math
implicit none

private
public :: invert_points_on_plane

contains

subroutine invert_points_on_plane(n, pnts, p0, vu, vv, params)
    !> Invert the array of points on a plane.
    !> n - Number of points to invert.
    !> pnts - Points to invert.
    !> p0 - Origin of plane.
    !> vu - Vector defining major axis of plane.
    !> vv - Vector defining minor axis of plane (should be orthognal to vu).
    !> params - Parameters of points on the plane.

    ! f2py intent(in) n, pnts, origin, pnorm
    ! f2py intent(out) params
    ! f2py depend(n) pnts, params

    ! Input
    integer, intent(in) :: n
    double precision, intent(in) :: p0(3), vu(3), vv(3)
    double precision, intent(in) :: pnts(n, 3)

    ! Output
    double precision, intent(out) :: params(n, 2)

    ! Working
    integer :: i
    double precision :: mag, vu_norm2, vv_norm2, u, v
    double precision :: vu_norm(3), vv_norm(3), pi(3)

    ! Get unit vectors and dot products.
    mag = norm(vu)
    vu_norm = vu / mag
    mag = norm(vv)
    vv_norm = vv / mag
    vu_norm2 = dot_product(vu_norm, vu_norm)
    vv_norm2 = dot_product(vv_norm, vv_norm)

    ! Calculate parameters on plane for each point.
    params(:, :) = 0.0d0
    do i = 1, n
        pi = pnts(i, :)
        u = dot_product(pi - p0, vu_norm) / vu_norm2
        v = dot_product(pi - p0, vv_norm) / vv_norm2
        if (dabs(u) .le. ptol) then
            u = 0.0d0
        end if
        if (dabs(v) .le. ptol) then
            v = 0.0d0
        end if
        params(i, :) = (/ u, v /)
    end do

end subroutine invert_points_on_plane

end module invert


      program conflict
      implicit none

      integer i, j, imax, jmax
      parameter (imax = 3, jmax = 3)

      real a(0:imax,0:jmax)

      do 1 i = 0, imax
         do 2 j = 0, jmax
            a(i,j) = a(j,i-1) + a(i+1,j) + a(i, j)
 2       continue
 1    continue

      end


*DECK R1MPYQ
      SUBROUTINE R1MPYQ (M, N, A, LDA, V, W)
C***BEGIN PROLOGUE  R1MPYQ
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNSQ and SNSQE
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (R1MPYQ-S, D1MPYQ-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N matrix A, this subroutine computes A*Q where
C     Q is the product of 2*(N - 1) transformations
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     and GV(I), GW(I) are Givens rotations in the (I,N) plane which
C     eliminate elements in the I-th and N-th planes, respectively.
C     Q itself is not given, rather the information to recover the
C     GV, GW rotations is supplied.
C
C     The subroutine statement is
C
C       SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of A.
C
C       N is a positive integer input variable set to the number
C         of columns of A.
C
C       A is an M by N ARRAY. On input A must contain the matrix
C         to be postmultiplied by the orthogonal matrix Q
C         described above. On output A*Q has replaced A.
C
C       LDA is a positive integer input variable not less than M
C         which specifies the leading dimension of the array A.
C
C       V is an input array of length N. V(I) must contain the
C         information necessary to recover the Givens rotation GV(I)
C         described above.
C
C       W is an input array of length N. W(I) must contain the
C         information necessary to recover the Givens rotation GW(I)
C         described above.
C
C***SEE ALSO  SNSQ, SNSQE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  R1MPYQ
      INTEGER M,N,LDA
      REAL A(LDA,*),V(*),W(*)
      INTEGER I,J,NMJ,NM1
      REAL COS,ONE,SIN,TEMP
      SAVE ONE
      DATA ONE /1.0E0/
C***FIRST EXECUTABLE STATEMENT  R1MPYQ
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 50
      DO 20 NMJ = 1, NM1
         J = N - NMJ
         IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
         IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(V(J)) .LE. ONE) SIN = V(J)
         IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 10 I = 1, M
            TEMP = COS*A(I,J) - SIN*A(I,N)
            A(I,N) = SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
C
C     APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
C
      DO 40 J = 1, NM1
         IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
         IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(W(J)) .LE. ONE) SIN = W(J)
         IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 30 I = 1, M
            TEMP = COS*A(I,J) + SIN*A(I,N)
            A(I,N) = -SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE R1MPYQ.
C
      END


    SUBROUTINE trap_charge_calibration(length_multiplier, load_time, expt_num, data_type)

    IMPLICIT NONE
    CHARACTER (len = 100) :: filename                ! Dummy variable for opening files
    CHARACTER(len=8) :: fmt                          ! Format descriptor for file_number
    CHARACTER(len=8) :: file_number                  ! File number to read
    CHARACTER(len=8) :: file_freq                    ! File frequency to read
    CHARACTER(len=8) :: file_attenuation             ! File attenuation to read

    INTEGER :: nvals = 0                            ! Number of datapoints
    INTEGER :: calibration_channel                  ! Integer value to determine calibration option
    INTEGER :: noise_channel                        ! Integer value to determine channel of noise files
    INTEGER :: filter_option                        ! Indicator for application of a filter
    INTEGER :: first_file_number                    ! Number of the first file to be analyzed
    INTEGER :: last_file_number                     ! Number of the last file to be analyzed
    INTEGER :: number_of_files                      ! Number of files to analyze (max = 100)
    INTEGER :: i, j, k, l, m, n, y                  ! Loop variables
    INTEGER :: unit                                 ! Unit number for r/w files
    INTEGER :: stat                                 ! Error message when opening files
    INTEGER :: data_type                            ! Pointer for .dat or .txt files to analyze
    INTEGER :: signal_end                           ! Length of signal on which to apply FFT
    INTEGER :: window_function                      ! Indicator for application of apodization function
    INTEGER :: mult                                 ! Number of cycles in all of datafile (1048576/square_total_real)
    INTEGER :: start                                ! Start of cycle as determined by random number generator
    INTEGER :: n_main                               ! Pointer for file section
    INTEGER :: attenuation                          ! Attenuation of input signal in decibels
    INTEGER :: derivative_peak                      ! Inflection point of derivative
    INTEGER :: der_opt                              ! Derivative option for looking for positive or negative derivative
!    INTEGER :: cycle_start                          ! Cycle number to begin analyzing
!    INTEGER :: cycle_end                            ! Cycle number on which to end analysis

    INTEGER :: length_multiplier                    ! Multiplier for length of each trapping event (multiple of 1 ms or 2500 datapoints)
    INTEGER :: load_time                            ! Time between end of one trappng event and beginning of next (multiple of 1 ms or 2500 datapoints)
    INTEGER :: expt_num                             ! Maximum number of experiments per file based on signal length (length_multiplier)

    REAL(4) :: input_freq                           ! Frequency of input calibration signal
    REAL(4) :: freq_shift                           ! Frequency shift of test signal (in percent)
    REAl(4) :: avg_sum                              ! Sum of all magnitude values (at a given time length) for averaging purposes
    REAL(4) :: avg                                  ! Average magnitude value at a given time length
    REAL(4) :: diff_squared                         ! Sum of square of difference between avg and peak_magnitude(j)
    REAL(4) :: std_dev                              ! Standard deviation of avg
    REAL(4) :: rel_std_dev                          ! Relative standard deviation of avg
    REAl(4) :: freq_avg_sum                         ! Sum of all frequency values (at a given time length) for averaging purposes
    REAL(4) :: freq_avg                             ! Average frequency value at a given time length
    REAL(4) :: freq_diff_squared                    ! Sum of square of difference between freq_avg and freq_value(j)
    REAL(4) :: freq_std_dev                         ! Standard deviation of freq_avg
    REAL(4) :: freq_rel_std_dev                     ! Relative standard deviation of freq_avg
    REAl(4) :: integral_avg_sum                     ! Sum of all frequency values (at a given time length) for averaging purposes
    REAL(4) :: integral_avg                         ! Average frequency value at a given time length
    REAL(4) :: integral_diff_squared                ! Sum of square of difference between freq_avg and freq_value(j)
    REAL(4) :: integral_std_dev                     ! Standard deviation of freq_avg
    REAL(4) :: integral_rel_std_dev                 ! Relative standard deviation of freq_avg
!    REAl(4) :: weighted_freq_avg_sum                ! Sum of all weighted frequency values (at a given time length) for averaging purposes
!    REAL(4) :: weighted_freq_avg                    ! Average weighted frequency value at a given time length
!    REAL(4) :: weighted_freq_diff_squared           ! Sum of square of difference between weighted_freq_avg and weighted_freq_value(j)
!    REAL(4) :: weighted_freq_std_dev                ! Standard deviation of weighted_freq_avg
!    REAL(4) :: weighted_freq_rel_std_dev            ! Relative standard deviation of weighted_freq_avg
    REAL(4) :: time                                 ! Length of sampled signal based on number of datapoints selected
    REAL(4) :: cycles                               ! Number of cycles based on length of sampled signal and frequency
    REAL(4) :: millivolts                           ! Voltage of mock input signal (in mV)
    REAL(4) :: electrons                            ! Number of charges on mock input signal (in electrons)
    REAL(4) :: peak_magnitude                       ! FFT magnitude value returned from subroutine "calibration_fft"
    REAL(4) :: harm2_rel_mag                        ! Ratio of 2nd harmonic magnitude to fundamental
    REAL(4) :: freq_value                           ! Frequency value returned from subroutine "calibration_fft"
    REAL(4) :: integral_value                       ! Integral value returned from subroutine "calibration_fft"

    REAL(8) :: A1                                   ! Variable to define test signal (obtained from Origin)
    REAL(8) :: A2                                   ! Variable to define test signal (obtained from Origin)
    REAL(8) :: x0                                   ! Variable to define test signal (obtained from Origin)
    REAL(8) :: dx                                   ! Variable to define test signal (obtained from Origin)
    REAL(8) :: x                                    ! Variable to define test signal (obtained from Origin)

    REAL(8) :: square_total_real                    ! Length of test signal
    REAL(8) :: old_square_total_real                ! Length of previous test signal before frequency shift
    REAL(8) :: remainder                            ! Offset for next cycle in test signal

    INTEGER :: array_pointer                        ! Counter for creating test signal with frequency shift
    REAL(4) :: rand                                 ! Random number

    INTEGER(2), DIMENSION (1:1000000) :: input_array
    REAL(4), DIMENSION (1:1048576) :: sq_wave_array     ! Square wave array
    REAL(4), DIMENSION (1:1048576) :: sq_wave           ! Square wave array after random start point selected
    REAL(4), DIMENSION (1:1048576) :: y_input           ! Input array
    REAL(4), DIMENSION (1:1048576) :: adj_input         ! Input datapoints from trap data
    REAL(4), DIMENSION (1:1048576) :: derivative        ! First derivative of y_input
    REAL(4), DIMENSION (1:1048576) :: y_filter          ! Output of 10 kHz high-pass filter
    REAL(4), DIMENSION (1:1048576) :: fft_filter_output ! Output of 10 kHz FFT filter
    REAL(4), DIMENSION (1:100) :: peaks                 ! Array for square wave peak magnitudes
    REAL(4), DIMENSION (1:100) :: freq                  ! Array for frequency values of square wave max peak magnitudes
    REAL(4), DIMENSION (1:100) :: peak_int              ! Array for integral values of square wave peak
    REAL(4), DIMENSION (1:100) :: rnd                   ! Random number array

    REAL(4), ALLOCATABLE :: peak_mag(:)             ! Array for peak magnitudes
    REAL(4), ALLOCATABLE :: frequency(:)            ! Array for frequency values of max peak magnitudes
    REAL(4), ALLOCATABLE :: integral(:)             ! Array for integral values of peak

    INTEGER :: file_channel
    INTEGER :: number_of_cycles                      ! Number of cycles per file based on length datafile and frequency
    INTEGER :: cycle_length                          ! Number of datapoints per cycle based on frequency

    REAl(4) :: sum_max                              ! Sum of all local maxima for averaging purposes
    REAl(4) :: sum_min                              ! Sum of all local minima for averaging purposes
    REAL(4) :: max_avg                              ! Average of maxima values
    REAL(4) :: min_avg                              ! Average of minima values
    REAL(4) :: max_diff_squared                     ! Sum of square of difference between max_avg and max_val_array(i)
    REAL(4) :: min_diff_squared                     ! Sum of square of difference between min_avg and min_val_array(i)
    REAL(4) :: max_std_dev                          ! Standard deviation of max_avg
    REAL(4) :: min_std_dev                          ! Standard deviation of min_avg
    REAL(4) :: amplitude                            ! Difference between max_avg and min_avg
    REAL(4) :: amp_error                            ! Amplitude error

    REAL(4), ALLOCATABLE :: max_val_array(:)         ! Array for local maxima values
    REAL(4), ALLOCATABLE :: min_val_array(:)         ! Array for local minima values
    REAL(4), ALLOCATABLE :: cycle_array(:)           ! Array for amplitude values in one cycle
    REAL(4), ALLOCATABLE :: y_input_array (:,:)

    ! User selected calibration options
    PRINT *, "Enter 1 for channel A calibration..."
    PRINT *, "Enter 2 for channel B calibration..."
    PRINT *, "Enter 3 for noiseless test signal (to see FFT magnitude uncertainty)..."
    PRINT *, "Enter 4 for test signal added onto noise files..."
    PRINT *, "Enter 5 for calibration of input charge to ADC bits..."
    READ *, calibration_channel
    WRITE (97,*) "Enter 1 for channel A calibration..."
    WRITE (97,*) "Enter 2 for channel B calibration..."
    WRITE (97,*) "Enter 3 for noiseless test signal (to see FFT magnitude uncertainty)..."
    WRITE (97,*) "Enter 4 for test signal added onto noise files..."
    WRITE (97,*) "Enter 5 for calibration of input charge to ADC bits..."
    WRITE (97,*) calibration_channel

    expt_num = INT(400 / length_multiplier)

    ! Actions to take for calibrating channel "A" or "B"
    IF (calibration_channel == 1 .OR. calibration_channel == 2) THEN

        PRINT *, "Enter attenuation in decibels..."
        READ *, attenuation
        WRITE (97,*) "Enter attenuation in decibels..."
        WRITE (97,*) attenuation

        ! Select frequency of calbration signal
        PRINT *, "Enter frequency of input calibration signal in kHz..."
        READ *, input_freq
        WRITE (97,*) "Enter frequency of input calibration signal in kHz..."
        WRITE (97,*) input_freq

        CLOSE (UNIT=97, STATUS='KEEP')

        fmt = '(I2.2)'
        WRITE (file_attenuation, fmt) attenuation

        fmt = '(I3.3)'
        WRITE (file_freq, fmt) INT(input_freq)
        filename = TRIM(file_attenuation)//'dB_'//TRIM(file_freq)//'kHz.txt'

        input_freq = input_freq * 1000

!        PRINT *, "Enter output file name (100 characters max)..."
!        READ *, filename
!        WRITE (97,*) "Enter output file name (100 characters max)..."
!        WRITE (97,*) filename
        unit = 101
        CALL open_new_file (unit, filename)

        unit = 102
        filename = "peak_magnitudes.txt"
        CALL open_new_file (unit, filename)

        ! Headers for output files
!        WRITE (101,1002) "Freq", "Data_Pts", "Seconds", "Cycles", "Magnitude", "Std_Dev", "Rel_Std_Dev", "Freq_Avg", "Freq_Std_Dev", "Freq_Rel_Std_Dev", &
!                         & "Integral_Avg", "Integral_Std_Dev", "Integral_Rel_Std_Dev"
!        1002 FORMAT  (T5, A5, T13, A9, T27, A8, T40, A7, T56, A10, T80, A8, T93, A11, T115, A8, T128, A12, T145, A16, TR10, A12, TR10, A16, TR5, A20)
        WRITE (101,1002) "Freq", "Data_Pts", "Seconds", "Cycles", "Harm1+2_Magnitude", "Std_Dev", "Rel_Std_Dev", "Freq_Avg", "Freq_Std_Dev", "Freq_Rel_Std_Dev", "Harm2_Rel_Mag"
        1002 FORMAT  (T5, A5, T13, A9, T27, A8, T40, A7, T52, A18, T80, A8, T93, A11, T115, A8, T128, A12, T145, A16, T166, A13)

        ! User selected option for number of files in each run
        ! Maximum number of files is only limited by how the code is currently written
        ! Can be increased by adding extra code to associated "DO" loop below
!        PRINT *, "Enter number of files..."
!        READ *, number_of_files
!        WRITE (97,*) "Enter number of files..."
!        WRITE (97,*) number_of_files
        PRINT *, "Enter number of first file..."
        READ *, first_file_number
        PRINT *, "Enter number of last file..."
        READ *, last_file_number
        WRITE (97,*) "Enter number of first file..."
        WRITE (97,*) first_file_number
        WRITE (97,*) "Enter number of last file..."
        WRITE (97,*) last_file_number

        number_of_files = last_file_number - first_file_number + 1
        ALLOCATE (y_input_array(1:1048576, 1:number_of_files))

        ! This DO loop assigns name of datafile to open
        ! This streamlines data acquisition and analysis
        DO  j = 0, (number_of_files - 1)

            IF (last_file_number < 10000) fmt = '(I4.4)'
            IF (last_file_number >= 10000) fmt = '(I5.5)'
!            fmt = '(I5.5)'
!            unit = j + 10002
!            ! No need to delete first two files with triggered boards, so...
!            unit = j + 10000
            unit = j + first_file_number

            IF  (data_type == 1)    THEN

                IF  (calibration_channel == 1)  THEN
!                    WRITE (file_number, fmt) (j+10002)
                    WRITE (file_number, fmt) (j+first_file_number)
                    filename = 'chA'//TRIM(file_number)//'.dat'
                ELSE IF (calibration_channel == 2)  THEN
!                    WRITE (file_number, fmt) (j+10002)
                    WRITE (file_number, fmt) (j+first_file_number)
                    filename = 'chB'//TRIM(file_number)//'.dat'
                END IF

                PRINT *, "Now reading from ", filename
                OPEN (UNIT=unit, FILE=filename, STATUS="old", ACTION="read", IOSTAT=stat, FORM="binary")

                input_array = 0
                y_input = 0

                ! Read input file into array "y_input"
                READ (unit, END=8) input_array            ! Read filename values and store in array "y"
                8   CONTINUE

                DO  k = 1, 1000000
                    y_input(k) = input_array(k)
                END DO

            ELSE IF (data_type == 2)   THEN

                IF  (calibration_channel == 1)  THEN
!                    WRITE (file_number, fmt) (j+10002)
                    WRITE (file_number, fmt) (j+first_file_number)
                    filename = 'chA'//TRIM(file_number)//'.txt'
                ELSE IF (calibration_channel == 2)  THEN
!                    WRITE (file_number, fmt) (j+10002)
                    WRITE (file_number, fmt) (j+first_file_number)
                    filename = 'chB'//TRIM(file_number)//'.txt'
                END IF

                PRINT *, "Now reading from ", filename
                OPEN (UNIT=unit, FILE=filename, STATUS="old", ACTION="read", IOSTAT=stat)

                y_input = 0

                ! Read input file into array "y_input"
                READ (unit, *, END=9) y_input            ! Read filename values and store in array "y"
                9   CONTINUE

            END IF

            CLOSE (unit)

            adj_input = 0

            DO  k = 1, 1000000
                IF  (MOD(k,2) == 1) THEN
                    adj_input(k) = y_input(k+1)
                ELSE IF (MOD(k,2) == 0) THEN
                    adj_input(k) = y_input(k-1)
                END IF
            END DO

            y_input_array(:,(j+1)) = adj_input

        END DO

        ! Performs calibration for both filtered and non-filtered
!        DO  y = 1, 2
        DO  y = 1, 1

            IF  (y == 1)    THEN
                filter_option = 1
            ELSE
                filter_option = 2
            END IF

            ! Performs calibration for both Gaussian windowed data and non-windowed data
!            DO  n = 1, 2
            DO  n = 1, 1

                ! Writes type of window in output file
                IF  (y == 1 .AND. n == 1)    THEN
                    window_function = 1
                    WRITE (101,201) "Gaussian_Window_Data_Filtered"
                    WRITE (102,201) "Gaussian_Window_Data_Filtered"
                    201 FORMAT (A30)
                ELSE IF (y == 1 .AND. n == 2)   THEN
                    window_function = 4
                    WRITE (101,201) "Non-Windowed_Data_Filtered"
                    WRITE (102,201) "Non-Windowed_Data_Filtered"
                ELSE IF (y == 2 .AND. n == 1)   THEN
                    window_function = 1
                    WRITE (101,201) "Gaussian_Window_Data_No_Filter"
                    WRITE (102,201) "Gaussian_Window_Data_No_Filter"
                ELSE IF (y == 2 .AND. n == 2)   THEN
                    window_function = 4
                    WRITE (101,201) "Non-Windowed_Data_No_Filter"
                    WRITE (102,201) "Non-Windowed_Data_No_Filter"
                END IF

                ! Allocate size of arrays based on number of calibration files (13 sections per file)
                ALLOCATE(peak_mag(1:(number_of_files*expt_num)), frequency(1:(number_of_files*expt_num)), integral(1:(number_of_files*expt_num)))

!                number_of_files = 10

                ! Looks at different lengths of signals
                ! Takes FFT at given length of many files and finds avg FFT magnitude
                DO  i = 1, INT(2500. * REAL(length_multiplier) / 2000.)
!                    signal_end = i
                    signal_end = ((i-1) * 2000) + 2500
                    PRINT *, signal_end

                    ! This DO loop assigns name of datafile to open
                    ! This streamlines data acquisition and analysis
                    DO  j = 1, number_of_files

                        y_input = y_input_array(:,j)

                        ! Apply a filter in accordance with user-defined input
                        IF  (filter_option == 1)    THEN
                            CALL fft_filter(y_input, fft_filter_output)
                            y_input = fft_filter_output
                        END IF

                        ! Finds FFT magnitude for each section at given length
                        DO  k = 1, expt_num
                            n_main = k

                            CALL calibration_fft(y_input, signal_end, n_main, window_function, input_freq, j, peak_magnitude, freq_value, integral_value, number_of_files, length_multiplier, harm2_rel_mag)

                            ! Assign mag, freq, and integral values to new array
                            peak_mag(k + ((j-1)*expt_num)) = peak_magnitude
                            frequency(k + ((j-1)*expt_num)) = freq_value
                            integral(k + ((j-1)*expt_num)) = integral_value
                        END DO

                    END DO

                    ! Sum all peak magnitude values at a given frequency
                    ! Sum all frequency values at a given signal length
                    ! Sum all integral values at a given signal length
                    avg_sum = 0
                    freq_avg_sum = 0
                    integral_avg_sum = 0
                        DO  j = 1, (number_of_files*expt_num)
                            avg_sum = avg_sum + peak_mag(j)
                            freq_avg_sum = freq_avg_sum + frequency(j)
                            integral_avg_sum = integral_avg_sum + integral(j)
                        END DO

                    ! Find the average magnitude of a given frequency
                    ! Find the average frequency at a given signal length
                    ! Find the average integral at a given signal length
                    avg = avg_sum/(number_of_files*expt_num)
                    freq_avg = freq_avg_sum/(number_of_files*expt_num)
                    integral_avg = integral_avg_sum/(number_of_files*expt_num)

                    ! Sum of the square of the difference betweeen each value and the average
                    diff_squared = 0
                    freq_diff_squared = 0
                    integral_diff_squared = 0
                        DO  j = 1, (number_of_files*expt_num)
                            diff_squared = diff_squared + ((peak_mag(j) - avg)**2)
                            freq_diff_squared = freq_diff_squared + ((frequency(j) - freq_avg)**2)
                            integral_diff_squared = integral_diff_squared + ((integral(j) - integral_avg)**2)
                        END DO

                    ! Standard deviation of magnitude average
                    ! Standard deviation of frequency average
                    ! Standard deviation of integral average
                    std_dev = SQRT(diff_squared/((number_of_files*expt_num)-1))
                    freq_std_dev = SQRT(freq_diff_squared/((number_of_files*expt_num)-1))
                    integral_std_dev = SQRT(integral_diff_squared/((number_of_files*expt_num)-1))

                    ! Relative standard deviation of magnitude average
                    ! Relative standard deviation of frequency average
                    ! Relative standard deviation of integral average
                    rel_std_dev = std_dev / avg * 100
                    freq_rel_std_dev = freq_std_dev / freq_avg * 100
                    integral_rel_std_dev = integral_std_dev / integral_avg * 100

                    time = REAL(signal_end - 1) * 16. / (40.E6)
                    cycles = time * input_freq

                    ! Write data to output files
!                    WRITE (101,200) input_freq, signal_end, time, cycles, avg, std_dev, rel_std_dev, freq_avg, freq_std_dev, freq_rel_std_dev, &
!                                    & integral_avg, integral_std_dev, integral_rel_std_dev
!                    200 FORMAT  (T2, F8.1, T14, I6, T25, F11.9, T37, F10.3, T48, F20.5, T69, F20.5, T95, F9.6, T113, F11.4, T128, F11.4, T151, F9.6, &
!                                    & TR2, F20.0, TR2, F20.0, TR15, F9.6)
                    WRITE (101,200) input_freq, signal_end, time, cycles, avg, std_dev, rel_std_dev, freq_avg, freq_std_dev, freq_rel_std_dev, harm2_rel_mag
                    200 FORMAT  (T2, F8.1, T14, I6, T25, F11.9, T37, F10.3, T48, F20.5, T69, F20.5, T95, F9.6, T113, F11.4, T128, F11.4, T151, F9.6, T170, F9.6)

                    WRITE (102,400) signal_end
                    400 FORMAT  (I6)

                    WRITE (102,600) (peak_mag(k), k=1,(number_of_files*expt_num))
                    600 FORMAT (T10, F20.5)

                END DO

                DEALLOCATE(peak_mag, frequency, integral)

            END DO
        END DO

        DEALLOCATE (y_input_array)

        ! Close all output files and keep them (i.e., don't delete them)
        CLOSE (101, STATUS = "KEEP")
        CLOSE (102, STATUS = "KEEP")

    ! Actions to take for observing FFT magnitude uncertainty with noiseless test signal
    ELSE IF (calibration_channel == 3) THEN

        ! User defined frequency of test signal
        PRINT *, "Enter desired frequency of test signal..."
        READ *, input_freq
        WRITE (97,*) "Enter desired frequency of test signal..."
        WRITE (97,*) input_freq

        ! User chosen frequency shift of test signal
        PRINT *, "By what percent would you like the frequency to shift?"
        PRINT *, "(0 = no frequency shift, 5 = 5%, etc.)"
        READ *, freq_shift
        WRITE (97,*) "By what percent would you like the frequency to shift?"
        WRITE (97,*) "(0 = no frequency shift, 5 = 5%, etc.)"
        WRITE (97,*) freq_shift

!        ! Option for looking at a selected number of cycles
!        PRINT *, "Enter starting number of cycles value..."
!        READ *, cycle_start
!        WRITE (97,*) "Enter starting number of cycles value..."
!        WRITE (97,*) cycle_start
!
!        PRINT *, "Enter ending number of cycles value (total must be ~5 cycles)..."
!        READ *, cycle_end
!        WRITE (97,*) "Enter ending number of cycles value (total must be ~5 cycles)..."
!        WRITE (97,*) cycle_end

        ! User defined ion charge
        PRINT *, "Enter desired input charge (in electrons) for test signal..."
        READ *, electrons
        WRITE (97,*) "Enter desired input charge (in electrons) for test signal..."
        WRITE (97,*) electrons

        ! User defined signal length
        PRINT *, "Enter length of test signal..."
        PRINT *, " 2500 =  1 ms"
        PRINT *, " 5000 =  2 ms"
        PRINT *, "20000 =  8 ms"
        PRINT *, "40000 = 16 ms"
        PRINT *, "72500 = 29 ms"
        READ *, signal_end
        WRITE (97,*) "Enter length of test signal..."
        WRITE (97,*) " 2500 =  1 ms"
        WRITE (97,*) " 5000 =  2 ms"
        WRITE (97,*) "20000 =  8 ms"
        WRITE (97,*) "40000 = 16 ms"
        WRITE (97,*) "72500 = 29 ms"
        WRITE (97,*) signal_end

        CLOSE (UNIT=97, STATUS='KEEP')

        ! Open output files
        unit = 301
        filename = "test_signal_array.txt"
        CALL open_new_file (unit, filename)

        unit = 302
        filename = "test_signal_peak_data.txt"
        CALL open_new_file (unit, filename)

        unit = 303
        filename = "test_signal_peak_mag.txt"
        CALL open_new_file (unit, filename)

        ! Headers for output files
        WRITE (302,3101) "Freq", "Data_Pts", "Seconds", "Cycles", "Magnitude", "Std_Dev", "Rel_Std_Dev", "Freq_Avg", "Freq_Std_Dev", "Freq_Rel_Std_Dev", &
                         & "Integral_Avg", "Integral_Std_Dev", "Integral_Rel_Std_Dev"
        3101 FORMAT  (T5, A5, T13, A9, T27, A8, T40, A7, T56, A10, T80, A8, T93, A11, T115, A8, T128, A12, T145, A16, TR10, A12, TR10, A16, TR5, A20)

        ! Variable names and values obtained from Origin for creating test signal
        ! Test signal approximates a real signal and follows a Boltzmann distribution
        ! Details of test signal and fitting function obtained from Simion and Origin, respectively
        A1 = -3.35668061258415E-4
        A2 = 0.994194949645035
        x0 = -0.505420267974969
        dx = 0.040649051968342

        square_total_real = 40.E6 / (input_freq * 16.)
        old_square_total_real = square_total_real
        mult = INT((2500*length_multiplier) / square_total_real)
        remainder = 0
        array_pointer = 0

        ! Create test signal based on an 18.4% duty cycle (based off of Simion simulations)
        ! Also must take into account the offset of each cycle based on limited time resolution
        ! (i.e., not every frequency will have an integer number of datapoints per cycle due to a finite time
        ! resolution in data collection)
        ! This offset changes the center of the Boltzmann distribution slightly so that not every cycle looks exactly the same
        DO  i = 1, mult-1
            DO  j = 1, INT(square_total_real)
                array_pointer = array_pointer + 1
                x = -1.715265866 + ((j-1) * 3.430531732 / square_total_real) - (remainder / square_total_real * 100 * (3.430531732 / square_total_real))
                IF (x <= 0)    THEN
                    sq_wave_array (array_pointer) = (A2 + (A1-A2)/(1 + EXP((x-x0)/dx))) * NINT(2.31 * electrons)
                ELSE IF (x > 0) THEN
                    sq_wave_array (array_pointer) = (A2 + (A1-A2)/(1 + EXP((-x-x0)/dx))) * NINT(2.31 * electrons)
                END IF
            END DO

            ! Non-integer portion of each cycle length is added onto frequency shift to create a steadily changing frequency
            remainder = square_total_real - INT(square_total_real)
            square_total_real = (old_square_total_real * (1 + ((freq_shift/100)*i/((mult-1)*signal_end/((2500*length_multiplier)))))) + remainder

        END DO

        ! The rest of the array is filled with zeroes
        DO  i = (mult * INT(square_total_real)), 1048576
            sq_wave_array (i) = 0
            sq_wave (i) = 0
        END DO

        unit = 1
        n_main = 1

        CALL RANDOM_SEED()
        CALL RANDOM_NUMBER(rnd)

            ! 100 files are averaged with a random starting position within the cycle
            DO  j = 1, 100
                start = NINT(rnd(j) * old_square_total_real)
                DO  k = 1, (2500*length_multiplier)
                    sq_wave (k) = sq_wave_array (start + k)
                END DO

                CALL calibration_fft(sq_wave, signal_end, n_main, window_function, input_freq, unit, peak_magnitude, freq_value, integral_value, number_of_files, length_multiplier, harm2_rel_mag)

                ! Assign mag, freq, and integral values to new array
                peaks(j) = peak_magnitude
                freq(j) = freq_value
                peak_int(j) = integral_value
            END DO

        ! Sum all peak magnitude values at a given frequency
        ! Sum all frequency values at a given signal length
        ! Sum all integral values at a given signal length
        avg_sum = 0
        freq_avg_sum = 0
        integral_avg_sum = 0
            DO  j = 1, 100
                avg_sum = avg_sum + peaks(j)
                freq_avg_sum = freq_avg_sum + freq(j)
                integral_avg_sum = integral_avg_sum + peak_int(j)
            END DO

        ! Find the average magnitude of a given frequency
        ! Find the average frequency at a given signal length
        ! Find the average integral at a given signal length
        avg = avg_sum/100
        freq_avg = freq_avg_sum/100
        integral_avg = integral_avg_sum/100

        ! Sum of the square of the difference betweeen each value and the average
        diff_squared = 0
        freq_diff_squared = 0
        integral_diff_squared = 0
            DO  j = 1, 100
                diff_squared = diff_squared + ((peaks(j) - avg)**2)
                freq_diff_squared = freq_diff_squared + ((freq(j) - freq_avg)**2)
                integral_diff_squared = integral_diff_squared + ((peak_int(j) - integral_avg)**2)
            END DO

        ! Standard deviation of magnitude average
        ! Standard deviation of frequency average
        ! Standard deviation of integral average
        std_dev = SQRT(diff_squared/99)
        freq_std_dev = SQRT(freq_diff_squared/99)
        integral_std_dev = SQRT(integral_diff_squared/99)

        ! Relative standard deviation of magnitude average
        ! Relative standard deviation of frequency average
        ! Relative standard deviation of integral average
        rel_std_dev = std_dev / avg * 100
        freq_rel_std_dev = freq_std_dev / freq_avg * 100
        integral_rel_std_dev = integral_std_dev / integral_avg * 100

        time = REAL(signal_end - 1) * 16. / (40.E6)
        cycles = time * input_freq

        ! Write data to output files
        WRITE (302,3200) input_freq, signal_end, time, cycles, avg, std_dev, rel_std_dev, freq_avg, freq_std_dev, freq_rel_std_dev, &
                        & integral_avg, integral_std_dev, integral_rel_std_dev
        3200 FORMAT  (T2, F8.1, T14, I6, T25, F11.9, T37, F10.3, T48, F20.5, T69, F20.5, T95, F9.6, T113, F11.4, T128, F11.4, T151, F9.6, &
                        & TR2, F20.0, TR2, F20.0, TR15, F9.6)

        WRITE (303,3600) signal_end, cycles, peak_magnitude
        3600 FORMAT (I6, T6, F8.4, T20, F20.5)

        WRITE (301,3000) sq_wave
        3000 FORMAT (F15.5)

        ! Close all output files and keep them (i.e., don't delete them)
        CLOSE (301, STATUS = "KEEP")
        CLOSE (302, STATUS = "KEEP")
        CLOSE (303, STATUS = "KEEP")

    ! Actions to take for calibrating to a test signal overlaid with noise
    ELSE IF (calibration_channel == 4) THEN

        ! User defined input frequency
        PRINT *, "Enter desired frequency of test signal..."
        READ *, input_freq
        WRITE (97,*) "Enter desired frequency of test signal..."
        WRITE (97,*) input_freq

!        ! Option for looking at a selected number of cycles
!        PRINT *, "Enter starting number of cycles value..."
!        READ *, cycle_start
!        WRITE (97,*) "Enter starting number of cycles value..."
!        WRITE (97,*) cycle_start
!
!        PRINT *, "Enter ending number of cycles value (total must be ~5 cycles)..."
!        READ *, cycle_end
!        WRITE (97,*) "Enter ending number of cycles value (total must be ~5 cycles)..."
!        WRITE (97,*) cycle_end

        ! User defined ion charge
        PRINT *, "Enter desired input charge (in electrons) for test signal..."
        READ *, electrons
        WRITE (97,*) "Enter desired input charge (in electrons) for test signal..."
        WRITE (97,*) electrons

        PRINT *, "Are noise files from channel A or channel B?"
        PRINT *, "Enter 1 for A..."
        PRINT *, "Enter 2 for B..."
        READ *, noise_channel
        WRITE (97,*) "Are noise files from channel A or channel B?"
        WRITE (97,*) "Enter 1 for A..."
        WRITE (97,*) "Enter 2 for B..."
        WRITE (97,*) noise_channel

        ! User selected option for number of files in each run
        ! Maximum number of files is only limited by how the code is currently written
        ! Can be increased by adding extra code to associated "DO" loop below
        PRINT *, "Enter number of files..."
        READ *, number_of_files
        WRITE (97,*) "Enter number of files..."
        WRITE (97,*) number_of_files

        CLOSE (UNIT=97, STATUS='KEEP')

        ! Open output files
        unit = 301
        filename = "mag_freq_integral_values.txt"
        CALL open_new_file (unit, filename)

        unit = 302
        filename = "test_signal_peak_data.txt"
        CALL open_new_file (unit, filename)

        unit = 303
        filename = "test_signal_peak_mag.txt"
        CALL open_new_file (unit, filename)

        unit = 304
        filename = "freq_data_all_lengths.txt"
        CALL open_new_file (unit, filename)

        ! Headers for output files
        WRITE (302,5101) "Freq", "Data_Pts", "Seconds", "Cycles", "Magnitude", "Std_Dev", "Rel_Std_Dev", "Freq_Avg", "Freq_Std_Dev", "Freq_Rel_Std_Dev", &
                         & "Integral_Avg", "Integral_Std_Dev", "Integral_Rel_Std_Dev"
        5101 FORMAT  (T5, A5, T13, A9, T27, A8, T40, A7, T56, A10, T80, A8, T93, A11, T115, A8, T128, A12, T145, A16, TR10, A12, TR10, A16, TR5, A20)

        ! Variable names and values obtained from Origin for creating test signal
        ! Test signal approximates a real signal and follows a Boltzmann distribution
        ! Details of test signal and fitting function obtained from Simion and Origin, respectively
        A1 = -3.35668061258415E-4
        A2 = 0.994194949645035
        x0 = -0.505420267974969
        dx = 0.040649051968342

        square_total_real = 40.E6 / (input_freq * 16.)
        old_square_total_real = square_total_real
        mult = INT((2500*length_multiplier) / square_total_real)
        remainder = 0
        array_pointer = 0

        ! Create test signal based on an 18.4% duty cycle (based off of Simion simulations)
        ! Also must take into account the offset of each cycle based on limited time resolution
        ! (i.e., not every frequency will have an integer number of datapoints per cycle due to a finite time
        ! resolution in data collection)
        ! This offset changes the center of the Boltzmann distribution slightly so that not every cycle looks exactly the same
        DO  i = 1, mult-1
            DO  j = 1, INT(square_total_real)
                array_pointer = array_pointer + 1
                x = -1.715265866 + ((j-1) * 3.430531732 / square_total_real) - (remainder / square_total_real * 100 * (3.430531732 / square_total_real))
                IF (x <= 0)    THEN
                    sq_wave_array (array_pointer) = (A2 + (A1-A2)/(1 + EXP((x-x0)/dx))) * NINT(2.31 * electrons)
                ELSE IF (x > 0) THEN
                    sq_wave_array (array_pointer) = (A2 + (A1-A2)/(1 + EXP((-x-x0)/dx))) * NINT(2.31 * electrons)
                END IF
            END DO

            ! Non-integer portion of each cycle length is added onto frequency shift to create a steadily changing frequency
            remainder = square_total_real - INT(square_total_real)
            square_total_real = (old_square_total_real * (1 + ((freq_shift/100)*i/((mult-1)*signal_end/((2500*length_multiplier)))))) + remainder

        END DO

        ! The rest of the array is filled with zeroes
        DO  i = (mult * INT(square_total_real)), 1048576
            sq_wave_array (i) = 0
        END DO

        ! Performs calibration for both filtered and non-filtered
        DO  y = 1, 2

            IF  (y == 1)    THEN
                filter_option = 1
            ELSE
                filter_option = 2
            END IF

            ! Performs calibration for both Gaussian windowed data and non-windowed data
            DO  n = 1, 2

                ! Writes type of window in output file
                IF  (y == 1 .AND. n == 1)    THEN
                    window_function = 1
                    WRITE (101,201) "Gaussian_Window_Data_Filtered"
                    WRITE (102,201) "Gaussian_Window_Data_Filtered"
                ELSE IF (y == 1 .AND. n == 2)   THEN
                    window_function = 4
                    WRITE (101,201) "Non-Windowed_Data_Filtered"
                    WRITE (102,201) "Non-Windowed_Data_Filtered"
                ELSE IF (y == 2 .AND. n == 1)   THEN
                    window_function = 1
                    WRITE (101,201) "Gaussian_Window_Data_No_Filter"
                    WRITE (102,201) "Gaussian_Window_Data_No_Filter"
                ELSE IF (y == 2 .AND. n == 2)   THEN
                    window_function = 4
                    WRITE (101,201) "Non-Windowed_Data_No_Filter"
                    WRITE (102,201) "Non-Windowed_Data_No_Filter"
                END IF

                ! Allocate size of arrays based on number of calibration files (13 sections per file)
                ALLOCATE(peak_mag(1:(number_of_files*(expt_num-1))), frequency(1:(number_of_files*(expt_num-1))), integral(1:(number_of_files*(expt_num-1))))

!                number_of_files = 10

                ! Looks at different lengths of signals
                ! Takes FFT at given length of many files and finds avg FFT magnitude
                DO  i = 1, INT(2500. * REAL(length_multiplier) / 2000.)
                    signal_end = ((i-1) * 2000) + 2500

                    PRINT *, signal_end

                    ! This DO loop assigns name of datafile to open
                    ! This streamlines data acquisition and analysis
                    DO  j = 0, (number_of_files - 1)

                        fmt = '(I5.5)'
                        unit = j + 10000

                        IF  (data_type == 1)    THEN

                            IF  (noise_channel == 1)  THEN
                                WRITE (file_number, fmt) j+10000
                                filename = 'chA'//TRIM(file_number)//'.dat'
                            ELSE IF (noise_channel == 2)  THEN
                                WRITE (file_number, fmt) j+10000
                                filename = 'chB'//TRIM(file_number)//'.dat'
                            END IF

                            PRINT *, "Now reading from ", filename
                            OPEN (UNIT=unit, FILE=filename, STATUS="old", ACTION="read", IOSTAT=stat, FORM="binary")

                            input_array = 0
                            y_input = 0

                            ! Read input file into array "y_input"
                            READ (unit, END=81) input_array            ! Read filename values and store in array "y"
                            81   CONTINUE

                            DO  k = 1, 1000000
                                y_input(k) = input_array(k)
                            END DO

                        ELSE IF (data_type == 2)   THEN

                            IF  (noise_channel == 1)  THEN
                                WRITE (file_number, fmt) j+10000
                                filename = 'chA'//TRIM(file_number)//'.txt'
                            ELSE IF (noise_channel == 2)  THEN
                                WRITE (file_number, fmt) j+10000
                                filename = 'chB'//TRIM(file_number)//'.txt'
                            END IF

                            PRINT *, "Now reading from ", filename
                            OPEN (UNIT=unit, FILE=filename, STATUS="old", ACTION="read", IOSTAT=stat)

                            y_input = 0

                            ! Read input file into array "y_input"
                            READ (unit, *, END=91) y_input            ! Read filename values and store in array "y"
                            91   CONTINUE

                        END IF

                        CLOSE (unit)

                        adj_input = 0

                        DO  k = 1, 1000000
                            IF  (MOD(k,2) == 1) THEN
                                adj_input(k) = y_input(k+1)
                            ELSE IF (MOD(k,2) == 0) THEN
                                adj_input(k) = y_input(k-1)
                            END IF
                        END DO

                        y_input = adj_input

                        ! Calculate the derivative of y_input
                        DO  k = 1, 1048576
                            IF  (k == 1)    THEN
                                derivative (k) = (y_input(k+1) - y_input(k))/((k+1)-k)
                            ELSE IF (j == 1048576)  THEN
                                derivative (k) = (y_input(k) - y_input(k-1))/(k-(k-1))
                            ELSE
                                derivative (k) = 0.5 * (((y_input(k+1) - y_input(k))/((k+1)-k)) + ((y_input(k) - y_input(k-1))/(k-(k-1))))
                            END IF
                        END DO

                        der_opt = 0
                        22  CONTINUE
                        k = 1

                        IF  (der_opt == 0)  THEN
                            DO WHILE    (derivative(k) > -5000) ! Looks for negative going derivative from end pulse @ 29 ms
                                k = k + 1
                                derivative_peak = k + (2500 * load_time)  ! Adding 2500 datapoints brings us to the beginning of the start pulse

                                IF  (k == (2500 * (length_multiplier + 1)))  THEN
                                    der_opt = 1
                                    GOTO 22
                                END IF
                            END DO

                        ELSE IF (der_opt == 1)  THEN

                            DO WHILE    (derivative(k) < 5000) ! Looks for positive going derivative from start pulse @ 29
                                k = k + 1
                                derivative_peak = k

                                IF  (k == (2500 * (length_multiplier + 1)))  THEN
                                    PRINT *, "Problem taking derivative..."
                                    PRINT *, "Is the BNC Pulser on?"
                                    GOTO 15
                                END IF
                            END DO
                        END IF

                        DO  k = 0, (1048576 - derivative_peak - 1)
                            y_input(k+1) = y_input(derivative_peak + k)
                        END DO

                        DO  k = (1048576 - derivative_peak), 1048576
                            y_input(k) = 0
                        END DO

                        ! Apply a filter in accordance with user-defined input
                        IF  (filter_option == 1)    THEN
                            CALL fft_filter(y_input, fft_filter_output)
                            y_input = fft_filter_output
                        END IF

                        WRITE (301,6998) i
                        WRITE (301,6999) j
                        6998 FORMAT (I6)
                        6999 FORMAT (I2)

                            ! Finds FFT magnitude for each section at given length
                            ! Each test signal has a random starting position within the cycle
                            DO  m = 1, (expt_num - 1)
                                n_main = m
                                CALL RANDOM_SEED()
                                CALL RANDOM_NUMBER(rand)
                                start = NINT(rand * old_square_total_real)

                                    DO  k = 1, (2500 * (length_multiplier - load_time))
                                        y_input(k + ((m-1)*(2500*length_multiplier))) = y_input(k + ((m-1)*(2500*length_multiplier))) + sq_wave_array (start + k)
                                    END DO

                                CALL calibration_fft(y_input, signal_end, n_main, window_function, input_freq, j, peak_magnitude, freq_value, integral_value, number_of_files, length_multiplier, harm2_rel_mag)

                                ! Assign mag, freq & integral values to new array
                                peak_mag(m + ((j-1)*(expt_num - 1))) = peak_magnitude
                                frequency(m + ((j-1)*(expt_num - 1))) = freq_value
                                integral(m + ((j-1)*(expt_num - 1))) = integral_value

                                ! Write data to output file
                                WRITE (301,7000) peak_mag(m + ((j-1)*(expt_num - 1))), frequency(m + ((j-1)*(expt_num - 1))), integral(m + ((j-1)*(expt_num - 1)))
                                7000 FORMAT (T5, F15.2, T30, F9.2, T45, F9.2, TR5, F20.0)

                            END DO

                        15 CONTINUE

                    END DO

                    ! Sum all peak magnitude values at a given frequency
                    ! Sum all frequency values at a given signal length
                    avg_sum = 0
                    freq_avg_sum = 0
                    integral_avg_sum = 0
                        DO  j = 1, (number_of_files*(expt_num - 1))
                            avg_sum = avg_sum + peak_mag(j)
                            freq_avg_sum = freq_avg_sum + frequency(j)
                            integral_avg_sum = integral_avg_sum + integral(j)

                            WRITE (304,7001) frequency(j)
                            7001 FORMAT (F9.2)
                        END DO

                    ! Find the average magnitude of a given frequency
                    ! Find the average frequency at a given signal length
                    avg = avg_sum/(number_of_files*(expt_num - 1))
                    freq_avg = freq_avg_sum/(number_of_files*(expt_num - 1))
                    integral_avg = integral_avg_sum/(number_of_files*(expt_num - 1))

                    ! Sum of the square of the difference betweeen each value and the average
                    diff_squared = 0
                    freq_diff_squared = 0
                    integral_diff_squared = 0
                        DO  j = 1, (number_of_files*(expt_num - 1))
                            diff_squared = diff_squared + ((peak_mag(j) - avg)**2)
                            freq_diff_squared = freq_diff_squared + ((frequency(j) - freq_avg)**2)
                            integral_diff_squared = integral_diff_squared + ((integral(j) - integral_avg)**2)
                        END DO

                    ! Standard deviation of magnitude average
                    ! Standard deviation of frequency average
                    std_dev = SQRT(diff_squared/((number_of_files*(expt_num - 1))-1))
                    freq_std_dev = SQRT(freq_diff_squared/((number_of_files*(expt_num - 1))-1))
                    integral_std_dev = SQRT(integral_diff_squared/((number_of_files*(expt_num - 1))-1))

                    ! Relative standard deviation of magnitude average
                    ! Relative standard deviation of frequency average
                    rel_std_dev = std_dev / avg * 100
                    freq_rel_std_dev = freq_std_dev / freq_avg * 100
                    integral_rel_std_dev = integral_std_dev / integral_avg * 100

                    time = REAL(signal_end - 1) * 16. / (40.E6)
                    cycles = time * input_freq

                    ! Write data to output files
                    WRITE (302,6200) input_freq, signal_end, time, cycles, avg, std_dev, rel_std_dev, freq_avg, freq_std_dev, freq_rel_std_dev, &
                                    & integral_avg, integral_std_dev, integral_rel_std_dev
                    6200 FORMAT  (T2, F8.1, T15, I5, T25, F11.9, T37, F10.3, T48, F20.5, T69, F20.5, T95, F9.6, T113, F11.4, T128, F11.4, T151, F9.6, &
                                    & TR2, F20.0, TR2, F20.0, TR15, F9.6)

                    WRITE (303,6600) signal_end, cycles
                    6600 FORMAT (I6, T6, F8.4)

                    WRITE (303,6800) (peak_mag(j), j=1,(number_of_files*(expt_num - 1)))
                    6800 FORMAT (T20, F20.5)

                END DO

                DEALLOCATE(peak_mag, frequency, integral)

            END DO
        END DO

        ! Close all output files and keep them (i.e., don't delete them)
        CLOSE (301, STATUS = "KEEP")
        CLOSE (302, STATUS = "KEEP")
        CLOSE (303, STATUS = "KEEP")
        CLOSE (304, STATUS = "KEEP")

    ! Calibration of input charge to ADC bits
    ELSE IF (calibration_channel == 5) THEN

        ! Select frequency of calbration signal
        PRINT *, "Enter frequency of input calibration signal (in kHz)..."
        READ *, input_freq
        WRITE (97,*) "Enter frequency of input calibration signal (in kHz)..."
        WRITE (97,*) input_freq
        input_freq = input_freq * 1000

        ! Select channel for files
        PRINT *, ""
        PRINT *, "Are files from channel A or channel B?"
        PRINT *, "Enter 1 for A..."
        PRINT *, "Enter 2 for B..."
        READ *, file_channel
        WRITE (97,*) ""
        WRITE (97,*) "Are files from channel A or channel B?"
        WRITE (97,*) "Enter 1 for A..."
        WRITE (97,*) "Enter 2 for B..."
        WRITE (97,*) file_channel

        ! User selected option for number of files in each run
        ! Maximum number of files is only limited by how the code is currently written
        ! Can be increased by adding extra code to associated "DO" loop below
        PRINT *, "Enter number of files..."
        READ *, number_of_files
        WRITE (97,*) "Enter number of files..."
        WRITE (97,*) number_of_files

        CLOSE (UNIT=97, STATUS='KEEP')

        number_of_cycles = INT(1.E6 * input_freq * 16. / 40.E6)     ! = input_freq Hz * 0.4 s

        ALLOCATE(max_val_array(1:((number_of_cycles-1200)*number_of_files)), min_val_array(1:((number_of_cycles-1200)*number_of_files)))

        ! This DO loop assigns name of datafile to open
        ! This streamlines data acquisition and analysis
        DO  j = 0, (number_of_files - 1)

            fmt = '(I5.5)'
            unit = j + 10000

            IF  (data_type == 1)    THEN

                IF  (file_channel == 1)  THEN
                    WRITE (file_number, fmt) j+10002
                    filename = 'chA'//TRIM(file_number)//'.dat'
                ELSE IF (file_channel == 2)  THEN
                    WRITE (file_number, fmt) j+10002
                    filename = 'chB'//TRIM(file_number)//'.dat'
                END IF

                PRINT *, "Now reading from ", filename
                OPEN (UNIT=unit, FILE=filename, STATUS="old", ACTION="read", IOSTAT=stat, FORM="binary")

                input_array = 0
                y_input = 0

                ! Read input file into array "y_input"
                READ (unit, END=84) input_array            ! Read filename values and store in array "y"
                84   CONTINUE

                DO  k = 1, 1000000
                    y_input(k) = input_array(k)
                END DO

            ELSE IF (data_type == 2)   THEN

                IF  (file_channel == 1)  THEN
                    WRITE (file_number, fmt) j+10002
                    filename = 'chA'//TRIM(file_number)//'.txt'
                ELSE IF (file_channel == 2)  THEN
                    WRITE (file_number, fmt) j+10002
                    filename = 'chB'//TRIM(file_number)//'.txt'
                END IF

                PRINT *, "Now reading from ", filename
                OPEN (UNIT=unit, FILE=filename, STATUS="old", ACTION="read", IOSTAT=stat)

                y_input = 0

                ! Read input file into array "y_input"
                READ (unit, *, END=94) y_input            ! Read filename values and store in array "y"
                94   CONTINUE

            END IF

            CLOSE (unit)

            adj_input = 0

            DO  k = 1, 1000000
                IF  (MOD(k,2) == 1) THEN
                    adj_input(k) = y_input(k+1)
                ELSE IF (MOD(k,2) == 0) THEN
                    adj_input(k) = y_input(k-1)
                END IF
            END DO

            y_input = adj_input

            CALL band_pass_fft_filter(y_input, input_freq, fft_filter_output)

            i = 0
            square_total_real = (40.E6 / (16. * input_freq))
            old_square_total_real = square_total_real

            DO WHILE (i < (number_of_cycles-1200))

                i = i + 1
                cycle_length = INT(square_total_real)

                ALLOCATE(cycle_array(1:cycle_length))

                DO  k = 1, cycle_length
                    cycle_array(k) = fft_filter_output((cycle_length*(i-1)) + k)
                END DO

                max_val_array(i + (j*(number_of_cycles-1200))) = MAXVAL(cycle_array, DIM=1)
                min_val_array(i + (j*(number_of_cycles-1200))) = MINVAL(cycle_array, DIM=1)

                remainder = square_total_real - INT(square_total_real)
                square_total_real = old_square_total_real + remainder

!                IF  (remainder == 0) THEN
!                    square_total_real = old_square_total_real
!                END IF

                DEALLOCATE(cycle_array)

            END DO

        END DO

        sum_max = 0
        sum_min = 0
        DO  k = 1, ((number_of_cycles-1200)*number_of_files)
            sum_max = sum_max + max_val_array(k)
            sum_min = sum_min + min_val_array(k)
        END DO

        max_avg = sum_max / ((number_of_cycles-1200)*number_of_files)
        min_avg = sum_min / ((number_of_cycles-1200)*number_of_files)

        ! Sum of the square of the difference betweeen each value and the average
        max_diff_squared = 0
        min_diff_squared = 0
        DO  k = 1, ((number_of_cycles-1200)*number_of_files)
            max_diff_squared = max_diff_squared + ((max_val_array(k) - max_avg)**2)
            min_diff_squared = min_diff_squared + ((min_val_array(k) - min_avg)**2)
        END DO

        ! Standard deviation of max average
        ! Standard deviation of max average
        max_std_dev = SQRT(max_diff_squared/(((number_of_cycles-1200)*number_of_files)-1))
        min_std_dev = SQRT(min_diff_squared/(((number_of_cycles-1200)*number_of_files)-1))

        amplitude = max_avg - min_avg
        amp_error = SQRT((max_std_dev)**2 + (min_std_dev)**2)

        PRINT *, "Frequency: ", input_freq
        PRINT *, "Amplitude: ", amplitude
        PRINT *, "Error:     ", amp_error

        DEALLOCATE(max_val_array, min_val_array)

    END IF

    END SUBROUTINE trap_charge_calibration

    ! Subroutine for FFT of calibration data
    SUBROUTINE calibration_fft (data_in, signal_end, n_fft, window_fn, freq_input, file_number, peak_magnitudes, freq_values, integral_values, number_of_files, len_mult, harm2_rel_mag)

    USE mkl_dfti

    IMPLICIT NONE

    REAL, PARAMETER :: freq_res = 40.E6 / 2**24

    TYPE (DFTI_DESCRIPTOR), POINTER :: My_Desc1_Handle
    INTEGER :: Status                                   ! Sets DFT Parameters
    INTEGER :: istat                                    ! Allocate status
    INTEGER :: i, j
    INTEGER :: maxfind_start = 0                        ! Pointer for local maximum
    INTEGER :: temp_signal_end                          ! Temporary pointer for end of signal
    INTEGER :: win_fn                                   ! Indicator for application of apodization function (1 = Gaussian, 2 = none)
    INTEGER :: file_number                              ! Pointer for input file number
    INTEGER :: number_of_files                          ! Number of files to analyze (max = 100)
    INTEGER :: peak_start = 0                           ! Pointer for peak start
    INTEGER :: peak_end = 0                             ! Pointer for peak end
    INTEGER :: len_mult                                 ! Multiplier for length of each trapping event (multiple of 1 ms or 2,500 datapoints)

    INTEGER, INTENT(IN) :: n_fft                            ! Pointer for file section
    INTEGER, INTENT(IN) :: signal_end                       ! Length of signal on which to perform DFT
    INTEGER, INTENT(IN) :: window_fn                        ! User supplied input for applying a window function or not
    REAL(4) :: freq_input                                   ! Frequency of input calibration signal
    REAL(4) :: sigma_fft                                    ! Sigma value for Gaussian window function
!    REAL(4) :: alpha_fft                                    ! Alpha value for Hann-Poisson window function
    REAL(4) :: start                                        ! Dummy variable for beginning of peak
    REAL(4) :: start_less_one                               ! Dummy variable for beginning of peak minus one
    REAL(4) :: last                                         ! Dummy variable for end of peak
    REAL(4) :: last_plus_one                                ! Dummy variable for end of peak plus one
    REAL(4) :: peak_magnitudes                              ! Peak magnitudes
    REAL(4) :: freq_values                                  ! Frequency values of max peak magnitudes
    REAL(4) :: integral_values                               ! Integral value returned from subroutine "calibration_fft"

    REAL(4), PARAMETER :: pi = 3.14159265
    REAL(4), DIMENSION (1:1048576), INTENT(IN) :: data_in   ! Raw input values

    REAL(4), DIMENSION (1:1048576) :: sig_in            ! Input array
!    REAL(4), DIMENSION (1:180) :: peak_magnitudes       ! Array for peak magnitudes
!    REAL(4), DIMENSION (1:180) :: freq_values           ! Array for frequency values of max peak magnitudes
    REAL(4), DIMENSION (1:501) :: maxfind_array         ! Array to find max fft magnitude

!    ! Parameters for FFT of length 1048576
!    ! ===================================
    INTEGER, PARAMETER :: npts = 1048576                    ! Number of datapoints
    REAL(4), DIMENSION (1:524288) :: freq               ! Frequency x-value after FFT
    REAL(4), DIMENSION (1:524288) :: fft_mag                ! DFT magnitude values
    REAL(4), DIMENSION (1:1048576) :: fft_input             ! Input values after applying rolling average filter
    REAL(4), DIMENSION (1:1048576) :: fft_output            ! DFT output values
!    REAL(4), DIMENSION (1:524288) :: phase                 ! DFT phase values

    ! Extra variables needed for "Harmonic Analysis"
    INTEGER :: channel                  ! Pointer for channel to analyze (A, B, or test signal)
    INTEGER :: freq_mult                ! Multiplier for length of FFT (base is 2^16)
    INTEGER :: t                        ! Flag used in user-selected options for channels 3 and 5
    REAL(4) :: fund_mag_win_1           ! No use here; needs declared so "Harmonic_Analysis" will work
    REAL(4), DIMENSION(1:10) :: harm_freq
                                        ! Frequency of first 10 harmonics
    REAL(4), DIMENSION(1:10) :: harm_mag
                                        ! Magnitude of first 10 harmonics
    REAL(4) :: harm2_rel_mag

    DO  i = (1 + ((n_fft-1)*(2500*len_mult))), (((n_fft-1)*(2500*len_mult)) + signal_end)
        fft_input(i - ((n_fft-1)*(2500*len_mult))) = data_in(i)
    END DO

    !   Make sure everything after signal of interest is zero
    DO  i = (signal_end + 1), 1048576
        fft_input(i) = 0
    END DO

    IF  (window_fn == 1) THEN
        !   Gaussian Window
        sigma_fft = 0.45
        DO  i = 0, (signal_end - 1)
            fft_input(i+1) = ( EXP( -0.5 * ((  (i - ((REAL(signal_end-1))/2)) / (sigma_fft * ((REAL(signal_end-1))/2))  )**2)   )  ) * fft_input(i+1)
        END DO
    ELSE IF (window_fn == 2) THEN
        !   Hann Window
        DO  i = 0, (signal_end - 1)
            IF  (i == 0)   THEN
                fft_input(i+1) = ( 0.5 + (0.5 * cos ((2*pi*i)/REAL(signal_end-1))) ) * fft_input(i+1)
            ELSE
                fft_input(i+1) = ( 0.5 - (0.5 * cos ((2*pi*i)/REAL(signal_end-1))) ) * fft_input(i+1)
            END IF
        END DO
    ELSE IF (window_fn == 3) THEN
        !   Hamming Window
        DO  i = 0, (signal_end - 1)
            IF  (i == 0)   THEN
                fft_input(i+1) = ( 0.54 + (0.46 * cos ((2*pi*i)/REAL(signal_end-1))) ) * fft_input(i+1)
            ELSE
                fft_input(i+1) = ( 0.54 - (0.46 * cos ((2*pi*i)/REAL(signal_end-1))) ) * fft_input(i+1)
            END IF
        END DO
    END IF

!    !   Hann-Poisson Window
!    alpha_fft = 3
!    DO  i = 0, (signal_end - 1)
!        IF  (i == 0)   THEN
!            fft_input(i+1) = (( 0.5 + (0.5 * cos ((2*pi*i)/(REAL(signal_end-1)/2))) )) * ( exp(-alpha_fft * (i/(REAL(signal_end-1)/2))) ) * fft_input(i+1)
!        ELSE
!            fft_input(i+1) = ( 0.5 - (0.5 * cos ((2*pi*i)/(REAL(signal_end-1)/2))) ) * ( exp(-alpha_fft * (i/(REAL(signal_end-1)/2))) ) * fft_input(i+1)
!        END IF
!    END DO

    Status = DftiCreateDescriptor(My_Desc1_Handle, DFTI_SINGLE, DFTI_REAL, 1, npts)
    Status = DftiSetValue(My_Desc1_Handle, DFTI_PLACEMENT, DFTI_NOT_INPLACE)
    Status = DftiSetValue(My_Desc1_Handle, DFTI_NUMBER_OF_USER_THREADS, 1)
    Status = DftiSetValue(My_Desc1_Handle, DFTI_FORWARD_SCALE, 1.0)
    Status = DftiCommitDescriptor(My_Desc1_Handle)
    Status = DftiComputeForward(My_Desc1_Handle, fft_input, fft_output)
    Status = DftiFreeDescriptor(My_Desc1_Handle)

    ! Calculate magnitude of DFT from real and imaginary parts
    ! Real parts of DFT are in odd rows [(2*i)-1], Imaginary parts are in even rows (2*i) {for i = 1, npts}
    ! Real parts of DFT are in even rows [(2*i)-1], Imaginary parts are in odd rows (2*i) {for i = 0, (npts-1)}
    DO  i = 1, 524288
        fft_mag(i) = sqrt( ((fft_output ((2*i)-1))**2) + ((fft_output (2*i))**2) )
!        phase (i) = atan( (fft_output (2*i)) / (fft_output ((2*i)-1)) )    ! arctan (imag/real)
    END DO

    ! Use "Harmonic_Analysis" to determine fundamental frequency and to sum intensities of first two harmonics
    fund_mag_win_1 = 0.; channel = 9; t = 0; freq_mult = 16
    CALL Harmonic_Analysis(channel, freq_mult, fft_mag, freq_input, fund_mag_win_1, signal_end, harm_freq, harm_mag, t)

    peak_magnitudes = SUM(harm_mag(1:2))
    freq_values = harm_freq(1)
    harm2_rel_mag = harm_mag(2)/harm_mag(1)

!    DO  i = 1, 524288
!        freq (i) = (i-1) * 40.E6 / 2**24
!    END DO
!
!    ! Starting point to look for frequency is 251 points before expected peak value
!    maxfind_start = NINT(freq_input/(40.E6 / 2**24)) - 251
!
!!    PRINT *, maxfind_start
!
!        ! Make array of all fft_magnitude values from peak_start to peak_end
!        ! MAXLOC(maxfind_array, DIM=1) +  maxfind_start equals the datapoint of peak max
!        ! Therefore freq(MAXLOC(maxfind_array, DIM=1) +  maxfind_start) equals freq of max magnitude
!        ! And fft_magnitude(MAXLOC(maxfind_array, DIM=1) +  maxfind_start) equals max fft magnitude
!        DO  i = 1, 501
!            maxfind_array(i) = fft_mag(maxfind_start + i)
!        END DO
!
!!    PRINT *, MAXLOC(maxfind_array, DIM=1)
!
!    ! Write peak magnitude and frequency values to array
!    peak_magnitudes = fft_mag(MAXLOC(maxfind_array, DIM=1) + maxfind_start)
!    freq_values = freq(MAXLOC(maxfind_array, DIM=1) + maxfind_start)
!
!!    peak_magnitudes( ((file_number-1)*18) + n_fft) = fft_mag(MAXLOC(maxfind_array, DIM=1) + maxfind_start)
!!    freq_values( ((file_number-1)*18) + n_fft) = freq(MAXLOC(maxfind_array, DIM=1) + maxfind_start)
!
!
!    ! Find beginning and end of range to integrate for windowed data
!    peak_start = MAXLOC(maxfind_array, DIM=1) + maxfind_start - 1
!    start = fft_mag(peak_start)
!    start_less_one = fft_mag(peak_start - 1)
!
!    ! Find start of peak
!    DO WHILE    (start >= start_less_one)
!                peak_start = peak_start - 1
!                start = fft_mag(peak_start)
!                start_less_one = fft_mag(peak_start - 1)
!    END DO
!
!    peak_start = peak_start + 1
!
!
!    peak_end = MAXLOC(maxfind_array, DIM=1) + maxfind_start + 1
!    last = fft_mag(peak_end)
!    last_plus_one = fft_mag(peak_end + 1)
!
!    ! Find end of peak
!    DO WHILE    (last >= last_plus_one)
!                last = fft_mag(peak_end)
!                last_plus_one = fft_mag(peak_end + 1)
!                peak_end = peak_end + 1
!    END DO
!
!
!    ! Integrate peak from peak_start to peak_end
!    integral_values = 0
!    DO  j = peak_start, peak_end
!        integral_values = integral_values + (fft_mag(j) * 40.E6 / 2**24)
!    END DO

    END SUBROUTINE calibration_fft


MODULE subs_raytracing

	use constantes
	use environ
	implicit none

	contains

subroutine varplasma(V,f,X,Y)
	!------------------------------------
	! Calculate the variables X and Y from the Appleton-Hartree
	! equation [Haselgrove (1963)]
	! CALLING SEQUENCE: call varplasma(V,f)
	! INPUTS : V: position vector in cartesian coordinates.
	!          f: frequency (Hz)
	! OUTPUTS: X: (fp/f)^2
	!          Y: fc/f
	!------------------------------------
	real(kind=8), dimension(:,:), intent(in)  :: V
	real(kind=8), intent(in)                  :: f
	real(kind=8), dimension(:), intent(out)   :: X
	real(kind=8), dimension(:,:), intent(out) :: Y
	real(kind=8), dimension(3,size(x))        :: B
	real(kind=8), dimension(size(X))          :: Ne, fp

	call density(V,Ne)
	fp = 1.d0/(2.d0*pi)*sqrt(e**2*Ne/(eps0*me))*1.d3 !Hz
	X = (fp/f)**2

	call magneticf(V,B)
	Y = e*B/(me*2.d0*pi*f)
end subroutine varplasma

subroutine index(X,Y,k,mode,mu)
	!------------------------------------
	! Calculation of the mu refractive index in a magnetised
	! plasma according to the Appleton-Hartree equation
	! [Haselgrove, 1960]
	! CALLING SEQUENCE: call index(X,Y,th,mu)
	! INPUTS: X: (fp/f)^2
	!         Y: fc/f
	!        th: (k,B) angle
	! OUTPUTS: mu
	!------------------------------------
	real(kind=8), dimension(:), intent(in)     	 :: X
	real(kind=8), dimension(:,:), intent(in)   	 :: Y,k
	character(len=1), intent(in), dimension(:) 	 :: mode
	real(kind=8), dimension(:), intent(out)    	 :: mu
	real(kind=8), dimension(size(mu))          	 :: normY,normk,vdotk,A,B,C,B2mAC
	real(kind=8), dimension(size(mu))		   	 :: nmode

	where (mode .eq. 'X')
		nmode =-1.d0
	else where
		nmode = 1.d0
	end where

	normY = sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)
	normk = sqrt(k(1,:)**2+k(2,:)**2+k(3,:)**2)
	where (normY .eq.0.d0)
		vdotk(:) = maxval(k(:,:))
	elsewhere
		vdotk(:) = (Y(1,:)*k(1,:)+Y(2,:)*k(2,:)+Y(3,:)*k(3,:))/normY(:)
	end where

	A = 1.d0-X-normY**2*(1.d0-X*vdotk**2/normk**2)
	B = 0.5d0*(-2.d0*(1.d0-X)*(1.d0-X-normY**2)+X*normY**2*(1.d0-vdotk**2/normk**2))
	C = (1.d0-X)*((1.d0-X)**2-normY**2)

	B2mAC = B**2-A*C

	! When magnetic field -> 0 then B2mAC -> 0 => NUMERICAL EFFECTS => when abs(B2mAC) < 1.d-15 => B2mAC=0
	where (abs(B2mAC) < 1.d-15)
		B2mAC = 0.d0
	end where

	mu = sqrt((-B+nmode*sqrt(B2mAC))/A)

	!write(*,*) B2mAC, -B+sqrt(B2mAC), mu

end subroutine index

subroutine calcp(X,Y,k,mode,p)
	!------------------------------------
	! Compute p solution of a*p^2+2b*p+c*=0
	! [Haselgrove (1963)]
	! CALLING SEQUENCE: call calcp(X,Y,k,p)
	! INPUTS: X: (fp/f)^2
	!         Y: fc/f
	!         k: wave vector in cartesian coordinates.
	! OUTPUTS: p [Haselgrove,63]
	!------------------------------------
	real(kind=8), dimension(:,:), intent(in)   :: Y,k
	real(kind=8), dimension(:), intent(in)     :: X
	character(len=1), intent(in), dimension(:) :: mode
	real(kind=8), dimension(:), intent(out)    :: p
	real(kind=8), dimension(size(p))           :: normY, vdotk,alpha,beta,gamma,nmode

	!------------------------------------------
	!mode O +/- mode X
	!p = (-beta +/- sqrt(beta**2-alpha*gamma))/alpha

	where (mode .eq. 'X')
		nmode =-1.d0
	else where
		nmode = 1.d0
	end where

	normY = sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)

	!si B=0 (Y=0) alors direction de Y = verticale
	where (normY .eq. 0.d0)
		vdotk(:) = maxval(k(:,:))
	elsewhere
		vdotk(:) = (Y(1,:)*k(1,:)+Y(2,:)*k(2,:)+Y(3,:)*k(3,:))/normY(:)
	end where

	!determination de p: pY=(q+1) et q=(n^2-1)/X
	alpha = 1.d0-X-normY**2
	beta = normY*(1.+(vdotk)**2)/2.
	gamma = -(vdotk)**2

	p = (-beta+nmode*sqrt(beta**2-alpha*gamma))/alpha
	!p = gamma/(-beta -nmode*sqrt(beta**2-alpha*gamma))

end subroutine calcp

subroutine varpartiel(X,Y,k,mode,A,B,C,D)
	!------------------------------------
	! calcul les variables J*,K*,L* et M*
	! d'Haselgrove (1963) decrivant les d_partielles
	! CALLING SEQUENCE: call varpartiel(X,Y,k,A,B,C,D)
	! INPUTS: X: (fp/f)^2
	!         Y: fc/f
	!         k: wave vector in cartesian coordinates.
	! OUTPUTS: A == J* [Haselgrove,63]
	!          B == K* [Haselgrove,63]
	!          C == L* [Haselgrove,63]
	!          D == M* [Haselgrove,63]
	!------------------------------------
	real(kind=8), dimension(:,:), intent(in)  :: Y,k
	real(kind=8), dimension(:), intent(in)    :: X
	character(len=1), intent(in),dimension(:) :: mode
	real(kind=8), dimension(:), intent(out)   :: A,B,C,D
	real(kind=8),dimension(size(X))           :: normY, vdotk,p,nmode

	normY = sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)

	where (mode .eq. 'X')
		nmode =-1.d0
	else where
		nmode = 1.d0
	end where
	!if B=0 (Y=0) then Y direction = vertical (vdotk not null)
	where (normY .eq. 0.d0)
		vdotk(:) = maxval(k(:,:))
	elsewhere
		vdotk(:) = (Y(1,:)*k(1,:)+Y(2,:)*k(2,:)+Y(3,:)*k(3,:))/normY(:)
	end where

	call calcp(X,Y,k,mode,p)

	A = nmode*4.d0*sqrt((normY*(1.d0+(vdotk)**2)/2.)**2-(1.d0-X-normY**2)*(-(vdotk)**2))
	B = -2.d0*X*vdotk*(p*normY-1.d0)
	C = (normY*(1.d0-normY**2)*p**2-2.d0*(1.-X-normY**2)*p-normY)
	D = 2.d0*X*p*(p*normY-1.d0)

	!write(*,*) '-----------------------------------------'
	!write(*,*)'X', X
	!write(*,*)'Y_x', Y(1,:)
	!write(*,*)'Y_y', Y(2,:)
	!write(*,*)'Y_z', Y(3,:)
	!write(*,*)'normY', normY
	!write(*,*) 'k', k
	!write(*,*) 'vdotk', vdotk
	!write(*,*) '-----------------------------------------'
	!write(*,*) 'p', p
	!write(*,*) '-----------------------------------------'
	!write(*,*) 'J',A
	!write(*,*) 'K',B
	!write(*,*) 'L',C
	!write(*,*) 'M',D

end subroutine varpartiel

subroutine dxdt(V,k,f,mode,dx_dt,nray)
	!------------------------------------
	! Compute dxidt = J*ki-K*Yi [Haselgrove (1960)]
	! CALLING SEQUENCE: call dxdt(V,k,f,dx_dt)
	! INPUTS : V: position vector in cartesian coordinates.
	!          k: wave vector in cartesian coordinates.
	!          f: frequency (Hz)
	! OUTPUTS: dx_dt : 3*Nray dimension array
	!------------------------------------
	integer, intent(in)                          :: nray
	real(kind=8), dimension(3,nray), intent(in)  :: V,k
	real(kind=8), intent(in)                     :: f
	character(len=1), intent(in), dimension(nray):: mode
	real(kind=8), dimension(3,nray), intent(out) :: dx_dt
	real(kind=8), dimension(3,nray)              :: Y
	real(kind=8), dimension(nray)                :: X, A,B,C,D
	integer	                                     :: i

	call varplasma(V,f,X,Y)
	call varpartiel(X,Y,k,mode,A,B,C,D)

	forall (i=1:3) dx_dt(i,:)=A(:)*k(i,:)-B(:)*Y(i,:)
	!write(*,*) '---------------------------'
	!write(*,*) 'dxdt_x', dx_dt(1,:)
	!write(*,*) 'dxdt_y', dx_dt(2,:)
	!write(*,*) 'dxdt_z', dx_dt(3,:)

end subroutine dxdt

subroutine dkdt(V,k,f,mode,dk_dt,nray)
	!------------------------------------
	! Compute dkidt = L*dX/dxi+sumj((K*kj+M*Yj)*dYj/dxi)
	! [Haselgrove (1960)]
	! CALLING SEQUENCE: call dkdt(V,k,f,dk_dt)
	! INPUTS : V: position vector in cartesian coordinates.
	!          k: wave vector in cartesian coordinates.
	!          f: frequency (Hz)
	! OUTPUTS: dk_dt: 3*Nray dimension array
	!------------------------------------
	integer, intent(in)							 :: nray
	real(kind=8), dimension(3,nray), intent(in)  :: V,k
	real(kind=8), intent(in)                     :: f
	character(len=1), intent(in),dimension(nray)    :: mode
	real(kind=8), dimension(3,nray), intent(out) :: dk_dt
	real(kind=8), dimension(3, nray)             :: Vav, Vap, Yav,Yap,Y,dYdx
	real(kind=8), dimension(nray)                :: h, Xav, Xap,A,B,C,D,X,dXdx
	integer                                      :: i,j

	call varplasma(V,f,X,Y)
	call varpartiel(X,Y,k,mode,A,B,C,D)

	h = 1.d-6
	do i = 1,3
		Vav = V
		Vav(i,:) = Vav(i,:)-h
		call varplasma(Vav,f,Xav,Yav)
		Vap = V
		Vap(i,:) = Vap(i,:)+h
		call varplasma(Vap,f,Xap,Yap)
		dXdx = (Xap-Xav)/(2.d0*h)
		forall (j=1:3) dYdx(j,:) = (Yap(j,:)-Yav(j,:))/(2.d0*h)
		dk_dt(i,:) = C*dXdx+((B*k(1,:)+D*Y(1,:))*dYdx(1,:)+(B*k(2,:)+D*Y(2,:))*dYdx(2,:)+(B*k(3,:)+D*Y(3,:))*dYdx(3,:))
	end do

	!write(*,*) '---------------------------'
	!write(*,*) 'dudt_x', dk_dt(1,:)
	!write(*,*) 'dudt_y', dk_dt(2,:)
	!write(*,*) 'dudt_z', dk_dt(3,:)
end subroutine dkdt

subroutine error(k,X,Y,mode,err)
	!---------------------------------
	! compute the error k^2-1-X*(pY-1)
	! [Haselgrove (1960)]
	! CALLING SEQUENCE: call error(k,X,Y, err)
	! INPUTS : V: position vector in cartesian coordinates.
	!          k: wave vector in cartesian coordinates.
	!          f: frequency en Hz
	! OUTPUTS: err: scalar = 0
	!------------------------------------
	real(kind=8), dimension(:,:), intent(in)  :: Y,k
	real(kind=8), dimension(:), intent(in)    :: X
	character(len=1), intent(in),dimension(:) :: mode
	real(kind=8), dimension(:), intent(out)   :: err
	real(kind=8), dimension(size(X))          :: p, normk2,normY

	normk2=k(1,:)**2+k(2,:)**2+k(3,:)**2
	normY = sqrt(Y(1,:)**2+Y(2,:)**2+Y(3,:)**2)
	call calcp(X,Y,k,mode,p)

	err = abs((normk2-1.d0-X*(p*normY-1.d0))/(X*(p*normY-1.d0)))

end subroutine error

END MODULE subs_raytracing


!##############################################################################
!# ****************************************************************************
!# <name> anisotropicdiffusion </name>
!# ****************************************************************************
!#
!# <purpose>
!# This program is a simple test program for discretising the equation
!#
!#              - div (A grad(u) = f
!#
!# on a 2D domain for a scalar function u and a matrix
!#
!#   A = ( a11 a12 )
!#       ( a21 a22 )
!#
!# a11,...,a22 are configured with a .dat file. The matrix may be
!# rotated according to
!#
!#   A~ =  ( cos(t) -sin(t) )  ( a11 a12 )  (  cos(t) sin(t) )
!#         ( sin(t)  cos(t) )  ( a21 a22 )  ( -sin(t) cos(t) )
!#
!# The example (module anisotropicdiffusion_method1) discretises and
!# solves this equation in a direct way, just listing all commands necessary
!# for initialisation, discretisation, solving and cleanup.
!##############################################################################

program anisotropicdiffusion

  use anisotropicdiffusion_method1
  use anisotropicdiffusion_method2

  implicit none

  ! local variables
  character(len=SYS_STRLEN) :: slogdir,slogfile

  ! The very first thing in every application:
  ! Initialise system-wide settings:

  call sys_init()

  ! Initialise the output system.
  !
  ! Normally, we write all the output to the screen and to a file
  ! './log/output.txt'.
  ! In the case that environment variables "$logdir"/"$resultsfile" exists,
  ! we write all the output to that file. This can be used e.g. in
  ! regression tests to compare results to reference results.
  if (sys_getenv_string('LOGDIR',slogdir) .and. &
      sys_getenv_string('RESULTFILE',slogfile)) then
    call output_init (trim(slogdir)//'/'//trim(slogfile))
  else
    call output_init ('./log/output.txt')
  end if

  ! The very second thing in every program:
  ! Initialise the FEAT 2.0 storage management:
  call storage_init(999, 100)

  ! Call the problem to solve.
  call output_lbrk ()
  call output_line ('Calculating anisotropic diffusion problem with method 1')
  call output_line ('-------------------------------------------------------')
  call anisotropicdiffusion1

  ! Call the problem to solve.
  call output_lbrk ()
  call output_line ('Calculating anisotropic diffusion problem with method 2')
  call output_line ('-------------------------------------------------------')
  call anisotropicdiffusion2

  ! Print out heap statistics - just to check if everything
  ! is cleaned up.
  ! This should display 'Handles in use=0' and 'Memory in use=0'!
  call output_lbrk ()
  call storage_info(.true.)

  ! Clean up the storage management, finish
  call output_done()
  call storage_done()

end program


subroutine mbmabt(a,b,c,n1,n2,n3)

!-----------------------------------------------------------------------
!
! This routine evaluates the matrix product A = B Ct, where
! A -> Mat(n1,n2), B -> Mat(n1,n3), C -> Mat(n2,n3)
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip) :: n1,n2,n3,i,j,k
  real(rp)    :: a(n1,n2), b(n1,n3), c(n2,n3)

  do i=1,n1
     do j=1,n2
        a(i,j)=0.0_rp
        do k=1,n3
           a(i,j)=a(i,j)+b(i,k)*c(j,k)
        end do
     end do
  end do

end subroutine mbmabt