      subroutine hainesindex(prs,tmk,tdk,haines,miy,mjx,mkzh,prsb,prst)
      include 'comconst'

!     Note that this version differs from the Seattle version to account
!     for flipped vertical coordinates

      dimension tmk(miy,mjx,mkzh), tdk(miy,mjx,mkzh), prs(miy,mjx,mkzh),
     &          haines(miy,mjx)

       do j = 1, mjx ! -1
       do i = 1, miy ! -1

         if( prs(i,j,1) .lt. prsb ) then
            haines(i,j) = 0.
         else
            do k = 2, mkzh

              kk  = mkzh+1 - k     ! Account for flipped vertical coordinates
              km1 = kk + 1         ! Account for flipped vertical coordinates

              if( prs(i,j,kk).gt.prst .and. prs(i,j,km1).le.prst ) then
                 tmkt = tmk(i,j,km1) + (tmk(i,j,kk)-tmk(i,j,km1)) *
     &                  (log(prst)-log(prs(i,j,km1))) /
     &                  (log(prs(i,j,kk))-log(prs(i,j,km1)))
              endif
              if( prs(i,j,kk).gt.prsb .and. prs(i,j,km1).le.prsb ) then
                 tmkb = tmk(i,j,km1) + (tmk(i,j,kk)-tmk(i,j,km1)) *
     &                  (log(prsb)-log(prs(i,j,km1))) /
     &                  (log(prs(i,j,kk))-log(prs(i,j,km1)))
                 tdkb = tdk(i,j,km1) + (tdk(i,j,kk)-tdk(i,j,km1)) *
     &                  (log(prsb)-log(prs(i,j,km1))) /
     &                  (log(prs(i,j,kk))-log(prs(i,j,km1)))
              endif
            enddo

            deltat = tmkb - tmkt
            dpdep  = tmkb - tdkb

            if( nint(prsb) .eq. 700 ) then    ! hainh
               if( deltat .le. 17.5 ) then
                  factor1 = 1.
               else if(deltat .gt. 17.5 .and. deltat .le. 21.5 ) then
                  factor1 = 2.
               else             ! deltat .gt. 21.5
                  factor1 = 3.
               endif

               if( dpdep .le. 14.5 ) then
                  factor2 = 1.
               else if( dpdep .gt. 14.5 .and. dpdep .le. 20.5 ) then
                  factor2 = 2.
               else             ! dpdep .gt. 20.5
                  factor2 = 3.
               endif
            endif

            if( nint(prsb) .eq. 850 ) then    ! hainm
               if( deltat .le. 5.5 ) then
                  factor1 = 1.
               else if(deltat .gt. 5.5 .and. deltat .le. 10.5 ) then
                  factor1 = 2.
               else             ! deltat .gt. 10.5
                  factor1 = 3.
               endif

               if( dpdep .le. 5.5 ) then
                  factor2 = 1.
               else if( dpdep .gt. 5.5 .and. dpdep .le. 12.5 ) then
                  factor2 = 2.
               else             ! dpdep .gt. 12.5
                  factor2 = 3.
               endif
            endif

            haines(i,j) = factor1 + factor2

C            if( mod(i,10) .eq. 0 .and. mod(j,10) .eq. 0 ) then
C               print *, j, i, tmkb, tmkt, deltat
C               print *, tmkb, tdkb, dpdep
C            endif

         endif

       enddo
       enddo

      return
      end


SUBROUTINE evolve_disc(t,dt)
  ! Subroutine updates disc properties according to simplified semi-analytic model
  ! Q and accretion rates are held constant, but mass is deducted from outer and inner regions

  use stardata
  use eosdata
  use embryodata

  implicit none
  integer :: i
  real ::  t,dt,dsigma, mlost,dtmin,counter
  real :: sigma_count

  ! Calculate mass lost in outer radius - if all mass lost, change irout

  dsigma = 1.1*sigma_d(irout)
  mlost = 0.0
  sigma_count = 0.0

  DO WHILE (dsigma > sigma_d(irout))

     dsigma = mdotvisc*dt/(2.0*pi*r_d(irout)*dr)

  IF(dsigma< sigma_d(irout)) THEN
     sigma_d(irout) = sigma_d(irout) - dsigma
     mlost= mlost + 2.0*pi*r_d(irout)*dsigma*dr

     exit
  ELSE IF(dsigma > sigma_d(irout)+sigma_count) THEN

! If mass loss greater than available mass in shell, pass it through shells until this is no longer true

     sigma_count = sigma_count + sigma_d(irout)
     mlost = mlost + 2.0*pi*r_d(irout)*sigma_d(irout)*dr

     sigma_d(irout) = 0.0
     irout = irout-1

  ELSE IF(dsigma < sigma_d(irout) + sigma_count) THEN
     exit
     ENDIF

  ENDDO

! Update mass of star and disc
! If timestep too long, and disc disappears, set disc mass to zero and exit
  IF(mdotvisc*dt > mdisc) THEN
  mstar = mstar+ mdisc
  mdisc =0.0
  q_disc = 0.0
  return
  ENDIF

    mstar = mstar + mdotvisc*dt
    mdisc = mdisc - mdotvisc*dt

    q_disc = mdisc/mstar

    ! As Omega has changed, entire disc properties must be recalculated
    ! Sigma is known, so no iteration required

    DO i=1,irout
       r_d(i) = rin + (i-1)*dr

       omega_d(i) = sqrt(G*mstar/(r_d(i)*r_d(i)*r_d(i)))

       !	Calculate sound speed assuming fixed Q

       cs_d(i) = pi*G*sigma_d(i)/(omega_d(i))

       ! Calculate scale height

       H_d(i) = cs_d(i)/omega_d(i)
       rhomid = sigma_d(i)/(2.0*H_d(i))

       ! Use EoS to calculate tau, gamma, betac

	CALL eos_cs(rhomid, cs_d(i))

	gamma_d(i) = gammamuT(1)
	T_d(i) = gammamuT(3)
	kappa_d(i) = gammamuT(4)

	tau_d(i) = sigma_d(i)*kappa_d(i)
	betac_d(i) = (tau_d(i)+1.0/tau_d(i))*cs_d(i)*cs_d(i)*omega_d(i)/&
			(sigma_SB*(T_d(i)**4.0)*gamma_d(i)*(gamma_d(i)-1.0))

!	Calculate alpha from this value --> accretion rate

	alpha_d(i) = 4.0/(9.0*gamma_d(i)*(gamma_d(i)-1.0)*betac_d(i))

!	print*, alpha_d(i), gamma_d(i),betac_d(i),cs_d(i),omega_d(i)
!	Compare with imposed accretion rate

!	mdotvisc = 3.0*pi*alpha_d(i)*cs_d(i)*cs_d(i)*sigma_d(i)/omega_d(i)
!	Check for MRI activation
!	If so, then set alpha=0.01 and readjust sigma to maintain mdotvisc

	IF(T_d(i)>1000.0) THEN
!	print*, 'MRI active ',r/udist, T, alpha, sigma
	alpha_d(i) = 0.01
	sigma_d(i) = mdotvisc*omega_d(i)/(3.0*pi*alpha_d(i)*cs_d(i)*cs_d(i))
!	print*, 'MRI active ', T, alpha, sigma
	ENDIF

 mjeans(i) = 4.0*1.412*pi*pi*pi/(3.0*G)
 mjeans(i) = mjeans(i)*cs_d(i)*cs_d(i)*cs_d(i)/(omega_d(i)*(1.0+1.0/sqrt(betac_d(i))))

 IF(alpha_d(i)<0.1) THEN
      gamma_j(i) = 2.0*(9.0*alpha_d(i)*gamma_d(i)*(gamma_d(i)-1.0)/4.0 - 1/betac_d(i))
   ELSE
      gamma_j(i) = 2.0*(9.0*0.1*gamma_d(i)*(gamma_d(i)-1.0)/4.0 - 1/betac_d(i))
   ENDIF

   gamma_j(i) = 1.0/gamma_j(i)

ENDDO

