module polytrope
   use real_kind

   integer, parameter :: NMP = 499!1000

   real(double), private :: avg_rho, rho_c, Z
   real(double), private :: a, k, n, PBC, MBC
   real(double), private :: rho(NMP), P(NMP), T(NMP), lnf(NMP)
   real(double), private :: kappa(NMP), GRADAp(NMP)
   real(double), private :: r(0:NMP), m(0:NMP), L(0:NMP), Inert(0:NMP)
   real(double), private :: Q(NMP), QQ(NMP), QC
   real(double), private :: Lnuc, TKH

contains
!  Construct a polytropic stellar model (n=3/2) with a given mass and radius.
!  Because the surface of the star needs to satisfy the photospheric boundary
!  condition the surface of the star does not coincide with the surface of the
!  polytrope. We adjust the radius of the polytrope until we match the
!  photospheric boudnary condition at the desired radius. We then adjust the
!  mass of the polytrope until the mass within the photosphere matches the
!  desired stelar mass.
!
!  dm and dr are intial guesses for the required corrections (dm may be 0
!  initially but dr should not be).
   subroutine get_polytrope(mass, radius, xa, dm, dr)
      use constants
      use settings
      use poly32
      implicit none
      character (512) :: str
      real(double), intent(in) :: mass, radius, xa(9)
      real(double), intent(inout) :: dm, dr
      real(double) :: ddm, ddr
      real(double) :: BCM(3), BCP(3), MM(2,2), invM(2,2), detM
      real(double) :: GRADR
      integer :: i, iter, IJ
      logical :: verbose = .false.

      ddr = 0.0d0
      ddm = 0.0d0

! Now adjust the mass and radius of the polytrope until we match the
! photospheric boundary when we truncate the polytrope at the desired
! stellar radius. The second condition is that we match the total stellar
! mass within the photoshpere.
! The entire polytrope will therefore be larger and more massive than the
! star itself.
      if (radius+dr < 0.0d0) dr = 1.0d-3*radius
      if (radius+dr < 0.0d0) stop
      do iter = 1, 100
         call compute_polytrope_constants(mass+dm, radius+dr)
         call setup_mesh_spacing(radius, radius+dr, xa)
         call integrate_polytrope(mass, xa)

         if (verbose) write(6, "(1X, 1P, I2, ' Mass and radius:', 2E12.5)") &
                 iter, m(NMP)/CMSN, r(NMP)/CRSN

!     Compute numerical derivatives
         ddm = 1.0d-6
         ddr = 1.0d-6
         BCM(1) = MBC
         BCP(1) = PBC

         call compute_polytrope_constants(mass+dm+ddm, radius+dr)
         call integrate_polytrope(mass, xa)
         BCM(2) = MBC
         BCP(2) = PBC

         call compute_polytrope_constants(mass+dm, radius+dr+ddr)
         call integrate_polytrope(mass, xa)
         BCM(3) = MBC
         BCP(3) = PBC

!        Newton-Raphson step: find corrections by multiplying the residuals
!        with the inverse of the matrix of derivatives
         if(verbose) write(6, "(1X, 1P, '   Deviations      ', 2E12.5)")  BCP(1), BCM(1)
         MM(1,1) = (BCP(2) - BCP(1)) / ddm; MM(1,2) = (BCP(3) - BCP(1)) / ddr
         MM(2,1) = (BCM(2) - BCM(1)) / ddm; MM(2,2) = (BCM(3) - BCM(1)) / ddr
         detM = MM(2,2)*MM(1,1) - MM(1,2)*MM(2,1)
         invM(1,1) =  MM(2,2) / detM
         invM(1,2) = -MM(1,2) / detM
         invM(2,2) =  MM(1,1) / detM
         invM(2,1) = -MM(2,1) / detM

         ddm = invM(1,1) * BCP(1) + invM(1,2) * BCM(1)
         ddr = invM(2,1) * BCP(1) + invM(2,2) * BCM(1)
         if(verbose) write(6, "(1X, 1P, '   Corrections     ', 2E12.5)")  ddm, ddr

         dm = dm - ddm
         dr = dr - ddr

!        Break out if we've converged
         if ( (ddm**2+ddr**2) < 1.0d-14) exit
      end do
      call compute_polytrope_constants(mass+dm, radius+dr)
      call setup_mesh_spacing(radius, radius+dr, xa)
      call integrate_polytrope(mass, xa)

      if (verbose) then
         print *, 'Polytrope mass and radius:', (mass+dm)/CMSN, (radius+dr)/CRSN
         print *, 'Stellar mass and radius:  ', m(NMP)/CMSN, r(NMP)/CRSN
         print *, 'Luminosity (total, nuc.): ', L(NMP)/CLSN, Lnuc/CLSN
         print *, 'Surface pressure, density:', P(NMP), rho(NMP)
         print *, 'Effective temperature:    ', T(NMP)
         print *, 'Central temperature:      ', T(1)
         !print *, L(NMP)/(T(NMP)**4*r(NMP)**2) / (CLSN/CRSN**2)
         print *, 'Final residuals:          ', PBC, MBC
         print *, ''
      end if

      return

!     Check self-consistency of solution: we assumed full convection
      IJ = 0
      do i=1, NMP
         GRADR = 3.0d0*KAPPA(i)*P(i)*L(i) / (16.0*CPI*CL*CG*CA*T(i)**4*(M(i) + 1.0d-16))
         str = "  (stable)"
         if (GRADAp(i) > GRADR) IJ = IJ+1
      enddo
      if (verbose) then
         print '(I4, " of ", I4, " meshpoints should be radiative")', IJ, NMP
      end if

      open (unit=66, file="polytrope.out")
      write (66, '("#",1P, 1X, A4, 9A12)') 'MP', 'm', 'r', 'rho', 'P', 'T', 'L', 'Q', 'QQ', 'conv.'
      do i=1, NMP
         GRADR = 3.0d0*KAPPA(i)*P(i)*L(i) / (16.0*CPI*CL*CG*CA*T(i)**4*(M(i) + 1.0d-16))
         str = "  (stable)"
         if (GRADAp(i) < GRADR) str = "  (unstable)"
         write (66, '(1P,1X,i5, 8E12.4, A12)') i, m(i), r(i), rho(i), p(i), T(i), L(i), Q(i), QQ(i), str
      end do

!      print *, (Q(NMP)-Q(1)), QQ(NMP)-QQ(1)

   end subroutine get_polytrope

!     calculate polytrope parameters: n, a, k, rho_c
   subroutine compute_polytrope_constants(mass, radius)
   use constants
   use poly32
   implicit none
   real(double), intent(in) :: mass, radius

   n = 3./2.            ! Polytropic index
   avg_rho = mass/(4./3.*CPI*radius**3)
   rho_c = avg_rho / (3.0/xi32(n_poly_mesh)**3 * dthetadxi32(n_poly_mesh))
   a = xi32(n_poly_mesh) / radius
   k = 4.0*CPI*CG/((n+1.0)*a**2) * rho_c**((n-1.0)/n) * 1.0e22
   end subroutine compute_polytrope_constants

!     Based on the values for polytrope, construct an Eggleton-type mesh point
!     distribution. This is relatively straightforward because the terms in
!     normal mesh spacing function can all be expressed in terms of known
!     values and prameters for the polytrope.
   subroutine setup_mesh_spacing(star_radius, poly_radius, xa)
   use constants
   use settings
   use poly32
   implicit none
   real(double), intent(in) :: star_radius, poly_radius, xa(9)
   real(double) :: xi, theta, dthetadxi, dq, dqi,QP(n_poly_mesh)
   real(double) :: VP, VT, VM, VR, VMF, XMC, gamma, T0, P_c
   real(double) :: logf, logT
   integer :: i, nn, nh, nl

   do i = 1, NMP
      r(i) = float(i-1)/float(NMP-1)*star_radius
   end do

   P_c = K * rho_c**n
   call prtoft(log(P_c), log(rho_c), logf, logT, xa)
   T0 = exp(logT)
   do i = 1, n_poly_mesh
      !r(i) = float(i-1)/float(NMP-1)*radius
      !xi = a*r(i)
      xi = xi32(i) * star_radius / poly_radius
      call interpolate_poly32(xi, theta, dthetadxi)

      gamma = 1.0 + 1.0/n
      !wmu = 2.0 / (1.0 + 3.0*XA(1) + 0.5*XA(2))
      !T0 = WMU * AMU*k * rho_c**(1.0/n) / BOLTZM

      VP = CT(4)*DLOG(k*rho_c**gamma*theta**(n+1.0)) + CT(5)*DLOG(theta**(n+1.0) + CT(9)/(k*rho_c**gamma))
      VP = CT(4)*DLOG(theta**(n+1.0)) + CT(5)*DLOG(theta**(n+1.0) + CT(9)/(k*rho_c**gamma))
      VT = CT(7)*DLOG(T0*theta/(T0*theta + CT(10)))
! VR and VM must go to zero at centre like r**2, m**(2/3)
      XMC = CT(6)*(1./3.*CT(8)**1.5)**(2./3.)
      VMF = XMC + (dthetadxi * CPI/a**3)**(2./3.)
      VM = DLOG(DABS(XMC/VMF))
      VR = -CT(3)*DLOG(xi**2/(a**2*CT(8)) + 1.0D0)
! Q(i) is the quantity that the meshpoints should be at equal intervals of
      QP(i) = VP + VT + VM + VR
   enddo
! Construct new mesh spacing function
   QC = (QP(n_poly_mesh) - QP(1)) / float(NMP-1)
   QQ(1) = QP(1)
   do i = 2, NMP
      QQ(i) = QQ(i-1) + QC
   end do
! Now find xi as a function of Q
   do i=1, NMP
      ! Binary search
      nh = n_poly_mesh
      nl = 1
      do while (nh > nl+1)
         nn = nl + (nh - nl) / 2
         if (QP(nn) < QQ(i)) then      ! n is new upper bound
            nh = nn
         else                          ! n is new lower bound
            nl = nn
         end if
      end do
      !do nl = 1, n_poly_mesh-1
      !   if (QP(nl+1) < QPP(i)) exit;
      !end do
      !print *, QPP(i), QP(nl), QP(nh)

      dq = min(1.0d0, (QQ(i) - QP(nl)) / (QP(nh) - QP(nl)))
      dqi = 1.0d0 - dq
      xi = dqi*xi32(nl) + dq*xi32(nh)

      r(i) = xi/a * star_radius/poly_radius
   end do
   end subroutine setup_mesh_spacing

   subroutine integrate_polytrope(mass, xa)
   use constants
   use settings
   use poly32
   use eostate_types
   use equation_of_state
   implicit none
   real(double), intent(in) :: mass, xa(9)
   real(double) :: xi, theta, dthetadxi, Ubind
   integer :: i
   real(double) :: dm(NMP), CPp(NMP), DELTAp(NMP)
   real(double) :: Enuc(NMP), Egrav(NMP), Lgrav, Lscale
   real(double) :: VP, VT, VM, VR, VMF, XMC
   real(double) :: logT, logf
   type(eostate) :: eos
   type(abundance) :: abund

   m(0) = 0.0d0
   r(0) = 0.0d0
   L(0) = 0.0d0
   Inert(0) = 0.0d0
   Ubind= 0.0d0
   Lnuc = 0.0d0
   do i = 1, NMP
      xi = a*r(i)
      call interpolate_poly32(xi, theta, dthetadxi)
      rho(i) = rho_c * theta**n
      P(i)   = k * rho(i)**(1.0+1.0/n)
      dm(i)  = rho(i) * 4./3.*CPI * (r(i)**3 - r(i-1)**3)
      m(i)   = m(i-1) + dm(i)
      Inert(i) = Inert(i-1) + 2./3. * r(i)**2*dm(i)
      if (i>1) Ubind = Ubind + 4.0d55*CPI*CG * m(i)*dm(i) / r(i)

      !call prtoft(log(P(i)), log(rho(i)), logf, logT)
      !rho(i) = rho(i) * (ne + nio) / (neo + nio)
      call prtoft(log(P(i)), log(rho(i)), logf, logT, xa)
      call statef(logf,logT, xa(:), abund, eos)
      call nucrat (logt, abund, eos )

      !mu = 2.0 / (1.0 + 3.0*XA(1) + 0.5*XA(2))
      !print *, i, TT / ( P(i) / (CR * rho(i) * mu) )
      T(i)      = eos%T
      lnf(i)    = logf
      CPp(i)    = eos%SCP
      GRADAp(i) = eos%GRADA
      DELTAp(i) = eos%DELTA
      kappa(i)  = eos%FK
      Enuc(i)   = eos%EX
      Lnuc      = Lnuc + Enuc(i)*dm(i)
! Mesh spacing equation
      VP = CT(4)*LOG(P(i)) + CT(5)*LOG(P(i) + CT(9))
      VT = CT(7)*LOG(T(i)/(T(i) + CT(10)))
! VR and VM must go to zero at centre like r**2, m**(2/3)
      XMC = CT(6)*(4./3.*rho_c*CT(8)**1.5)**(2./3.)
      VMF = XMC + M(i)**(2./3.)
      VM = LOG(ABS(XMC/VMF))
      VR = -CT(3)*LOG(R(i)**2/CT(8) + 1.0D0)
! Q(i) is the quantity that the meshpoints should be at equal intervals of
      Q(i) = VP + VT + VM + VR
   end do

   !print *, Lnuc, L(NMP)

!  Integrate luminosity equation
!  We assume that the energy is being produced by homologous contraction
!  This gives eps_grav = -3/5*cp*T * Rdot/R.
!  Integrating this expression fixes L up to the overall scale factor
!  Rdot/R, which can then be determined from the known luminosity at the
!  surface.
   L(1) = 0.0
   L(NMP) = 4.0*CPI*R(NMP)**2 * 0.25*CA*CL*T(NMP)**4 * 1.0d-11
   Lgrav = 0.0
   do i = 2, NMP
      Egrav(i) = 0.6 * CPp(i) * T(i)
      Lgrav = Lgrav + Egrav(i) * dm(i)
   end do
   Lscale = (L(NMP) - Lnuc) / Lgrav
   Egrav = Egrav * Lscale
   do i = 2, NMP-1
      L(i) = L(i-1) + (Egrav(i) + Enuc(i)) * dm(i)
   end do

