c
c
c
c =========================================================
      subroutine rp1(maxmx,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,
     &           wave,s,amdq,apdq)
c =========================================================
c
c     # solve Riemann problems for the 1D Euler equations using Roe's
c     # approximate Riemann solver.
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routine step1, rp is called with ql = qr = q.
c
c
      implicit double precision (a-h,o-z)
      dimension   ql(1-mbc:maxmx+mbc, meqn)
      dimension   qr(1-mbc:maxmx+mbc, meqn)
      dimension    s(1-mbc:maxmx+mbc, mwaves)
      dimension wave(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension amdq(1-mbc:maxmx+mbc, meqn)
      dimension apdq(1-mbc:maxmx+mbc, meqn)
c
c     # local storage
c     ---------------
      parameter (max2 = 2002)  !# assumes at most 2000 grid points with mbc=2
      dimension delta(3)
      dimension u(-1:max2),enth(-1:max2),a(-1:max2)
      logical efix
      common /param/  gamma,gamma1
c
      data efix /.true./    !# use entropy fix for transonic rarefactions
c
c     # Compute Roe-averaged quantities:
c
      do 20 i=2-mbc,mx+mbc
         rhsqrtl = dsqrt(qr(i-1,1))
         rhsqrtr = dsqrt(ql(i,1))
         pl = gamma1*(qr(i-1,3) - 0.5d0*(qr(i-1,2)**2)/qr(i-1,1))
         pr = gamma1*(ql(i,3) - 0.5d0*(ql(i,2)**2)/ql(i,1))
         rhsq2 = rhsqrtl + rhsqrtr
         u(i) = (qr(i-1,2)/rhsqrtl + ql(i,2)/rhsqrtr) / rhsq2
         enth(i) = (((qr(i-1,3)+pl)/rhsqrtl
     &             + (ql(i,3)+pr)/rhsqrtr)) / rhsq2
         a2 = gamma1*(enth(i) - .5d0*u(i)**2)
         a(i) = dsqrt(a2)
   20    continue
c
c
      do 30 i=2-mbc,mx+mbc
c
c        # find a1 thru a3, the coefficients of the 3 eigenvectors:
c
         delta(1) = ql(i,1) - qr(i-1,1)
         delta(2) = ql(i,2) - qr(i-1,2)
         delta(3) = ql(i,3) - qr(i-1,3)
         a2 = gamma1/a(i)**2 * ((enth(i)-u(i)**2)*delta(1)
     &      + u(i)*delta(2) - delta(3))
         a3 = (delta(2) + (a(i)-u(i))*delta(1) - a(i)*a2) / (2.d0*a(i))
         a1 = delta(1) - a2 - a3
c
c        # Compute the waves.
c
         wave(i,1,1) = a1
         wave(i,2,1) = a1*(u(i)-a(i))
         wave(i,3,1) = a1*(enth(i) - u(i)*a(i))
         s(i,1) = u(i)-a(i)
c
         wave(i,1,2) = a2
         wave(i,2,2) = a2*u(i)
         wave(i,3,2) = a2*0.5d0*u(i)**2
         s(i,2) = u(i)
c
         wave(i,1,3) = a3
         wave(i,2,3) = a3*(u(i)+a(i))
         wave(i,3,3) = a3*(enth(i)+u(i)*a(i))
         s(i,3) = u(i)+a(i)
   30    continue
c
c     # compute Godunov flux f0:
c     --------------------------
c
c
      if (efix) go to 110
c
c     # no entropy fix
c     ----------------
c
c     # amdq = SUM s*wave   over left-going waves
c     # apdq = SUM s*wave   over right-going waves
c
      do 100 m=1,3
         do 100 i=2-mbc, mx+mbc
            amdq(i,m) = 0.d0
            apdq(i,m) = 0.d0
            do 90 mw=1,mwaves
               if (s(i,mw) .lt. 0.d0) then
                   amdq(i,m) = amdq(i,m) + s(i,mw)*wave(i,m,mw)
                 else
                   apdq(i,m) = apdq(i,m) + s(i,mw)*wave(i,m,mw)
                 endif
   90          continue
  100       continue
      go to 900
c
c-----------------------------------------------------
c
  110 continue
c
c     # With entropy fix
c     ------------------
c
c    # compute flux differences amdq and apdq.
c    # First compute amdq as sum of s*wave for left going waves.
c    # Incorporate entropy fix by adding a modified fraction of wave
c    # if s should change sign.
c
      do 200 i=2-mbc,mx+mbc
c
c        # check 1-wave:
c        ---------------
c
         rhoim1 = qr(i-1,1)
         pim1 = gamma1*(qr(i-1,3) - 0.5d0*qr(i-1,2)**2 / rhoim1)
         cim1 = dsqrt(gamma*pim1/rhoim1)
         s0 = qr(i-1,2)/rhoim1 - cim1     !# u-c in left state (cell i-1)

c        # check for fully supersonic case:
         if (s0.ge.0.d0 .and. s(i,1).gt.0.d0)  then
c            # everything is right-going
             do 60 m=1,3
                amdq(i,m) = 0.d0
   60           continue
             go to 200
             endif
c
         rho1 = qr(i-1,1) + wave(i,1,1)
         rhou1 = qr(i-1,2) + wave(i,2,1)
         en1 = qr(i-1,3) + wave(i,3,1)
         p1 = gamma1*(en1 - 0.5d0*rhou1**2/rho1)
         c1 = dsqrt(gamma*p1/rho1)
         s1 = rhou1/rho1 - c1  !# u-c to right of 1-wave
         if (s0.lt.0.d0 .and. s1.gt.0.d0) then
c            # transonic rarefaction in the 1-wave
             sfract = s0 * (s1-s(i,1)) / (s1-s0)
           else if (s(i,1) .lt. 0.d0) then
c            # 1-wave is leftgoing
             sfract = s(i,1)
           else
c            # 1-wave is rightgoing
             sfract = 0.d0   !# this shouldn't happen since s0 < 0
           endif
         do 120 m=1,3
            amdq(i,m) = sfract*wave(i,m,1)
  120       continue
c
c        # check 2-wave:
c        ---------------
c
         if (s(i,2) .ge. 0.d0) go to 200  !# 2-wave is rightgoing
         do 140 m=1,3
            amdq(i,m) = amdq(i,m) + s(i,2)*wave(i,m,2)
  140       continue
c
c        # check 3-wave:
c        ---------------
c
         rhoi = ql(i,1)
         pi = gamma1*(ql(i,3) - 0.5d0*ql(i,2)**2 / rhoi)
         ci = dsqrt(gamma*pi/rhoi)
         s3 = ql(i,2)/rhoi + ci     !# u+c in right state  (cell i)
c
         rho2 = ql(i,1) - wave(i,1,3)
         rhou2 = ql(i,2) - wave(i,2,3)
         en2 = ql(i,3) - wave(i,3,3)
         p2 = gamma1*(en2 - 0.5d0*rhou2**2/rho2)
         c2 = dsqrt(gamma*p2/rho2)
         s2 = rhou2/rho2 + c2   !# u+c to left of 3-wave
         if (s2 .lt. 0.d0 .and. s3.gt.0.d0) then
c            # transonic rarefaction in the 3-wave
             sfract = s2 * (s3-s(i,3)) / (s3-s2)
           else if (s(i,3) .lt. 0.d0) then
c            # 3-wave is leftgoing
             sfract = s(i,3)
           else
c            # 3-wave is rightgoing
             go to 200
           endif
c
         do 160 m=1,3
            amdq(i,m) = amdq(i,m) + sfract*wave(i,m,3)
  160       continue
  200    continue
c
c     # compute the rightgoing flux differences:
c     # df = SUM s*wave   is the total flux difference and apdq = df - amdq
c
      do 220 m=1,3
         do 220 i = 2-mbc, mx+mbc
            df = 0.d0
            do 210 mw=1,mwaves
               df = df + s(i,mw)*wave(i,m,mw)
  210          continue
            apdq(i,m) = df - amdq(i,m)
  220       continue
c

c
  900 continue
      return
      end


      subroutine diavc3(vecout,vecin,diag,shift,ndim,vdsv)
*
* vecout(i)=vecin(i)/(diag(i)+shift)
*
* vdsv = sum(i) vecin(i) ** 2 /( diag(i) + shift )
*
*     adapted from jeppen olsen's original
*
      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     ndim
      real(8), intent(in) ::
     &     vecin(ndim), diag(ndim), shift
      real(8), intent(out) ::
     &     vecout(ndim), vdsv

      real(8), parameter ::
     &     thres = 1d-10
      integer, parameter ::
     &     ntest = 00

      real(8) ::
     &     divide
      integer ::
     &     i

*
      vdsv = 0.0d0
      do i=1,ndim
*
        divide=diag(i)+shift
        if(abs(divide).le.thres) divide=thres
*
        vdsv = vdsv + vecin(i)*vecin(i) /divide
        vecout(i)=vecin(i)/divide
*
      end do
*
      if(ntest.ge.100) then
        write(lulog,*) 'diavc3 : vecin, diag,vecout '
        do i = 1, ndim
          write(lulog,'(3e15.8)') vecin(i),diag(i),vecout(i)
        end do
      end if
*
      return
      end


      double precision function cosine_bell_sum(x,y,z)
      implicit none

      double precision x,y,z

      double precision hmax, h1, b, c, r, w(3)
      double precision q, qv

      integer m,n, get_n_locations
      double precision cosbell

      n = get_n_locations()

      call get_td_cosbell_parms(r,hmax,b,c)

      q = 0
      do m = 1,n
         call get_td_gaussian_locations(m,w)
         qv = cosbell(x,y,z,w,r,hmax)
         q  = q  + qv
      enddo
      cosine_bell_sum = b + c*q

      end

      double precision function cosbell(x,y,z,w,r,hmax)
      implicit none

      double precision x,y,z,w(3),r,hmax
      double precision get_gc_distance, h1, ri
      double precision pi

      common /compi/ pi

      ri = get_gc_distance(x,y,z,w)

      if (ri .le. r) then
         h1 = hmax*(1 + cos(pi*ri/r))
      else
         h1 = 0.d0
      endif
      cosbell = h1

      end

c     # ----------------------------------------------------
c     # Set a,hmax parameters for Cosine bell
c     # ----------------------------------------------------

      subroutine set_initial_cosbell_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax, b,c

      double precision wc_init_com(3,100), r_init_com, hmax_init_com
      double precision b_init_com, c_init_com

      common /comcbinit1/ wc_init_com, r_init_com, hmax_init_com,
     &      b_init_com, c_init_com

      r_init_com = r
      hmax_init_com = hmax
      b_init_com = b
      c_init_com = c

      call set_td_cosbell_parms(r,hmax,b,c)

      end

      subroutine get_initial_cosbell_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax, b,c

      double precision wc_init_com(3,100), r_init_com,
     &      hmax_init_com, b_init_com, c_init_com

      common /comcbinit1/ wc_init_com, r_init_com, hmax_init_com,
     &      b_init_com, c_init_com

      r = r_init_com
      hmax = hmax_init_com
      b = b_init_com
      c = c_init_com

      end

      subroutine set_td_cosbell_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax,b,c

      double precision wc_td_com(3,100), r_td_com, hmax_td_com,
     &      b_td_com, c_td_com

      common /comcbinit1/ wc_td_com, r_td_com, hmax_td_com,
     &      b_td_com, c_td_com

      r_td_com = r
      hmax_td_com = hmax
      b_td_com = b
      c_td_com = c

      end

      subroutine get_td_cosbell_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax, b, c

      double precision wc_td_com(3,100), r_td_com, hmax_td_com
      double precision b_td_com,c_td_com

      common /comcbinit1/ wc_td_com, r_td_com, hmax_td_com,
     &      b_td_com, c_td_com

      r = r_td_com
      hmax = hmax_td_com
      b = b_td_com
      c = c_td_com

      end


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.
!
! 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.

!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity of the fluid [J/kg/K]
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return cpf  [J/kg/K]
!> @details
!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
!> J/kg/K) of brine, given temperature (t, in degC) pressure (p,in MPa),
!> and salinity (s, in mol/L) at node(i,j,k)\\n \n
!>
!> Source:\n
!> Driesner & Heinrich, The system H2O-NaCl. Part I: Correlation
!>    formulae for phase relations in temperature-pressure-composition
!>    space from 0 to 1000 C, 0 to 5000 bar, and 0 to 1 XNaCl
!>    Geochimica et Cosmochimica Acta 71 (2007) 4880-4901\n\n
!>
!> Driesner, The system H2O-NaCl. Part II: Correlations for molar
!>    volume, enthalpy, and isobaric heat capacity from 0 to 1000 C, 1
!>    to 5000 bar, and 0 to 1 XNaCl Geochimica et Cosmochimica Acta 71
!>    (2007) 4902-4919\n \n
      double precision function cpf(i,j,k,ismpl)
        use arrays
        use mod_flow

        implicit none

        ! Location indices
        integer, intent (in) :: i
        integer, intent (in) :: j
        integer, intent (in) :: k

        ! Sample index
        integer :: ismpl

        ! Local Temperature, [degC]
        double precision :: t

        ! Local Pressure [MPa]
        double precision :: p

        ! Local salinity [mol/kg]
        double precision :: s

        ! Monomials of pressure [bar]
        double precision :: pb, pb2

        ! Pure water compressibility [1/Pa]
        double precision cw
        double precision, external :: compw

        ! Pure water density [kg/m3]
        double precision rw
        double precision, external :: rhow

        ! Pure water thermal conductivity [J/kg/K]
        double precision, external :: cpw

        ! Molar mass of NaCl [g/mol]
        double precision, parameter :: mmnacl = 58.44277d0

        ! Mass fraction of NaCl in solution [-]
        double precision :: fracnacl

        ! Molar mass of water, H2O [g/mol]
        double precision, parameter :: mmwater = 18.01528d0

        ! Mole fraction of NaCl [-]
        double precision :: xnacl

        ! Temperature at which pure water has the same specific
        ! enthalpy as the solution [K]
        double precision :: tv

        ! Driesner2007: Coefficients

        ! Equation (23)
        double precision :: q1, q10, q11, q12

        ! Equation (24)
        double precision :: q2, q20, q21, q22, q23

        ! Equation (25), (26)
        double precision :: q1x, q2x

        ! Local temperature [degC]
        t = temp(i,j,k,ismpl)

        ! Local pressure [MPa]
        p = pres(i,j,k,ismpl)*pa_conv1

        ! Local salinity [mol/L]
        s = tsal(i,j,k,ismpl)

        if (s<=0.0d0) then

          ! Pure water heat capacity
          cpf = cpw(p,t)

        else

          ! pure water density [g/L = kg/m3]
          rw = rhow(p,t)

          ! Pressure monomials [bar]
          pb = p*10.0d0
          pb2 = pb*pb

          ! Mass fraction of NaCl, mol/L > (g/L) / (g/L) mass fraction
          fracnacl = s*mmnacl/(rw+s*mmnacl)

          ! Mole fraction of NaCl, (mol/L) / (mol/L)
          xnacl = (fracnacl/mmnacl) / (fracnacl/mmnacl+(1-fracnacl)/mmwater)

          ! Driesner2007 parameters, Table 5
          q11 = -32.1724d0 + 0.0621255d0*pb
          q21 = -1.69513d0 - 4.52781d-4*pb - 6.04279d-8*pb2
          q22 = 0.0612567d0 + 1.88082d-5*pb

          ! Driesner2007: q1 and q2 parameters for liquid NaCl
          q1x = 47.9048d0 - 9.36994d-3*pb + 6.51059d-6*pb2
          q2x = 0.241022d0 + 3.45087d-5*pb - 4.28356d-9*pb2

          ! Driesner2007: Set xnacl=1 in (23) => q1 = q1x
          q10 = q1x

          ! Driesner2007: Set xnacl=0 in (23) => q1 = 0.0d0
          q12 = -q10 - q11

          ! Driesner2007: Set xnacl=0 in (24) => q2 = 1.0d0
          q20 = 1.0d0 - q21*sqrt(q22)

          ! Driesner2007: Set xnacl=1 in (10) => q2 = q2x
          q23 = q2x - q20 - q21*sqrt(1.0d0+q22)

          ! Driesner2007: Equation (23)
          q1 = q10 + q11*(1.0d0-xnacl) + q12*(1.0d0-xnacl)**2

          ! Driesner2007: Equation (24)
          q2 = q20 + q21*sqrt(xnacl+q22) + q23*xnacl

          ! Temperature at which pure water has the same specific
          ! enthalpy as the solution
          tv = q1 + q2*t

          ! Isobaric heat capacity of solution
          cpf = q2*cpw(p,tv)

        end if

        return

      end function cpf


      SUBROUTINE DHYI2HYOB(P0,HYAI,HYBI,PSFC,MLON,NLAT,KLEVI,XI,HYAO,
     +                     HYBO,KLEVO,XO,PI,PO,INTFLG, MSGFLG, XMSG)
      IMPLICIT NONE
