!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cold plasma dispersion relation. Appleton-Hartree display.
! Frequency on logarithmic axis, plotting N rather than N^2
! for various angles of propagation theta.
! Variables:
! Frequencies normalized to omegape. omega. omegace (positive) (=>B).
! Species of mass Aj (times electron mass), density nj (times electron den)
! Charge Zj. Electrons have charge -1.
! S = 1 - \sum_j n_j/(Aj*omega^2-Zj^2*omegace^2/Aj)
! D = \sum_j Zj*omegace/(Aj*omega) n_j/(Aj*omega^2-omegace^2/Aj)
! P = 1 - \sum_j n_j/(Aj*omega)^2.
! R = 1 - \sum_j n_j /(Aj*omega*(omega+omegace*Zj/Aj) = S+D
! L = 1 - \sum_j n_j /(Aj*omega*(omega-omegace*Zj/Aj) = S-D
! Propagation angle theta
! A = S*\sin^2 \theta + P*\cos^2 \theta
! B = R*L*\sin^2 \theta + P*S*(1 + \cos^2 \theta )
! C = P*R*L
! F^2 = (RL - PS)^2 \sin^4 \theta + 4 P^2 D^2 \cos^2 \theta
! is the discriminant, and is manifestly positive.
! Solution is
! N^2 = B\pm F/2A. But it is better evaluated as N^2=2C/(B\mp F)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Alternative display of dispersion relation
! N_\perp^2 for various given N_\parallel^2
! Variables:
! Parallel refractive index squared N2a, Perp squared N2e
! A = S
! B = (S-N2a)*(S+P)-D^2
! C = P*[(S-N2a)^2 -D^2]
! F^2 = B^2 -4AC
! is the discriminant, and may be negative, giving complex N2e
! Solution is
! N2e^2 = (B\pm F)/2A.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Non-uniform plasma plot with given Npar uses the alternative display
! but the omegaf is fixed and the omegape varies. We arrive at the same
! calculation by substituting omega=omegaf/omegape, and
! omegace=omegace/omegape. Ensure that no element of omegape is zero!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module coldplasmawaves
implicit none
integer, parameter :: nspecies=2,nomega=2000
integer :: ispecies,i,itheta,ntheta,iw,ipf,iNpar,nNpar=10
integer :: ntp,ntm,ntp2
real, dimension(nspecies) :: nj,Aj,Zj
real :: omegace,omegamax,domce   ! over omegape.
real :: omegfac=0.2              ! Factor for log omega minumum.
real :: N2min,N2max,EyExmax,EzExmax,thetadeg
real, dimension(nomega) :: S,D,P,R,L,A,B,C,F2,resfac,F
real, dimension(nomega) ::  N2P,N2M,omega,X,Y,Nplus,Nminus
real, dimension(nomega) :: EyExP,EzExP,EyExM,EzExM
real :: theta,sintheta,costheta
character*3 sangle
real, external :: wy2ny,wx2nx
! Coldperp and Nomegape extra variables
logical, dimension(nomega) :: logic
real, dimension(nomega) :: omegape=1.,omegapi
logical :: lperp=.false.
integer :: iplottype=1
real :: N2a,Npmax=5,Na,olh,ouh
integer :: colorfast=2,colorslow=1
complex, dimension(nomega) :: CN2P,CN2M
real :: omegaf   ! The fixed frequency for omegape plots, unnormalized
! Control parameters:
character*8 string
character*20 argument
integer :: ikey=0,manyplot=0
real :: izero,xnlower=.17
logical :: lEz=.false.,logx=.true.,logy=.true.,lplotomega=.false.

data Aj/1.,1836./
data Zj/-1.,1./
data nj/1.,1./
contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine evalN2
  S=1. ; D=0.; P=1.
  do ispecies=1,nspecies
     S=S-nj(ispecies)/&
          (Aj(ispecies)*omega**2-Zj(ispecies)**2*omegace**2/Aj(ispecies))
     D=D- (Zj(ispecies)*omegace/(Aj(ispecies)*omega))* nj(ispecies)/&
          (Aj(ispecies)*omega**2-Zj(ispecies)**2*omegace**2/Aj(ispecies))
     P=P- nj(ispecies)/(Aj(ispecies)*omega)**2
  enddo
  R=S+D
  L=S-D
  A=S*sintheta**2+P*costheta**2
  B=R*L*sintheta**2+P*S*(1+costheta**2)
  C=P*R*L
!  F2=(R*L-P*S)**2*sintheta**4+4*P**2*D**2*costheta**2
! Avoid overflows at low frequency by taking sqrt with P factor outside
  F=sqrt((R*L/P-S)**2*sintheta**4+4*D**2*costheta**2)*abs(P)
  ! Explicit Sign flips at omega= omegac
  N2P=2.*C/(B-sign(1.,(1.-omega/omegace)*(omega*Aj(2)/omegace-1))*F)
  N2M=2.*C/(B+sign(1.,(1.-omega/omegace)*(omega*Aj(2)/omegace-1))*F)
  EyExP=D/(N2P-S)
  EyExM=D/(N2M-S)
  EzExP=N2P*sintheta*costheta/(N2P*sintheta**2-S)
  EzExM=N2M*sintheta*costheta/(N2M*sintheta**2-S)
  if(lplotomega)then
     N2P=N2P*omega**2
     N2M=N2M*omega**2
  endif
  Nplus=sign(1.,N2P)*sqrt(abs(N2P))
  Nminus=sign(1.,N2M)*sqrt(abs(N2M))
end subroutine evalN2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine evalNperp2
  ! omega, and omegace here are normalized to omegap
  S=1. ; D=0.; P=1.
  do ispecies=1,nspecies
     S=S-nj(ispecies)/&
          (Aj(ispecies)*omega**2-Zj(ispecies)**2*omegace**2/Aj(ispecies))
     D=D- (Zj(ispecies)*omegace/(Aj(ispecies)*omega))* nj(ispecies)/&
          (Aj(ispecies)*omega**2-Zj(ispecies)**2*omegace**2/Aj(ispecies))
     P=P- nj(ispecies)/(Aj(ispecies)*omega)**2
  enddo
  R=S+D
  L=S-D
  A=S
  B=(S-N2a)*(S+P)-D**2
  C=P*((S-N2a)**2-D**2)
  F2=B**2-4.*A*C
  resfac=1.
  CN2P=(B*resfac+sqrt(F2*resfac**2))/(2.*A*resfac)
  CN2M=(B*resfac-sqrt(F2*resfac**2))/(2.*A*resfac)
  where(F2.lt.0)
     N2P=0.
     N2M=0.
  elsewhere(real(CN2P).gt.real(CN2m))
     N2P=real(CN2P)
     N2M=real(CN2M)
  elsewhere
     N2P=real(CN2M)
     N2M=real(CN2P)
  endwhere
end subroutine evalNperp2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine evalNperpop
  ! omegape, and omegace here are unnormalized; so should be omegaf.
  S=1. ; D=0.; P=1.
  do ispecies=1,nspecies
     S=S-nj(ispecies)/ &
          (Aj(ispecies)*(omegaf/omegape)**2 &
             -Zj(ispecies)**2*(omegace/omegape)**2/Aj(ispecies))
     D=D- (Zj(ispecies)*omegace/(Aj(ispecies)*omegaf))* nj(ispecies)/&
          (Aj(ispecies)*(omegaf/omegape)**2 &
             -Zj(ispecies)**2*(omegace/omegape)**2/Aj(ispecies))
     P=P- nj(ispecies)/(Aj(ispecies)*(omegaf/omegape))**2
  enddo
  R=S+D
  L=S-D
  A=S
  B=(S-N2a)*(S+P)-D**2
  C=P*((S-N2a)**2-D**2)
  F2=B**2-4.*A*C
  resfac=1.
  CN2P=(B*resfac+sqrt(F2*resfac**2))/(2.*A*resfac)
  CN2M=(B*resfac-sqrt(F2*resfac**2))/(2.*A*resfac)
  where(F2.lt.0)
     N2P=0.
     N2M=0.
  elsewhere(real(CN2P).gt.real(CN2m))
     N2P=real(CN2P)
     N2M=real(CN2M)
  elsewhere
     N2P=real(CN2M)
     N2M=real(CN2P)
  endwhere
end subroutine evalNperpop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Various utilities
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine initialize ! Only the scope and omega arrays.
  if(logx)then
     omega(1)=omegfac*omegamax/nomega
  else
     omega(1)=omegamax/nomega
  endif
  izero=nomega*alog(omega(1))/alog(omegamax/omega(1))
  do i=2,nomega
     if(logx)then
        omega(i)=omega(1)*exp(alog(omegamax/omega(1))*(i-1.)/(nomega-1.))
     else
        omega(i)=i*omega(1)   !linear
     endif
  enddo
end subroutine initialize
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine initomegape
  ! When doing omegape plots, interpret omegamax as the
  ! maximum of omegapi/omegaf but omegapi is not normalized.
  omegaf=sqrt(Aj(1)/Aj(2))
  if(logx)then
     omegapi(1)=omegfac*omegamax*omegaf/nomega
  else
     omegapi(1)=omegamax*omegaf/nomega
  endif
  do i=2,nomega
     if(logx)then
        omegapi(i)=omegapi(1)  &
             *exp(alog(omegamax*omegaf/omegapi(1))*(i-1.)/(nomega-1.))
     else
        omegapi(i)=i*omegapi(1)   !linear
     endif
  enddo
  ! The calculation is done in terms of omegape.
  omegape=omegapi*sqrt(Aj(2)/Aj(1))                  ! Unnormalized.
end subroutine initomegape
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine markatomega(om,frac,trace,yinc,mychar)
  real om,frac,yinc
  real, dimension(nomega) :: trace
  character*(*) mychar
  real, external :: wx2nx,wy2ny
  i=iatomega(om)
  if(i.le.nomega.and.i.gt.0)call jdrwstr(wx2nx(omega(i)),wy2ny(trace(i))+yinc,mychar,frac)
end subroutine markatomega
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer function iatomega(om)
  real om
  if(logx)then  !This switch does not work without consistency
     iatomega=1+int(alog(om/omega(1))/alog(omegamax/omega(1))*(nomega-1.))
  else
     iatomega=int(om/omega(1))
  endif
end function iatomega
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine savesettings
  open(13,file='coldplas.input',status='unknown')
  write(13,'(4f10.5,i4)')omegace,omegamax,N2min,N2max,ntheta
  write(13,*)ipf
  write(13,*)' #omegace,omegamax,N2min,N2max,ntheta, // ipf'
  write(13,*)' key    k,l y-range; s,d x-range; r,e B-value'
  close(13)
end subroutine savesettings
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine readsettings
  open(12,file='coldplas.input',status='old',err=2)
  read(12,*,end=2,err=2)omegace,omegamax,N2min,N2max,ntheta
  write(*,'(a,4f10.3,i4)')'Read parameters',omegace,omegamax,N2min,N2max,ntheta
  read(12,*,end=2,err=2)ipf
2 continue
  close(12)
! Parse commandline arguments, single characters passed to uif.
  do i=1,iargc()
     call getarg(i,argument)
     ikey=ichar(argument(1:1))
     call uif(ikey)                    ! Perform possible key action
  enddo
  if(ipf.ne.0)write(*,*)'Nonstop plotting',ipf
  if(ikey.ne.0)call savesettings    ! If key was a valid command
! Decide default plot ranges.
  if(.not.logx)then; omegamax=3.5;
  else; omegamax=5.001 ; if(iplottype.eq.3)omegamax=20.00001
  endif
  if(logy)then; N2min=1.e-1; N2max=2000. ; if(iplottype.eq.3)N2max=200000
  else; N2min=-1. ; N2max=10. ;
  endif
end subroutine readsettings
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine findresonances
   implicit none
! Ensure correct plotting of resonances by adjusting at gaps.
   ntm=nomega
   ntp=nomega
   do i=3,nomega ! Find the resonance gaps for plotting, annotation.
      if(N2P(i-1).gt.1. .and. N2P(i).lt.1..and.omega(i-1).le.1) ntp=i
      if(N2M(i-1).gt.1. .and. N2M(i).lt.1..and.omega(i-1).le.1) ntm=i
      if(Nminus(i-1).gt.0.and.Nminus(i).lt.0.)Nminus(i-1)=N2max
      if(Nminus(i-1).lt.N2min.and.Nminus(i).gt.N2min)Nminus(i)=N2min
      if(Nplus(i-1).gt.0.and.Nplus(i).lt.0)Nplus(i-1)=N2max
      if(Nplus(i-1).lt.N2min.and.Nplus(i).gt.N2min)Nplus(i)=N2min
   enddo
 end subroutine findresonances
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! User interface
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine uif(iw)
! User interface routine
  integer :: iw
if(manyplot.eq.0)call pfset(0) ! By default each new plot is not printed
if(iw.eq.ichar('r'))then
   if(domce.lt..034*omegace)domce=domce*5.
   omegace=omegace+domce
elseif(iw.eq.ichar('e'))then
   if(domce.gt..32*omegace)domce=domce/5.
   if(omegace.gt.1.e-3)omegace=omegace-domce
elseif(iw.eq.ichar('p'))then
   call pfset(3)
elseif(iw.eq.ichar('h'))then
   write(*,*)'Usage coldplas [<key> ... ]'
   write(*,*)'Keyboard and command line graph-control keys as follows'
   write(*,*)'Y-RANGE SHIFT: up/k down/l; X-RANGE: left/s right/d'
   write(*,*)'Y-RANGE EXPAND:u CONTRACT:i; X-RANGE (log) EXPND:n CNTRCT:m'
   write(*,*)'B-VALUE e=decrs r=incrs; SAVE settings: v,'
   write(*,*)'POLARIZATION toggle from Ey/Ex to Ez/Ex: z'
   write(*,*)'LOGARITHMIC axes toggle: x, y.',' NPERP/NTOT plot cycle: -'
   write(*,*)'ORDINATE plotting toggle from N to k: o'
   write(*,*)'WAIT at end of plotting: w, NO-WAIT: a,',' TELL parameters: t'
   write(*,*)'PRINT plot: p, EVERY FRAME print (movie) toggle: .'
   write(*,*)'QUIT: q, return, or single left click in window.'
elseif(iw.eq.65362.or.iw.eq.ichar('k'))then
   N2max=2.*N2max
   N2min=2.*N2min
elseif(iw.eq.65364.or.iw.eq.ichar('l'))then
   N2max=N2max/2.
   N2min=N2min/2.
elseif(iw.eq.65361.or.iw.eq.ichar('s'))then
   if(logx)then
      if(omegamax.gt.0.02*omegace)omegamax=omegamax/2.
   else
      if(omegamax.gt.0.0001*omegace)omegamax=omegamax/2.
   endif
elseif(iw.eq.65363.or.iw.eq.ichar('d'))then
   if(logx)then
      if(omegamax.lt.10.*omegace)omegamax=omegamax*2.
   else
      if(omegamax.lt.3.*omegace)omegamax=omegamax*2.
   endif
elseif(iw.eq.ichar('n'))then
   if(omegfac.gt.1.e-4)omegfac=omegfac/2.
elseif(iw.eq.ichar('m'))then
   if(omegfac.lt.1.e2)omegfac=omegfac*2.
elseif(iw.eq.ichar('u'))then
   N2min=N2min/2.
elseif(iw.eq.ichar('i'))then
   N2min=N2min*2.
elseif(iw.eq.ichar('w'))then
   ipf=abs(ipf)
elseif(iw.eq.ichar('a'))then
   ipf=-3
elseif(iw.eq.ichar('z'))then
   lEz=.not.lEz
elseif(iw.eq.ichar('x'))then
   logx=.not.logx
elseif(iw.eq.ichar('o'))then
   lplotomega=.not.lplotomega
elseif(iw.eq.ichar('y'))then
   logy=.not.logy
   if(logy)then
      N2min=.1;   N2max=2000.; if(iplottype.eq.3)N2max=200000
   else
      if(lperp)then; N2max=600.;N2min=-60.
      else; N2min=-1.; N2max=10.;endif
   endif
elseif(iw.eq.ichar('c'))then
   omegace=2.5
   omegamax=5.0001; if(iplottype.eq.3)omegamax=20.00001
   N2min=1.e-1
   N2max=8000.
elseif(iw.eq.ichar('v'))then
   call savesettings
elseif(iw.eq.ichar('-').or.iw.eq.189)then
   iplottype=mod(iplottype,3)+1
   if(iplottype.eq.1)then
      lperp=.false.
   else
      lperp=.true.
   endif
   if(iplottype.eq.3)omegamax=20.00001
elseif(iw.eq.ichar('q').or.iw.eq.65293)then
   iw=0
elseif(iw.eq.ichar('t'))then
   write(*,*)'  omegace, omegamax, N2min,   N2max,  ntheta  current values'
   write(*,'(4f10.4,i4)')omegace,omegamax,N2min,N2max,ntheta
elseif(iw.eq.ichar('.'))then
   manyplot=mod(manyplot+1,2)
else
   write(*,*)'key number=',iw,' not recognized'
endif
!   write(*,*)'iw number=',iw
end subroutine uif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Plotting and Annotating
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine annotationN2
  implicit none
  real :: ynorm,oalfven
  real, external :: wx2nx,wy2ny
  ! Annotations
  call color(15)
  if(Nminus(ntm-40).lt.N2max*(1.-(100-thetadeg)*.002) &
        .and.ntm.lt.nomega)then
      if(nint(thetadeg).eq.90)then
         call jdrwstr(wx2nx(omega(ntm-1)), &
              wy2ny(N2max)-.002*(100-thetadeg),'!Aq!@='//sangle,0.)
         call charangl(90.)
         if(omega(ntm-1).lt.omegamax.and.wx2nx(omega(ntm-1)).gt.xnlower) &
              call jdrwstr(wx2nx(omega(ntm-1)), &
              wy2ny(N2max)-.002*(100-thetadeg),'Lower Hybrid',-1.5)
         call charangl(0.)
      else
         call jdrwstr(wx2nx(omega(ntm-1)), &
              wy2ny(N2max)-.002*(100-thetadeg),sangle,0.)
      endif
   endif
   if(nint(thetadeg).eq.90)then
      if(omegace.gt.1.02)call markatomega(1.03*omegace,0.,Nplus,-0.014,'E')
      call markatomega(omegace*(1+sqrt(1+4./omegace**2))/2.+.1,&
           0.,Nplus,.01,'E')
      call markatomega(.98*sqrt(omegace**2+1.),1.,N2P,0.0,'!Aw!@!duh!d')
      call markatomega(.98*sqrt(omegace**2+1.),1.,N2P,.02,'!A}!@')
      if(omegace.gt.1.02)call markatomega((2.*omegace+1.)/3.5,-0.1,N2M,-.005,'O')
      call markatomega(.85,0.,N2P,0.01,'E')
!      call markatomega(.85,0.,N2M,0.01,'O')
      call vecw(1.,N2min,0)
      call vecw(1.,N2max,1)
      call vecw(omega(1),0.,0)
      call vecw(omegamax,0.,1)
      ynorm=wy2ny(N2min)+.035
      call jdrwstr(wx2nx(omegace),ynorm,'!AW!@',0.)
      call jdrwstr(wx2nx(omegace),ynorm-.022,'!A{!@',0.)
      call jdrwstr(wx2nx(omegace),ynorm+.022,'!A}!@',0.)
      if(omegace/Aj(2).ge.omega(2))then
         call jdrwstr(wx2nx(omegace/Aj(2)),ynorm,'!AW!@!di!d',0.)
         call jdrwstr(wx2nx(omegace/Aj(2)),ynorm-.022,'!A{!@',0.)
         call jdrwstr(wx2nx(omegace/Aj(2)),ynorm+.022,'!A}!@',0.)
      endif
   elseif(abs(thetadeg).lt.1)then
      if(omegace.gt.1.02)call markatomega((omegace+1.3)/2.,-1.,Nplus,0.01,'R')
      call markatomega(1.+.1*omegace,-0.02,Nminus,-.002,'L')
      if(wx2nx(omegace/Aj(2)).gt.xnlower) &
           call markatomega(0.7*omegace/Aj(2),1.2,Nplus,0.,'L')
!      call markatomega(sqrt(omegace**2+1.),-2.,N2P,0.,'R')
      call markatomega(.85,0.,Nplus,-0.01,'L')
      call markatomega(.25,-1.,Nminus,-0.01,'R')
      call markatomega(omegace*(1+sqrt(1+4./omegace**2))/2.,&
           .75,N2P,.033,'!A{!@!Aw!@!dR!d')
      call markatomega((-(1-Aj(1)/Aj(2))*omegace &
           +sqrt(omegace**2*(1+Aj(1)/Aj(2))**2+4.*(1+Aj(1)/Aj(2))))/2.,&
           -.75,N2P,.033,'!Aw!@!dL!d!A{!@') ! Left cut needs ion corrections
      call charangl(90.)
         if(logx.or.omegamax.lt.4.)then
            call charangl(70.)
            call markatomega(.08*min(1.,omegace),1.,Nminus,0.,' Helicon or')
            call markatomega(.14*min(1.,omegace),1.,Nminus,0.,' Whistler Branch')
            call charangl(90.)
         endif
      if(omegace.ge.1.)then
         if(wy2ny(N2max).gt.wy2ny(2.)+.33) &
              call markatomega(.6,2.,Nminus,0.,'!Aw!@!dp!dcos!Aq!B{!@')
      else
         call markatomega(.5*omegace,1.,Nminus,0.,' Electron cyclotron waves')
      endif
      if(wx2nx(omegace/Aj(2)).gt.xnlower)then
         call markatomega(0.8*omegace/Aj(2),1.2,Nplus,0.,'Ion cyclotron waves')
      endif
      oalfven=omega(1)+.05*omegace/Aj(2)
      if(wx2nx(oalfven).gt.xnlower)then
         call markatomega(oalfven,-1.,Nminus,0.,'Alfven !A_!@')
         call markatomega(oalfven,1.5,Nminus,0.,'Shear Alfven')
      endif
      if(wx2nx(omegace/250).gt.xnlower)then
!         call markatomega(omegace/250.,-1.,Nminus,0.,'Whistlers !A_!@')
         call charangl(0.)
         if(lplotomega)then
            call markatomega(omegace/200.,1.,Nminus,-0.01,'Whistlers')
         else
            call markatomega(omegace/200.,-1.,Nminus,-0.01,'Whistlers')
         endif
      endif
      call charangl(0.)
   endif
 end subroutine annotationN2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine annotationperp
   external wy2ny,wx2nx
   real wy2ny,wx2nx,ynorm
   ynorm=wy2ny(N2min)+.035
   ouh=sqrt(omegace**2+1.)
   call jdrwstr(wx2nx(ouh),ynorm,'!Aw!@!duh!d',1.2)
   call jdrwstr(wx2nx((-(1-Aj(1)/Aj(2))*omegace &
        +sqrt(omegace**2*(1+Aj(1)/Aj(2))**2+4.*(1+Aj(1)/Aj(2))))/2.),&
        ynorm,'!Aw!@!dL!d!A{!@',-.75)
   call jdrwstr(wx2nx(ouh),ynorm,'!A}!@',0.)
   call jdrwstr(wx2nx(omegace),ynorm,'!AW!@',-1.5)
   call jdrwstr(wx2nx(omegace),ynorm-0.012,'!A{!@',0.)
   call jdrwstr(wx2nx(omegace),ynorm+0.012,'!A}!@',0.)
   if(omegace/Aj(2).ge.omega(2))then
      call jdrwstr(wx2nx(omegace/Aj(2)),ynorm,'!AW!@!di!d',0.)
      call jdrwstr(wx2nx(omegace/Aj(2)),ynorm-.022,'!A{!@',0.)
      call jdrwstr(wx2nx(omegace/Aj(2)),ynorm+.022,'!A}!@',0.)
   endif
   ! Lower hybrid frequency for single ion species.
   olh=((1.+Aj(1)/Aj(2))+omegace**2*(1+(Aj(1)/Aj(2))**2))/2.
   olh=olh-sqrt((((1.-Aj(1)/Aj(2))+omegace**2*(1-(Aj(1)/Aj(2))**2))/2.)**2&
        +1./Aj(2))
   olh=sqrt(olh)
   call jdrwstr(wx2nx(olh),ynorm,'!A}!@',0)
   call drcstr('!Aw!@!dLH!d')
   call color(colorslow)
   call polyline((/ouh,ouh/),(/N2min,N2max/),2)
   call polyline((/olh,olh/),(/N2min,N2max/),2)
   call color(15)
 end subroutine annotationperp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine annotateNomegape
   external wy2ny,wx2nx
   real wy2ny,wx2nx,ynorm
   real ogc,oin,opeeqom
   real Rde,Rdi
   ynorm=wy2ny(N2min)+.035
   ogc=omegace/omegaf*sqrt(Aj(1)/Aj(2))
   oin=omegace/omegaf*Aj(1)/Aj(2)
   opeeqom=sqrt(Aj(1)/Aj(2))
   ! Lower hybrid frequency for single ion species. Solving for omegapi
   ! at given omega. omegapi^2=Rde*Rdi/(Rde+Aj(2)/Aj(1)*Rdi) where
   ! Rde,i = (omega^2-Omegae,i^2). Then one must normalize by omegaf.
   Rde=omegaf**2-omegace**2
   Rdi=omegaf**2-(omegace*Aj(1)/Aj(2))**2
   olh=Rde*Rdi/(Rde+Rdi*Aj(2)/Aj(1))
   olh=sqrt(olh)/omegaf ! This becomes nan and suppresses plotting when needed
   call color(colorslow)
   call polyline((/olh,olh/),(/N2min,N2max/),2)
   call color(15)
!   write(*,*)ogc,omegace,omegaf,olh
   call jdrwstr(wx2nx(ogc),ynorm,'!A}!@',0)
   call drcstr('(!AW!@!di!d!AW!@!de!d)!u1/2!u/!Aw!@')
   call jdrwstr(wx2nx(oin),ynorm,'!A}!@',0)
   call drcstr('!AW!@!di!d/!Aw!@')
   call jdrwstr(wx2nx(opeeqom),ynorm+.035,'!A{!@',0)
   call jdrwstr(wx2nx(opeeqom),ynorm+.035,'!Aw!@!dpe!d/!Aw!@=1',-1.1)
   call jdrwstr(wx2nx(olh),ynorm+.07,'!A{!@',0)
   call jdrwstr(wx2nx(olh),ynorm+.07,'!Aw!@!dLH!d/!Aw!@=1',-1.1)

 end subroutine annotateNomegape
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine plotthesolutions(EyExmax,EzExmax)
   real :: EyExmax,EzExmax
   if(lEz)then
      call polycolorgapline(omega,Nplus,nomega, &
           int(1+min(.99,abs(EzExP)/EzExmax)*240.),Nplus.ge.0.)
      if(.not.logy)call polycolorgapline(omega,Nplus,nomega, &
           int(1+min(.99,abs(EzExP)/EzExmax)*240.),Nplus.le.0.5)
      call polycolorgapline(omega,Nminus,nomega, &
           int(1+min(.99,abs(EzExM)/EzExmax)*240.),Nminus.ge.0)
      if(.not.logy)call polycolorgapline(omega,Nminus,nomega, &
           int(1+min(.99,abs(EzExM)/EzExmax)*240.),Nminus.le.0.5)
   else
      call polycolorgapline(omega,Nplus,nomega, &
           int(1+min(.99,abs(EyExP)/EyExmax)*240.),Nplus.ge.0.)
      if(.not.logy)call polycolorgapline(omega,Nplus,nomega, &
           int(1+min(.99,abs(EyExP)/EyExmax)*240.),Nplus.le.0.5)
      call polycolorgapline(omega,Nminus,nomega, &
           int(1+min(.99,abs(EyExM)/EyExmax)*240.),Nminus.ge.0)
      if(.not.logy)call polycolorgapline(omega,Nminus,nomega, &
           int(1+min(.99,abs(EyExM)/EyExmax)*240.),Nminus.le.0.5)
   endif
 end subroutine plotthesolutions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine setupplots
   call axregion(.15,.88,.1,.7)
   call pltinit(0.,omega(nomega),N2min,N2max)
   call color(15)
   call charsize(.018,.018)
   if(.not.lperp)then
      call gradlegend(0.,EyExmax,1.04,0.,1.04,1.,.01,.true.)
      if(lEz)then
         call legendline(1.045,0.45,258,'|E!dz!d/E!dx!d|')
      else
         call legendline(1.045,0.45,258,'|E!dy!d/E!dx!d|')
      endif
   endif
   call scalewn(omega(1),omega(nomega),N2min,N2max,logx,logy)
   call axis()
   call axis2
   if(lplotomega)then
      if(lperp)then
         call axlabels('!Aw!@/!Aw!@!dp!d','k!d!A`!@!dc/!Aw!@!dp!d')
      else
         call axlabels('!Aw!@/!Aw!@!dp!d','kc/!Aw!@!dp!d')
      endif
      if(N2min.lt.0.)then
         call jdrwstr(0.08,wy2ny(0.97*N2min+0.03*N2max),'-|k!u2!u|!u1/2!u',0.)
         call jdrwstr(0.08,wy2ny(0.97*N2min+0.03*N2max)-.01,'_______',0.)
         call jdrwstr(0.08,wy2ny(0.97*N2min+0.03*N2max)-.033,'!Aw!@!dp!d/c',0.)
      endif
   else
      if(lperp)then
         call axlabels('!Aw!@/!Aw!@!dp!d','N!d!A`!@!d')
         if(N2min.lt.0.)call jdrwstr(0.15,wy2ny(0.)-.035, &
           '-|N!d!A`!@!d!u2!u|!u1/2!u',-1.1)
      else
         call axlabels('!Aw!@/!Aw!@!dp!d','N')
         if(N2min.lt.0.)call jdrwstr(0.15,wy2ny(0.97*N2min+0.03*N2max), &
           '-|N!u2!u|!u1/2!u',0.-1.1)
      endif
   endif
 end subroutine setupplots
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine setupomegape
   call axregion(.15,.88,.1,.7)
   call pltinit(0.,omegapi(nomega),N2min,N2max)
   call color(15)
   call charsize(.018,.018)
   call scalewn(omegapi(1),omegapi(nomega),N2min,N2max,logx,logy)
   call axis()
   call axis2
   call axlabels('!Aw!@!dpi!d/!Aw!@','N!d!a`!@!d')
   if(N2min.lt.0.)call jdrwstr(0.15,wy2ny(0.)-.035, &
        '-|N!d!A`!@!d!u2!u|!u1/2!u',-1.1)
 end subroutine setupomegape
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine plotNs
  call setupplots
  call boxtitle('!Aq!@=0: !p!n-!n!qRight-hand, !p!n-!n!qLeft-hand;'// &
      '!Aq!@=90: !p!n-!n!qOrdinary, !p!n-!n!qExtraordinary')
  call winset(.true.)
  do itheta=1,ntheta
     theta=3.1415926*(itheta-1.)/(ntheta-1.)/2.
     sintheta=sin(theta) ; costheta=cos(theta)
     thetadeg=180.*theta/3.1415926
     write(sangle,'(i2)')nint(thetadeg)
     call evalN2
     call findresonances
     call plotthesolutions(EyExmax,EzExmax)
     call color(15)
     call annotationN2 ! Must be after findresonances
  enddo
  call prtend('')
end subroutine plotNs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine plotNperps
  real dxa,dya,xleg
  call setupplots
  call boxtitle('N!d!A`!@!d for N!d!A|!@!d given by line labels')
  call winset(.true.)
  call color(15)
  if(.not.logy)call polyline((/omega(1),omega(nomega)/),(/1.,1./),2)
  call annotationperp
  do iNpar=1,nNpar
     Na=(Npmax*(iNpar)/(nNpar))
     N2a=Na**2
     thetadeg=45.
     call evalNperp2
     call color(15)
     call fwrite(Na,iw,1,string)
     logic=.true.
     where(F2.le.0. .and. cshift(F2,1).gt.0.)
        N2P=0.5*(cshift(N2P,1)+cshift(N2M,1))
        N2M=N2P
     elsewhere(F2.le.0. .and. cshift(F2,-1).gt.0.)
        N2P=0.5*(cshift(N2P,-1)+cshift(N2M,-1))
        N2M=N2P
     elsewhere(F2.le.0. &
          .or. cshift(N2M,-1)*N2M.lt.-10. &
          .or. cshift(N2M,1)*N2M.lt.-10. &
          )
        logic=.false.
     end where
     call color(colorslow)
     call polygapline(omega,N2P,nomega,logic)
     i=(iatomega(olh)+nomega/5-(nomega/16)*mod(1+iNpar,2))
     if(Na.le.1)i=(iatomega(olh)-(nomega/20))
     i=max(min(i,nomega-1),1)
     dxa=wx2nx(omega(i+1))-wx2nx(omega(i))
     dya=wy2ny(N2P(i+1))-wy2ny(N2P(i))
     call charangl(atan2(dya,dxa)*180./3.1415926)
     call jdrwstr(wx2nx(omega(i)),wy2ny(N2P(i)),string,0.5)
     call charangl(0.)
     xleg=0.02
     if(.not.logx.or.olh/omega(1).lt.15.)xleg=0.7
     call legendline(xleg,.95,0,'Slow Wave')

     call color(colorfast)
     call dashset(colorfast)
     call legendline(xleg,.9,0,'Fast Wave')
     call polygapline(omega,N2M,nomega,logic)
     i=iatomega(olh)+nomega/20
     i=max(min(i,nomega-1),1)
     dxa=wx2nx(omega(i+1))-wx2nx(omega(i))
     dya=wy2ny(N2M(i+1))-wy2ny(N2M(i))
     call charangl(atan2(dya,dxa)*180./3.1415926)
     call jdrwstr(wx2nx(omega(i)),wy2ny(N2M(i)),string,0.5)
     call charangl(0.)
     call dashset(0)
  enddo
  call prtend('')
end subroutine plotNperps
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine plotNomegape
  real dxa,dya,xleg
  integer iwidth
!  real vminus,vat,vplus
  omegapi=omegapi/omegaf  ! Scale omegapi for plotting.
  call setupomegape
  call fwrite(omegace/omegaf*sqrt(Aj(1)/Aj(2)),iwidth,3,string)
  call boxtitle('N!d!A`!@!d for N!d!A|!@!d given by line labels.' &
   //'  (!AW!@!di!d!AW!@!de!d)!u1/2!u/!Aw!@='//string(1:iwidth))
  call winset(.true.)
  call color(15)
  call annotateNomegape
  do iNpar=1,nNpar
     Na=(Npmax*(iNpar)/(nNpar))
     N2a=Na**2
     call evalNperpop
     call color(15)
     call fwrite(Na,iw,1,string)
     logic=.true.
     where(F2.le.0. .and. cshift(F2,1).gt.0.)
        N2P=0.5*(cshift(N2P,1)+cshift(N2M,1))
        N2M=N2P
     elsewhere(F2.le.0. .and. cshift(F2,-1).gt.0.)
        N2P=0.5*(cshift(N2P,-1)+cshift(N2M,-1))
        N2M=N2P
     elsewhere(F2.le.0. &
          .or. cshift(N2M,-1)*N2M.lt.-10. &
          .or. cshift(N2M,1)*N2M.lt.-10. &
          )
        logic=.false.
     end where

     xleg=0.02
     !     if(.not.logx.or.olh/omegapi(1).lt.15.)xleg=0.7
     call color(colorfast)
     call dashset(colorfast)
     call legendline(xleg,.9,0,'Fast Wave')
     call polygapline(omegapi,N2M,nomega,logic)
!     i=iatomega(olh)+nomega/20
!     i=max(min(i,nomega-1),1)
     i=nomega/3
     dxa=wx2nx(omegapi(i+1))-wx2nx(omegapi(i))
     dya=wy2ny(N2M(i+1))-wy2ny(N2M(i))
     call charangl(atan2(dya,dxa)*180./3.1415926)
     call jdrwstr(wx2nx(omegapi(i)),wy2ny(N2M(i)),string,0.5)
     call charangl(0.)
     call dashset(0)

! Attempts to improve slow wave plot don't work.
!     where(N2P.gt.1.e5.and.cshift(N2P,1).lt.1.); N2P=100.; endwhere
!     where(N2P.lt.1..and.cshift(N2P,-1).gt.1.e5); N2P=cshift(N2P,1); endwhere
!     where(N2P.lt.1.e-5.and.cshift(N2P,1).gt.1) ; logic=.false.; endwhere
     call color(colorslow)
     call polygapline(omegapi,N2P,nomega,logic)
     i=nomega/2
     if(mod(iNpar,2).eq.0)i=nomega/3
     dxa=wx2nx(omegapi(i+1))-wx2nx(omegapi(i))
     dya=wy2ny(N2P(i+1))-wy2ny(N2P(i))
     call charangl(atan2(dya,dxa)*180./3.1415926)
     call jdrwstr(wx2nx(omegapi(i)),wy2ny(N2P(i)),string,0.5)
     call charangl(0.)
     call legendline(xleg,.95,0,'Slow Wave')
  enddo
  call prtend('')

end subroutine plotNomegape
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module coldplasmawaves
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Has to be after the plasma module in this file.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program coldplas
use coldplasmawaves

!Defaults
omegace=2.5
domce=0.1
ipf=0
EyExmax=2.8
EzExmax=2.8
ntheta=10
Npmax=5

! Handle command line arguments and settings.
call readsettings
! Plotting settings initialization
call pfset(ipf)
call brgwscaled(0.,.9)
call setiwarn(0) ! Silence range warnings

! Start user interface loop.
1 continue

call initialize
if(iplottype.eq.1)then
   call plotNs
elseif(iplottype.eq.2)then
   call plotNperps
elseif(iplottype.eq.3)then
   call initomegape
   call plotNomegape
endif

if(ipf.lt.0)then  ! If in no-wait plotting mode always save settings.
   call savesettings
   call exit()
endif

call eye3d(iw)
call uif(iw)
if(iw.ne.0)goto 1
! End of user interface loop

end program coldplas
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


*
*     -------------------------------------------------------------
*      N I N E 1 1
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
*                                                                  *
*     |  J1/2  J2/2  J3/2 |                                        *
*     |  L1/2  L2/2  J3/2 |                                        *
*     |  K1/2  K1/2    1  |                                        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
      SUBROUTINE NINE11(J1,J2,J3,L1,L2,K1,A)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      A=ZERO
      ISKAI=DBLE((J1-L1)*(J1+L1+2)-(J2-L2)*(J2+L2+2))
      IF(ISKAI.EQ.0) RETURN
      CALL SIXJ(J1,L1,K1,L2,J2,J3,0,S)
      VARD=DSQRT(DBLE(4*K1)*DBLE(K1+2)*DBLE(K1+1)*DBLE(J3)*
     :DBLE(J3+2)*DBLE(J3+1))
      A=S*DBLE(ISKAI)/VARD
      IF(MOD(L1+J2+K1+J3,4).NE.0) A=-A
      RETURN
      END


      subroutine ire_val_lamx(ctfm,ctfmp,n_A,n_B,n_Lamx,Nx,hx,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_B(Nx)
      real*8 n_Lamx(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = (0.5000000000000000D0 / n_A(i) / n_B(i) * (n_B(i - 1) - 0.1D1
     # * n_B(i + 1)) / hx + 0.2500000000000000D0 / n_A(i) ** 2 * (-0.1D1
     # * n_A(i - 1) + n_A(i + 1)) / hx) / ctfmp(i) + (0.2D1 / n_B(i) - 0
     #.2D1 / n_A(i)) / ctfm(i) - 0.1D1 * n_Lamx(i)
      res(i)=qb
      end do
      END


module subs
! module that contains the core of the intergraion procedure of the OVM
! after changes run:
!
!    f2py -c  main.f90 -m main
!
! note you need to open a new python interpreter so that the module changes will be applicable

implicit none

contains

subroutine rk4(a,lambda,v0,h,L,N,m,wp,local_rho,local_flow,x,dotx,dt,ndotx,nx,ndeltax,nlocal_rho,nlocal_flow)
    !  integration scheme

    implicit none

    ! input variables
    double precision,intent(in)   :: local_rho(:),   x(:),  dotx(:),   local_flow(:)
    double precision, intent(in)  :: a,lambda,v0,h,dt,L,wp
    integer, intent(in) :: N,m
    ! output variables
    double precision, intent(out),dimension(size(local_rho)) :: nx, ndotx, ndeltax, nlocal_rho, nlocal_flow

    ! local variables
    double precision,dimension(size(local_rho)) :: k1,k2,k3,k4
    double precision,dimension(N+m) :: dummy_ndeltax,dummy_ndotx
    real(kind=8)  :: weightsum, boxsize, front_flow, weight
    integer :: i,j

    ! RK4
    call acceleration_mcf(a,lambda,v0,h,local_rho,local_flow,dotx,k1)

    ndotx(:) = dotx(:) + k1*dt/2
    call acceleration_mcf(a,lambda,v0,h,local_rho,local_flow,ndotx,k2)

    ndotx(:) = dotx(:) + k2*dt/2
    call acceleration_mcf(a,lambda,v0,h,local_rho,local_flow,ndotx,k3)

    ndotx(:) = dotx(:) + k3*dt
    call acceleration_mcf(a,lambda,v0,h,local_rho,local_flow,ndotx,k4)

    ndotx(:) =  dotx(:) +  dt/6. * (k1 + 2*k2 + 2*k3 + k4)
    nx(:)      = x(:)  + ndotx * dt

    ! calculate headways
    do i=1,size(local_rho)-1
       ndeltax(i) = nx(i+1)-nx(i)
    end do
    ndeltax(N) = nx(1)-nx(N)

    do i=1,N
       ! apply periodic boundary condition
       nx(i)      = mod(nx(i)+L,L)
       ndeltax(i) = mod(ndeltax(i)+L,L)
       ! prepare extended ndeltax array
       dummy_ndeltax(i) = ndeltax(i)
       dummy_ndotx(i) = ndotx(i)
    end do

    ! extended arrays
    do i =1,m
       dummy_ndeltax(N+i) = ndeltax(i)
       dummy_ndotx(N+i) = ndotx(i)
    end do

    ! weighted local_rho and local_flow
    do i=1,N
       boxsize = 0.0
       front_flow = 0.0
       weightsum = 0.0
       do j=1,m
          weight = exp(wp*(dble(m)-dble(j)))
          weightsum = weightsum + weight

          boxsize = boxsize + dummy_ndeltax(i+j-1) * weight
          front_flow = front_flow + dummy_ndotx(i+j) * weight
       end do
       boxsize       = boxsize/weightsum !acctually here should be a "*m" but it would drop in the next step again
       nlocal_rho(i) = 1./boxsize
       nlocal_flow(i) = front_flow/weightsum
    end do

end subroutine

subroutine acceleration_mcf(a,lambda,v0,h,local_rho,local_flow,dotx,ddotx)
    ! Acceleration for the model OVM_rho_relax2J - that is similiar to the MCF introduced in Peng and Sun (2010)

    implicit none
    double precision,intent(in)   :: local_rho(:),dotx(:),local_flow(:)
    double precision, intent(in)  :: a,lambda,v0,h
    double precision, intent(out) :: ddotx(size(local_rho))

    double precision :: ovf(size(local_rho))

    call ovfunction(v0,h,local_rho(:),ovf(:))

    ddotx(:) =  a*(ovf(:) - dotx(:)) + lambda * (local_flow(:) - dotx(:))
  end subroutine acceleration_mcf

subroutine ovfunction(v0,h,local_rho,ovf)
     ! optimal velocity function as in Marschler et al (2014) but instead of using Delta_x here the inverse
     ! local density is used. For just one head car this the inverse local_rho is the same as Delta_x

     implicit none
     double precision,intent(in)   :: local_rho(:)
     double precision, intent(in)  :: v0,h
     double precision, intent(out) :: ovf(size(local_rho))

     ovf(:)= v0*(tanh(1./local_rho(:) - h) + tanh(h))

   end subroutine

subroutine annff(X,coef0,coef1,intercept0,intercept1,predict)
     implicit none
     double precision,intent(in)   :: X(:)
     double precision, intent(in)  :: coef0(:,:)
     double precision, intent(in)  :: coef1(:)
     double precision, intent(in)  :: intercept0(:)
     double precision, intent(in)  :: intercept1
     double precision :: hiddenout(size(coef1))
     double precision, intent(out) :: predict

     integer::i,j,imax,jmax
     imax = size(coef1)
     jmax = size(coef0(:,1))

     predict = 0.
     do i=1,imax
        hiddenout(i) = 0.
        do j=1,jmax
           hiddenout(i) = hiddenout(i) + X(j)*coef0(j,i)
        end do
        hiddenout(i) = logistic(hiddenout(i)+intercept0(i))
        predict = predict + hiddenout(i)*coef1(i)
     end do
     predict = predict + intercept1

end subroutine annff

function logistic(x)

   implicit none
   double precision :: logistic
   double precision, intent(in):: x

   logistic = 1./(1.+exp(-x))
   return

 end function

end module


subroutine diffuse_mom2D

!        momentum tendency due to SGS diffusion

use vars
use sgs, only: tk, grdf_x, grdf_z
use params, only: docolumn, dowallx
implicit none

real rdx2,rdz2,rdz,rdx25,rdz25,rdx21,rdx251
real dxz,dzx

integer i,j,k,ic,ib,kc,kcu
real tkx, tkz, rhoi, iadzw, iadz
real fu(0:nx,1,nz),fv(0:nx,1,nz),fw(0:nx,1,nz)

rdx2=1./dx/dx
rdx25=0.25*rdx2

dxz=dx/dz

j=1

if(.not.docolumn) then

if(dowallx) then

  if(mod(rank,nsubdomains_x).eq.0) then
    do k=1,nzm
         v(0,j,k) = v(1,j,k)
         w(0,j,k) = w(1,j,k)
    end do
  end if
  if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then
    do k=1,nzm
         v(nx+1,j,k) = v(nx,j,k)
         w(nx+1,j,k) = w(nx,j,k)
    end do
  end if

end if

do k=1,nzm

 kc=k+1
 kcu=min(kc,nzm)
 dxz=dx/(dz*adzw(kc))
 rdx21=rdx2 * grdf_x(k)
 rdx251=rdx25 * grdf_x(k)

   do i=0,nx
    ic=i+1
    tkx=rdx21*tk(i,j,k)
    fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k))
    fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k))
    tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu))
    fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz)
   end do
   do i=1,nx
    ib=i-1
    dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k))
    dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k))
    dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k))
   end do

