!@sum contains code related to 3 layers snow model
!@auth I.Aleinov
!@ver  1.0

#define DEBUG_SNOW

      MODULE SNOW_MODEL
!@sum SNOW_MODEL does column physics for 3 layers snow model
!@auth I.Aleinov
!@ver  1.0
      USE FILEMANAGER, only: openunit
      USE CONSTANT, only :
     $     rho_water => rhow,   ! (kg m-3)
     $     rho_ice => rhoi,     ! (kg m-3)
     $     lhm_kg => lhm,       ! (J kg-1)
     $     lhe_kg => lhe,       ! (J kg-1)
     $     shi_kg => shi,       ! (J kg-1 C-1)
     $     tfrz => tf,          ! (K)
     $     sigma => stbo        ! (W m-2 K-4)

      IMPLICIT NONE
      SAVE
      PRIVATE

      PUBLIC snow_adv, snow_redistr, snow_fraction, i_earth, j_earth

ccc physical parameters
!@var rho_fresh_snow density of fresh snow (kg m-3)
      real*8, parameter :: rho_fresh_snow =  150.d0 ! (kg m-3)
!@var lat_fusion volumetric latent heat of fusion for water  (J m-3)
      real*8, parameter :: lat_fusion = lhm_kg * rho_water ! (J m-3)
!@var lat_evap volumetric latent heat of evaporation for water  (J m-3)
      real*8, parameter :: lat_evap = lhe_kg * rho_water ! (J m-3)
!@var max_fract_water max fraction of free water in a wet snow (1)
      real*8, parameter :: max_fract_water = .055d0

ccc model parameters
!@var EPS small number (used as cutoff parameter) (1)
      real*8, parameter :: EPS = 1.d-8  ! was 1.d-12
!@var MAX_NL maximal number of snow layers (only 3 are used, really) (1)
      integer, parameter :: MAX_NL = 16
!@var TOTAL_NL maximal number of snow layers (actual number used) (1)
ccc actually MAX_NL can be set = TOTAL_NL but should test first ...
      integer, parameter :: TOTAL_NL=3
!@var MIN_SNOW_THICKNESS minimal thickness of snow (m)
ccc trying to increase MIN_SNOW_THICKNESS for stability
ccc      real*8, parameter :: MIN_SNOW_THICKNESS =  0.01d0  ! was 0.09d0
      real*8, parameter :: MIN_SNOW_THICKNESS =  0.1d0
!@var MIN_FRACT_COVER minimal snow cover (cutoff param) (1)
      real*8, parameter :: MIN_FRACT_COVER = 0.0001d0

!@var DEB_CH channel for debug output
      integer :: DEB_CH = 0
!@var i_earth, j_earth coordinate of current point (for debugging)
      integer i_earth, j_earth

      CONTAINS

      subroutine pass_water( wsn, hsn, dz, nl,
     &                       water_down, heat_down,
     &                       lat_fusion, max_fract_water,
     &                       rho_water, rho_fresh_snow)
!@sum  pass extra water to the lower layers
!@auth I.Aleinov
!@ver  1.0
      implicit none
      integer nl
      real*8  wsn(nl), hsn(nl), dz(nl)
      real*8 water_down, heat_down, lat_fusion, max_fract_water
      real*8 rho_water, rho_fresh_snow
      integer n
      real*8 ice, free_water, ice_old
      integer pass_water_flag

      pass_water_flag = 0
      do n=1,nl
        ice_old = min(wsn(n),-hsn(n)/lat_fusion)
        ice = ice_old
        wsn(n) = wsn(n) + water_down
        hsn(n) = hsn(n) + heat_down
        water_down = 0.d0
        heat_down = 0.d0
        if( hsn(n) .ge. 0.d0 .or. wsn(n) .le. 0.d0 ) then ! all melted
          water_down = wsn(n)
          heat_down = hsn(n)
          wsn(n) = 0.d0
          hsn(n) = 0.d0
          dz(n) = 0.d0
          pass_water_flag = 1
        else if (hsn(n).gt.-wsn(n)*lat_fusion) then !/* some melted */
          ice = -hsn(n)/lat_fusion
          free_water = wsn(n) - ice
c!!!                may be ice*max_fract_water ??
          water_down = max(0d0, free_water - ice*max_fract_water)
          wsn(n) = wsn(n) - water_down
          !/* should I reduce dz here ??? */
          !/* dz(n) = dz(n) * min( ice/ice_old, 1.d0 )  */
          dz(n) = min( dz(n), ice*rho_water/rho_fresh_snow )
          pass_water_flag = 2
        else !/* all frozen */
          if (wsn(n)+EPS .lt. ice_old) dz(n) = dz(n)*wsn(n)/ice_old
          dz(n) = min( dz(n), wsn(n)*rho_water/rho_fresh_snow )
        endif
        dz(n) = max( dz(n), wsn(n)*rho_water/rho_ice )
      enddo
      return
      end subroutine pass_water

      subroutine snow_fraction(
     &     dz, nl, prsnow, dt, fract_cover, fract_cover_new)
!@sum computes new snow fraction and returns it in fract_cover_new
!@auth I.Aleinov
!@ver  1.0
      implicit none
      integer nl
      real*8 dz(TOTAL_NL+1), prsnow, dt
      real*8 fract_cover, fract_cover_new
      real*8 dz_aver, fresh_snow

      fresh_snow = rho_water/rho_fresh_snow * prsnow*dt

      dz_aver = sum(dz(1:nl))*fract_cover + fresh_snow

      fract_cover_new = min( 1.d0, dz_aver/MIN_SNOW_THICKNESS )
      if ( fract_cover_new < MIN_FRACT_COVER ) fract_cover_new = 0.d0

      return
      end subroutine snow_fraction

      subroutine snow_redistr(
     &     dz, wsn, hsn, nl, fract_cover_ratio, tr_flux, dt )
!@sum  redistributes snow between the layers
!@auth I.Aleinov
!@ver  1.0
      implicit none
      integer nl
      real*8 dz(TOTAL_NL+1), wsn(TOTAL_NL), hsn(TOTAL_NL)
      real*8 fract_cover_ratio
      integer nlo
      real*8 dzo(TOTAL_NL+1), wsno(TOTAL_NL), hsno(TOTAL_NL)
      integer n, no
      real*8 total_dz, ddz, delta, fract
      real*8, optional :: tr_flux(0:TOTAL_NL), dt
      integer i

c$$$      if( fract_cover_new .lt. MIN_FRACT_COVER ) then
c$$$        print *, 'snow_redistr: fract_cover_new < MIN_FRACT_COVER'
c$$$        print *, 'fract_cover_new = ', fract_cover_new
c$$$        call stop_model(
c$$$     &       'snow_redistr: fract_cover_new < MIN_FRACT_COVER',255)
c$$$      endif

      if ( dz(1) == 0.d0 ) return  ! no snow - nothing to redistribute

      dzo(1:nl)  = dz(1:nl)
      wsno(1:nl) = wsn(1:nl)
      hsno(1:nl) = hsn(1:nl)
      nlo = nl

      total_dz = sum( dzo(1:nl) )

      !fract_cover_ratio = fract_cover/fract_cover_new
      total_dz = total_dz*fract_cover_ratio

      if ( total_dz .gt. MIN_SNOW_THICKNESS*1.5d0 ) then
        nl = TOTAL_NL
        dz(1) = MIN_SNOW_THICKNESS
        dz(2:nl) = (total_dz-dz(1))/(nl-1)
      else
        nl = 1
        dz(1) = total_dz
      endif

      wsn(1:TOTAL_NL) = 0.d0
      hsn(1:TOTAL_NL) = 0.d0

      no = 0
      delta = 0.d0
      do n=1,nl
        do while ( delta.lt.dz(n) .and. no.lt.nlo )
          no = no + 1
          delta = delta + dzo(no)*fract_cover_ratio
          wsn(n) = wsn(n) + wsno(no)*fract_cover_ratio
          hsn(n) = hsn(n) + hsno(no)*fract_cover_ratio
          enddo
        ddz = delta - dz(n)
        fract = ddz/(dzo(no)*fract_cover_ratio)