return
end subroutine evolve_disc


      subroutine dt4o(d1,o2,t4,edt4o)

      implicit double precision(a-h,o-z)

      dimension d1(3),o2(3,3,3),t4(3,3,3,3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(15),b(15)

      a(1)=t4(1,1,1,1)
      a(2)=t4(1,1,1,2)
      a(3)=t4(1,1,1,3)
      a(4)=t4(1,1,2,2)
      a(5)=t4(1,1,2,3)
      a(6)=t4(1,1,3,3)
      a(7)=t4(1,2,2,2)
      a(8)=t4(1,2,2,3)
      a(9)=t4(1,2,3,3)
      a(10)=t4(1,3,3,3)
      a(11)=t4(2,2,2,2)
      a(12)=t4(2,2,2,3)
      a(13)=t4(2,2,3,3)
      a(14)=t4(2,3,3,3)
      a(15)=t4(3,3,3,3)

      b(1)=d1(1)*o2(1,1,1)
      b(2)=3.d0*d1(1)*o2(1,1,2)+d1(2)*o2(1,1,1)
      b(3)=3.d0*d1(1)*o2(1,1,3)+d1(3)*o2(1,1,1)
      b(4)=3.d0*(d1(1)*o2(1,2,2)+d1(2)*o2(1,1,2))
      b(5)=6.d0*d1(1)*o2(1,2,3)+3.d0*(d1(2)*o2(1,1,3)+d1(3)*o2(1,1,2))
      b(6)=3.d0*(d1(1)*o2(1,3,3)+d1(3)*o2(1,1,3))
      b(7)=3.d0*d1(2)*o2(1,2,2)+d1(1)*o2(2,2,2)
      b(8)=6.d0*d1(2)*o2(1,2,3)+3.d0*(d1(1)*o2(2,2,3)+d1(3)*o2(1,2,2))
      b(9)=6.d0*d1(3)*o2(1,2,3)+3.d0*(d1(1)*o2(2,3,3)+d1(2)*o2(1,3,3))
      b(10)=3.d0*d1(3)*o2(1,3,3)+d1(1)*o2(3,3,3)
      b(11)=d1(2)*o2(2,2,2)
      b(12)=3.d0*d1(2)*o2(2,2,3)+d1(3)*o2(2,2,2)
      b(13)=3.d0*(d1(2)*o2(2,3,3)+d1(3)*o2(2,2,3))
      b(14)=3.d0*d1(3)*o2(2,3,3)+d1(2)*o2(3,3,3)
      b(15)=d1(3)*o2(3,3,3)

      edt4o=a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+a(4)*b(4)+
     .      a(5)*b(5)+a(6)*b(6)+a(7)*b(7)+a(8)*b(8)+a(9)*b(9)+
     .      a(10)*b(10)+a(11)*b(11)+a(12)*b(12)+a(13)*b(13)+
     .      a(14)*b(14)+a(15)*b(15)

      return
      end


      subroutine ch_rtday

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine routes the daily flow through the reach using a
!!    variable storage coefficient

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_d(:)     |m             |average depth of main channel
!!    ch_n(2,:)   |none          |Manning"s "n" value for the main channel
!!    ch_s(2,:)   |m/m           |average slope of main channel
!!    chside(:)   |none          |change in horizontal distance per unit
!!                               |change in vertical distance on channel side
!!                               |slopes; always set to 2 (slope=1/2)
!!    pet_ch       |mm H2O        |potential evapotranspiration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    rcharea     |m^2           |cross-sectional area of flow
!!    rchdep      |m             |depth of flow on day
!!    rtevp       |m^3 H2O       |evaporation from reach on day
!!    rttime      |hr            |reach travel time
!!    rttlc       |m^3 H2O       |transmission losses from reach on day
!!    rtwtr       |m^3 H2O       |water leaving reach on day
!!    sdti        |m^3/s         |average flow on day in reach
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    det         |hr            |time step (24 hours)
!!    c           |none          |inverse of channel side slope
!!    jrch        |none          |reach number
!!    p           |m             |wetted perimeter
!!    rh          |m             |hydraulic radius
!!    scoef       |none          |Storage coefficient (fraction of water in
!!                               |reach flowing out on day)
!!    topw        |m             |top width of main channel
!!    vol         |m^3 H2O       |volume of water in reach at beginning of
!!                               |day
!!    wtrin       |m^3 H2O       |amount of water flowing into reach on day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt, Min
!!    SWAT: Qman

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~
!!    Modified by Balaji Narasimhan
!!    Spatial Sciences Laboratory, Texas A&M University

      use basin_module
      use channel_data_module
      use channel_module
      use hydrograph_module
      use hru_module, only : hru
      use channel_velocity_module
      use maximum_data_module
      use reservoir_module
      use reservoir_data_module

      implicit none

      real :: scoef         !none          |Storage coefficient (fraction of water in
      real :: p             !m             |wetted perimeter
      !real :: tbase        !not used in this subroutine
      real :: topw          !m             |top width of main channel
      real :: vol           !m^3 H2O       |volume of water in reach at beginning of
                            !              |day
      real :: c             !none          |inverse of channel side slope
      real :: rh            !m             |hydraulic radius
      real :: volrt         !units         |description
      real :: maxrt         !units         |description
      real :: dddep         !units         |description
      real :: addp          !units         |description
      real :: addarea       !units         |description
      real :: vc            !m/s           |flow velocity in reach
      real :: aaa           !units         |description
      real :: rttlc1        !units         |description
      real :: rttlc2        !units         |description
      real :: rtevp1        !units         |description
      real :: rtevp2        !units         |description
      real :: det           !hr            |time step (24 hours)
      real :: qman          !m^3/s or m/s  |flow rate or flow velocity
      real :: adddep        !units         |description
      integer :: itermx     !units         |description
      integer :: ihr, ires, ichan, iobhr
      real :: depst, depstmax, rchvol

      !! calculate volume of water in reach
      vol = wtrin

      !! Find average flowrate in a day
      volrt = wtrin  / (86400 * rt_delt)

      !! Find maximum flow capacity of the channel at bank full
      c = ch_hyd(jhyd)%side
	  p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c)
	  rh = ch_vel(jrch)%area / p
	  maxrt = Qman(ch_vel(jrch)%area, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s)

      sdti = 0.
	  rchdep = 0.
	  p = 0.
	  rh = 0.
	  vc = 0.

      ch(jrch)%chfloodvol = 0.
      !! If average flowrate is greater than than the channel capacity at bank full
      !! then simulate flood plain flow else simulate the regular channel flow
      !! taking floodwater to wetlands
      if (volrt > maxrt) then
      ch(jrch)%chfloodvol = (volrt - maxrt) * 86400 * rt_delt
      do ihr = 1, sp_ob%hru
        iobhr = hru(ihr)%obj_no
        ichan = ob(iobhr)%flood_ch_lnk
        if (ichan == jrch) then
          ires = hru(ihr)%dbs%surf_stor
          depstmax = wet_ob(ires)%pvol
          depst = wet_ob(ires)%pvol - wet(ires)%flo
          depst = max(0., depst)
          depst = min(depst, ch(jrch)%chfloodvol)

          if (depst > 0.) then
            wet(ires)%flo = wet(ires)%flo + depst
            wet_in_d(ires)%flo = wet_in_d(ires)%flo + depst / 10000.
            volrt = volrt- depst / (86400 * rt_delt)
            ch(jrch)%chfloodvol = ch(jrch)%chfloodvol - depst
            vol = vol - depst
            end if
          end if
        end do
      end if

      if (volrt > maxrt) then
	    rcharea = ch_vel(jrch)%area
	    rchdep = ch_hyd(jhyd)%d
	    p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c)
	    rh = ch_vel(jrch)%area / p
	    sdti = maxrt
	    adddep = 0
	    !! find the crossectional area and depth for volrt
	    !! by iteration method at 1cm interval depth
	    !! find the depth until the discharge rate is equal to volrt
        itermx = 0
	    Do While (sdti < volrt)
          adddep = adddep + 0.01
          addarea = rcharea + ((ch_hyd(jhyd)%w * 5) + 4 * adddep) * adddep
          addp = p + (ch_hyd(jhyd)%w * 4) + 2. * adddep * Sqrt(1. + 4 * 4)
	      rh = addarea / addp
          sdti = Qman(addarea, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s)
          itermx = itermx + 1
          if (itermx > 100) exit
	    end do
	    rcharea = addarea
	    rchdep = ch_hyd(jhyd)%d + adddep
	    p = addp
	    sdti = volrt
! store floodplain water that can be used by riparian HRU"s

	  else
	  !! find the crossectional area and depth for volrt
	  !! by iteration method at 1cm interval depth
	  !! find the depth until the discharge rate is equal to volrt
	    Do While (sdti < volrt)
	      rchdep = rchdep + 0.01
	      rcharea = (ch_vel(jrch)%wid_btm + c * rchdep) * rchdep
	      p = ch_vel(jrch)%wid_btm + 2. * rchdep * Sqrt(1. + c * c)
	      rh = rcharea / p
          sdti = Qman(rcharea, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s)
	    end do
	    sdti = volrt
	  end if

      !! calculate top width of channel at water level
      topw = 0.
      if (rchdep <= ch_hyd(jhyd)%d) then
        topw = ch_vel(jrch)%wid_btm + 2. * rchdep * c
      else
        topw = 5 * ch_hyd(jhyd)%w + 2. * (rchdep - ch_hyd(jhyd)%d) * 4.
      end if

      !! Time step of simulation (in hour)
      !! adjusted by Ann van Griensven Feb 2018 / losses are independent of residence time.

      det = 24.* rt_delt

      if (sdti > 0.) then
        !! calculate velocity and travel time
  	    vc = sdti / rcharea
        ch(jrch)%vel_chan = vc
	    rttime = ch_hyd(jhyd)%l * 1000. / (3600. * vc)

        !! calculate volume of water leaving reach on day
        scoef = 2. * det / (2. * rttime + det)
        if (scoef > 1.) then
          rchvol = ch_hyd(jhyd)%l * 1000. * rcharea
          rtwtr = vol + ch(jrch)%rchstor - rchvol
        else
          rtwtr = scoef * (wtrin + ch(jrch)%rchstor)
        end if

        ch(jrch)%rchstor = ch(jrch)%rchstor + vol - rtwtr

        !! calculate amount of water in channel at end of day

        !! Add if statement to keep rchstor from becoming negative
        if (ch(jrch)%rchstor < 0.0) ch(jrch)%rchstor = 0.0

        !! transmission and evaporation losses are proportionally taken from the
        !! channel storage and from volume flowing out

       !! calculate transmission losses
	    rttlc = 0.

	    if (rtwtr > 0.) then

	      !!  Total time in hours to clear the water
          rttlc = det * ch_hyd(jhyd)%k * ch_hyd(jhyd)%l * p

	      if (ch(jrch)%rchstor <= rttlc) then
	        rttlc1 = min(rttlc, ch(jrch)%rchstor)
	        ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc1
	        rttlc2 = rttlc - rttlc1
	        if (rtwtr <= rttlc2) then
	          rttlc2 = min(rttlc2, rtwtr)
	          rtwtr = rtwtr - rttlc2
	        else
	          rtwtr = rtwtr - rttlc2
            end if
            rttlc = rttlc1 + rttlc2
	      else
	        ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc
	      end if
        end if

        !! calculate evaporation
	    rtevp = 0.
        if (rtwtr > 0.) then
          aaa = bsn_prm%evrch * pet_ch / 1000. * rt_delt
	      if (rchdep <= ch_hyd(jhyd)%d) then
            rtevp = aaa * ch_hyd(jhyd)%l * 1000. * topw
	      else
		    if (aaa <=  (rchdep - ch_hyd(jhyd)%d)) then
              rtevp = aaa * ch_hyd(jhyd)%l * 1000. * topw
	        else
	          rtevp = (rchdep - ch_hyd(jhyd)%d)
	          rtevp = rtevp + (aaa - (rchdep - ch_hyd(jhyd)%d))
              topw = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * c
	          rtevp = rtevp * ch_hyd(jhyd)%l * 1000. * topw
	        end if
	      end if

	      rtevp2 = rtevp * ch(jrch)%rchstor / (rtwtr + ch(jrch)%rchstor)

	      if (ch(jrch)%rchstor <= rtevp2) then
	        rtevp2 = min(rtevp2, ch(jrch)%rchstor)
	        ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2
	        rtevp1 = rtevp - rtevp2
	        if (rtwtr <= rtevp1) then
	          rtevp1 = min(rtevp1, rtwtr)
	          rtwtr = rtwtr - rtevp1
	        else
	          rtwtr = rtwtr - rtevp1
	        end if
	      else
	        ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2
	        rtevp1 = rtevp - rtevp2
	        if (rtwtr <= rtevp1) then
	          rtevp1 = min(rtevp1, rtwtr)
	          rtwtr = rtwtr - rtevp1
	        else
	          rtwtr = rtwtr - rtevp1
	        end if
	      end if
	      rtevp = rtevp1 + rtevp2
        end if

      else
        rtwtr = 0.
        sdti = 0.
	    ch(jrch)%rchstor = 0.
	    ch(jrch)%vel_chan = 0.
        ch(jrch)%flwin = 0.
        ch(jrch)%flwout = 0.
      end if

      if (rtwtr < 0.) rtwtr = 0.
      if (ch(jrch)%rchstor < 0.) ch(jrch)%rchstor = 0.

      return
      end subroutine ch_rtday


      SUBROUTINE GOVER(NI,NJ,XI,XJ,R,SG)
************************************************************************
*                                                                      *
*   GOVER CALCULATES THE OVERLAP INTEGRALS USING A GAUSSIAN EXPANSION  *
*         STO-6G BY R.F. STEWART, J. CHEM. PHYS., 52 431-438, 1970     *
*                                                                      *
*         ON INPUT   NI   =  ATOMIC NUMBER OF FIRST ATOM               *
*                    NJ   =  ATOMIC NUMBER OF SECOND ATOM              *
*                    R    =  INTERATOMIC DISTANCE IN ANGSTROMS         *
*         ON EXIT    S    =  9X9 ARRAY OF OVERLAPS, IN ORDER S,PX,PY,  *
*                            PZ                                        *
*                                                                      *
************************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      COMMON /NATYPE/ NZTYPE(107), MTYPE(10),LTYPE
      COMMON /TEMP/  C(60,6), Z(60,6)
      COMMON /NATORB/ NATORB(107)
      DIMENSION S(6,6), XI(3),XJ(3), SG(9,9)
      DATA NGAUSS/6/
C
C    FIND START AND END OF GAUSSIAN
C
      IFA=NZTYPE(NI)*4-3
      IF(C(IFA+1,1).NE.0.D0)THEN
         ILA=IFA+3
      ELSE
         ILA=IFA
      ENDIF
      IFB=NZTYPE(NJ)*4-3
      IF(C(IFB+1,1).NE.0.D0)THEN
         ILB=IFB+3
      ELSE
         ILB=IFB
      ENDIF
C
C  CONVERT R INTO AU
C
      R=R/0.529167D0
      R = R**2
      KA=0
      DO 80 I=IFA,ILA
         KA=KA+1
         NAT=KA-1
         KB=0
         DO 80 J=IFB,ILB
            KB=KB+1
            NBT=KB-1
C
C         DECIDE IS IT AN S-S, S-P, P-S, OR P-P OVERLAP
C
            IF(NAT.GT.0.AND.NBT.GT.0) THEN
C    P-P
               IS=4
               TOMB=(XI(NAT)-XJ(NAT))*(XI(NBT)
     1-XJ(NBT))*3.5711928576D0
            ELSEIF(NAT.GT.0) THEN
C    P-S
               IS=3
               TOMB=(XI(NAT)-XJ(NAT))*1.88976D0
            ELSEIF(NBT.GT.0) THEN
C    S-P
               IS=2
               TOMB=(XI(NBT)-XJ(NBT))*1.88976D0
            ELSE
C    S-S
               IS=1
            ENDIF
            DO 60 K=1,NGAUSS
               DO 60 L=1,NGAUSS
                  S(K,L)=0.0D0
                  AMB=Z(I,K)+Z(J,L)
                  APB=Z(I,K)*Z(J,L)
                  ADB=APB/AMB