c NCL: xo = hyi2hyo (p0,hyai,hybi,psfc,xi,hyao,hybo)

c this routine interploates one hybrid level to another
c     formula for the pressure of a hybrid surface is;
c          phy(k) = hya(k)*p0 + hyb(k)*psfc

c     input  ["i" input ... "o" output]
c          hyai   - is the "a" or pressure hybrid coef [input]
c          hybi   - is the "b" or sigma coeficient     [input]
c          p0     - is the base pressure in Pa         [input]
c          psfc   - is the surface pressure Pa         [input]
c          mlon   - longitude dimension
c          nlat   - latitude  dimension
c          klevi  - number of input  levels
c          hyao   - is the "a" or pressure hybrid coef
c          hybo   - is the "b" or sigma coeficient
c          klevo  - number of output levels
c          xmsg   = missing code; if none present set to
c                   some bogus value [eg, 1d20]
c          intflg - if  0 set all values outside of input P to xmsg
c                   if  1 set output values to closest input pressure level
c     output
c          xo     - pressure at hybrid levels [Pa]
c          msgflg - if  0 no missing values upon return
c                   if -1 missing values are present.

c                                                 ! input
      INTEGER MLON,NLAT,KLEVI,KLEVO,INTFLG
      DOUBLE PRECISION P0,HYAI(KLEVI),HYBI(KLEVI),HYAO(KLEVO),
     +                 HYBO(KLEVO),PSFC(MLON,NLAT),XI(MLON,NLAT,KLEVI),
     +                 PI(KLEVI),PO(KLEVO), XMSG