!  Kelvin-Helmholtz timescale
   TKH = 0.5d-33 * Ubind / L(NMP)

!  Boundary conditions
   PBC = (eos%PG + 0.5*eos%PR) - 2./3. * 1.0d11*CG*m(NMP)/(r(NMP)**2*eos%FK)
   MBC = mass - m(NMP)

   end subroutine integrate_polytrope

   subroutine generate_polytrope_model(mass_in_msun, Tc, xa, h, dh, hnuc)
   use constants
   use settings
   use atomic_data
   use poly32
   use opacity
   use mesh, only:nm, nvar
   use indices
   implicit none
   real(double), intent(in) :: mass_in_msun, Tc, xa(9)
   real(double), intent(out) :: h(nvar,nm), dh(nvar,nm), hnuc(50, nm)
   real(double) :: mass, radius, rr, dm, dr, dtdr
   integer :: i, kk

   ! Read in polytrope structure
   call read_poly32

   ! Initialise opacity table
   KOP = 1
   KION = 5
   call load_opacity(kop, czs)

   ! Set coefficients for mesh spacing function
   CT = 0.0d0
   !CT(1:10) = (/ 0.0E+00, 0.0E+00, 5.0E-02, 5.0E-02, 0.15E+0, 2.0E-02, 0.45E+0, 1.0E-04, 1.0E+15, 2.0E+04 /)
   CT(3) = 5.0d-02
   CT(4) = 5.0d-02
   CT(5) = 0.15d0
   CT(6) = 2.0d-02
   CT(7) = 0.45d0
   CT(8) = 1.0d-4
   CT(9) = 1.0d15
   CT(10) = 2.0d4

   ! Convert mass to code units
   mass = mass_in_msun * CMSN

   ! Crude initial guess for the radius
   radius = 8.0d0 * CRSN * mass / CMSN
   radius = min(400.d0 * CRSN, radius)
   radius = max(3.d0 * CRSN, radius)

   ! Initial guess for corrections
   dm = 0.d0!mass * 7.0d-2
   dr = radius * 1.0d-2
   !radius = radius - dr

   print *, 'Generating polytropic starting model for mass ', mass_in_msun
   print *, 'Initial guess: ', (mass+dm)/CMSN, (radius+dr)/CRSN
   do i=1, 20
      call get_polytrope(mass, radius, xa, dm, dr)
      dtdr = T(1)
      call get_polytrope(mass, radius + 1.0d-6, xa, dm, dr)
      dtdr = (T(1) - dtdr) / 1.0d-6;
      rr = (Tc - T(1)) / dtdr
      if (radius + rr < 0.0d0) rr = -radius * 1.0d-1
      if (radius + rr > 1.1*radius) rr = radius * 1.0d-1
      radius = radius + rr
      call get_polytrope(mass, radius, xa, dm, dr)

      print *, 'Polytrope mass and radius:', (mass+dm)/CMSN, (radius+dr)/CRSN
      print *, 'Stellar mass and radius:  ', m(NMP)/CMSN, r(NMP)/CRSN
      print *, 'Luminosity (total, nuc.): ', L(NMP)/CLSN, Lnuc/CLSN
      print *, 'Central pressure, density:', P(1), rho(1)
      print *, 'Surface pressure, density:', P(NMP), rho(NMP)
      print *, 'Effective temperature:    ', T(NMP)
      print *, 'Central temperature:      ', T(1)

      if (abs((T(1) - Tc)/Tc) < 1.0d-6) exit
   end do

   ! Convert output to format used by the evolution code
   H(:,:) = 0.0d0
   do i = 1, NMP
      kk = NMP + 1 - i
      H(VAR_LNF,kk)   = lnf(i)
      H(VAR_LNT,kk)   = log(T(i))
      H(VAR_MASS,kk)  = m(i)
      H(VAR_QK,kk)    = QC
      H(VAR_LNR,kk)   = 0.5*log(r(i)**2 + CT(8))
      H(VAR_LUM,kk)   = L(i)
      H(VAR_INERT,kk) = Inert(i)
      H(VAR_OMEGA,kk) = 1.0d6

      H(VAR_H1, kk)   = XA(1)
      H(VAR_HE4, kk)  = XA(2)
      H(VAR_C12, kk)  = XA(3)
      H(VAR_N14, kk)  = XA(4)
      H(VAR_O16, kk)  = XA(5)
      H(VAR_NE20, kk) = XA(6)
      H(VAR_MG24, kk) = XA(7)
      H(VAR_SI28, kk) = XA(8)
      H(VAR_FE56, kk) = XA(9)
   end do

   dh = 0.0d0
   hnuc = 0.0d0

   end subroutine generate_polytrope_model

   subroutine generate_starting_model(mass_in_msun, h, dh, hnuc, sm,dty,age,per,bms,ecc,p1,enc,kh,kp,jmod,jb,jn,jf)
   use constants
   use settings
   use atomic_data
   use poly32
   use opacity
   use mesh, only:nm, nvar
   use indices
   implicit none
   real(double), intent(in) :: mass_in_msun
   integer, intent(out) :: kh,jn,jf, jmod,kp,jb
   real(double), intent(out) :: sm,dty,age,per,bms,ecc,p1,enc
   real(double), intent(out) :: h(nvar,nm), dh(nvar,nm), hnuc(50, nm)
   real(double) :: Tc
   real(double) :: ch0, che, vma, xa(9)

   ! Set coefficients for mesh spacing function
   CT = 0.0d0
   !CT(1:10) = (/ 0.0E+00, 0.0E+00, 5.0E-02, 5.0E-02, 0.15E+0, 2.0E-02, 0.45E+0, 1.0E-04, 1.0E+15, 2.0E+04 /)
   CT(3) = 5.0d-02
   CT(4) = 5.0d-02
   CT(5) = 0.15d0
   CT(6) = 2.0d-02
   CT(7) = 0.45d0
   CT(8) = 1.0d-4
   CT(9) = 1.0d15
   CT(10) = 2.0d4

   ! We want a central temperature of ~1e6K, where all nuclear reactions switch
   ! off.
   Tc = 1.0d6

   ! ZAMS composition, from init.dat
   ch0 = ch
   if (czs < 0.0d0) czs = 0.02d0
   if (ch<0.0d0) ch0 = 0.76d0 - 3.0d0*czs
   che = 1.0d0 - ch0 - czs
   xa(1) = ch0*cbn(1)/can(1)
   xa(2) = che*cbn(2)/can(2)
   xa(3) = cc*czs*cbn(3)/can(3)
   xa(4) = cn*czs*cbn(4)/can(4)
   xa(5) = co*czs*cbn(5)/can(5)
   xa(6) = cne*czs*cbn(6)/can(6)
   xa(7) = cmg*czs*cbn(7)/can(7)
   xa(8) = csi*max(czs, 1.0d-4)*cbn(8)/can(8)
   xa(9) = cfe*max(czs, 1.0d-4)*cbn(9)/can(9)
   vma = sum(xa(1:9))
   xa(1:9) = xa(1:9) / vma

   call generate_polytrope_model(mass_in_msun, Tc, xa, H, dH, Hnuc)

   sm   = m(NMP) / CMSN
   dty  = 0.1*TKH/CSY
   age  = 0.0d0
   per  = 1.0d6
   bms  = 0.1 + sm
   ecc  = 0.0d0
   p1   = 1.0d6
   enc  = 0.0d0
   kh   = NMP
   kp   = 2000
   jmod = 0
   jb   = 1
   jn   = 24
   jf   = 0

   end subroutine generate_starting_model
end module polytrope


! { dg-do compile }
! { dg-options "-O -ftree-vectorize" }
      SUBROUTINE OpenAD_set_ref_state(DRF, RHOFACF, RHOFACC)
      real(8) DRF(1 : 15)
      real(8) RHOFACF(1 : 16)
      real(8) RHOFACC(1 : 15)
      integer, dimension(:), allocatable :: oad_it
      integer :: oad_it_ptr
      INTEGER(8) OpenAD_Symbol_188
      INTEGER(4) K
          OpenAD_Symbol_188 = 0
          DO K = 2, 15, 1
            RHOFACF(INT(K)) = ((RHOFACC(K) * DRF(K + (-1)) + RHOFACC(K +
     + (-1)) * DRF(K)) /(DRF(K) + DRF(K + (-1))))
            OpenAD_Symbol_188 = (INT(OpenAD_Symbol_188) + INT(1))
          END DO
          oad_it(oad_it_ptr) = OpenAD_Symbol_188
      end subroutine OpenAD_set_ref_state


      subroutine see1(i1,i2,i3,i4,x,y,xv,yv,ind)
C...01/09/78
      dimension x(1),y(1)
      x1=x(i1)
      y1=y(i1)
      x2=x(i2)
      y2=y(i2)
      x3=x(i3)
      y3=y(i3)
      x4=x(i4)
      y4=y(i4)
      m=0
      a=x1
      b=y1
      i=i1
    9 if(i.eq.i3) goto 2
      if(i.eq.i4) goto 2
      r1=cosin1(yv-y4,x4-xv,a-xv,b-yv)
      r2=cosin1(yv-b,a-xv,x3-xv,y3-yv)
      if(r1*r2.lt.0) goto2
      call lcross(a,b,xv,yv,x3,y3,x4,y4,c,d)
      goto 7
    2 r1=cosin1(yv-b,a-xv,(x3+x4)/2-xv,(y3+y4)/2-yv)
      if(m.ne.0) goto 11
      r3=r1
      a=x2
      b=y2
      i=i2
      m=m+1
      go to 9
   11 c=(x3+x4)/2
      d=(y3+y4)/2
      if(r1*r3.ge.0) goto 8
      call lcross(c,d,xv,yv,x1,y1,x2,y2,a,b)
    7 ind=0
      if(((a-xv)**2+(b-yv)**2-(c-xv)**2-(d-yv)**2).gt.0) return
    8 ind=1
      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  Tapenade 3.16 (master) -  9 Oct 2020 17:47
!
MODULE MOD_VARIANCE_B
  USE MOD_MEAN, ONLY : mean
  USE MOD_MEAN_B, ONLY : mean_b
  USE MOD_MATH, ONLY : subtract
  USE MOD_MATH_B, ONLY : divide_b, subtract_b
  IMPLICIT NONE
  PUBLIC :: variance_b
  PRIVATE

CONTAINS
!  Differentiation of variance in reverse (adjoint) mode (with options i4 dr8 r8):
!   gradient     of useful results: b
!   with respect to varying inputs: a b
!   RW status of diff variables: a:out b:in-zero
  SUBROUTINE VARIANCE_B(a, ad, b, bd)
    IMPLICIT NONE
    real(8), DIMENSION(:), INTENT(INOUT) :: a
    real(8), DIMENSION(:), INTENT(INOUT) :: ad
    real(8), INTENT(INOUT) :: b
    real(8), INTENT(INOUT) :: bd
    real(8) :: meanval
    real(8) :: meanvald
    real(8) :: temp1
    real(8) :: temp1d
    real(8) :: temp2
    real(8) :: temp2d
    real(8) :: n
    INTEGER*8 :: i
    INTRINSIC SIZE
    INTRINSIC REAL
    INTRINSIC INT
    INTEGER*8 :: ad_to
    CALL MEAN(a, meanval)
    n = REAL(SIZE(a), 8)
    DO i=1,INT(n)
      CALL PUSHREAL8(temp1)
      CALL SUBTRACT(a(i), meanval, temp1)
    END DO
    ad_to = i - 1
    ad = 0.0_8
    meanvald = 0.0_8
    DO i=ad_to,1,-1
      temp2d = bd
      CALL DIVIDE_B(temp1, temp1d, n, temp2, temp2d)
      temp1d = 2*temp1*temp1d
      CALL POPREAL8(temp1)
      CALL SUBTRACT_B(a(i), ad(i), meanval, meanvald, temp1, temp1d)
    END DO
    CALL MEAN_B(a, ad, meanval, meanvald)
    bd = 0.0_8
  END SUBROUTINE VARIANCE_B

END MODULE MOD_VARIANCE_B


program test_sto_ra

! The STO basis is taken from (and the energies compared against):
!
! THEORETICAL CHEMISTRY ACCOUNTS: THEORY, COMPUTATION, AND MODELING (THEORETICA
! CHIMICA ACTA)
! Volume 104, Number 5 (2000), 411-413, DOI: 10.1007/s002140000150
!
! http://www.springerlink.com/content/v7p00qyqgh5t3neu/
! http://www.unb.ca/fredericton/science/chem/ajit/download.htm

use types, only: dp
use sto, only: stoints2, get_basis2, get_values
use utils, only: assert, savetxt
use mesh, only: linspace
use radialscf, only: doscf, kinetic_energy
use hfprint, only: printall, printlam
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)
real(dp), allocatable :: R(:), u(:, :, :)

allocate(nbfl(0:3), nl(15, 0:3), zl(15, 0:3), focc(7, 0:3))
nbfl = 0
focc = 0
focc(:7, 0) = [2, 2, 2, 2, 2, 2, 2]
focc(:5, 1) = [6, 6, 6, 6, 6]
focc(:3, 2) = [10, 10, 10]
focc(:1, 3) = [14]
nbfl(0) = 15
nl(:15, 0) = [1, 1, 2, 2, 3, 3, 3, 4, 3, 3, 3, 3, 3, 3, 3]
zl(:15, 0) = [102.772371_dp, 85.593215_dp, 70.820905_dp, 41.242337_dp, &
    36.905364_dp, 25.990833_dp, 20.824259_dp, 10.834095_dp, 10.835315_dp, &
    5.559242_dp, 4.498561_dp, 2.306842_dp, 1.710801_dp, 0.761325_dp, &
    0.569949_dp]