end do

end if

!-------------------------
rdz=1./dz
dzx=dz/dx

do k=1,nzm-1
 kc=k+1
 uwsb(kc)=0.
 vwsb(kc)=0.
 iadz = 1./adz(k)
 iadzw= 1./adzw(kc)
 rdz2=rdz*rdz *grdf_z(k)
 rdz25=0.25*rdz2
   do i=1,nx
    ib=i-1
    tkz=rdz2*tk(i,j,k)
    fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz
    tkz=rdz25*(tk(i,j,k)+tk(ib,j,k)+tk(i,j,kc)+tk(ib,j,kc))
    fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + &
                       (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc)
    fv(i,j,kc)=-tkz*(v(i,j,kc)-v(i,j,k))*iadzw*rhow(kc)
    uwsb(kc)=uwsb(kc)+fu(i,j,kc)
    vwsb(kc)=vwsb(kc)+fv(i,j,kc)
  end do
end do

uwsb(1) = 0.
vwsb(1) = 0.

do i=1,nx
 tkz=rdz2*grdf_z(nzm)*tk(i,j,nzm)
 fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm)
 fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1)
 fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1)
 fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz)
 fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz)
 uwsb(1) = uwsb(1) + fu(i,j,1)
 vwsb(1) = vwsb(1) + fv(i,j,1)