C
C           CHECK OF OVERLAP IS NON-ZERO BEFORE STARTING
C
                  IF((ADB*R).LT.90.D0) THEN
                     ABN=1.0D0
                     GO TO(50,10,20,30),IS
   10                ABN=2.*TOMB*Z(I,K)*SQRT(Z(J,L))/AMB
                     GO TO 50
   20                ABN=-2.*TOMB*Z(J,L)*SQRT(Z(I,K))/AMB
                     GO TO 50
   30                ABN=-ADB*TOMB
                     IF(NAT.EQ.NBT) ABN=ABN+0.5D0
   40                ABN=4.0D0*ABN*SQRT(APB)/AMB
   50                S(K,L)=SQRT((2.*SQRT(APB)/AMB)**3)*EXP(-ADB*R)*ABN
                  ENDIF
   60       CONTINUE
            SG(KA,KB)=0.0D0
            DO 70 K=1,NGAUSS
               DO 70 L=1,NGAUSS
   70       SG(KA,KB)=SG(KA,KB)+S(K,L)*C(I,K)*C(J,L)
   80 CONTINUE
      RETURN
      END


c **********************************************************************
c This SOFTWARE  has been authored  by an employee   or employees of the
c University  of  California, operator    of the  Los   Alamos  National
c Laboratory  under Contract No. W-7405-ENG-36  with the U.S. Department
c of  Energy.   The U.S. Government  has  rights to use,  reproduce, and
c distribute this SOFTWARE.   The  public may copy,  prepare  derivative
c works and publicly display this SOFTWARE without charge, provided that
c this  Notice  and any statement  of  authorship are  reproduced on all
c copies.  Neither the Government nor the University makes any warranty,
c express or implied, or assumes any liability or responsibility for the
c use  of this SOFTWARE.  If SOFTWARE  is modified to produce derivative
c works, such  modified SOFTWARE should be clearly  marked, so as not to
c confuse it with the version available from LANL.
c
c It is expressly forbidden to distribute this code, in whole or in part,
c either as is or modified.
c **********************************************************************

c: msubs - assorted utility routines of a matrix or array nature
c:

      subroutine dmnmx(x,natom,xmin,xmax,ixmin,ixmax)
c: finds min and max in array x, returns values(xmin,xmax) and pointers(ixmin,ixmax)
c:
      implicit real*8(a-h,o-z)
      dimension x(natom)
      ixmin=1
      ixmax=1
      do 10 i=1,natom
      if(x(i).lt.x(ixmin)) ixmin=i
      if(x(i).gt.x(ixmax)) ixmax=i
   10 continue
      xmin=x(ixmin)
      xmax=x(ixmax)
      return
      end

      subroutine dmnmxstride(x,natom,xmin,xmax,ixmin,ixmax,istride)
c: finds min and max in array x, returns values(xmin,xmax) and pointers(ixmin,ixmax)
c: runs through array with stride istride, looking at natom elements
c:
      implicit real*8(a-h,o-z)
      dimension x(natom*istride)
      ixmin=1
      ixmax=1
      do 10 i=1,natom*istride,istride
      if(x(i).lt.x(ixmin)) ixmin=i
      if(x(i).gt.x(ixmax)) ixmax=i
   10 continue
      xmin=x(ixmin)
      xmax=x(ixmax)
      return
      end

      subroutine rmnmx(x,natom,xmin,xmax,ixmin,ixmax)
c: finds min and max in array x, returns values(xmin,xmax) and pointers(ixmin,ixmax)
c:
      implicit real*4(a-h,o-z)
      dimension x(natom)
      ixmin=1
      ixmax=1
      do 10 i=1,natom
      if(x(i).lt.x(ixmin)) ixmin=i
      if(x(i).gt.x(ixmax)) ixmax=i
   10 continue
      xmin=x(ixmin)
      xmax=x(ixmax)
      return
      end

      function imax(ia,n)
c: finds max integer in array ia
c:
      dimension ia(n)
      if(n.eq.0) then
        imax=0
        return
      else
        imax=ia(1)
      end if
      do 10 i=1,n
      if(ia(i).gt.imax) imax=ia(i)
   10 continue
      return
      end

      function dmax(a,n)
c:  finds max value in real*8 array a
c:
      implicit real*8(a-h,o-z)
      dimension a(n)
      dmax=a(1)
      do 10 i=1,n
      if(a(i).gt.dmax) dmax=a(i)
   10 continue
      return
      end

      function dmin(a,n)
c:  finds min value in real*8 array a
c:
      implicit real*8(a-h,o-z)
      dimension a(n)
      dmin=a(1)
      do 10 i=1,n
      if(a(i).lt.dmin) dmin=a(i)
   10 continue
      return
      end

      subroutine dmfac(a,n,fac)
c:  multiplies each of the n elements in real*8 array a by fac
c:
      implicit real*8(a-h,o-z)
      dimension a(n)
      do 10 i=1,n
      a(i)=a(i)*fac
   10 continue
      return
      end

      subroutine dmave(a,n,ave)
c:  finds average of the n elements in real*8 array a
c:
      implicit real*8(a-h,o-z)
      dimension a(n)
      sum=0.0d0
      do 10 i=1,n
      sum=sum+a(i)
   10 continue
      ave=sum/float(n)
      return
      end

      subroutine dmzer(a,n)
c:  zeros each of the n elements in real*8 array a
c:
      implicit real*8(a-h,o-z)
      dimension a(n)
      do 10 i=1,n
      a(i)=0.0d0
   10 continue
      return
      end

      subroutine imzer(ia,n)
c:  zeros each of the n elements in integer array ia
c:
      implicit real*8(a-h,o-z)
      dimension ia(n)
      do 10 i=1,n
      ia(i)=0
   10 continue
      return
      end

      subroutine nanchk(x,n)
c:  checks whether x is a bad number (either inf or NaN)
c:
      implicit real*8(a-h,o-z)
      dimension x(n)
      do 10 i=1,n
      if(x(i).ne.x(i)) then
        write(6,*) 'bad number found:',x(i)
         stop 'nanchk - bad number found'
      end if
   10 continue
      return
      end

      subroutine lag4pt(x,xn,fn,f)
c:  4 point lagrangian interpolation (Abrom. and Stegun, pg 878)
c:
      implicit real*8(a-h,o-z)
      real*8 l(4)
      dimension xn(4),fn(4)

      l(1)=(x-xn(2))*(x-xn(3))*(x-xn(4)) /
     >     ( (xn(1)-xn(2))*(xn(1)-xn(3))*(xn(1)-xn(4)) )
      l(2)=(x-xn(1))*(x-xn(3))*(x-xn(4)) /
     >     ( (xn(2)-xn(1))*(xn(2)-xn(3))*(xn(2)-xn(4)) )
      l(3)=(x-xn(1))*(x-xn(2))*(x-xn(4)) /
     >     ( (xn(3)-xn(1))*(xn(3)-xn(2))*(xn(3)-xn(4)) )
      l(4)=(x-xn(1))*(x-xn(2))*(x-xn(3)) /
     >     ( (xn(4)-xn(1))*(xn(4)-xn(2))*(xn(4)-xn(3)) )

      f=0.0d0
      do 10 i=1,4
        f=f+l(i)*fn(i)
   10 continue

      return
      end

      subroutine mwrit(iunit,a,n)
c:  writes square matrix out to unit iunit
c:
      implicit real*8(a-h,o-z)
      dimension a(n,n)

      do 10 i=1,n
      write(iunit,20) (a(i,j),j=1,n)
   20 format(1x,1p10d10.2)
   10 continue

      return
      end

      subroutine mwritg(iunit,title,a,nrdim,nr,nc)
c:  writes rectangular matrix out to unit iunit
c:
      implicit real*8(a-h,o-z)
      character*(*) title
      dimension a(nrdim,nc)

c   allow up to 3 blank lines before matrix print starts
c   signaled by '/' in title card
      iskip=0
      do 2 i=1,3
      if(title(i:i).eq.'/') then
        write(iunit,*) ' '
        iskip=iskip+1
      end if
    2 continue

      write(iunit,5) title(1+iskip:len(title))
    5 format(1x,a)
      do 10 i=1,nr
      write(iunit,20) (a(i,j),j=1,nc)
   20 format(1x,1p10d10.2)
   10 continue

      return
      end

      subroutine mwritt(iunit,a,n)
c:  writes trianular matrix out to unit iunit
c:
      implicit real*8(a-h,o-z)
      dimension a(n)

      ii=0
      do 10 i=1,n
      write(iunit,20) (a(ii+j),j=1,i)
      ii=ii+i
   20 format(1x,1p10d10.2)
   10 continue
      return
      end

      subroutine moscan(a,n)
c:  scans square matrix for largest off-diagonal element
c:
      implicit real*8(a-h,o-z)
      dimension a(n,n)

      amax=0.0d0
      do 20 i=1,n
      do 10 j=1,n
      if(abs(a(i,j)).gt.amax .and. i.ne.j) then
        amax=abs(a(i,j))
        iimax=i
        jjmax=j
      end if
   10 continue
   20 continue

      write(6,50) iimax,jjmax,a(iimax,jjmax)
   50 format(' largest off-diagonal element:',i4,i4,1pd12.3)

      return
      end

      subroutine mvmult(a,v,c,n)
c:  performs matrix-vector multiply:  c=A*v
c:
      implicit real*8(a-h,o-z)
      dimension a(n,n),v(n),c(n)

      do 10 i=1,n
      do 10 j=1,n
      c(i)=c(i) + a(i,j)*v(j)
   10 continue

      return
      end

      subroutine mvmulth(a,v,c,n)
c:  performs matrix-vector multiply:  c=A*v, where A is upper symmetric half matrix
c:
      implicit real*8(a-h,o-z)
      dimension a(n*(n+1)/2),v(n),c(n)

c      do 30 i=1,n
c      v(i)=0.0d0
c      ij=i*(i-1)/2
c      do 10 j=1,i
c      ij=ij+1
c      c(i)=c(i) + a(ij)*v(j)
c   10 continue
c      do 20 j=i+1,n
c      ij=ij+j-1
c      c(i)=c(i) + a(ij)*v(j)
c   20 continue
c   30 continue

      do 10 i=1,n
      c(i)=0.0d0
   10 continue

      ij=0
      do 30 i=1,n
      do 20 j=1,i
      ij=ij+1
      c(i)=c(i) + a(ij)*v(j)
      c(j)=c(j) + a(ij)*v(i)
   20 continue
      c(i)=c(i) - a(ij)*v(i)
   30 continue

      return
      end

      subroutine vecaxpy(n,a,x,y)
c: performs y(i) = a*x(i) + y(i)  , i=1,n
c: like daxpy, but without increment option
c:
      implicit real*8(a-h,o-z)
      dimension x(n),y(n)

      do 10 i=1,n
      y(i)=y(i) + a*x(i)
   10 continue

      return
      end

      subroutine vecypax(y,a,x,n)
c: performs y(i) = y(i) + a*x(i) , i=1,n
c: like daxpy, but reordered input, and without increment option
c:
      implicit real*8(a-h,o-z)
      dimension x(n),y(n)

      do 10 i=1,n
      y(i)=y(i) + a*x(i)
   10 continue

      return
      end

      subroutine vecswap(a,b,n,work)
c:  swaps n=long vector a with n-long vector b using work space in work(n)
c:
      implicit real*8(a-h,o-z)
      dimension a(n),b(n),work(n)

      do 10 i=1,n
      work(i)=a(i)
      a(i)=b(i)
      b(i)=work(i)
   10 continue

      return
      end

      subroutine scalswap(a,b)
c:  swaps scalar a with scalar b
c:
      implicit real*8(a-h,o-z)

      temp=a
      a=b
      b=a

      return
      end

      subroutine mchebrecur(t3,x,t2,t1,n)