c                                                 ! output
      DOUBLE PRECISION XO(MLON,NLAT,KLEVO)
c                                                 ! local
      INTEGER NL,ML,KI,KO, MSGFLG
      DOUBLE PRECISION PEPS, PILOW
c f77
      PEPS   = 1.0D-3
      MSGFLG = 0

      DO NL = 1,NLAT
          DO ML = 1,MLON
              DO KI = 1,KLEVI
                  PI(KI) = HYAI(KI)*P0 + HYBI(KI)*PSFC(ML,NL)
              END DO
              PILOW = PI(KLEVI) - PEPS

              DO KO = 1,KLEVO
                  PO(KO) = HYAO(KO)*P0 + HYBO(KO)*PSFC(ML,NL)
              END DO

              DO KO = 1,KLEVO
C outlier check: set flag for interface routine and value
                 IF (PO(KO).LT.PI(1) .OR. PO(KO).GT.PILOW ) THEN
C must be outside input pressure range
                     IF (INTFLG.EQ.0) THEN
C default is to set to xmsg
                         MSGFLG       = -1
                         XO(ML,NL,KO) = XMSG
                     ELSEIF (INTFLG.EQ.1) THEN
C set to nearest input value
                         IF (PO(KO).LT.PI(1)) THEN
                             XO(ML,NL,KO) = XI(ML,NL,1)
                         ELSEIF (PO(KO).GT.PILOW) THEN
                             XO(ML,NL,KO) = XI(ML,NL,KLEVI)
                         END IF
                     END IF
                 ELSE
C This was the original code
                     DO KI = 1,KLEVI-1
                        IF ((PO(KO).GE.PI(KI) .AND.
     +                       PO(KO).LT.PI(KI+1)))THEN
                             XO(ML,NL,KO) = XI(ML,NL,KI) +
     +                                  (XI(ML,NL,KI+1)-XI(ML,NL,KI))*
     +                                  (DLOG(PO(KO))-DLOG(PI(KI)))/
     +                                  (DLOG(PI(KI+1))-DLOG(PI(KI)))
                             GO TO 20
                        END IF
                     END DO
                 END IF
   20            CONTINUE
              END DO

          END DO
      END DO

      RETURN
      END


!================================================================
!================================================================
!================================================================
!================================================================
subroutine condinit(x,u,dx,nn)
  use amr_parameters
  use hydro_parameters
  use poisson_parameters
  implicit none
  integer ::nn                            ! Number of cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:nvar)::u ! Conservative variables
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates initial conditions for RAMSES.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! U is the conservative variable vector. Conventions are here:
  ! U(i,1): d, U(i,2:ndim+1): d.u,d.v,d.w and U(i,ndim+2): E.
  ! Q is the primitive variable vector. Conventions are here:
  ! Q(i,1): d, Q(i,2:ndim+1):u,v,w and Q(i,ndim+2): P.
  ! If nvar >= ndim+3, remaining variables are treated as passive
  ! scalars in the hydro solver.
  ! U(:,:) and Q(:,:) are in user units.
  !================================================================
  integer::i,j,id,iu,iv,iw,ip
  real(dp)::x0,lambday,ky,lambdaz,kz,rho1,rho2,p0,v0,v1,v2
  integer::ivar
  real(dp),dimension(1:nvector,1:nvar),save::q   ! Primitive variables

  id=1; iu=2; iv=3; iw=4; ip=ndim+2
  x0=x_center(1)
  lambday=0.25
  ky=2.*acos(-1.0d0)/lambday
  lambdaz=0.25
  kz=2.*acos(-1.0d0)/lambdaz
  rho1=d_region(1)
  rho2=d_region(2)
  v1=v_region(1)
  v2=v_region(2)
  v0=0.1
  p0=10.

  do i=1,nn
     if(x(i,1) < x0)then
        q(i,id)=rho1
        q(i,iu)=0.0
        if(ndim>1)q(i,iu)=v0*cos(ky*(x(i,2)-lambday/2.))*exp(+ky*(x(i,1)-x0))
        if(ndim>1)q(i,iv)=v1
        if(ndim>2)q(i,iw)=0.0D0
        q(i,ip)=p0+rho1*gravity_params(1)*x(i,1)
     else
        q(i,id)=rho2
        q(i,iu)=0.0
        if(ndim>1)q(i,iu)=v0*cos(ky*(x(i,2)-lambday/2.))*exp(-ky*(x(i,1)-x0))
        if(ndim>1)q(i,iv)=v2
        if(ndim>2)q(i,iw)=0.0D0
        q(i,ip)=p0+rho1*gravity_params(1)*x0+rho2*gravity_params(1)*(x(i,1)-x0)
     endif
  end do

  ! Convert primitive to conservative variables
  ! density -> density
  u(1:nn,1)=q(1:nn,1)
  ! velocity -> momentum
  u(1:nn,2)=q(1:nn,1)*q(1:nn,2)
#if NDIM>1
  u(1:nn,3)=q(1:nn,1)*q(1:nn,3)
#endif
#if NDIM>2
  u(1:nn,4)=q(1:nn,1)*q(1:nn,4)
#endif
  ! kinetic energy
  u(1:nn,ndim+2)=0.0d0
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,2)**2
#if NDIM>1
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,3)**2
#endif
#if NDIM>2
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,4)**2
#endif
  ! pressure -> total fluid energy
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+q(1:nn,ndim+2)/(gamma-1.0d0)
  ! passive scalars
  do ivar=ndim+3,nvar
     u(1:nn,ivar)=q(1:nn,1)*q(1:nn,ivar)
  end do

end subroutine condinit


      program watbug

      dimension T(481),P(481),PE(481),APE(481),D(481),MON(481),LABEL(18),
     1          DAYS(13),H(481),AE(481),ST(481),DST(481),DEF(481),
     2          SUR(481),DY(481)

      data DAYS/0.0,31.0,28.0,31.0,30.0,31.0,30.0,31.0,31.0,30.0,31.0,
     1          30.0,31.0/

      real LAT,INDEX

c
c     ********************************************************************
c     *                                                                  *
c     *  This algorithm was developed by C. Willmott at the Department   *
c     *  of Geography, University of Delaware in 1978 in order to        *
c     *  facilitate the calculation of climatic water budgets.  A        *
c     *  minimum amount of data (i.e. air temperature, precipitation     *
c     *  and a few initial parameters) and no "look up" tables are       *
c     *  required as all relationships are explicitly specified.  The    *
c     *  program was refined on a Burroughs' B7700 although standard     *
c     * (ANSI compatible) Fortran was used. It should, therefore, run    *
c     * with few or no modifications on most moderate to large sized     *
c     * machines.  If problems are encountered, however, users are       *
c     * urged to contact the author.                                     *
c     *                                                                  *
c     ********************************************************************
c
c     Initial parameters:
c
c     'LABEL'  72 character alphanumeric problem title.
c
c     'N'      Total number of months or days over which soil moisture
c              balancing is to occur.  If N equals '1', balancing
c              does not occur ans ST(1) must be specified.
c
c     'NT'     Total number of months or days over which the water budget
c              is to be calculated.
c
c     'KD'     The day of the month where the first calculations
c              are to begin. KD must be less than or equal
c              to the number of days in month KM.
c
c     'KM'     The first month of calculations.
c              KM must be between 0 and 12.
c
c     'KY'     The first year of calculations. Last two digits only(!).
c
c     'FC'     Soil water holding or field capacity ot the top (only)
c              soil layer in millimeters.
c
c     'SM'     Determines a resistance function of soil water to removal
c              by evapotranspiration.  Blank or 0 indicates that the
c              availability of soil moisture to evapotranspiration will
c              decline linearly with the ratio of actual to potential
c              maximum soil moisture. Any other numeric designation
c              will result in an alternative procedure where moisture is
c              withdrawn at the maximum rate until the actual/potential
c              ratio drops below 0.7 at which time a linear decline in
c              availability is assumed (see Mather, 1974: 106 - curves
c              C and G).
c
c     'LAT'    The latitude in degrees.
c
c     'DT'     Time differential. Blank or 0 indicates monthly
c              calculations.  Any other number causes daily calculations.
c
c     'TUNIT'  Designates the units of air temperature. 1.0 means
c              the raw temperature data are in degrees Fahrenheit.
c              2.0 means degrees Kelvin. Any other numeric
c              designation or a blank means degrees Celsius.
c
c     'PUNIT'  Units of precipitation. 1.0 means the raw data
c              are in centimeters. 2.0 means inches. 3.0 means hundreths
c              of an inch. Other designations or blanks means millimeters.
c
c     'ST'     Estimated soil moisture content of the top soil
c              layer just prior to beginning of calculations.
c              ST only needs to be specified when balancing
c              is not to be done (see note below). ST(1) is in mm.
c
c     'HEAT'   Estimated heat index. It needs to be specified
c              only when soil moisture balancing does not occur.
c              (Note: balancing should only be specified for
c              periods containing one or more complete years of data).
c     'INDEX'  Should be set greater than zero when calculations
c              for a subsequent station are to follow these.  (Note:
c              control parameters and data must be included
c              sequentially in the input data set for each station
c              that is to be evaluated).
c
c     Read initial parameters:
c

   10 read(5,1000,end=20,err=20) LABEL,N,NT,KD,KM,KY,FC,SM,LAT,DT,
     1                           TUNIT,PUNIT,ST(1),HEAT,INDEX

      NNN = NNN + 1