ccc the following is just for check
          if ( fract.lt.-EPS .or. fract.gt.1.d0+EPS ) then
            print *, 'fract= ', fract
            call stop_model('snow_redistr: internal error 3',255)
            endif
        wsn(n) = wsn(n) - fract*wsno(no)*fract_cover_ratio
        hsn(n) = hsn(n) - fract*hsno(no)*fract_cover_ratio
        if ( n.lt.nl ) then
          wsn(n+1) = wsn(n+1) + fract*wsno(no)*fract_cover_ratio
          hsn(n+1) = hsn(n+1) + fract*hsno(no)*fract_cover_ratio
          delta = ddz
        else
          if ( abs(fract).gt.EPS ) then
            print *, 'fract= ', fract
            call stop_model('snow_redistr: internal error 1',255)
            endif
          endif
        enddo

ccc for tracers
      if ( present(tr_flux) ) then
        if ( nlo < TOTAL_NL ) wsno(nlo+1:TOTAL_NL) = 0.d0
        tr_flux(0) = 0.d0
        do i=1,TOTAL_NL
          tr_flux(i) =
     &         - (wsn(i) - wsno(i)*fract_cover_ratio)/dt
     &         + tr_flux(i-1)
        enddo

        if ( abs(tr_flux(TOTAL_NL)) > 1.d-12 )
     &       call stop_model("SNOW: snow redistr flux error",255)
      endif

      return
      end subroutine snow_redistr

      subroutine snow_adv(dz, wsn, hsn, nl,
     &    srht, trht, snht, htpr, evaporation, pr, dt,
     &    t_ground, dz_ground,
     &    water_to_ground, heat_to_ground,
     &    radiation_out, snsh_dt, evap_dt, ! fb_or_fv,
     &     tr_flux )
      implicit none
!@sum  a wrapper that calles real snow_adv (introduced for debugging)
!@auth I.Aleinov
!@ver  1.0
ccc input:
      integer nl
      real*8 srht, trht, snht, htpr, evaporation
      real*8 pr, dt, t_ground, dz_ground
      real*8 snsh_dt, evap_dt !, fb_or_fv

ccc output:
      real*8 water_to_ground, heat_to_ground
      real*8 radiation_out
ccc data arrays
      real*8 dz(nl+1), wsn(nl), hsn(nl)

ccc tracer variables
!@var tr_flux flux of water between snow layers (>0 is down) (m/s)
      real*8 tr_flux(0:TOTAL_NL)
      real*8 wsn_o(MAX_NL), evap_o
      integer nl_o

ccc for debug
      real*8 total_energy, total_water  !, lat_evap
      integer i, retcode
      integer, save :: counter=0

      counter = counter + 1
      !rint *, counter

ccc for tracers
      wsn_o(:) = 0.d0
      nl_o = nl
      wsn_o(1:nl) = wsn(1:nl)
      evap_o = evaporation

ccc checking if the model conserves energy (part 1) (for debugging)
      total_energy = 0.d0
      total_water = 0.d0
      do i=1,nl
        total_energy = total_energy - hsn(i)
        total_water = total_water - wsn(i)
      enddo

      call snow_adv_1(dz, wsn, hsn, nl,
     &    srht, trht, snht, htpr, evaporation, pr, dt,
     &    t_ground, dz_ground,
     &    water_to_ground, heat_to_ground,
     &    radiation_out, snsh_dt, evap_dt, retcode )

!      if (fb_or_fv .le. 0.) return
ccc checking if the model conserves energy (part 2) (for debugging)
      do i=1,nl
        total_energy = total_energy + hsn(i)
        total_water = total_water + wsn(i)
      enddo
      total_energy = total_energy -
     &    (srht+trht-snht-lat_evap*evaporation+htpr)*dt
      total_energy = total_energy + heat_to_ground*dt + radiation_out*dt
      if ( abs(total_energy) .gt. 1.d0 ) then
        print*, "total energy error",i_earth, j_earth,total_energy,
     *       heat_to_ground*dt,radiation_out*dt
        call stop_model('snow_adv: total energy error',255)
      end if
      total_water = total_water
     &     - (pr - evaporation - water_to_ground)*dt
      if ( abs(total_water)/dt .gt. 1.d-15 ) then
        print*, "water cons error",i_earth, j_earth, total_water/dt
        if ( abs(total_water)/dt .gt. 1.d-10 )
     &    call stop_model('snow_adv: water conservation error',255)
      end if

c$$$    if( fr_type .lt. 1.d-6 .and. abs(total_energy) .gt. 1.d-6 ) then
c$$$      print*, "total energy error",i_earth, j_earth,total_energy
c$$$      call abort
c$$$    endif

ccc for tracers
      !!!tr_flux(0) = tr_flux(0) + pr - evaporation
      tr_flux(0) = pr - evaporation
      do i=1,TOTAL_NL
        tr_flux(i) = -(wsn(i) - wsn_o(i))/dt
     &       + tr_flux(i-1)
      enddo
ccc checking if preserve water
      if ( abs( tr_flux(TOTAL_NL) - water_to_ground ) > 1.d-15 ) then
        if ( DEB_CH == 0 )
     $       call openunit("snow_debug", DEB_CH, .false., .false.)
        write(DEB_CH,*) "snow_adv: H2O error "
     &       , abs( tr_flux(TOTAL_NL) - water_to_ground )
     &       , tr_flux(TOTAL_NL) , water_to_ground
     &       , nl, nl_o, counter, evaporation, evap_o
        !call abort
        !stop 'snow_adv: H2O error'
      endif

      return
      end subroutine snow_adv

      subroutine snow_adv_1(dz, wsn, hsn, nl,
     &    srht, trht, snht, htpr, evaporation, pr, dt,
     &    t_ground, dz_ground,
     &    water_to_ground, heat_to_ground,
     &    radiation_out, snsh_dt, evap_dt, retcode )
      implicit none
!@sum main program that does column snow physics
!@auth I.Aleinov
!@ver  1.0
ccc input:
      integer nl
      real*8 srht, trht, snht, htpr, evaporation
      real*8 pr, dt, t_ground, dz_ground
      real*8 snsh_dt, evap_dt

ccc constants: (now defined as global params)
      real*8 k_ground, c_ground
ccc output:
      real*8 water_to_ground, heat_to_ground
      real*8 radiation_out
      integer retcode

ccc main parameters: layer thickness, water equivalent, heat content
      real*8 dz(nl+1), wsn(nl), hsn(nl)
ccc!!! I wonder if the following arrays should have dim (nl) instead
ccc    of (MAX_NL) to force the allocation on a stack (for OpenMP) ?
      real*8 tsn(MAX_NL+1), csn(MAX_NL), ksn(MAX_NL+1), isn(MAX_NL)
      real*8 wsn_o(MAX_NL), hsn_o(MAX_NL), dz_o(MAX_NL+1)

      real*8 water_down, heat_down, fresh_snow, rho_snow, flux_in
      real*8 mass_layer, mass_above, scale_rho
      real*8 flux_in_deriv, flux_corr
      real*8 delta_tsn_impl ! shft of temperature due to implicit method
      integer n, nl_o
      real*8 dz_he(MAX_NL+1)

ccc!!!  check if lat_evap shoud be replaced by heat of sublimation

ccc !!! ground properties should be passed as formal parameters !!!
      k_ground =        3.4d0    !/* W K-1 m */    /* --??? */
      c_ground =        1.d5     !/* J m-3 K-1 */  /* -- ??? */

ccc will need initial values if all snow melted and for tracers
      wsn_o(1:nl) = wsn(1:nl)
      hsn_o(1:nl) = hsn(1:nl)
      dz_o(1:nl) = dz(1:nl)
      nl_o = nl

      !!! just to deceive the optimizer
      if ( dz_o(1) > 1.d6 ) call stop_model("snow_adv_1: what?!!",255)

ccc just in case, may need reasonable tsn(1) if all melted
      tsn(1) = 0.d0

ccc fluxes in/out
      heat_to_ground = 0.d0
      water_to_ground = 0.d0

#ifdef DEBUG_SNOW
      call check_rho_snow( dz, wsn, nl )
#endif

ccc compute amount of fresh snow
ccc !!! insert evaporation into computation of the amount of fresh snow
ccc use fresh_snow only to change the depth of the first layer
      fresh_snow = rho_water/rho_fresh_snow
     &                * min(pr*dt-evaporation*dt, -htpr*dt/lat_fusion)
      if(fresh_snow > 0.d0) then
        dz(1) = dz(1) + fresh_snow
      else
        if ( wsn(1) < EPS ) goto 1000
        !goto 1000
      endif