end do

do k=1,nzm
  kc=k+1
  rhoi = 1./(rho(k)*adz(k))
  do i=1,nx
    dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi
    dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi
  end do
end do ! k

do k=2,nzm
  rhoi = 1./(rhow(k)*adzw(k))
  do i=1,nx
    dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi
  end do
end do ! k

end subroutine diffuse_mom2D


C######################################################################|
      module Coulomb_logarithms
C----------------------------------------------------------------------|
C     This module is used to calculate the Coulomb logarithm
C     associated with collisions of various particles.
C
C     Functions:
C       - ln_Lambda_0(ne, T):       thermal <-> thermal electrons
C       - ln_Lambda_c(ne, T):       relativistic <-> relativistic
C                                   electrons
C       - ln_Lambda_ee(ne, T, p):   thermal <-> non-thermal electrons
C       - ln_Lambda_ei(ne, T, p):   thermal ions <-> non-thermal
C                                   electrons
C
C     Function arguments:
C       - ne:   free electron density (m**-3)
C       - T:    electron temperature (eV)
C       - p:    normalised electron momentum
C
C----------------------------------------------------------------------|
      use double
      use physical_constants, only :
     >  m_ec

      implicit none

      private

      public ::
     >  ln_Lambda_0,
     >  ln_Lambda_c,
     >  ln_Lambda_ee,
     >  ln_Lambda_ei

        ! ----- Parameters --------------------------------------------|
      real(kind=dp), parameter ::
     >  k   = 5._dp

      contains