c
c     Assumed parameter values (i.e. when they are not specified).
c

      if (N .eq. 0)  N = 1
      if (NT .eq. 0)  NT = N
      if ((KD .eq. 0) .and. (DT .ne. 0.0))  KD = 1
      if ((KD .eq. 0) .and. (DT .eq. 0.0))  KD = 15
      if (KM .eq. 0)  KM = 1

c
c     Set array sizes for calculating a soil water balance
c

      M = N + 1

c
c     Call the main subprogram which controls all calculations
c

      call main(N,NT,M,FC,LAT,KD,KM,KY,DT,DY,HEAT,SM,T,P,PE,APE,D,
     1          DAYS,H,AE,ST,DST,DEF,SUR,MON,LABEL,TUNIT,PUNIT)

c
c     Test to see if subsequent stations are to be evaluated.
c

      if (INDEX .GT. 0.0)  go to 10

   20 continue
      stop
 1000 format(18A4,/,5I5,9F5.0)

      end program watbug

c*************************************************************************

      subroutine main(N,NT,M,FC,LAT,KD,KM,KY,DT,DY,HEAT,SM,T,P,PE,APE,D,
     1                DAYS,H,AE,ST,DST,DEF,SUR,MON,LABEL,TUNIT,PUNIT)

      real LAT,T(M),P(M),PE(M),APE(M),D(M),DAYS(13),H(M),DY(M),AE(M),
     1     ST(M),DST(M),DEF(M),SUR(M),MON(M),FMT(18),LABEL(18)
      dimension OUT(10),SUMM(5),SUMY(5)
      integer IND(5) /3,4,8,9,10/

c
c     Read the data format (FMT).
c

      read(5,1000)  FMT
      NNN = 0

c
c     Unit correction factors
c

      C1 = 1.0
      C2 = 1.0
      FK = 0.0
      if (TUNIT .eq. 1.0)  FK = 32
      if (TUNIT .eq. 1.0)  C1 = 5.0/9.0
      if (TUNIT .eq. 2.0)  FK = 273.16
      if (PUNIT .eq. 1.0)  C2 = 10.0
      if (PUNIT .eq. 2.0)  C2 = 25.4
      if (PUNIT .eq. 3.0)  C2 = 0.254

c
c     Read air temperature and precipitation data
c
      do 10 I=1,N
        read(5,FMT,end=290,err=280)  T(I),P(I)
        NNN = NNN + 1
c
c     Unit translations
c
        T(I) = C1 * (T(I) - FK)
        P(I) = C2 * P(I)

   10 continue

c
c     Original code has a Y2K problem
c
      KY = KY + 1900

c
c     Test for daily, monthly, day by day or month by month budgeting
c

      if ((DT .ne. 0.0) .and. (N .eq. 1))  go to 70
      if ((DT .ne. 0.0) .and. (N .eq. 1)) go to 20
      if (DT .ne. 0.0)  go to 60

c***
c***  Here for monthly balancing
c***

      call date(N,M,KD,KM,DY,MON,DT,DAYS)
      call mather(N,M,H,T,HEAT,A,PE,APE,DAYS,LAT,DL,KD,KM,DT,MON,DY)
      call diff(N,M,P,APE,D,DEF)
      call bal(N,M,ST,D,FC,SM,SUR,DST,DT,DAYS,KM)
      call evapo(N,M,D,AE,APE,P,DST,DEF)

c
c     Write monthly input data and results
c
   20 continue

      write(6,1010) LABEL
      write(6,1020) N,NT,FC,LAT

      if (N .eq. 1) go to 130

      I = 1
      go to 40
   30 continue
      call conv(SUMY,5,1,5)
      write(6,1030)  SUMY
   40 call init(SUMY,5)
      write(6,1040)  KY

      KY = KY + 1
      write(6,1050)
   50 I = I + 1

c
c     Round off to nearest whole number and get totals before writing
c

      call output(PE,APE,P,D,ST,DST,AE,DEF,SUR,M,OUT,I)
      call toty(OUT,10,IND,SUMY,5)
      call conv(OUT,10,2,10)
      OUT(1)=T(I)

      write(6,1060)  MON(I),OUT
      if ((I .lt. N) .and. (MON(I) .eq. 12)) go to 30
      if ((I .eq. N) .and. (NT .gt. N)) go to 130
      if (I .eq. N) go to 290
      go to 50

   60 continue

c***
c*** Here for daily balancing
c***
      call date(N,M,KD,KM,DY,MON,DT,DAYS)
      call mather(N,M,H,T,HEAT,A,PE,APE,DAYS,LAT,DL,KD,KM,DT,MON,DY)
      call diff(N,M,P,APE,D,DEF)
      call bal(N,M,ST,D,FC,SM,SUR,DST,DT,DAYS,KM)
      call evapo(N,M,D,AE,APE,P,DST,DEF)

c
c     Write daily input data and results.
c
   70 continue

      write(6,1010) LABEL
      write(6,1070) N,NT,FC,LAT

      if (N .eq. 1) go to 190

      I = 0
      go to 90
   80 continue
      call conv(SUMM,5,1,5)
      call conv(SUMY,5,1,5)

      write(6,1080) SUMM
      write(6,1030) SUMY

   90 call init(SUMY,5)
      write(6,1040)  KY
      KY = KY + 1
      go to 110
  100 continue
      call conv(SUMM,5,1,5)
      write(6,1080)  SUMM
  110 call init(SUMM,5)
      write(6,1090)  MON(I+1)
      write(6,1100)
  120 I = I + 1
      KD = DY(I)
      KM = MON(I)

c
c     Round off to nearest whole numbers and get totals before writing.
c

      call output(PE,APE,P,D,ST,DST,AE,DEF,SUR,M,OUT,I)
      call totm(OUT,10,IND,SUMM,5)
      call toty(OUT,10,IND,SUMY,5)
      call conv(OUT,10,2,10)

      OUT(1) = T(I)

      write(6,1060) KD,OUT
      if ((I .lt. N) .and. (MON(I) .eq.12) .and. (DY(I) .eq. DAYS(KM + 1))) go to 80
      if ((I .lt. N) .and. (DY(I) .eq. DAYS(KM + 1))) go to 100
      if ((I .eq. N) .and. (NT .le. N)) go to 290
      if (I .eq. N) go to 190
      go to 120

c***
c***  Here for month-by-month calculations.
c***

  130 continue
      N1 = 0
      if (N .gt. 1)  N1 = 1

c
c     Get the initial soil moisture, month and day.
c

      if (N .gt. 1)  ST(1) = ST(N)
      KD = 15
      if (N .gt. 1)  KM = MON(N) + 1
      if (KM .ge. 13)  KM = 1
      DY(1) = KD
      MON(1) = KM

c
c     Set initial parameters.
c

      NN = NT - N
      if (N .eq. 1)  NN = NT
      if (NNN .eq. 1)  NNN = 0
      N = 1
      LL = 0
      M = N + 1

c
c     Test for appropriate labels.
c

      if (NNN .eq. 0)  go to 150
      if ((KM .gt. 1) .and. (N1 .eq. 1)) go to 170
      if (KM .gt. 1)  go to 160

  140 continue

c
c     Write labels, year, and last years totals.
c

      call conv(SUMY,5,1,5)
      write(6,1030)  SUMY
  150 call init(SUMY,5)
      write(6,1040)  KY
      KY = KY + 1
  160 continue
      write(6,1050)