ccc water and heat to pass through the snow pack
      water_down = (pr - evaporation)*dt
      heat_down = htpr*dt
ccc will include heat of evaporation later
c!!      heat_down = heat_down - lat_evap*evaporation*dt

!#ifdef DEBUG_SNOW
!      call check_rho_snow( dz, wsn, nl )
!#endif

      call pass_water( wsn, hsn, dz, nl, water_down, heat_down,
     &                       lat_fusion, max_fract_water,
     &                       rho_water, rho_fresh_snow)
      heat_to_ground = heat_to_ground + heat_down/dt
      water_to_ground = water_to_ground + water_down/dt

      if ( sum( wsn(1:nl) ) < EPS ) goto 1000

#ifdef DEBUG_SNOW
      call check_rho_snow( dz, wsn, nl )
#endif

      call snow_redistr(dz, wsn, hsn, nl, 1.d0)
      dz(nl+1) = dz_ground

ccc compute spec. heat and thermal conductivity
      do n=1,nl
        rho_snow = wsn(n)*rho_water/dz(n)
        !csn(n) = (1.9d6) * rho_snow / rho_ice
        csn(n) = shi_kg * rho_snow
        ksn(n) = (3.22d-6) * rho_snow**2
      enddo
      ksn(nl+1) = k_ground

ccc compute temperature of the layers (and amount of ice)
      do n=1,nl
        if ( hsn(n) .gt. 0.d0 ) then
          print *, 'OOPS, No snow in layer ', n
          call stop_model('snow_adv_1: empty snow layer found (1)',255)
        else if ( hsn(n) .gt. -wsn(n)*lat_fusion ) then
          tsn(n) = 0.d0
          isn(n) = -hsn(n)/lat_fusion
        else
          tsn(n) = (hsn(n)+wsn(n)*lat_fusion)/(csn(n)*dz(n))
          isn(n) = wsn(n)
        endif
      enddo
      tsn(nl+1) = t_ground

c!!! this is for debugging
      if(tsn(1).lt.-120.d0) call stop_model("SNOW:tsn<-120",255)

ccc compute incomming heat flux (from atm.)
ccc include all fluxes except htpr (which is already included)
      flux_in =
     &      srht
     &      +trht - sigma*(tsn(1)+tfrz)**4
     &      -lat_evap*evaporation
     &      -snht

      flux_in_deriv =
     &     -4.d0*sigma*(tsn(1)+tfrz)**3 - lat_evap*evap_dt - snsh_dt

      radiation_out = sigma*(tsn(1)+tfrz)**4

ccc this is a hack to keep heat_eq stable: force dz >= 0.1
      !dz_he(1:nl+1) = dz(1:nl+1)
      !dz_he(1) = max( dz_he(1), MIN_SNOW_THICKNESS )

ccc solve heat equation
      call heat_eq(
     &     dz, tsn, hsn, csn, ksn, nl,
     &     flux_in, flux_in_deriv, flux_corr, dt )

c!!! this is for debugging
      if(tsn(1).lt.-120.d0) call stop_model("SNOW:he:tsn<-120",255)

      heat_to_ground = heat_to_ground + flux_in

ccc now redistribute extra flux proportionallly to input derivatives
ccc snht_out_cor, delta_tsn_impl
      delta_tsn_impl = flux_corr / flux_in_deriv
      radiation_out = radiation_out -
     &     (-4.d0*sigma*(tsn(1)+tfrz)**3)*delta_tsn_impl
      snht = snht + snsh_dt * delta_tsn_impl
      evaporation = evaporation + evap_dt * delta_tsn_impl

ccc and now remove (add) water due to extra evaporation.
c!!! this may make wsn(1) negative, the only way I see now to prevent it
c!!! is to keep minimal thickness of snow big enough

      water_down = - evap_dt * delta_tsn_impl * dt ! ??

#ifdef DEBUG_SNOW
      call check_rho_snow( dz, wsn, nl )
#endif

ccc pass extra water down
ccc      water_down = 0.d0
      heat_down = 0.d0
      call pass_water( wsn, hsn, dz, nl, water_down, heat_down,
     &                       lat_fusion, max_fract_water,
     &                       rho_water, rho_fresh_snow)
      heat_to_ground = heat_to_ground + heat_down/dt
      water_to_ground = water_to_ground + water_down/dt

      if ( sum( wsn(1:nl) ) < EPS ) goto 1000

      call snow_redistr(dz, wsn, hsn, nl, 1.d0)
      dz(nl+1) = dz_ground

ccc compute temperature of the layers
      do n=1,nl
        if ( hsn(n) .gt. 0.d0 ) then
          print *, 'OOPS, No snow in layer ', n
          call stop_model('snow_adv_1: empty snow layer found (2)',255)
        else if ( hsn(n) .gt. -wsn(n)*lat_fusion ) then
          tsn(n) = 0.d0
        else
          tsn(n) = (hsn(n)+wsn(n)*lat_fusion)/(csn(n)*dz(n))
        endif
      enddo
      tsn(nl+1) = t_ground

ccc repack the layers
      mass_above = 0.d0
      do n=1,nl
        if( dz(n) .gt. EPS ) then
          mass_layer = wsn(n)*rho_water
          mass_above = mass_above + .5d0 * mass_layer
          scale_rho = .5d-7 * 9.8d0 * mass_above
     &     * exp(14.643d0 - 4000.d0/(tsn(n)+tfrz)
     &                  - .02d0 * mass_layer/dz(n))
     &     * dt
          scale_rho = 1.d0 + scale_rho
          dz(n) = dz(n) / scale_rho
          if( dz(n).lt.mass_layer/rho_ice )
     &                   dz(n) = mass_layer/rho_ice
          mass_above = mass_above + .5d0 * mass_layer
        endif
      enddo

#ifdef DEBUG_SNOW
      call check_rho_snow( dz, wsn, nl )
#endif

c!!! this is for debugging
      if(tsn(1).lt.-120.d0) then
        print*,"tsn error",i_earth, j_earth,1,tsn(1:nl)
        call stop_model('snow_adv_1: tsn error',255)
      end if

      if ( radiation_out > 500.d0 ) call stop_model("SNOW:T>0",255)

      retcode = 0
      return

 1000 continue ! all melted
ccc!!! may create water_to_ground<0 if evaporation is not properly
ccc    limited. Check later.
      water_to_ground = sum( wsn_o(1:nl_o) )/dt + pr - evaporation
      heat_to_ground  = sum( hsn_o(1:nl_o) )/dt + htpr
     &     - lat_evap*evaporation
     &     - snht + srht + trht - sigma*(tsn(1)+tfrz)**4
      radiation_out = sigma*(tsn(1)+tfrz)**4
      if ( radiation_out > 500.d0 ) call stop_model("SNOW:T>0",255)
      wsn(1:nl) = 0.d0
      hsn(1:nl) = 0.d0
      nl = 1
      return
      end subroutine snow_adv_1

      subroutine heat_eq(
     &     dz, tsn, hsn, csn, ksn, nl,
     &     flux_in, flux_in_deriv, flux_corr, dt)
      implicit none
!@sum solves heat transport equation for snow layers
!@auth I.Aleinov
!@ver  1.0
!@alg This solver is currently using a half-implicit scheme.
!@+   Implicitness is controlled by the parameters:
!@+       gamma - for upper boundary
!@+       eta(MAX_NL+1) - for the rest of the boundaries
!@+   In general we are trying to use half-implicit method (gamma = .5)
!@+   at the surface. But this may introduce a systematic error when
!@+   temperature of the snow is close to 0 C.
!@+   When option DO_EXPLIC_0 is enabled the program checks for possible
!@+   error and if necessary recomputes the solution with reduced gamma,
!@+   i.e. in more explicit way.
!@+   DO_EXPLIC_0 is enabled by default. One may try to turn it off if
!@+   there are serious stability problems.
!@calls :TRIDIAG
      integer nl
      real*8 dz(nl+1), tsn(nl+1), hsn(nl)
      real*8 csn(nl), ksn(nl+1)
ccc n+1 corresponds to the first layer of the ground
      real*8 flux_in, flux_in_deriv, flux_corr, dt, syst_flux_err

      real*8 eta(MAX_NL+1), tnew(MAX_NL), gamma