C======================================================================|
      real(kind=dp) function ln_Lambda_0(ne, T)
C----------------------------------------------------------------------|
C     Calculates the thermal electron Coulomb logarithm according to
C     Eq. (2.7) in L. Hesslow et al., J. Plasma Phys. 84, 905840605
C     (2018).
C
C     Input:
C       ne  : free electron density (m**-3)
C       T   : electron temperature (eV)
C
C     Output:
C       lnL0: thermal electron Coulomb logarithm
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, T

C----------------------------------------------------------------------|
      ln_Lambda_0 = 14.9_dp - .5_dp*log(1.e-20_dp*ne) + log(T/1.e3_dp)

      return
      end function ln_Lambda_0
C======================================================================|

C======================================================================|
      real(kind=dp) function ln_Lambda_c(ne, T)
C----------------------------------------------------------------------|
C     Calculates the relativistic electron Coulomb logarithm according
C     to Eq. (2.9) in L. Hesslow et al., J. Plasma Phys. 84, 905840605
C     (2018).
C
C     Input:
C       ne  : free electron density (m**-3)
C       T   : electron temperature (eV)
C
C     Output:
C       lnLc: relativistic electron Coulomb logarithm
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, T

C----------------------------------------------------------------------|
      ln_Lambda_c = 14.6_dp + .5_dp*log(T/(1.e-20_dp*ne))

      return
      end function ln_Lambda_c
C======================================================================|

C======================================================================|
      real(kind=dp) function ln_Lambda_ee(ne, T, p)
C----------------------------------------------------------------------|
C     Calculates the Coulomb logarithm for collisions between
C     non-thermal and thermal electrons according to Eq. (2.10) in
C     L. Hesslow et al., J. Plasma Phys. 84, 905840605 (2018).
C
C     Input:
C       ne  : free electron density (m**-3)
C       T   : electron temperature (eV)
C       p   : normalised electron momentum
C
C     Output:
C       lnLe: electron-electron Coulomb logarithm
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, p, T

C----------------------------------------------------------------------|
      ln_Lambda_ee= ln_Lambda_0(ne, T) + 1._dp/k
     >  * log(1 + sqrt(m_ec*(sqrt(1+p**2)-1)/T)**k)

      return
      end function ln_Lambda_ee
C======================================================================|

C======================================================================|
      real(kind=dp) function ln_Lambda_ei(ne, T, p)
C----------------------------------------------------------------------|
C     Calculates the Coulomb logarithm for collisions between
C     non-thermal electrons and ions according to Eq. (2.10) in
C     L. Hesslow et al., J. Plasma Phys. 84, 905840605 (2018).
C
C     Input:
C       ne  : free electron density (m**-3)
C       T   : electron temperature (eV)
C       p   : normalised electron momentum
C
C     Output:
C       lnLi: electron-ion Coulomb logarithm
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, p, T

C----------------------------------------------------------------------|
      ln_Lambda_ei = ln_Lambda_0(ne, T)
     >  + log(1 + (sqrt(2*m_ec/T)*p)**k)/k

      return
      end function ln_Lambda_ei
C======================================================================|

      end module Coulomb_logarithms