c
c     Read input data and call budget subroutines.
c

  170 LL = LL + 1
      if (NNN .eq. 0)  go to 180
      read(5,FMT,end=290,err=280)  T(N),P(N)
      T(N) = C1 * (T(N) - FK)
      P(N) = C2 * P(N)
  180 NNN = NNN + 1

      call mather(N,M,H,T,HEAT,A,PE,APE,DAYS,LAT,DL,KD,KM,DT,MON,DY)
      call diff(N,M,P,APE,D,DEF)
      D(N + 1) = D(N)
      call bal(N,M,ST,D,FC,SM,SUR,DST,DT,DAYS,KM)
      ST(N) = ST(N + 1)
      SUR(N) = SUR(N + 1)
      DST(N) = DST(N + 1)
      call evapo(N,M,D,AE,APE,P,DST,DEF)

c
c     Round off to nearest whole number and get totals before writing.
c

      call output(PE,APE,P,D,ST,DST,AE,DEF,SUR,M,OUT,N)
      call toty(OUT,10,IND,SUMY,5)
      call conv(OUT,10,2,10)
      OUT(1) = T(N)

c
c     Write results and get next month.
c

      write(6,1060)  KM,OUT
      call date(N,M,KD,KM,DY,MON,DT,DAYS)

      if (NN .eq. LL)  go to 290
      if (KM .eq. 1)  go to 140
      go to 170

c***
c***  Here for day-by-day calculations.
c***

  190 continue
      N1 = 0
      if (N .gt. 1)  N1 = 1

c
c     Get the initial soil moisture, month, and day.
c

      if (N .gt. 1)  ST(1) = ST(N)
      if (N .gt. 1)  KD = DY(N) + 1
      if (N .gt. 1)  KM = MON(N)
      if (KD .gt. DAYS(KM + 1))  go to 200
      DY(1) = KD
      MON(1) = KM
      go to 210
  200 continue
      KM = KM + 1
      KD = 1
      if (KM .ge. 13)  KM = 1
      DY(1) = KD
      MON(1) = KM

  210 continue

c
c     Initialize parameters.
c

      NN = NT - N
      if (N .eq. 1)  NN = NT
      if (NNN .eq. 1)   NNN = 0
      N = 1
      L = 0
      M = N + 1

c
c     Test for appropriate labels.
c
      if (NNN .eq. 0) go to 230
      if ((KD .ne. 1) .and. (KM .ne. 1) .and. (N1 .eq.1))  go to 260
      if ((KD .ne. 1) .or. (KM .ne. 1)) go to 240

  220 continue

c
c     Write labels, the year, month, and last years or months totals.
c

      call conv(SUMM,5,1,5)
      call conv(SUMY,5,1,5)
      write(6,1080) SUMM
      write(6,1030)  SUMY
  230 call init(SUMY,5)
      write(6,1040)  KY
      KY = KY + 1
      go to 250
  240 continue
      call conv(SUMM,5,1,5)
      write(6,1080)  SUMM
  250 call init(SUMM,5)
      write(6,1090)  KM
      write(6,1100)

c
c     Read input data and call budget subroutines.
c

  260 L = L + 1
      if (NNN .eq. 0)  go to 270
      read(5,FMT,end=290,err=280)  T(N),P(N)
      T(N) = C1 * (T(N) - FK)
      P(N) = C2 * P(N)
  270 NNN = NNN + 1

      call mather(N,M,H,T,HEAT,A,PE,APE,DAYS,LAT,DL,KD,KM,DT,MON,DY)
      call diff(N,M,P,APE,D,DEF)
      D(N + 1) = D(N)
      call bal(N,M,ST,D,FC,SM,SUR,DST,DT,DAYS,KM)
      ST(N) = ST(N+1)
      SUR(N) = SUR(N+1)
      DST(N) = DST(N+1)
      call evapo(N,M,D,AE,APE,P,DST,DEF)

c
c     Round off to nearest whole number and get totals before writing.
c

      call output(PE,APE,P,D,ST,DST,AE,DEF,SUR,M,OUT,N)
      call totm(OUT,10,IND,SUMM,5)
      call toty(OUT,10,IND,SUMY,5)
      call conv(OUT,10,2,10)
      OUT(1) = T(N)

c
c     Write results and get a new date.
c

      write(6,1060)  KD,OUT
      call date(N,M,KD,KM,DY,MON,DT,DAYS)

      if (NN .eq. L)  go to 290
      if ((KM .eq. 1) .and. (KD .eq. 1)) go to 220
      if (KD .eq. 1) go to 240
      go to 260