ccc arrays for coefficients:
      real*8 a(MAX_NL), b(MAX_NL), c(MAX_NL), f(MAX_NL)
      real*8 left, right, dt_to_cdz
      integer n, iter
      integer :: itermax=2

ccc setting implicit/explicit choice for each layer
ccc eta=1 - implicit, eta=0 - explicit
ccc for now using explicit method for layers with T=0.d0

      do n=1,nl
         eta(n) = .5d0
ccc        eta(n) = 1.d0
c!!        if( tsn(n) .ge. 0.d0 ) eta(n) = 0.d0
        enddo
      eta(nl+1) = 0.d0
ccc      gamma = .5d0
c!! I am trying to make it nearly expicit for a test !!!
      gamma = .5d0

!!! testing: trying to improve stability
ccc switching to explicit method for very thin snow
      if ( dz(1) < MIN_SNOW_THICKNESS * .5d0 ) then
        eta(1) = 1.d0
        gamma = 1.d0
      endif

ccc In general we are trying to use half-implicit method (gamma = .5d0)
ccc on the interface. But this introduces a systematic error when
ccc tnew(1) > 0. So in the case DO_EXPLIC_0 we move to explicit method
ccc (i.e. reduce gamma)

ccc DO_EXPLIC_0 enables correction of the error which is introduced
ccc by implicit scheme when tsn(1) == 0 C
ccc (of course one has to use preprocessing to do it ...)
ccc it is enabled by default

#define DO_EXPLIC_0
#ifdef DO_EXPLIC_0
      do iter=1,itermax
#endif
ccc equation for upper snow layer
        n = 1
        dt_to_cdz = dt/(csn(n)*dz(n))
        right = 2.d0*dt_to_cdz/( dz(n)/ksn(n) + dz(n+1)/ksn(n+1) )
        a(n) = 1.d0 + right*eta(n) - dt_to_cdz*flux_in_deriv*gamma
        b(n) = 0.d0
        c(n) = -right*eta(n+1)
        f(n) = tsn(n)*( 1.d0 - right*(1.d0-eta(n))
     &                  - dt_to_cdz*flux_in_deriv*gamma )
     &         + tsn(n+1)*right*(1.d0-eta(n+1))
     &         + dt_to_cdz * flux_in

ccc all other snow layers including the lower one
        do n=2,nl

          dt_to_cdz = dt/(csn(n)*dz(n))
          right = 2.d0*dt_to_cdz/( dz(n)/ksn(n) + dz(n+1)/ksn(n+1) )
          left  = 2.d0*dt_to_cdz/( dz(n)/ksn(n) + dz(n-1)/ksn(n-1) )

          a(n) = 1.d0 + ( left + right )*eta(n)
          b(n) = -left*eta(n-1)
          c(n) = -right*eta(n+1)

          f(n) = tsn(n)*( 1.d0 - ( left + right )*(1.d0-eta(n)) )
     &         + tsn(n-1)*left*(1.d0-eta(n-1))
     &         + tsn(n+1)*right*(1.d0-eta(n+1))
          enddo

c        call sweep3diag(b, c, a, f, tnew, nl)
          call TRIDIAG(b,a,c,f,tnew,nl)

ccc flux_corr is the energy wich should be returned to the atmosphere
        flux_corr = flux_in_deriv*( tnew(1) - tsn(1) )*gamma

#ifdef DO_EXPLIC_0
        syst_flux_err = flux_in_deriv*( tnew(1) - 0.d0 )*gamma
        ! if( iter/=2 .and. tnew(1)>0.d0 .and. flux_in_deriv<0.d0 ) then
        ! back to 77 :-L
        if ( iter.ne.itermax .and.
     &         tnew(1).gt.0.d0 .and. flux_in_deriv.lt.0.d0 ) then
          syst_flux_err = flux_in_deriv*( tnew(1) - 0.d0 )*gamma
          gamma = (1.d0 - syst_flux_err/flux_corr) *gamma
        else
          ! exit
          ! back to 77 :-L
          goto 77
        endif
      enddo
 77   continue
#endif

      do n=1,nl
        hsn(n) = hsn(n) + (tnew(n)-tsn(n))*csn(n)*dz(n)
        enddo

ccc flux to the ground :
      n = nl
      flux_in = - ( tsn(n+1)-tnew(n)*eta(n)-tsn(n)*(1.d0-eta(n)) ) *
     &           2.d0/( dz(n)/ksn(n) + dz(n+1)/ksn(n+1) )

      return
      end subroutine heat_eq

      subroutine check_rho_snow( dz, wsn, nl )
      integer nl
      real*8 dz(nl+1), wsn(nl)
      integer n
      do n=1,nl
        if( wsn(n) < EPS ) cycle
        if ( wsn(n)/dz(n)*rho_water+EPS < rho_fresh_snow) then
          print *,"rho_snow < rho_fresh_snow at i,j=",i_earth, j_earth
          print *,"n, wsn, rho_sn, rho_fresh= ", n,wsn(n),
     *         wsn(n)/dz(n)*rho_water ,rho_fresh_snow
          call stop_model('check_rho_snow: rho < rho_fresh_snow',255)
        end if
      enddo

      do n=1,nl
        if( wsn(n) < EPS ) cycle
        if ( wsn(n)/dz(n)*rho_water-EPS > rho_ice) then
          print *,"rho_snow > rho_ice at i,j=",i_earth, j_earth
          print *,"n, wsn, rho_sn, rho_ice= ", n,wsn(n),
     *         wsn(n)/dz(n)*rho_water ,rho_ice
          call stop_model('check_rho_snow: rho > rho_ice',255)
        end if
      enddo

      end subroutine check_rho_snow

      END MODULE SNOW_MODEL


C=======================================================================
C  ML_ROOTGR, Subroutine
C
C  Determines root growth
C-----------------------------------------------------------------------
C  Revision history
C
C  1. Written
C  2  Modified by                           E. Alocilja & B. Baer 9-88
C  3  Modified by                           T. Jou                4-89
C  4. Header revision and minor changes             P.W.W.      2-8-93
C  5. Added switch block, etc.                      P.W.W.      2-8-93
C  6. Simplified the RLNEW calculation and slowed
C     the growth of roots in deeper soils.   J.T.R. & B.D.B.   6-20-94
C  7. Converted to modular format                    W.D.B.    7-31-02
C-----------------------------------------------------------------------
C  INPUT  : None
C
C  LOCAL  : RLDF,RNFAC,RLNEW,SWDF,TRLDF,RNLF,L,L1
C
C  OUTPUT : None
C-----------------------------------------------------------------------
C  Called : ML_CERES
C
C  Calls  : None
C-----------------------------------------------------------------------
C                         DEFINITIONS
C
C  L,L1   : Loop counter
C  RLDF() : A root length density factor for soil layer L used to calculate
C           new root growth distribution - unitless
C  RLNEW  : New root length to be added to the total root system length -
C           cm.  root per sq. cm. ground
C  RNFAC  : Zero to unity factor describing mineral N availability effect on
C           root growth in Layer L
C  RNLF   : Intermediate factor used to calculate distribution of new root
C           growth in the soil - unitless value between 0 and 1
C  SWDF   : Soil water deficit factor for Layer L used to calculate root
C           growth and water uptake - unitless value between 0 and 1
C  TRLDF  : An intermediate calculation used to calculate distribution of
C           new root growth in soil
C=======================================================================

      SUBROUTINE ML_ROOTGR (
     & CUMDEP, CUMDTT, DEPMAX, DLAYR, DTT,
     & ESW, GRORT, ISWNIT, LL, NH4, NLAYR, NO3,
     & PLTPOP, PORMIN,RLV, RLWR, RTDEP, SAT, SHF, SW, SWFAC)

      USE MODULEDEFS
      IMPLICIT  NONE
      SAVE
C---------------------------------------------------------------------------
C  VARIABLES THAT WERE IN COMMON BLOCK
C---------------------------------------------------------------------------

      REAL CUMDEP
      REAL CUMDTT
      REAL DEPMAX
      REAL DLAYR(NL)
      REAL DTT
      REAL ESW(NL)
      REAL LL(NL)
      REAL NH4(NL)
      INTEGER NLAYR
      REAL NO3(NL)
      REAL PLTPOP
      REAL RLV(NL)
      REAL RLWR
      REAL RTDEP
      REAL SHF(NL)
      REAL SW(NL)
      REAL SWFAC
	REAL RTSURV
	REAL RTEXF
	REAL SWEXF
	REAL SAT(NL)
	REAL PORMIN