C######################################################################|


      SUBROUTINE PCHSP(IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER :: N, INCFD, NWK, IERR
      INTEGER, DIMENSION(2) :: IC
      REAL(rprec), DIMENSION(2) :: VC
      REAL(rprec), DIMENSION(N) :: X
      REAL(rprec), DIMENSION(INCFD,N) :: F, D
      REAL(rprec), DIMENSION(2,N) :: WK
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IBEG, IEND, INDEX, J, NM1
      REAL(rprec) :: G, HALF, ONE
      REAL(rprec), DIMENSION(3) :: STEMP
      REAL(rprec) :: THREE, TWO
      REAL(rprec), DIMENSION(4) :: XTEMP
      REAL(rprec) :: ZERO
!-----------------------------------------------
!   E x t e r n a l   F u n c t i o n s
!-----------------------------------------------
      REAL(rprec) , EXTERNAL :: PCHDF
!-----------------------------------------------
!***BEGIN PROLOGUE  PCHSP
!***DATE WRITTEN   820503   (YYMMDD)
!***REVISION DATE  870707   (YYMMDD)
!***CATEGORY NO.  E1B
!***KEYWORDS  LIBRARY=SLATEC(PCHIP),
!             TYPE=SINGLE PRECISION(PCHSP-S DPCHSP-D),
!             CUBIC HERMITE INTERPOLATION,PIECEWISE CUBIC INTERPOLATION,
!             SPLINE INTERPOLATION
!***AUTHOR  FRITSCH, F. N., (LLNL)
!             MATHEMATICS AND STATISTICS DIVISION
!             LAWRENCE LIVERMORE NATIONAL LABORATORY
!             P.O. BOX 808  (L-316)
!             LIVERMORE, CA  94550
!             FTS 532-4275, (415) 422-4275
!***PURPOSE  Set derivatives needed to determine the Hermite represen-
!            tation of the cubic spline interpolant to given data, with
!            specified boundary conditions.
!***DESCRIPTION
!
!          PCHSP:   Piecewise Cubic Hermite Spline
!
!     Computes the Hermite representation of the cubic spline inter-
!     polant to the data given in X and F satisfying the boundary
!     conditions specified by IC and VC.
!
!     To facilitate two-dimensional applications, includes an increment
!     between successive values of the F- and D-arrays.
!
!     The resulting piecewise cubic Hermite FUNCTION may be evaluated
!     by PCHFE or PCHFD.
!
!     NOTE:  This is a modified version of C. de Boor''S cubic spline
!            routine CUBSPL.
!
! ----------------------------------------------------------------------
!
!  Calling sequence:
!
!        PARAMETER  (INCFD = ...)
!        INTEGER  IC(2), N, NWK, IERR
!        REAL  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
!
!        CALL  PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
!
!   Parameters:
!
!     IC -- (input) INTEGER array of length 2 specifying desired
!           boundary conditions:
!           IC(1) = IBEG, desired condition at beginning of data.
!           IC(2) = IEND, desired condition at END of data.
!
!           IBEG = 0  to set D(1) so that the third derivative is con-
!              tinuous at X(2).  This is the "not a knot" condition
!              provided by de Boor''S cubic spline routine CUBSPL.
!              < This is the DEFAULT boundary condition. >
!           IBEG = 1  IF first derivative at X(1) is given in VC(1).
!           IBEG = 2  IF second derivative at X(1) is given in VC(1).
!           IBEG = 3  to USE the 3-point difference formula for D(1).
!                     (Reverts to the DEFAULT b.c. IF N.LT.3 .)
!           IBEG = 4  to USE the 4-point difference formula for D(1).
!                     (Reverts to the DEFAULT b.c. IF N.LT.4 .)
!          NOTES:
!           1. An error RETURN is taken IF IBEG is out of range.
!           2. For the "natural" boundary condition, USE IBEG=2 and
!              VC(1)=0.
!
!           IEND may take on the same values as IBEG, but applied to
!           derivative at X(N).  In CASE IEND = 1 or 2, the value is
!           given in VC(2).
!
!          NOTES:
!           1. An error RETURN is taken IF IEND is out of range.
!           2. For the "natural" boundary condition, USE IEND=2 and
!              VC(2)=0.
!
!     VC -- (input) REAL array of length 2 specifying desired boundary
!           values, as indicated above.
!           VC(1) need be set ONLY IF IC(1) = 1 or 2 .
!           VC(2) need be set ONLY IF IC(2) = 1 or 2 .
!
!     N -- (input) number of data points.  (Error RETURN IF N.LT.2 .)
!
!     X -- (input) REAL array of independent variable values.  The
!           elements of X must be strictly increasing:
!                X(I-1) .LT. X(I),  I = 2(1)N.
!           (Error RETURN IF not.)
!
!     F -- (input) REAL array of dependent variable values to be inter-
!           polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
!
!     D -- (output) REAL array of derivative values at the data points.
!           These values will determine the cubic spline interpolant
!           with the requested boundary conditions.
!           The value corresponding to X(I) is stored in
!                D(1+(I-1)*INCFD),  I=1(1)N.
!           No other entries in D are changed.
!
!     INCFD -- (input) increment between successive values in F and D.
!           This argument is provided primarily for 2-D applications.
!           (Error RETURN IF  INCFD.LT.1 .)
!
!     WK -- (scratch) REAL array of working storage.
!
!     NWK -- (input) length of work array.
!           (Error RETURN IF NWK.LT.2*N .)
!
!     IERR -- (output) error flag.
!           Normal RETURN:
!              IERR = 0  (no errors).
!           "Recoverable" errors:
!              IERR = -1  IF N.LT.2 .
!              IERR = -2  IF INCFD.LT.1 .
!              IERR = -3  IF the X-array is not strictly increasing.
!              IERR = -4  IF IBEG.LT.0 or IBEG.GT.4 .
!              IERR = -5  IF IEND.LT.0 of IEND.GT.4 .
!              IERR = -6  IF both of the above are true.
!              IERR = -7  IF NWK is too small.
!               NOTE:  The above errors are checked in the order listed,
!                   and following arguments have **NOT** been validated.
!             (the d-array has not been changed in any of these cases.)
!              IERR = -8  in case of trouble solving the linear system
!                         for the interior derivative values.
!             (The D-array may have been changed in this case.)
!             (             Do **NOT** USE it!                )
!
!***REFERENCES  CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES, SPRINGER-
!                 VERLAG (NEW YORK, 1978), PP. 53-59.
!***ROUTINES CALLED  PCHDF
!***END PROLOGUE  PCHSP
!
! ----------------------------------------------------------------------
!
!  Change record:
!     82-08-04   Converted to SLATEC library version.
!     87-07-07   Minor cosmetic changes to prologue.
!
! ----------------------------------------------------------------------
!
!  Programming notes:
!
!     To produce a Double precision version, simply:
!        a. Change PCHSP to DPCHSP wherever it occurs,
!        b. Change the real declarations to double precision, and
!        c. Change the constants ZERO, HALF, ... to Double precision.
!
!  DECLARE ARGUMENTS.
!
!
!  DECLARE LOCAL VARIABLES.
!
!
      DATA ZERO/0/
      DATA HALF/0.5_DP/
      DATA ONE/1/
      DATA TWO/2/
      DATA THREE/3/
!
!  VALIDITY-CHECK ARGUMENTS.
!
!***FIRST EXECUTABLE STATEMENT  PCHSP
      IF (N >= 2) THEN
         IF (INCFD < 1) GO TO 5002
         DO J = 2, N
            IF (X(J) <= X(J-1)) GO TO 5003
         END DO
!
         IBEG = IC(1)
         IEND = IC(2)
         IERR = 0
         IF (IBEG<0 .OR. IBEG>4) IERR = IERR - 1
         IF (IEND<0 .OR. IEND>4) IERR = IERR - 2
         IF (IERR < 0) GO TO 5004
!
!  FUNCTION DEFINITION IS OK -- GO ON.
!
         IF (NWK < 2*N) GO TO 5007
!
!  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
!  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
         WK(1,2:N) = X(2:N) - X(:N-1)
         WK(2,2:N) = (F(1,2:N)-F(1,:N-1))/WK(1,2:N)
!
!  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
!
         IF (IBEG > N) IBEG = 0
         IF (IEND > N) IEND = 0
!
!  SET UP FOR BOUNDARY CONDITIONS.
!
         IF (IBEG==1 .OR. IBEG==2) THEN
            D(1,1) = VC(1)
         ELSE IF (IBEG > 2) THEN
!        PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
            DO J = 1, IBEG
               INDEX = IBEG - J + 1
!           INDEX RUNS FROM IBEG DOWN TO 1.
               XTEMP(J) = X(INDEX)
               IF (J < IBEG) STEMP(J) = WK(2,INDEX)
            END DO
!                 --------------------------------
            D(1,1) = PCHDF(IBEG,XTEMP,STEMP,IERR)
!                 --------------------------------
            IF (IERR /= 0) GO TO 5009
            IBEG = 1
         ENDIF
!
         IF (IEND==1 .OR. IEND==2) THEN
            D(1,N) = VC(2)
         ELSE IF (IEND > 2) THEN
!        PICK UP LAST IEND POINTS.
            DO J = 1, IEND
               INDEX = N - IEND + J
!           INDEX RUNS FROM N+1-IEND UP TO N.
               XTEMP(J) = X(INDEX)
               IF (J < IEND) STEMP(J) = WK(2,INDEX+1)
            END DO
!                 --------------------------------
            D(1,N) = PCHDF(IEND,XTEMP,STEMP,IERR)
!                 --------------------------------
            IF (IERR /= 0) GO TO 5009
            IEND = 1
         ENDIF
!
! --------------------( BEGIN CODING FROM CUBSPL )--------------------
!
!  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
!  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
!  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
!     WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
!
!  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
!             WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
!
         IF (IBEG == 0) THEN
            IF (N == 2) THEN
!           NO CONDITION AT LEFT END AND N = 2.
               WK(2,1) = ONE
               WK(1,1) = ONE
               D(1,1) = TWO*WK(2,2)
            ELSE
!           NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
               WK(2,1) = WK(1,3)
               WK(1,1) = WK(1,2) + WK(1,3)
               D(1,1) = ((WK(1,2)+TWO*WK(1,1))*WK(2,2)
     1            *WK(1,3)+WK(1,2)**2*WK(2,3))/WK(1,1)
            ENDIF
         ELSE IF (IBEG == 1) THEN
!        SLOPE PRESCRIBED AT LEFT END.
            WK(2,1) = ONE
            WK(1,1) = ZERO
         ELSE
!        SECOND DERIVATIVE PRESCRIBED AT LEFT END.
            WK(2,1) = TWO
            WK(1,1) = ONE
            D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
         ENDIF
!
!  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
!  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
!  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
!
         NM1 = N - 1
         IF (NM1 > 1) THEN
            DO J = 2, NM1
               IF (WK(2,J-1) == ZERO) GO TO 5008
               G = -WK(1,J+1)/WK(2,J-1)
               D(1,J) = G*D(1,J-1) + THREE*(WK(1,J)
     1            *WK(2,J+1)+WK(1,J+1)*WK(2,J))
               WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J)+WK(1,J+1))
            END DO
         ENDIF
!
!  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
!           (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
!
!     IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
!     SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
!     AT THIS POINT.
         IF (IEND /= 1) THEN
!
            IF (IEND == 0) THEN
               IF (N==2 .AND. IBEG==0) THEN
!           NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
                  D(1,2) = WK(2,2)
                  GO TO 30
               ELSE IF (N==2 .OR. N==3 .AND. IBEG==0) THEN
!           EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
!           NOT-A-KNOT AT LEFT END POINT).
                  D(1,N) = TWO*WK(2,N)
                  WK(2,N) = ONE
                  IF (WK(2,N-1) == ZERO) GO TO 5008
                  G = -ONE/WK(2,N-1)
               ELSE
!           NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
!           KNOT AT LEFT END POINT.
                  G = WK(1,N-1) + WK(1,N)
!           DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
                  D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1)
     1            +WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
                  IF (WK(2,N-1) == ZERO) GO TO 5008
                  G = -G/WK(2,N-1)
                  WK(2,N) = WK(1,N-1)
               ENDIF
            ELSE
!        SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
               D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
               WK(2,N) = TWO
               IF (WK(2,N-1) == ZERO) GO TO 5008
               G = -ONE/WK(2,N-1)
            ENDIF
!
!  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
!
            WK(2,N) = G*WK(1,N-1) + WK(2,N)
            IF (WK(2,N) == ZERO) GO TO 5008
            D(1,N) = (G*D(1,N-1)+D(1,N))/WK(2,N)
!
!  CARRY OUT BACK SUBSTITUTION
!
         ENDIF
   30    CONTINUE
         DO J = NM1, 1, -1
            IF (WK(2,J) == ZERO) GO TO 5008
            D(1,J) = (D(1,J)-WK(1,J)*D(1,J+1))/WK(2,J)
         END DO
! --------------------(  END  CODING FROM CUBSPL )--------------------
!
!  NORMAL RETURN.
!
         RETURN
!
!  ERROR RETURNS.
!
      ENDIF
!     N.LT.2 RETURN.
      IERR = -1
      STOP 'PCHSP -- NUMBER OF DATA POINTS LESS THAN TWO'
      RETURN
!
 5002 CONTINUE
!     INCFD.LT.1 RETURN.
      IERR = -2
      STOP 'PCHSP -- INCREMENT LESS THAN ONE'
      RETURN
!
 5003 CONTINUE
!     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      STOP 'PCHSP -- X-ARRAY NOT STRICTLY INCREASING'
      RETURN
!
 5004 CONTINUE
!     IC OUT OF RANGE RETURN.
      IERR = IERR - 3
      STOP 'PCHSP -- IC OUT OF RANGE'
      RETURN
!
 5007 CONTINUE
!     NWK TOO SMALL RETURN.
      IERR = -7
      STOP 'PCHSP -- WORK ARRAY TOO SMALL'
      RETURN
!
 5008 CONTINUE
!     SINGULAR SYSTEM.
!   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
!   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
      IERR = -8
      STOP 'PCHSP -- SINGULAR LINEAR SYSTEM'
      RETURN
!
 5009 CONTINUE
!     ERROR RETURN FROM PCHDF.
!   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -9
      STOP 'PCHSP -- ERROR RETURN FROM PCHDF'
      RETURN
!------------- LAST LINE OF PCHSP FOLLOWS ------------------------------
      END SUBROUTINE PCHSP


program Selection_Sort_1              !基于minloc()的一组数的选择排序法。
implicit none
    integer,parameter ::i=10          !i为数的数量
    integer :: a(i),m(1)              !定义数组
    integer :: o,t                    !数组中的位置

    read(*,*) a                       !读入一组数
    do o=1,i-1                        !选择排序法核心循环代码
        m = minloc(a(o:)) + o - 1     !minloc()返回数组中最小数的位置+待排位-1
        t = a(o)
        a(o)=a(m(1))                  !待排数与最小值交换
        a(m)=t                        !最小值原位与待排数交换
    end do

    write(*,"(10I4)") a
end program


! RUN: %python %S/test_folding.py %s %flang_fc1
! Test folding of array constructors with duplicate names for the implied
! DO variables
module m1
  integer, parameter :: expected(12) = [1, 2, 4, 6, 1, 2, 4, 6, 1, 2, 3, 6]
  integer, parameter :: dups(12) = &
    [ ((iDuplicate, iDuplicate = 1,j), &
       (2 * iDuplicate, iDuplicate = j,3 ), &
        j = 1,3 ) ]
  logical, parameter :: test_dups = all(dups == expected)
end module


	REAL FUNCTION MHSIZE
     .	(ALPHA,POWER,T,THETA,C,M,PI,CORRECTED)
	USE MSIMSL
	IMPLICIT NONE