nbfl(1) = 12
nl(:12, 1) = [2, 2, 3, 3, 4, 4, 3, 3, 3, 3, 3, 3]
zl(:12, 1) = [83.018450_dp, 46.836527_dp, 41.801671_dp, 25.187270_dp, &
    25.102935_dp, 13.925446_dp, 13.918592_dp, 9.852338_dp, 5.415789_dp, &
    4.328539_dp, 1.999556_dp, 1.359217_dp]
nbfl(2) = 9
nl(:9, 2) = [3, 3, 4, 4, 4, 4, 4, 4, 4]
zl(:9, 2) = [54.653258_dp, 31.812073_dp, 26.239889_dp, 17.292475_dp, &
    13.510169_dp, 10.453460_dp, 7.146561_dp, 4.838823_dp, 3.220235_dp]
nbfl(3) = 6
nl(:6, 3) = [4, 4, 4, 5, 4, 4]
zl(:6, 3) = [30.150869_dp, 18.531819_dp, 12.237536_dp, 8.036556_dp, &
    7.428155_dp, 4.881720_dp]

Z = 88
tolE = 1e-10_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
allocate(H(n, n, 0:Lmax), S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
m = ndof*(ndof+1)/2
allocate(slater(m*(m+1)/2, 0:2*Lmax))
call stoints2(Z, nbfl, nl, zl, S, T, V, slater)

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
allocate(R(20000))
allocate(u(size(R), size(C, 2), 0:ubound(C, 3)))
! This calculates the values of eigenvectors (for plotting)
!R = linspace(0._dp, 30._dp, size(R))
!u = get_values(nbfl, nl, zl, C, R)
!open(newunit=n, file="R.txt", status="replace")
!write(n, *) R
!close(n)
!call savetxt("eigs0.txt", u(:, :nbfl(0), 0))
!call savetxt("eigs1.txt", u(:, :nbfl(1), 1))
!call savetxt("eigs2.txt", u(:, :nbfl(2), 2))
!call savetxt("eigs3.txt", u(:, :nbfl(2), 3))
Ekin = kinetic_energy(nbfl, P_, T)
call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-23094.30349262_dp)) < 1e-8_dp)
call assert(abs(Ekin - (+23094.30362539_dp)) < 1e-8_dp)
call assert(all(abs(lam(:7, 0) - [-3388.941040_dp, -587.744207_dp, &
    -147.871730_dp, -37.341571_dp, -8.253170_dp, -1.370676_dp, &
    -0.148760_dp]) < 1e-6_dp))
call assert(all(abs(lam(:1, 3) - [-12.430502_dp]) < 1e-6_dp))

end program


! System-specific code for RCR program.
! This version is for use with the IBM fortran compiler and IBM ESSL library

module rcrlib
	use, intrinsic :: ieee_arithmetic ! IBM-specific call
	implicit none
	integer, parameter :: SP=kind(1.0), DP=selected_real_kind(9,99)
	integer, parameter :: stderr=0
	public SP, DP, sysv, is_finite, sort, is_positive_normal, stderr

contains

subroutine sysv(a,b)
  real(kind=DP), dimension(:,:), intent(inout) :: a,b
  integer :: n, nrhs, lda, ldb, ipvt(size(b,1)), info
  n = size(b,1)
  nrhs = size(b,2)
  lda = n
  ipvt = 0
  ldb = n
  info = -1
  call dgesv(n,nrhs,a,lda,ipvt,b,ldb,info) ! IBM-specific call
end subroutine sysv

elemental function is_finite(x)
	real(kind=DP), intent(in) :: x
	logical :: is_finite
    is_finite = ieee_is_finite(x) ! IBM-specific call
end function is_finite

elemental function is_positive_normal(x)
	real(kind=DP), intent(in) :: x
	logical :: is_positive_normal
	is_positive_normal = (ieee_class(x)== IEEE_POSITIVE_NORMAL)	! IBM-specific call
end function is_positive_normal

function sort(array)
	real(kind=DP), dimension(:), intent(in) :: array
	real(kind=DP), dimension(size(array)) :: sort
	integer :: n
	sort = array
	n=size(array)
	if (DP == 8) then
        call qsort_up(sort,n,DP) ! IBM-specific call
		if (n /= size(array)) then
			write (*,*) "Error trying to sort"
		end if
	else
		write (*,*) "Wrong type"
	end if
end function sort

end module rcrlib


      SUBROUTINE BASGLB (VIN1,VOUT1,PONT,ICSTM)
C
C     THIS ROUTINE CONTAINS FOUR ENTRY POINTS
C
C     1- BASGLB TRANSFORMS A VECTOR FROM BASIC TO GLOBAL
C     2- GLBBAS TRANSFORMS A VECTOR FROM GLOBAL TO BASIC
C     3- FDCSTM FINDS THE LOGICAL RECORD ON THE CSTM FOR A PARTICULAR ID
C     4- GBTRAN FINDS A PARTICULAR GLOBAL TO BASIC TRANSFORMATION AND
C        RETURNS IT AS A 3 X 3 STORED BY ROWS.
C
C
      LOGICAL         TONLY
      INTEGER         CSTM,TYSYS,CHECK
      REAL            T(9)
      DIMENSION       VIN(3),VIN1(3),VOUT1(3),TI(3,3),TL(3,3),
     1                PONT(3),PONT1(3),TZ(3,3),IPARM(2)
      COMMON /XCSTM / TZ
      COMMON /LOADX / LC(4),CSTM,LC1(10),IDUM(3),ICM
      COMMON /TRANX / NSYS,TYSYS,RO(3),TO(3,3)
      COMMON /SYSTEM/ IBUF,NOUT
      DATA    IPARM/ 4HBASG,2HLB /
C
C     NSYS  IS SYSTEM NUMBER
C     TYSYS IS SYSTEM TYPE
C     RO IS LOCATION OF ORIGIN
C     TO IS ROTATION MATRIX
C
      TONLY = .FALSE.
      CHECK = 123456789
      ASSIGN 90 TO IEXIT
      GO TO 10
C
C
      ENTRY GBTRAN (ICSTM,PONT,T)
C     ===========================
C
      IF (ICSTM .EQ. 0) GO TO 300
      IF (TYSYS.GE.2 .AND. CHECK.NE.123456789) WRITE (NOUT,5)
    5 FORMAT ('0*** SYSTEM POTENTIAL ERROR, GBTRAN WAS CALLED WITHOUT',
     1        ' FIRST CALLING BASGLB')
      CHECK = 123456789
      TONLY = .TRUE.
      GO TO 235
C
C
      ENTRY FDCSTM (ICSTM)
C     ====================
C
      TONLY = .FALSE.
      ASSIGN 50 TO IEXIT
C
C     FDCSTM WILL FIND REQUESTED SYSTEM (ICSTM)
C
   10 CONTINUE
      IF (ICSTM .EQ. 0) GO TO 81
      IF (ICM   .NE. 0) GO TO 80
      IF (ICSTM-NSYS) 20,40,20
   20 CALL READ (*60,*80,CSTM,NSYS,14,0,FLAG)
      IF (ICSTM-NSYS) 20,30,20
   30 CALL BCKREC (CSTM)
   40 GO TO IEXIT, (90,240,50)
   50 RETURN
C
   60 N1 = -2
      IPARM1 = CSTM
   70 CALL MESAGE (N1,IPARM1,IPARM)
C
C     UNABLE TO FIND REQUESTED COORDINATE SYSTEM
C
   80 N1      =-30
      IPARM1  = 25
      IPARM(1)= ICSTM
      GO TO 70
C
C     REQUEST FOR BASIC COORDINATE SYSTEM
C
   81 CONTINUE
      TYSYS = 1
      NSYS  = 0
      RO(1) = 0.0
      RO(2) = 0.0
      RO(3) = 0.0
      DO 82 I = 1,3
      DO 82 J = 1,3
      TO(J,I) = 0.0
   82 CONTINUE
      TO(1,1) = 1.0
      TO(2,2) = 1.0
      TO(3,3) = 1.0
      GO TO 40
C
C     CONVERTS BASIC TO GLOBAL
C
   90 IOTH = 0
C
C     RECTANGULAR
C
  100 DO 120 I = 1,3
      DO 110 J = 1,3
      TZ(I,J) = TO(J,I)
  110 TI(I,J) = TO(J,I)
  120 VIN(I)  = VIN1(I)
      IF (TYSYS-2) 130,140,140
  130 CALL MPYL (TI(1,1),VIN(1),3,3,1,VOUT1(1))
      GO TO 50
C
C     CYLINDRICAL
C
  140 DO 150 I = 1,3
  150 PONT1(I) = PONT(I) - RO(I)
      CALL MPYL (TI(1,1),PONT1(1),3,3,1,VIN(1))
      DO 160 I = 1,3
      DO 160 J = 1,3
  160 TL(I,J) = 0.0
      R = SQRT(VIN(1)*VIN(1) + VIN(2)*VIN(2))
      IF (R  .EQ.  0.0) GO TO 210
      IF (TYSYS .GT. 2) GO TO 230
      TL(3,3) = 1.0
      TL(1,1) = VIN(1)/R
      TL(2,2) = TL(1,1)
      TL(2,1) = VIN(2)/R
      TL(1,2) =-TL(2,1)
  170 CALL MPYL (TL(1,1),TI(1,1),3,3,3,TZ(1,1))
  180 IF (TONLY) GO TO 201
      IF ( IOTH) 270,190,270
  190 DO 200 I = 1,3
  200 VIN(I) = VIN1(I)
      CALL MPYL (TZ(1,1),VIN(1),3,3,1,VOUT1(1))
      GO TO 50
C
C     RETURN THE TRANSFORMATION ONLY
C
  201 T(1) = TZ(1,1)
      T(2) = TZ(1,2)
      T(3) = TZ(1,3)
      T(4) = TZ(2,1)
      T(5) = TZ(2,2)
      T(6) = TZ(2,3)
      T(7) = TZ(3,1)
      T(8) = TZ(3,2)
      T(9) = TZ(3,3)
      GO TO 50
C
C     ORIENTATION ARBITARY   TL = I   I.E. TZ = TI
C
  210 DO 220 I = 1,3
      DO 220 J = 1,3
      TZ(I,J) = TI(I,J)
  220 CONTINUE
      GO TO 180
C
C     SPHERICAL
C
  230 XL = SQRT(VIN(1)*VIN(1) + VIN(2)*VIN(2) + VIN(3)*VIN(3))
      XR = VIN(1)/R
      YR = VIN(2)/R
      ZL = VIN(3)/XL
C
C     BUILD TL TRANSPOSE
C
      TL(1,1) = VIN(1)/XL
      TL(1,2) = XR*ZL
      TL(1,3) =-YR
      TL(2,1) = VIN(2)/XL
      TL(2,2) = YR*ZL
      TL(2,3) = XR
      TL(3,1) = ZL
      TL(3,2) =-R/XL
      GO TO 170
C
C
      ENTRY GLBBAS (VIN1,VOUT1,PONT,ICSTM)
C     ====================================
C
      TONLY = .FALSE.
  235 ASSIGN 240 TO IEXIT
      IOTH = 1
      GO TO 10
C
C     CONVERTS FROM GLOBAL TO BASIC
C
  240 IF (TYSYS-2) 250,100,100
  250 IF ( TONLY ) GO TO 261
      DO 260 I = 1,3
  260 VIN(I) = VIN1(I)
      CALL MPYL (TO(1,1),VIN(1),3,3,1,VOUT1(1))
      GO TO 50
C
C     RETURN THE TRANSFORMATION ONLY.
C
  261 T(1) = TO(1,1)
      T(2) = TO(2,1)
      T(3) = TO(3,1)
      T(4) = TO(1,2)
      T(5) = TO(2,2)
      T(6) = TO(3,2)
      T(7) = TO(1,3)
      T(8) = TO(2,3)
      T(9) = TO(3,3)
      GO TO 50
C
C     COMPUTE TL TRANSPOSE
C
C     TRANSPOSE ROTATION PRODUCT
C
  270 DO 280 I = 1,3
      VIN(I) = VIN1(I)
      DO 280 J = 1,3
  280 TI(I,J) = TZ(J,I)
      CALL MPYL (TI(1,1),VIN(1),3,3,1,VOUT1(1))
      GO TO 50
C
C     COORDINATE SYSTEM 0
C
  300 DO 310 I = 2,8
  310 T(I) = 0.
      T(1) = 1.
      T(5) = 1.
      T(9) = 1.
      GO TO 50
      END


!##############################################################################
! PROGRAM HetAg_Gov
!
! ## Heterogeneous agents and government activity (optimal quantity of debt)
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog09_10m.f90"

program HetAg_Gov

    use globals
    use toolbox

    implicit none
    integer, parameter :: NB = 4
    integer :: ib
    real*8 :: blevels(0:NB), Wlevels(0:NB), W0

    ! initialize variables
    call initialize()

    ! benchmark equilibrium
    by = 0.6d0

    ! set initial guess of the interest rate
    r = 0.042d0

    ! solve initial equilibrium
    call solve_model()

    ! store initial uility level
    W0 = sum(phi(:,:)*V(:,:))

    ! set up number of debt levels
    call grid_Cons_Equi(blevels, 0.5d0, 1.5d0)

    ! calculate equilibrium with different debt levels
    do ib = 0, NB
        by = blevels(ib)
        call solve_model()
        Wlevels(ib) = sum(phi(:,:)*V(:,:))
    enddo

    ! plot equivalent variation
    call plot(blevels, ((Wlevels/W0)**(1d0/egam)-1d0)*100d0)
    call execplot