c:  performs Chebyshev recursion matrix operation:  T3 = 2*X*T2 - T1
      implicit real*8(a-h,o-z)
      dimension t1(n,n),t2(n,n),t3(n,n)
      dimension x(n,n) !! rjz -- wrong?
      call mmmult(x,t2,t3,n)
      do 10 i=1,n
      do 10 j=1,n
      t3(i,j)=2.0d0*t3(i,j)-t1(i,j)
   10 continue

      return
      end

      subroutine mmmult(a,b,c,n)
c:  performs matrix multiply:  C=A*B  (simply calls mmab)
      implicit real*8(a-h,o-z)
      dimension a(n,n),b(n,n),c(n,n)

      call mmab(a,b,c,n)

      return
      end

      subroutine mmab(a,b,c,n)
c:  performs matrix multiply:  C=A*B
c:  optimized for HP 735 -- compile with +OP2, 3 or 4 (4 is probably best)
c:
      implicit real*8(a-h,o-z)
      dimension a(n,n),b(n,n),c(n,n)

      if(n.le.300) then

        do 10 i=1,n
        do 10 j=1,n
        c(i,j)=0.0d0
        do 10 k=1,n
        c(i,j)=c(i,j) + a(i,k)*b(k,j)
   10   continue

      else

c  transpose A
        do 20 i=1,n
        do 20 j=1,n
        temp=a(i,j)
        a(i,j)=a(j,i)
        a(j,i)=temp
   20   continue
c  multiply ATT*B
        do 30 i=1,n
        do 30 j=1,n
        c(i,j)=0.0d0
        do 30 k=1,n
        c(i,j)=c(i,j) + a(k,i)*b(k,j)
   30   continue
c  untranspose A
        do 40 i=1,n
        do 40 j=1,n
        temp=a(i,j)
        a(i,j)=a(j,i)
        a(j,i)=temp
   40   continue
      end if

      return
      end

      subroutine vvadd(a,b,c,n)
c:  performs vector-vector add:  c=a+b
c:
      implicit real*8(a-h,o-z)
      dimension a(n),b(n),c(n)

        do 10 i=1,n
        c(i) = a(i) + b(i)
   10   continue

      return
      end

      subroutine xxprint(a,b,c,n)
      implicit real*8(a-h,o-z)
      dimension a(n,n),b(n,n),c(n,n)
      sum=0.0d0
      do 10 i=1,n
      do 10 j=1,n
      sum=sum+c(i,j)
   10 continue
      write(6,*) 'sum= ', sum
      return
      end

      real*8 function vecdot(a,b,n)
c: vector dot product of a and b, length n
c:
      implicit real*8(a-h,o-z)
      dimension a(n),b(n)
      dot=0.0d0
      do 10 i=1,n
      dot=dot+a(i)*b(i)
   10 continue
      vecdot=dot
      return
      end

      subroutine vecrenorm(a,n)
c: renormalize vector a of length n
c:
      implicit real*8(a-h,o-z)
      dimension a(n)

      dot=0.0d0
      do 10 i=1,n
      dot=dot+a(i)*a(i)
   10 continue

      fix=1.0d0/sqrt(dot)
      do 20 i=1,n
      a(i)=fix*a(i)
   20 continue

      return
      end

      subroutine vecmsk(a,bmask,n)
c: replace each element of vector a with a(i)=a(i)*bmask(i)
c:
      implicit real*8(a-h,o-z)
      dimension a(n),bmask(n)
      dot=0.0d0
      do 10 i=1,n
      a(i)=a(i)*bmask(i)
   10 continue
      return
      end

      subroutine vecred(v,n,crit)
c: zero each element of v whose abs value is less than crit
c: red== "reduce"
c:
      implicit real*8(a-h,o-z)
      dimension v(n)
      do 10 i=1,n
      if(abs(v(i)).lt.crit) v(i)=0.0d0
   10 continue
      return
      end

      subroutine vecmov(a,b,n)
c: copy vector a into b, length n
c:
      implicit real*8(a-h,o-z)
      dimension a(n),b(n)
      do 10 i=1,n
      b(i)=a(i)
   10 continue
      return
      end

      subroutine ivecmov(ia,ib,n)
c: copy integer vector a into b, length n
c:
      implicit real*8(a-h,o-z)
      dimension ia(n),ib(n)
      do 10 i=1,n
      ib(i)=ia(i)
   10 continue
      return
      end


!
! MAIN PROGRAM HERE. This is just an example so you know
! how to use it. This file is in the public domain.
!

module time_kdtree
  use kdtree2_precision_module
  use kdtree2_module
contains

real function time_search(tree,nsearch,mode, nn, r2)
    !
    ! Return CPU time, in seconds, for searching 'nsearch' reference points
    ! using any specific search mode.
    !

    type(kdtree2), pointer :: tree
    integer, intent(in) :: nsearch ! how many reference points
    integer, intent(in) :: mode ! what kind of search
    integer, intent(in) :: nn ! number of neighbors
    real(kdkind), intent(in) :: r2 ! radius^2
    !
    real(kdkind) :: qv(tree%dimen), rv ! query vector, random variate
    integer :: i, random_loc, nf
    real :: t0, t1
    type(kdtree2_result), allocatable :: results(:)

    real(kind(0.0d0)) :: nftotal
    call cpu_time(t0) ! get initial time.
    nftotal = 0.0

    allocate(results(nn))
    do i=1,nsearch

       select case (mode)
       case (1)
          !
          ! Fixed NN search around randomly chosen point
          !
          call random_number(qv)
          call kdtree2_n_nearest(tp=tree,qv=qv,nn=nn,results=results)
       case (2)
          !
          ! Fixed NN seasrch around randomly chosen point in dataset
          ! with 100 correlation time
          !
          call random_number(rv)
          random_loc = floor(rv*tree%n) + 1
          call kdtree2_n_nearest_around_point(tp=tree,idxin=random_loc,&
           correltime=100,nn=nn,results=results)
       case (3)
          !
          ! fixed r2 search
          !
          call random_number(qv)
          call kdtree2_r_nearest(tp=tree,qv=qv,r2=r2,nfound=nf,&
           nalloc=nn,results=results)
          nftotal = nftotal+nf
       case default
          write (*,*) 'Search type ', mode, ' not implemented.'
          time_search = -1.0 ! invalid
          return
end select

enddo
    call cpu_time(t1)

    time_search = t1-t0
    if (nftotal .gt. 0.0) then
! write (*,*) 'Average number of neighbors found = ', nftotal / real(nsearch)
    endif
deallocate(results)
    return
end function time_search

  real function searches_per_second(tree,mode,nn,r2) result(res)
    !
    !
    ! return estimated number of searches per second.
    ! Will call "time_search" with increasing numbers of reference points
    ! until CPU time taken is at least 1 second.
    !
    type(kdtree2), pointer :: tree
    integer, intent(in) :: mode ! what kind of search
    integer, intent(in) :: nn ! number of neighbors
    real(kdkind), intent(in) :: r2 ! radius^2
    !
    integer :: nsearch
    real :: time_taken

    nsearch = 50 ! start with 50 reference points
    do
time_taken = time_search(tree,nsearch,mode,nn,r2)
       if (time_taken .lt. 1.0) then
! write (*,*) 'Intermediate result : ', time_taken, &
! 'sec, nref=',nsearch
          nsearch = nsearch * 5
          cycle
else
res = real(nsearch) / time_taken
          return
end if
end do
return
end function searches_per_second

  real(kdkind) function average_number_within_ball(tree,navg,r2) result(res)
    ! return the arithmetical average number of points within ball of size
    ! 'r2'
    !
    ! log(avg) = 1/navg log(N_within_ball(i))
    type(kdtree2), pointer :: tree
    integer,intent(in) :: navg
    real(kdkind), intent(in) :: r2
    !
    integer :: i, cnt
    real(kdkind) :: sum, qv(tree%dimen)
    sum = 0.0
    do i=1,navg
       call random_number(qv)
       cnt = kdtree2_r_count(tree,qv,r2)
       if (cnt .gt. 0) sum = sum + real(cnt)
    end do

res = sum/real(navg, kdkind)
    return
end function average_number_within_ball

end module time_kdtree

program kd_tree_test
  use kdtree2_module
  use time_kdtree

  integer :: n, d
  real(kdkind), dimension(:,:), allocatable :: my_array
  real(kdkind), allocatable :: query_vec(:)

  type(kdtree2), pointer :: tree, tree2, tree3
  ! this is how you declare a tree in your main program

  integer :: k

  type(kdtree2_result),allocatable :: results(:), resultsb(:)
  integer :: nnbrute, rind
  real(kdkind) :: t0, t1, sps, avgnum, maxdeviation
  real(kdkind) :: rv
  integer, parameter :: nnn = 5
  integer, parameter :: nr2 = 5
  real r2array(5)
  data r2array / 1.0e-4,1.0e-3,5.0e-3,1.0e-2,2.0e-2 /
  integer :: nnarray(5)
  data nnarray / 1, 5, 10, 25, 500/

  print *, "Type in N and d"
  read *, n, d

  allocate(my_array(d,n))
  allocate(query_vec(d))
  call random_number(my_array) !fills entire array with built-in-randoms

  call cpu_time(t0)
  tree => kdtree2_create(my_array,sort=.false.,rearrange=.false.) ! this is how you create a tree.
  call cpu_time(t1)
!  write (*,*) real(n)/real(t1-t0), ' points per second built for non-rearranged tree.'

  call cpu_time(t0)
  tree2 => kdtree2_create(my_array,sort=.false.,rearrange=.true.) ! this is how you create a tree.
  call cpu_time(t1)
  write (*,*) real(n)/real(t1-t0), ' points per second built for rearranged tree.'

  call cpu_time(t0)
  tree3 => kdtree2_create(my_array,sort=.true.,rearrange=.true.) ! this is how you create a tree.
  call cpu_time(t1)
  write (*,*) real(n)/real(t1-t0), ' points per second built for 2nd rearranged tree.'

  nnbrute = 50
  allocate(results(nnbrute), resultsb(nnbrute))

  write (*,*) 'Comparing search of ', nnbrute, ' neighbors to brute force.'
  do k=1,50
     !
     !
     call random_number(rv)
     rind = floor(rv*tree3%n)+1
     query_vec = my_array(:,rind)

     ! find five nearest neighbors to.
     results(:)%idx = -666
     resultsb(:)%idx = -777

     call kdtree2_n_nearest_brute_force(tp=tree3, qv=query_vec, nn=nnbrute, results=resultsb)

     call kdtree2_n_nearest_around_point(tp=tree3,idxin=rind,correltime=-1,nn=nnbrute, results=results)
     ! negative 1 correlation time will get all points.

     maxdeviation = maxval(abs(results(1:nnbrute)%dis - resultsb(1:nnbrute)%dis))
     if (any(results(1:nnbrute)%idx .ne. resultsb(1:nnbrute)%idx) .or. &
      (maxdeviation .gt. 1.0e-8)) then
write (*,*) 'MISMATCH! @ k=',k

        print *, "Tree indexes = ", results(1:nnbrute)%idx
        print *, "Brute indexes = ", resultsb(1:nnbrute)%idx
        print *, "Tree-brute distances = ", results(1:nnbrute)%dis- resultsb(1:nnbrute)%dis
     endif
enddo

10 format('R^2 search, r2/d=',G10.2,':',F13.0,A)
20 format(A,' NN=',I7,':',F10.0,' searches/s in ',A)

  if (.true.) then
     ! simple testing to mimic kdtree_test_old
     !
     do k=1,nnn
        sps =searches_per_second(tree2,1,nnarray(k),1.0_kdkind)
        write (*,20) 'Random pts',nnarray(k),sps,'rearr. tree.'

     end do
do k=1,nnn
        sps = searches_per_second(tree2,2,nnarray(k),1.0_kdkind)
        write (*,20) 'in-data pts',nnarray(k),sps,'reearr. tree.'
     end do
else
do k=1,nr2
        avgnum = average_number_within_ball(tree2,500,r2array(k)* &
         real(d,kdkind))
        write (*,*) 'Avg number within ', r2array(k)*real(d,kdkind),'=',avgnum
     end do