!
!  Calculate sample size (number of subjects) for Mantel-Haenszel test.
!  Sample size is derived by interating to find the zero of the mhpowerfcn
!  routine.
!
!   input:
!       alpha=type I error
!       power=power for the uncorrected or corrected M-H chi-square
!       t=number of 2X2 tables
!       theta=common odds ratio accross tables that is to be detected
!       c(i)=proportion of cases in table i
!       m(i)=number of controls per case in table i
!       pi(i,2)=proportion of successes among controls in table i
!       corrected=uncorrected or corrected result (0 or 1)
!

	REAL POWER, T, C(20), M(20), PI(20), THETA, ALPHA
	INTEGER CORRECTED

	REAL CPOWER, CT, CC(20), CM(20), CPI(20), CTHETA, CALPHA
	INTEGER CCORRECTED
	COMMON /MHSIZECOMM/ CPOWER, CT, CC, CM, CPI, CTHETA,
     .		 CALPHA, CCORRECTED

	INTEGER I
	INTEGER    ITMAX, NROOT
	REAL       EPS, ERRABS, ERRREL, ETA
	PARAMETER  (NROOT=1)
!	INTEGER    INFO(NROOT)
	REAL       POWERFCN
!	REAL N(NROOT)
!	REAL NGUESS(NROOT)
	EXTERNAL POWERFCN
!	DATA NGUESS/0/
!	DATA NGUESS/1/
	real a,b
!
!  Code:
!
!  Load input for mhpowerfcn function into common.
!
	CPOWER=POWER
	CT=T
	DO I=1,T
		CC(I)=C(I)
		CM(I)=M(I)
		CPI(I)=PI(I)
	END DO
	CTHETA=THETA
	CALPHA=ALPHA
	CCORRECTED=CORRECTED
!
!  Set zero finding parameters.
!
	EPS    = 1.0E-4
	ERRABS = 1.0E-4
	ERRREL = 1.0E-4
	ETA    = .01
	ITMAX  = 100
!
!  Iterate for the sample size.
!
!	CALL ZREAL (POWERFCN, ERRABS, ERRREL, EPS, ETA, NROOT,
!     .		ITMAX, NGUESS, N, INFO)
	a=0
	b=1000000000
	CALL ZBREN (powerfcn, ERRABS, ERRREL, A, B, ITMAX)
!	write (*,*)" ...info=",info(1)
!	CALL ZERO(POWERFCN,NGUESS,EPS,N)
!
!	MHSIZE=N(NROOT)
	mhsize=b

	RETURN
	END

	REAL FUNCTION POWERFCN(N)
!
!  This is function to find the zero for when determining the
!  M-H sample size.
!
!  i.e., powerfcn=power-mhpowerfcn(...,n,...)
!
	IMPLICIT NONE
	REAL MHPOWERFCN
	REAL N

	REAL CPOWER, CT, CC(20), CM(20), CPI(20), CTHETA, CALPHA
	INTEGER CCORRECTED
	COMMON /MHSIZECOMM/ CPOWER, CT, CC, CM, CPI, CTHETA,
     .		 CALPHA, CCORRECTED
	REAL LOCALPOWER
!
!  Code.
!
!	write(*,*)" ...trying n=",n
!
!  A sample size less than one causes mhpowerfcn to fail.
!  Protect against that here.
!
	if (n.lt.1) then
	    localpower=0
	else
	    LOCALPOWER=MHPOWERFCN(N,CT,CC,CM,CTHETA,CPI,CALPHA,CCORRECTED)
	end if

	POWERFCN=CPOWER-LOCALPOWER
!	write(*,*)" ......diff=",POWERFCN

      RETURN
	END


module compute_flux_module

  implicit none

  private

  public :: compute_flux_2d

contains

  subroutine compute_flux_2d(lo, hi, dt, dx, &
                             phi,ph_lo,ph_hi, &
                             umac,  u_lo,  u_hi, &
                             vmac,  v_lo,  v_hi, &
                             flxx, fx_lo, fx_hi, &
                             flxy, fy_lo, fy_hi, &
                             phix_1d, phiy_1d, phix, phiy, slope, glo, ghi)

    use slope_module, only: slopex, slopey

    integer, intent(in) :: lo(2), hi(2), glo(2), ghi(2)
    double precision, intent(in) :: dt, dx(2)
    integer, intent(in) :: ph_lo(2), ph_hi(2)
    integer, intent(in) ::  u_lo(2),  u_hi(2)
    integer, intent(in) ::  v_lo(2),  v_hi(2)
    integer, intent(in) :: fx_lo(2), fx_hi(2)
    integer, intent(in) :: fy_lo(2), fy_hi(2)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2)) :: &
         phix_1d, phiy_1d, phix, phiy, slope

    integer :: i, j, k
    double precision :: hdtdx(2)

    hdtdx = 0.5*(dt/dx)

    call slopex(glo, ghi, &
                phi, ph_lo, ph_hi, &
                slope, glo, ghi)

    ! compute phi on x faces using umac to upwind; ignore transverse terms
    do    j = lo(2)-1, hi(2)+1
       do i = lo(1)  , hi(1)+1

          if (umac(i,j) .lt. 0.d0) then
             phix_1d(i,j) = phi(i  ,j) - (0.5d0 + hdtdx(1)*umac(i,j))*slope(i  ,j)
          else
             phix_1d(i,j) = phi(i-1,j) + (0.5d0 - hdtdx(1)*umac(i,j))*slope(i-1,j)
          end if

       end do
    end do

    call slopey(glo, ghi, &
                phi, ph_lo, ph_hi, &
                slope, glo, ghi)

    ! compute phi on y faces using umac to upwind; ignore transverse terms
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-1, hi(1)+1

          if (vmac(i,j) .lt. 0.d0) then
             phiy_1d(i,j) = phi(i,j  ) - (0.5d0 + hdtdx(2)*vmac(i,j))*slope(i,j  )
          else
             phiy_1d(i,j) = phi(i,j-1) + (0.5d0 - hdtdx(2)*vmac(i,j))*slope(i,j-1)
          end if

       end do
    end do

    ! update phi on x faces by adding in y-transverse terms
    do    j = lo(2), hi(2)
       do i = lo(1), hi(1)+1

          if (umac(i,j) .lt. 0.d0) then
             phix(i,j) = phix_1d(i,j) &
                  - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1)+vmac(i  ,j)) * (phiy_1d(i  ,j+1)-phiy_1d(i  ,j)) )
          else
             phix(i,j) = phix_1d(i,j) &
                  - hdtdx(2)*( 0.5d0*(vmac(i-1,j+1)+vmac(i-1,j)) * (phiy_1d(i-1,j+1)-phiy_1d(i-1,j)) )
          end if

          ! compute final x-fluxes
          flxx(i,j) = phix(i,j)*umac(i,j)

       end do
    end do

    ! update phi on y faces by adding in x-transverse terms
    do    j = lo(2), hi(2)+1
       do i = lo(1), hi(1)

          if (vmac(i,j) .lt. 0.d0) then
             phiy(i,j) = phiy_1d(i,j) &
                  - hdtdx(1)*( 0.5d0*(umac(i+1,j  )+umac(i,j  )) * (phix_1d(i+1,j  )-phix_1d(i,j  )) )
          else
             phiy(i,j) = phiy_1d(i,j) &
                  - hdtdx(1)*( 0.5d0*(umac(i+1,j-1)+umac(i,j-1)) * (phix_1d(i+1,j-1)-phix_1d(i,j-1)) )
          end if

          ! compute final y-fluxes
          flxy(i,j) = phiy(i,j)*vmac(i,j)

       end do
    end do

  end subroutine compute_flux_2d

end module compute_flux_module


program test
! Check that gcp_points works as expected

use spherical_geometry

integer,parameter :: rs = 8, &
                     npts = 1000 ! Number of points along path
integer :: npts_out
real(rs) :: x1 =  0.,  y1 =  0.,  &
            x2 = 45.,  y2 = 45.  ! Endpoints
real(rs) :: ds, lon(npts), lat(npts) ! Points on path

write(0,'(a,f0.1,1x,f0.1)') 'Start point : ',x1,y1,&
                            'End point :   ',x2,y2

call gcp_points(x1,y1,x2,y2,lon,lat,n=npts,degrees=.true.)

write(*,'(a)') "> -W2p,red"
do i=1,npts
   write(*,*) lon(i),lat(i)
enddo

ds = 1.
call gcp_points(x1,y1,x2,y2,lon,lat,ds=ds,npts=npts_out,degrees=.true.)

write(*,'(a)') "> -W2p,green,."
do i=1,npts_out
   write(*,*) lon(i),lat(i)
enddo

end program test


module ExactSol
implicit none

!///////////////////////////////////////////////////////////
!///////////////////////////////////////////////////////////

! shock tube problem - exact solution

!//////////////////////////////////////////////////////////
!//////////////////////////////////////////////////////////
!任意の時間，位置，速度，圧力，密度を格納するための配列を入力すれば使える
!空間刻みは密度用の配列の上限から取るため，配列は1:imaxで確保しておくこと
contains
    subroutine ExactSolver(t,x,u,p,rho)
    implicit none

    double precision, intent(in) :: t
    double precision, intent(inout) :: x(:),u(:),p(:),rho(:)

    double precision :: gamma
    double precision :: rho_l, rho_r, u_l, u_r, p_l, p_r, x_l, x_r, x_0, c_l, c_r
    double precision :: xi

    integer :: imx, i
    double precision :: dltx

    double precision :: gamm1, gamp1, gam2, gamg2, gamg2i
    double precision :: ratc, ratpre
    double precision :: coe1, coe2, coe3

    double precision :: pp, pp1, pp2, res, res2
    double precision :: beta, u_2, v_sh, v_cd
    double precision :: bcr, bc12, bc23, bc34, bc45, bcl, c_4

!----------------------------------------------------------
! initial condition 1
!----------------------------------------------------------

      gamma = 1.4d0
      rho_l = 1.0d0
      rho_r = 0.1d0
      u_l   = 0.0d0
      u_r   = 0.0d0
      p_l   = rho_l/gamma
      p_r   = rho_r/gamma

      !imx   = 501                  !格子点数
      imx = ubound(rho,1) - lbound(rho,1) + 1
!      t     = 0.50d0               !計算する時間
      !x_l   = -1.0d0                !左側境界
      x_l   = 0.0d0                !左側境界
      x_r   = 1.0d0                !右側境界
      x_0   = (x_r+x_l)*0.5d0      !膜の位置

!----------------------------------------------------------
! initial condition 2
!----------------------------------------------------------

      c_l=dsqrt(gamma*p_l/rho_l)   !音速
      c_r=dsqrt(gamma*p_r/rho_r)   !音速

!----------------------------------------------------------
! make grid
!----------------------------------------------------------

      dltx=(x_r-x_l)/dble(imx-1)   !格子幅
      do i=1,imx
       x(i)=x_l+dltx*dble(i-1)
      end do
!
!----------------------------------------------------------
! output initial condition
!----------------------------------------------------------
!
      do i=1,imx
       xi=x(i)
!
! --- region 1 ---(低圧部)
       if ((xi<=x_r).and.(xi>=x_0)) then
        u(i)=u_r
        p(i)=p_r
        rho(i)=rho_r
! --- region 5 ---(高圧部)
       else if ((xi<x_0).and.(xi>=x_l)) then
        u(i)=u_l
        p(i)=p_l
        rho(i)=rho_l
! --- otherwise ---
       else
        u(i)=0.0d0
        p(i)=0.0d0
        rho(i)=0.0d0
       end if
!
!d       write(10,'(1P,2E25.15)') x(i),u(i)
!d	 write(11,'(1P,2E25.15)') x(i),p(i)
!d	 write(12,'(1P,2E25.15)') x(i),rho(i)
      end do
!
! for gnuplot recognizing
!
!d      write(10,*)
!d	write(11,*)
!d	write(12,*)
!
!----------------------------------------------------------
! bisection method (二分法)
!----------------------------------------------------------
!
      gamm1 = gamma-1.0d0
      gamp1 = gamma+1.0d0
      gam2  = 2.0d0/gamm1
      gamg2 = gam2*gamma
      gamg2i= 1.0d0/gamg2
      ratc= c_l/c_r            !音速比
      ratpre= p_r/p_l          !圧力比
      coe1  = gam2*ratc
      coe2  = (u_l-u_r)/c_r
      coe3  = dsqrt(2.0d0/gamma)
!
      pp1=0.1d0*p_l/p_r
      pp2=p_l/p_r
!
      do i=1,10000
       pp=(pp1+pp2)*0.5d0
       res = func(pp)
       res2 = func(pp2)
    if(res*res2.le.0.0d0) then
        pp1=pp
       else
        pp2=pp
       end if
      end do
!
!----------------------------------------------------------
! beta, speed of shockwave and contact discontinuity
!----------------------------------------------------------
!
      beta  = dsqrt(gamm1+(gamp1)*pp)
      u_2   = u_r+c_r*coe3*(pp-1.0d0)/beta              !領域2での速度
      v_sh  = u_r+(pp-1.0d0)*(c_r**2)/(gamma*(u_2-u_r)) !衝撃波速度
      v_cd  = u_2                                       !接触速度
!
!----------------------------------------------------------
! output state
!----------------------------------------------------------
!
!	do j=5,25,5
!	 t=j/100.0d0
!	t=0.25d0
!
      bcr   = x_r
      bc12  = x_0+v_sh*t
      bc23  = x_0+v_cd*t
      bc34  = x_0+((gamp1*v_cd*0.5d0)-c_l-(gamm1*u_l*0.5d0))*t
      bc45  = x_0+(u_l-c_l)*t
      bcl   = x_l