C--------------------------------------------------------------------
C   LOCAL VARIABLES
C--------------------------------------------------------------------
      CHARACTER ISWNIT*1
      REAL      RLDF(NL),RNFAC,RLNEW,SWDF,TRLDF,RNLF,GRORT
      INTEGER   L,L1

C--------------------------------------------------------------------
C            MAIN CODE
C--------------------------------------------------------------------
C
C     The small differences between root length/weight ratios used in earlier
C     models were insignificant considering the uncertainty of the value
C     and the uncertainty of loss of assimilate by exudation and respiration.
C     A compromise value of 0.98 was choosen for all crops.
C
C     RLNEW  = GRORT * 0.98 * PLTPOP     ! A compromise value -- JTR
      RLNEW  = GRORT * RLWR * PLTPOP     ! A compromise value -- JTR
      CUMDEP = 0.0
      RNFAC  = 1.0
      RLDF   = 0.0
      L      = 0

      DO WHILE ((CUMDEP .LT. RTDEP) .AND. (L .LT. NLAYR))
         L = L + 1
         CUMDEP = CUMDEP + DLAYR(L)
         IF (SW(L)-LL(L) .LT. 0.25*ESW(L)) THEN
            SWDF = 4.0*(SW(L)-LL(L))/ESW(L)
            IF (SWDF .LT. 0.0) THEN
               SWDF = 0.0
            ENDIF
          ELSE
            SWDF = 1.0
         ENDIF
C
C        Made all crops so that RNFAC is constrained between 0.01 and 1.0;
C        on page 94 of Jones & Kiniry book the minimum is 0.01. - WTB
C
         IF (ISWNIT .NE. 'N') THEN
            RNFAC = 1.0 - (1.17*EXP(-0.15*(NO3(L)+NH4(L))))
            RNFAC = AMAX1 (RNFAC,0.01)
         ENDIF

         RLDF(L) = AMIN1(SWDF,RNFAC)*SHF(L)*DLAYR (L)
      END DO

!     CHP 3/19/2014
!     Also changed L to L1 in the following section
      L1 = L
      L1 = MAX(1,L)
C
C     The following changes were made to simplify the code and make the model
C     more generic. It also takes into account some newer data provided by
C     Julio Dardenelli of Argentina.  For the first time the ceres model
C     restricts the rate of downward movement of roots with the soil property
C     -- root weighting factor -- to account for greater difficulty in growing
C     downward in hard soil. Changes made by JTR 6/16/94.
C

c** wdb 10/22/03
          RTEXF = 0.1
          SWEXF = 1.0
          IF (SAT(L1)-SW(L1) .LT. PORMIN) THEN
            SWEXF = (SAT(L1) - SW(L1)) / PORMIN
            SWEXF = MIN(SWEXF, 1.0)
          ENDIF

          RTSURV = MIN(1.0,(1.-RTEXF*(1.-SWEXF)))

c** wdb 10/22/03
      IF (CUMDTT .LT. 275.0) THEN                ! JTR 6/17/94
         RTDEP = RTDEP + DTT*0.1*SQRT(SHF(L1)*AMIN1(SWFAC*2.0,SWDF))
       ELSE
         RTDEP = RTDEP + DTT*0.2*SQRT(SHF(L1)*AMIN1(SWFAC*2.0,SWDF))
      ENDIF

      RTDEP    = AMIN1 (RTDEP,DEPMAX)
      RLDF(L1) = RLDF(L1)*(1.0-(CUMDEP-RTDEP)/DLAYR(L1))
      TRLDF    = 0.0

      DO  L = 1, L1
         TRLDF = TRLDF + RLDF(L)
      END DO

      IF (TRLDF .GE. RLNEW*0.00001 .AND. TRLDF .GT. 0.0) THEN
         RNLF = RLNEW/TRLDF
         DO L = 1, L1
            RLV(L) = RLV(L) + RLDF(L)*RNLF/DLAYR(L)-0.005*RLV(L)
	      RLV(L) = RLV(L) * RTSURV
            RLV(L) = AMAX1 (RLV(L),0.0)
            RLV(L) = AMIN1 (RLV(L),4.0)
         END DO
      ENDIF

      RETURN
      END SUBROUTINE ML_ROOTGR


      SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
     $                   WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          COMPZ, JOB
      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
*     ..
*     .. Array Arguments ..
      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  ZHSEQR computes the eigenvalues of a complex upper Hessenberg
*  matrix H, and, optionally, the matrices T and Z from the Schur
*  decomposition H = Z T Z**H, where T is an upper triangular matrix
*  (the Schur form), and Z is the unitary matrix of Schur vectors.
*
*  Optionally Z may be postmultiplied into an input unitary matrix Q,
*  so that this routine can give the Schur factorization of a matrix A
*  which has been reduced to the Hessenberg form H by the unitary
*  matrix Q:  A = Q*H*Q**H = (QZ)*T*(QZ)**H.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          = 'E': compute eigenvalues only;
*          = 'S': compute eigenvalues and the Schur form T.
*
*  COMPZ   (input) CHARACTER*1
*          = 'N': no Schur vectors are computed;
*          = 'I': Z is initialized to the unit matrix and the matrix Z
*                 of Schur vectors of H is returned;
*          = 'V': Z must contain an unitary matrix Q on entry, and
*                 the product Q*Z is returned.
*
*  N       (input) INTEGER
*          The order of the matrix H.  N >= 0.
*
*  ILO     (input) INTEGER
*  IHI     (input) INTEGER
*          It is assumed that H is already upper triangular in rows
*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*          set by a previous call to ZGEBAL, and then passed to CGEHRD
*          when the matrix output by ZGEBAL is reduced to Hessenberg
*          form. Otherwise ILO and IHI should be set to 1 and N
*          respectively.
*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
*  H       (input/output) COMPLEX*16 array, dimension (LDH,N)
*          On entry, the upper Hessenberg matrix H.
*          On exit, if JOB = 'S', H contains the upper triangular matrix
*          T from the Schur decomposition (the Schur form). If
*          JOB = 'E', the contents of H are unspecified on exit.
*
*  LDH     (input) INTEGER
*          The leading dimension of the array H. LDH >= max(1,N).
*
*  W       (output) COMPLEX*16 array, dimension (N)
*          The computed eigenvalues. If JOB = 'S', the eigenvalues are
*          stored in the same order as on the diagonal of the Schur form
*          returned in H, with W(i) = H(i,i).
*
*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)
*          If COMPZ = 'N': Z is not referenced.
*          If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
*          contains the unitary matrix Z of the Schur vectors of H.
*          If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
*          which is assumed to be equal to the unit matrix except for
*          the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
*          Normally Q is the unitary matrix generated by ZUNGHR after
*          the call to ZGEHRD which formed the Hessenberg matrix H.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.
*          LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
*
*  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, ZHSEQR failed to compute all the
*                eigenvalues in a total of 30*(IHI-ILO+1) iterations;
*                elements 1:ilo-1 and i+1:n of W contain those
*                eigenvalues which have been successfully computed.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
      DOUBLE PRECISION   RZERO, RONE, CONST
      PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0,
     $                   CONST = 1.5D+0 )
      INTEGER            NSMAX, LDS
      PARAMETER          ( NSMAX = 15, LDS = NSMAX )
*     ..
*     .. Local Scalars ..
      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
      INTEGER            I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L,
     $                   MAXB, NH, NR, NS, NV
      DOUBLE PRECISION   OVFL, RTEMP, SMLNUM, TST1, ULP, UNFL
      COMPLEX*16         CDUM, TAU, TEMP
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   RWORK( 1 )
      COMPLEX*16         S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV, IZAMAX
      DOUBLE PRECISION   DLAMCH, DLAPY2, ZLANHS
      EXTERNAL           LSAME, ILAENV, IZAMAX, DLAMCH, DLAPY2, ZLANHS
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLACPY, ZLAHQR,
     $                   ZLARFG, ZLARFX, ZLASET, ZSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