do k=1,nnn
        sps =searches_per_second(tree,1,nnarray(k),1.0_kdkind)
        write (*,20) 'Random pts',nnarray(k),sps,'regular tree.'
        sps =searches_per_second(tree2,1,nnarray(k),1.0_kdkind)
        write (*,20) 'Random pts',nnarray(k),sps,'rearr. tree.'
        sps =searches_per_second(tree3,1,nnarray(k),1.0_kdkind)
        write (*,20) 'Random pts',nnarray(k),sps,'rearr./sorted tree.'
     enddo

     do k=1,nnn
        sps = searches_per_second(tree,2,nnarray(k),1.0_kdkind)
        write (*,20) 'in-data pts',nnarray(k),sps,'regular tree.'
        sps = searches_per_second(tree2,2,nnarray(k),1.0_kdkind)
        write (*,20) 'in-data pts',nnarray(k),sps,'reearr. tree.'
        sps =searches_per_second(tree3,2,nnarray(k),1.0_kdkind)
        write (*,20) 'in-data pts',nnarray(k),sps,'rearr./sorted tree.'
     enddo

     do k=1,nr2
        sps =searches_per_second(tree,3,20000,r2array(k)*real(d,kdkind))
        write (*,10) r2array(k),sps, ' searches/s'
        sps =searches_per_second(tree2,3,20000,r2array(k)*real(d,kdkind))
        write (*,10) r2array(k), sps, ' searches/s in rearranged tree'
        sps =searches_per_second(tree3,3,20000,r2array(k)*real(d,kdkind))
        write (*,10) r2array(k), sps, ' searches/s in rearranged/sorted tree'
     end do
end if
call kdtree2_destroy(tree)
  call kdtree2_destroy(tree2)
  call kdtree2_destroy(tree3)
  ! this releases memory for the tree BUT NOT THE ARRAY OF DATA YOU PASSED
  ! TO MAKE THE TREE.

  deallocate(my_array)
  ! deallocate the memory for the data.

end program kd_tree_test


      PROGRAM SQUARES

      CALL SQUARE(10)
      END

      SUBROUTINE SQUARE(N)
      SUM = 1
      DO 10 I = 1, N
         WRITE (*,'(I10,$)') (I*I)
 10   CONTINUE
      PRINT *, ""
      END


PROGRAM cube_test
    USE Precision
    USE vtk_datasets,   ONLY : rectlnr_grid
    USE vtk_attributes, ONLY : scalar, attributes
    USE vtk,            ONLY : vtk_legacy_write
    IMPLICIT NONE
    !! author: Ian Porter
    !! date: 12/20/2017
    !!
    !! This is a test of a cube geometry using a rectilinear grid
    !!
    INTEGER(i4k), PARAMETER     :: n_params_to_write = 3
    TYPE (rectlnr_grid)         :: cube
    TYPE (attributes), DIMENSION(n_params_to_write) :: vals_to_write
    INTEGER(i4k)                :: i = 0_i4k
    INTEGER(i4k),     PARAMETER :: n_x = 11, n_y = 6, n_z = 3, unit = 20
    REAL(r8k)                   :: j = 0.0_r8k
    REAL(r8k),        PARAMETER :: temp_val = 555.0_r8k
    CHARACTER(LEN=*), PARAMETER :: filename = 'cube.vtk'
    CHARACTER(LEN=*), PARAMETER :: title    = 'Testing of cube geometry'
    INTEGER(i4k), DIMENSION(3)  :: dims
    REAL(r8k), DIMENSION(n_x), PARAMETER :: x_coords = &
      & [ 0.1_r8k, 0.2_r8k, 0.3_r8k, 0.4_r8k, 0.5_r8k, 0.6_r8k, 0.7_r8k, 0.8_r8k, 0.9_r8k, 1.0_r8k, 1.1_r8k ]
    REAL(r8k), DIMENSION(n_y), PARAMETER :: y_coords = &
      & [ 0.2_r8k, 0.4_r8k, 0.6_r8k, 0.8_r8k, 1.0_r8k, 1.2_r8k ]
    REAL(r8k), DIMENSION(n_z), PARAMETER :: z_coords = &
      & [ 0.5_r8k, 1.0_r8k, 1.5_r8k ]
    REAL(r8k), DIMENSION(n_x*n_y*n_z,1:n_params_to_write) :: vals
    CHARACTER(LEN=20), DIMENSION(n_params_to_write), PARAMETER :: dataname = &
      & [ 'Temperature_(K)     ', 'Pressure_(Pa)       ', 'Stress_(Pa)         ' ]

    vals(1,:) = temp_val
    DO i = 2, SIZE(vals,DIM=1)
        IF (i <= SIZE(vals) / 2) THEN
            vals(i,1) = vals(i-1,1) + 2.0_r8k          !! Temperature
        ELSE
            vals(i,1) = vals(i-1,1) - 2.0_r8k          !! Temperature
        END IF
        j = j + 1.0_r8k
        vals(i,2) = vals(i-1,2) + MAX(50.0_r8k, j)     !! Pressure
        vals(i,3) = vals(i-1,3) + SQRT(REAL(i))        !! Stress
    END DO
    dims = (/ n_x, n_y, n_z /)
    CALL cube%init (dims=dims, x_coords=x_coords, y_coords=y_coords, z_coords=z_coords)
    DO i = 1, n_params_to_write
        IF (.NOT. ALLOCATED(vals_to_write(i)%attribute))THEN
            ALLOCATE(scalar::vals_to_write(i)%attribute)
            vals_to_write(1)%n = SIZE(vals(:,1))
        END IF
        CALL vals_to_write(i)%attribute%init (dataname(i), numcomp=1, values1d=vals(:,i))
    END DO

    CALL vtk_legacy_write (unit, cube, pointdatasets=vals_to_write, filename=filename, title=title)

    WRITE(*,*) 'Finished'

END PROGRAM cube_test


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2019 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program frank_matrix
  use rokko
  use mpi
  implicit none
  integer :: dim
  type(rokko_distributed_matrix) :: mat, Z
  type(rokko_parallel_dense_ev) :: solver
  type(rokko_grid) :: grid
  type(rokko_mapping_bc) :: map
  type(rokko_eigen_vector) :: w
  character(len=:), allocatable :: library, routine
  character(len=:), allocatable :: library_routine, tmp_str
  double precision, allocatable, dimension(:,:) :: array, array_tmp

  integer :: provided,ierr, myrank, nprocs
  integer :: i, j, proc

  call MPI_init_thread(MPI_THREAD_MULTIPLE, provided, ierr)
  call MPI_comm_rank(MPI_COMM_WORLD, myrank, ierr)
  call MPI_comm_size(MPI_COMM_WORLD, nprocs, ierr)

  if (command_argument_count() >= 1) then
     call get_command_argument_deferred(1, library_routine)
  else
     library_routine = rokko_parallel_dense_ev_default_solver()
  endif
  call rokko_split_solver_name(library_routine, library, routine)

  if (command_argument_count() == 2) then
     call get_command_argument_deferred(2, tmp_str)
     read(tmp_str, *) dim
  else
     dim = 10
  endif

  if (myrank == 0) then
     print *,"library = ", library
     print *,"routine = ", routine
     print *,"matrix dimension = ", dim
  endif

  call rokko_parallel_dense_ev_construct(solver, library)
  call rokko_grid_construct(grid, MPI_COMM_WORLD, rokko_grid_row_major)
  call rokko_parallel_dense_ev_default_mapping(solver, dim, grid, map)
  call rokko_distributed_matrix_construct(mat, map)
  call rokko_distributed_matrix_construct(Z, map)
  call rokko_eigen_vector_construct(w, dim)

  ! Generating frank matrix as a "eigen array" at all processes
  allocate(array(dim, dim))
  do i=1, dim
     do j=1, dim
        array(i,j) = dble(dim + 1 - max(i, j))
     end do
  end do

  call rokko_distributed_matrix_generate_from_array(mat, array)
  call rokko_distributed_matrix_print(mat)
  call rokko_parallel_dense_ev_diagonalize(solver, mat, w, Z)

  allocate(array_tmp(dim, dim))
  call rokko_all_gather(Z, array_tmp)
  array = matmul(transpose(array_tmp), array_tmp)
  call mpi_barrier(mpi_comm_world, ierr)

  ! Display orthogonality of eigenvectors
  do proc = 0, nprocs-1
     if (proc == myrank) then
        print*, "myrank=", myrank
        do i = 1, dim
           write(*,'(10f8.4)') (array(i, j), j=1, dim)
        end do
     endif
     call mpi_barrier(mpi_comm_world, ierr)
     !   call sleep(0.1)
  end do

  if (myrank.eq.0) then
     write(*,*) "Computed Eigenvalues = "
     do i = 1, dim
        write(*,"(f30.20)") rokko_get_elem(w ,i)
     enddo
  endif

  call mpi_barrier(mpi_comm_world, ierr)

  call rokko_distributed_matrix_destruct(mat)
  call rokko_distributed_matrix_destruct(Z)
  call rokko_eigen_vector_destruct(w)
  call rokko_parallel_dense_ev_destruct(solver)
  call rokko_grid_destruct(grid)
  deallocate(array,array_tmp)

  call MPI_finalize(ierr)
end program frank_matrix


!****************************************************
!   Weighted Least Squares Spectrum
!
!   Input:
!       spec [options] [inputfile] [outputfile]
!
!   Options:
!       -p         Power spectrum (default)
!       -a         Amplitude spectrum
!       -pd        Power density spectrum
!       -tday      Treat times as days (default)
!       -tsec      Treat times as seconds
!       -kplrraw   Input file is a Kepler data file (use raw columns)
!       -kplrpdc   Input file is a Kepler data file (use PDC columns)
!       -kplrwg    Input file is a Kepler data file (use WG columns)
!       -auto      Automatic. No interaction required (experimental)
!       --ofac=number
!       -quiet     Print nothing to screen
!       -version   Print program version information
!
!   Written by
!     Rasmus Handberg
!     Department of Physics and Astronomy
!     Aarhus University
!****************************************************