contains

    ! For solving the model
    subroutine solve_model

        use toolbox

        implicit none
        real*8 :: x_in
        logical :: check

        ! start timer
        call tic()

        write(*, '(a)')'       K/Y         r     tau_r      diff_K'

        ! set tolerance level for outer optimization
        call settol_root(sig_out)

        ! set initial guess
        x_in = r
        check = .false.

        ! solve asset market equilibrium
        call fzero(x_in, asset_market, check)

        if(check)write(*,'(a)')'ERROR IN ROOTFINDING'

        call toc

        ! write output to the screen
        call output

    end subroutine

    ! For initializing variables
    subroutine initialize()

        use toolbox

        implicit none
        integer :: is

        ! calculate the shock process
        call discretize_AR(rho, 0d0, sigma_eps, eta, pi, weights)
        eta = exp(eta)

        ! calculate aggregate labor supply
        LL = sum(eta*weights)

        ! initialize grid
        call grid_Cons_Grow(a, a_l, a_u, a_grow)

        ! initialize policy function
        do is = 1, ns
            c(:, is) = 0.04d0*a(:) + eta(is)
            c_new(:, is) = c(:, is)
        enddo

        ! get an initial guess for the distribution function
        phi = 1d0/dble((NA+1)*NS)

    end subroutine

    ! For calculating the value function
    subroutine value_function()

        use toolbox

        implicit none
        integer :: iter, ia, is, is_p
        real*8 :: V_new(0:NA, NS), aplus, con_lev
        integer :: ial(0:NA, NS), iar(0:NA, NS)
        real*8 :: varphi(0:NA, NS)

        ! get the interpolation shares and points
        do ia = 0, NA
            do is = 1, NS

                ! calculate where this guy would go
                aplus = max(((1d0+rn)*a(ia)+wn*eta(is)-c(ia,is))/(1d0+growth), a_l)

                ! determine the gridpoints in between this decision lies and share
                call linint_Grow(aplus, a_l, a_u, a_grow, NA, &
                    ial(ia, is), iar(ia, is), varphi(ia, is))
            enddo
        enddo

        ! initialize value function
        V = c

        ! iterate until the value function converges
        do iter = 1, itermax

            ! calculate new value function
            do ia = 0, NA
                do is = 1, NS

                    ! interpolate over all future states
                    V_new(ia, is) = 0d0
                    do is_p = 1, NS
                        V_new(ia, is) = V_new(ia, is) + pi(is, is_p)* &
                            (varphi(ia,is)*V(ial(ia,is),is_p) + &
                            (1d0-varphi(ia,is))*V(iar(ia,is),is_p))**egam
                    enddo

                    ! add current utility
                    V_new(ia, is) = (c(ia,is)**egam + beta*V_new(ia, is))**(1d0/egam)
                enddo
            enddo

            con_lev = maxval(abs(V_new(:, :) - V(:, :))/max(abs(V(:, :)), 1d-10))

            ! update value function
            V = V_new

            ! check for convergence
            if(con_lev < sig_in)then
                V = V**egam/egam
                return
            endif
        enddo

    end subroutine

    ! For creating output plots
    subroutine output()

        implicit none
        integer :: ia, is
        real*8 :: Std_c, Std_a, Std_eta, util

        ! aggregate consumption and investment
        CC = sum(phi*c)
        II = (growth+delta)*KK

        call value_function()
        util = sum(phi(:,:)*V(:,:))

        ! calculate coefficients of variation
        Std_eta = 0d0
        Std_c   = 0d0
        Std_a   = 0d0
        do ia = 0, NA
            do is = 1, NS
                Std_eta = Std_eta + phi(ia, is)*(eta(is)   - LL)**2
                Std_c   = Std_c   + phi(ia, is)*(c(ia, is) - CC)**2
                Std_a   = Std_a   + phi(ia, is)*(a(ia)     - KK)**2
            enddo
        enddo
        Std_eta = sqrt(Std_eta)/LL
        Std_c   = sqrt(Std_c)  /CC
        Std_a   = sqrt(Std_a)  /AA

        ! write output to screen
        write(*, '(//a)')'AIYAGARI ECONOMY OUTPUT'
        write(*,'(/a)')'PROD :       K/Y       L/Y         r         w'
        write(*,'(6x,4f10.4)')(/KK, LL/)/YY*100d0, r*100d0, w
        write(*,'(/a)')'GOODS:       C/Y       I/Y       G/Y       D/Y'
        write(*,'(6x,4f10.4)')(/CC, II, GG, CC+II+GG/)/YY*100d0
        write(*,'(/a)')'GOVMT:       B/Y       G/Y     tau_w     tau_r'
        write(*,'(6x,5f10.4)')(/BB, GG/)/YY*100d0, tau_w, tau_r
        write(*,'(/a)')'               c         a       eta     util'
        write(*,'(a,4f10.4)')'LEV  :', CC, AA, LL, util
        write(*,'(a,3f10.4)')'STD  :', Std_c, Std_a, Std_eta
        write(*,'(//)')

    end subroutine

end program


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    PostProcess.f90
    !> \brief   Perform post-processing of results.
    !> \author  M.H.A. Piro
    !> \date    January 14, 2013
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   01/14/2013      M.H.A. Piro         Original code.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to perform post-procesing of results.
    !
    !
    ! Pertinent variables:
    ! ====================

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

subroutine PostProcess

    USE ModuleThermo
    USE ModuleThermoIO
    USE ModuleGEMSolver

    implicit none

    integer :: i

    ! Initiate variables:
    dGibbsEnergySys = 0d0

    ! Multiply the number of moles of all phases by the normalizing constant:
    dNormalizeInput = 1D0 / dNormalizeInput
    dMolesPhase     = dMolesPhase   * dNormalizeInput
    dMolesElement   = dMolesElement * dNormalizeInput
    dMolesSpecies   = dMolesSpecies * dNormalizeInput

    ! Compute the integral Gibbs energy of the system:
    do i = 1, nElements
        dGibbsEnergySys = dGibbsEnergySys + dElementPotential(i) * dMolesElement(i)
    end do
    dGibbsEnergySys = dGibbsEnergySys * dIdealConstant * dTemperature

    return

end subroutine PostProcess


      MODULE multbc_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  20:12:31   2/12/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE multbc (N, K, M, C, TEMP, B)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(IN) :: N
      INTEGER, INTENT(IN) :: K
      INTEGER, INTENT(IN) :: M
      REAL(DOUBLE), DIMENSION(K*M) :: C
      REAL(DOUBLE), DIMENSION(M) :: TEMP
      REAL(DOUBLE), DIMENSION(N*K) :: B
!VAST...Calls: DGEMV, DCOPY
      END SUBROUTINE
      END INTERFACE
      END MODULE


       SUBROUTINE CELLMAP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! sets up the 3D linkcell map
!!!! K.Travis 06/06/12  Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      USE header_file
      IMPLICIT NONE

      INTEGER   :: IX,IY,IZ,ICELL,IMAP

!!!!! this version assumes no periodic boundaries!!

      DO IZ = 1,NCELLZ
        DO IY = 1,NCELLY
          DO IX = 1,NCELLX

            IMAP = (ICELL(IX, IY,IZ,NCELLX,NCELLY,NCELLZ) - 1)*13

            MAP(IMAP + 1 ) = ICELL(IX + 1, IY    , IZ    , NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 2 ) = ICELL(IX + 1, IY + 1, IZ    , NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 3 ) = ICELL(IX    , IY + 1, IZ    , NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 4 ) = ICELL(IX - 1, IY + 1, IZ    , NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 5 ) = ICELL(IX + 1, IY    , IZ - 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 6 ) = ICELL(IX + 1, IY + 1, IZ - 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 7 ) = ICELL(IX    , IY + 1, IZ - 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 8 ) = ICELL(IX - 1, IY + 1, IZ - 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 9 ) = ICELL(IX + 1, IY    , IZ + 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 10) = ICELL(IX + 1, IY + 1, IZ + 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 11) = ICELL(IX    , IY + 1, IZ + 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 12) = ICELL(IX - 1, IY + 1, IZ + 1, NCELLX,NCELLY,NCELLZ)
            MAP(IMAP + 13) = ICELL(IX    , IY    , IZ + 1, NCELLX,NCELLY,NCELLZ)

          END DO
        END DO
      END DO

      END SUBROUTINE

      INTEGER FUNCTION ICELL(IXX,IYY,IZZ,NX,NY,NZ)

      IMPLICIT NONE
! declare input variables
      INTEGER,  INTENT(IN) :: IXX
      INTEGER,  INTENT(IN) :: IYY
      INTEGER,  INTENT(IN) :: IZZ
      INTEGER,  INTENT(IN) :: NX
      INTEGER,  INTENT(IN) :: NY
      INTEGER,  INTENT(IN) :: NZ
! evaluate cell index
      ICELL = 1 + MOD(IXX - 1 + NX, NX)       + &
 &                MOD(IYY - 1 + NY, NY)*NX    + &
 &                MOD(IZZ - 1 + NZ, NZ)*NX*NY

      END FUNCTION


module reigen

! Solves the radial Schroedinger/Dirac eigenproblem

use types, only: dp
use ode1d, only: integrate, normalize, parsefunction, get_n_nodes, get_min_idx
use rschroed, only: schroed_outward_adams, schroed_inward_adams
use rdirac, only: dirac_outward_adams, dirac_inward_adams
use utils, only: stop_error

implicit none
private
public solve_radial_eigenproblem, integrate_rproblem_outward

contains

subroutine integrate_rproblem_outward(l, E, R, Rp, V, Z, c, relat, &
    P, Q, imax)
! Integrates the radial Schroedinger/Dirac equations outward for the given E
!
! Input parameters:
! l .... the quantum number l
! E .... the energy at which to integration the equation
! R(:) .... radial grid
! V(:) .... potential on the radial grid
! Z .... the nucleus charge
! c .... speed of light
! relat ... the relativistic mode (1, 2 or 3), see solve_radial_eigenproblem()
!           for more information
!
! Output parameters:
! P(:), Q(:) ..... The P and Q components.
! For Schroedinger equation P(r) = r*R(r), Q(r) = P'(r), for Dirac equation,
! P(r) = r*g(r), Q(r) = r*f(r), where "g" and "f" are the large and small
! components of the Dirac equation
!
! The components are not normalized.

integer, intent(in) :: l, relat, Z
real(dp), intent(in) :: E, c, R(:), Rp(:), V(:)
real(dp), intent(out) :: P(:), Q(:)
integer, intent(out) :: imax

integer :: kappa

if (relat == 0) then
    call schroed_outward_adams(l, Z, E, R, Rp, V, P, Q, imax)
else if (relat == 1) then
    call stop_error("Scalar relativistic case not implemented")
else if (relat == 2 .or. relat == 3) then
    if (relat == 3) then
        if (l == 0) then
              call stop_error("for l=0 only spin up (relat=2) is allowed")
        end if
        kappa = l
    else
        kappa = -l-1
    end if
    call dirac_outward_adams(c, kappa, Z, E, R, Rp, V, P, Q, imax)
else
    call stop_error("wrong value of relat.")
end if
end subroutine

subroutine integrate_radial_problem_inward(l, E, R, Rp, V, c, &
    relat, P, Q, imin)
! Integrates the radial Schroedinger/Dirac equations inward for the given E
!
! Input parameters:
! l .... the quantum number l
! E .... the energy at which to integration the equation
! R(:) .... radial grid
! V(:) .... potential on the radial grid
! c .... speed of light
! relat ... the relativistic mode (1, 2 or 3), see solve_radial_eigenproblem()
!           for more information
!
! Output parameters:
! P(:), Q(:) ..... The P and Q components.
! For Schroedinger equation P(r) = r*R(r), Q(r) = P'(r), for Dirac equation,
! P(r) = r*g(r), Q(r) = r*f(r), where "g" and "f" are the large and small
! components of the Dirac equation
!
! The components are not normalized.

integer, intent(in) :: l, relat
real(dp), intent(in) :: E, c, R(:), Rp(:), V(:)
real(dp), intent(out) :: P(:), Q(:)
integer, intent(out) :: imin

integer :: kappa

if (relat == 0) then
    call schroed_inward_adams(l, E, R, Rp, V, P, Q, imin)
else if (relat == 1) then
    call stop_error("Scalar relativistic case not implemented")
else if (relat == 2 .or. relat == 3) then
    if (relat == 3) then
        if (l == 0) then
              call stop_error("for l=0 only spin up (relat=2) is allowed")
        end if
        kappa = l
    else
        kappa = -l-1
    end if
    call dirac_inward_adams(c, kappa, E, R, Rp, V, P, Q, imin)
else
    call stop_error("Wrong value of relat.")
end if
end subroutine

logical function is_E_above(n, l, nods_actual)
integer, intent(in) :: n, l, nods_actual
is_E_above = nods_actual > n-l-1
end function

subroutine solve_radial_eigenproblem(n, l, Ein, eps, max_iter, &
    R, Rp, V, Z, c, relat, perturb, Emin_init, Emax_init, converged, E, P, Q)
! Solves the radial Dirac (Schroedinger) equation and returns the eigenvalue
! (E) and normalized eigenvector (P, Q) for the given "n" and "l".
!
!    Finds the wavefunction with defined "n" and "l". The potential is "V".
!    relat ... 0 nonrelat (runge-kutta)
!              2 relat (runge-kutta) spin up
!              3 relat (runge-kutta) spin down
!    Ein gives the initial energy for the perturbation method
!    eps ... the solver halves the difference between Emin and Emax until
!            |Emax-Emin|<eps
!    max_iter ... The maximum allowed number of shooting iterations to solve
!                 the eigenproblem
!    R  ... the grid on which to solve the equation
!    Rp ... the grid derivatives on which to solve the equation
!    V  ... the potential V(r) on the grid R
!    Z is the coulomb term in the potential V=-Z/r+..., it is used for
!    the asymptotic
!    c is the speed of light in atomic units
!    perturb ... If .true., use perturbation correction (faster, but assumes
!        the potential behaves as -Z/r for r->oo), otherwise use bisection
!        (slower, but works for any potential)
!    Emin_init, Emax_init ... The range in which to find the energy. If the
!        energy is not in the range, the "converged" variable will be equal to
!        either 9 (Emin_init too big) or 10 (Emin_init too small).
!
!    Returns eigenvalue E and the normalized wavefunctions P, Q. If it doesn't
!    converge, then converged /= 0, and E is undefined (P and Q then contains
!    the latest integration of the shooting solver if available --- this is
!    useful for debugging why it did not converge).
!
!    Conceptually, the algorithm is to use bisection to converge energy (using
!    the number of nodes as the criterion) until we get close enough, so that
!    the perturbation theory starts to converge, and then use perturbation to
!    finish it. If perturbation does not converge, we need to fail over to
!    bisection.
integer, intent(in) :: n, l, relat, Z, max_iter
real(dp), intent(in) :: R(:), Rp(:), V(:), eps, Ein, c
logical, intent(in) :: perturb
real(dp), intent(in) :: Emin_init, Emax_init
integer, intent(out) :: converged
real(dp), intent(out) :: P(:), Q(:), E