*     ..
*     .. Statement Function definitions ..
      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      WANTT = LSAME( JOB, 'S' )
      INITZ = LSAME( COMPZ, 'I' )
      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
*
      INFO = 0
      WORK( 1 ) = MAX( 1, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -5
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZHSEQR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Initialize Z, if necessary
*
      IF( INITZ )
     $   CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
*     Store the eigenvalues isolated by ZGEBAL.
*
      DO 10 I = 1, ILO - 1
         W( I ) = H( I, I )
   10 CONTINUE
      DO 20 I = IHI + 1, N
         W( I ) = H( I, I )
   20 CONTINUE
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
      IF( ILO.EQ.IHI ) THEN
         W( ILO ) = H( ILO, ILO )
         RETURN
      END IF
*
*     Set rows and columns ILO to IHI to zero below the first
*     subdiagonal.
*
      DO 40 J = ILO, IHI - 2
         DO 30 I = J + 2, N
            H( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
      NH = IHI - ILO + 1
*
*     I1 and I2 are the indices of the first row and last column of H
*     to which transformations must be applied. If eigenvalues only are
*     being computed, I1 and I2 are re-set inside the main loop.
*
      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      ELSE
         I1 = ILO
         I2 = IHI
      END IF
*
*     Ensure that the subdiagonal elements are real.
*
      DO 50 I = ILO + 1, IHI
         TEMP = H( I, I-1 )
         IF( DIMAG( TEMP ).NE.RZERO ) THEN
            RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) )
            H( I, I-1 ) = RTEMP
            TEMP = TEMP / RTEMP
            IF( I2.GT.I )
     $         CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
            CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
            IF( I.LT.IHI )
     $         H( I+1, I ) = TEMP*H( I+1, I )
            IF( WANTZ )
     $         CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 )
         END IF
   50 CONTINUE
*
*     Determine the order of the multi-shift QR algorithm to be used.
*
      NS = ILAENV( 4, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
      MAXB = ILAENV( 8, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
      IF( NS.LE.1 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
*
*        Use the standard double-shift algorithm
*
         CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
     $                LDZ, INFO )
         RETURN
      END IF
      MAXB = MAX( 2, MAXB )
      NS = MIN( NS, MAXB, NSMAX )
*
*     Now 1 < NS <= MAXB < NH.
*
*     Set machine-dependent constants for the stopping criterion.
*     If norm(H) <= sqrt(OVFL), overflow should not occur.
*
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = RONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( NH / ULP )
*
*     ITN is the total number of multiple-shift QR iterations allowed.
*
      ITN = 30*NH
*
*     The main loop begins here. I is the loop index and decreases from
*     IHI to ILO in steps of at most MAXB. Each iteration of the loop
*     works with the active submatrix in rows and columns L to I.
*     Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
*     H(L,L-1) is negligible so that the matrix splits.
*
      I = IHI
   60 CONTINUE
      IF( I.LT.ILO )
     $   GO TO 180
*
*     Perform multiple-shift QR iterations on rows and columns ILO to I
*     until a submatrix of order at most MAXB splits off at the bottom
*     because a subdiagonal element has become negligible.
*
      L = ILO
      DO 160 ITS = 0, ITN
*
*        Look for a single small subdiagonal element.
*
         DO 70 K = I, L + 1, -1
            TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
            IF( TST1.EQ.RZERO )
     $         TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK )
            IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) )
     $         GO TO 80
   70    CONTINUE
   80    CONTINUE
         L = K
         IF( L.GT.ILO ) THEN
*
*           H(L,L-1) is negligible.
*
            H( L, L-1 ) = ZERO
         END IF
*
*        Exit from loop if a submatrix of order <= MAXB has split off.
*
         IF( L.GE.I-MAXB+1 )
     $      GO TO 170
*
*        Now the active submatrix is in rows and columns L to I. If
*        eigenvalues only are being computed, only the active submatrix
*        need be transformed.
*
         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
*
         IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN
*
*           Exceptional shifts.
*
            DO 90 II = I - NS + 1, I
               W( II ) = CONST*( ABS( DBLE( H( II, II-1 ) ) )+
     $                   ABS( DBLE( H( II, II ) ) ) )
   90       CONTINUE
         ELSE
*
*           Use eigenvalues of trailing submatrix of order NS as shifts.
*
            CALL ZLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S,
     $                   LDS )
            CALL ZLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS,
     $                   W( I-NS+1 ), 1, NS, Z, LDZ, IERR )
            IF( IERR.GT.0 ) THEN
*
*              If ZLAHQR failed to compute all NS eigenvalues, use the
*              unconverged diagonal elements as the remaining shifts.
*
               DO 100 II = 1, IERR
                  W( I-NS+II ) = S( II, II )
  100          CONTINUE
            END IF
         END IF
*
*        Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
*        where G is the Hessenberg submatrix H(L:I,L:I) and w is
*        the vector of shifts (stored in W). The result is
*        stored in the local array V.
*
         V( 1 ) = ONE
         DO 110 II = 2, NS + 1
            V( II ) = ZERO
  110    CONTINUE
         NV = 1
         DO 130 J = I - NS + 1, I
            CALL ZCOPY( NV+1, V, 1, VV, 1 )
            CALL ZGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), LDH,
     $                  VV, 1, -W( J ), V, 1 )
            NV = NV + 1
*
*           Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
*           reset it to the unit vector.
*
            ITEMP = IZAMAX( NV, V, 1 )
            RTEMP = CABS1( V( ITEMP ) )
            IF( RTEMP.EQ.RZERO ) THEN
               V( 1 ) = ONE
               DO 120 II = 2, NV
                  V( II ) = ZERO
  120          CONTINUE
            ELSE
               RTEMP = MAX( RTEMP, SMLNUM )
               CALL ZDSCAL( NV, RONE / RTEMP, V, 1 )
            END IF
  130    CONTINUE
*
*        Multiple-shift QR step
*
         DO 150 K = L, I - 1
*
*           The first iteration of this loop determines a reflection G
*           from the vector V and applies it from left and right to H,
*           thus creating a nonzero bulge below the subdiagonal.
*
*           Each subsequent iteration determines a reflection G to
*           restore the Hessenberg form in the (K-1)th column, and thus
*           chases the bulge one step toward the bottom of the active
*           submatrix. NR is the order of G.
*
            NR = MIN( NS+1, I-K+1 )
            IF( K.GT.L )
     $         CALL ZCOPY( NR, H( K, K-1 ), 1, V, 1 )
            CALL ZLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
            IF( K.GT.L ) THEN
               H( K, K-1 ) = V( 1 )
               DO 140 II = K + 1, I
                  H( II, K-1 ) = ZERO
  140          CONTINUE
            END IF
            V( 1 ) = ONE
*
*           Apply G' from the left to transform the rows of the matrix
*           in columns K to I2.
*
            CALL ZLARFX( 'Left', NR, I2-K+1, V, DCONJG( TAU ),
     $                   H( K, K ), LDH, WORK )
*
*           Apply G from the right to transform the columns of the
*           matrix in rows I1 to min(K+NR,I).
*
            CALL ZLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU,
     $                   H( I1, K ), LDH, WORK )
*
            IF( WANTZ ) THEN
*
*              Accumulate transformations in the matrix Z
*
               CALL ZLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ,
     $                      WORK )
            END IF
  150    CONTINUE
*
*        Ensure that H(I,I-1) is real.
*
         TEMP = H( I, I-1 )
         IF( DIMAG( TEMP ).NE.RZERO ) THEN
            RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) )
            H( I, I-1 ) = RTEMP
            TEMP = TEMP / RTEMP
            IF( I2.GT.I )
     $         CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
            CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
            IF( WANTZ ) THEN
               CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 )
            END IF
         END IF
*
  160 CONTINUE
*
*     Failure to converge in remaining number of iterations
*
      INFO = I
      RETURN
*
  170 CONTINUE
*
*     A submatrix of order <= MAXB in rows and columns L to I has split
*     off. Use the double-shift QR algorithm to handle it.
*
      CALL ZLAHQR( WANTT, WANTZ, N, L, I, H, LDH, W, ILO, IHI, Z, LDZ,
     $             INFO )
      IF( INFO.GT.0 )
     $   RETURN
*
*     Decrement number of remaining iterations, and return to start of
*     the main loop with a new value of I.
*
      ITN = ITN - ITS
      I = L - 1
      GO TO 60