c
c     Write final messages and totals.
c

  280 continue
      write(6,1110)  NNN + 1
      go to 300

  290 continue
      if (DT .ne. 0.0)  write(6,1080)  SUMM
      write(6,1030)  SUMY
      write(6,1120)  NNN

  300 continue
      write(6,1130)

      return

 1000 format (18A4)
 1010 format ('0',18A4)
 1020 format (//,'  No. of months over which balancing occurs is ',I5,//,
     1 '  Total No. of months evaluated is ',I5,//,
     2 '  Soil moisture capacity is ',F5.1,' mm ',//,
     3 '  Latitude is ',F4.1)

 1030 format (/,'  Yearly totals',3X,2I6,18X,3I6)
 1040 format (///,'  Year is ', I4)
 1050 format (//,'  MO     TEMP    UPE    APE   PREC   DIFF     ST    DST     AE',
     1        '    DEF   SURP',/)
 1060 format (I4,2X,F6.1,9I6)
 1070 format (//,'   No. of days over which balancing occurs is ',I5,//,
     1        '   Total No. of days evaluated is ',I5,//,
     2        '   Soil moisture capacity is ',F5.1,' mm ',//,
     3        '   Latitude is ',F4.1)
 1080 format (/,'   Monthly totals',2X,2I6,18X,3I6)
 1090 format (//,'   Month is ',I2)
 1100 format (//,'   DY     TEMP    UPE    APE   PREC   DIFF     ST    DST     AE',
     1        '    DEF   SURP',/)
 1110 format (///,'   Error encountered in the data at record ',I5)
 1120 format (///,'   Processing terminated after record ',I5)
 1130 format ('1')
      end subroutine main

c*************************************************************************
      subroutine date(N,M,KD,KM,DY,MON,DT,DAYS)

        real DY(M),MON(M),DAYS(13)

c
c       Generate day and month designations.
c
c       Test for monthly, daily, month-by-month, or day-by-day calculations.
c

        if ((DT .ne. 0.0) .and. (N .eq. 1))  go to 60
        if ((DT .eq. 0.0) .and. (N .eq. 1))  go to 50
        if (DT .ne. 0.0)  go to 20

c
c       Monthly calculations.
c

        KD = 15
        KM = KM - 1
        if (KM .le. 0)  KM = 0
        do 10 I=1,N
            KM = KM + 1
            if (KM .ge. 13)  KM = 1
            MON(I) = KM
            DY(I) = KD
  10    continue
        go to 80

c
c       Daily calculations.
c

  20    continue
        K = 1
        KD = KD - 1
        if (KD .le. 0)  KD = 0
        if (KD .gt. 0)  K = KD
        KM = KM - 1
        if (KM .le. 0)  KM = 0
        J = 0
  30    KM = KM + 1
        if (KD .gt. DAYS(KM+1))  KD = 1
        if (KM .ge. 13)  KM = 1
        do 40 I=K,DAYS(KM+1)
            J = J + 1
            MON(J) = KM
            DY(J) = I
  40    continue
        if (J .ge. N)  go to 80
        K = 1
        go to 30

c
c       Month-by-month calculations.
c

  50    continue
        KD = 15
        KM = KM + 1
        if (KM .ge. 13)  KM = 1
        DY(N) = KD
        MON(N) = KM
        go to 80

c
c       Day-by-day calculations.
c

  60    continue
        KD = KD + 1
        DY(N) = KD
        MON(N) = KM
        if (KD .gt. DAYS(KM+1))  go to 70
        go to 80

  70    continue
        KM = KM + 1
        KD = 1
        if (KM .ge. 13)  KM = 1
        DY(N) = KD
        MON(N) = KM

  80   continue
       return

      end subroutine date

c*************************************************************************
      subroutine mather(N,M,H,T,HEAT,A,PE,APE,DAYS,LAT,DL,KD,KM,DT,MON,DY)

        real LAT,H(M),T(M),PE(M),APE(M),DAYS(13),MON(M),DY(M)

c
c       Calculate potential evapotranspiration.
c
c       When 'LAT' is greater than 50 degrees, the daylength correction
c       remains equal to that for 50 degs. 'ALAT' is, therefore,
c       used as the argument for subrouting 'day'.
c

        ALAT = LAT
        if (ALAT .ge. 50.0)  ALAT = 50.0

c
c       Calculate the heat index during balancing on the first call
c       of 'mather'. On the second call, go directly to 'PE' calculations.
c

        if (N .lt. 12)  go to 40
        if ((N .lt. 365) .and. (DT .ne. 0.0)) go to 40

        XN = N
        HEAT = 0.0
        do 30 I=1,N
            if (T(I) .le. 0.0)  go to 10
            H(I) = (T(I) / 5.0) ** 1.514
            go to 20
  10        H(I) = 0.0
  20        continue
            HEAT = HEAT + H(I)
  30    continue

c
c       Adjust 'HEAT' for budgets greater than a year.
c

        HEAT = HEAT * 12.0 / XN

c
c       Note: 'A' is an empirically derived exponent based upon 'HEAT'
c

  40    continue
        A = 6.75 / 10.0**7.0 * HEAT**3.0
     1      - 7.71 / 10.0**5.0 * HEAT**2.0
     2      + 1.79 / 10.0**2.0 * HEAT
     3      + 0.49

c
c       Get initial monthly PE, I.E. based upon 30 days in
c       a month and 12 hours in a day
c       Note: PE(I) and APE(I) are calculated in mm / month or day.
c

        do 70 I=1,N
            if (T(I) .le. 0.0)  go to 50
            PE(I) = 16.0 * (10.0 * T(I) / HEAT)**A

c
c           Correct for temperatures greater than 26.5 deg C.
c           See Thornthwaite (1948) for explanation.
c

            if (T(I) .ge. 26.5)  PE(I) = (-41.58547 + 3.22441 * T(I)
     1                                   -0.04325 * T(I)**2.0) * 10.0

c
c           Correct PE(I) for daily calculations.
c

            if (DT .ne. 0.0)  PE(I) = PE(I) / 30.0
            go to 60
   50       PE(I) = 0.0
   60       continue
            KD = DY(I)
            KM = MON(I)

c
c           Adjust PE for daylength and the number of days in a month.
c

            call day(DAYS,ALAT,KD,KM,DT,DECD,DL)
            APE(I) = PE(I) * (DAYS(KM+1) / 30.0) * (DL / 12.0)

  70        continue
            return
      end subroutine mather

c*************************************************************************
      subroutine day(DAYS,LAT,KD,KM,DT,DECD,DL)

        real DAYS(13)
        real LAT

c
c       Calculate the number of hours in a
c       day and the solar declination associated with that
c       day.  The input required includes: the month (KM),
c       the dat (KD) and the latitude (LAT).
c

        X = 0.0
        do 10  I=1,KM
            X = X + DAYS(I)
   10   continue
        SUM = X + KD

c
c       Get the number of days since the vernal equinox (March 21).
c

        DAYL = SUM - 80.0
        if (DAYL .le. 0.0)  DAYL = 285.0 + SUM

c
c       Calculate the declination.
c

        DECD = 23.45 * sin(DAYL / 365.0 * 6.2832)
        DECR = DECD * 0.017453

c
c       Calculate number of hours of daylight corresponding to
c       day (KD) and month (KM) (see Sellers, 1965).
c

        CZ = cos(1.5708 + 0.01745 * (100.0 / 60.0))
        ALAT = LAT * 0.017453
        XX = cos(DECR) * cos(ALAT)
        if (XX .le. 0.0)  go to 20

        CSH = (CZ - sin(DECR) * sin(ALAT)) / XX
        H = acos(CSH)
        DL = 24.0 * H / 3.1416
        go to 30

c
c       Error message - divide by zero or less.
c

   20   write(6,1000)

   30   continue
        return
 1000   format ('0', ' Error - divide by zero or less - lat. ',//,
     1          '   or the declination is probably incorrect ')

      end subroutine day

c*************************************************************************
      subroutine diff(N,M,P,APE,D,DEF)

        real P(M),APE(M),D(M),DEF(M)

c
c       Compare APE(I) with precipitation (P(I)).
c

        do 10 I=1,N
            D(I) = P(I) - APE(I)
            DEF(I) = 0.0
            if (D(I) .lt. 0.0)  DEF(I) = D(I)
  10    continue
        return

      end subroutine diff

c*************************************************************************
      subroutine bal(N,M,ST,D,FC,SM,SUR,DST,DT,DAYS,KM)

        real ST(M),D(M),SUR(M),DST(M),DAYS(13)

c
c       Iterate for soil moisture terms that balance
c       the water budget on the first call of 'bal'. On a second call
c       and/or when N is '1', 'bal' does month-by-month or day-by-day
c       soil moisture calculations.
c

        if (N .eq. 1)  go to 10

        ST(N+1) = 0.0
        ST(1) = 300.0
        DST(1) = 0.0
        K = 0
        Z = 0.0
   10   continue

        do 80 I=2,N+1
            if (D(I) .ge. 0.0)  go to 50

c
c           Test for monthly or daily withdrawal.
c

            if (DT .ne. 0.0)  go to 30

c
c           Withdrawal for monthly budgets (Note: this is done on
c           an approximate day-by-day basis).
c

            X1 = ST(I - 1)
            do 20 J=1,30
                RATIO = ST(I-1) / FC
                ST(I) = ST(I-1) + D(I) * RATIO / 30.0
                if ((RATIO .ge. 0.7) .and. (SM .gt. 0.0))  ST(I) = ST(I-1) + D(I) / 30.0
                ST(I-1) = ST(I)
   20       continue
            ST(I-1) = X1
            go to 40
   30       continue

c
c           Withdrawal for daily budgets.
c

            ST(I) = ST(I-1) + ST(I-1) / FC * D(I)
            if ((ST(I-1) / FC .ge. 0.7) .and. (SM .gt. 0.0))  ST(I) = ST(I-1) + D(I)

  40        continue
            if (ST(I) .le. 1.0)  ST(I) = 1.0
            go to 70

  50        continue
            ST(I) = ST(I-1) + D(I)
            if (ST(I) .ge. FC)  go to 60
            SUR(I) = 0.0
            go to 70

  60        continue
            SUR(I) = ST(I) - FC
            ST(I) = FC

  70        continue
            DST(I) = ST(I) - ST(I-1)
            if (D(I) .le. 0.0)  SUR(I) = 0.0

  80        continue

            if (N .eq. 1)  go to 160

            K = K + 1

c
c           Tests for balances.
c

            if (K .gt. 50) go to 160
            XX = abs(ST(N+1) + DST(1) - ST(1))
            if ((XX .lt. 1.0) .and. (Z .eq. 1.0))  go to 160
            if (XX .lt. 1.0)  go to 90
            ST(1) = ST(N+1) + DST(1)
            go to 10

  90        continue
            if (D(1) .ge. 0.0)  go to 130
            if (DT .ne. 0.0)  go to 110

c
c           Balance for the first month
c

            X2 = ST(N+1)
            do 100 L=1,30
                RATIO = ST(N+1) / FC
                ST(1) = ST(N+1) + D(1) * RATIO / 30.0
                if ((RATIO .ge. 0.7) .and. (SM .gt. 0.0))  ST(1) = ST(N+1) + D(1) / 30.0
                ST(N+1) = ST(1)
  100       continue
            ST(N+1) = X2
            go to 120
  110       continue

c
c           Balance for the first day.
c

            ST(1) = ST(N+1) + ST(N+1) / FC * D(1)
            if ((ST(N+1) / FC .ge. 0.7) .and. (SM .gt. 0.0))  ST(1) = ST(N+1) + D(1)

  120       continue
            if (ST(1) .le. 1.0)  ST(1) = 1.0
            go to 150

  130       continue
            ST(1) = ST(N+1) + D(1)
            if (ST(1) .ge. FC)  go to 140
            SUR(1) = 0.0
            go to 150

  140       SUR(1) = ST(1) - FC
            ST(1) = FC

  150       continue
            DST(1) = ST(1) - ST(N+1)
            if (D(1) .le. 0.0)  SUR(1) = 0.0
            Z = 1.0
            go to 10

  160       continue

            return

      end subroutine bal

c*************************************************************************
      subroutine evapo(N,M,D,AE,APE,P,DST,DEF)

        real D(M),AE(M),APE(M),P(M),DST(M),DEF(M)

c
c       Calculate actual evapotranspiration and deficit.
c

        do 10 I=1,N
            AE(I) = APE(I)
            if (D(I) .lt. 0.0)  AE(I) = P(I) + abs(DST(I))
            DEF(I) = APE(I) - AE(I)

  10    continue

        return

      end subroutine evapo

c*************************************************************************
      subroutine init(SUM,N)

        dimension SUM(N)

c
c       Initialize array 'SUM' with zeroes.
c

        I = 0
   10   I = I + 1
        SUM(I) = 0.0
        if (I .lt. N)  go to 10

        return

      end subroutine init

c*************************************************************************
      subroutine output(PE,APE,P,D,ST,DST,AE,DEF,SUR,M,OUT,L)

        dimension PE(M),APE(M),P(M),D(M),ST(M),DST(M),AE(M),DEF(M),SUR(M),
     1            OUT(10)

c
c       Fill the output array 'OUT'.
c

        OUT(2) = PE(L)
        OUT(3) = APE(L)
        OUT(4) = P(L)
        OUT(5) = D(L)
        OUT(6) = ST(L)
        OUT(7) = DST(L)
        OUT(8) = AE(L)
        OUT(9) = DEF(L)
        OUT(10) = SUR(L)

        return

      end subroutine output

c*************************************************************************
      subroutine totm(X,N,IND,SUM,NN)

        dimension SUM(NN),IND(NN),X(N)

c
c       Sum values of 'X' specified by 'IND' over the month.
c

        I = 0
   10   I = I + 1
        J = IND(I)
        SUM(I) = SUM(I) + X(J)
        if (I .lt. NN)  go to 10

        return

      end subroutine totm

c*************************************************************************
      subroutine toty(X,N,IND,SUM,NN)

        dimension SUM(NN),IND(NN),X(N)

c
c       Sum values of 'X' specified by 'IND' over the year.
c

        I = 0
 10     I = I + 1
        J = IND(I)
        SUM(I) = SUM(I) + X(J)
        if (I .lt. NN)  go to 10

        return

      end subroutine toty

c*************************************************************************
      subroutine conv(X,NUM,MIN,MAX)

        dimension X(NUM)

c
c       Round X(I) to nearest whole number.
c

        I = MIN - 1
   10   I = I + 1
        if (X(I) .eq. 0.0)  go to 20
        Y = abs(X(I))
        J = X(I) / Y
        K = Y + 0.5
        X(I) = K * J
   20   if (I .lt. MAX) go to 10

        return
      end subroutine conv


! THIS VERSION: GALAHAD 2.2 - 23/04/2008 AT 16:30 GMT.
   PROGRAM GALAHAD_QPC_EXAMPLE
   USE GALAHAD_QPC_double         ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
   TYPE ( QPT_problem_type ) :: p
   TYPE ( QPC_data_type ) :: data
   TYPE ( QPC_control_type ) :: control
   TYPE ( QPC_inform_type ) :: info
   INTEGER :: s
   INTEGER, PARAMETER :: n = 3, m = 2, h_ne = 4, a_ne = 4
   INTEGER, ALLOCATABLE, DIMENSION( : ) :: C_stat, B_stat
! start problem data
   ALLOCATE( p%G( n ), p%X_l( n ), p%X_u( n ) )
   ALLOCATE( p%C( m ), p%C_l( m ), p%C_u( m ) )
   ALLOCATE( p%X( n ), p%Y( m ), p%Z( n ) )
   ALLOCATE( B_stat( n ), C_stat( m ) )
   p%new_problem_structure = .TRUE.           ! new structure
   p%n = n ; p%m = m ; p%f = 1.0_wp           ! dimensions & objective constant
   p%G = (/ 0.0_wp, 2.0_wp, 0.0_wp /)         ! objective gradient
   p%C_l = (/ 1.0_wp, 2.0_wp /)               ! constraint lower bound
   p%C_u = (/ 2.0_wp, 2.0_wp /)               ! constraint upper bound
   p%X_l = (/ - 1.0_wp, - infinity, - infinity /) ! variable lower bound
   p%X_u = (/ 1.0_wp, infinity, 2.0_wp /)     ! variable upper bound
   p%X = 0.0_wp ; p%Y = 0.0_wp ; p%Z = 0.0_wp ! start from zero
!  sparse co-ordinate storage format
   CALL SMT_put( p%H%type, 'COORDINATE', s )     ! Specify co-ordinate
   CALL SMT_put( p%A%type, 'COORDINATE', s )     ! storage for H and A
   ALLOCATE( p%H%val( h_ne ), p%H%row( h_ne ), p%H%col( h_ne ) )
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! Hessian H
   p%H%row = (/ 1, 2, 3, 3 /)                     ! NB lower triangle
   p%H%col = (/ 1, 2, 3, 1 /) ; p%H%ne = h_ne
   p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! Jacobian A
   p%A%row = (/ 1, 1, 2, 2 /)
   p%A%col = (/ 1, 2, 2, 3 /) ; p%A%ne = a_ne
! problem data complete
   CALL QPC_initialize( data, control )       ! Initialize control parameters
   control%infinity = infinity                ! Set infinity
   CALL QPC_solve( p,  C_stat, B_stat, data, control, info )    ! Solve problem
   IF ( info%status == 0 ) THEN               !  Successful return
     WRITE( 6, "( ' QPC: ', I0, ' QPA and ', I0, ' QPB iterations  ', /,       &
    &     ' Optimal objective value =',                                        &
    &       ES12.4, /, ' Optimal solution = ', ( 5ES12.4 ) )" )                &
     info%QPA_inform%iter, info%QPB_inform%iter, info%obj, p%X
   ELSE                                       !  Error returns
     WRITE( 6, "( ' QPC_solve exit status = ', I6 ) " ) info%status
   END IF
   CALL QPC_terminate( data, control, info )  !  delete internal workspace
   END PROGRAM GALAHAD_QPC_EXAMPLE


!==============================================================================!
  subroutine Turb_Mod_Vis_T_K_Eps(turb)
!------------------------------------------------------------------------------!
!   Computes the turbulent viscosity for RANS models.                          !
!                                                                              !
!   In the domain:                                                             !
!   For k-eps model :                                                          !
!                                                                              !
!   vis_t = c_mu * rho * k^2 * eps                                             !
!                                                                              !
!   On the boundary (wall viscosity):                                          !
!   vis_tw = y^+ * vis_t kappa / (E * ln(y^+))                                 !
!                                                                              !
!   For k-eps-v2f model :                                                      !
!                                                                              !
!   vis_t = CmuD * rho * Tsc  * vv                                             !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type), target :: turb
!---------------------------------[Calling]------------------------------------!
  real :: Roughness_Coefficient
  real :: Tau_Wall_Low_Re
  real :: U_Plus_Log_Law
  real :: U_Plus_Rough_Walls
  real :: Y_Plus_Low_Re
  real :: Y_Plus_Rough_Walls
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type), pointer :: flow
  type(Grid_Type),  pointer :: grid
  type(Var_Type),   pointer :: u, v, w
  type(Var_Type),   pointer :: kin, eps
  integer                   :: c1, c2, s, c
  real                      :: pr, beta, ebf, sc
  real                      :: u_tan, u_tau
  real                      :: kin_vis, u_plus, y_star, re_t, f_mu
  real                      :: z_o
!==============================================================================!
!   Dimensions:                                                                !
!                                                                              !
!   production    p_kin    [m^2/s^3]   | rate-of-strain  shear    [1/s]        !
!   dissipation   eps % n  [m^2/s^3]   | turb. visc.     vis_t    [kg/(m*s)]   !
!   wall shear s. tau_wall [kg/(m*s^2)]| dyn visc.       viscosity[kg/(m*s)]   !
!   density       density  [kg/m^3]    | turb. kin en.   kin % n  [m^2/s^2]    !
!   cell volume   vol      [m^3]       | length          lf       [m]          !
!   left hand s.  A        [kg/s]      | right hand s.   b        [kg*m^2/s^3] !
!   wall visc.    vis_w    [kg/(m*s)]  | kinematic viscosity      [m^2/s]      !
!   thermal cap.  capacity[m^2/(s^2*K)]| therm. conductivity     [kg*m/(s^3*K)]!
!------------------------------------------------------------------------------!
!   p_kin = 2*vis_t / density S_ij S_ij                                        !
!   shear = sqrt(2 S_ij S_ij)                                                  !
!------------------------------------------------------------------------------!

  ! Take aliases
  flow => turb % pnt_flow
  grid => flow % pnt_grid
  call Field_Mod_Alias_Momentum(flow, u, v, w)
  call Turb_Mod_Alias_K_Eps    (turb, kin, eps)

  do c = 1, grid % n_cells

    ! Kinematic viscosities
    kin_vis = flow % viscosity(c) / flow % density(c)

    re_t =  flow % density(c) * kin % n(c)**2  &
         / (flow % viscosity(c) * eps % n(c))

    y_star = (kin_vis * eps % n(c))**0.25 * grid % wall_dist(c)/kin_vis

    f_mu = (1.0 -     exp(-y_star/14.0))**2   &
         * (1.0 + 5.0*exp(-(re_t/200.0) * (re_t/200.0) ) /re_t**0.75)

    f_mu = min(1.0,f_mu)

    turb % vis_t(c) = min(f_mu * c_mu * flow % density(c) * kin % n(c)**2  &
                    / (eps % n(c) + TINY), 0.6*kin % n(c)                  &
                    / (sqrt(6.0)*c_mu*flow % shear(c) + TINY))
  end do

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 < 0) then
      if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL .or.  &
         Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALLFL) then

        u_tan = Field_Mod_U_Tan(flow, s)

        u_tau = c_mu25 * sqrt(kin % n(c1))
        turb % y_plus(c1) = Y_Plus_Low_Re(turb,                  &
                                          u_tau,                 &
                                          grid % wall_dist(c1),  &
                                          kin_vis)

        turb % tau_wall(c1) = Tau_Wall_Low_Re(turb,               &
                                              flow % density(c1), &
                                              u_tau,              &
                                              u_tan,              &
                                              turb % y_plus(c1))

        ebf = Turb_Mod_Ebf_Momentum(turb, c1)

        u_plus = U_Plus_Log_Law(turb, turb % y_plus(c1))

        if(turb % y_plus(c1) < 3.0) then
          turb % vis_w(c1) = turb % vis_t(c1) + flow % viscosity(c1)
        else
          turb % vis_w(c1) =    turb % y_plus(c1) * flow % viscosity(c1)  &
                           / (  turb % y_plus(c1) * exp(-1.0 * ebf)      &
                              + u_plus * exp(-1.0/ebf) + TINY)
        end if

        turb % y_plus(c1) = Y_Plus_Low_Re(turb,                  &
                                          u_tau,                 &
                                          grid % wall_dist(c1),  &
                                          kin_vis)

        if(turb % rough_walls) then
          z_o = Roughness_Coefficient(turb, turb % z_o_f(c1))
          turb % y_plus(c1) = Y_Plus_Rough_Walls(turb,                  &
                                                 u_tau,                 &
                                                 grid % wall_dist(c1),  &
                                                 kin_vis)
          u_plus     = U_Plus_Rough_Walls(turb, grid % wall_dist(c1))
          turb % vis_w(c1) = turb % y_plus(c1) * flow % viscosity(c1) / u_plus
        end if

        if(heat_transfer) then
          pr   = Field_Mod_Prandtl_Number(flow, c1)
          pr_t = Turb_Mod_Prandtl_Number(turb, c1)
          beta = 9.24 * ((pr/pr_t)**0.75 - 1.0)  &
               * (1.0 + 0.28 * exp(-0.007*pr/pr_t))
          ebf = Turb_Mod_Ebf_Scalar(turb, c1, pr)
          turb % con_w(c1) =    turb % y_plus(c1)                         &
                              * flow % viscosity(c1)                      &
                              * flow % capacity(c1)                       &
                      / (  turb % y_plus(c1) * pr * exp(-1.0 * ebf)       &
                         + (u_plus + beta) * pr_t * exp(-1.0 / ebf) + TINY)
        end if

        if(flow % n_scalars > 0) then
          sc   = Field_Mod_Schmidt_Number(flow, c1)  ! laminar Schmidt number
          beta = 9.24 * ((sc/sc_t)**0.75 - 1.0)                 &
           * (1.0 + 0.28 * exp(-0.007*sc/sc_t))
          ebf = 0.01 * (sc * turb % y_plus(c1)**4               &
          / ((1.0 + 5.0 * sc**3 * turb % y_plus(c1)) + TINY))
          turb % diff_w(c1) =  turb % y_plus(c1)                &
              * (flow % viscosity(c1)/flow % density(c1)) &
              / (  turb % y_plus(c1) * sc * exp(-1.0 * ebf)     &
              + (u_plus + beta) * sc_t * exp(-1.0 / ebf) + TINY)
        end if

      end if  ! Grid_Mod_Bnd_Cond_Type(grid,c2).eq.WALL or WALLFL
    end if    ! c2 < 0
  end do

  call Grid_Mod_Exchange_Cells_Real(grid, turb % vis_t)
  call Grid_Mod_Exchange_Cells_Real(grid, turb % vis_w)
  if(heat_transfer) then
    call Grid_Mod_Exchange_Cells_Real(grid, turb % con_w)
  end if
  if(flow % n_scalars > 0) then
    call Grid_Mod_Exchange_Cells_Real(grid, turb % diff_w)
  end if

  end subroutine