real(dp) :: Emin, Emax, dE, Pr(size(R)), Qr(size(R)), factor, S
integer :: minidx, ctp, iter
logical :: isbig
integer :: nnodes
logical :: last_bisect
integer :: imin, imax
E = Ein
if (.not.(n > 0)) call stop_error("n > 0 not satisfied")
if (.not.((0 <= l).and.(l < n))) call stop_error("0 <= l < n not satisfied")

Emax = Emax_init
Emin = Emin_init
if (E > Emax .or. E < Emin) E = (Emin + Emax) / 2

iter = 0
last_bisect = .true.
do while (iter < max_iter)
    iter = iter + 1

    ! See if bisection is converged
    if (abs(Emax - Emin) < eps) then
        if (.not. last_bisect) then
            ! The perturbation theory correction was used in the last
            ! iteration and in that case, the consistent stopping criterion is
            ! to converge with abs(dE), not abs(Emax - Emin).
            ! As such we fail, because abs(Emax - Emin) is converged, but
            ! abs(dE) isn't.
            converged = 6
            return
        end if
        if (abs(Emax - Emax_init) < tiny(1._dp)) then
            ! The algorithm didn't change Emax, so Emax_init was set
            ! incorrectly.
            converged = 10
            return
        end if
        if (abs(Emin - Emin_init) < tiny(1._dp)) then
            ! The algorithm didn't change Emin, so Emin_init was set
            ! incorrectly.
            converged = 9
            return
        end if
        call integrate_rproblem_outward(l, E, R, Rp, V, &
            Z, c, relat, P, Q, imax)
        minidx = get_min_idx(P(:imax))
        if (minidx <= 0) then
            ! The wavefunction doesn't have a peak
            converged = 4
            return
        end if

        ! Trim the wavefunction after the last minimum:
        P(minidx:) = 0
        Q(minidx:) = 0

        ! To make sure the zeros from above are not counted as nodes, we
        ! substract 1 from minidx here:
        nnodes = get_n_nodes(P(:minidx-1))

        if (nnodes /= n - l - 1) then
            ! Wrong number of nodes for the converged energy
            converged = 5
            return
        end if

        exit
    end if

    ctp = find_ctp(V + l*(l+1)/(2*R**2), E)
    ! If the classical turning point is too large (or cannot be found at all),
    ! we can't use inward integration to correct the energy, so we use
    ! bisection. Also use bisection if the user requests it.
    if (.not. perturb) then
        ctp = size(R)
    else if (ctp == 0) then
        ctp = size(R)
    else if (R(ctp) / R(size(R)) > 0.5_dp) then
        ctp = size(R)
    else if (size(R) - ctp <= 10) then
        ctp = size(R)
    else if (E >= 0) then
        ! Also do bisection for positive energies, as we cannot use inward
        ! integration for these
        ctp = size(R)
    end if
    call integrate_rproblem_outward(l, E, R(:ctp), Rp(:ctp), V(:ctp), &
        Z, c, relat, P(:ctp), Q(:ctp), imax)
    nnodes = get_n_nodes(P(:imax))
    if (nnodes /= n-l-1 .or. ctp == size(R) .or. imax < ctp) then
        ! If the number of nodes is not correct, or we didn't manage to
        ! integrate all the way to "ctp", or if "ctp" was too large, we just
        ! use bisection:
        isbig = is_E_above(n, l, nnodes)
        if (isbig) then
            Emax = E
        else
            Emin = E
        end if
        E = (Emin + Emax) / 2
        last_bisect = .true.
        cycle
    end if

    ! Perturbation theory correction
    call integrate_radial_problem_inward(l, E, R(ctp:), Rp(ctp:), V(ctp:), &
        c, relat, Pr(ctp:), Qr(ctp:), imin)
    if (imin > 1) then
        ! The inward integration didn't integrate to the ctp
        converged = 8
        return
    end if

    ! Normalize the inward solution to match the outward one:
    factor = P(ctp) / Pr(ctp)
    if (abs(factor) > 1e9) then
        ! Normalization factor for inward/outward is too large
        converged = 7
        return
    end if
    Pr = Pr * factor
    Qr = Qr * factor

    P(ctp+1:) = Pr(ctp+1:)
    Q(ctp+1:) = Qr(ctp+1:)
    if (relat == 2 .or. relat == 3) then
        S = integrate(Rp, P**2 + Q**2)
    else
        S = integrate(Rp, P**2)
    end if
    dE = P(ctp) * (Q(ctp) - Qr(ctp)) / (2 * S)
    if (relat == 2 .or. relat == 3) then
        dE = 2 * c * dE
    end if

    ! The only stopping criterion for perturbation theory correction:
    if (abs(dE) < eps) exit

    ! We always trust the sign of dE to drive bisection
    isbig = dE < 0
    if (isbig) then
        Emax = E
    else
        Emin = E
    end if

    ! If the dE prediction is out of the trust region, we don't trust the value
    ! of dE, and we do bisection
    if (E + dE > Emax .or. E + dE < Emin) then
        E = (Emin + Emax) / 2
        last_bisect = .true.
    else
        E = E + dE
        last_bisect = .false.
    end if
end do
if (iter == max_iter) then
    ! We didn't converge in 'max_iter' iterations
    converged = 2
    return
end if

! Normalize the wavefunction:
if (relat == 0) then
    S = integrate(Rp, P**2)
else
    S = integrate(Rp, P**2 + Q**2)
end if
S = sqrt(abs(S))
if (S > 0) then
    P = P / S
    Q = Q / S
else
    ! This would happen if the function is zero, but we already check this
    ! above (converged == 4), so we fail laudly here.
    call stop_error("solve_radial_eigenproblem: zero function")
end if

converged = 0
end subroutine

integer function find_ctp(V, E) result(ctp)
! Finds the classical turning point for the potential 'V' and energy 'E'
!
! Classical turning point 'ctp' is defined as E = V(ctp)
! The function returns the integer index into the array V.
real(dp), intent(in) :: V(:), E
integer :: i
do i = size(V), 1, -1
    if (V(i)-E <= 0) then
        ctp = i
        return
    end if
end do
ctp = 0
end function

end module


c Code in this file based on Applied Statistics algorithms
c (C) Royal Statistical Society 1979
c
C a minimal modification of AS136 to use double precision
C all variables are now declared.
C B.D. Ripley 1998/06/17
C Declaration re-ordering to satisfy "f77 -ansi",  M.Maechler 2001/04/12
C
c ~= R's  kmeans(x=A, centers=C, iter.max=ITER, algorithm = "Hartigan-Wong")
C
      SUBROUTINE KMNS(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
     *    ITRAN, LIVE, ITER, WSS, IFAULT)
C
C     ALGORITHM AS 136  APPL. STATIST. (1979) VOL.28, NO.1
C
C     Divide M points in N-dimensional space into K clusters so that
C     the within cluster sum of squares is minimized.
C
      INTEGER M,N,K,ITER,IFAULT
      INTEGER IC1(M), IC2(M), NC(K), NCP(K), ITRAN(K), LIVE(K)
      DOUBLE PRECISION A(M,N), D(M), C(K,N), AN1(K), AN2(K), WSS(K)
c                      ------        ------
c                     data x[,]      centers[,]
      DOUBLE PRECISION DT(2), ZERO, ONE
      INTEGER I,IL,J,L,INDX,IJ,II, iTrace, iMaxQtr
      DOUBLE PRECISION BIG, DA, TEMP, DB, DC,AA
C
C     Define BIG to be a very large positive number
C
      DATA BIG /1.E30/, ZERO /0.0/, ONE /1.0/
C
      iTrace = IFAULT
      iMaxQtr = ITRAN(1)
      IFAULT = 3
      IF (K .LE. 1 .OR. K .GE. M) RETURN
      IFAULT = 0
C
C     For each point I, find its two closest centres, IC1(I) and
C     IC2(I).     Assign it to IC1(I).
C
      DO 60 I = 1, M
        IC1(I) = 1
        IC2(I) = 2
        DO IL = 1, 2
          DT(IL) = ZERO
          DO J = 1, N
            DA = A(I,J) - C(IL,J)
            DT(IL) = DT(IL) + DA*DA
          end DO
        end DO ! IL
        IF (DT(1) .GT. DT(2)) THEN
          IC1(I) = 2
          IC2(I) = 1
          TEMP = DT(1)
          DT(1) = DT(2)
          DT(2) = TEMP
        END IF
        DO 50 L = 3, K
          DB = ZERO
          DO J = 1, N
            DC = A(I,J) - C(L,J)
            DB = DB + DC*DC
            IF (DB .GE. DT(2)) GO TO 50
          end DO
          IF (DB .ge. DT(1)) then
             DT(2) = DB
             IC2(I) = L
          else
             DT(2) = DT(1)
             IC2(I) = IC1(I)
             DT(1) = DB
             IC1(I) = L
          end IF
 50    CONTINUE
 60    CONTINUE
C
C     Update cluster centres to be the average of points contained
C     within them.
C     NC(L) := #{units in cluster L},  L = 1..K
      DO L = 1, K
        NC(L) = 0
        DO J = 1, N
           C(L,J) = ZERO
        end DO
      end DO
      DO I = 1, M
        L = IC1(I)
        NC(L) = NC(L) + 1
        DO J = 1, N
           C(L,J) = C(L,J) + A(I,J)
        end DO
      end DO
C
C     Check to see if there is any empty cluster at this stage
C
      DO L = 1, K
        IF (NC(L) .EQ. 0) THEN
          IFAULT = 1
          RETURN
        END IF
        AA = NC(L)
        DO J = 1, N
           C(L,J) = C(L,J) / AA
        end DO
C
C     Initialize AN1, AN2, ITRAN & NCP
C     AN1(L) = NC(L) / (NC(L) - 1)
C     AN2(L) = NC(L) / (NC(L) + 1)
C     ITRAN(L) = 1 if cluster L is updated in the quick-transfer stage,
C              = 0 otherwise
C     In the optimal-transfer stage, NCP(L) stores the step at which
C     cluster L is last updated.
C     In the quick-transfer stage, NCP(L) stores the step at which
C     cluster L is last updated plus M.
C
        AN2(L) = AA / (AA + ONE)
        AN1(L) = BIG
        IF (AA .GT. ONE) AN1(L) = AA / (AA - ONE)
        ITRAN(L) = 1
        NCP(L) = -1
      end DO

      INDX = 0
      DO IJ = 1, ITER
C
C OPtimal-TRAnsfer stage: there is only one pass through the data.
C     Each point is re-allocated, if necessary, to the cluster that will
C     induce the maximum reduction in within-cluster sum of squares.
C
        CALL OPTRA(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
     *        ITRAN, LIVE, INDX)

        if(iTrace .gt. 0) call kmns1(K, IJ, INDX)
C
C     Stop if no transfer took place in the last M optimal transfer steps.
        IF (INDX .EQ. M) GO TO 150

C
C Quick-TRANSfer stage: Each point is tested in turn to see if it should
C     be re-allocated to the cluster to which it is most likely to be
C     transferred, IC2(I), from its present cluster, IC1(I).
C     Loop through the data until no further change is to take place.
C
        CALL QTRAN(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
     *       ITRAN, INDX, iTrace, iMaxQtr)
C
        if(iMaxQtr .lt. 0) then
           IFAULT = 4
           GO TO 150
        end if
C
C     If there are only two clusters, there is no need to re-enter the
C     optimal transfer stage.
C
        IF (K .EQ. 2) GO TO 150
C
C     NCP has to be set to 0 before entering OPTRA.
C
        DO L = 1, K
           NCP(L) = 0
        end DO

      end DO ! iter --------------------------------------
C
C     Since the specified number of iterations has been exceeded, set
C     IFAULT = 2.   This may indicate unforeseen looping.
C
      IFAULT = 2

  150 continue
      ITER = IJ
C
C     Compute within-cluster sum of squares for each cluster.
C
      do L = 1, K
        WSS(L) = ZERO
        do J = 1, N
           C(L,J) = ZERO
        end do
      end do

      do I = 1, M
        II = IC1(I)
        do J = 1, N
          C(II,J) = C(II,J) + A(I,J)
        end do
      end do

      do J = 1, N
        do L = 1, K
           C(L,J) = C(L,J) / DBLE(NC(L))
        end do
        do I = 1, M
          II = IC1(I)
          DA = A(I,J) - C(II,J)
          WSS(II) = WSS(II) + DA*DA
        end do
      end do
C
      RETURN
      END
C
C
      SUBROUTINE OPTRA(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
     *      ITRAN, LIVE, INDX)
C
C     ALGORITHM AS 136.1  APPL. STATIST. (1979) VOL.28, NO.1
C
C     This is the OPtimal TRAnsfer stage.
C                 ----------------------
C     Each point is re-allocated, if necessary, to the cluster that
C     will induce a maximum reduction in the within-cluster sum of
C     squares.
C
      INTEGER M,N,K,INDX
      INTEGER IC1(M), IC2(M), NC(K), NCP(K), ITRAN(K), LIVE(K)
      DOUBLE PRECISION    A(M,N), D(M), C(K,N), AN1(K), AN2(K)

      INTEGER L,I,L1,L2,LL,J
      DOUBLE PRECISION ZERO, ONE
      DOUBLE PRECISION BIG,DE,DF,DA,DB,R2,RR,DC,DD,AL1,ALW,AL2,ALT
C
      DATA BIG /1.0E30/, ! BIG := a very large positive number
     +     ZERO /0.0/, ONE/1.0/