*
  180 CONTINUE
      WORK( 1 ) = MAX( 1, N )
      RETURN
*
*     End of ZHSEQR
*
      END


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program GPa2km
!===============================================================================
!  Find the depth for a given Earth model which is at the requested pressure

use global_1d_models

implicit none

real(8) :: P,P0,P1,P2,depth,depth0,depth1,depth2,dPdz
character(10) :: model
real(8) :: tol=5.  !  Accuracy of the solution / GPa
real(8),parameter :: dz=100.

if (command_argument_count() /= 1 .and. command_argument_count() /= 2) then
   write(0,'(a)') '  Usage: GPa2km [P / GPa] (PREM|AK135)'
   stop
endif

call get_command_argument(1,model); read(model,*) P
model = 'PREM'
if (command_argument_count() == 2) call get_command_argument(2,model)
if (model == 'PREM') tol = 1.
!  Search for the depth which gives the correct pressure using Newton-Raphson
!  f(x)=0: x_n+1 = x_n - f(x_n) / f'(x_n)
!  f'(x) approx. by (f(x_n)-f(x_n+dx))/dx

!depth1 = 0.
!depth0 = 2890.  ! starting guess of CMB
!do while (abs(depth1 - depth0) > tol)
!   if (depth1 > 0.) depth0 = depth1
!   if (depth1 < 0.) depth0 = 0.
!   dPdz = (pressure(depth0+dz,model=trim(model)) - &
!           pressure(depth0,model=trim(model)))/dz
!   depth1 = depth0 - (pressure(depth,model=trim(model)) - P) / dPdz
!   write(*,*) depth1
!enddo

!  Actually, use the method of halves to get the correct depth:
!  This is fine for PREM which has an analytical answer, but layered models
!  will required some thought.
if (model /= 'PREM') write(0,'(a)',advance='no') 'GPa2km is thinking'
!  starting guesses
depth0 = 0.      ;  P0 = 0.    ! Top
depth2 = 6371.   ;  P2 = 365.  ! Bottom
depth1 = 6371./2.;  P1 = pressure(depth1,model=trim(model))  ! Middle
do while (abs(P2 - P0) > tol)
   if (P > P0 .and. P < P1) then
      depth0 = depth0
      depth2 = depth1                  ; P2 = pressure(depth2,model=trim(model))
      depth1 = (depth0 + depth2) / 2.  ; P1 = pressure(depth1,model=trim(model))
   else if (P > P1 .and. P < P2) then
      depth0 = depth1                  ; P0 = pressure(depth0,model=trim(model))
      depth2 = depth2
      depth1 = (depth0 + depth2) / 2.  ; P1 = pressure(depth1,model=trim(model))
   else if (P == P1) then
      write(*,*) depth1; stop
   endif
   P0 = pressure(depth0,model=trim(model))
   P1 = pressure(depth1,model=trim(model))
   if (model /= 'PREM') write(0,'(a)',advance='no') '.'
enddo
if (model /= 'PREM') write(0,'(a)') ''
write(*,'(i0.1)') int(depth1)

end program GPa2km
!-------------------------------------------------------------------------------


! test_pot_twist.f90
! twist angle, cos(phi) potential
MODULE test_pot_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  USE, INTRINSIC :: iso_fortran_env, ONLY : error_unit

  IMPLICIT NONE
  PRIVATE

  ! Public routine
  PUBLIC :: force

  ! Public data
  INTEGER, PARAMETER, PUBLIC :: n = 4 ! Four-body potential