!==============================================================================!
  subroutine Acm_Coarsen_Matrix(sol)
!------------------------------------------------------------------------------!
!   Coarsens system matrix for Additive Correction Multigrid method.           !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Solver_Type), target :: sol
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type),   pointer :: grid
  type(Matrix_Type), pointer :: a
  type(Matrix_Type), pointer :: a_lev(:)
  integer                    :: dia_11, dia_22, pos_12, pos_21
  integer                    :: s, c1, c2, lev, s_lev, c1_lev, c2_lev
  real                       :: a_12, a_21
!==============================================================================!

  grid  => sol % pnt_grid
  a     => sol % a
  a_lev => sol % a_lev

  !---------------------------------!
  !   Simply copy the first level   !
  !---------------------------------!
  a_lev(1) % val(:) = a % val(:)

  !--------------------------!
  !   Coarsen other levels   !
  !--------------------------!
  do lev = 2, grid % n_levels

    do s = 1, grid % level(1) % n_faces    ! go through finest faces

      s_lev = grid % level(lev) % face(s)  ! check if face expands to lev

      if(s_lev > 0) then

        ! Matrix entries in the finest level
        a_12 = a_lev(1) % val(a_lev(1) % pos(1, s))
        a_21 = a_lev(1) % val(a_lev(1) % pos(2, s))

        c1_lev = grid % level(lev) % faces_c(1, s_lev)   ! cell 1 at level lev
        c2_lev = grid % level(lev) % faces_c(2, s_lev)   ! cell 2 at level lev

        dia_11 = a_lev(lev) % dia(c1_lev)  ! cell position in the matrix
        dia_22 = a_lev(lev) % dia(c2_lev)  ! cell position in the matrix

        pos_12 = a_lev(lev) % pos(1, s_lev)  ! face position in the matrix
        pos_21 = a_lev(lev) % pos(2, s_lev)  ! face position in the matrix

        a_lev(lev) % val(dia_11) = a_lev(lev) % val(dia_11) - a_12
        a_lev(lev) % val(dia_22) = a_lev(lev) % val(dia_22) - a_21

        a_lev(lev) % val(pos_12) = a_lev(lev) % val(pos_12) + a_12
        a_lev(lev) % val(pos_21) = a_lev(lev) % val(pos_21) + a_21
      end if

    end do   ! face
  end do  ! level

  end subroutine