program spec
	use kind_defs
	use timeseries
	implicit none
	integer :: N, j, Nspec, err
	real(dbl) :: nu_min, nu_max, dF, Pint
	real(dbl) :: nu, Tot, numax, Amax = 0
	real(dbl) :: alpha, beta, priv_max, priv_numax
	real(dbl), allocatable :: A(:), delta(:)
	real(dbl) :: ofac = 2 ! Oversampling factor when using auto
	character(200) :: buffer, inputfile = '', outputfile = '', StrSpectrumType
	logical :: bolUseWeights, UseFundamental = .false., RunAuto = .false.
	integer :: PPMNormalisation = 0 ! Default normalizaton to PPM is OFF
   	integer :: SpectrumType = 1 ! Default spectrum type is power
   	integer :: TimeType = 1 ! Default time type is days
	integer :: inputtype = 0
	real(dbl) :: t1, t2
	integer :: nargs, iargc

	! Extract parameters from command-line:
	nargs = iargc()
	do j = 1,nargs
		call getarg(j, buffer)
		select case (trim(buffer))
			case ("-a")
				SpectrumType = 0
			case ("-p")
				SpectrumType = 1
			case ("-pd")
				SpectrumType = 2
			case ("-tsec")
				TimeType = 0
			case ("-tday")
				TimeType = 1
			case ("-auto")
				RunAuto = .true.
			case ("-kplrraw")
				TimeType = 1
				PPMNormalisation = 1
				inputtype = 1
			case ("-kplrpdc")
				TimeType = 1
				PPMNormalisation = 1
				inputtype = 2
			case ("-kplrwg")
				TimeType = 1
				PPMNormalisation = 1
				inputtype = 3
			case ("-quiet")
				quiet = .true.
			case ("-version")
				print *, "Current version:"
				print *, "$Revision: 119 $"
				print *, "$Date: 2016-02-09 09:57:56 +0100 (ti, 09 feb 2016) $"
				stop

			case default
				buffer = trim(buffer)
				if (scan(buffer, "--ofac=") == 1) then
					buffer = buffer(8:)
					read(buffer, *) ofac
				else
					if (.not. buffer(1:1) == "-" .and. inputfile == "") then
						inputfile = trim(buffer)
					elseif (.not. buffer(1:1) == "-" .and. outputfile == "") then
						outputfile = trim(buffer)
					else
						print *, "UNKNOWN ARGUMENT: " // trim(buffer)
						stop
					endif
				endif
		end select
	enddo

	if (.not. quiet) then
		print *, "---------------------------------"
		print *, " Weighted Least Squares Spectrum "
		print *, "---------------------------------"
	endif

	! If no files were given, ask for input and make output:
	if (inputfile == "") then
        print *, 'Enter input-file:'
        read '(a50)', inputfile
	endif
	if (outputfile == '') then
		j = scan(inputfile, '/', back=.true.)
		if (j /= 0) then
			outputfile = trim(inputfile(j+1:))
		else
			outputfile = trim(inputfile)
		endif
		j = scan(outputfile, '.', back=.true.)
		if (j > 1) then
			outputfile = trim(outputfile(1:j-1)) // '.spec'
		else
			outputfile = trim(outputfile) // '.spec'
		endif
	endif

	! Read the data from the input-file:
	if (.not. quiet) then
		print *, "Reading data..."
	endif
	open(50, file=inputfile, status='old', action='read')
		! Count number of datapoints:
		call CountData(50, N, bolUseWeights, inputtype)

		! Allocate the data:
		allocate(t(1:N), f(1:N), w(1:N), stat=err)
		if (err /= 0) stop "Couldn't allocate memory!"

		! Ask to use the statistical weights:
		if (bolUseWeights .and. .not. RunAuto) then
			print *, "Do you want to use the statistical weights? (1=yes,0=no)"
			read(*, '(i1)') j
			if (j == 0) bolUseWeights = .false.
		endif
		if (.not. quiet) then
			if (bolUseWeights) then
				print *, "Using weights"
			else
				print *, "Not using weights"
			endif
		endif

		! Import the data:
		call ImportData(50, bolUseWeights, t, f, w, inputtype)
	close(50)

	! Convert time vector to seconds, based on the selected input:
	if (TimeType == 1) then
		t = t*86400_dbl
	endif

	! Apply desired scaling to PPM:
    if (PPMNormalisation == 1) then
    	f = 1e6_dbl*(f/median(f) - 1.0_dbl)
    elseif (PPMNormalisation == 2) then
    	f = 1e6_dbl*(f - 1.0_dbl)
    elseif (PPMNormalisation == 3) then
    	f = 1e6_dbl*f
    endif

	! Print information about series:
	call print_info(t, nu_max, dF)

	! Select frequencies:
	if (RunAuto) then
		nu_min = 0.0_dbl
		Pint = dF
		dF = dF/ofac
		if (.not. quiet) then
			print *, 'WARNING: Fundamental resolution not fully supported!'
			print *, 'Oversampling by factor of ' , ofac , ': ', dF
		endif
	else
		print *, ''
		print *, 'min-frequency (microHz):'
		read *, nu_min
		print *, 'max-frequency (microHz):'
		read *, nu_max
		print *, 'DeltaF (microHz):'
		read *, dF
		if (SpectrumType == 2) then
			print *, 'Integral of Spectral Window function (1/microHz):'
			read *, Pint
		endif
	endif

	! Calculate number of points in spectrum:
	call cpu_time(t1)
	if (nu_min == 0) nu_min = nu_min + dF ! Don't calculate nu=0
	Nspec = ceiling((nu_max-nu_min)/dF)+1
	if (Nspec <= 0 .or. nu_min < 0 .or. nu_max < 0) stop "Wrong frequencies!"

	if (.not. quiet) then
		print *, ""
		print *, "Points in spectrum:", Nspec
		print *, "--------------------------------"
	endif

	! Allocate memory for results:
	allocate(A(1:Nspec), delta(1:Nspec), stat=err)
	if (err /= 0) stop "Couldn't allocate memory!"

	! Subtract the mean from the data:
	f = f - mean(f,w) ! Weighted mean

	! Calcultate spectrum:
	!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(alpha,beta,nu,priv_max,priv_numax)
	priv_max = 0.0_dbl
	!$OMP DO SCHEDULE(STATIC)
	do j = 1,Nspec
		nu = nu_min+dF*(j-1)

		! Calculate alpha and beta:
		call CalcAlphaBeta(t,f,w,nu,alpha,beta)

		! Calculate power and phase:
		A(j) = alpha**2 + beta**2
		delta(j) = atan2(alpha,beta)

		! Save the local maximum in the spectrum:
		if (A(j) > priv_max) then
			priv_max = A(j)
			priv_numax = nu
		endif

		! Update progressbar:
		call Progress2(Nspec)
	enddo
	!$OMP END DO NOWAIT
	!$OMP FLUSH (Amax)
	if (priv_max > Amax) then
		!$OMP CRITICAL
			if (priv_max > Amax) then
				Amax = priv_max
				numax = priv_numax
			endif
		!$OMP END CRITICAL
	endif
	!$OMP END PARALLEL

	! Convert to the desired spectrum type
	! and construct spectrum type string:
	if (SpectrumType == 1) then
		StrSpectrumType = 'Power spectrum'
	elseif (SpectrumType == 2) then
		StrSpectrumType = 'Power density spectrum'
		A = A/Pint
		Amax = Amax/Pint
	else
		StrSpectrumType = 'Amplitude spectrum'
		A = sqrt(A)
		Amax = sqrt(Amax)
	endif
	if (bolUseWeights) then
		StrSpectrumType = 'Weighted ' // StrSpectrumType
	endif

	if (.not. quiet) then
		print *, ''
		print *, "--------------------------------"
		print '(" Amax  = ",f10.3)', Amax
		print '(" Numax = ",f10.3," microHz")', numax
    endif

	! Write spectrum to file:
	open(51, file=outputfile, status='replace', action='write')
		write(51, '(a)') '#-----------------------------------------'
		write(51, '(a)') '# SPEC'
		write(51, '(a)') '# ' // trim(inputfile)
		write(51, '(a)') '# Type: ' // trim(StrSpectrumType)
		if (SpectrumType == 2) then
			write(51, '(a,f6.4,a)') '# Pint: ', Pint, ' (1/microHz)'
		endif
		write(51, '(a,f6.4,a)') '# Resolution: ', dF, ' microHz'
		write(51, '(a)') '# Frequencies in microHz, Spectrum, Phases'
		write(51, '(a)') '#-----------------------------------------'
		do j = 1,Nspec
			nu = nu_min+dF*(j-1)
			write(51, '(3ES26.16E3)') nu, A(j), delta(j)
		enddo
	close(51)

	! Clean up memory:
	deallocate(A, delta, t, f, w)

    if (.not. quiet) then
		call cpu_time(t2)
		print *, ''
		call print_time(t2-t1)
	endif
end program spec


!******************************************************************
! Test program in Fortran 90
! To emulate Herve Carfantan's simulation
!  spdiv => Direct spectral division
!  wiene => Wiener filter
!  tikho => Tikhonov regularisation
!  maxen => Maximum Entropy method
!
! JLP
! Version 23/03/2001
!******************************************************************
program dcv_deconv_1D
 use dcv_1D_data
 use dcv_1D_mod
 implicit none
 integer			:: n_simu
 logical,parameter		:: display_all=.false.
 real				:: rms_err,ss
 integer			:: iter,pntr,nx,ny
 character(len=20)		:: extension
 character(len=40)		:: title
 character(len=60)		:: filename
 character(len=80)		:: comments

call jlp_begin
call jlp_inquifmt

print *,' Program to deconvolve 1D signals'
print *,' JLP version 23/03/2001'

print *,' Number of simulation (1 or 2): '
read(5,*) n_simu

select case(n_simu)
 case(1)
!!!! idim = 256
  extension='s1'
  nn1 = 256
! Length of the support of hh is hh_nx=5 (for this simulation)
!  hh_nx = 5
  hh_nx = 100
 case(2)
!!!! idim = 512
  extension='s2'
  nn1 = 512
! Length of the support of hh is hh_nx=32 (for this simulation)
  hh_nx = 32
 case default
  print *,' Error: n_simu=',n_simu
  stop
end select

! Read it first to determine the size:
filename=trim(extension)//'_yy0'
call jlp_vm_readimag(pntr,nx,ny,filename,comments);
if(ny /= 1 .or. nx > idim)then
   print *,' Fatal error: nx=',nx,' ny=',ny; stop;
endif
nn = nx;
! To prepare FFT's:
print *,' fft_setup with (',nn1,',1)'
call fft_setup(nn1,1)

! Then allocate memory space:
allocate(yy0(idim)); allocate(yy(idim)); allocate(hh(idim));
allocate(yyd(idim)); allocate(w0(idim)); allocate(w1(idim));
allocate(w_re(idim)); allocate(w_im(idim));
allocate(hh_re(idim)); allocate(hh_im(idim));
allocate(hht_re(idim)); allocate(hht_im(idim));
allocate(yy_re(idim)); allocate(yy_im(idim));

! Read input files:
!----------------------
! Original signal:
filename=trim(extension)//'_yy0'
call jlp_readimag(yy0,nx,ny,idim,filename,comments);
yy0(nn+1:idim)=0.;
!----------------------
! Signal to deconvolve:
filename=trim(extension)//'_yyb'
call jlp_readimag(yy,nx,ny,idim,filename,comments);
if(ny /= 1 .or. nx /= nn)then
   print *,' Fatal error: nx=',nx,' ny=',ny; stop;
endif
yy(nn+1:idim)=0.;
!----------------------
! PSF:
filename=trim(extension)//'_psf'
call jlp_readimag(hh,nx,ny,idim,filename,comments);
if(ny /= 1 .or. nx /= nn)then
   print *,' Fatal error: nx=',nx,' ny=',ny; stop;
endif
hh(nn+1:idim)=0.;

! Set to zero all arrays:
w0 = 0.; w1 = 0.;

!--------------------------------
! Check if input is OK:
if(display_all)then
  call dcv_display_input
endif

!--------------------------------
! Deconvolution
!--------------------------------

write(6,18);
18 format(/,&
' ==================== Options: ================',/,&
' - spdiv: spectral division',/,&
' - wiene: Wiener filter',/,&
' Regularisation on x_i only ',/,&
' - tikho: Tikhonov''s regularisation',/,&
' - ggaus: Generalized Gauss''s regularisation (p=1.1)',/,&
' - maxen: regularisation with maximum entropy',/,&
' - sqrtr: convex sqrt(s2+x2) regularisation',/,&
' Regularisation on x_i+1 - x_i ',/,&
' - gmark: Gauss-Markov''s regularisation (p=2)',/,&
' ======== Enter the option you want: ===========')
read(5,*) option
print *,' OK: option=',option

select case(option)

!--------------------------------
! Deconvolution by spectral division:
case('spdiv')
   call dcv_spdiv
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display signal deconvolved by spectral division:"
   write(title,10) rms_err
10 format('Spectral division:  rms=',f6.4)
   call dcv_plot2(yyd,yy0,nn,title)

!--------------------------------
! Deconvolution by Wiener filter:
case('wiene')
   alpha=1.
   call dcv_wiener
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display Wiener deconvolved signal:"
   write(title,11) alpha,rms_err
11 format('Wiener: alpha=',F4.1,' rms=',f6.4)
   if(n_simu==1)then
     call dcv_plot2(yyd,yy0,nn,title)
   else
! Bad visibility for the simulation #2,
! so only the deconvolved signal is displayed
     call dcv_plot1(yyd,nn,title)
   endif

!--------------------------------
! Deconvolution with Tikhonov's regularisation
! Generalized Gauss with p=2
case('tikho')
   print *,' Enter alpha value: '; read(5,*)alpha
   call dcv_tikhonov(iter)
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display Tikhonov deconvolved signal:"
   write(title,12) alpha,rms_err,iter
12 format('Tikhonov: alpha=',F4.1,' rms=',f6.4,' iter=',I3)
   call dcv_plot2(yyd,yy0,nn,title)

!--------------------------------
! Deconvolution with generalized Gauss' regularisation
! with p=1.1
case('ggaus')
   print *,' Enter alpha value: '; read(5,*)alpha
   call dcv_ggauss(iter)
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display generalized Gauss deconvolved signal:"
   write(title,13) alpha,rms_err,iter