C
C     If cluster L is updated in the last quick-transfer stage, it
C     belongs to the live set throughout this stage.   Otherwise, at
C     each step, it is not in the live set if it has not been updated
C     in the last M optimal transfer steps.
C
      do L = 1, K
        IF (ITRAN(L) .EQ. 1) LIVE(L) = M + 1
      end do

C     ---------------------- Loop over each point -------------------
      DO I = 1, M
        INDX = INDX + 1
        L1 = IC1(I)
        L2 = IC2(I)
        LL = L2
C
C     If point I is the only member of cluster L1, no transfer.
C
        IF (NC(L1) .EQ. 1) GO TO 90
C
C     If L1 has not yet been updated in this stage, no need to
C     re-compute D(I).
C
        IF (NCP(L1) .ne. 0) then
           DE = ZERO
           do J = 1, N
              DF = A(I,J) - C(L1,J)
              DE = DE + DF*DF
           end do
           D(I) = DE * AN1(L1)
        END IF
C
C     Find the cluster with minimum R2.
C
        DA = ZERO
        do J = 1, N
          DB = A(I,J) - C(L2,J)
          DA = DA + DB*DB
        end do
        R2 = DA * AN2(L2)
        DO 60 L = 1, K
C
C     If I >= LIVE(L1), then L1 is not in the live set.   If this is
C     true, we only need to consider clusters that are in the live set
C     for possible transfer of point I.   Otherwise, we need to consider
C     all possible clusters.
C
           IF (I .GE. LIVE(L1) .AND. I .GE. LIVE(L) .OR. L .EQ. L1 .OR.
     *          L .EQ. LL) GO TO 60
           RR = R2 / AN2(L)
           DC = ZERO
           do J = 1, N
              DD = A(I,J) - C(L,J)
              DC = DC + DD*DD
              IF (DC .GE. RR) GO TO 60
           end do
           R2 = DC * AN2(L)
           L2 = L
 60     CONTINUE
        IF (R2 .ge. D(I)) then
C     If no transfer is necessary, L2 is the new IC2(I).
           IC2(I) = L2
        ELSE
C
C     Update cluster centres, LIVE, NCP, AN1 & AN2 for clusters L1 and
C     L2, and update IC1(I) & IC2(I).
          INDX = 0
          LIVE(L1) = M + I
          LIVE(L2) = M + I
          NCP(L1) = I
          NCP(L2) = I
          AL1 = NC(L1)
          ALW = AL1 - ONE
          AL2 = NC(L2)
          ALT = AL2 + ONE
          do J = 1, N
            C(L1,J) = (C(L1,J) * AL1 - A(I,J)) / ALW
            C(L2,J) = (C(L2,J) * AL2 + A(I,J)) / ALT
          end do
          NC(L1) = NC(L1) - 1
          NC(L2) = NC(L2) + 1
          AN2(L1) = ALW / AL1
          AN1(L1) = BIG
          IF (ALW .GT. ONE) AN1(L1) = ALW / (ALW - ONE)
          AN1(L2) = ALT / AL2
          AN2(L2) = ALT / (ALT + ONE)
          IC1(I) = L2
          IC2(I) = L1
        END IF

   90   CONTINUE
        IF (INDX .EQ. M) RETURN

      end do
C     ---------------------- each point -------------------

      do L = 1, K
        ITRAN(L) = 0 !before entering QTRAN.
c       LIVE(L) has to be decreased by M before re-entering OPTRA
        LIVE(L) = LIVE(L) - M
      end do
C
      RETURN
      END
C
C
      SUBROUTINE QTRAN(A, M, N, C, K, IC1, IC2, NC, AN1, AN2, NCP, D,
     *    ITRAN, INDX, iTrace, iMaxQtr)
C
C     ALGORITHM AS 136.2  APPL. STATIST. (1979) VOL.28, NO.1
C
C     This is the Quick TRANsfer stage.
c                 --------------------
C     IC1(I) is the cluster which point I belongs to.
C     IC2(I) is the cluster which point I is most likely to be
C         transferred to.
C     For each point I, IC1(I) & IC2(I) are switched, if necessary, to
C     reduce within-cluster sum of squares.  The cluster centres are
C     updated after each step.
C
      INTEGER M,N,K,INDX, iTrace
      INTEGER IC1(M), IC2(M), NC(K), NCP(K), ITRAN(K)
      DOUBLE PRECISION A(M,N), D(M), C(K,N), AN1(K), AN2(K)

      DOUBLE PRECISION ZERO, ONE
      INTEGER ICOUN,ISTEP,I,L1,L2,J
      DOUBLE PRECISION BIG,DA,DB,DD,AL1,ALW,AL2,ALT,R2,DE
      external kmnsQpr
C
C     Define BIG to be a very large positive number
C
      DATA BIG /1.0E30/, ZERO /0.0/, ONE /1.0/
C
C     In the quick transfer stage, NCP(L)
C     is equal to the step at which cluster L is last updated plus M.
C
      ICOUN = 0
      ISTEP = 0
c   Repeat {
 10   continue

      DO I = 1, M
        if(iTrace .gt. 0 .and. ISTEP .ge. 1 .and. I .eq. 1) ! only from second "round" on
     +       call kmnsQpr(ISTEP, ICOUN, NCP, K, iTrace)
        ICOUN = ICOUN + 1
        ISTEP = ISTEP + 1
        IF(ISTEP .ge. iMaxQtr) THEN
           iMaxQtr = -1
           RETURN
        ENDIF
        L1 = IC1(I)
        L2 = IC2(I)
C
C     If point I is the only member of cluster L1, no transfer.
C
        IF (NC(L1) .EQ. 1) GO TO 60
C
C     If ISTEP > NCP(L1), no need to re-compute distance from point I to
C     cluster L1.   Note that if cluster L1 is last updated exactly M
C     steps ago, we still need to compute the distance from point I to
C     cluster L1.
C
        IF (ISTEP .le. NCP(L1)) then
           DA = ZERO
           DO J = 1, N
              DB = A(I,J) - C(L1,J)
              DA = DA + DB*DB
           end DO
           D(I) = DA * AN1(L1)
        end IF
C
C     If ISTEP >= both NCP(L1) & NCP(L2) there will be no transfer of
C     point I at this step.
C
        IF (ISTEP .lt. NCP(L1) .or. ISTEP .lt. NCP(L2)) then
           R2 = D(I) / AN2(L2)
           DD = ZERO
           DO J = 1, N
              DE = A(I,J) - C(L2,J)
              DD = DD + DE*DE
              IF (DD .GE. R2) GO TO 60
           end DO
C
C     Update cluster centres, NCP, NC, ITRAN, AN1 & AN2 for clusters
C     L1 & L2.   Also update IC1(I) & IC2(I).   Note that if any
C     updating occurs in this stage, INDX is set back to 0.
C
           ICOUN = 0
           INDX = 0
           ITRAN(L1) = 1
           ITRAN(L2) = 1
           NCP(L1) = ISTEP + M
           NCP(L2) = ISTEP + M
           AL1 = NC(L1)
           ALW = AL1 - ONE
           AL2 = NC(L2)
           ALT = AL2 + ONE
           DO J = 1, N
              C(L1,J) = (C(L1,J) * AL1 - A(I,J)) / ALW
              C(L2,J) = (C(L2,J) * AL2 + A(I,J)) / ALT
           end DO
           NC(L1) = NC(L1) - 1
           NC(L2) = NC(L2) + 1
           AN2(L1) = ALW / AL1
           AN1(L1) = BIG
           IF (ALW .GT. ONE) AN1(L1) = ALW / (ALW - ONE)
           AN1(L2) = ALT / AL2
           AN2(L2) = ALT / (ALT + ONE)
           IC1(I) = L2
           IC2(I) = L1
        end if
C
C     If no re-allocation took place in the last M steps, return.
C
   60   IF (ICOUN .EQ. M) RETURN
      end do

      call rchkusr() ! allow user interrupt
      GO TO 10
c     --------
      END


!NCLFORTSTART
SUBROUTINE DCOMPUTEABSVORT(av, u, v, msfu, msfv, msft, cor, dx, dy, nx, ny, nz,&
                          nxp1, nyp1)

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: av

    INTEGER, INTENT(IN) :: nx, ny, nz, nxp1, nyp1
    REAL(KIND=8), DIMENSION(nxp1,ny,nz), INTENT(IN) :: u
    REAL(KIND=8), DIMENSION(nx,nyp1,nz), INTENT(IN) :: v
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(OUT) :: av
    REAL(KIND=8), DIMENSION(nxp1,ny), INTENT(IN):: msfu
    REAL(KIND=8), DIMENSION(nx,nyp1), INTENT(IN) :: msfv
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: msft
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: cor
    REAL(KIND=8) :: dx, dy

!NCLEND

    INTEGER :: jp1, jm1, ip1, im1, i, j, k
    REAL(KIND=8) :: dsy, dsx, dudy, dvdx, avort
    REAL(KIND=8) :: mm

    !$OMP PARALLEL DO COLLAPSE(3) PRIVATE(i, j, k, jp1, jm1, ip1, im1, &
    !$OMP dsx, dsy, mm, dudy, dvdx, avort) SCHEDULE(runtime)
    DO k = 1,nz
        DO j = 1,ny
            DO i = 1,nx
                jp1 = MIN(j+1, ny)
                jm1 = MAX(j-1, 1)
                ip1 = MIN(i+1, nx)
                im1 = MAX(i-1, 1)
                dsx = (ip1 - im1) * dx
                dsy = (jp1 - jm1) * dy
                mm = msft(i,j)*msft(i,j)
                dudy = 0.5D0*(u(i,jp1,k)/msfu(i,jp1) + u(i+1,jp1,k)/msfu(i+1,jp1) - &
                     u(i,jm1,k)/msfu(i,jm1) - u(i+1,jm1,k)/msfu(i+1,jm1))/dsy*mm
                dvdx = 0.5D0*(v(ip1,j,k)/msfv(ip1,j) + v(ip1,j+1,k)/msfv(ip1,j+1) - &
                     v(im1,j,k)/msfv(im1,j) - v(im1,j+1,k)/msfv(im1,j+1))/dsx*mm
                avort = dvdx - dudy + cor(i,j)
                av(i,j,k) = avort*1.D5

            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE DCOMPUTEABSVORT

!NCLFORTSTART
SUBROUTINE DCOMPUTEPV(pv, u, v, theta, prs, msfu, msfv, msft, cor, dx, dy, nx, &
                      ny, nz, nxp1, nyp1)
    USE wrf_constants, ONLY : G

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: pv

    INTEGER,INTENT(IN) :: nx, ny, nz, nxp1, nyp1
    REAL(KIND=8), DIMENSION(nxp1,ny,nz), INTENT(IN) :: u
    REAL(KIND=8), DIMENSION(nx,nyp1,nz), INTENT(IN) :: v
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: theta
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(OUT) :: pv
    REAL(KIND=8), DIMENSION(nxp1,ny), INTENT(IN) ::  msfu
    REAL(KIND=8), DIMENSION(nx,nyp1), INTENT(IN) :: msfv
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: msft
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: cor
    REAL(KIND=8) :: dx,dy

!NCLEND

    INTEGER :: kp1, km1, jp1, jm1, ip1, im1, i, j, k
    REAL(KIND=8) :: dsy, dsx, dp, dudy, dvdx, dudp, dvdp, dthdp, avort
    REAL(KIND=8) :: dthdx, dthdy, mm

    !$OMP PARALLEL DO COLLAPSE(3) PRIVATE(i, j, k, kp1, km1, jp1, jm1, ip1, &
    !$OMP im1, dsx, dsy, mm, dudy, dvdx, avort, &
    !$OMP dp, dudp, dvdp, dthdp, dthdx, dthdy) SCHEDULE(runtime)
    DO k = 1,nz
        DO J = 1,ny
            DO i = 1,nx
                kp1 = MIN(k+1, nz)
                km1 = MAX(k-1, 1)
                jp1 = MIN(j+1, ny)
                jm1 = MAX(j-1, 1)
                ip1 = MIN(i+1, nx)
                im1 = MAX(i-1, 1)

                dsx = (ip1 - im1)*dx
                dsy = (jp1 - jm1)*dy
                mm = msft(i,j)*msft(i,j)

                dudy = 0.5D0*(u(i,jp1,k)/msfu(i,jp1) + u(i+1,jp1,k)/msfu(i+1,jp1) - &
                       u(i,jm1,k)/msfu(i,jm1) - u(i+1,jm1,k)/msfu(i+1,jm1))/dsy*mm
                dvdx = 0.5D0*(v(ip1,j,k)/msfv(ip1,j) + v(ip1,j+1,k)/msfv(ip1,j+1) - &
                       v(im1,j,k)/msfv(im1,j) - v(im1,j+1,k)/msfv(im1,j+1))/dsx*mm
                avort = dvdx - dudy + cor(i,j)
                dp = prs(i,j,kp1) - prs(i,j,km1)
                dudp = 0.5D0*(u(i,j,kp1) + u(i+1,j,kp1) - u(i,j,km1) - u(i+1,j,km1))/dp
                dvdp = 0.5D0*(v(i,j,kp1) + v(i,j+1,kp1) - v(i,j,km1) - v(i,J+1,km1))/dp
                dthdp = (theta(i,j,kp1) - theta(i,j,km1))/dp
                dthdx = (theta(ip1,j,k) - theta(im1,j,k))/dsx*msft(i,j)
                dthdy = (theta(i,jp1,k) - theta(i,jm1,k))/dsy*msft(i,j)
                pv(i,j,k) = -G*(dthdp*avort - dvdp*dthdx + dudp*dthdy)*10000.D0
                pv(i,j,k) = pv(i,j,k)*1.D2
            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE DCOMPUTEPV


module display_unum_as_real_mod
  use ISO_FORTRAN_ENV, only : INT64, REAL64
  use unum_to_float_mod
  use unum_env_mod,    only : Get_ulpu, Get_ubitmask
  use unum_t_mod
  implicit none

contains
  subroutine Display_unum_as_real (u)
    implicit none
    type (unum_t) :: u
    type (unum_t) :: u_temp, ulpu_local, ubitmask_local

    ulpu_local = Get_ulpu ()
    ubitmask_local = Get_ubitmask ()
    u_temp%u = u%u + ulpu_local%u

    if (IsExQ (u)) then
      print *, u2f (u)
    else
      write (unit=*, fmt=10) u2f (u), u2f (u_temp)
    end if
10 format ('(' , f15.5, ', ', f15.5, ')')
  end subroutine Display_unum_as_real
end module display_unum_as_real_mod


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  ()
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_GEN_COORS

    USE MR_KINDS

    USE MR_MAC_PI

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_GEN_XY

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  ()
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GEN_XY( THETA0 , BTH , LTH , NBENDS , NI , NJ , XYUV , XYUU , XYVV , XYOO )

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: THETA0
    REAL   (XYRD_KIND) , INTENT(IN ) :: BTH , LTH

    INTEGER            , INTENT(IN ) :: NBENDS

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (XYRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,XYRD_KIND),1:NJ,1:2) :: XYUV
    REAL   (XYRD_KIND) , INTENT(OUT) , DIMENSION(0:NI0(NI,XYRD_KIND),1:NJ,1:2) :: XYUU
    REAL   (XYRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,XYRD_KIND),0:NJ,1:2) :: XYVV
    REAL   (XYRD_KIND) , INTENT(OUT) , DIMENSION(0:NI0(NI,XYRD_KIND),0:NJ,1:2) :: XYOO

    REAL   (XYRD_KIND) , DIMENSION(0:NI0(2*NI,XYRD_KIND),0:2*NJ,1:2) :: XY_ALL

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM

    CALL MR_GEN_XY_ALL( THETA0 , BTH , LTH , NBENDS , NI , NJ , XY_ALL )

    DO DIM = 1 , 2
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          XYUV( I , J ,DIM) = XY_ALL(2*I-1,2*J-1,DIM)
        END DO
      END DO
    END DO

    DO DIM = 1 , 2
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 0 , NI
          XYUU( I , J ,DIM) = XY_ALL(2*I  ,2*J-1,DIM)
        END DO
      END DO
    END DO

    DO DIM = 1 , 2
      DO J = 0 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          XYVV( I , J ,DIM) = XY_ALL(2*I-1,2*J  ,DIM)
        END DO
      END DO
    END DO

    DO DIM = 1 , 2
      DO J = 0 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 0 , NI
          XYOO( I , J ,DIM) = XY_ALL(2*I  ,2*J  ,DIM)
        END DO
      END DO
    END DO

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  ()
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GEN_XY_ALL( THETA0 , BTH , LTH , NBENDS , NI , NJ , XY_ALL )

    IMPLICIT NONE

    REAL   (PARD_KIND) , INTENT(IN ) :: THETA0
    REAL   (XYRD_KIND) , INTENT(IN ) :: BTH , LTH

    INTEGER            , INTENT(IN ) :: NBENDS

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (XYRD_KIND) , INTENT(OUT) , DIMENSION(0:NI0(2*NI,XYRD_KIND),0:2*NJ,1:2) :: XY_ALL

    REAL   (PARD_KIND) :: DXI , DYJ

    REAL   (PARD_KIND) :: THETA

    INTEGER(IJID_KIND) :: I , J

    DXI = 0.5_PARD_KIND * NBENDS / NI
    DYJ = 1.0_PARD_KIND / NJ

    XY_ALL( 0 ,NJ,1) = 0.0
    XY_ALL( 0 ,NJ,2) = 0.0
   !DIR$ VECTOR ALIGNED
    DO I = 1 , NI
      THETA = THETA0 * COS(  2.0 * PI * ( ( I-0.5 ) * DXI )  )

      XY_ALL(2*I-1,NJ,1) = XY_ALL(2*I-2,NJ,1) + 0.5 * DXI * LTH * COS(THETA)
      XY_ALL(2*I-1,NJ,2) = XY_ALL(2*I-2,NJ,2) + 0.5 * DXI * LTH * SIN(THETA)

      XY_ALL(2*I  ,NJ,1) = XY_ALL(2*I-1,NJ,1) + 0.5 * DXI * LTH * COS(THETA)
      XY_ALL(2*I  ,NJ,2) = XY_ALL(2*I-1,NJ,2) + 0.5 * DXI * LTH * SIN(THETA)

    END DO

    DO J = NJ+1 , 2*NJ , +1
     !DIR$ VECTOR ALIGNED
      DO I = 0 , 2*NI
        THETA = THETA0 * COS(  2.0 * PI * ( 0.5 * I * DXI )  )

        XY_ALL( I , J ,1) = XY_ALL( I ,J-1,1) - 0.5 * DYJ * BTH * SIN(THETA)
        XY_ALL( I , J ,2) = XY_ALL( I ,J-1,2) + 0.5 * DYJ * BTH * COS(THETA)

      END DO
    END DO

    DO J = NJ-1 , 0 , -1
     !DIR$ VECTOR ALIGNED
      DO I = 0 , 2*NI
        THETA = THETA0 * COS(  2.0 * PI * ( 0.5 * I * DXI )  )

        XY_ALL( I , J ,1) = XY_ALL( I ,J+1,1) + 0.5 * DYJ * BTH * SIN(THETA)
        XY_ALL( I , J ,2) = XY_ALL( I ,J+1,2) - 0.5 * DYJ * BTH * COS(THETA)

      END DO
    END DO

  END SUBROUTINE MR_GEN_XY_ALL

  END SUBROUTINE MR_GEN_XY

  END MODULE MR_MOD_GEN_COORS