! =====================================================================
! subroutine VNL
!
! This subroutine constructs the nonlinear, mean-field interaction
! potential in the Gross-Pitaevskii equation.
! ---------------------------------------------------------------------
      subroutine VNL(nQQ,g,V,U)
      implicit none

      integer :: nQQ
      double precision :: g
      double precision :: V(nQQ)
      double complex :: U(nQQ)

      integer :: i

      do i = 1, nQQ
         V(i) = g*cdabs(U(i))**2
      enddo

      return
      end
! =====================================================================


program testbubblesort
        integer lst(10)
        lst = (/ 10, 9, 8, 4, 5, 6, 7, 3, 2, 1 /)
        call bubblesort(lst, 1, 10)
        call show(lst)
end program testbubblesort

subroutine bubblesort(lst, a, b)
        integer a
        integer b
        integer lst(10)
        integer x
        integer y
        integer tmp
        do x = a, b-1
            do y = a, b-x
                if (lst(y) .gt. lst(y+1)) then
                    tmp = lst(y)
                    lst(y) = lst(y+1)
                    lst(y+1) = tmp
                end if
            end do
        end do
end

subroutine show(lst)
        integer lst(10)
        integer x
        do x = 1, 10
                print 100, lst(x)
        end do

100 format (i0)
end


module data_struct

public

   ! floating point precision
   !integer, parameter :: dp = selected_real_kind(6, 37) ! 32-bit
   !integer, parameter :: dp = selected_real_kind(15, 307) ! 64-bit
   integer, parameter :: dp = selected_real_kind(33, 4931) ! 128-bit

   ! intel 3 vector csr format
   type dcsr3
      integer :: m ! number of rows
      double precision, allocatable :: val(:)
      integer, allocatable :: col(:)
      integer, allocatable :: rowind(:)
   end type

   type fis
      double precision :: val
      double precision :: dir(8)
   end type

   type Mrho
      double precision, allocatable :: eigval(:)
      double precision, allocatable :: eigvec(:,:)
   end type

   type rho
      type( Mrho ), allocatable :: array(:)
      real( kind = dp), allocatable :: weights(:)
   end type

contains

   subroutine EvenBounds( N, M, kmin, kmax )

      implicit none
      integer, intent(in) :: N, M
      integer, intent(out) :: kmin, kmax

      ! local variables
      real, dimension(3) :: btab

      btab = (/ 0.0, real(M)/2.0, -real(M)/2.0 /)
      kmin = ceiling( maxval( btab ) )

      btab = (/ real(N)/2.0, real(N)-real(M)/2.0, real(N)+real(M)/2.0 /)
      kmax = floor( minval( btab ) )

   end subroutine

   subroutine OddBounds( N, M, kmin, kmax )

      implicit none
      integer, intent(in) :: N, M
      integer, intent(out) :: kmin, kmax

      ! local variables
      real btab(3)

      btab = (/ 0.0, -real(M+1)/2.0, real(M-1)/2.0 /)
      kmin = ceiling( maxval( btab ) )

      btab = (/ real(N-1)/2.0, real(N)-real(M+1)/2.0, real(N)+real(M-1)/2.0 /)
      kmax = floor( minval( btab ) )

   end subroutine

end module


: BEGIN IMMEDIATE
    HERE @
;

: UNTIL IMMEDIATE
    ' 0BRANCH ,
    HERE @ -
    ,
;

\ print number
: PUTS 48 + EMIT 10 EMIT ;

\ print 9 down to 1
: MAIN
    10
    BEGIN
        1-
        DUP
        PUTS
    DUP 0= UNTIL
    DROP
;

MAIN