!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
module M_testsuite_M_color
use M_color, only : rgbmono, hue, closest_color_name, color_name2rgb
use M_verify, only : unit_check, unit_check_good, unit_check_bad, unit_check_done, unit_check_start
contains
subroutine test_suite_m_color
call test_hue()                 ! converts a color's components from one color model to another
call test_closest_color_name()  ! given RGB values, try to find closest named color
call test_color_name2rgb()      ! given a color name, return rgb color values in range 0 to 100
call test_rgbmono()             ! convert RGB colors to a reasonable grayscale
contains
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_rgbmono()
real :: gray
integer :: ierr
call unit_check_start('rgbmono')
   call rgbmono(100.0,  0.0,  0.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.30, msg='red     ')
   call rgbmono(  0.0,100.0,  0.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.59, msg='green   ')
   call rgbmono(  0.0,  0.0,100.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.11, msg='blue    ')
   call rgbmono(100.0,100.0,  0.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.89, msg='Yellow  ')
   call rgbmono(  0.0,100.0,100.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.70, msg='Cyan    ')
   call rgbmono(100.0,  0.0,100.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.41, msg='Magenta ')
   call rgbmono(100.0,100.0,100.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.100,msg='White   ')
   call rgbmono( 00.0,  0.0,  0.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.0,  msg='Black   ')
   call rgbmono( 50.0,  0.0,  0.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.15, msg='Maroon  ')
   call rgbmono(100.0, 50.0, 50.0,gray,ierr); call unit_check('rgbmono',int(gray+0.5).eq.65, msg='Pink    ')
call unit_check_done('rgbmono')
end subroutine test_rgbmono
end subroutine test_suite_m_color
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_hue()
use M_verify, only : unit_check, unit_check_good, unit_check_bad, unit_check_done, unit_check_start
use M_verify, only : unit_check_level
implicit none
real              :: c, m, y
real              :: r, g, b
real              ::    i, q
integer           :: status
call unit_check_start('hue')
   call hue('cmy',100.0,  0.0,  0.0,'rgb',r,g,b,status)
   call unit_check('hue',all([r.eq.  0.0,g.eq.100.0,b.eq.100.0 ]),'cyan cmy 100 0 0 to rgb',r,g,b)

   call hue('cmy',  0.0,100.0,  0.0,'rgb',r,g,b,status)
   call unit_check('hue',all([r.eq.100.0,g.eq.  0.0,b.eq.100.0 ]),'magenta cmy to rgb')

   call hue('cmy',  0.0,  0.0,100.0,'rgb',r,g,b,status)
   call unit_check('hue',all([r.eq.100.0,g.eq.100.0,b.eq.  0.0 ]),'yellow cmy to rgb')

   call hue('rgb',100.0,  0.0,100.0,'cmy',c,m,y,status)
   call unit_check('hue',all([c.eq.  0.0,m.eq.100.0,y.eq.  0.0 ]),'magenta rgb to cmy')

   call hue('rgb',  0.0,100.0,100.0,'cmy',c,m,y,status)
   call unit_check('hue',all([c.eq.100.0,m.eq.  0.0,y.eq.  0.0 ]),'cyan rgb to cmy')

   call hue('rgb',100.0,100.0,  0.0,'cmy',c,m,y,status)
   call unit_check('hue',all([c.eq.  0.0,m.eq.  0.0,y.eq.100.0 ]),'yellow rgb to cmy')

   call hue('rgb',100.0,  0.0,  100.0,'yiq',y,i,q,status)
   call unit_check('hue',all(abs([y-41.2999992,i-27.43087,q-52.2599983]).lt.0.10),'rgb to yiq',y,i,q,'for green')

   call hue('rgb',  0.0,100.0,  0.0,'yiq',y,i,q,status)
   call unit_check('hue',all(abs([ y-58.70147,i-(-27.43087),q-(-52.29881) ]).lt.0.10),'rgb to yiq',y,i,q,'for magenta')

   call hue('yiq',41.29853,27.43087,52.29881 ,'rgb',r,g,b,status)
   call unit_check('hue',all(abs([r-100.0,  g-0.0,b-100.0]).lt.0.01),msg='yiq to rgb for green')

   call hue('yiq',58.70147,-27.43087,-52.29881,'rgb',r,g,b,status)
   call unit_check('hue',all(abs([r-0.0,g-100.0, b-0.0]).lt.0.01),msg='yiq to rgb for magenta')

   !                      NAME        RGB(0-255)            HLS(0-100)
   call check_name('hls', 'red',      [ 100,  0,    0   ], [ 0,    50,   100 ])
   call check_name('hls', 'orange',   [ 100,  65,   0   ], [ 39,   50,   100 ])
   call check_name('hls', 'yellow',   [ 100,  100,  0   ], [ 60,   50,   100 ])
   call check_name('hls', 'green',    [ 0,    100,  0   ], [ 120,  50,   100 ])
   call check_name('hls', 'cyan',     [ 0,    100,  100 ], [ 180,  50,   100 ])
   call check_name('hls', 'blue',     [ 0,    0,    100 ], [ 240,  50,   100 ])
   call check_name('hls', 'magenta',  [ 100,  0,    100 ], [ 300,  50,   100 ])
   call check_name('hls', 'black',    [ 0,    0,    0   ], [ 0,    0,    0   ])
   call check_name('hls', 'white',    [ 100,  100,  100 ], [ 0,    100,  0   ])
   call check_name('hsv', 'black',    [ 0,    0,    0   ], [ 0,    0,    0   ])
   !                      NAME        RGB(0-255)            HSV(0-100)
   call check_name('hsv', 'gray50',   [ 50,   50,   50  ], [ 0,    0,    50  ])
   call check_name('hsv', 'silver',   [ 75,   75,   75  ], [ 0,    0,    75  ])
   call check_name('hsv', 'white',    [ 100,  100,  100 ], [ 0,    0,    100 ])
   call check_name('hsv', 'red4',     [ 55,   0,    0   ], [ 0,    100,  55  ])
   call check_name('hsv', 'red',      [ 100,  0,    0   ], [ 0,    100,  100 ])
   call check_name('hsv', 'olive',    [ 50,   50,   0   ], [ 60,   100,  50  ])
   call check_name('hsv', 'yellow',   [ 100,  100,  0   ], [ 60,   100,  100 ])
   call check_name('hsv', 'green',    [ 0,    100,  0   ], [ 120,  100,  100 ])
   call check_name('hsv', 'lime',     [ 0,    100,  0   ], [ 120,  100,  100 ])
   call check_name('hsv', 'teal',     [ 0,    50,   50  ], [ 180,  100,  50  ])
   call check_name('hsv', 'cyan',     [ 0,    100,  100 ], [ 180,  100,  100 ])
   call check_name('hsv', 'navy',     [ 0,    0,    50  ], [ 240,  100,  50  ])
   call check_name('hsv', 'blue',     [ 0,    0,    100 ], [ 240,  100,  100 ])
   call check_name('hsv', 'purple',   [ 63,   13,   94  ], [ 277,  87,   94  ])
   call check_name('hsv', 'magenta4', [ 55,   0,    55  ], [ 300,  100,  55  ])
   call check_name('hsv', 'magenta',  [ 100,  0,    100 ], [ 300,  100,  100 ])
   call check_name('hsv', 'maroon',   [ 69,   19,   38  ], [ 338,  73,   69  ])

call unit_check_done('hue')

contains
subroutine check_name(modelout,name,rgb,other)
implicit none

! given a color convert to MODELOUT and compare to expected values