13 format('Gen. Gauss: alpha=',F4.1,' rms=',f6.4,' it=',I3)
   call dcv_plot2(yyd,yy0,nn,title)

!--------------------------------
! Deconvolution with convex sqrt(s2+x2) regularisation
case('sqrtr')
   print *,' Enter alpha and s: (0.1,0.001) '; read(5,*)alpha,ss
   call dcv_sqrtrf(ss,iter)
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display convex sqrt regul. deconvolved signal:"
   write(title,14) ss,alpha,rms_err,iter
14 format('sqrt: s=',F4.3,'alpha=',F4.1,' rms=',f6.4,' it=',I3)
   call dcv_plot2(yyd,yy0,nn,title)

!--------------------------------
! Deconvolution with Maximum Entropy method
case('maxen')
   print *,' Enter alpha value: '; read(5,*)alpha
   call dcv_mem(iter)
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display MEM deconvolved signal:"
   write(title,15) alpha,rms_err,iter
15 format('MEM: alpha=',F4.1,' rms=',f6.4,' iter=',I3)
   call dcv_plot2(yyd,yy0,nn,title)

!--------------------------------
! Deconvolution with Gauss Markov regularisation (on x_i+1 - x_i)
case('gmark')
   print *,' Enter alpha: '; read(5,*)alpha
   call dcv_gmark(iter)
   yyd(nn+1:idim) = 0.; yy0(nn+1:idim) = 0.;
   rms_err=sqrt(sum((yyd-yy0)**2))/float(nn)
   print *,'rms error=',rms_err
   write(6,*) "Display Gauss-Markov deconvolved signal:"
   write(title,16) alpha,rms_err,iter
16 format('Gauss-Markov alpha=',F4.1,' rms=',f5.3,' it=',I3)
   call dcv_plot2(yyd,yy0,nn,title)

!---------------------------------
! Test with Banana function:
case('banan')
   call dcv_banana
case default
   print *,' Fatal: invalid option'
   stop
end select

call jlp_end

end program dcv_deconv_1D


c---------------------------------------------------------------------
c---------------------------------------------------------------------

        subroutine verify(no_time_steps, verified, num_zones,
     $                    rho_i, us, vs, ws, speed, qs, square,
     $                    rhs, forcing, u, nx, nxmax, ny, nz)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c  verification routine
c---------------------------------------------------------------------

        include 'header.h'
        include 'mpi_stuff.h'

        integer zone, num_zones
        double precision rho_i(*), us(*), vs(*), ws(*), speed(*),
     $                   qs(*), square(*), rhs(*), forcing(*), u(*)

        double precision xcrref(5),xceref(5),xcrdif(5),xcedif(5),
     >                   epsilon, xce(5), xcr(5), dtref,
     $                   xce_sub(5), xcr_sub(5)
        integer m, no_time_steps, niterref, iz, ip
        integer nx(*), nxmax(*), ny(*), nz(*)
        logical verified

c---------------------------------------------------------------------
c   tolerance level
c---------------------------------------------------------------------
        epsilon = 1.0d-08

c---------------------------------------------------------------------
c   compute the error norm and the residual norm
c---------------------------------------------------------------------

        do m = 1, 5
          xcr(m) = 0.d0
          xce(m) = 0.d0
        end do

        do iz = 1, proc_num_zones
          zone = proc_zone_id(iz)
          call error_norm (xce_sub, u(start5(iz)),
     $                     nx(zone), nxmax(zone), ny(zone), nz(zone))
          call compute_rhs(rho_i(start1(iz)), us(start1(iz)),
     $                     vs(start1(iz)), ws(start1(iz)),
     $                     speed(start1(iz)), qs(start1(iz)),
     $                     square(start1(iz)), rhs(start5(iz)),
     $                     forcing(start5(iz)), u(start5(iz)),
     $                     nx(zone), nxmax(zone), ny(zone), nz(zone))

          call rhs_norm   (xcr_sub, rhs(start5(iz)),
     $                     nx(zone), nxmax(zone), ny(zone), nz(zone))

          do m = 1, 5
            xcr(m) = xcr(m) + xcr_sub(m) / dt
            xce(m) = xce(m) + xce_sub(m)
          end do

        end do

        do m = 1, 5
          xcr_sub(m) = xcr(m)
          xce_sub(m) = xce(m)
        end do
        call mpi_reduce(xcr_sub, xcr, 5, dp_type, MPI_SUM,
     >                  root, comm_setup, ierror)
        call mpi_reduce(xce_sub, xce, 5, dp_type, MPI_SUM,
     >                  root, comm_setup, ierror)

        if (myid .ne. root) return

        verified = .true.

        do m = 1,5
           xcrref(m) = 1.0
           xceref(m) = 1.0
        end do

c---------------------------------------------------------------------
c    reference data for class S
c---------------------------------------------------------------------
        if ( class .eq. 'S') then
           dtref = 1.5d-2
           niterref = 100

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.7698876173566d+01
           xcrref(2) = 0.1517766790280d+01
           xcrref(3) = 0.2686805141546d+01
           xcrref(4) = 0.1893688083690d+01
           xcrref(5) = 0.1369739859738d+02

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.9566808043467d+01
           xceref(2) = 0.3894109553741d+01
           xceref(3) = 0.4516022447464d+01
           xceref(4) = 0.4099103995615d+01
           xceref(5) = 0.7776038881521d+01

c---------------------------------------------------------------------
c    reference data for class W
c---------------------------------------------------------------------
        elseif ( class .eq. 'W') then
           dtref = 1.5d-3
           niterref = 400

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.1887636218359d+03
           xcrref(2) = 0.1489637963542d+02
           xcrref(3) = 0.4851711701400d+02
           xcrref(4) = 0.3384633608154d+02
           xcrref(5) = 0.4036632495857d+03

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.2975895149929d+02
           xceref(2) = 0.1341508175806d+02
           xceref(3) = 0.1585310846491d+02
           xceref(4) = 0.1450916426713d+02
           xceref(5) = 0.5854137431023d+02

c---------------------------------------------------------------------
c    reference data for class A
c---------------------------------------------------------------------
        elseif ( class .eq. 'A') then
           dtref = 1.5d-3
           niterref = 400

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.2800097900548d+03
           xcrref(2) = 0.2268349014438d+02
           xcrref(3) = 0.7000852739901d+02
           xcrref(4) = 0.5000771004061d+02
           xcrref(5) = 0.5552068537578d+03

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.3112046666578d+02
           xceref(2) = 0.1172197785348d+02
           xceref(3) = 0.1486616708032d+02
           xceref(4) = 0.1313680576292d+02
           xceref(5) = 0.7365834058154d+02

c---------------------------------------------------------------------
c    reference data for class B
c---------------------------------------------------------------------
        elseif ( class .eq. 'B') then
           dtref = 1.0d-3
           niterref = 400

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.5190422977921d+04
           xcrref(2) = 0.3655458539065d+03
           xcrref(3) = 0.1261126592633d+04
           xcrref(4) = 0.1002038338842d+04
           xcrref(5) = 0.1075902511165d+05

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.5469182054223d+03
           xceref(2) = 0.4983658028989d+02
           xceref(3) = 0.1418301776602d+03
           xceref(4) = 0.1097717156175d+03
           xceref(5) = 0.1260195162174d+04

c---------------------------------------------------------------------
c    reference data for class C
c---------------------------------------------------------------------
        elseif ( class .eq. 'C') then
           dtref = 0.67d-3
           niterref = 400

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.5886814493676d+05
           xcrref(2) = 0.3967324375474d+04
           xcrref(3) = 0.1444126529019d+05
           xcrref(4) = 0.1210582211196d+05
           xcrref(5) = 0.1278941567976d+06

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.6414069213021d+04
           xceref(2) = 0.4069468353404d+03
           xceref(3) = 0.1585311908719d+04
           xceref(4) = 0.1270243185759d+04
           xceref(5) = 0.1441398372869d+05

c---------------------------------------------------------------------
c    reference data for class D
c---------------------------------------------------------------------
        elseif ( class .eq. 'D') then
           dtref = 0.3d-3
           niterref = 500

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.7650595424723d+06
           xcrref(2) = 0.5111519817683d+05
           xcrref(3) = 0.1857213937602d+06
           xcrref(4) = 0.1624096784059d+06
           xcrref(5) = 0.1642416844328d+07

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.8169589578340d+05
           xceref(2) = 0.5252150843148d+04
           xceref(3) = 0.1984739188642d+05
           xceref(4) = 0.1662852404547d+05
           xceref(5) = 0.1761381855235d+06

c---------------------------------------------------------------------
c    reference data for class E
c---------------------------------------------------------------------
        elseif ( class .eq. 'E') then
           dtref = 0.2d-3
           niterref = 500

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.5058298119039d+07
           xcrref(2) = 0.3576837494299d+06
           xcrref(3) = 0.1230856227329d+07
           xcrref(4) = 0.1093895671677d+07
           xcrref(5) = 0.1073671658903d+08

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.5288293042051d+06
           xceref(2) = 0.3471875724140d+05
           xceref(3) = 0.1282998930808d+06
           xceref(4) = 0.1095483394612d+06
           xceref(5) = 0.1129716454231d+07

c---------------------------------------------------------------------
c    reference data for class F
c---------------------------------------------------------------------
        elseif ( class .eq. 'F') then
           dtref = 0.1d-3
           niterref = 500

c---------------------------------------------------------------------
c    Reference values of RMS-norms of residual.
c---------------------------------------------------------------------
           xcrref(1) = 0.3974469160412d+08
           xcrref(2) = 0.3260760921834d+07
           xcrref(3) = 0.9756215393494d+07
           xcrref(4) = 0.8278472138497d+07
           xcrref(5) = 0.7547269314441d+08

c---------------------------------------------------------------------
c    Reference values of RMS-norms of solution error.
c---------------------------------------------------------------------
           xceref(1) = 0.3475757666334d+07
           xceref(2) = 0.2386799228183d+06
           xceref(3) = 0.8436705443034d+06
           xceref(4) = 0.7339112115118d+06
           xceref(5) = 0.7327832757877d+07

           if (no_time_steps .eq. 50) then

           niterref = 50
           xcrref(1) = 0.3198801286787d+09
           xcrref(2) = 0.3435698123358d+08
           xcrref(3) = 0.8489831174901d+08
           xcrref(4) = 0.6940707552477d+08
           xcrref(5) = 0.4478684103255d+09

           xceref(1) = 0.6761099692230d+07
           xceref(2) = 0.5361561494769d+06
           xceref(3) = 0.1662878706114d+07
           xceref(4) = 0.1443852092060d+07
           xceref(5) = 0.1260678700480d+08

           endif
        else
           dtref = 0.0d0
           niterref = 0
           verified = .false.
        endif

c---------------------------------------------------------------------
c    Compute the difference of solution values and the known reference values.
c---------------------------------------------------------------------
        do m = 1, 5

           xcrdif(m) = dabs((xcr(m)-xcrref(m))/xcrref(m))
           xcedif(m) = dabs((xce(m)-xceref(m))/xceref(m))

        enddo

c---------------------------------------------------------------------
c    Output the comparison of computed results to known cases.
c---------------------------------------------------------------------

        write(*, 1990) class
 1990   format(' Verification being performed for class ', a)
        write (*,2000) epsilon
 2000   format(' accuracy setting for epsilon = ', E20.13)
        if (dabs(dt-dtref) .gt. epsilon) then
           verified = .false.
           write (*,1000) dtref
 1000      format(' DT does not match the reference value of ',
     >              E15.8)
        else if (no_time_steps .ne. niterref) then
           verified = .false.
           write (*,1002) niterref
 1002      format(' NITER does not match the reference value of ',
     >              I5)
        endif

        write (*,2001)

 2001   format(' Comparison of RMS-norms of residual')
        do m = 1, 5
           if (xcrdif(m) .le. epsilon) then
              write (*,2011) m,xcr(m),xcrref(m),xcrdif(m)
           else
              verified = .false.
              write (*,2010) m,xcr(m),xcrref(m),xcrdif(m)
           endif
        enddo

        write (*,2002)

 2002   format(' Comparison of RMS-norms of solution error')
        do m = 1, 5
           if (xcedif(m) .le. epsilon) then
              write (*,2011) m,xce(m),xceref(m),xcedif(m)
           else
              verified = .false.
              write (*,2010) m,xce(m),xceref(m),xcedif(m)
           endif
        enddo

 2010   format(' FAILURE: ', i2, E20.13, E20.13, E20.13)
 2011   format('          ', i2, E20.13, E20.13, E20.13)

        if (verified) then
           write(*, 2020)
 2020      format(' Verification Successful')
        else
           write(*, 2021)
 2021      format(' Verification failed')
        endif

        return
        end