c ----------------------------
      subroutine corrmclumig97
c ----------------------------
c Simulate the energy response of Lumig - simulation in MC is wrong.

      implicit none
      logical firstc
      data firstc/.true./
      save firstc

#include"common97.inc"
#include"local.inc"
#include"constant.inc"

      real off,nl,res,off1,offold,nlold,resold,
     + off96,nl96,res96,off97,nl97,res97,
     + off97n,nl97n,res97n,resad97n,alpha97n,
     + alpha,beta,resad

      data off96,nl96,res96 /0.45,0.0011,0.32/

      real Etrue,arnd,brnd,xgam
      real rngama
	real rangam
	real Eres
      real Em1,em2,em3,off2
	real DEF_EE
	data DEF_EE /27.55/

      Logical LumiSimFirst
      Logical LSFMC
      Logical LSFBGD

      Data LumiSimFirst /.true./
      Data LSFMC /.true./
      Data LSFBGD /.true./

      SAVE LumiSimFirst,LSFMC,LSFBGD
      real x

      if (firstc) then
         write(*,*) '********************************'
         write(*,*) '***  Lumi correction for MC  ***'
         write(*,*) '********************************'
         write(999,*) '********************************'
         write(999,*) '***  Lumi correction for MC  ***'
         write(999,*) '********************************'
	   write(*,*) 'YEAR SET TO:',year
         firstc = .false.
	end if

	elumie = 0.
	elumig = 0.
	en44m = 0.

	off97n = 0.38
	nl97n = -0.0005
	res97n = 0.323 + lumires
	resad97n = 0.3
	alpha97n = 19.5

c      IF (year.eq.1996) THEN
c       NL=NL96
c       OFF=OFF96
c       RES=RES96

c      ELSEIF (year.eq.1997) THEN
       NL=NL97N
       OFF=OFF97N
       RES=RES97N
       RESAD=RESAD97N
       ALPHA=ALPHA97N
c     ENDIF

      If(LumiSimfirst)then
         write(6,*) '  '
         WRITE(6,*) ' ***************************************'
         write(6,*) '  '
         write(6,*) '      First call of LUMI SIMULATION '
         write(6,*) '           and LUMISMEARING'
         write(6,*) '  '
         write(6,*) '         RESOLUTION :', RES
         write(6,*) '             OFFSET :', OFF
         write(6,*) '       NONLINEARITY :', NL
         write(6,*) ' EXTRA RESOLUTION 1 :', RESAD
         write(6,*) '          ASYMMETRY :', ALPHA
         write(6,*) '  '
         write(6,*) '        LUMISIMTYP :',year
         write(6,*) '       BEAM ENERGY :',DEF_EE
         write(6,*) '  '
         write(999,*) '  '
         WRITE(999,*) ' ***************************************'
         write(999,*) '  '
         write(999,*) '      First call of LUMI SIMULATION '
         write(999,*) '           and LUMISMEARING'
         write(999,*) '  '
         write(999,*) '         RESOLUTION :', RES
         write(999,*) '             OFFSET :', OFF
         write(999,*) '       NONLINEARITY :', NL
         write(999,*) ' EXTRA RESOLUTION 1 :', RESAD
         write(999,*) '          ASYMMETRY :', ALPHA
         write(999,*) '  '
         write(999,*) '        LUMISIMTYP :',year
         write(999,*) '       BEAM ENERGY :',DEF_EE
         write(999,*) '  '

	   LumiSimfirst =.false.
      endif

C call random generator
C
      call rannor(arnd,brnd)
c	call rnorml(brnd,1)
C
C
	elumig = 0.
	Etrue = 0.

	Etrue = HCL_ENEG
      if(etrue.le.0.)  then
         elumig = 0.
         return
      endif

c ---------------------------------------
c 1996
c ---------------------------------------
c       IF (year.EQ.1996) THEN
c        em1=(Etrue-off)*(1.0+nl*(DEF_EE-Etrue))
c        elumig=em1 + (res)*sqrt(Etrue)*brnd
c       ENDIF
c	elumig = elumig + lumiscale

c ---------------------------------------
c 1997
c ---------------------------------------
	beta = 0.
	xgam = 0.
	em1 = 0.
	em2 = 0.
c     IF (year.EQ.1997) THEN
c
c       etrue = etrue - off
c	 if (etrue.gt.0.0) then
c	  beta = sqrt(alpha/(etrue*res**2+resad))
c	  xgam = rngama(alpha)/beta
c	  etrue = etrue - xgam+(alpha-1.)/beta
c	  if (etrue.lt.0) etrue = 0.
c	 end if
c     elumig = etrue*(1.0+nl*(DEF_EE-off-etrue))

      beta=sqrt(alpha/(((ETRUE-OFF)*res**2)+resad))
      xgam=(rngama(alpha))/beta
	em1 = (ETRUE-OFF-xgam+((alpha-1.0)/beta))
	em2 = (1.0+nl*(DEF_EE-ETRUE+xgam-((alpha-1.0)/beta)))
      elumig= (em1 * em2) + lumiscale

c      ENDIF

      elumie = ene_le
      en44m = TAG44_E

c -------------------------------
c Log MC quantities
c -------------------------------
      if (Q2_TRU.gt.0.0) then
         logmcq2 = log10(Q2_TRU)
      else
         logmcq2 = -99.
      end if

      if (X_TRU.gt.0.0) then
         logmcx = log10(X_TRU)
      else
         logmcx = -99.
      end if

      if (Y_TRU.gt.0.0) then
         logmcy = log10(Y_TRU)
      else
         logmcy = -99.
      end if

      return
      end


SUBROUTINE clawpack5_setaux(mbc,mx,my, &
     xlower,ylower,dx,dy,maux,aux)
  IMPLICIT NONE

  INTEGER mbc,mx,my,maux
  DOUBLE PRECISION xlower,ylower,dx,dy

  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

  DOUBLE PRECISION rhol, cl, rhor, cr
  COMMON /comaux/ rhol,cl,rhor,cr

  INTEGER i,j
  DOUBLE PRECISION xcell

  DO j=1-mbc,my+mbc
     DO i=1-mbc,mx+mbc
        xcell = xlower + (i-0.5d0)*dx
        IF (xcell .LT. 0.5d0) THEN
           aux(1,i,j) = rhol
           aux(2,i,j) = cl
        ELSE
           aux(1,i,j) = rhor
           aux(2,i,j) = cr
        ENDIF
     ENDDO
  ENDDO

  RETURN
END SUBROUTINE clawpack5_setaux


!
!  The rest of the 1-d program
!
      double precision function diff( a, b, nx, s, e )
      integer nx, s, e
      double precision a(0:nx+1, s-1:e+1), b(0:nx+1, s-1:e+1)
!
      double precision sum
      integer i, j
!
      sum = 0.0d0
      do j=s,e
         do i=1,nx
            sum = sum + (a(i,j) - b(i,j)) ** 2
         enddo
      enddo
!
      diff = sum
      return
      end


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE VECTOR_NORM ( VEC, NSIZE, WHICH, VEC_NORM, IERR )

! Calculates a particular norm (VEC_NORM) for an input vector (VEC) of extent NSIZE. The norm that is to be calculated is specified
! by WHICH:

!    (1) If WHICH = 'EUCLIDIAN', calculate the Euclidian norm (square root of the sum of the squares of all terms in the vector)
!    (2) If WHICH = 'INFINITY' , calculate the infinity  norm (maximum absolute value in the vector)

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  ERR, F04, F06, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ZERO
      USE SUBR_BEGEND_LEVELS, ONLY    :  VECTOR_NORM_BEGEND

      USE VECTOR_NORM_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'VECTOR_NORM'
      CHARACTER(LEN=*), INTENT(IN)    :: WHICH             ! Which norm to calculate (see below)

      INTEGER(LONG)   , INTENT(IN)    :: NSIZE             ! Extent of VEC
      INTEGER(LONG)   , INTENT(OUT)   :: IERR              ! Error indicator
      INTEGER(LONG)                   :: I                 ! DO loop index
      INTEGER(LONG)   , PARAMETER     :: SUBR_BEGEND = VECTOR_NORM_BEGEND

      REAL(DOUBLE)    , INTENT(IN)    :: VEC(NSIZE)        ! The vector for which the norm will be calculated
      REAL(DOUBLE)    , INTENT(OUT)   :: VEC_NORM          ! The norm calculated for VEC
      REAL(DOUBLE)                    :: TEMP              ! Temporary variable

      INTRINSIC                       :: DSQRT

! *********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGIN',F10.3)
      ENDIF