character(len=*),intent(in)   :: name
integer,intent(in)            :: rgb(3), other(3)
character(len=*),intent(in)   :: modelout
   real                       :: r,g,b
   real                       :: val1,val2,val3
   integer                    :: status

   r=real(rgb(1))
   g=real(rgb(2))
   b=real(rgb(3))
   ! convert RGB values to MODELOUT values
   call hue('rgb',r,g,b,modelout,val1,val2,val3,status)
   if(unit_check_level.gt.0)then
      write(*,*)'EXPECTED '//modelout//' ====>',other
      write(*,*)'RETURNED '//modelout//' ====>',int([val1+0.5,val2+0.5,val3+0.5])
      write(*,*)'STATUS ==========>',status
   endif
   call unit_check('hue', status.eq.0.and.all(abs(int([val1+0.5,val2+0.5,val3+0.5])-other).lt.2 ),'convert from rgb to '//modelout)

end subroutine check_name
!===================================================================================================================================
end subroutine test_hue
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_closest_color_name()
use M_verify, only : unit_check, unit_check_good, unit_check_bad, unit_check_done, unit_check_start
implicit none
call unit_check_start('closest_color_name')
   !                NAME       RGB(0-255)
   call check_name('black',    [ 0,    0,    0   ])
   call check_name('blue',     [ 0,    0,    100 ])
   call check_name('cyan',     [ 0,    100,  100 ])
   call check_name('gray50',   [ 50,   50,   50  ])
   call check_name('green',    [ 0,    100,  0   ])
   call check_name('magenta',  [ 100,  0,    100 ])
   call check_name('magenta4', [ 55,   0,    55  ])
   call check_name('maroon',   [ 69,   19,   38  ])
   call check_name('navy',     [ 0,    0,    50  ])
   call check_name('olive',    [ 50,   50,   0   ])
   call check_name('orange',   [ 100,  65,   0   ])
   call check_name('purple',   [ 63,   13,   94  ])
   call check_name('red',      [ 100,  0,    0   ])
   call check_name('red4',     [ 55,   0,    0   ])
   call check_name('silver',   [ 75,   75,   75  ])
   call check_name('teal',     [ 0,    50,   50  ])
   call check_name('white',    [ 100,  100,  100 ])
   call check_name('yellow',   [ 100,  100,  0   ])
   call check_name('lime',     [ 0,    100,  0   ])

call unit_check_done('closest_color_name')

contains
subroutine check_name(name,rgb)
! given a colorname look up RGB values, compare to expected values, check
implicit none
character(len=*)   :: name
integer,intent(in) :: rgb(3)
real               :: r, g, b
real               :: r2,g2,b2
character(len=20)  :: echoname
character(len=20)  :: closestname

   r=real(rgb(1))
   g=real(rgb(2))
   b=real(rgb(3))

   ! see if get expected name
   call closest_color_name(r,g,b,closestname)
   if(closestname.eq.name)then
      call unit_check('closest_color_name',closestname.eq.name,msg='names match for '//name)
   else
   ! did not get back name put in; but maybe alternate alias
      ! if values the same assume OK
      call color_name2rgb(name,r2,g2,b2,echoname)
      call unit_check('closest_color_name',     &
      & rgb(1) .eq. int(r2+0.5) .and. &
      & rgb(2) .eq. int(g2+0.5) .and. &
      & rgb(3) .eq. int(b2+0.5)  ,msg='close enough for NAME: '//trim(name)//' CLOSESTNAME: '//trim(closestname) )
   endif
end subroutine check_name
!===================================================================================================================================
end subroutine test_closest_color_name
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_color_name2rgb()
use M_verify, only : unit_check, unit_check_good, unit_check_bad, unit_check_done, unit_check_start
implicit none
call unit_check_start('color_name2rgb')
   !                NAME       RGB(0-255)
   call check_name('black',    [ 0,    0,    0   ])
   call check_name('blue',     [ 0,    0,    100 ])
   call check_name('cyan',     [ 0,    100,  100 ])
   call check_name('gray50',   [ 50,   50,   50  ])
   call check_name('green',    [ 0,    100,  0   ])
   call check_name('magenta',  [ 100,  0,    100 ])
   call check_name('magenta4', [ 55,   0,    55  ])
   call check_name('maroon',   [ 69,   19,   38  ])
   call check_name('navy',     [ 0,    0,    50  ])
   call check_name('olive',    [ 50,   50,   0   ])
   call check_name('orange',   [ 100,  65,   0   ])
   call check_name('purple',   [ 63,   13,   94  ])
   call check_name('red',      [ 100,  0,    0   ])
   call check_name('red4',     [ 55,   0,    0   ])
   call check_name('silver',   [ 75,   75,   75  ])
   call check_name('teal',     [ 0,    50,   50  ])
   call check_name('white',    [ 100,  100,  100 ])
   call check_name('yellow',   [ 100,  100,  0   ])
   call check_name('lime',     [ 0,    100,  0   ])

call unit_check_done('color_name2rgb')
contains
subroutine check_name(name,rgb)
! given a colorname look up RGB values, compare to expected values, check
implicit none
character(len=*)   :: name
integer,intent(in) :: rgb(3)
real               :: r,g,b
real               :: r1,g1,b1
real               :: r2,g2,b2
character(len=20)  :: echoname
character(len=20)  :: closestname
   call color_name2rgb(name,r,g,b,echoname)                                   ! given a color name look up RGB values in range 0-100
   call unit_check('color_name2rgb',echoname.ne.'Unknown',msg='make sure echoed name does not equal unknown')
   call unit_check('color_name2rgb',all(int([r+0.5,g+0.5,b+0.5]).eq.rgb),msg='check returned RGB values against expected values' )

   call closest_color_name(r,g,b,closestname)                                 ! see if get name back
   if(closestname.eq.name)then
      call unit_check('color_name2rgb',closestname.eq.name,msg='names match for '//name)
   else                                                     ! did not get back name put in; but maybe alternate alias
      ! if values the same assume OK
      call color_name2rgb(closestname,r1,g1,b1,echoname)
      call color_name2rgb(name,r2,g2,b2,echoname)
      call unit_check('color_name2rgb',     &
      & int(r1+0.5) .eq. int(r2+0.5) .and. &
      & int(g1+0.5) .eq. int(g2+0.5) .and. &
      & int(b1+0.5) .eq. int(b2+0.5)  ,msg='close enough for NAME: '//trim(name)//' CLOSESTNAME: '//trim(closestname) )
   endif

end subroutine check_name
!===================================================================================================================================
end subroutine test_color_name2rgb
end module M_testsuite_M_color
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
program runtest
use M_verify, only : unit_check_command, unit_check_keep_going, unit_check_level, unit_check_stop
use M_testsuite_M_color
implicit none
   unit_check_command=''
   unit_check_keep_going=.true.
   unit_check_level=0
   call test_suite_M_color()
   call unit_check_stop()
contains

end program runtest
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================


! 1D Langmuir turbulence simulation according to Guio and Forme 2006
! Last update: 9/5/2013
! For Kappa on: 01/05/2016

! Michael Hirsch Oct 2013 -- updated vbeam,tetabeam to use C++ vector format

program zakharov1d

use, intrinsic:: iso_fortran_env, only: wp=>real64, i64=>int64
use perf, only: sysclock2ms

implicit none

!integer(i64) :: tic, toc

real(wp), parameter :: pi = 4.0_wp * atan(1.0_wp),&
                       me=9.10938356e-31_wp, & ! kg
                       electroncharge=1.60217662e-19_wp, & ! coulombs
                       mi=16*1.66e-27_wp, & ! atomic oxygen
                       Kb=1.38064852e-23_wp, &    ! Boltzmann cte
                       eV=1.602176565e-19_wp, epsilon0=8.854187817e-12_wp

real(wp), parameter :: Te=3000.0_wp, Ti=1000.0_wp, Z=1.0_wp, &
                       nuic=1.0_wp, & ! ion collision freq
                       nuec=100.0_wp, & ! electron collision freq
                       n0=5.0e11_wp ! background density

real(wp), parameter :: vbeam_ev(1) = [500.0_wp]
integer, parameter :: Nvbeam=size(vbeam_ev)
real(wp) :: vbeam(Nvbeam), tetabeam(Nvbeam)

real(wp), parameter :: power_n_cte=7.7735e6_wp / sqrt(53.5_wp),&
                       power_E_cte=0.5033_wp*0.5033_wp / sqrt(3.0_wp)

!    Kappa parameters
! look at Broughton et al., Modeling of MF wave mode conversion
real(wp), parameter :: se_percent=0.001_wp, kappa=1.584_wp, T_se=18.2_wp*eV, &
                       theta_se=sqrt((kappa-1.5_wp)/kappa*2.0_wp*T_se/me), &
                       se_cte= 0.7397_wp / theta_se**3.0_wp

!    Simulation parameters

real(wp) :: endTime !100.0e-3_wp ! simulation ends (seconds)
real(wp), parameter :: Tstep=0.5e-7_wp ! simulation time steps
integer :: TT, TT_res               ! TT=floor(endTime/Tstep)+2
integer, parameter :: res=20
!TT_res=floor(endTime/Tstep/res)

real(wp), parameter :: L=70.0_wp           ! simulation box length (meter)j
integer :: N
real(wp) :: Xstep
integer, parameter :: QW=1     ! number of realizations

integer, allocatable :: SEED(:)
integer :: Nseed, clock

real(wp), parameter :: eta=(Te+3.0_wp*Ti) / Te, &
                       ve=sqrt(Kb*Te/me), &
                       Cs=sqrt(eta*me/mi)*ve, &
                       omegae=sqrt(n0*electroncharge**2.0_wp/me/epsilon0), &
                       lambdaD=ve/omegae

real(wp), allocatable :: beamev(:), nbeam(:)
integer :: Nnbeam

character(:), allocatable :: odir, ofn
character(256) :: argv
integer :: argc,i, ii,iij1, q,tt1,c1,c2,beami, beamj, realization,u,uEE,uNN
real(wp) :: tic1,toc1

!---- main loop variables

real(wp) :: Xsection_ion, Xsection_pl, E_thermal_k_squared, n_thermal_k_squared, &
  gamas,  gamal1, gamal2, gamal3, gamal

type params

  real(wp) :: pi, me,electroncharge,mi, Kb,eV,epsilon0, Z,Te, Ti, nuic, nuec, n0, nbeam, &
            vbeam_ev, vbeam, tetabeam, endTime, Tstep, TT, res, TT_res, L, N, Xstep, QW, &
            eta, ve, Cs, omegae, lambdaD
!  	have to include other parameters regarding the Kappa distribution

end type params

type(params) :: parameters

integer, allocatable :: p(:)

real(wp) :: CC(2), SSn(2), cte1, cte2, kn1(2), kn2(2), kn3(2), kn4(2), kv1(2), kv2(2), kv3(2), kv4(2)

real(wp), allocatable :: Source_factor_E(:), rdist(:), k(:),  Source_factor_n(:), omegaL(:), nui(:), nue(:), output1(:,:), &
EE(:,:,:), nn(:,:,:), vv(:,:,:), SSE(:,:), k1(:,:), k2(:,:), k3(:,:), k4(:,:)

integer :: LL,UU,pp

N = 2046
!! number of samples in L should be divisible by 6

Xstep = L / N

allocate(p(N))
allocate(rdist(N), k(N), Source_factor_n(N), Source_factor_E(N), omegaL(N), nui(N), nue(N), output1(N,12), &
   EE(3,N,2), nn(3,N,2), vv(3,N,2), SSE(N,2), k1(N,2), k2(N,2), k3(N,2), k4(N,2))

!---- argparse
argc = command_argument_count()
if (argc < 3) error stop 'must input:   outputDirectory endTime beamEnergy(s)'

call get_command_argument(1,argv)
odir = trim(argv)
print *,'writing output to', odir
call execute_command_line('mkdir -p '//odir)

call get_command_argument(2,argv)
read(argv,*) endTime
TT = floor(endTime / Tstep)
TT_res = floor(endTime/Tstep/res)

allocate(beamev(argc-2))
do i = 3,argc
   call get_command_argument(i,argv)
    read(argv,*) beamev(i-2)
enddo

Nnbeam = size(beamev)

nbeam = beamev*n0

print *, "Nnbeam=", Nnbeam, "Nvbeam=",Nvbeam, "TT=",TT,"time steps"

call cpu_time(tic1)

! initialization

vbeam=sqrt(eV*vbeam_ev*2/me)
 tetabeam=0.3*vbeam

print *,"vbeam=",vbeam,"tetabeam=",tetabeam

call random_seed(size=nseed)
allocate(seed(nseed))
seed(:) = 600  ! FIXME: arbitrary for simulation repeatability

nbm: do beami=1,Nnbeam
vbm: do beamj=1,Nvbeam

  parameters%pi = pi
  parameters%me = me
  parameters%electroncharge = electroncharge
  parameters%mi = mi
  parameters%Kb = Kb
  parameters%eV = eV
  parameters%epsilon0= epsilon0
  parameters%Z = Z
  parameters%Te = Te
  parameters%Ti = Ti
  parameters%nuic = nuic
  parameters%nuec= nuec
  parameters%n0 = n0
  parameters%nbeam = nbeam(beami)
  parameters%vbeam_ev = vbeam_ev(beamj)
  parameters%vbeam = vbeam(beamj)
  parameters%tetabeam = tetabeam(beamj)
  parameters%endTime = endTime
  parameters%Tstep = Tstep
  parameters%TT = TT
  parameters%res = res
  parameters%TT_res = TT_res
  parameters%L = L
  parameters%N = N
  parameters%Xstep = Xstep
  parameters%QW = QW
  parameters%eta = eta
  parameters%ve = ve
  parameters%Cs = Cs
  parameters%omegae = omegae
  parameters%lambdaD = lambdaD

  write(argv,'(A,I0.3,A,I0.3,A)')  odir//"/parameters_n" , beami, "_v" , beamj,'.bin'
  ofn = trim(argv)

  open(newunit=u, file=ofn, status='replace',action='write', access='stream')
  write(u) parameters, real(SEED,wp)
  close(u)
  print *, "Wrote parameters to ",ofn

  do ii=1,N
    p(ii)=ii-N/2

    if (ii==N/2) then
      k(ii) = 0
      Xsection_ion=0.0_wp
      Xsection_pl=0.0_wp
      n_thermal_k_squared=0.0_wp
      E_thermal_k_squared=0.0_wp
    else
      k(ii)=2*pi*p(ii)/N/Xstep
      call Xsection(Xsection_ion,Xsection_pl,k(ii))
      Xsection_ion=Xsection_ion/N**2
      Xsection_pl=Xsection_pl/N**2
      n_thermal_k_squared=Xsection_ion*n0
      E_thermal_k_squared=Xsection_pl *n0* (electroncharge/epsilon0/k(ii))**2.0_wp
    end if

    omegaL(ii)=sqrt(omegae**2.0_wp + 3.0_wp*(k(ii)*ve)**2.0_wp)
    gamas= -1.0_wp*sqrt(pi/8)*(sqrt(me/mi) + (Te/Ti)**2.0_wp / sqrt(Te/Ti) * &
            exp(-1.0_wp*(Te/2.0_wp/Ti)-1.5_wp))*abs(k(ii))*Cs
		!gamas= -1.0_wp*sqrt(pi/2)*(sqrt(me/mi) + 4*(Te/2/Ti)**2 / sqrt(Te/2/Ti) * &
!            exp(-1.0_wp*(Te*4/Ti)))*abs(k(ii))*Cs*10   ! based on Robinson 2002
		!gamas= -1.0_wp*sqrt(pi/8)*(1/(1+k(ii)*k(ii)*lambdaD*lambdaD)+3*Ti/Te)**2 / &
!              sqrt(1/(1+k(ii)*k(ii)*lambdaD*lambdaD)+3*Ti/Te)*(sqrt(me/mi)+(Te/Ti)**2 / &
!               sqrt(Te/Ti)*exp(-1.0_wp*(Te/2.0_wp/Ti)/(1+k(ii)*k(ii)*lambdaD*lambdaD)-1.5_wp)) * &
!               abs(k(ii))*Cs   ! Based on some Chinese paper!!
    nui(ii)=(nuic/2-gamas)

    if (ii==N/2) then
      gamal=0.0_wp           ! this one is Nan due to division by zero
      gamal1=0.0_wp
      nue(ii)=nuec/2.0_wp-gamal1
      Source_factor_n(ii)=0.0_wp
      Source_factor_E(ii)=0.0_wp
    else
      gamal1=-1.0_wp*sqrt(pi/8) * (omegae/k(ii)/ve)**2.0_wp * sign(1.0_wp,k(ii)) * omegaL(ii)**2.0_wp / &
              (k(ii)*ve) * exp(-1.0_wp*(omegaL(ii)/k(ii)/ve)**2.0_wp/2)  !Landau damping due to the thermal electrons

      gamal2=-1.0_wp*sqrt(pi/8)* (omegae / k(ii) / tetabeam(beamj))**2.0_wp * sign(1.0_wp,k(ii)) * nbeam(beami) / &
              n0*omegaL(ii)*(omegaL(ii)-k(ii)*vbeam(beamj)) / (k(ii)*tetabeam(beamj)) * &
              exp(-1.0_wp* (omegaL(ii)-k(ii)*vbeam(beamj) / k(ii) / tetabeam(beamj))**2.0_wp/2) !Landau damping due to the beam
      !gamal2=-1.0_wp*sqrt(pi/8)*(omegae/k(ii)/tetabeam(beamj))**2 * sign(1.0_wp,k(ii)) * &
!             nbeam(beami)/n0*omegaL(ii)*(omegaL(ii)-k(ii)*vbeam(beamj))/(k(ii)*tetabeam(beamj))* &
!             exp(-1.0_wp*((omegaL(ii)-k(ii)*vbeam(beamj))/k(ii)/tetabeam(beamj))**2/2)  ! Landau damping due to the beam
      gamal3=-1.0_wp*sqrt(pi)* (omegae*omegaL(ii))**2.0_wp / k(ii)**3.0_wp * sign(1.0_wp,k(ii)) *se_cte * &
              (1.0_wp + omegaL(ii)**2.0_wp/kappa/ (k(ii)*theta_se)**2.0_wp)**(-1.0_wp*(kappa+1))

      gamal=gamal1*(1-se_percent)+gamal2+se_percent*gamal3 ! here decide to include the beam and Kappa distribution
      nue(ii) = nuec/2-gamal1

      Source_factor_n(ii)=2*nui(ii)*sqrt(4*nui(ii)*k(ii)*k(ii)/(4*nui(ii)*nui(ii)+k(ii)*k(ii))* &
                          n_thermal_k_squared*power_n_cte)
      ! source factor is the factor by which we balance the thermal source intensity
      Source_factor_E(ii)=sqrt(2*nue(ii)*E_thermal_k_squared*power_E_cte)
      nue(ii)=nuec/2-gamal
    end if

    output1(ii,1) = p(ii)
    output1(ii,2) = k(ii)
    output1(ii,3) = Xsection_ion
    output1(ii,4) = Xsection_pl
    output1(ii,5) = E_thermal_k_squared
    output1(ii,6) = n_thermal_k_squared
    output1(ii,7) = omegaL(ii)
    output1(ii,8) = gamas
    output1(ii,9) = nui(ii)
    output1(ii,10) = nue(ii)
    output1(ii,11) = Source_factor_E(ii)
    output1(ii,12) = Source_factor_n(ii)
  end do ! ii

  !print *,output1(1,:)

  write(argv,'(A,I0.3,A,I0.3,A)') odir//"/output1_n",beami,"_v", beamj,'.bin'
  open(newunit=u,file=trim(argv),status='replace',action='write',access='stream')

  write(u) output1
  close(u)
  print *, "Wrote to ", trim(argv)

  rlz: do realization=1,QW
    cte2=omegae/2.0_wp/n0

    call system_clock(clock)
!    seed = clock + 37 * [ (i - 1, i = 1, nseed) ]
    call random_seed(put=seed)

    write(argv,'(A,I0.3,I0.3,A,I0.3,A,I0.3,A)') odir//"/EE",seed(1),realization,"_n",beami,"_v",beamj,".bin"
    open(newunit=uEE,file=trim(argv), status='replace',action='write',access='stream')
    print *,'writing to ',trim(argv)

    write(argv,'(A,I0.3,I0.3,A,I0.3,A,I0.3,A)') odir//"/nn",seed(1),realization, "_n" ,beami, "_v",beamj,'.bin'
    open(newunit=uNN,file=trim(argv), status='replace',action='write',access='stream')
    print *,'writing to ',trim(argv)

  !   main loops

    vv(:,:,:)=0.0_wp

    do iij1=1,3
      call random_number(rdist)
      EE (iij1,:,1)=sqrt(output1(:,5)/2.0_wp)*rdist
      call random_number(rdist)
      EE (iij1,:,2)=sqrt(output1(:,5)/2.0_wp)*rdist
      call random_number(rdist)
      nn (iij1,:,1)=sqrt(output1(:,6)/2.0_wp)*rdist
      call random_number(rdist)
      nn (iij1,:,2)=sqrt(output1(:,6)/2.0_wp)*rdist
    end do ! iij1 4

  !  print *,EE(3,3,2)
  !  stop

    nn(:,N-N/2+1:N,1) = nn(:,:N/2,1)
    nn(:,N-N/2+1:N,2) = -nn(:,:N/2,2) ! yes minus
    nn(:,N/2,:)=0.0_wp

    do tt1=1,TT

  !		int c0=(tt1-1) % 3
      c1= modulo(tt1, 3)+1
      c2= modulo(tt1+1, 3)+1
  !		long double omega_off=omegae+2*pi*300000

  		! update display every 50th iteration
      if (modulo(tt1,50) == 0) print '(A,I0.3,F7.2,A,I0.3,A,I0.3)',"Realization: ",&
          realization,tt1*100.0/TT,"% complete.  n",beami," v",beamj

      call calc_k1(N,nn,k1,SSE)

      do pp=1,N
        LL= max(p(pp)-N/3,-N/3)
        UU= min(N/3,p(pp)+N/3)
        CC(:)=0.0_wp

        do q=LL,UU
          CC(1)=CC(1)+(EE(c1,q+N/2,1)+k1(q+N/2,1)/2)*nn(c1,p(pp)-q+N/2,1)-(EE(c1,q+N/2,2)+k1(q+N/2,2)/2)*nn(c1,p(pp)-q+N/2,2)
          CC(2)=CC(2)+(EE(c1,q+N/2,1)+k1(q+N/2,1)/2)*nn(c1,p(pp)-q+N/2,2)+(EE(c1,q+N/2,2)+k1(q+N/2,2)/2)*nn(c1,p(pp)-q+N/2,1)
        end do

        cte1=1.5_wp*omegae*(lambdaD*k(pp))**2.0_wp
  			!cte1=1.5_wp*Kb*Te/me/omega_off*k(pp)*k(pp)-(omega_off**2-omegae**2)/2.0_wp/omega_off
        k2(pp,1)=Tstep*(cte1*(EE(c1,pp,2)+k1(pp,2)/2.0_wp-SSE(pp,1)/2.0_wp*Tstep) - &
                  nuE(pp) * (EE(c1,pp,1)+k1(pp,1)/2.0_wp+SSE(pp,2)/2.0_wp*Tstep)+cte2*CC(2))
        k2(pp,2)=Tstep*(-1.0_wp*cte1*(EE(c1,pp,1)+k1(pp,1)/2.0_wp+SSE(pp,2)/2.0_wp*Tstep) - &
                  nuE(pp)*(EE(c1,pp,2)+k1(pp,2)/2.0_wp-SSE(pp,1)/2.0_wp*Tstep)-cte2*CC(1))

      end do ! pp N

      do pp=1,N
        LL= max(p(pp)-N/3,-N/3)
        UU= min(N/3,p(pp)+N/3)
        CC(:)=0.0_wp

        do q=LL,UU
          CC(1)=CC(1)+(EE(c1,q+N/2,1)+k2(q+N/2,1)/2)*nn(c1,p(pp)-q+N/2,1)-(EE(c1,q+N/2,2)+k2(q+N/2,2)/2)*nn(c1,p(pp)-q+N/2,2)
          CC(2)=CC(2)+(EE(c1,q+N/2,1)+k2(q+N/2,1)/2)*nn(c1,p(pp)-q+N/2,2)+(EE(c1,q+N/2,2)+k2(q+N/2,2)/2)*nn(c1,p(pp)-q+N/2,1)
        end do

        cte1=1.5_wp*omegae*(lambdaD*k(pp))**2.0_wp
  			!cte1=1.5_wp*Kb*Te/me/omega_off*k(pp)*k(pp)-(omega_off**2-omegae**2)/2.0_wp/omega_off
        k3(pp,1)=Tstep*(cte1*(EE(c1,pp,2)+k2(pp,2)/2.0_wp-SSE(pp,1)/2.0_wp*Tstep) - &
                nuE(pp)*(EE(c1,pp,1)+k2(pp,1)/2.0_wp+SSE(pp,2)/2.0_wp*Tstep)+cte2*CC(2))
        k3(pp,2)=Tstep*(-1.0_wp*cte1*(EE(c1,pp,1)+k2(pp,1)/2.0_wp+SSE(pp,2)/2.0_wp*Tstep) - &
                nuE(pp)*(EE(c1,pp,2)+k2(pp,2)/2.0_wp-SSE(pp,1)/2.0_wp*Tstep)-cte2*CC(1))

      end do ! pp N

      do pp=1,N
        LL= max(p(pp)-N/3,-N/3)
        UU= min(N/3,p(pp)+N/3)
        CC(:)=0.0_wp

        do q=LL,UU
          ! no vect
          CC(1)=CC(1)+(EE(c1,q+N/2,1)+k3(q+N/2,1))*nn(c1,p(pp)-q+N/2,1)-(EE(c1,q+N/2,2)+k3(q+N/2,2))*nn(c1,p(pp)-q+N/2,2)
          CC(2)=CC(2)+(EE(c1,q+N/2,1)+k3(q+N/2,1))*nn(c1,p(pp)-q+N/2,2)+(EE(c1,q+N/2,2)+k3(q+N/2,2))*nn(c1,p(pp)-q+N/2,1)
        end do

        cte1=1.5_wp*omegae*(lambdaD*k(pp))**2.0_wp
  			!cte1=1.5_wp*Kb*Te/me/omega_off*k(pp)*k(pp)-(omega_off**2-omegae**2)/2.0_wp/omega_off
        k4(pp,1)=Tstep*(cte1*(EE(c1,pp,2)+k3(pp,2)-SSE(pp,1)*Tstep)-nuE(pp)*(EE(c1,pp,1)+k3(pp,1)+SSE(pp,2)*Tstep)+cte2*CC(2))
        k4(pp,2)=Tstep*(-1.0_wp*cte1*(EE(c1,pp,1)+k3(pp,1)+SSE(pp,2)*Tstep) - &
            nuE(pp)*(EE(c1,pp,2)+k3(pp,2)-SSE(pp,1)*Tstep)-cte2*CC(1))

        EE(c2,pp,1)=EE(c1,pp,1)+(k1(pp,1)+2.0_wp*k2(pp,1)+2.0_wp*k3(pp,1)+k4(pp,1))/6.0+SSE(pp,2) * Tstep ! no vect
        EE(c2,pp,2)=EE(c1,pp,2)+(k1(pp,2)+2.0_wp*k2(pp,2)+2.0_wp*k3(pp,2)+k4(pp,2))/6.0-SSE(pp,1) * Tstep ! no vect
        EE(c2,N/2,:)=0.0_wp
      end do ! pp N

      do pp=1,N/2
        call random_number(rdist(:2))
        SSn(:)= rdist(:2)*Source_factor_n(pp)/sqrt(Tstep)

        LL= max(p(pp)-N/3,-N/3)
        UU= min(N/3,p(pp)+N/3)
        CC(:)=0.0_wp

        do q=LL,UU
          ! no vect
          CC(1)=CC(1)+EE(c1,q+N/2,1)*EE(c1,q-p(pp)+N/2,1)+EE(c1,q+N/2,2)*EE(c1,q-p(pp)+N/2,2)
          CC(2)=CC(2)+EE(c1,q+N/2,2)*EE(c1,q-p(pp)+N/2,1)-EE(c1,q+N/2,1)*EE(c1,q-p(pp)+N/2,2)
        end do

        kn1(:)=Tstep*(vv(c1,pp,:))
        kv1(:)=Tstep*(-2.0_wp*nui(pp)*vv(c1,pp,:) - (Cs*k(pp))**2.0_wp *nn(c1,pp,:)-k(pp)**2.0_wp*epsilon0/4/mi*CC(:))

        CC(:)=0.0_wp

        do q=LL,UU
          ! no vect
          CC(1)=CC(1)+(EE(c1,q+N/2,1)+k1(q+N/2,1)/2)*(EE(c1,q-p(pp)+N/2,1)+k1(q-p(pp)+N/2,1)/2)+ &
                (EE(c1,q+N/2,2)+k1(q+N/2,2)/2)*(EE(c1,q-p(pp)+N/2,2)+k1(q-p(pp)+N/2,2)/2)
          CC(2)=CC(2)+(EE(c1,q+N/2,2)+k1(q+N/2,2)/2)*(EE(c1,q-p(pp)+N/2,1)+k1(q-p(pp)+N/2,1)/2)- &
                (EE(c1,q+N/2,1)+k1(q+N/2,1)/2)*(EE(c1,q-p(pp)+N/2,2)+k1(q-p(pp)+N/2,2)/2)
        end do

        kn2(:)=Tstep*(vv(c1,pp,:)+kv1(:)/2+SSn(:)/2*Tstep)

        kv2(:)=Tstep*(-2.0_wp*nui(pp)*(vv(c1,pp,:)+kv1(:)/2+SSn(:)/2*Tstep)- &
                (Cs*k(pp))**2.0_wp *(nn(c1,pp,:)+kn1(:)/2)-k(pp)**2.0_wp*epsilon0/4/mi*CC(:))

        CC(:)=0.0_wp

        do q=LL,UU
          CC(1)=CC(1)+(EE(c1,q+N/2,1)+k2(q+N/2,1)/2)*(EE(c1,q-p(pp)+N/2,1)+k2(q-p(pp)+N/2,1)/2) + &
                (EE(c1,q+N/2,2)+k2(q+N/2,2)/2)*(EE(c1,q-p(pp)+N/2,2)+k2(q-p(pp)+N/2,2)/2)
          CC(2)=CC(2)+(EE(c1,q+N/2,2)+k2(q+N/2,2)/2)*(EE(c1,q-p(pp)+N/2,1)+k2(q-p(pp)+N/2,1)/2) - &
                (EE(c1,q+N/2,1)+k2(q+N/2,1)/2)*(EE(c1,q-p(pp)+N/2,2)+k2(q-p(pp)+N/2,2)/2)
        end do

        kn3(:)=Tstep*(vv(c1,pp,:)+kv2(:)/2+SSn(:)/2*Tstep)

        kv3(:)=Tstep*(-2.0_wp*nui(pp)*(vv(c1,pp,:)+kv2(:)/2+SSn(:)/2*Tstep) - &
               (Cs*k(pp))**2.0_wp *(nn(c1,pp,:)+kn2(:)/2)-k(pp)**2.0_wp*epsilon0/4/mi*CC(:))

        CC(:)=0.0_wp
        do q=LL,UU
          CC(1)=CC(1)+(EE(c1,q+N/2,1)+k3(q+N/2,1)/2)*(EE(c1,q-p(pp)+N/2,1)+k3(q-p(pp)+N/2,1)/2) + &
                (EE(c1,q+N/2,2)+k3(q+N/2,2)/2)*(EE(c1,q-p(pp)+N/2,2)+k3(q-p(pp)+N/2,2)/2)
          CC(2)=CC(2)+(EE(c1,q+N/2,2)+k3(q+N/2,2)/2)*(EE(c1,q-p(pp)+N/2,1)+k3(q-p(pp)+N/2,1)/2) - &
                (EE(c1,q+N/2,1)+k3(q+N/2,1)/2)*(EE(c1,q-p(pp)+N/2,2)+k3(q-p(pp)+N/2,2)/2)
        end do

        kn4(:)=Tstep*(vv(c1,pp,:)+kv3(:)+SSn(:)*Tstep)
        kv4(:)=Tstep*(-2.0_wp*nui(pp)*(vv(c1,pp,:)+kv3(:)+SSn(:)*Tstep) - &
               (Cs*k(pp))**2.0_wp *(nn(c1,pp,:)+kn3(:))-k(pp)**2.0_wp*epsilon0/4/mi*CC(:))

        vv(c2,pp,:)=vv(c1,pp,:)+(kv1(:)+2*kv2(:)+2*kv3(:)+kv4(:))/6+SSn(:)*Tstep
        nn(c2,pp,:)=nn(c1,pp,:)+(kn1(:)+2*kn2(:)+2*kn3(:)+kn4(:))/6
        nn(c2,N/2,:)=0.0_wp

        if (pp>=1) then
          nn(c2,N-pp,1)=nn(c2,pp,1)
          nn(c2,N-pp,2)=-nn(c2,pp,2)
        end if

      end do ! pp N/2

  ! WRITE TO FILE
      if ( modulo(tt1,res) == 0) then
      !  print *, 'updating output EE nn files'
        write(uEE) EE(c2,:,:)
        write(unn) nn(c2,:,:)
      end if

    end do ! tt1

    close(uEE)
    close(unn)

  end do rlz !realizations
end do vbm !Nvbeam
end do nbm !Nnbeam

call cpu_time(toc1)
print *,"Elapsed Time: ", toc1-tic1

contains

subroutine calc_k1(N,nn, k1,SSE)

integer :: pp
integer, intent(in) :: N
real(wp), intent(in) :: nn(3,N,2)
real(wp),intent(out) :: k1(N,2), SSE(N,2)
real(wp) :: CC(2) = 0.0_wp

!integer(i64) :: tic, toc

do pp=1,N

  LL = max(p(pp)-N/3,-N/3)
  UU = min(N/3,p(pp)+N/3)
  CC(:)=0.0_wp

  do q=LL,UU
    CC(1) = CC(1)+EE(c1,q+N/2,1)*nn(c1,p(pp)-q+N/2,1)-EE(c1,q+N/2,2)*nn(c1,p(pp)-q+N/2,2)
    CC(2) = CC(2)+EE(c1,q+N/2,1)*nn(c1,p(pp)-q+N/2,2)+EE(c1,q+N/2,2)*nn(c1,p(pp)-q+N/2,1)
  end do

  call random_number(rdist(:2))
  SSE(pp,:) = rdist(:2)*Source_factor_E(pp)/sqrt(Tstep)

  cte1=1.5_wp*omegae*(lambdaD*k(pp))**2.0_wp
	!cte1=1.5_wp*Kb*Te/me/omega_off*k(pp)*k(pp)-(omega_off**2-omegae**2)/2.0_wp/omega_off
  k1(pp,1)=Tstep*(cte1*EE(c1,pp,2)-nuE(pp)*EE(c1,pp,1)+cte2*CC(2))
  k1(pp,2)=Tstep*(-1.0_wp*cte1*EE(c1,pp,1)-nuE(pp)*EE(c1,pp,2)-cte2*CC(1))
end do ! pp N

end subroutine calc_k1

elemental subroutine Xsection(Xsec_ion, Xsec_pl, k)
  implicit none

  real(wp), intent(out) :: Xsec_ion, Xsec_pl
  real(wp), intent(in) :: k

  real(wp) :: alpha,XX

  alpha=1.0_wp / (k*lambdaD)
  Xsec_ion= 2.0_wp * pi/(1.0_wp + alpha**2.0_wp) * (Z * alpha**4.0_wp/(1.0_wp+alpha**2.0_wp + alpha**2.0_wp * Z*Te/Ti))
  XX=2.0_wp*pi*(1.0_wp + alpha**2.0_wp*Z*Te/Ti)/(1.0_wp+alpha**2.0_wp+alpha**2.0_wp*Z*Te/Ti)

  Xsec_pl=XX-Te/Ti*Xsec_ion

end subroutine Xsection

end program


module global_variables
  implicit none
  real(8),parameter :: pi = 4d0*atan(1d0)
  complex(8),parameter :: zi = (0d0,1d0)
  real(8),parameter :: fs = 0.024189d0
  real(8),parameter :: ev = 27.2114d0
  real(8),parameter :: b_a = 0.529d0
  real(8),parameter :: clight = 137.035999139d0

! material parameters
  real(8),parameter :: tau_z = 1d0, delta_gap = 0d0
! Fermi velocity of graphene PRL 101, 226405 (2008).
  real(8),parameter :: velocity = clight*1.12d6/299792458d0
  integer,parameter :: nkx = 32, nky = 32
  real(8),parameter :: kx_max = 1d0, ky_max = 1d0
! Fermi-Dirac distribution
  real(8),parameter :: mu_F = 0d0/ev
  real(8),parameter :: kbT  = 80d0/11604.505d0/ev

  real(8) :: kx(nkx),ky(nky)
  real(8) :: dkx,dky
  complex(8) :: zpsi(2,2,nkx,nky)
  real(8) :: occ(2,nkx,nky), eps(2,nkx,nky)

! time propagation
  real(8),parameter :: Tprop = 2.2d3/fs, dt = 0.08d0
  integer,parameter :: nt = aint(Tprop/dt)+1

  real(8) :: jt(2,0:nt), ac(2,0:nt), ac_dt2(2,0:nt)

end module global_variables
!----------------------------------------------------------------------------------------!
program main
  use global_variables
  implicit none

  call init
  call init_ac

  call time_propagation

end program main
!----------------------------------------------------------------------------------------!
subroutine init
  use global_variables
  implicit none
  integer :: ikx,iky
  real(8) :: kxt, kyt, theta
  complex(8) :: zs

  do ikx = 1,nkx
    kx(ikx) = -kx_max + 2d0*kx_max*dble(ikx-1)/dble(nkx-1)
  end do
  dkx = 2d0*kx_max/dble(nkx-1)

  do iky = 1,nky
    ky(iky) = -ky_max + 2d0*ky_max*dble(iky-1)/dble(nky-1)
  end do
  dky = 2d0*ky_max/dble(nky-1)

  eps = 0d0

  if(delta_gap == 0d0)then ! Dirac cone
    do ikx = 1, nkx
      kxt = kx(ikx)
      do iky = 1,nky
        kyt = ky(iky)

        zs = tau_z*kxt+zI*kyt
        if(zs /= 0d0)then
          theta = -aimag(log(-zs))
        else
          theta = 0d0
        end if

        zpsi(1,1,ikx,iky) = exp(zI*theta)/sqrt(2d0)
        zpsi(2,1,ikx,iky) = 1d0/sqrt(2d0)
        eps(1,ikx,iky) = -velocity*sqrt(tau_z**2*kxt**2 + kyt**2)

        zpsi(1,2,ikx,iky) = exp(zI*(theta+pi))/sqrt(2d0)
        zpsi(2,2,ikx,iky) = 1d0/sqrt(2d0)
        eps(2,ikx,iky) = velocity*sqrt(tau_z**2*kxt**2 + kyt**2)

      end do
    end do
  else
    stop 'Kane band is not implemented yet.'
  end if

! Fermi-Dirac distribution
  do ikx = 1,nkx
    do iky = 1,nky

      occ(1,ikx,iky) = 2d0/(exp((eps(1,ikx,iky)-mu_F)/kbT)+1d0)
      occ(2,ikx,iky) = 2d0/(exp((eps(2,ikx,iky)-mu_F)/kbT)+1d0)

    end do
  end do

end subroutine init
!----------------------------------------------------------------------------------------!
subroutine time_propagation
  use global_variables
  implicit none
  real(8) :: jxy(2)
  integer :: it

  open(21,file="current.out")
  call current(jxy(:),0)
  write(21,"(999e26.16e3)")0d0,ac(:,0),jxy
  do it = 0,nt-1
    if(mod(it,max(100,nt/100)) == 0)write(*,*)"it=",it,nt
    call dt_evolve(it)
    call current(jxy(:),it)
    write(21,"(999e26.16e3)")dt*(it+1),ac(:,it+1),jxy
  end do
  close(21)

end subroutine time_propagation
!----------------------------------------------------------------------------------------!
subroutine dt_evolve(it)
  implicit none
  integer,intent(inout) :: it

  call dt_evolve_Taylor(it)
!  call dt_evolve_Magnus(it)
!  call dt_evolve_Magnus_1st(it)

end subroutine dt_evolve
!!----------------------------------------------------------------------------------------!
!subroutine dt_evolve_Magnus(it)
!  use global_variables
!  implicit none
!  integer,intent(in) :: it
!  real(8) :: acx0, acx1, acx2
!  real(8) :: acy0, acy1, acy2
!  integer :: ikx, iky
!  real(8) :: kxt, kyt,kxt_eff, kyt_eff
!  real(8) :: delta,lambda(2)
!  complex(8) :: zHeff(2,2),zalpha,zx,zvec(2,2),zc(2)
!  real(8) :: const,ss
!
!
!  if(delta_gap /= 0d0)stop 'delta_gap has to be zero in Magnus propagator.'
!
!  acx0 = ac(1,it)
!  acx2 = (ac(1,it)-2d0*ac_dt2(1,it)+ac(1,it+1))/(0.5d0*dt)**2
!  acx1 = (ac(1,it+1)-acx0-0.5d0*dt**2*acx2)/dt
!
!  acy0 = ac(2,it)
!  acy2 = (ac(2,it)-2d0*ac_dt2(2,it)+ac(2,it+1))/(0.5d0*dt)**2
!  acy1 = (ac(2,it+1)-acy0-0.5d0*dt**2*acy2)/dt
!
!  const = -dt**2/6d0*tau_z*velocity**2
!
!
!!$omp parallel default(shared), private(ikx,iky,kxt,kyt,kxt_eff,kyt_eff,ss,delta,zalpha, &
!!$omp & lambda,zx,zvec,zc)
!!$omp do collapse(2)
!  do ikx = 1,nkx
!    do iky = 1,nky
!      kxt = kx(ikx) + acx0
!      kxt_eff = kxt + 0.5d0*dt*acx1 + dt**2/6d0*acx2
!      kyt = ky(iky) + acy0
!      kyt_eff = kyt + 0.5d0*dt*acy1 + dt**2/6d0*acy2
!
!      ss = kxt*acy1-acx1*kyt
!!      zHeff(1,1) =  const*ss
!!      zHeff(2,1) =  velocity*(tau_z*kxt_eff + zI*kyt_eff)
!!      zHeff(1,2) =  velocity*(tau_z*kxt_eff - zI*kyt_eff)
!!      zHeff(2,2) = -const*ss
!
!      delta  = const*ss
!      zalpha = velocity*(tau_z*kxt_eff + zI*kyt_eff)
!!
!      if(delta >= 0d0)then
!
!! vector 1
!        lambda(1) = sqrt(delta**2 + abs(zalpha)**2)
!        zx = zalpha/(lambda(1) + delta)
!        ss = 1d0/sqrt(1d0 + abs(zx)**2)
!        zvec(1,1) = ss
!        zvec(2,1) = ss*zx
!
!! vector 2
!        lambda(2) = -lambda(1)
!        zvec(1,2) = -ss*conjg(zx)
!        zvec(2,2) =  ss
!
!      else
!
!! vector 1
!        lambda(1) = sqrt(delta**2 + abs(zalpha)**2)
!        zx = conjg(zalpha)/(lambda(1) - delta)
!        ss = 1d0/sqrt(1d0 + abs(zx)**2)
!        zvec(1,1) = ss*zx
!        zvec(2,1) = ss
!
!! vector 2
!        lambda(2) = -lambda(1)
!        zvec(1,2) =  ss
!        zvec(2,2) = -ss*conjg(zx)
!
!      end if
!
!! projection
!      zc(1) = conjg(zvec(1,1))*zpsi(1,ikx,iky) + conjg(zvec(2,1))*zpsi(2,ikx,iky)
!      zc(2) = conjg(zvec(1,2))*zpsi(1,ikx,iky) + conjg(zvec(2,2))*zpsi(2,ikx,iky)
!
!! propagation
!      zc(1) = zc(1)*exp(-zI*lambda(1)*dt)
!      zc(2) = zc(2)*exp(-zI*lambda(2)*dt)
!
!! update wavefunction
!      zpsi(:,ikx,iky) = zc(1)*zvec(:,1) + zc(2)*zvec(:,2)
!
!
!    end do
!  end do
!!$omp end do
!!$omp end parallel
!
!end subroutine dt_evolve_Magnus
!!----------------------------------------------------------------------------------------!
!subroutine dt_evolve_Magnus_1st(it)
!  use global_variables
!  implicit none
!  integer,intent(in) :: it
!  real(8) :: acx0, acx1, acx2
!  real(8) :: acy0, acy1, acy2
!  integer :: ikx, iky
!  real(8) :: kxt, kyt,kxt_eff, kyt_eff
!  real(8) :: delta,lambda(2)
!  complex(8) :: zHeff(2,2),zalpha,zx,zvec(2,2),zc(2)
!  real(8) :: const,ss
!
!
!  if(delta_gap /= 0d0)stop 'delta_gap has to be zero in Magnus propagator.'
!
!  acx0 = ac(1,it)
!  acx2 = (ac(1,it)-2d0*ac_dt2(1,it)+ac(1,it+1))/(0.5d0*dt)**2
!  acx1 = (ac(1,it+1)-acx0-0.5d0*dt**2*acx2)/dt
!
!  acy0 = ac(2,it)
!  acy2 = (ac(2,it)-2d0*ac_dt2(2,it)+ac(2,it+1))/(0.5d0*dt)**2
!  acy1 = (ac(2,it+1)-acy0-0.5d0*dt**2*acy2)/dt
!
!  delta = 0d0
!
!
!!$omp parallel default(shared), private(ikx,iky,kxt,kyt,kxt_eff,kyt_eff,ss,zalpha, &
!!$omp & lambda,zx,zvec,zc)
!!$omp do collapse(2)
!  do ikx = 1,nkx
!    do iky = 1,nky
!      kxt = kx(ikx) + acx0
!      kxt_eff = kxt + 0.5d0*dt*acx1 + dt**2/6d0*acx2
!      kyt = ky(iky) + acy0
!      kyt_eff = kyt + 0.5d0*dt*acy1 + dt**2/6d0*acy2
!
!      zalpha = velocity*(tau_z*kxt_eff + zI*kyt_eff)
!!
!! vector 1
!      lambda(1) = sqrt(delta**2 + abs(zalpha)**2)
!      zx = zalpha/(lambda(1) + delta)
!      ss = 1d0/sqrt(1d0 + abs(zx)**2)
!      zvec(1,1) = ss
!      zvec(2,1) = ss*zx
!
!! vector 2
!      lambda(2) = -lambda(1)
!      zvec(1,2) = -ss*conjg(zx)
!      zvec(2,2) =  ss
!
!
!! projection
!      zc(1) = conjg(zvec(1,1))*zpsi(1,ikx,iky) + conjg(zvec(2,1))*zpsi(2,ikx,iky)
!      zc(2) = conjg(zvec(1,2))*zpsi(1,ikx,iky) + conjg(zvec(2,2))*zpsi(2,ikx,iky)
!
!! propagation
!      zc(1) = zc(1)*exp(-zI*lambda(1)*dt)
!      zc(2) = zc(2)*exp(-zI*lambda(2)*dt)
!
!! update wavefunction
!      zpsi(:,ikx,iky) = zc(1)*zvec(:,1) + zc(2)*zvec(:,2)
!
!
!    end do
!  end do
!!$omp end do
!!$omp end parallel
!
!end subroutine dt_evolve_Magnus_1st
!!----------------------------------------------------------------------------------------!
subroutine dt_evolve_Taylor(it)
  use global_variables
  implicit none
  integer,intent(in) :: it
  integer :: ikx, iky
  real(8) :: kxt, kyt
  complex(8) :: zpsi_t(2,2,0:4)

!$omp parallel default(shared), private(ikx,iky,kxt,kyt,zpsi_t)
!$omp do collapse(2)
  do ikx = 1,nkx
    do iky = 1,nky

      kxt = kx(ikx) + ac(1,it)
      kyt = ky(iky) + ac(2,it)
! RK1
      zpsi_t(:,:,0) = zpsi(:,:,ikx,iky)
      zpsi_t(1,:,1) = 0.5d0*delta_gap*zpsi_t(1,:,0) &
        + velocity*(tau_z*kxt - zI*kyt)*zpsi_t(2,:,0)
      zpsi_t(2,:,1) = velocity*(tau_z*kxt + zI*kyt)*zpsi_t(1,:,0)  &
        - 0.5d0*delta_gap*zpsi_t(2,:,0)

      kxt = kx(ikx) + ac_dt2(1,it)
      kyt = ky(iky) + ac_dt2(2,it)
! RK2
      zpsi_t(:,:,0) = zpsi(:,:,ikx,iky) - zI*0.5d0*dt*zpsi_t(:,:,1)

      zpsi_t(1,:,2) = 0.5d0*delta_gap*zpsi_t(1,:,0) &
        + velocity*(tau_z*kxt - zI*kyt)*zpsi_t(2,:,0)
      zpsi_t(2,:,2) = velocity*(tau_z*kxt + zI*kyt)*zpsi_t(1,:,0)  &
        - 0.5d0*delta_gap*zpsi_t(2,:,0)

! RK3
      zpsi_t(:,:,0) = zpsi(:,:,ikx,iky) - zI*0.5d0*dt*zpsi_t(:,:,2)

      zpsi_t(1,:,3) = 0.5d0*delta_gap*zpsi_t(1,:,0) &
        + velocity*(tau_z*kxt - zI*kyt)*zpsi_t(2,:,0)
      zpsi_t(2,:,3) = velocity*(tau_z*kxt + zI*kyt)*zpsi_t(1,:,0)  &
        - 0.5d0*delta_gap*zpsi_t(2,:,0)

      kxt = kx(ikx) + ac(1,it+1)
      kyt = ky(iky) + ac(2,it+1)

! RK4
      zpsi_t(:,:,0) = zpsi(:,:,ikx,iky) - zI*dt*zpsi_t(:,:,3)

      zpsi_t(1,:,4) = 0.5d0*delta_gap*zpsi_t(1,:,0) &
        + velocity*(tau_z*kxt - zI*kyt)*zpsi_t(2,:,0)
      zpsi_t(2,:,4) = velocity*(tau_z*kxt + zI*kyt)*zpsi_t(1,:,0)  &
        - 0.5d0*delta_gap*zpsi_t(2,:,0)

      zpsi(:,:,ikx,iky) = zpsi(:,:,ikx,iky) -zI*dt/6d0*( &
        zpsi_t(:,:,1) + 2d0*zpsi_t(:,:,2) + 2d0*zpsi_t(:,:,3) + zpsi_t(:,:,4) )

    end do
  end do
!$omp end do
!$omp end parallel

end subroutine dt_evolve_Taylor
!----------------------------------------------------------------------------------------!
subroutine init_ac
  use global_variables
  implicit none
  integer :: it
  real(8) :: tt,tt2, xx, xx2
  real(8) :: E0,omega,tpulse
  real(8) :: E_SD, T_SD
  real(8) :: gap_Floquet

!  gap_Floquet = 0.1d0/ev
  E0 = 1d7*b_a*1d-10/ev
  omega = 0.19074d0/ev ! 6.5 micron
  tpulse = 1d3/fs

!  E0 = omega*0.5d0/velocity*sqrt( &
!    (gap_Floquet + omega)**2 - omega**2 &
!    )

  write(*,"(A,2x,e26.16e3,A)")"Field strength =",E0*ev/b_a*1d10, "eV/m"

! Source-drain
  E_SD = 1d-8
  T_SD = 10d0/fs

  ac = 0d0
  ac_dt2 = 0d0

  do it = 0,nt

    tt = dt*it
    tt2 = dt*it + 0.5d0*dt

! source-drain
    if(tt<T_SD)then
      ac(1,it) = ac(1,it) - E_SD*(tt/2d0 - T_SD/(2d0*pi)*sin(pi*tt/T_SD))
    else
      ac(1,it) = ac(1,it) - E_SD*(tt - T_SD/2d0)
    end if
    if(tt2<T_SD)then
      ac_dt2(1,it) = ac_dt2(1,it) - E_SD*(tt2/2d0 - T_SD/(2d0*pi)*sin(pi*tt2/T_SD))
    else
      ac_dt2(1,it) = ac_dt2(1,it) - E_SD*(tt2 - T_SD/2d0)
    end if

! circular laser
    xx = tt - T_SD - 0.5d0*tpulse
    xx2 = tt2 - T_SD - 0.5d0*tpulse

     if( abs(xx)<0.5d0*tpulse )then
        ac(1,it) = ac(1,it) - E0/omega*cos(pi*xx/tpulse)**4*sin(omega*xx)
        ac(2,it) = ac(2,it) - E0/omega*cos(pi*xx/tpulse)**4*cos(omega*xx)
     end if

     if( abs(xx2)<0.5d0*tpulse )then
        ac_dt2(1,it) = ac_dt2(1,it) - E0/omega*cos(pi*xx2/tpulse)**4*sin(omega*xx2)
        ac_dt2(2,it) = ac_dt2(2,it) - E0/omega*cos(pi*xx2/tpulse)**4*cos(omega*xx2)
     end if

  end do

end subroutine init_ac
!----------------------------------------------------------------------------------------!
subroutine current(jxy,it)
  use global_variables
  implicit none
  real(8),intent(out) :: jxy(2)
  integer,intent(in) :: it
  real(8) :: jx,jy
  integer :: ikx, iky
  real(8) :: kxt, kyt
  real(8) :: jxt,jyt,jx0,jy0,xx
  complex(8) :: zs

  jx = 0d0
  jy = 0d0

!$omp parallel default(shared), private(ikx,iky,kxt,kyt,jxt,jyt,zs,jx0,jy0)
!$omp do reduction(+:jx,jy) collapse(2)
  do ikx = 1,nkx
    do iky = 1,nky

       kxt = kx(ikx) + ac(1,it)
       kyt = ky(iky) + ac(2,it)

       jxt = 2d0*occ(1,ikx,iky)*real(zpsi(1,1,ikx,iky)*conjg(zpsi(2,1,ikx,iky))) &
            +2d0*occ(2,ikx,iky)*real(zpsi(1,2,ikx,iky)*conjg(zpsi(2,2,ikx,iky)))
       jyt = 2d0*occ(1,ikx,iky)*real(zI*zpsi(1,1,ikx,iky)*conjg(zpsi(2,1,ikx,iky))) &
            +2d0*occ(2,ikx,iky)*real(zI*zpsi(1,2,ikx,iky)*conjg(zpsi(2,2,ikx,iky)))

       zs =  -(tau_z*kxt-zI*kyt)&
            /sqrt(kxt**2+kyt**2)

       jx0 =  2d0*0.5d0*real(zs)   *(occ(1,ikx,iky)-occ(2,ikx,iky))
       jy0 =  2d0*0.5d0*real(zI*zs)*(occ(1,ikx,iky)-occ(2,ikx,iky))

       jx = jx + jxt - jx0
       jy = jy + jyt - jy0

     end do
  end do
!$omp end do
!$omp end parallel

  jxy(1) = jx*dkx*dky
  jxy(2) = jy*dkx*dky

end subroutine current
!----------------------------------------------------------------------------------------!
!----------------------------------------------------------------------------------------!
!----------------------------------------------------------------------------------------!


C        function str2ten_2(E,ndi,nshear,ngens)
C         implicit none
C
C         integer :: ndi,nshear,ngens
C         real(kind=8), dimension(ngens) :: E
C         type(Tensor2) :: str2ten_2
C         integer, dimension(3) :: ii, jj
C         integer :: i
C
C         str2ten_2 = Identity2(str2ten_2)
C
C         do i=1,ndi
C          str2ten_2%ab(i,i) = E(i)
C         enddo
C
C         ii = (/1,2,3/)
C         jj = (/2,3,1/)
C
C         do i=1,nshear
C          str2ten_2%ab(ii(i),jj(i)) = E(i+ndi)/2.
C         end do

C        end function str2ten_2

       function str2ten_2s(E,ndi,nshear,ngens)
        implicit none

        integer :: ndi, nshear, ngens
        real(kind=8), dimension(ngens) :: E
        type(Tensor2s) :: str2ten_2s
        integer :: i

        str2ten_2s = Identity2(str2ten_2s)

        do i=1,ndi
         str2ten_2s%a6(i) = E(i)
        enddo

        do i=1,nshear
         str2ten_2s%a6(i+3) = E(i+ndi)/2.
        end do

       end function str2ten_2s


Module TORANA
use func
contains

subroutine ANALYSIS(natm,atmass,xyz,ntor,wavall,wav_proall,inert1,inert2,inert3)
implicit real*8 (a-h,o-z)
real*8,parameter :: pi=3.141592653589793D0
integer*8,intent(inout)::natm, ntor
real*8, intent(inout)::atmass(:)
real*8, intent(inout)::inert1,inert2,inert3
real*8,allocatable,intent(inout)::wavall(:), wav_proall(:),xyz(:,:)
real*8,allocatable :: Hess(:,:),eigvecmat(:,:),eigvalarr(:),kmat(:,:),massmat(:,:),freq(:), fre_pro(:), normvec(:,:),tmpvec(:)
real*8,allocatable ::D(:,:) ,E(:,:),P(:,:) ,origin(:)
integer*8, allocatable :: torgroup(:,:)
real*8 :: VnV(3),V1V2(3)
real*8 :: MIM(3,3) , Meigvecmat(3,3) , Meigvalarr(3)
integer*8 :: nbond,existence, nmode, nmodeall

!Don't support linear molecules
write(*,*) "*****************************************************"
write(*,*) "*          Torsion Projection analysis              * "
write(*,*) "*****************************************************"
write(*,*)

nmode=3*natm-6 !The number of vibrational modes
nmodeall=3*natm
write(*,"(' The number of vibrational modes:',i6)") nmode

write(*,*) "Atomic masses:"
write(*,"(6(f12.6))") atmass

!load xyz and fixe it in the center of mass
xyz=xyz/0.52917720859D0
allocate(origin(3))
write(*,*) "Cartesian coordinate(Bohr)"
do i=1, natm
write(*,"(3(f12.6))") xyz(i,:)
end do
origin=0
do i=1, natm
    origin(1)=atmass(i)*xyz(i,1)+origin(1)
    origin(2)=atmass(i)*xyz(i,2)+origin(2)
    origin(3)=atmass(i)*xyz(i,3)+origin(3)
end do
temp=sum(atmass)
origin=origin/temp
write(*,*) "Origin cartesian coordinate"
write(*,*) origin
do i=1 , natm
    xyz(i,1)=xyz(i,1)-origin(1)
    xyz(i,2)=xyz(i,2)-origin(2)
    xyz(i,3)=xyz(i,3)-origin(3)
end do
write(*,*) "Cartesian coordinate fixed at mass center"
do i=1,natm
write(*,"(3(f12.6))") xyz(i,:)
end do

!Load Hessian matrix
allocate(Hess(nmodeall,nmodeall))
Hess=0
call loclabel(10,"Cartesian Force Constants")
read(10,*)
read(10,"(5(1PE16.8))") ((Hess(i,j),j=1,i),i=1,nmodeall)
Hess=Hess+transpose(Hess)
do i=1,nmodeall
	Hess(i,i)=Hess(i,i)/2D0
end do
! call showmatgau(Hess,"Hessian matrix",1)

!Load bond array and torsion bond, then analysis torsion group
call loclabel(10,"Total Bond Number")
read(10,*)
read(10,*) nbond
allocate(torgroup(natm,2*ntor))
if (ntor>0) then
call torgana(natm, ntor, nbond, torgroup)
 write(*,*)
 write(*,*) "********************Torsion bond group*****************"
 do i=1,ntor
     write(*,"(' Pivot atom lables where tosion is happening:'I8,I8)") torgroup(1,(i*2-1)),torgroup(1,i*2)
     write(*,*) "One of the torsion groups about mentioned torsion above:"
     write(*,"(10(I5))") torgroup(:,(i*2-1))
     write(*,*)
 end do
else
    write(*,*) "Warning!!!  Torsion haven't been detected!!!"
end if

!Construct mass matrix
allocate(massmat(nmodeall,nmodeall))
massmat=0
do i=1,natm
	do j=(i-1)*3+1,i*3
		massmat(j,j)=atmass(i)
    end do
end do

!Calculat the moments of inertia
MIM=0
do iatm=1,natm
    MIM(1,1)=atmass(iatm)*(xyz(iatm,2)**2+xyz(iatm,3)**2)+MIM(1,1)
    MIM(1,2)=-atmass(iatm)*(xyz(iatm,1)*xyz(iatm,2))+MIM(1,2)
    MIM(1,3)=-atmass(iatm)*(xyz(iatm,1)*xyz(iatm,3))+MIM(1,3)
    MIM(2,2)=atmass(iatm)*(xyz(iatm,1)**2+xyz(iatm,3)**2)+MIM(2,2)
    MIM(2,3)=-atmass(iatm)*(xyz(iatm,2)*xyz(iatm,3))+MIM(2,3)
    MIM(3,3)=atmass(iatm)*(xyz(iatm,1)**2+xyz(iatm,2)**2)+MIM(3,3)
end do
MIM(2,1)=MIM(1,2)
MIM(3,1)=MIM(1,3)
MIM(3,2)=MIM(2,3)
write(*,*)
write(*,*) "********************************************************"
write(*,*) "*     Now, output Properties of global rotation        *"
write(*,*) "********************************************************"
write(*,*)
write(*,*) "The moment of inertia(amu*Bohr^2) martix is:"
do i=1,3
write(* , "(f12.6, f12.6, f12.6)") MIM(i,1) , MIM(i,2) , MIM(i,3)
end do
call diagsymat(MIM,Meigvecmat,Meigvalarr,Mistat) !Note the column of eigvecmat has already been automatically normalized
if (istat==0) write(*,*) "Diagonalization passed"
write(*,*) "Principle moment inertia is:"
write(*,"(f12.6,f12.6,f12.6)") Meigvalarr
inert1=Meigvalarr(1)
inert2=Meigvalarr(2)
inert3=Meigvalarr(3)
write(*,*) "And corresponding eigenvect is:"
do i=1,3
    write(*,"(f12.6,f12.6,f12.6)") Meigvecmat(i,:)
end do

!construct translation vector and rotation vector
allocate(D(nmodeall,(6+ntor)),E(nmodeall,nmodeall),P(nmodeall,nmodeall))
D=0
do i=1,natm !global translation vector
    D((i-1)*3+1,1)=1
    D((i-1)*3+2,2)=1
    D((i-1)*3+3,3)=1
end do
do i=1, natm !global rotation vector
    do j=1,3
    D((i-1)*3+j,4)=dot_product(xyz(i,:),Meigvecmat(2,:))*Meigvecmat(j,3)-dot_product(xyz(i,:),Meigvecmat(3,:))*Meigvecmat(j,2)
    D((i-1)*3+j,5)=dot_product(xyz(i,:),Meigvecmat(3,:))*Meigvecmat(j,1)-dot_product(xyz(i,:),Meigvecmat(1,:))*Meigvecmat(j,3)
    D((i-1)*3+j,6)=dot_product(xyz(i,:),Meigvecmat(1,:))*Meigvecmat(j,2)-dot_product(xyz(i,:),Meigvecmat(2,:))*Meigvecmat(j,1)
    end do
end do

do j=7,(6+ntor)
  do i=1,natm !internal rotation vector
     inner:do k=1, natm
         if (i==torgroup(k,((j-6)*2-1))) then
           existence=1
           exit inner
         else if(0==torgroup(k,((j-6)*2-1))) then
           existence=0
           exit inner
         else
           existence=0
         end if
         end do inner
    if (existence==1)   then
        VnV=xyz(i,:)-xyz(torgroup(1,((j-6)*2-1)),:)
        V1V2=xyz(torgroup(1,((j-6)*2-1)),:)-xyz(torgroup(1,((j-6)*2)),:)
        D((i-1)*3+1,j)=(VnV(2)*V1V2(3)-VnV(3)*V1V2(2))/dsqrt(V1V2(1)**2+V1V2(2)**2+V1V2(3)**2)
        D((i-1)*3+2,j)=(VnV(3)*V1V2(1)-VnV(1)*V1V2(3))/dsqrt(V1V2(1)**2+V1V2(2)**2+V1V2(3)**2)
        D((i-1)*3+3,j)=(VnV(1)*V1V2(2)-VnV(2)*V1V2(1))/dsqrt(V1V2(1)**2+V1V2(2)**2+V1V2(3)**2)
    else
        VnV=xyz(i,:)-xyz(torgroup(1,((j-6)*2)),:)
        V1V2=xyz(torgroup(1,((j-6)*2)),:)-xyz(torgroup(1,((j-6)*2-1)),:)
        D((i-1)*3+1,j)=(VnV(2)*V1V2(3)-VnV(3)*V1V2(2))/dsqrt(V1V2(1)**2+V1V2(2)**2+V1V2(3)**2)
        D((i-1)*3+2,j)=(VnV(3)*V1V2(1)-VnV(1)*V1V2(3))/dsqrt(V1V2(1)**2+V1V2(2)**2+V1V2(3)**2)
        D((i-1)*3+3,j)=(VnV(1)*V1V2(2)-VnV(2)*V1V2(1))/dsqrt(V1V2(1)**2+V1V2(2)**2+V1V2(3)**2)
    end if
  end do
end do

do i=2,(6+ntor) !Schmidt orthogonalization
    do j=1,i-1
    D(:,i)=D(:,i)-(dot_product(D(:,j),D(:,i))/dot_product(D(:,j),D(:,j)))*D(:,j)
    end do
end do

do i=1,(6+ntor)
tmp=dsqrt(sum(D(:,i)**2))
D(:,i)=D(:,i)/tmp
end do
E=0
do i=1,nmodeall
    E(i,i)=1
end do

!Now, calculating frequencies
!===============================================================
!========Calculate original frequenceis at first================
!Construct force constant matrix (mass-weighted Hessian matrix)
write(*,*)
write(*,*)"**************************************************************"
write(*,*)"* Now,frequencies are calculating without torsion projection *"
write(*,*)"*          Note: Normal coordinate will be print             *"
write(*,*)"**************************************************************"
write(*,*)
allocate(kmat(nmodeall,nmodeall))
do i=1,nmodeall
	do j=1,nmodeall
		kmat(i,j)=hess(i,j)/dsqrt(massmat(i,i)*massmat(j,j))
	end do
end do
write(*,*)
call showmatgau(kmat,"Force constant matrix (i.e mass-weighted Hessian)")

!Diagonalization of force constant matrix
allocate(eigvecmat(nmodeall,nmodeall),eigvalarr(nmodeall))
call diagsymat(kmat,eigvecmat,eigvalarr,istat) !Note the column of eigvecmat has already been automatically normalized
if (istat==0) write(*,*) "Diagonalization passed"
write(*,*) eigvalarr

!Convert force constant to harmonic frequencies
amu2kg=1.66053878D-27
b2m=0.529177249D-10
au2J=4.35974434D-18
eigvalarr=eigvalarr*au2J/b2m**2/amu2kg !First convert force constant from a.u. to SI
allocate(freq(nmodeall))
do i=1,nmodeall
	if (eigvalarr(i)<0) then
		freq(i)=-dsqrt(abs(eigvalarr(i)))/(2*pi)
	else
		freq(i)=dsqrt(eigvalarr(i))/(2*pi)
	end if
end do

!Sort all modes according to absolute value of frequencies (from low to high)
allocate(tmpvec(nmodeall))
do i=1,nmodeall
	do j=i+1,nmodeall
		if (abs(freq(i))>abs(freq(j))) then
			temp=freq(i)
			freq(i)=freq(j)
			freq(j)=temp
			tmpvec=eigvecmat(:,i)
			eigvecmat(:,i)=eigvecmat(:,j)
			eigvecmat(:,j)=tmpvec
		end if
	end do
end do
!Now the first six modes are considered as overall motions, we now sort remaining modes from low to high
do i=7,nmodeall
	do j=i+1,nmodeall
		if (freq(i)>freq(j)) then
			temp=freq(i)
			freq(i)=freq(j)
			freq(j)=temp
			tmpvec=eigvecmat(:,i)
			eigvecmat(:,i)=eigvecmat(:,j)
			eigvecmat(:,j)=tmpvec
		end if
	end do
end do
wavall=freq/2.99792458D10

!Convert normal coordinates from mass-weighted basis to Cartesian basis
allocate(normvec(nmodeall,nmodeall))
do i=1,natm
	do j=(i-1)*3+1,i*3
		normvec(j,:)=eigvecmat(j,:)/dsqrt(atmass(i))
	end do
end do
do i=1,nmodeall !Normalization
	tmp=dsqrt(sum(normvec(:,i)**2))
	normvec(:,i)=normvec(:,i)/tmp
end do
write(*,*)
call showmatgau(normvec(:,7:),"Normal coordinates (columns)",form="1x,f9.4,4x")

!Output final frequencies
write(*,*)
write(*,*) "The frequencies (cm-1) corresponding to overall translation and rotation:"
write(*,"(6(f12.5))") wavall(1:6)
write(*,*) "Harmonic vibrational frequencies:"
idx=0
do i=7,nmodeall
	idx=idx+1
	write(*,"(' Mode',i5,':',E15.5,' Hz',f15.5,' cm-1')") idx,freq(i),wavall(i)
end do
deallocate(kmat, eigvecmat,  eigvalarr, tmpvec, normvec)
write(*,*)
write(*,*)"**************************************************************"
write(*,*)"*  Now,frequencies are calculating with torsion projection   *"
write(*,*)"*      Note: Normal coordinate will not be print             *"
write(*,*)"**************************************************************"
write(*,*)
P=E-matmul(D,transpose(D))
Hess=matmul(P,Hess)
Hess=matmul(Hess,P)

!Construct force constant matrix (mass-weighted Hessian matrix)
allocate(kmat(nmodeall,nmodeall))
do i=1,nmodeall
	do j=1,nmodeall
		kmat(i,j)=hess(i,j)/dsqrt(massmat(i,i)*massmat(j,j))
	end do
end do
write(*,*)
call showmatgau(kmat,"Force constant matrix (i.e mass-weighted Hessian)")

!Diagonalization of force constant matrix
allocate(eigvecmat(nmodeall,nmodeall),eigvalarr(nmodeall))
call diagsymat(kmat,eigvecmat,eigvalarr,istat) !Note the column of eigvecmat has already been automatically normalized
if (istat==0) write(*,*) "Diagonalization passed"
write(*,*) eigvalarr

!Convert force constant to harmonic frequencies
amu2kg=1.66053878D-27
b2m=0.529177249D-10
au2J=4.35974434D-18
eigvalarr=eigvalarr*au2J/b2m**2/amu2kg !First convert force constant from a.u. to SI
allocate(fre_pro(nmodeall))
do i=1,nmodeall
	if (eigvalarr(i)<0) then
		fre_pro(i)=-dsqrt(abs(eigvalarr(i)))/(2*pi)
	else
		fre_pro(i)=dsqrt(eigvalarr(i))/(2*pi)
	end if
end do

!Sort all modes according to absolute value of frequencies (from low to high)
allocate(tmpvec(nmodeall))
do i=1,nmodeall
	do j=i+1,nmodeall
		if (abs(fre_pro(i))>abs(fre_pro(j))) then
			temp=fre_pro(i)
			fre_pro(i)=fre_pro(j)
			fre_pro(j)=temp
			tmpvec=eigvecmat(:,i)
			eigvecmat(:,i)=eigvecmat(:,j)
			eigvecmat(:,j)=tmpvec
		end if
	end do
end do
!Now the first six+ntor modes are considered as overall motions, we now sort remaining modes from low to high
do i=7+ntor,nmodeall
	do j=i+1,nmodeall
		if (fre_pro(i)>fre_pro(j)) then
			temp=fre_pro(i)
			fre_pro(i)=fre_pro(j)
			fre_pro(j)=temp
			tmpvec=eigvecmat(:,i)
			eigvecmat(:,i)=eigvecmat(:,j)
			eigvecmat(:,j)=tmpvec
		end if
	end do
end do
wav_proall=fre_pro/2.99792458D10

!Output final frequencies
write(*,*)
    write(*,*) "The frequencies (cm-1) corresponding to overall translation and rotation:"
    write(*,"(6(f12.5))") wav_proall(1:6)
    write(*,*) "Harmonic vibrational frequencies:"
    idx=0
    do i=7,nmodeall
	    idx=idx+1
	    write(*,"(' Mode',i5,':',E15.5,' Hz',f15.5,' cm-1')") idx,freq(i),wav_proall(i)
    end do
    write(*,*)
    end subroutine ANALYSIS

    end module TORANA


SUBROUTINE mgo_coord_no_mot
 ! Luca 9Aug14 - 1Nov14
 ! Calculating the anisotropic analytic coordination number for MgO
 ! as well as the isotropic coordination number for MgO

 !USE OMP_LIB                                                 !>>> CPU_TIME
 USE PARACLUSTER
 USE CLUSTER
 USE POTENTIAL
 USE ENFORCE
 USE DISTANCE
 USE SUBSTRATE

 IMPLICIT NONE

 integer               :: i, j
 double precision      :: comfactor, gamma_sub
 REAL(8), DIMENSION(nsiz,nsiz)   :: dij, df_dx, df_dy, df_dz
 REAL(8), DIMENSION(nsiz,nsiz)   :: cos_theta, df_mot_dx, df_mot_dy, df_mot_dz
 !REAL(8) :: t_start, t_end                                   !>>> CPU_TIME
 !t_start = OMP_GET_WTIME()                                   !>>> CPU_TIME

IF (ipas.EQ.1) WRITE(*,*) 'mgo_coord_no_mot> first calculation of isotropic and anisotropic CN for MgO substrate'

!$OMP PARALLEL DEFAULT(SHARED)
!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! Elements on the diagonal
   DO i = 1, natom
      cos_theta(i,i) = 0.d0
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   DO i = 1, natom-1
      DO j = i+1, natom
         !====================================================
         ! Note that here the cosine of theta is always from
         ! 0 to 1. Matrix cos_theta is antisymmetric
         !====================================================
         cos_theta(j,i) = xyz_dist(3,j,i)/ pair_dist(j,i)
         cos_theta(i,j) = -cos_theta(j,i)
      END DO
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   DO i = 1, natom
      DO j = 1, natom
         ! alpha/rc*r(i,j) -alpha
         dij(j,i) = (beta_sub * pair_dist(j,i) ) - alpha_sub
      END DO
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! Elements on the diagonal
   DO i = 1, natom
      mgo_s(i,i) = 0.d0
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,gamma_sub), SCHEDULE(DYNAMIC,20)
   DO i = 1, natom-1
      DO j = i+1, natom

            gamma_sub = exp(dij(j,i))

            ! The sum of these s(i,j) is the analytic coord no.
            mgo_s(j,i) = 1.d0/(1.d0 + gamma_sub)
            mgo_s(i,j) = mgo_s(j,i)

            ! Derivative of s w.r.t r(i,j)
            ! Use beta_sub or beta_sub_angstrom to have arete(1) or Angstrom as units
            mgo_dS(j,i) = -beta_sub_angstrom * gamma_sub / (gamma_sub+1.d0)**2
            mgo_dS(i,j) = mgo_dS(j,i)

      END DO ! on j
   END DO ! on i
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
  ! mgo_s_mot is antisymmetric
   DO i = 1, natom
      mgo_s_mot(1:natom,i) = mgo_s(1:natom,i) * cos_theta(1:natom,i)
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! LP: Calculating the sum of s(i,j), which is mgo_cn(i), global.
   ! This is the coord num of any single atom i
   ! No problem because s(i,i) is always zero
   ! The sum can be done on any index because mgo_s is a symmetric matrix
   DO i = 1, natom
      mgo_cn(i) = SUM(mgo_s(1:natom,i))
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! LP: Calculating the sum of s(i,j), which is mgo_CN(i), global.
   ! This is the coord num of any single atom i
   ! No problem because s(i,i) is always zero
   ! This time the sum should be done on the second index,
   ! because mgo_s_mot is antisymmetric, but if I
   ! multiply by -1 I can sum on the first index
   DO i = 1, natom
      mgo_cn_mot(i) = -SUM(mgo_s_mot(1:natom,i))
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,comfactor), SCHEDULE(STATIC)
   !-------------------------------------------------------------------------
   ! ISOTROPIC CN
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE. i) THEN
            ! Calculating the derivative of coordination number with
            ! respect to distance between atoms i and j, multiplied for
            ! the derivative of distance between atoms i and j
            ! with respect to position of atom i
            comfactor  = mgo_dS(j,i)/ pair_dist(j,i)
            df_dx(j,i) = comfactor * xyz_dist(1,j,i) ! Here there should be a minus, but later on [*] I will omit another one
            df_dy(j,i) = comfactor * xyz_dist(2,j,i) ! Here there should be a minus, but later on [*] I will omit another one
            df_dz(j,i) = comfactor * xyz_dist(3,j,i) ! Here there should be a minus, but later on [*] I will omit another one
         ELSE
            df_dx(j,i) = 0.d0
            df_dy(j,i) = 0.d0
            df_dz(j,i) = 0.d0
         END IF
      END DO
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,comfactor), SCHEDULE(STATIC)
   !-------------------------------------------------------------------------
   ! ANISOTROPIC CN
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE. i) THEN
            ! Calculating the derivative of coordination number with
            ! respect to distance between atoms i and j, multiplied for
            ! the derivative of distance between atoms i and j
            ! with respect to position of atom i
            comfactor = xyz_dist(3,j,i) /pair_dist(j,i)**3

            df_mot_dx(j,i) = df_dx(j,i) *cos_theta(j,i) + mgo_s(j,i)*(comfactor *xyz_dist(1,j,i))
            df_mot_dy(j,i) = df_dy(j,i) *cos_theta(j,i) + mgo_s(j,i)*(comfactor *xyz_dist(2,j,i))
            df_mot_dz(j,i) = df_dz(j,i) *cos_theta(j,i) + mgo_s(j,i)*(comfactor *xyz_dist(3,j,i) -1.d0/pair_dist(j,i))
         ELSE
            df_mot_dx(j,i) = 0.d0
            df_mot_dy(j,i) = 0.d0
            df_mot_dz(j,i) = 0.d0
         END IF
      END DO
   END DO
!$OMP END DO

!$OMP SECTIONS PRIVATE(i)
!$OMP SECTION
   DO i = 1, natom
      ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i).
      ! df_dx is antisymmetric. The sum should be done on the second index, but a minus has
      ! been introduced previously (in [*]).
      mgo_dcn_dx(i) = SUM(df_dx(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      mgo_dcn_dy(i) = SUM(df_dy(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      mgo_dcn_dz(i) = SUM(df_dz(1:natom, i))
   END DO
!-------------------------------------------
!$OMP SECTION
   DO i = 1, natom
      ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
      ! df_mot_dx is symmetric, no matter what is the index of the sum.
      mgo_dcn_mot_dx(i) = SUM(df_mot_dx(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      mgo_dcn_mot_dy(i) = SUM(df_mot_dy(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      mgo_dcn_mot_dz(i) = SUM(df_mot_dz(1:natom, i))
   END DO
!$OMP END SECTIONS
!$OMP END PARALLEL
   !---------------------------------------------------------------------------
   !t_end = OMP_GET_WTIME()                                     !>>> CPU_TIME
   !! Writing the cpu time for the subroutine                   !>>> CPU_TIME
   !WRITE(500,'(1I10, 4X, 1F10.8)') ipas, t_end -t_start        !>>> CPU_TIME
END SUBROUTINE mgo_coord_no_mot


c=======================================================================
c
c     Integer Random Utilities
c
c     sous-programmes de generateur aleatoires et generateurs de bruit
c     sur des matrices ou vecteurs d'entiers
c
c-----------------------------------------------------------------------
c
c        irns    : Generates an integer single random deviate from a
c                  normal distribution with mean and standard deviation
c
c        irus    : Generates an integer single random deviate from an
c                  uniform distribution with mean and half interval
c
c        idie    : Generates a cast of die (n faces)
c
c        IDIEV   : Generates a vector from a cast of die (n faces)
c
c        IVIRN   : Initializes a vector of integers at an integer
c                  random from a normal distribution
c
c        IVIRU   : Initializes a vector of integers at an integer
c                  random from an uniform distribution
c
c        IMIRN   : Initializes a matrix of integers at an integer
c                  random from an normal distribution
c
c        IMSIRN  : Initializes a symmetric matrix of integers at
c                  an integer random from an normal distribution
c
c        IMIRU   : Initializes a matrix of integers at an integer
c                  random from an uniform distribution
c
c        IMSIRU  : Initializes a symmetric matrix of integers at
c                  an integer random from an uniform distribution
c
c=======================================================================
c
c     function irns
c
c     Generates an integer single random deviate from a
c     normal distribution with mean and standard deviation
c
c=======================================================================
c
c     INPUT :
c            mean   : mean of the normal distribution             double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            irns   : integer from a normal distribution         integer
c
c     CALL   :
c            irn    : Generates a single random deviate from a normal
c                     distribution with mean at zero
c                     and standard deviation at one              integer
c
c-----------------------------------------------------------------------
      function irns ( mean, std )
      implicit none
      integer irns
      double precision mean, std, rn
      irns = int ( rn()*std + mean )
      return
      end
c
c=======================================================================
c
c     function irus
c
c     Generates an integer single random deviate from a
c     normal distribution with mean and half interval
c
c=======================================================================
c
c     INPUT :
c            mean   : mean of the normal distribution             double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            irus   : integer from an uniform distribution       integer
c
c-----------------------------------------------------------------------
c
      function irus ( mean, hint )
      implicit none
      integer irus
      double precision mean, hint
      irus = int ( (rand()-0.5)*2.*hint + mean )
      return
      end
c
c=======================================================================
c
c     function idie
c
c     Generates a cast of die (n faces)
c
c=======================================================================
c
c     INPUT :
c            n      : number of faces of the die                 integer
c
c     OUTPUT :
c            idie   : cast of die                                integer
c
c-----------------------------------------------------------------------
      function idie ( n )
      implicit none
      integer n, idie
      idie = 0
      do while(idie.eq.0)
         idie = int ( rand() * n ) + 1
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IDIEV
c
c     Generates a vector from a cast of die (n faces)
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            n      : number of faces of the die                 integer
c
c     OUTPUT :
c            vect   : nvect cast of die, vector(nvect)           integer
c
c     CALL   :
c        idie    : Generates a cast of die (n faces)
c
c-----------------------------------------------------------------------
c
      SUBROUTINE IDIEV ( nvect, n, vect )
      implicit none
      integer nvect, n, idie, i
      integer vect(*)
      do i=1,nvect
         vect(i) = idie(n)
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IVIRN
c
c     Initializes a vector of integers at a scalar
c     random from a normal distribution
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            mean   : mean of the normal distribution             double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            vnorm  : normal distribution vector(nvect)          integer
c
c     CALL   :
c            irns   : Generates an integer single random deviate from a
c                     normal distribution with mean
c                     and standard deviation
c
c-----------------------------------------------------------------------
c
      SUBROUTINE IVIRN ( nvect, mean, std, vnorm )
c
      implicit none
      integer nvect
      double precision mean, std
      integer vnorm(*)
      integer irns, i
      do i=1,nvect
         vnorm(i) = irns ( mean, std )
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IVIRU
c
c     Initializes a vector of integers at a scalar
c     random from an uniform distribution
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            mean   : mean of the uniform distribution            double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            vunif  : random vector(nvect)                       integer
c
c     CALL   :
c            irus   : Generates an integer single random deviate from an
c                     uniform distribution with mean and half interval
c
c-----------------------------------------------------------------------
c
      SUBROUTINE IVIRU ( nvect, mean, hint, vunif )
      implicit none
      integer nvect
      double precision mean, hint
      integer vunif(*)
      integer i, irus
      do i=1,nvect
         vunif(i) = irus ( mean, hint )
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMIRN
c
c     Initializes a matrix of integers at an integer
c     random from an normal distribution
c
c=======================================================================
c
c     INPUT :
c            nlmat  : number of rows of the matrix mat           integer
c            ncmat  : number of columns of the matrix mat        integer
c            mean   : mean of the uniform distribution            double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            mat    : random matrix as vector (nlmat*ncmat)      integer
c
c     CALL   :
c            irns   : Generates an integer single random deviate from a
c                     normal distribution with mean
c                     and standard deviation
c
c-----------------------------------------------------------------------
      SUBROUTINE IMIRN ( nlmat, ncmat, mean, std, mat )
      implicit none
      integer nlmat, ncmat
      double precision mean, std
      integer mat(nlmat,*)
      integer irns, i,j
      do i=1,ncmat
         do j=1,nlmat
            mat(j,i) = irns ( mean, std )
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMSIRN
c
c     Initializes a symmetric matrix of integers at an integer
c     random from an normal distribution
c
c=======================================================================
c
c     INPUT :
c            nmat   : size of the symmetric matrix mat           integer
c            mean   : mean of the uniform distribution            double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            mat    : random symmetric matrix
c                     vector(nmat*(nmat+1)/2)                    integer
c
c     CALL   :
c            irns   : Generates an integer single random deviate from a
c                     normal distribution with mean
c                     and standard deviation
c
c-----------------------------------------------------------------------
      SUBROUTINE IMSIRN ( nmat, mean, std, mat )
      implicit none
      integer nmat
      double precision mean, std
      integer mat(*)
      integer irns, i,j,k
      k = 0
      do j=1,nmat
         do i=1,j
            k = k + 1
            mat(k) = irns ( mean, std )
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMIRU
c
c     Initializes a matrix of integers at an integer
c     random from an uniform distribution
c
c=======================================================================
c
c     INPUT :
c            nlmat  : number of rows of the matrix mat           integer
c            ncmat  : number of columns of the matrix mat        integer
c            mean   : mean of the uniform distribution            double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            mat    : random matrix as vector (nlmat*ncmat)      integer
c
c     CALL   :
c            irus   : Generates an integer single random deviate from an
c                     uniform distribution with mean and half interval
c
c-----------------------------------------------------------------------
      SUBROUTINE IMIRU ( nlmat, ncmat, mean, hint, mat )
      implicit none
      integer nlmat, ncmat
      double precision mean, hint
      integer mat(nlmat,*)
      integer irus, i,j
      do i=1,ncmat
         do j=1,nlmat
            mat(j,i) = irus ( mean, hint )
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMSIRU
c
c     Initializes a symmetric matrix of integers at an integer
c     random from an uniform distribution
c
c=======================================================================
c
c     INPUT :
c            nmat   : size of the symmetric matrix mat           integer
c            mean   : mean of the uniform distribution            double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            mat    : random symmetric matrix
c                     vector(nmat*(nmat+1)/2)                    integer
c
c     CALL   :
c            irus   : Generates an integer single random deviate from an
c                     uniform distribution with mean and half interval
c
c-----------------------------------------------------------------------
      SUBROUTINE IMSIRU ( nmat, mean, hint, mat )
      implicit none
      integer nmat
      double precision mean, hint
      integer mat(*)
      integer irus, i,j,k
      k = 0
      do j=1,nmat
         do i=1,j
            k = k + 1
            mat(k) = irus ( mean, hint )
         end do
      end do
      return
      end


! Various subroutines for calculating quantities in Roche geometry
module roche
   use real_kind

contains

   ! Calculate the scaled (a = 1) x coordinate of the binary component Jstar.
   ! Internally, all calculations assume m1 > m2, q = m2/m1 < 1 and x1 > 0.
   ! This means that when the mass ratio inverts, the coordinate system changes.
   ! This can be handled entirely automatically, as long as the arguments passed
   ! in are consistent and all functions perform the required coordinate
   ! transformation.
   elemental function calc_scaled_x(m1, m2, Jstar)
   implicit none
   real(double), intent(in) :: m1, m2
   integer, intent(in) :: Jstar
   real(double) :: calc_scaled_x
   real(double) :: q
   integer :: n

   q = m2 / m1
   n = Jstar
   if (q > 1.0d0) then
      q = m1 / m2
      n = 3 - Jstar
   end if

   if (n == 1) then
      calc_scaled_x = q / (1.0d0 + q)
   else
      calc_scaled_x = -1.0d0 / (1.0d0 + q)
   end if
   end function calc_scaled_x

   elemental function calc_scaled_potential(m1, m2, x, y, z)
   implicit none
   real(double), intent(in) :: m1, m2, x, y, z
   real(double) :: calc_scaled_potential
   real(double) :: q, xx, qrat, yz2

   q = m2 / m1
   xx = x
   if (q > 1.0d0) then
      q = 1.0d0 / q
      xx = 1.0d0 - x
   end if

   qrat = 1.0d0 / (1.0d0 + q)
   yz2 = y**2 + z**2
   calc_scaled_potential = qrat * (1.0d0/sqrt((x - q*qrat)**2+yz2) + q / sqrt((x+qrat)**2+yz2)) + 0.5d0*(x**2+y**2)
   end function calc_scaled_potential

   elemental function calc_scaled_xl1(m1, m2)
   implicit none
   real(double), intent(in) :: m1, m2
   real(double) :: calc_scaled_xl1
   real(double) :: q,q1,q2,q3,q4,q5,q6,xl1
   integer :: ij

   q = m1 / m2
   if ( q < 1.0d0 ) q = 1.0d0/q
   q5 = 1.0d0 + q
   xl1 = (q/(3.0d0*q5))**(1.0d0 / 3.0d0)
   q3 = 3.0d0 + q
   q2 = q + q
   q4 = 3.0d0 + q2
   q1 = 2.0d0 + q
   q6 = 1.0d0/q5
  ! Newton-Raphson iteration for L1
   do ij = 1, 4
     xl1 = xl1 + &
          (q - xl1*(q2 - xl1*(q - xl1*(q3 - xl1*(q4 - xl1*q5)))))&
          /(q2 - xl1*(q2 - xl1*(3.0d0*q3 - xl1*(4.0d0*q4 - xl1*5.0d0*q5))))
   end do
   calc_scaled_xl1 = q6 - xl1
   end function calc_scaled_xl1

   elemental function calc_scaled_xl2(m1, m2)
   implicit none
   real(double), intent(in) :: m1, m2
   real(double) :: calc_scaled_xl2
   real(double) :: q,q1,q2,q3,q4,q5,q6,xl1,xl2
   integer :: ij

   q = m1 / m2
   if ( q < 1.0d0 ) q = 1.0d0/q
   q5 = 1.0d0 + q
   xl1 = (q/(3.0d0*q5))**(1.0d0 / 3.0d0)
   xl2 = 2.0d0 - q*xl1/q5
   q3 = 3.0d0 + q
   q2 = q + q
   q4 = 3.0d0 + q2
   q1 = 2.0d0 + q
   q6 = 1.0d0/q5
  ! Newton-Raphson iteration for L2
   do ij = 1, 4
     xl2 = xl2 + &
          (q - xl2*(q2 - xl2*(q1 - xl2*(q3 - xl2*(q4 - xl2*q5)))))&
          /(q2 - xl2*(2.0d0*q1 - xl2*(3.0d0*q3 - xl2*(4.0d0*q4 - xl2*5.0d0*q5))))
   end do
   calc_scaled_xl2 = q6 - xl2
   end function calc_scaled_xl2

   ! Calculate the correction factor for the cross section of the mass flow at level surface xx (dimensionless, L1=0, L2=1)
   elemental function stream_cross_section_primary(q, xx)
      use real_kind
      implicit none
      real(double), intent(in) :: q, xx
      real(double) :: stream_cross_section_primary
      real(double) :: a, b, c, d

      a = 4.50d-4 + (3.68d-4 + 3.15d-4 * q) * q
      if (q < 0.3d0) then
         b = 2.32d0 + (-1.31d0 + 2.87d0 * q) * q
      else
         b = 2.21d0 + 0.238d0 * q
      end if
      c = q * (1.22d0 + q*(-1.22d0 + q*0.564d0))
      d = 0.323d0 * q**0.230d0 - 7.39d-2

      stream_cross_section_primary = (c * xx + a)**b + d * xx
   end function stream_cross_section_primary

   ! Calculate the correction factor for the cross section of the mass flow at level surface xx (dimensionless, L1=0, L2=1)
   elemental function stream_cross_section_secondary(q, xx)
      use real_kind
      implicit none
      real(double), intent(in) :: q, xx
      real(double) :: stream_cross_section_secondary
      real(double) :: a, b, c, d

      a = 9.53d-4 * q**0.501d0 + 1.65d-4
      b = 3.25d-1 * q**0.326d0 + 2.03d0
      c = 6.33d-1 * q**0.271d0 - 7.18d-2
      d = 2.30d-1 * q**0.361d0 + 1.89d-2

      stream_cross_section_secondary = (c * xx + a)**b + d * xx
   end function stream_cross_section_secondary

   !> \brief Compute the Roche-lobe radius Rl/a
   !!
   !! \param x  q^(1/3)
   elemental function rlobe(x)
      use real_kind
      use constants

      implicit none
      real(double), intent(in) :: x
      real(double) :: rlobe,x2

      x2 = x**2
      rlobe = 0.49_dbl*x2 / (0.6_dbl*x2 + log(1.0_dbl + x))
   end function rlobe

end module


program test
  use CountingSort
  implicit none

  integer, parameter :: n = 100, max_age = 140

  real, dimension(n) :: t
  integer, dimension(n) :: ages

  call random_number(t)
  ages = floor(t * max_age)

  call counting_sort(ages, 0, max_age)

  write(*,'(I4)') ages

end program test