subroutine cudaclaw_qinit(maxmx,maxmy,meqn,mbc, &
    mx,my,xlower,ylower,dx,dy,q,maux,aux)
    !! =====================================================
    !!
    !! # Set initial conditions for q.

    IMPLICIT NONE

    integer :: maxmx, maxmy, meqn, mbc, mx, my, maux
    double precision :: xlower, ylower, dx,dy

    double precision :: q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
    double precision :: aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)

    double precision :: qin(5), qout(5)
    common /comic/ qin,qout

    double precision :: gamma, gamma1
    common /cparam/  gamma,gamma1

    integer :: idisc
    double precision :: x0, y0, alf, beta, r0
    common/cdisc/ x0,y0,alf,beta,r0,idisc

    double precision :: rinf, vinf, einf
    common /cominf/ rinf,vinf,einf

    integer :: i,j, m, idisc_example
    double precision :: xlow, ylow, win
    double precision :: rhoin, rhoout, pout, pin, pinf

    integer :: blockno, fc2d_cudaclaw_get_block

    blockno = fc2d_cudaclaw_get_block()

    if (idisc .ne. 2) then
        write(6,*) 'qinit.f : idisc must be 2 for this example.'
        stop
    endif

    if (meqn .ne. 4) then
        write(6,*) 'qinit.f : meqn must be 4 for this example.'
        stop
    endif

    idisc_example = idisc
    do  i = 1-mbc,mx+mbc
        xlow = xlower + (i-1)*dx
        do j = 1-mbc,my+mbc
            ylow = ylower + (j-1)*dy
            !! # set (xlow,ylow) to lower left corner of grid cell:

            call cellave2(blockno,xlow,ylow,dx,dy,win)
            !! # win is now the fraction of the cell that lies inside the
            !! # circle
            do m = 1,meqn
                q(i,j,m) = win*qin(m) + (1.d0-win)*qout(m)
            enddo
        enddo

        !! # behind shock:
        do  j=1-mbc,my+mbc
            if (xlow .lt. 0.2d0) then
                q(i,j,1) = rinf
                q(i,j,2) = rinf*vinf
                q(i,j,3) = 0.d0
                q(i,j,4) = einf
            endif
        enddo
    enddo

    return
end subroutine cudaclaw_qinit


*DECK DHEFA
      SUBROUTINE DHEFA (A, LDA, N, IPVT, INFO, JOB)
      INTEGER LDA, N, IPVT(*), INFO, JOB
      DOUBLE PRECISION A(LDA,*)
C-----------------------------------------------------------------------
C     This routine is a modification of the LINPACK routine DGEFA and
C     performs an LU decomposition of an upper Hessenberg matrix A.
C     There are two options available:
C
C          (1)  performing a fresh factorization
C          (2)  updating the LU factors by adding a row and a
C               column to the matrix A.
C-----------------------------------------------------------------------
C     DHEFA factors an upper Hessenberg matrix by elimination.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                JOB = 1    means that a fresh factorization of the
C                           matrix A is desired.
C                JOB .ge. 2 means that the current factorization of A
C                           will be updated by the addition of a row
C                           and a column.
C
C     On return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = k  if  U(k,k) .eq. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that DHESL will divide by zero if called.
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 7/20/83.  This version dated 6/20/01.
C
C     BLAS called: DAXPY, IDAMAX
C-----------------------------------------------------------------------
      INTEGER IDAMAX, J, K, KM1, KP1, L, NM1
      DOUBLE PRECISION T
C
      IF (JOB .GT. 1) GO TO 80
C
C A new facorization is desired.  This is essentially the LINPACK
C code with the exception that we know there is only one nonzero
C element below the main diagonal.
C
C     Gaussian elimination with partial pivoting
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        Find L = pivot index
C
         L = IDAMAX (2, A(K,K), 1) + K - 1
         IPVT(K) = L
C
C        Zero pivot implies this column already triangularized
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           Interchange if necessary
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           Compute multipliers
C
            T = -1.0D0/A(K,K)
            A(K+1,K) = A(K+1,K)*T
C
C           Row elimination with column indexing
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY (N-K, T, A(K+1,K), 1, A(K+1,J), 1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
C
C The old factorization of A will be updated.  A row and a column
C has been added to the matrix A.
C N-1 is now the old order of the matrix.
C
  80  CONTINUE
      NM1 = N - 1
C
C Perform row interchanges on the elements of the new column, and
C perform elimination operations on the elements using the multipliers.
C
      IF (NM1 .LE. 1) GO TO 105
      DO 100 K = 2,NM1
        KM1 = K - 1
        L = IPVT(KM1)
        T = A(L,N)
        IF (L .EQ. KM1) GO TO 90
          A(L,N) = A(KM1,N)
          A(KM1,N) = T
  90    CONTINUE
        A(K,N) = A(K,N) + A(K,KM1)*T
 100    CONTINUE
 105  CONTINUE
C
C Complete update of factorization by decomposing last 2x2 block.
C
      INFO = 0
C
C        Find L = pivot index
C
         L = IDAMAX (2, A(NM1,NM1), 1) + NM1 - 1
         IPVT(NM1) = L
C
C        Zero pivot implies this column already triangularized
C
         IF (A(L,NM1) .EQ. 0.0D0) GO TO 140
C
C           Interchange if necessary
C
            IF (L .EQ. NM1) GO TO 110
               T = A(L,NM1)
               A(L,NM1) = A(NM1,NM1)
               A(NM1,NM1) = T
  110       CONTINUE
C
C           Compute multipliers
C
            T = -1.0D0/A(NM1,NM1)
            A(N,NM1) = A(N,NM1)*T
C
C           Row elimination with column indexing
C
               T = A(L,N)
               IF (L .EQ. NM1) GO TO 120
                  A(L,N) = A(NM1,N)
                  A(NM1,N) = T
  120          CONTINUE
               A(N,N) = A(N,N) + T*A(N,NM1)
         GO TO 150
  140    CONTINUE
            INFO = NM1
  150    CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
C----------------------- End of Subroutine DHEFA -----------------------
      END


      subroutine torus_setprob(example_in,mapping_in, ic_in,
     &     alpha_in,rps_in, ceqn_in)
      implicit none

      double precision alpha_in, rps_in
      integer example_in, mapping_in, ic_in, ceqn_in

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha
      common /torus_comm/ alpha

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer example
      common /example_comm/ example

      integer mapping
      common /mapping_comm/ mapping

      integer initchoice
      common /initchoice_comm/ initchoice

      integer color_equation
      common /eqn_comm/ color_equation

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

      example = example_in
      mapping = mapping_in
      initchoice = ic_in

      alpha = alpha_in

      revs_per_s = rps_in

      color_equation = ceqn_in

      end


module zdens
  ! Computes average particle density along the z-axis.
  use state, only: PcmcState
  implicit none

  real(8), allocatable :: histZdens(:,:,:)  !! Histogram of number of particle at a given plan XY. Array(z, fam, box)
  real(8) :: binZdens=1.D0                  !! space bin between two XY planes.
  integer :: nbinZdens=1000                 !! number of slices
  integer :: zdens_steps=0                  !! number of states sampled

  private :: histZdens, binZdens, nbinZdens, zdens_steps

  character(*), parameter, private :: suff_zdens="_zdens.dat"

contains

  subroutine zdens_init(st)
    !! Initialize calculations.
    type(PcmcState) :: st
    allocate(histZdens(nbinZdens, st%dist%nfam, st%ntotbox))
    histZdens = 0.0
    zdens_steps = 0
  end subroutine zdens_init

  subroutine zdens_update(st)
    !! Updates with current state.
    implicit none
    type(PcmcState) :: st
    integer :: i,k,nz
    real(8) :: Lz

    do k=1,st%ntotbox
      Lz = st%boxes(k)%tens(3,3)
      do i=1,st%boxes(k)%N
        nz = floor((st%boxes(k)%parts(i)%pos(3)*Lz)/binZdens) + 1
        if( nz <= nbinZDens ) histZdens(nz, st%boxes(k)%parts(i)%famille, k) = histZdens(nz, st%boxes(k)%parts(i)%famille, k) + 1.D0
      end do
    end do
    zdens_steps = zdens_steps + 1
  end subroutine zdens_update

  subroutine zdens_finish(st)
    !! Finalize calculations. `histZdens` is set to an average density.
    type(PcmcState) :: st
    histZdens = histZdens/(binZdens*(zdens_steps/st%inp%pZdens))
  end subroutine zdens_finish

  subroutine zdens_output(st, file_prefix)
    !! Prints densities to  files of the form `file_prefix`_`box_number`.dat
    type(PcmcState) :: st
    character(*) :: file_prefix
    integer :: k,i,j, ufo
    character(512) :: chardump
    do k=1,st%ntotbox
      write(chardump,'(A,"_box",I0,A)') file_prefix, k, suff_zdens
      open(newunit=ufo, file=chardump)
      do i=1, nbinZdens
        write(ufo, '(ES16.7)', advance='NO') (real(i)-0.5D0)*binZdens
        do j=1,st%dist%nfam
          write(ufo, '(ES16.7)', advance='NO') histZdens(i, j,k)
        end do
        write(ufo,*)
      end do
    end do
    close(ufo)
  end subroutine zdens_output

  subroutine zdens_free()
    !! Frees arrays initialized in [[zdens_init]].
    deallocate(histZdens)
  end subroutine zdens_free

end module zdens


      DOUBLE PRECISION FUNCTION ZRZT02( M, N, AF, LDA, TAU, WORK,
     $                 LWORK )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX*16         AF( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  ZRZT02 returns
*       || I - Q'*Q || / ( M * eps)
*  where the matrix Q is defined by the Householder transformations
*  generated by ZTZRZF.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix AF.
*
*  N       (input) INTEGER
*          The number of columns of the matrix AF.
*
*  AF      (input) COMPLEX*16 array, dimension (LDA,N)
*          The output of ZTZRZF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array AF.
*
*  TAU     (input) COMPLEX*16 array, dimension (M)
*          Details of the Householder transformations as returned by
*          ZTZRZF.
*
*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          Length of WORK array. LWORK >= N*N+N.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   RWORK( 1 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           DLAMCH, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZLASET, ZUNMRZ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, MAX
*     ..
*     .. Executable Statements ..
*
      ZRZT02 = ZERO
*
      IF( LWORK.LT.N*N+N ) THEN
         CALL XERBLA( 'ZRZT02', 7 )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
*     Q := I
*
      CALL ZLASET( 'Full', N, N, DCMPLX( ZERO ), DCMPLX( ONE ), WORK,
     $             N )
*
*     Q := P(1) * ... * P(m) * Q
*
      CALL ZUNMRZ( 'Left', 'No transpose', N, N, M, N-M, AF, LDA, TAU,
     $             WORK, N, WORK( N*N+1 ), LWORK-N*N, INFO )
*
*     Q := P(m)' * ... * P(1)' * Q
*
      CALL ZUNMRZ( 'Left', 'Conjugate transpose', N, N, M, N-M, AF, LDA,
     $             TAU, WORK, N, WORK( N*N+1 ), LWORK-N*N, INFO )
*
*     Q := Q - I
*
      DO 10 I = 1, N
         WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
   10 CONTINUE
*
      ZRZT02 = ZLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
     $         ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
      RETURN
*
*     End of ZRZT02
*
      END