!
      do i=1,imx
       xi=x(i)
!
! ---over left---
!
       if (xi>bcr) then
        u(i)=0.0d0
        p(i)=0.0d0
        rho(i)=0.0d0
!
!--- region 1 ---(u_1,p_1,rho_1)(低圧部)
!
       else if (xi>=bc12) then
        u(i)=u_r
        p(i)=p_r
        rho(i)=rho_r
!
!--- region 2 ---(u_2,p_2,rho_2) (衝撃波－接触不連続)
!
       else if (xi>=bc23) then
        u(i)=u_2
        p(i)=p_r*pp
        rho(i)=rho_r*(gamm1+(gamp1)*pp)/(gamp1+(gamm1)*pp)
!	  c0=c_r+gamm1*(u(i)-u_r)*0.5d0
!	  c1=dsqrt(gamma*p(i)/rho(i))
!	  write(6,*) u(i),p(i),rho(i)
!
!--- region 3 ---(u_3,p_3,rho_3) (接触不連続－膨張波)
!
       else if (xi>=bc34) then
        u(i)=u_2
        p(i)=p_r*pp
        rho(i)=rho_l*((p(i)/p_l)**(1.0d0/gamma))
!	  write(6,*) u(i),p(i),rho(i)
!
!--- region 4 ---(u_4,p_4,rho_4) (膨張波)
!
       else if (xi>=bc45) then
        u(i)=(2.0d0/gamp1) &
     &   *(((x(i)-x_0)/t)+c_l+(gamm1/2.0d0)*u_l)
        c_4=c_l-((gamm1)/2.0d0)*(u(i)-u_l)
        p(i)=p_l*((c_4/c_l)**gamg2)
        rho(i)=rho_l*((p(i)/p_l)**(1.0d0/gamma))
!	  write(6,*) u(i),p(i),rho(i)
!
!--- region 5 ---(u_5,p_5,rho_5) (高圧部)
!
       else if (xi>=bcl) then
        u(i)=u_l
        p(i)=p_l
        rho(i)=rho_l
!
! ---over left---
!
       else
        u(i)=0.0d0
        p(i)=0.0d0
        rho(i)=0.0d0
       end if
!
    end do
!
    return
    contains
!
!------------------------------------------------
! function for bisection algorithm
!------------------------------------------------
!
      function func(pp) result(res)
        double precision, intent(in) :: pp
        double precision :: res
!
      res=coe1*(1.0d0-(pp*ratpre)**(gamg2i)) &
     &   +coe2 &
     &   -coe3*(pp-1.0d0)/dsqrt(gamm1+(gamp1)*pp)
!
        return
      end function func

    end subroutine ExactSolver

end module ExactSol


module variables
!Network parameters
	integer,parameter::  N= 20000 !=Number of Neurons= Network size
	integer,parameter:: Avg_degree=10 !=<k>
	integer,parameter:: Nbonds=N*Avg_degree/2
!Time Parameters
	integer,parameter:: n_s=50000
	integer,parameter::     MeassTime=0.9*n_s
	integer,parameter::   transient=0.1*n_s
!Model Parameters
	real(8),parameter:: r1= 0.001  !Spontaneous activation
	integer,parameter:: nrefract=3 !nuumber of times at the refractary step n=2+nrefract
	integer,parameter:: nstates=nrefract+2
	real(8),parameter:: lambda=12.5
!Threshold Variables
	real(8)::  sigma_p  ! Threshold T
	real(8),parameter::  Delta_sigma=0.05 ! Threshold Change
	real(8),parameter:: sigma_0=0.45
	real(8),parameter:: sigma_F=2.05
	real(8):: Prob
!Neuron States and  Neighbor lists
	integer S(1:N) !Neuron State
	integer S_prev(1:N) !Previous Neuron State
	integer,parameter:: x1=5*Avg_degree
	integer,dimension(N):: MyNeighbors=0 ! MyNeighbors(i) = Ammount of neighbors of i
	integer,dimension(N,x1):: NeighborMat=0 ! NeighborMat(i,k)= identity of the k-tjh neighbor of i
	real(8),dimension(N,x1):: Wij=0 ! Wij(i,k)= weight of the k-tjh connetcion of i, i.e., the conection with  NeighborMat(i,k)
	real(8),dimension(N,x1):: sigmaWij=0 !
	real(8)::weight
!OBSERVABLES
	integer:: activity,prev_activity
	real(8):: AVGact,AVGact2,AvgActPrev
	real(8):: f_s, varf_s,AC1  !fraction of actives, variance of activity and first autocorrelation coefficient
!AUXILIAR VARIABLES
	integer it !iteration step
	integer i,j, jj,k
	real(8) p !for random numbers
end module

program KC1
use variables
implicit none

!Load connection matrix and generate weights
open(99,file= "../Matrix/MyMatrix.txt",status="old",action="read")
do k=1,Nbonds
read(99,*) i,j
p=rand(); weight=p

MyNeighbors(i)=MyNeighbors(i)+1
NeighborMat(i,MyNeighbors(i))=j
Wij(i,MyNeighbors(i))=weight

MyNeighbors(j)=MyNeighbors(j)+1
NeighborMat(j,MyNeighbors(j))=i
Wij(j,MyNeighbors(j))=weight
enddo
close(99)

 do i=1,N; p=rand();  S(i)= int(p*3)
enddo

 ! RUN
open(101,file= "Results.txt",status="unknown")

do sigma_p=sigma_0,sigma_F,delta_sigma

!notice the difference with the original model here:
sigmaWij=Wij*sigma_p
call BlockStep
enddo
close(101)
! RUN Backwards
open(101,file= "BackResults.txt",status="unknown")
do sigma_p=sigma_F,sigma_0,-delta_sigma
sigmaWij=Wij*sigma_p
call BlockStep
enddo
close(101)

end program

!------------------------------------------------

subroutine BlockStep
use variables;
implicit none
do it=1,transient;call step;enddo
avgact=0;avgact2=0;AvgActPrev=0
do it=1,MeassTime;prev_activity=activity;call step
avgact=avgact+activity;
avgact2=avgact2+activity**2;
AvgActPrev=AvgActPrev+activity*prev_activity
enddo
avgact=avgact/real(measstime);
avgact2=avgact2/real(measstime)
AvgActPrev=AvgActPrev/real(measstime)

f_s= avgact/real(N)
varf_s= real(avgact2-avgact**2)/real(N)**2
AC1= real((AvgActPrev-avgact**2)/(avgact2-avgact**2))

write(101,*) real(sigma_p ),f_s, varf_s, AC1
write(*,*) real(sigma_p ),f_s, varf_s, AC1
end subroutine

!------------------------------------------------

subroutine step
use variables;
implicit none
integer Normalization

S_prev=S
S=0
!Activity=0
do i=1,N

!Previously active -> Refractory P=1
if (S_prev(i)>1) then
S(i)=S_prev(i)+1;
if (S(i)==nstates)  S(i)=0;
endif

if (S_prev(i).eq.0)then !Previously Quiescent- > Excited P=r1
!	s(i)=0
	p=rand()
	if (p<r1)then
		S(i)=1;
	endif
endif

if (S_prev(i)==1) then
! New Part
        Normalization=0
        do k=1,MyNeighbors(i)
            j=NeighborMat(i,k)
            if (S_prev(j)==0) then
            Normalization=Normalization+1
            endif
        end do
! End Normalization calculation
	do k=1,MyNeighbors(i)
		j=NeighborMat(i,k)
		if (S_prev(j)==0) then
				p=rand()
				!Notice the difference Here
			if (p<sigmaWij(i,k)*2/real(Normalization)) then
				S(j)=1
			endif
		endif
	end do
S(i)=2
end if
end do !N

Activity=0
do i=1,N
if (S(i)==1) activity=activity+1
end do !N
end subroutine


! ****************************************************************************
! ... Minimization utilitites
! ... System Dynamics
! ... Quim Ballabrera, January 2018
! ... Source: Numerical Recipes
! ...
! ... subroutine DFPMIN
! ... subroutine LNSRCH
! ****************************************************************************

module minimization

use types, only: dp

implicit none

contains

SUBROUTINE dfpmin(p,n,gtol,iter,fret,func,dfunc)

integer, parameter                         :: ITMAX = 200
real(dp), parameter                        :: STPMX = 100.0D0
real(dp), parameter                        :: EPS   = 3.0D-8
real(dp), parameter                        :: TOLX  = 4.0D0*EPS

integer, intent(in)                        :: n
real(dp), dimension(n), intent(inout)      :: p
integer, intent(out)                       :: iter
real(dp), intent(in)                       :: gtol
real(dp), intent(out)                      :: fret

real(dp)                                   :: func
external                                   :: dfunc,func

! ... Local variables
! ...
integer i,its,j
logical check

real(dp) den,fac,fad,fae,fp,stpmax,xsum,sumdg,sumxi,temp,test
real(dp), dimension(n)      :: dg,g,hdg,pnew,xi
real(dp), dimension(n,n)    :: hessin

fp=func(p)
call dfunc(p,g)

xsum=0.d0
hessin(:,:) = 0.0d0
do i=1,n
  hessin(i,i) = 1.d0
  xi(i)       = -g(i)
  xsum         = xsum + p(i)**2
enddo
stpmax=STPMX*max(sqrt(xsum), dble(n))

do its=1,ITMAX
  iter=its
  call lnsrch(n,p,fp,g,xi,pnew,fret,stpmax,check,func)
  fp=fret

  xi(:) = pnew(:) - p(:)
  p(:)  = pnew(:)

  test=0.d0
  do i=1,n
    temp = abs(xi(i))/max(abs(p(i)),1.d0)
    if (temp.gt.test) test = temp
  enddo
  if (test.lt.TOLX) return

  dg(:) = g(:)
  call dfunc(p,g)
  test = 0.d0
  den  = max(fret,1.d0)
  do i=1,n
    temp = abs(g(i))*max(abs(p(i)),1.d0)/den
    if (temp.gt.test) test = temp
  enddo
  if(test.lt.gtol) return

  dg(:) = g(:) - dg(:)
  do i=1,n
    hdg(i) = DOT_PRODUCT(hessin(i,:),dg(:))
  enddo

  fac   = 0.d0
  fae   = 0.d0
  sumdg = 0.d0
  sumxi = 0.d0
  do i=1,n
    fac   = fac   + dg(i)*xi(i)
    fae   = fae   + dg(i)*hdg(i)
    sumdg = sumdg + dg(i)**2
    sumxi = sumxi + xi(i)**2
  enddo

  if(fac**2.gt.EPS*sumdg*sumxi)then
    fac=1.d0/fac
    fad=1.d0/fae
    do i=1,n
      dg(i)=fac*xi(i)-fad*hdg(i)
    enddo
    do i=1,n
      do j=1,n
        hessin(i,j) = hessin(i,j)       &
                    + fac*xi(i)*xi(j)   &
                    - fad*hdg(i)*hdg(j) &
                    + fae*dg(i)*dg(j)
      enddo
    enddo
  endif

  do i=1,n
    xi(i) = -DOT_PRODUCT(hessin(i,:),g(:))
  enddo

enddo
stop  'Error: too many iterations in dfpmin'

end subroutine dfpmin
!C  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! ====================================================================================
! ...
subroutine lnsrch(n,xold,fold,g,p,x,f,stpmax,check,func)

real(dp), parameter                    :: ALF  = 1.0D-4
real(dp), parameter                    :: TOLX = 1.0D-7

integer, intent(in)                    :: n
real(dp), intent(in)                   :: fold
real(dp), intent(in)                   :: stpmax
real(dp), dimension(n), intent(in)     :: xold
real(dp), dimension(n), intent(in)     :: g
real(dp), dimension(n), intent(inout)  :: p
real(dp), dimension(n), intent(out)    :: x
real(dp), intent(out)                  :: f
logical, intent(out)                   :: check

real(dp)                               :: func
external                               :: func

! ... Local variables
! ...
integer i
real(dp) a,alam,alam2,alamin,b,disc,f2,fold2,rhs1,rhs2
real(dp) slope,xsum,temp,test,tmplam

check=.false.
xsum = sqrt(DOT_PRODUCT(p,p))
if (xsum.gt.stpmax) then
  p(:) = p(:)*stpmax/xsum
endif
slope = DOT_PRODUCT(g,p)
test=0.d0
do i=1,n
  temp=abs(p(i))/max(abs(xold(i)),1.d0)
  if(temp.gt.test)test=temp
enddo
alamin=TOLX/test
alam=1.d0
do
  x(:) = xold(:) + alam*p(:)
  f = func(x)
  if(alam.lt.alamin)then
    x(:) = xold(:)
    check=.true.
    return
  else if(f.le.fold+ALF*alam*slope)then
    return
  else
    if(alam.eq.1.d0)then
      tmplam=-slope/(2.d0*(f-fold-slope))
    else
      rhs1=f-fold-alam*slope
      rhs2=f2-fold2-alam2*slope
      a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
      b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
      if(a.eq.0.d0)then
        tmplam=-slope/(2.d0*b)
      else
        disc=b*b-3.d0*a*slope
        tmplam=(-b+sqrt(disc))/(3.d0*a)
      endif
      if(tmplam.gt..5d0*alam)tmplam=.5d0*alam
    endif
  endif
  alam2=alam
  f2=f
  fold2=fold
  alam=max(tmplam,.1d0*alam)
enddo
end subroutine lnsrch
!C  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! ====================================================================================
! ...

end module minimization


      module moduleExample_2_mod
      implicit none
!
!     Procedure Interfaces
!
      interface print_matrix
        module procedure print_matrix_integer
        module procedure print_matrix_real
      end interface print_matrix

!
!     Here are subroutines and functions for my program.
!
      CONTAINS
!
      subroutine print_matrix_integer(matrix,header)