CONTAINS

  SUBROUTINE force  ( r, pot, f )
    IMPLICIT NONE
    REAL, DIMENSION(:,:),           INTENT(in)  :: r
    REAL,                           INTENT(out) :: pot
    REAL, DIMENSION(:,:), OPTIONAL, INTENT(out) :: f

    ! We choose to make the polymer the minimum length needed for testing
    INTEGER                  :: a, b
    REAL, DIMENSION(3,2:n)   :: d      ! the d vectors
    REAL, DIMENSION(2:n,2:n) :: cc, dd ! the C and D coefficients
    REAL                     :: prefac, fac, fac1, fac2

    ! Routine to demonstrate the calculation of forces from the
    ! polymer angle-twisting potential
    ! Written for ease of comparison with the text, rather than efficiency!

    ! Check dimensions to be sure
    IF ( ANY ( SHAPE(r) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'r shape error', SHAPE(r), 3, n
       STOP 'Error in test_pot_twist'
    END IF

    ! Set up d vectors
    DO a = 2, n
       d(:,a) = r(:,a) - r(:,a-1)
    END DO

    ! Store C coefficients in a matrix
    ! In the general case we would not need to calculate every pair
    ! and also we would make use of the symmetry cc(b,a)=cc(a,b)
    DO a = 2, n
       DO b = 2, n
          cc(a,b) = DOT_PRODUCT ( d(:,a), d(:,b) )
       END DO
    END DO

    ! Store D coefficients in a matrix
    ! In the general case we would not need to calculate every pair
    ! and also we would make use of the symmetry dd(b,a)=dd(a,b)
    DO a = 2, n
       DO b = 2, n
          dd(a,b) = cc(a,a)*cc(b,b) - cc(a,b)**2
       END DO
    END DO

    ! For this test there is just one angle
    a = n

    ! Here is the potential as a function of cos(phi)
    ! For testing we use the simplest form: v= -cos(phi)
    ! The notation matches that used in the appendix

    prefac = 1.0 /  SQRT(dd(a,a-1)*dd(a-1,a-2))
    fac = (cc(a,a-1)*cc(a-1,a-2)-cc(a,a-2)*cc(a-1,a-1))
    pot = prefac * fac ! This is -cos(phi)

    IF ( .NOT. PRESENT(f) ) RETURN

    IF ( ANY ( SHAPE(f) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'f shape error', SHAPE(f), 3, n
       STOP 'Error in test_pot_twist'
    END IF

    ! Here we include the derivative of the potential with respect to cos(phi) in the prefactor
    ! For this simple case it is -1, so the forces are simply gradients of cos(phi) as in the text

    fac1 = fac/dd(a,a-1)
    fac2 = fac/dd(a-1,a-2)
    f(:,a) = -prefac * ( cc(a-1,a-2)*d(:,a-1) - cc(a-1,a-1)*d(:,a-2) &
         & -fac1 * ( cc(a-1,a-1)*d(:,a) - cc(a,a-1)*d(:,a-1) ) )
    f(:,a-1) = -prefac * ( cc(a-1,a-2)*d(:,a) - cc(a-1,a-2)*d(:,a-1) &
         & + cc(a,a-1)*d(:,a-2) + cc(a-1,a-1)*d(:,a-2) - 2.0*cc(a,a-2)*d(:,a-1) &
         & -fac2 * ( cc(a-2,a-2)*d(:,a-1) - cc(a-1,a-2)*d(:,a-2) ) &
         & -fac1 * ( cc(a,a)*d(:,a-1) - cc(a-1,a-1)*d(:,a) - cc(a,a-1)*d(:,a) + cc(a,a-1)*d(:,a-1)) )
    f(:,a-2) = -prefac*( -cc(a-1,a-2)*d(:,a) + cc(a,a-1)*d(:,a-1)  &
         & -cc(a,a-1)*d(:,a-2) - cc(a-1,a-1)*d(:,a) + 2.0*cc(a,a-2)*d(:,a-1) &
         & -fac2 * ( cc(a-1,a-1)*d(:,a-2) - cc(a-2,a-2)*d(:,a-1) - cc(a-1,a-2)*d(:,a-1) + cc(a-1,a-2)*d(:,a-2) ) &
         & -fac1 * ( -cc(a,a)*d(:,a-1) + cc(a,a-1)*d(:,a)))
    f(:,a-3) = -prefac * ( -cc(a,a-1)*d(:,a-1) + cc(a-1,a-1)*d(:,a) &
         & -fac2 * ( -cc(a-1,a-1)*d(:,a-2) + cc(a-1,a-2)*d(:,a-1) ) )

  END SUBROUTINE force

END MODULE test_pot_module


      SUBROUTINE TRAPZD(FUNC,A,B,S,N)
      IF (N.EQ.1) THEN
        S=0.5*(B-A)*(FUNC(A)+FUNC(B))
        IT=1
      ELSE
        TNM=IT
        DEL=(B-A)/TNM
        X=A+0.5*DEL
        SUM=0.
        DO 11 J=1,IT
          SUM=SUM+FUNC(X)
          X=X+DEL
11      CONTINUE
        S=0.5*(S+(B-A)*SUM/TNM)
        IT=2*IT
      ENDIF
      RETURN
      END


      subroutine dbhplot(apot,lmax,nr,dr)
      parameter(ipmax=1000)
      real apot(20,0:20000),rp(1000),pplot(1000),iplot(ipmax)
      data ifirst /0/
      save rp,ifirst,nrp, iplot
      character*40 toplbl

      if (ifirst.eq.0) then
         ifirst=1
         nrp=1
         rp(nrp)=log10(dr)
         iplot(nrp)=1
         do ir=1,nr
            r=log10(ir*dr)
            if (r-rp(nrp).gt.0.01) then
               nrp=nrp+1
               rp(nrp)=r
               iplot(nrp)=ir
               if (nrp.ge.ipmax) then
                  write(*,*) 'Not able to plot all points in dbhplot.'
                  write(*,*) 'Increase ipmax parameter & recompile!'
                  goto 4
               endif
            endif
         enddo
      endif

 4    do l=0,lmax,2
         j=l/2+1
         pmax=-1e31
         pmin=1e31
         do irp=1,nrp
            pp=apot(j,iplot(irp))
            pmax=max(pmax,pp)
            pmin=min(pmin,pp)
            pplot(irp)=pp
         enddo

         call pgenv(log10(dr),log10(nr*dr),pmin,pmax,0,1)
         call pgline(nrp,rp,pplot)
         write(toplbl,'(''l='',i3)') l
         call pglabel('log10(R)','POT',toplbl)
      enddo
      return
      end


module n_interface_mod
  implicit none
  save
contains
!this module is caluclating Frensel reflectio probabilities
!ONLY for a flat surface of the skin.....
!this is incredibly un abstract
  subroutine n_interface(n1,n2,ct1,diffuse_flag,reflect_flag)
    use constants_mod, only: pi
    implicit none
  real*8,intent(in) :: n1,n2 !refractive indices
  real*8,intent(in) :: ct1 !cos theta 1, or nzp, same thing
  logical, intent(in) :: diffuse_flag
  logical, intent(out):: reflect_flag

  real*8 :: ca, theta1
  real*8 :: R
  real*8 :: ran
  logical :: TIR

  !initialise decision vars to 0
  reflect_flag=.false.
  TIR=.false.
  R=0.00

  if (ct1.lt.0.d0) then !it means pkt is entering medium
    if (.not.diffuse_flag) then !if packet is not diffuse, used reduced fresnel eqn.
      R=((n1-n2)/(n1+n2))**2
    else !pkt is difffuse, use full fresnel. swap quadrant of theta to fix direction frame of packet
      theta1=dacos(ct1)
      theta1=pi-theta1
      call fresnel(n1,n2,theta1,r)
    endif
  else !packet is within medium- need to check if it leaves or reflects off skin surface
     if (n2.lt.n1) then
      ca=dasin(n2/n1)
      if (acos(ct1).gt.ca) then !if angle of incidence > crit angle, Total Internal Reflection
        TIR=.true.
      else  !else call fresnel
        theta1=dacos(ct1)
        call fresnel(n1,n2,theta1,r)
      endif
  endif

 endif
  if (TIR) then
    reflect_flag=.true.
  else
    call random_number(ran)
    if (ran.lt.R) then
      reflect_flag=.true.

    endif
  endif

    return

  end subroutine n_interface

  subroutine fresnel(n1,n2,theta1,r)
  !check probability of reflection for an incident packet
  implicit none
  real*8, intent(in) :: n1,n2,theta1
  real*8 :: theta2
  real*8 :: rs,rp,r

    theta2=(n1/n2)*SIN(theta1)

    rs = (n1*cos(theta1) - n2*cos(theta2))/(n1*cos(theta1)+ n2*cos(theta2))
    rs=rs**2

    rp=(n1*cos(theta2) - n2*cos(theta1))/(n1*cos(theta2) + n2*cos(theta1))
    rp=rp**2

    r=0.5*(rs+rp)

    if (r.gt.1) print*, 'R greater than 1 in fresnel...please investigate broken physics',r

  end subroutine fresnel

  subroutine reflect(z_dir)
    !WARNING: takes in single direction(z) and uses to reset cost
  use packet_mod, only: cost
  implicit none
  real*8, intent(inout) :: z_dir
  z_dir= -z_dir
  cost=z_dir
  end subroutine

end module n_interface_mod


module ltm2ubv

   use real_kind

   implicit none
   real(double) :: tgr(34), ggr(13), tab(34,13,5)

contains

subroutine load_colour_conversion_table(fu)
   use real_kind

   implicit none
   integer, intent(in) :: fu
   integer :: i,j, k

991 format (3(10f10.5,/), 4f10.5,/, 10f10.5,/, 3f10.5,/, 442(5f8.3,/))
   read (fu,991) tgr, ggr, (((tab(i,j,k), k=1,5), j=1,13), i=1,34)
   close (fu)
end subroutine

subroutine lt2ubv ( logl, logt, mass, mv, bminv, uminb )
   ! yields values of MV, B-V and U-B for given log L, log T, and mass

   use real_kind

   implicit none
   real(double) :: logl, logt, mass, mv, bminv, uminb

   integer :: i,ing1,ing2,int1,int2,k,j,k0,k1,k2
   real(double) :: logm,logg,logg1,logg2,logt1,logt2
   real(double) :: dg1,dg2,bc1,bc2,ub1,ub2,bv1,bv2,dt1,dt2,ubx,bvx,bcx,mbol
   real(double) :: bc(4), ub(4), bv(4), vr(4), ri(4)

   logm = log10(mass)
   logg = logm + 4.0d0*logt - logl - 10.6071d0

   ! determine values of log g to interpolate between
   ing1 = 1
   ing2 = 13
1  continue                         ! FIXME - replace with do while()
   if ( ing2 - ing1.gt.1 ) then     ! FIXME - replace with do while()
      i = (ing1 + ing2)/2
      if ( ggr(i).gt.logg ) then
         ing2 = i
      else
         ing1 = i
      end if
      goto 1                        ! FIXME - replace with end do
   end if                           ! FIXME - replace with end do
   logg1 = ggr(ing1)
   logg2 = ggr(ing2)

   ! determine values of log T to interpolate between
   int1 = 1
   int2 = 34
2  continue                         ! FIXME - replace with do while()
   if ( int2 - int1.gt.1 ) then     ! FIXME - replace with do while()
      i = (int1 + int2)/2
      if ( tgr(i).gt.logt ) then
         int2 = i
      else
         int1 = i
      end if
      goto 2                        ! FIXME - replace with end do
   end if                           ! FIXME - replace with end do

   logt1 = tgr(int1)
   logt2 = tgr(int2)

   do k = 1, 2
      do j = 1, 2
         k0 = (k - 1)*2 + j
         k1 = int1 - 1 + k
         k2 = ing1 - 1 + j
         bc(k0) = tab(k1, k2, 1)
         ub(k0) = tab(k1, k2, 2)
         bv(k0) = tab(k1, k2, 3)
         vr(k0) = tab(k1, k2, 4)
         ri(k0) = tab(k1, k2, 5)
      end do
   end do

   dg1 = (logg - logg1)/(logg2 - logg1)
   dg2 = 1.0d0 - dg1
   bc1 = bc(2)*dg1 + bc(1)*dg2
   ub1 = ub(2)*dg1 + ub(1)*dg2
   bv1 = bv(2)*dg1 + bv(1)*dg2
   bc2 = bc(4)*dg1 + bc(3)*dg2
   ub2 = ub(4)*dg1 + ub(3)*dg2
   bv2 = bv(4)*dg1 + bv(3)*dg2
   dt1 = (logt - logt1)/(logt2 - logt1)
   dt2 = 1.0d0 - dt1
   bcx = bc2*dt1 + bc1*dt2
   ubx = ub2*dt1 + ub1*dt2
   bvx = bv2*dt1 + bv1*dt2
   mbol = 4.75d0 - 2.5d0*logl
   mv = mbol - bcx
   bminv = bvx
   uminb = ubx

end subroutine lt2ubv

end module