! **********************************************************************************************************************************
      IERR     = 0
      TEMP     = ZERO
      VEC_NORM = ZERO

      IF (WHICH == 'EUCLIDIAN') THEN                       ! Euclidian norm

         DO I=1,NSIZE
            TEMP = TEMP + VEC(I)*VEC(I)
         ENDDO
         VEC_NORM = DSQRT(TEMP)

      ELSE IF (WHICH == 'INFINITY') THEN                   ! Infinity norm

         DO I=1,NSIZE
            IF (DABS(VEC(I)) > VEC_NORM) THEN
               VEC_NORM = DABS(VEC(I))
            ENDIF
         ENDDO

      ELSE

         FATAL_ERR = FATAL_ERR + 1
         WRITE(ERR,964) SUBR_NAME, WHICH
         WRITE(F06,964) SUBR_NAME, WHICH

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  964 FORMAT(' *ERROR   965: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' INPUT VARIABLE WHICH = "',A,'" IS NOT A VALID VECTOR NORM METHOD FOR THIS SUBR')

! **********************************************************************************************************************************

      END SUBROUTINE VECTOR_NORM


      program loopexit4

c     The postcondition of a certainly executed loop should be its invariant
c     updated by the last increment plus the exit condition

      real t(10)

      read *, n

      if(n.ge.1) then

         j = 0
         do i = 1, n, 1
            t(i) = 0.
            j = j + 2
            k = 3
         enddo

C        Expected precondition:
C        P(I,J,K,N) {J==2I-2, K==3, N+1<=I, I<=N+1, 1<=N}
         print *, i, j, k

      endif

      end


program demo_rect
!(LICENSE:PD)
   use M_draw
   implicit none
   integer :: i, ipaws
   real    :: r

   !! set up graphics area
   call prefsize(400,400)
   call vinit(' ') ! start graphics using device $M_DRAW_DEVICE
   call ortho2(left=-100.0, right=100.0, bottom=-100.0, top=100.0)

   !! draw some filled rectangles
   call polyfill(.true.)
   do i=95,5,-10
      call color(i/10)
      r=real(i)
      call rect( -1.0*r, -1.0*r, 1.0*r, 1.0*r )
   enddo

   !! draw some rectangles
   call polyfill(.false.)
   call linewidth(50)
   call color(7)
   do i=5,95,5
      r=real(i)
      call rect( -1.0*r, -1.0*r, 1.0*r, 1.0*r )
   enddo

   !! pause
   call vflush()
   ipaws=getkey()

   !! wrap up graphics
   call vexit()

end program demo_rect


program test_subscript
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

n = 1
ntests = 11
call initialize_tests(tests,ntests)

tests(n) = assert(all(subscript([1_int8,2_int8,3_int8],[2_int8]) == [2_int8]),&
                  'subscript, int8')
n = n + 1

tests(n) = assert(all(subscript([1_int16,2_int16,3_int16],[2_int16]) == [2_int16]),&
                  'subscript, int16')
n = n + 1

tests(n) = assert(all(subscript([1_int32,2_int32,3_int32],[2_int32]) == [2_int32]),&
                  'subscript, int32')
n = n + 1

tests(n) = assert(all(subscript([1_int64,2_int64,3_int64],[2_int64]) == [2_int64]),&
                  'subscript, int64')
n = n + 1

tests(n) = assert(all(subscript([1._real32,2._real32,3._real32],[2]) == [2._real32]),&
                 'subscript, real32')
n = n + 1

tests(n) = assert(all(subscript([1._real64,2._real64,3._real64],[2]) == [2._real64]),&
                  'subscript, real64')
n = n + 1

tests(n) = assert(all(subscript([1._real128,2._real128,3._real128],[2]) == [2._real128]),&
                  'subscript, real128')
n = n + 1

tests(n) = assert(size(subscript([1,2,3],[0])) == 0,&
                  'subscript out of bounds returns empty array')
n = n + 1

tests(n) = assert(all(subscript(arange(cmplx(1._real32,0._real32),&
                                       cmplx(3._real32,0._real32)),[2])&
                       == [cmplx(2._real32,0._real32)]),&
                  'subscript, complex real32')
n = n + 1

tests(n) = assert(all(subscript(arange(cmplx(1._real64,0._real64),&
                                       cmplx(3._real64,0._real64)),[2])&
                       == [cmplx(2._real64,0._real64)]),&
                  'subscript, complex real64')
n = n + 1

tests(n) = assert(all(subscript(arange(cmplx(1._real128,0._real128),&
                                       cmplx(3._real128,0._real128)),[2])&
                       == [cmplx(2._real128,0._real128)]),&
                  'subscript, complex real128')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_subscript


!
! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
program main

   use dot_m
   use dot_cuda_m

   integer :: i, j, m, n
   integer :: AllocateStatus
   real, allocatable :: A(:,:)
   real, allocatable :: B(:,:)
   real, allocatable :: C(:)
   real, allocatable :: D(:)

   m = 4098
   n = 4098

   write(*,*) 'Running with m,n: ', m, n

   ! alloc arrays (A to D)
   allocate( A(m,n), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   allocate( B(m,n), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   allocate( C(m), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   allocate( D(m), stat = AllocateStatus)
   IF (AllocateStatus /= 0) STOP "*** Not enough memory ***"

   ! Create random arrays A and B
   call random_seed()
   call random_number(A)
   call random_number(B)
   do j = 1,n
      do i = 1,m
          A(i,j) = int(A(i,j)*10.0)
          B(i,j) = int(B(i,j)*10.0)
      end do
   end do

   ! call dot product on host
   call dot(A, B, C, m, n)

!$acc data copyin(A, B) copyout(D)
   call dot_cuda(A, B, D, m, n)
!$acc end data

   ! check answers
   write(*,*) 'maxval(abs(C-D)): ', maxval(abs(C-D))

end program


module state_interface
  !! Encapsulate state variables that must persist throughught execution for purposes of accumulation
  use kind_parameters, only : rkind
  implicit none

  private

  type, public :: state_t
    private
    real(rkind) time_       !! simulated time
    real(rkind) mass_       !! mass contained in chamber
    real(rkind) energy_     !! internal energy contained in chamber
    real(rkind) burn_depth_ !! surface-normal burn distance
  contains
    procedure :: define, row_vector, energy, mass, burn_depth, time, absolute
    procedure, private :: add, multiply
    generic :: operator(+) => add
    generic :: operator(*) => multiply
  end type

  interface state_t
    module procedure new_state
  end interface

  interface

    module subroutine define(this, input_file, R_gas, c_v, volume, time, burn_depth)
      !! set all components of this gas_t object
      implicit none
      class(state_t), intent(out) :: this
      character(len=*), intent(in) :: input_file
      real(rkind), intent(in) :: R_gas, c_v, volume, time, burn_depth
    end subroutine

    pure module function absolute(this) result(this_abs)
      !! result is absolute value of the state vector
      implicit none
      class(state_t), intent(in) :: this
      real(rkind), allocatable :: this_abs(:)
    end function

    pure module function new_state(mass, energy, burn_depth, time)
      !! result is a new state_t object
      implicit none
      real(rkind), intent(in) ::  mass, energy, burn_depth, time
      type(state_t) new_state
    end function

    pure module function row_vector(this)
      implicit none
      class(state_t), intent(in) :: this
      real(rkind), allocatable :: row_vector(:,:)
    end function

    elemental module function time(this)
      !! get the time state variable
      implicit none
      class(state_t), intent(in) :: this
      real(rkind) time
    end function

    elemental module function burn_depth(this)
      !! get the burn_depth state variable
      implicit none
      class(state_t), intent(in) :: this
      real(rkind) burn_depth
    end function

    elemental module function energy(this)
      !! get the energy state variable
      implicit none
      class(state_t), intent(in) :: this
      real(rkind) energy
    end function

    elemental module function mass(this)
      !! get the mass state variable
      implicit none
      class(state_t), intent(in) :: this
      real(rkind) mass
    end function

    pure module function add(lhs, rhs) result(total)
      !! result has components computed from summing lhs & rhs components
      implicit none
      class(state_t), intent(in) :: lhs, rhs
      type(state_t) total
    end function

    pure module function multiply(lhs, rhs) result(product_)
      !! result has components computed from summing lhs & rhs components
      implicit none
      class(state_t), intent(in) :: lhs
      real(rkind), intent(in) :: rhs
      type(state_t) product_
    end function

  end interface

end module state_interface


program dataStatement
implicit none

   integer :: a(5), b(4,3), c(10),i, j
   data a /7,8,9,10,11/

   data b(1,:) /1,1,1/
   data b(2,:)/2,2,2/
   data b(3,:)/3,3,3/
   data b(4,:)/4,4,4/
   data (c(i),i = 1,10,2) /4,5,6,7,8/
   data (c(i),i = 2,10,2)/5*2/

   Print *, 'The A array:'
   do j = 1, 5
      print*, a(j)
   end do

   Print *, 'The B array:'
   do i = lbound(b,1), ubound(b,1)
      write(*,*) (b(i,j), j = lbound(b,2), ubound(b,2))
   end do

   Print *, 'The C array:'
   do j = 1, 10
      print*, c(j)
   end do

end program dataStatement


let Pair = fn (X:*) (Y:*) :* => (Z:*->(X->Y->Z)->Z);;

let pair = fn (X:*) (Y:*) (x:X) (y:Y) : Pair X Y => fn (Z:*) (f:X->Y->Z) => f x y;;
let fst = fn (X:*) (Y:*) (p:Pair X Y) : X => p X (fn (x:X) (y:Y) => x);;
let snd = fn (X:*) (Y:*) (p:Pair X Y) : Y => p Y (fn (x:X) (y:Y) => y);;

let Sum = fn (X:*) (Y:*) => (Z:*->(X->Z)->(Y->Z)->Z);;
let inl = fn (X:*) (Y:*) (x:X) : (Sum X Y) => fn (Z:*) (fx:X->Z) (fy:Y->Z) => fx x;;
let inr = fn (X:*) (Y:*) (y:Y) : (Sum X Y) => fn (Z:*) (fx:X->Z) (fy:Y->Z) => fy y;;

let rec IntList:* = Sum Unit (Pair Int IntList);;
let Cons = Pair Int IntList;;

let null = (inl Unit Cons unit) as IntList;;
let cons = fn (a:Int) (d:IntList) : IntList =>
   inr Unit Cons (pair Int IntList a d);;
let car (c:Cons) = fst Int IntList c;;
let cdr (c:Cons) = snd Int IntList c;;
let case = fn (l:IntList) (Z:*) (f1:Unit->Z) (f2:Cons->Z) :Z =>
   (l as (Sum Unit Cons)) Z f1 f2;;

/* Here is where the content starts.  For the sake of
   demonstration, I only sort positive ints. */

let is_sorted (L:IntList) : Bool =
    let rec helper (L:IntList) (lowbound:Int) : Bool =
        case L Bool
            (fn (u:Unit) => true)
            (fn (c:Cons) =>
                let elem = car c in
                (IF (Unit->Bool)
                    (elem >= lowbound)
                    (fn d => helper (cdr c) elem)
                    (fn d => false)
                    unit))
    in
    helper L 0
;;

let rec print_list (l:IntList) : Unit =
    case l Unit
        (fn (u:Unit) => unit)
        (fn (c:Cons) => let u = print (car c) in print_list (cdr c));;

let Pos = (x:Int.x>=0);;

let rec length (l:IntList) : Pos =
  (case l Pos
     (fn (u:Unit) => 0)
     (fn (l2:Cons) => 1 + (length (cdr l2))));;

/* Uses crazy IF because cast algorithm fails */
let split_in_half (L:IntList) : (Pair IntList IntList) =
    let mkpair = pair IntList IntList in
    let rec helper (firsthalf:IntList) (secondhalf:IntList) :
                                       (Pair IntList IntList) =
        case firsthalf (Pair IntList IntList)
            (fn (u:Unit) => mkpair firsthalf secondhalf)
            (fn (c:Cons) =>
                let tl1 = cdr c in
                IF
                    (Unit -> (Pair IntList IntList))
                    ((length tl1) >= ((length (secondhalf)) + 1))
                    (fn u => helper tl1 (cons (car c) secondhalf))
                    (fn u => mkpair firsthalf secondhalf)
                    unit)
    in
    helper L null
;;

let rec merge (L1:IntList) (L2:IntList)
        : (l:IntList.(length l) = (length L1) + (length L2))
        =
    case L1 IntList
        (fn (u:Unit) => L2)
        (fn (c1:Cons) =>
            case L2 IntList
                (fn (u:Unit) => L1)
                (fn (c2:Cons) =>
                    let e1 = car c1 in    let e2 = car c2 in
                    IF (Unit -> IntList) (e1 >= e2)
                    (fn u => cons e2 (merge L1 (cdr c2)))
                        (fn u => cons e1 (merge (cdr c1) L2))
                        unit));;

let rec mergesort (L:IntList) : (l:IntList. is_sorted l) =
    let u = print_list L in
    let u = newline unit in
    IF (Unit -> IntList) (1 >= (length L))
        (fn u => L)
        (fn u =>
            let twolists = split_in_half L in
            let L1 = fst IntList IntList twolists in
            let L2 = snd IntList IntList twolists in
            merge (mergesort L1) (mergesort L2))
        unit
;;

let L2 = cons 1 null;;
(is_sorted L2);;
/*(length L2);;
split_in_half L2;;*/

let L1 = cons 1 (cons 2 (cons 3 (cons 4 (cons 5 null))));;
(length L1);;
(is_sorted L1);;
let twolists = split_in_half L1;;
print_list (fst IntList IntList twolists);;
print_list (snd IntList IntList twolists);;

let L3 = cons 3 (cons 2 (cons 9 (cons 4 (cons 1 null))));;
let sorted_L3 = mergesort L3;;
is_sorted L3;;
is_sorted sorted_L3;;
(length L3);;
(length sorted_L3);;

print 3;;
print_list L3;;

print_list (merge (cons 1 (cons 3 (cons 5 null)))
           (cons 2 (cons 4 (cons 6 null))));;

print_list sorted_L3;;