!
!     This subroutine prints a square integer matrix whose dimension is less than 6.
!
      implicit none
      integer,dimension(:,:),intent(in)::matrix
      character(len=*),intent(in),optional::header
      integer::i
!
!     Print the matrix.
!
 1000 Format(I10,4x,I10,4x,I10,4x,I10,4x,I10,4x,I10)
 2000 Format(1x,A)
      if(PRESENT(header)) write(*,2000) TRIM(header)
      do i = 1,Size(matrix,1)
        write(*,1000) matrix(i,:)
      endDo
!
      return
      end subroutine print_matrix_integer

      subroutine print_matrix_real(matrix,header)
!
!     This subroutine prints a square real matrix whose dimension is less than 6.
!
      implicit none
      real,dimension(:,:),intent(in)::matrix
      character(len=*),intent(in),optional::header
      integer::i
!
!     Print the matrix.
!
 1000 Format(f10.5,4x,f10.5,4x,f10.5,4x,f10.5,4x,f10.5,4x,f10.5)
 2000 Format(1x,A)
      if(PRESENT(header)) write(*,2000) TRIM(header)
      do i = 1,Size(matrix,1)
        write(*,1000) matrix(i,:)
      endDo
!
      return
      end subroutine print_matrix_real
!
      end module moduleExample_2_mod

      program moduleExample_2
!
!     This is an example program demonstrating some uses of modules.
!
      USE moduleExample_2_mod
      implicit none
      integer,dimension(5,5)::matrixI,matrixJ,matrixK
      real,dimension(5,5)::matrixA,matrixB,matrixC
!
!     Fill real matrixA and matrixB with random numbers.
!
      call random_number(matrixA)
      call random_number(matrixB)
      write(*,*)' Matrix A:'
      write(*,*) matrixA
      write(*,*)' Here is Matrix A:'
      call print_matrix(matrixA)
      write(*,*)' Here is Matrix B:'
      call print_matrix(matrixB)
!
!     Fill integer matrixI and matrixJ with random numbers.
!
      call random_number(matrixC)
      matrixI = matrixC*100
      write(*,*)' Matrix I:'
      write(*,*) matrixI
      write(*,*)' Here is matrixI:'
      call print_matrix(matrixI)
!
!     Form matrixC = sqrt(matrixA)
!
      matrixC = SQRT(matrixA)
      write(*,*)' Here is matrixC:'
      call print_matrix(header='Here is matrixC in the print routine...',matrix=matrixC)
!
      end program moduleExample_2


module print_tools

implicit none
integer, parameter :: stdout = 6
contains
subroutine print_rmatrix(name, m)
    character(*), intent(in) :: name
    real, dimension(:, :), intent(in) :: m
    integer :: num_rows
    integer :: num_cols
    character(len = 100) :: num_cols_str
    integer :: r, c, use
    num_rows = size(m, 1)
    num_cols = size(m, 2)
    write(num_cols_str, fmt='(I0)') num_cols
    write(unit=stdout, fmt='(A)') name // ':'
    do r = 1, num_rows
        write(unit=stdout, fmt='('// num_cols_str // '(F10.3, A))') (m(r, c), ' ', c=1,num_cols)
    end do
end subroutine print_rmatrix
    end module print_tools

MODULE m

CONTAINS
 PURE FUNCTION f ( i , j )
  INTEGER , INTENT(IN) :: i
  INTEGER , INTENT(IN) :: j
  REAL :: f

  f = 1.0 * i * j
 END FUNCTION f

 SUBROUTINE call_test ( nrows , ncols )
  USE print_tools

  INTEGER , INTENT(IN) :: nrows
  INTEGER , INTENT(IN) :: ncols
  INTEGER :: r
  INTEGER :: c
  REAL :: array6 ( 1 : nrows , 1 : ncols )
  REAL :: array7 ( 1 : nrows , 1 : ncols )

  DO r = 1 , nrows , 1
   DO c = 1 , ncols , 1
    array6 ( r , c ) = 1.0 * r * c
   END DO
  END DO
  CALL print_rmatrix ("array6" , array6 )
  DO r = 1 , nrows , 1
   DO c = 1 , ncols , 1
    array7 ( r , c ) = f ( r , c ) * 2.0
   END DO
  END DO
  CALL print_rmatrix ("array7" , array7 )
 END SUBROUTINE call_test

END MODULE m

PROGRAM claw_test
  use m
  INTEGER :: nRows = 10
  INTEGER :: nCols = 20
  CALL call_test(nRows, nCols)
END PROGRAM claw_test


program problem67
  implicit none
  integer, parameter    :: m=100,n=5050
  integer, dimension(n) :: numbers,scratch
  integer               :: i,j,temp,index1,index2,level_start

  open(33,file='./data/problem67.dat')
  read(33,*) numbers

  do i=1,n
     scratch(i)=-1
  end do
  scratch(1)=numbers(1)

  level_start=0
  do i=1,m-1
     do j=1,i
        index1=level_start+j
        index2=index1+i
        temp=scratch(index1)+numbers(index2)
        if (temp>scratch(index2)) then
           scratch(index2)=temp
        end if

        index2=index1+i+1
        temp=scratch(index1)+numbers(index2)
        if (temp>scratch(index2)) then
           scratch(index2)=temp
        end if
     end do
     level_start=level_start+i
  end do

  print *, maxval(scratch(level_start+1:n))

end program problem67


! { dg-do run }
! PR35994 [4.3/4.4 regression] MAXLOC and MINLOC off by one with mask
program GA4076
  REAL DDA(100)
  dda = (/(J1,J1=1,100)/)
  IDS = MAXLOC(DDA,1)
  if (ids.ne.100) STOP 1!expect 100

  IDS = MAXLOC(DDA,1, (/(J1,J1=1,100)/) > 50)
  if (ids.ne.100) STOP 2!expect 100

  IDS = minLOC(DDA,1)
  if (ids.ne.1) STOP 3!expect 1

  IDS = MinLOC(DDA,1, (/(J1,J1=1,100)/) > 50)
  if (ids.ne.51) STOP 4!expect 51

END


! Example: Compute the LU Factorization of a matrix on the GPU
program main
  use hipfort
  use hipfort_check
  use hipfort_hipsolver
  implicit none
  integer(c_int),parameter    :: M   = 3,&
                                 N   = 3,&
                                 lda = 3
  integer(c_size_t),parameter :: size_piv = min(M, N) ! count of pivot indices
  real(c_double)              :: hA(lda,N)
  integer(c_int)              :: hInfo           ! provides information about algorithm completion
  integer(c_int)              :: hIpiv(size_piv) ! array for pivot indices on CPU
  !
  type(c_ptr)            :: handle = c_null_ptr
  integer(c_int),pointer :: dInfo
  integer(c_int),pointer :: dIpiv(:)
  real(c_double),pointer :: dA(:,:)
  type(c_ptr)            :: dWork
  integer(c_int)         :: size_work_bytes ! size of workspace to pass to getrf (in bytes)
  !
  hA = reshape((/12,-51,4, 6,167,-68, -4,24,-41/),shape(hA))

  write(*,"(a)",advance="no") "-- Running test 'hipsolverDgetrf' (Fortran 2008 interfaces) - "

  ! let's print the input matrix, just to see it
  ! print *, hA

  ! initialization
  call hipsolverCheck(hipsolverCreate(handle))

  ! calculate the sizes of our arrays
  ! allocate memory on GPU & copy hA to device
  call hipCheck(hipMalloc(dInfo))
  call hipCheck(hipMalloc(dIpiv, mold=hIpiv))
  call hipCheck(hipMalloc(dA, source=hA))

  ! create the workspace
  call hipsolverCheck(hipsolverDgetrf_bufferSize(handle, M, N, dA, lda, size_work_bytes))
  call hipCheck(hipMalloc(dWork, int(size_work_bytes,c_size_t)))

  ! compute the LU factorization on the GPU
  call hipsolverCheck(hipsolverDgetrf(handle, M, N, dA, lda, dWork, size_work_bytes, dIpiv, dInfo))

  ! copy the results back to CPU
  call hipCheck(hipMemcpy(hInfo, dInfo, hipMemcpyDeviceToHost))
  call hipCheck(hipMemcpy(hIpiv, dIpiv, hipMemcpyDeviceToHost))
  call hipCheck(hipMemcpy(hA, dA, hipMemcpyDeviceToHost))

  ! the results are now in hA and hIpiv
  ! we can print some of the results if we want to see them
  ! print *, "hInfo=",hInfo
  ! print *, "hA=",hA
  ! print *, "hIpiv=",hA

  ! clean up
  call hipCheck(hipFree(dWork))
  call hipCheck(hipFree(dInfo))
  call hipCheck(hipFree(dIpiv))
  call hipCheck(hipFree(dA))
  call hipsolverCheck(hipsolverDestroy(handle))

  ! TODO: add correctness check
  write(*,*) "PASSED!"
end program


!==============================================================================
! TEST_NUMERIC
!==============================================================================

!==============================================================================
MODULE TEST_NUMERIC_MODULE
!==============================================================================
USE CONSTANTS_MODULE
USE NUMERIC_MODULE
IMPLICIT NONE

!---------------------------------------------------------------------------
! Visibility
!---------------------------------------------------------------------------
PUBLIC test_Numeric

!==============================================================================
! Module procedures
!==============================================================================
CONTAINS

!------------------------------------------------------------------------------
! test_Numeric
!------------------------------------------------------------------------------
SUBROUTINE test_Numeric( nSuccess, nFail )
   ! Declare the arguments.
   INTEGER, INTENT(OUT) :: nSuccess
   INTEGER, INTENT(OUT) :: nFail

   ! Declare local variables.
   LOGICAL :: Flag

   ! Initialize.
   nSuccess = 0
   nFail    = 0

   CALL test_CholeskyDecomposition( Flag )
   IF( Flag ) THEN
      nSuccess = nSuccess + 1
   ELSE
      nFail = nFail + 1
   END IF

   CALL test_CholeskySolve( Flag )
   IF( Flag ) THEN
      nSuccess = nSuccess + 1
   ELSE
      nFail = nFail + 1
   END IF

   CALL test_CholeskyInverse( Flag )
   IF( Flag ) THEN
      nSuccess = nSuccess + 1
   ELSE
      nFail = nFail + 1
   END IF

END

!------------------------------------------------------------------------------
! test_CholeskyDecomposition
!------------------------------------------------------------------------------
SUBROUTINE test_CholeskyDecomposition( Flag )
   ! Declare the arguments.
   LOGICAL, INTENT(OUT) :: Flag

   REAL(8), DIMENSION(6,6) :: C, A, L

   C = RESHAPE((/ 1,1,1,1,1,1, 0,2,2,2,2,2, 0,0,3,3,3,3, 0,0,0,4,4,4, 0,0,0,0,5,5, 0,0,0,0,0,6 /), SHAPE(C))
   A = MATMUL( C, TRANSPOSE(C) )

   CALL CholeskyDecomposition(6, A, L)

   Flag = ALL( ABS(L-C) .LE. 1e-12 )

   IF( .NOT. Flag ) THEN
      CALL Dump(6,C-L,6,6)
   END IF

END SUBROUTINE test_CholeskyDecomposition

!------------------------------------------------------------------------------
! test_CholeskySolve
!------------------------------------------------------------------------------
SUBROUTINE test_CholeskySolve( Flag )
   ! Declare the arguments.
   LOGICAL, INTENT(OUT) :: Flag

   REAL(8), DIMENSION(6,6) :: C, A, L
   REAL(8), DIMENSION(6)   :: b, x, y

   C = RESHAPE((/ 1,1,1,1,1,1, 0,2,2,2,2,2, 0,0,3,3,3,3, 0,0,0,4,4,4, 0,0,0,0,5,5, 0,0,0,0,0,6 /), SHAPE(C))
   A = MATMUL( C, TRANSPOSE(C) )
   b = RESHAPE((/ 21, 81, 171, 267, 342, 378 /), SHAPE(b))
   y = RESHAPE((/ 6, 5, 4, 3, 2, 1 /), SHAPE(y))

   CALL CholeskyDecomposition(6, A, L)
   CALL CholeskySolve(6, L, b, x)

   Flag = ALL( ABS(x-y) .LT. 1e-12 )

   IF( .NOT. Flag ) THEN
      CALL Dump(6,x-y,6,1)
   END IF
END SUBROUTINE test_CholeskySolve

!------------------------------------------------------------------------------
! test_CholeskyInverse
!------------------------------------------------------------------------------
SUBROUTINE test_CholeskyInverse( Flag )
   ! Declare the arguments.
   LOGICAL, INTENT(OUT) :: Flag

   REAL(8), DIMENSION(6,6) :: C, A, Ainv, L, B, Eye

   C = RESHAPE((/ 1,1,1,1,1,1, 0,2,2,2,2,2, 0,0,3,3,3,3, 0,0,0,4,4,4, 0,0,0,0,5,5, 0,0,0,0,0,6 /), SHAPE(C))
   A = MATMUL( C, TRANSPOSE(C) )
   Eye = RESHAPE((/ 1,0,0,0,0,0, 0,1,0,0,0,0, 0,0,1,0,0,0, 0,0,0,1,0,0, 0,0,0,0,1,0, 0,0,0,0,0,1 /), SHAPE(Eye))

   CALL CholeskyDecomposition(6, A, L)

   CALL CholeskyInverse(6, L, Ainv)
   B = MATMUL(A,Ainv)
   Flag = ALL( ABS(B - Eye) .LE. 1e-12 )

   IF( .NOT. Flag ) THEN
      CALL Dump(6,B,6,6)
   END IF

END SUBROUTINE test_CholeskyInverse

!==============================================================================
END MODULE TEST_NUMERIC_MODULE
!==============================================================================