      subroutine operatn

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine performs all management operations

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dayl(:)     |hours         |day length for current day
!!    daylmn(:)   |hours         |shortest daylength occurring during the
!!                               |year
!!    dormhr(:)   |hours         |time threshold used to define dormant
!!                               |period for plant (when daylength is within
!!                               |the time specified by dormhr from the minimum
!!                               |daylength for the area, the plant will go
!!                               |dormant)
!!    phubase(:)  |heat units    |base zero total heat units (used when no
!!                               |land cover is growing
!!    icr(:)      |none          |sequence number of crop grown within a year
!!    iida        |julian date   |day being simulated (current julian date)
!!    idc(:)      |none          |crop/landcover category:
!!                               |1 warm season annual legume
!!                               |2 cold season annual legume
!!                               |3 perennial legume
!!                               |4 warm season annual
!!                               |5 cold season annual
!!                               |6 perennial
!!                               |7 trees
!!    idplt(:)    |none          |land cover code from crop.dat
!!    igro(:)     |none          |land cover status code:
!!                               |0 no land cover currently growing
!!                               |1 land cover growing
!!    ihru        |none          |HRU number
!!    iop(:,:,:)  |julian date   |date of tillage operation
!!    ncut(:)     |none          |sequence number of harvest operation within
!!                               |current year
!!    nro(:)      |none          |sequence number of year in rotation
!!    ntil(:)     |none          |sequence number of tillage operation within
!!                               |current year
!!    phuacc(:)   |none          |fraction of plant heat units accumulated
!!    phut(:,:,:) |none          |fraction of heat units (base zero or plant)
!!                               |at which tillage occurs
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aphu        |heat units    |fraction of total heat units accumulated
!!    j           |none          |HRU number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: plantop, dormant, harvkillop, harvestop, killop, tillmix

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: aphu, tillphu

      j = 0
      j = ihru

!! operations performed only when no land cover growing

        do while(idop(nop(j),j) > 0 .and. iida == idop(nop(j),j))
          call sched_mgt
          if (mgtop(nop(j),j) == 17) then
	      call sched_mgt
	    end if
          if (yr_skip(j) == 1) exit
        end do

        if (igro(j) == 0) then
          aphu = phubase(j)
        else
          aphu = phuacc(j)
        end if
        if (dorm_flag == 1) aphu = 999.
        do while (phu_op(nop(j),j) > 0. .and. aphu > phu_op(nop(j),j))
          call sched_mgt
          if (igro(j) == 0) then
            aphu = phubase(j)
          else
            aphu = phuacc(j)
          end if
          if (dorm_flag == 1) aphu = 999.
          if (mgtop(nop(j),j) == 17) then
	      call sched_mgt
          end if
          if (yr_skip(j) == 1) exit
        end do

      return
1000  format (4i10,a10)
      end


module intqmod

!$$$ module documentation block
!           .      .    .                                       .
! module:   intqmod    module for intq and its tangent linear intq_tl
!   prgmmr:
!
! abstract: module for intq and its tangent linear intq_tl
!
! program history log:
!   2005-05-13  Yanqiu zhu - wrap intq and its tangent linear intq_tl into one module
!   2005-11-16  Derber - remove interfaces
!   2008-11-26  Todling - remove intq_tl; add interface back
!   2009-08-13  lueken - update documentation
!   2012-09-14  Syed RH Rizvi, NCAR/NESL/MMM/DAS  - implemented obs adjoint test
!   2014-04-14      Su   -  add another non linear qc(purser's scheme)
!   2015-02-26      Su   -  add njqc as an option to choose Purser's varqc
!   2016-05-18  guo     - replaced ob_type with polymorphic obsNode through type casting
!
! subroutines included:
!   sub intq_
!
! variable definitions:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

use m_obsNode, only: obsNode
use m_qNode, only: qNode
use m_qNode, only: qNode_typecast
use m_qNode, only: qNode_nextcast
use m_obsdiagNode, only: obsdiagNode_set
implicit none

PRIVATE
PUBLIC intq

interface intq; module procedure &
          intq_
end interface

contains

subroutine intq_(qhead,rval,sval)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    intq        apply nonlin qc obs operator for q
!   prgmmr: derber           org: np23                date: 1991-02-26
!
! abstract: apply observation operator and adjoint for q with
!             nonlinear qc operator
!
! program history log:
!   1991-02-26  derber
!   1993-08-15  wu
!   1997-12-12  weiyu yang
!   1999-08-24  derber, j., treadon, r., yang, w., first frozen mpp version
!   2004-08-02  treadon - add only to module use, add intent in/out
!   2004-10-05  parrish - add non-linear qc option
!   2005-03-01  parrish - nonlinear qc change to account for inflated obs error
!   2005-04-11  treadon - merge intq and intq_qc into single routine
!   2005-08-02  derber  - modify for variational qc parameters for each ob
!   2005-09-28  derber  - consolidate location and weight arrays
!   2005-10-21  su      - modify for variational qc
!   2006-07-28  derber  - modify to use new inner loop obs data structure
!   2007-03-19  tremolet - binning of observations
!   2007-06-05  tremolet - use observation diagnostics structure
!   2007-07-09  tremolet - observation sensitivity
!   2008-05-31  safford - rm unused vars
!   2008-01-04  tremolet - Don't apply H^T if l_do_adjoint is false
!   2008-11-28  todling  - turn FOTO optional; changed ptr%time handle
!   2010-05-13  todling  - update to use gsi_bundle; update interface
!   2012-09-14  Syed RH Rizvi, NCAR/NESL/MMM/DAS  - introduced ladtest_obs
!   2014-12-03  derber  - modify so that use of obsdiags can be turned off
!   2015-12-21  yang    - Parrish's correction to the previous code in new varqc.
!
!   input argument list:
!     qhead    - obs type pointer to obs structure
!     sq       - q increment in grid space
!     rq
!
!   output argument list:
!     rq       - results from q observation operator
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: half,one,tiny_r_kind,cg_term,r3600,two
  use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag
  use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc
  use jfunc, only: jiter
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use gsi_4dvar, only: ladtest_obs
  implicit none

! Declare passed variables
  class(obsNode),pointer ,intent(in   ) :: qhead
  type(gsi_bundle)       ,intent(in   ) :: sval
  type(gsi_bundle)       ,intent(inout) :: rval

! Declare local variables
  integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus
  real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8
! real(r_kind) penalty
  real(r_kind) cg_q,val,p0,grad,wnotgross,wgross,q_pg
  real(r_kind),pointer,dimension(:) :: sq
  real(r_kind),pointer,dimension(:) :: rq
  type(qNode), pointer :: qptr

!  If no q data return
  if(.not. associated(qhead))return
! Retrieve pointers
! Simply return if any pointer not found
  ier=0
  call gsi_bundlegetpointer(sval,'q',sq,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'q',rq,istatus);ier=istatus+ier
  if(ier/=0) return

  !qptr => qhead
  qptr => qNode_typecast(qhead)
  do while (associated(qptr))
     j1=qptr%ij(1)
     j2=qptr%ij(2)
     j3=qptr%ij(3)
     j4=qptr%ij(4)
     j5=qptr%ij(5)
     j6=qptr%ij(6)
     j7=qptr%ij(7)
     j8=qptr%ij(8)
     w1=qptr%wij(1)
     w2=qptr%wij(2)
     w3=qptr%wij(3)
     w4=qptr%wij(4)
     w5=qptr%wij(5)
     w6=qptr%wij(6)
     w7=qptr%wij(7)
     w8=qptr%wij(8)

!    Forward model
     val=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4)+ &
         w5* sq(j5)+w6* sq(j6)+w7* sq(j7)+w8* sq(j8)

     if(luse_obsdiag)then
        if (lsaveobsens) then
           grad = val*qptr%raterr2*qptr%err2
           !-- qptr%diags%obssen(jiter) = grad
           call obsdiagNode_set(qptr%diags,jiter=jiter,obssen=grad)
        else
           !-- if (qptr%luse) qptr%diags%tldepart(jiter)=val
           if (qptr%luse) call obsdiagNode_set(qptr%diags,jiter=jiter,tldepart=val)
        endif
     endif

     if (l_do_adjoint) then
        if (.not. lsaveobsens) then
           if( .not. ladtest_obs)   val=val-qptr%res

!          gradient of nonlinear operator

           if (vqc .and. nlnqc_iter .and. qptr%pg > tiny_r_kind .and.  &
                                qptr%b  > tiny_r_kind) then
              q_pg=qptr%pg*varqc_iter
              cg_q=cg_term/qptr%b
              wnotgross= one-q_pg
              wgross =q_pg*cg_q/wnotgross              ! wgross is gama in the reference by Enderson
              p0=wgross/(wgross+exp(-half*qptr%err2*val**2))  ! p0 is P in the reference by Enderson
              val=val*(one-p0)                         ! term is Wqc in the referenc by Enderson
           endif

           if (njqc .and. qptr%jb > tiny_r_kind .and. qptr%jb <10.0_r_kind) then
              val=sqrt(two*qptr%jb)*tanh(sqrt(qptr%err2)*val/sqrt(two*qptr%jb))
              grad = val*qptr%raterr2*sqrt(qptr%err2)
           else
              grad = val*qptr%raterr2*qptr%err2
           endif
           if( ladtest_obs) then
              grad = val
           end if
        endif

!       Adjoint
        rq(j1)=rq(j1)+w1*grad
        rq(j2)=rq(j2)+w2*grad
        rq(j3)=rq(j3)+w3*grad
        rq(j4)=rq(j4)+w4*grad
        rq(j5)=rq(j5)+w5*grad
        rq(j6)=rq(j6)+w6*grad
        rq(j7)=rq(j7)+w7*grad
        rq(j8)=rq(j8)+w8*grad

     endif

     !qptr => qptr%llpoint
     qptr => qNode_nextcast(qptr)

  end do
  return
end subroutine intq_

end module intqmod


**********************************************************************
**********************************************************************
      integer function pos(ndum,indcell,cellmax,ncell,guessc
     &                     ,indlens,lensmax,nlens)
*
* determines number of cell or lens in shoot  (new version: bisection)
*     implemetation of "hunt" (--> num.rec.)
*
* input:
*      ndum      - index of cell whose actual number is wanted
*      indcell   - vector with actual numbers of cells
*      cellmax   - maximal number of cells
*      ncell   - total number of cells
*      guessc    - guess for actual cell number; accelerates search a lo
*                      (in case cell search is negative)
*      indlens   - vector with actual numbers of lenses
*      lensmax   - maximal number of lenses
*      nlens     - total number of lenses
*
* output(function value):
*        - positive: position of data for cell number "ndum" in vectors
*          indcell, cell(i,.),...   (if cell with # ndum exists)
*        - negative: position of data for lens number "ndum" in vectors
*          indlens, lensdata(i,.),...   (if lens with # ndum exists)
*        - zero     (if neither cell nor lens with # ndum does exist)
*
* called in:
*           shootcl
*
* use of subroutines:
*           none
*
* use of functions:
*           poslc
*					October 31, 1991; J. Wambsganss
*
      implicit none
      external poslc
      integer cellmax,ncell,guessc,plens,poslc,lensmax,nlens,inc,lower
     &      ,upper,middle,ndum,indlens(lensmax),indcell(cellmax)
*
      if(guessc.lt.2)guessc = 2
*
* first check, if guess fits:
*
      if(ndum.eq.indcell(guessc))then
         pos = guessc
         return
*
* then check, if number of cell larger than largest value in indcell:
*               (--> look for according lens)
*
      elseif(ndum.gt.indcell(ncell))then
         plens =  poslc(ndum,indlens,lensmax,nlens)
         if(plens.gt.0)then
            pos = -plens
         else
            pos = 0
         endif
         return
*
* then check, if number of cell less than smallest value in indcell:
*               (--> return with zero)
*
      elseif(ndum.lt.indcell(1))then
         if(ndum.lt.indlens(1))then
            pos = 0
            return
         else
            plens =  poslc(ndum,indlens,lensmax,nlens)
            if(plens.gt.0)then
               pos = -plens
            else
               pos = 0
            endif
            return
         endif
      else
*
*  start with "HUNT"-procedure:   ( guess value: guessc )
*
         inc   = 1
         upper = guessc
         lower = guessc - 1
*
*    bracket searched value with  lower  and  upper:
*
    5    if(ndum.lt.indcell(lower))then
            upper  = lower
            lower = max(lower-inc,1)
            inc    = inc + inc
            goto 5
         elseif(ndum.gt.indcell(upper))then
            lower  = upper
            upper = min(upper+inc,ncell)
            inc    = inc + inc
            goto 5
         endif
*
* bisection with bracketing values lower, upper:
*
   10    if(lower.gt.upper)then
*
*  no cell found: look for lens with this (cell-) number:
*
            plens =  poslc(ndum,indlens,lensmax,nlens)
            if(plens.gt.0)then
               pos = -plens
            else
               pos = 0
            endif
            return
         else
*
*  next step in bracketing:
*
            middle = (lower + upper)/2
            if(ndum.eq.indcell(middle))then
               pos = middle
               return
            elseif(ndum.lt.indcell(middle))then
               upper = middle - 1
               goto 10
            else
               lower = middle + 1
               goto 10
            endif
         endif
      endif
      end


      subroutine routels(iru_sub)

!!    ~ ~ ~ PURPOSE ~ ~ ~

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    icodes(:)   |none          |routing command code:
!!                               |0 = finish       9 = save
!!                               |1 = subbasin    10 = recday
!!                               |2 = route       11 = reccnst
!!                               |3 = routres     12 = structure
!!                               |4 = transfer    13 =
!!                               |5 = add         14 = saveconc
!!                               |6 = rechour     15 =
!!                               |7 = recmon      16 = autocal
!!                               |8 = recyear     17 = routing unit
!!    ihouts(:)   |none          |outflow hydrograph storage location
!!    inum1s(:)   |none          |routing unit number - runon
!!    inum2s(:)   |none          |inflow hydrograph number number
!!    inum3s(:)   |none          |subbasin number
!!    inum4s(:)   |none          |not used in this command
!!    rnum1s(:)   |none          |drainage area of routing unit in km2
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!
      use parm
      real :: latqout, gwqout, latqrunon, surfqrunon, latqlyr

!!    compute infiltration from surface runon to next landscape unit
      real :: ls_overq, ls_latq, ls_tileq, ls_gwq

!!    water
!      if (rnum1 > 1.e-4) return
!      xx = varoute(29,inum2) + varoute(30,inum2) + varoute(31,inum2) +
!     &        varoute(32,inum2)
!      if (xx < 1.e-6) then
!        ls_overq = varoute(1,inum2) * rnum1
!        ls_latq = 0.
!        ls_tileq = 0.
!        ls_gwq = 0.
!      else
!        ls_overq = varoute(29,inum2) * rnum1
!        ls_latq = varoute(30,inum2) * rnum1
!        ls_tileq = varoute(31,inum2) * rnum1
!        ls_gwq = varoute(32,inum2) * rnum1
!      end if

      if (inum5 == 0 .or. inum8 == 0) then
        ls_overq = 0.
        surfqrunon = 0.
        surfqout = 0.
        if (inum5 == 0) then
          ls_overq = varoute(29,inum2) * rnum1
        end if
        if (inum8 == 0) then
          ls_overq = ls_overq + varoute(31,inum2) * rnum1
        end if
!!    sediment
      sed = varoute(3,inum2) * rnum1
      !! use surface runoff (mm) for eiq - m3/(10 * 100*km2) = mm
      ru_eiq(inum3,inum1) = ls_overq / (1000. * daru_km(inum3,inum1))
      trancap = ru_ktc(inum3,inum1) * ru_c(inum3,inum1) *
     &        ru_eiq(inum3,inum1) * ru_k(inum3,inum1) *
     &        ru_a(inum3,inum1)**1.4 * ru_ovs(inum3,inum1)**1.4
      trancap = trancap * daru_km(inum3,inum1) * 100.   !! t/ha -> t
      if (sed > trancap) then
        varoute(3,ihout) = trancap
        dr = varoute(3,ihout) / sed
      else
        varoute(3,ihout) = sed
        dr = 1.
      end if

!!    organic nitrogen
      orgn = varoute(4,inum2) * rnum1
      cy = varoute(3,inum2) / (varoute(2,inum2) + 1.e-6)
      if (cy > .01) then
        enratio = .78 * cy ** (-.2468)
      else
        enratio = 3.
      end if
      enratio = Min(enratio,3.)
      dr_er = dr * enratio
      dr_er = Min(dr_er,1.)
      varoute(4,ihout) = orgn * dr_er

!!    organic phosphorus
      orgp = varoute(5,inum2) * rnum1
      varoute(5,ihout) = orgp * dr_er

!!    nitrate (& nitrite)
      no3 = (varoute(6,inum2) + varoute(15,inum2)) * rnum1
!!    soluble phosphorus
      slbp = varoute(7,inum2) * rnum1
!!    soluble pesticide not routed
!!    sorbed pesticide not routed
!!    chlorophyll-a not routed
!!    ammonium
      nh3 = varoute(14,inum2) * rnum1
!!    CBOD not routed
!!    dissolved oxygen not routed
!!    persistent bacteria not routed
!!    less persistent bacteria not routed

!!    dstor = rnum1

!!    compute infiltration from surface runon to next landscape unit
      if (ls_overq > 1.e-6) then
        do kk = 1, hrutot(inum3)
          jj= hru1(inum3) + kk - 1
          if (iru_sub == 0) then
            frac = hru_fr(jj)
            dakm = sub_km(inum3)
          else
            frac = hru_rufr(inum1,kk)
            dakm = daru_km(inum3,inum1)
          end if
          if (frac > 1.e-9) then
          xx = frac * dakm * 100.     !!km2*100 = ha
	    surfqrunon = ls_overq / (10. * xx)

          if (pot_volxmm(jj) > 1.e-6) then
            pot_vol(jj) = pot_vol(jj) + surfqrunon
          else

!!        add surface runon to soil layers - use percmain like rainfall infiltration
          qs = surfqrunon / 24.
          vs = (qs ** .4) * (hru_slp(jj) ** .3) / (ov_n(jj) ** .6)
          trt = slsubbsn(jj) / (3600. * vs)
          inflpcp = sol_k(1,jj) * trt + dstor
          inflpcp = Min (inflpcp, surfqrunon)
          surfqout = surfqout + (surfqrunon - inflpcp) * 10. * xx
          ihru = jj
          latq(jj) = 0.
          sepbtm(jj) = 0.
          qtile = 0.
          call percmain
          latqout = latqout + latq(jj) * 10. * xx
          gwqout = gwqout + sepbtm(jj) * 10. * xx
          end if
          end if
        end do
        varoute(29,ihout) = varoute(29,ihout) + surfqout
        varoute(30,ihout) = varoute(30,ihout) + latqout
        varoute(32,ihout) = varoute(32,ihout) + gwqout
    !    surfq_ru(jj) = surfqout / (10. * xx)
    !    latq_ru(jj) = latqout / (10. * xx)
    !    infl_ru(jj) = inflpcp
        varoute(2,ihout) = varoute(2,ihout) + surfqout + latqout +
     &                                                         gwqout
      end if
      end if

!!    compute lateral flow to next landscape unit
      if (inum6 == 0) then
      ls_latq = varoute(30,inum2) * rnum1
      latqout = 0.
      latqrunon = 0.
      if (ls_latq > 1.e-9) then
        do kk = 1, hrutot(inum3)
          jj= hru1(inum3) + kk - 1
          if (iru_sub == 0) then
            frac = hru_fr(jj)
            dakm = sub_km(inum3)
          else
            frac = hru_rufr(inum1,kk)
            dakm = daru_km(inum3,inum1)
          end if
          if (frac > 1.e-9) then
            xx = frac * dakm * 100.     !!km2*100 = ha
	      latqrunon = ls_latq / (10. * xx)
	      jj= hru1(inum3) + kk - 1
!!          put in soil layers - weighted by depth of soil layer
            dep = 0.
            xslat = 0.
            do lyr = 1, sol_nly(jj)
              latqlyr = ((sol_z(lyr,jj)-dep) / sol_z(sol_nly(jj),jj))
     &                                                  * latqrunon
              dep = sol_z(lyr,jj)
              sol_st(lyr,jj) = sol_st(lyr,jj) + latqlyr
              if (sol_st(lyr,jj) > sol_ul(lyr,jj)) then
                xslat = xslat + (sol_st(lyr,jj) - sol_ul(lyr,jj))
                sol_st(lyr,jj) = sol_ul(lyr,jj)
              end if
            end do
!!          add excess water to next landscape unit
            latqout = latqout + xslat * 10. * xx
          end if
        end do
        varoute(30,ihout) = varoute(30,ihout) + latqout
        varoute(2,ihout) = varoute(2,ihout) + latqout
      end if
      end if

!!    compute groundwater flow to next landscape unit -
!!    used the next day in gwmod - routed with recharge
      if (inum7 == 0) then
      ls_gwq = varoute(32,inum2) * rnum1
      if (ls_gwq > 1.e-6) then
        gwqout = 0.
        gwqrunon = 0.
        do kk = 1, hrutot(inum3)
          jj= hru1(inum3) + kk - 1
          if (iru_sub == 0) then
            frac = hru_fr(jj)
            dakm = sub_km(inum3)
          else
            frac = hru_rufr(inum1,kk)
            dakm = daru_km(inum3,inum1)
          end if
          if (frac > 1.e-9) then
            xx = frac * dakm * 100.     !!km2*100 = ha
	      gwqrunon = ls_gwq / (10. * xx)
	      jj= hru1(inum3) + kk - 1
	      gwq_ru(jj) = gwqrunon
	    end if
        end do
      end if
      end if

      do ii = 29, mvaro
        varoute(ii,inum2) = 0.
      end do

      return
      end


*DECK DPLPFE
      SUBROUTINE DPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT,
     +   IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM,
     +   AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS,
     +   FOUND)
C***BEGIN PROLOGUE  DPLPFE
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPFE-S, DPLPFE-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/,
C     /SCOPY/DCOPY/.
C
C     THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS
C     AND GET SEARCH DIRECTION).
C     REVISED 811130-1100
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DCOPY, DPRWPG, IDLOC, LA05BD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DPLPFE
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*),
     * RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG,
     * ONE,RATIO,RCOST,RMAX,ZERO
      DOUBLE PRECISION DASUM
      LOGICAL FOUND,TRANS
C***FIRST EXECUTABLE STATEMENT  DPLPFE
      LPG=LMX-(NVARS+4)
      ZERO=0.D0
      ONE=1.D0
      RMAX=ZERO
      FOUND=.FALSE.
      I=MRELAS+1
      N20002=MRELAS+NVARS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      J=IBASIS(I)
C
C     IF J=IBASIS(I) .LT. 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL
C     AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER.
      IF (.NOT.(J.GT.0)) GO TO 20006
C
C     DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS.
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20009
      GO TO 20002
20009 CONTINUE
C
C     IF A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU),
C     THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER.
      IF (.NOT.(IND(J).EQ.3)) GO TO 20012
      IF (.NOT.((BU(J)-BL(J)).LE.EPS*(ABS(BL(J))+ABS(BU(J)))))
     *GO TO 20015
      GO TO 20002
20015 CONTINUE
      CONTINUE
20012 CONTINUE
      RCOST=RZ(J)
C
C     IF VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE.  THIS
C     ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN.
      IF(MOD(IBB(J),2).EQ.0) RCOST=-RCOST
C
C     IF THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE
C     REDUCED COST FOR THAT VARIABLE.
      IF(IND(J).EQ.4) RCOST=-ABS(RCOST)
      CNORM=ONE
      IF(J.LE.NVARS)CNORM=COLNRM(J)
C
C     TEST FOR NEGATIVITY OF REDUCED COSTS.
      IF (.NOT.(RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO)) GO TO 20018
      FOUND=.TRUE.
      RATIO=RCOST**2/RG(J)
      IF (.NOT.(RATIO.GT.RMAX)) GO TO 20021
      RMAX=RATIO
      IENTER=I
20021 CONTINUE
      CONTINUE
20018 CONTINUE
      CONTINUE
20006 GO TO 20002
C
C     USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION.
20004 IF (.NOT.(FOUND)) GO TO 20024
      J=IBASIS(IENTER)
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.LE.NVARS)) GO TO 20027
      IF (.NOT.(J.EQ.1)) GO TO 20030
      ILOW=NVARS+5
      GO TO 20031
20030 ILOW=IMAT(J+3)+1
20031 CONTINUE
      IL1=IDLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20033
      ILOW=ILOW+2
      IL1=IDLOC(ILOW,AMAT,IMAT)
20033 CONTINUE
      IPAGE=ABS(IMAT(LMX-1))
      IHI=IMAT(J+4)-(ILOW-IL1)
20036 IU1=MIN(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20038
      GO TO 20037
20038 CONTINUE
      DO 30 I=IL1,IU1
      WW(IMAT(I))=AMAT(I)*CSC(J)
30    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20041
      GO TO 20037
20041 CONTINUE
      IPAGE=IPAGE+1
      KEY=1
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20036
20037 GO TO 20028
20027 IF (.NOT.(IND(J).EQ.2)) GO TO 20044
      WW(J-NVARS)=ONE
      GO TO 20045
20044 WW(J-NVARS)=-ONE
20045 CONTINUE
      CONTINUE
C
C     COMPUTE SEARCH DIRECTION.
20028 TRANS=.FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
C
C     THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE IF EITHER
C     VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS
C     POSITIVE REDUCED COST.
      IF (.NOT.(MOD(IBB(J),2).EQ.0.OR.(IND(J).EQ.4 .AND. RZ(J).GT.ZERO))
     *) GO TO 20047
      I=1
      N20050=MRELAS
      GO TO 20051
20050 I=I+1
20051 IF ((N20050-I).LT.0) GO TO 20052
      WW(I)=-WW(I)
      GO TO 20050
20052 CONTINUE
20047 DIRNRM=DASUM(MRELAS,WW,1)
C
C     COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN
C     ADD-DROP (EXCHANGE) STEP, LA05CD( ).
      CALL DCOPY(MRELAS,WR,1,DUALS,1)
20024 RETURN
      END


      module module_ftuv_driver

      use module_wave_data, only : nw

      implicit none

      save

      integer, parameter :: dp = selected_real_kind(14,300)

      integer, private, parameter :: nref = 51
      real(dp), private, parameter :: m2s = 60._dp
      real(dp), private, parameter :: Pa2hPa = .01_dp

      integer, private :: nz, kcon
      integer, private :: next, last
      integer, private :: curjulday = 0

      integer, private, allocatable :: luse2usgs(:)

      real(dp), private :: esfact = 1.0_dp
      real(dp), private :: dobson

      real(dp), private :: dels

      real(dp), private :: zref(nref), tref(nref), airref(nref), o3ref(nref)
      real(dp), private :: albedo(nw-1,2)

      type column_density
        integer :: ncoldens_levs
        integer :: ndays_of_year
        real(dp), pointer :: col_levs(:)
        real(dp), pointer :: day_of_year(:)
        real(dp), pointer :: o3_col_dens(:,:,:,:)
        real(dp), pointer :: o2_col_dens(:,:,:,:)
        logical :: is_allocated
      end type column_density

      type(column_density), private, allocatable :: col_dens(:)
      logical, private :: photo_inti_initialized = .false.

      data zref/ 00.0, 01.0, 02.0, 03.0, 04.0, 05.0, 06.0, 07.0, 08.0, 09.0, &
                 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0, &
                 20.0, 21.0, 22.0, 23.0, 24.0, 25.0, 26.0, 27.0, 28.0, 29.0, &
                 30.0, 31.0, 32.0, 33.0, 34.0, 35.0, 36.0, 37.0, 38.0, 39.0, &
                 40.0, 41.0, 42.0, 43.0, 44.0, 45.0, 46.0, 47.0, 48.0, 49.0, &
                 50.0 /

     data tref/ 288.150, 281.651, 275.154, 268.659, 262.166, 255.676, 249.187, &
                242.700, 236.215, 229.733, 223.252, 216.774, 216.650, 216.650, &
                216.650, 216.650, 216.650, 216.650, 216.650, 216.650, 216.650, &
                217.581, 218.574, 219.567, 220.560, 221.552, 222.544, 223.536, &
                224.527, 225.518, 226.509, 227.500, 228.490, 230.973, 233.743, &
                236.513, 239.282, 242.050, 244.818, 247.584, 250.350, 253.114, &
                255.878, 258.641, 261.403, 264.164, 266.925, 269.684, 270.650, &
                270.650, 270.650 /

     data airref/ 2.55E+19, 2.31E+19, 2.09E+19, 1.89E+19, 1.70E+19, 1.53E+19, &
                  1.37E+19, 1.23E+19, 1.09E+19, 9.71E+18, 8.60E+18, 7.59E+18, &
                  6.49E+18, 5.54E+18, 4.74E+18, 4.05E+18, 3.46E+18, 2.96E+18, &
                  2.53E+18, 2.16E+18, 1.85E+18, 1.57E+18, 1.34E+18, 1.14E+18, &
                  9.76E+17, 8.33E+17, 7.12E+17, 6.09E+17, 5.21E+17, 4.47E+17, &
                  3.83E+17, 3.28E+17, 2.82E+17, 2.41E+17, 2.06E+17, 1.76E+17, &
                  1.51E+17, 1.30E+17, 1.12E+17, 9.62E+16, 8.31E+16, 7.19E+16, &
                  6.23E+16, 5.40E+16, 4.70E+16, 4.09E+16, 3.56E+16, 3.11E+16, &
                  2.74E+16, 2.42E+16, 2.14E+16 /

      data o3ref/ 8.00E+11, 7.39E+11, 6.90E+11, 6.22E+11, 5.80E+11, 5.67E+11, &
                  5.70E+11, 5.86E+11, 6.50E+11, 8.23E+11, 1.13E+12, 1.57E+12, &
                  2.02E+12, 2.24E+12, 2.35E+12, 2.57E+12, 2.95E+12, 3.47E+12, &
                  4.04E+12, 4.49E+12, 4.77E+12, 4.88E+12, 4.86E+12, 4.73E+12, &
                  4.54E+12, 4.32E+12, 4.03E+12, 3.65E+12, 3.24E+12, 2.85E+12, &
                  2.52E+12, 2.26E+12, 2.03E+12, 1.80E+12, 1.58E+12, 1.40E+12, &
                  1.22E+12, 1.04E+12, 8.73E+11, 7.31E+11, 6.07E+11, 4.95E+11, &
                  3.98E+11, 3.18E+11, 2.54E+11, 2.03E+11, 1.62E+11, 1.30E+11, &
                  1.04E+11, 8.27E+10, 6.61E+10/

      integer, private, parameter :: pid_no2 = 4
      integer, private, parameter :: pid_n2o = 9
      integer, private, parameter :: pid_n2o5 = 8
      integer, private, parameter :: pid_o31d = 2
      integer, private, parameter :: pid_o33p = 3
      integer, private, parameter :: pid_hono = 12
      integer, private, parameter :: pid_hno3 = 13
      integer, private, parameter :: pid_hno4 = 14
      integer, private, parameter :: pid_no3o2 = 5
      integer, private, parameter :: pid_no3o = 6
      integer, private, parameter :: pid_h2o2 = 11
      integer, private, parameter :: pid_ch2om = 16
      integer, private, parameter :: pid_ch2or = 15
      integer, private, parameter :: pid_ald = 17
      integer, private, parameter :: pid_ch3choa = 17
      integer, private, parameter :: pid_ch3chob = 18
      integer, private, parameter :: pid_ch3choc = 19
      integer, private, parameter :: pid_op1 = 24
      integer, private, parameter :: pid_op2 = 1
      integer, private, parameter :: pid_paa = 16
      integer, private, parameter :: pid_ket = 23
      integer, private, parameter :: pid_glya = 21
      integer, private, parameter :: pid_glyb = 21
      integer, private, parameter :: pid_mgly = 22
      integer, private, parameter :: pid_dcb = 1
      integer, private, parameter :: pid_onit = 25
      integer, private, parameter :: pid_pan = 26
      integer, private, parameter :: pid_mvk = 27
      integer, private, parameter :: pid_macr = 28
      integer, private, parameter :: pid_hyac = 29
      integer, private, parameter :: pid_glyald= 30

      contains

      subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, &
                              gmt, julday, &
                              p_phy, t_phy, rho_phy, p8w, t8w, &
                              xlat, xlong, z_at_w, &
                              moist, chem,gd_cloud,gd_cloud2, &
                              ph_no2,ph_o31d,ph_o33p,ph_hono, &
                              ph_hno3,ph_hno4,ph_no3o2,ph_no3o, &
                              ph_h2o2,ph_ch2om,ph_ch2or,ph_ald, &
                              ph_op1,ph_op2,ph_paa,ph_ket,ph_glya, &
                              ph_glyb,ph_mgly,ph_dcb,ph_onit, &
                              ph_macr,ph_ch3coc2h5,ph_n2o, &
                              ph_pan,ph_mpan,ph_acetol,ph_gly, &
                              ph_bigald,ph_mek,ph_c2h5ooh,ph_c3h7ooh, &
                              ph_pooh,ph_rooh,ph_xooh,ph_isopooh, &
                              ph_alkooh,ph_mekooh,ph_tolooh, &
                              ph_terpooh,ph_n2o5,ph_mvk,ph_glyald, &
                              ph_hyac, ivgtyp, &
                              ph_radfld, ph_adjcoe, ph_prate, &
                              wc_x, zref_x, &
                              tauaer1, tauaer2, tauaer3, tauaer4, &
                              waer1, waer2, waer3, waer4, &
                              gaer1, gaer2, gaer3, gaer4, &
                              ids,ide, jds,jde, kds,kde, &
                              ims,ime, jms,jme, kms,kme, &
                              its,ite, jts,jte, kts,kte )

      use module_configure
      use module_state_description
      use module_model_constants
      use module_data_sorgam, only : mw_so4_aer

      use module_wave_data, only : tuv_jmax, nw, wc
      use module_ftuv_subs, only : calc_zenith

      implicit none

      integer, intent(in ) :: id, julday, &
                                ids,ide, jds,jde, kds,kde, &
                                ims,ime, jms,jme, kms,kme, &
                                its,ite, jts,jte, kts,kte
      integer, intent(in) :: ivgtyp(ims:ime,jms:jme)

      real, intent(in ) :: dtstep, gmt
      real(dp), intent(in ) :: curr_secs

      type(grid_config_rec_type), intent(in ) :: config_flags

      real, intent(in ) :: p_phy(ims:ime,kms:kme,jms:jme), &
                             t_phy(ims:ime,kms:kme,jms:jme), &
                             rho_phy(ims:ime,kms:kme,jms:jme), &
                             p8w(ims:ime,kms:kme,jms:jme), &
                             t8w(ims:ime,kms:kme,jms:jme), &
                             z_at_w(ims:ime,kms:kme,jms:jme)

      real, optional, &
            intent(in ) :: gd_cloud(ims:ime,kms:kme,jms:jme), &
                             gd_cloud2(ims:ime,kms:kme,jms:jme)
      real, intent(in ) :: xlat(ims:ime,jms:jme), &
                             xlong(ims:ime,jms:jme)
      real, intent(in ) :: moist(ims:ime,kms:kme,jms:jme,num_moist)
      real, intent(in ) :: chem(ims:ime,kms:kme,jms:jme,num_chem)

      real, dimension( ims:ime, kms:kme, jms:jme ), &
            intent(in ) :: tauaer1, tauaer2, tauaer3, tauaer4, &
                             waer1, waer2, waer3, waer4, &
                             gaer1, gaer2, gaer3, gaer4

      real, dimension( ims:ime, kms:kme, jms:jme ), &
            intent(out ) :: ph_no2, ph_o31d, ph_o33p, ph_hono, &
                             ph_hno3, ph_hno4, ph_no3o2, ph_no3o, &
                             ph_h2o2, ph_ch2om, ph_ch2or, ph_ald, &
                             ph_op1, ph_op2, ph_paa, ph_ket, ph_glya, &
                             ph_glyb, ph_mgly, ph_dcb, &
                             ph_onit, ph_macr, ph_ch3coc2h5, ph_n2o, &
                             ph_pan, ph_mpan, ph_acetol, ph_gly, &
                             ph_bigald, ph_mek, ph_c2h5ooh, ph_c3h7ooh,&
                             ph_pooh,ph_rooh,ph_xooh,ph_isopooh, &
                             ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh, &
                             ph_n2o5,ph_mvk,ph_glyald,ph_hyac

      real, dimension( ims:ime, nref, jms:jme, nw-1 ), &
            intent(out ) :: ph_radfld
      real, dimension( ims:ime, nref, jms:jme, tuv_jmax ), &
            intent(out ) :: ph_adjcoe
      real, dimension( ims:ime, nref, jms:jme, tuv_jmax ), &
            intent(out ) :: ph_prate
      real, dimension(nw-1), &
            intent(out ) :: wc_x
      real, dimension(nref), &
            intent(out ) :: zref_x

      real(dp), parameter :: xair_kg = 1.0e3_dp/28.97_dp*6.023e23_dp*1.0e-6_dp
      real(dp), parameter :: ph_no3o_factor = 1.1236_dp
      real(dp), parameter :: kg_per_amu = 1.65979e-27_dp

      integer :: i, j, k, kp1, m
      integer :: astat, istat
      integer :: isorg
      integer :: lu
      real(dp) :: xtime, xhour, xmin, gmtp
      real(dp) :: wrk, qs, es
      real(dp) :: alat, along, azim, zen
      real(dp) :: o3top
      real(dp) :: o2top
      real(dp) :: atm_mass_den

      real(dp) :: zen_angle(its:ite,jts:jte)
      real(dp) :: temp(kts:kte+1), o3(kts:kte+1), air(kts:kte+1)
      real(dp) :: zh(kts:kte+1), rh(kts:kte+1), xlwc(kts:kte+1)

      real(dp) :: acb1(kts:kte+1), acb2(kts:kte+1), aoc1(kts:kte+1), aoc2(kts:kte+1)
      real(dp) :: aant(kts:kte+1), aso4(kts:kte+1), asal(kts:kte+1)

      real(dp) :: tauaer300(kts:kte), tauaer400(kts:kte+1), &
                  tauaer600(kts:kte), tauaer999(kts:kte+1)
      real(dp) :: waer300(kts:kte), waer400(kts:kte), &
                  waer600(kts:kte), waer999(kts:kte)
      real(dp) :: gaer300(kts:kte), gaer400(kts:kte), &
                  gaer600(kts:kte), gaer999(kts:kte)

      real(dp) :: p_jtop(its:ite,jts:jte)
      real(dp) :: o2_exo_col(its:ite,jts:jte)
      real(dp) :: o3_exo_col(its:ite,jts:jte)
      real(dp) :: prate(kts:kte+1,tuv_jmax)
      real(dp) :: radfld(nz,nw-1)
      real(dp) :: adjcoe(nz,tuv_jmax)
      real(dp) :: prate0(nz,tuv_jmax)

      if( config_flags%chem_opt == MOZART_KPP .or. &
          config_flags%chem_opt == MOZCART_KPP .or. &
          config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
         p_jtop(its:ite,jts:jte) = Pa2hPa * p_phy(its:ite,kte,jts:jte)
         call p_interp( o2_exo_col, o3_exo_col, p_jtop, &
                        id, its, ite, jts, jte )
      else
         o2top = 3.60906e+21_dp
         o3top = 2.97450e+16_dp
      endif

      isorg=0
      aer_select: SELECT CASE(config_flags%chem_opt)
         CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RADM2SORG_AQCHEM,RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP, &
               RACM_ESRLSORG_AQCHEM_KPP,CBMZSORG,CBMZSORG_AQ)
             isorg=1
             CALL wrf_debug(15,'SORGAM aerosols initialization ')
         CASE DEFAULT
             CALL wrf_debug(15,'no aerosols initialization yet')
             CALL wrf_message('no aerosols initialization yet')
   END SELECT aer_select

      xtime = curr_secs/60._dp
      xhour = real( int(gmt + .01_dp) + int(xtime/m2s),kind=dp )
      xmin = m2s*gmt + ( xtime - xhour*m2s )
      gmtp = mod( xhour, 24.0_dp )
      gmtp = gmtp + xmin/m2s

      xlwc(:) = 0._dp

      J_TILE_LOOP : do j = jts, jte
      I_TILE_LOOP : do i = its, ite

        if( config_flags%chem_opt == MOZART_KPP .or. &
            config_flags%chem_opt == MOZCART_KPP .or. &
            config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then

           if( luse2usgs( ivgtyp(i,j) ) /= 16 ) then

              lu = 1
           else
              lu = 2
           endif
        else
           lu = 1
        endif

        if( config_flags%chem_opt == MOZART_KPP .or. &
            config_flags%chem_opt == MOZCART_KPP .or. &
            config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
           o3top = o3_exo_col(i,j)
           o2top = o2_exo_col(i,j)
        endif

level_loop : &
        do k = kts, kte
          kp1 = k + 1
          temp(kp1) = t_phy(i,k,j)
          air(kp1) = xair_kg*rho_phy(i,k,j)
          o3(kp1) = chem(i,k,j,p_o3)*1.0e-6_dp

          wrk = t_phy(i,k,j) - 273._dp
          es = 6.11_dp*10.0_dp**(7.63_dp*wrk/(241.9_dp + wrk))
          qs = 0.622_dp*es/(p_phy(i,k,j)*0.01_dp)
          wrk = moist(i,k,j,p_qv)/qs
          rh(kp1) = max( 0.0_dp, min( 1.0_dp, wrk) )

          if( p_qc > 1 ) then
             xlwc(kp1) = 1.0e3_dp*moist(i,k,j,p_qc)*rho_phy(i,k,j)
          end if
          if( xlwc(kp1) < 1.0e-6_dp ) then
             xlwc(kp1) = 0.0_dp
          end if

          zh(kp1) = .5_dp*(z_at_w(i,kp1,j)+z_at_w(i,k,j))*0.001_dp - z_at_w(i,kts,j)*0.001_dp
          acb1(kp1) = 0._dp
          acb2(kp1) = 0._dp
          aoc1(kp1) = 0._dp
          aoc2(kp1) = 0._dp
          aant(kp1) = 0._dp
          aso4(kp1) = 0._dp
          asal(kp1) = 0._dp
          tauaer300(k) = 0._dp
          tauaer400(k) = 0._dp
          tauaer600(k) = 0._dp
          tauaer999(k) = 0._dp
          waer300(k) = 0._dp
          waer400(k) = 0._dp
          waer600(k) = 0._dp
          waer999(k) = 0._dp
          gaer300(k) = 0._dp
          gaer400(k) = 0._dp
          gaer600(k) = 0._dp
          gaer999(k) = 0._dp
          if( isorg == 1 ) then
             acb1(kp1) = chem(i,k,j,p_ecj)
             aoc1(kp1) = chem(i,k,j,p_orgpaj)
             aant(kp1) = chem(i,k,j,p_no3aj) + chem(i,k,j,p_nh4aj)
             aso4(kp1) = chem(i,k,j,p_so4aj)
             asal(kp1) = chem(i,k,j,p_seas)
          elseif( config_flags%chem_opt == MOZART_KPP .or. &
                  config_flags%chem_opt == MOZCART_KPP ) then
             aso4(kp1) = chem(i,k,j,p_sulf)*air(kp1)*real(mw_so4_aer,kind=dp)*kg_per_amu*1.e-9_dp
            if( config_flags%chem_opt == MOZCART_KPP ) then
             atm_mass_den = rho_phy(i,k,j)
             acb1(kp1) = chem(i,k,j,p_bc1)*atm_mass_den
             acb2(kp1) = chem(i,k,j,p_bc2)*atm_mass_den
             aoc1(kp1) = chem(i,k,j,p_oc1)*atm_mass_den
             aoc2(kp1) = chem(i,k,j,p_oc2)*atm_mass_den
             asal(kp1) = (chem(i,k,j,p_seas_1) + chem(i,k,j,p_seas_2) &
                          + chem(i,k,j,p_seas_3) + chem(i,k,j,p_seas_4))*atm_mass_den
            endif
          endif
          if(config_flags%aer_ra_feedback == 1) then
             tauaer300(k) = tauaer1(i,k,j)
             tauaer400(k) = tauaer2(i,k,j)
             tauaer600(k) = tauaer3(i,k,j)
             tauaer999(k) = tauaer4(i,k,j)
             waer300(k) = waer1(i,k,j)
             waer400(k) = waer2(i,k,j)
             waer600(k) = waer3(i,k,j)
             waer999(k) = waer4(i,k,j)
             gaer300(k) = gaer1(i,k,j)
             gaer400(k) = gaer2(i,k,j)
             gaer600(k) = gaer3(i,k,j)
             gaer999(k) = gaer4(i,k,j)
          endif
        enddo level_loop
        temp(1) = t8w(i,kts,j)
        air(1) = xair_kg*( p8w(i,kts,j)/t8w(i,kts,j)/r_d )
        o3(1) = o3(2)
        rh(1) = rh(2)
        xlwc(1) = 0._dp
        zh(1) = 0._dp
        acb1(1) = acb1(2)
        acb2(1) = acb2(2)
        aoc1(1) = aoc1(2)
        aoc2(1) = aoc2(2)
        aant(1) = aant(2)
        aso4(1) = aso4(2)
        asal(1) = asal(2)
        do k = kts+1, kte-1
          air(k) = .5_dp*air(k) + .25_dp*( air(k-1) + air(k+1) )
        enddo
       alat = real(xlat(i,j),kind=dp)
       along = -real(xlong(i,j),kind=dp)
       call calc_zenith( alat, along, julday, gmtp, azim, zen )
       zen_angle(i,j) = zen
       call photo( config_flags%chem_opt,&
                   kte+1, &
                   tuv_jmax, &
                   julday, &
                   gmtp, &
                   alat, along, &
                   o3top, o2top, dobson, &
                   lu, &
                   zh, &
                   temp, &
                   air, &
                   rh, &
                   xlwc, &
                   o3, &
                   acb1, &
                   acb2, &
                   aoc1, &
                   aoc2, &
                   aant, &
                   aso4, &
                   asal, &
                   tauaer300, tauaer400, &
                   tauaer600, tauaer999, &
                   waer300, waer400, &
                   waer600, waer999, &
                   gaer300, gaer400, &
                   gaer600, gaer999, &
                   config_flags%aer_ra_feedback, &
                   prate, &
                   radfld, &
                   adjcoe, &
                   prate0 )
        do k = kts, kte
          ph_no2(i,k,j) = max( 0._dp,prate(k,pid_no2)*m2s )
          ph_o31d(i,k,j) = max( 0._dp,prate(k,pid_o31d)*m2s )
          ph_o33p(i,k,j) = max( 0._dp,prate(k,pid_o33p)*m2s )
          ph_hono(i,k,j) = max( 0._dp,prate(k,pid_hono)*m2s )
          ph_hno3(i,k,j) = max( 0._dp,prate(k,pid_hno3)*m2s )
          ph_hno4(i,k,j) = max( 0._dp,prate(k,pid_hno4)*m2s )
          ph_no3o2(i,k,j) = max( 0._dp,prate(k,pid_no3o2)*m2s )
          ph_no3o(i,k,j) = max( 0._dp,prate(k,pid_no3o)*m2s*ph_no3o_factor )
          ph_h2o2(i,k,j) = max( 0._dp,prate(k,pid_h2o2)*m2s )
          ph_ch2om(i,k,j) = max( 0._dp,prate(k,pid_ch2om)*m2s )
          ph_ch2or(i,k,j) = max( 0._dp,prate(k,pid_ch2or)*m2s )
          ph_ald(i,k,j) = max( 0._dp,prate(k,pid_ald)*m2s )
          ph_op1(i,k,j) = max( 0._dp,prate(k,pid_op1)*m2s )
          ph_op2(i,k,j) = max( 0._dp,prate(k,pid_op2)*m2s )
          ph_paa(i,k,j) = max( 0._dp,prate(k,pid_paa)*m2s )
          ph_ket(i,k,j) = max( 0._dp,prate(k,pid_ket)*m2s )
          ph_glya(i,k,j) = max( 0._dp,prate(k,pid_glya)*m2s )
          ph_glyb(i,k,j) = max( 0._dp,prate(k,pid_glyb)*m2s )
          ph_mgly(i,k,j) = max( 0._dp,prate(k,pid_mgly)*m2s )
          ph_dcb(i,k,j) = max( 0._dp,prate(k,pid_dcb)*m2s )
          ph_onit(i,k,j) = max( 0._dp,prate(k,pid_onit)*m2s )
          ph_macr(i,k,j) = max( 0._dp,prate(k,pid_macr) *m2s )
          ph_ch3coc2h5(i,k,j) = max( 0._dp,prate(k,23)*m2s )
        enddo
        wc_x(1:nw-1) = wc(1:nw-1)
        zref_x(1:nref) = zref(1:nref)
        if( config_flags%chem_opt == MOZART_KPP .or. &
            config_flags%chem_opt == MOZCART_KPP .or. &
            config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
          do k = kts, kte
            ph_n2o(i,k,j) = max( 0._dp,prate(k,pid_n2o)*m2s )
            ph_n2o5(i,k,j) = max( 0._dp,prate(k,pid_n2o5)*m2s )
            ph_mvk(i,k,j) = max( 0._dp,prate(k,pid_mvk)*m2s )
            ph_pan(i,k,j) = max( 0._dp,prate(k,pid_pan)*m2s )
            ph_ald(i,k,j) = max( 0._dp,(prate(k,pid_ch3choa)+prate(k,pid_ch3chob)+prate(k,pid_ch3choc))*m2s )
            ph_gly(i,k,j) = ph_mgly(i,k,j)
            ph_mek(i,k,j) = ph_ket(i,k,j)
            ph_acetol(i,k,j) = ph_op1(i,k,j)
            ph_pooh(i,k,j) = ph_op1(i,k,j)
            ph_glyald(i,k,j) = max( 0._dp,prate(k,pid_glyald) *m2s )
            ph_hyac(i,k,j) = max( 0._dp,2._dp*prate(k,pid_hyac) *m2s )
            ph_hno4(i,k,j) = ph_hno4(i,k,j) + 1.e-5_dp*m2s
          enddo
        end if
      enddo I_TILE_LOOP
      enddo J_TILE_LOOP
      end subroutine ftuv_driver
      subroutine ftuv_init( id,ips, ipe, jps, jpe, kte, &
                            ide, jde, config_flags, num_land_cat, mminlu_loc)
      use module_state_description, only : mozart_kpp, mozcart_kpp, mozart_mosaic_4bin_vbs0_kpp
      use module_ftuv_subs, only : aer_init
      use module_configure, only : grid_config_rec_type
      implicit none
      integer, intent(in) :: id
      integer, intent(in) :: ips, ipe, jps, jpe, kte
      integer, intent(in) :: ide, jde
      integer, intent(in) :: num_land_cat
      character(len=*), intent(in) :: mminlu_loc
      type(grid_config_rec_type), intent(in ) :: config_flags
      integer :: astat
      integer :: ncid
      integer :: dimid
      integer :: varid
      integer :: max_dom
      integer :: cpos
      integer :: iend, jend
      integer :: lon_e, lat_e
      integer :: ncoldens_levs
      integer :: ndays_of_year
      integer :: i
      real, allocatable :: coldens(:,:,:,:)
      character(len=128) :: err_msg
      character(len=64) :: filename
      character(len=3) :: id_num
      LOGICAL , EXTERNAL :: wrf_dm_on_monitor
include 'netcdf.inc'
      if( id == 1 .and. .not. photo_inti_initialized ) then
        write(err_msg,*) 'ftuv_init: calling photo_inti for id = ',id
        call wrf_message( trim(err_msg) )
        call photo_inti( config_flags%chem_opt, kte, 20._dp )
      endif
is_mozart : &
      if( config_flags%chem_opt == MOZART_KPP .or. &
          config_flags%chem_opt == MOZCART_KPP .or. &
          config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
        if( id == 1 .and. .not. allocated(col_dens) ) then
          CALL nl_get_max_dom( 1,max_dom )
          allocate( col_dens(max_dom),stat=astat )
          if( astat /= 0 ) then
            CALL wrf_message( 'ftuv_init: failed to allocate column_density type col_dens' )
            CALL wrf_abort
          end if
          write(err_msg,*) 'ftuv_init: intializing ',max_dom,' domains'
          call wrf_message( trim(err_msg) )
          col_dens(:)%is_allocated = .false.
        endif
col_dens_allocated : &
        if( .not. col_dens(id)%is_allocated ) then
          if( wrf_dm_on_monitor() ) then
            cpos = index( config_flags%exo_coldens_inname, '<domain>' )
            if( cpos > 0 ) then
              write(id_num,'(i3)') 100+id
              filename = config_flags%exo_coldens_inname(:cpos-1) // 'd' // id_num(2:3)
            else
              filename = trim( config_flags%exo_coldens_inname )
            endif
            err_msg = 'ftuv_init: intializing domain ' // id_num(2:3)
            call wrf_message( trim(err_msg) )
            err_msg = 'ftuv_init: failed to open file ' // trim(filename)
            call handle_ncerr( nf_open( trim(filename), nf_noclobber, ncid ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get col_dens levels id'
             call handle_ncerr( nf_inq_dimid( ncid, 'coldens_levs', dimid ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get col_dens levels'
             call handle_ncerr( nf_inq_dimlen( ncid, dimid, ncoldens_levs ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get number of days in year id'
             call handle_ncerr( nf_inq_dimid( ncid, 'ndays_of_year', dimid ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get number of days in year'
             call handle_ncerr( nf_inq_dimlen( ncid, dimid, ndays_of_year ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get west_east id'
             call handle_ncerr( nf_inq_dimid( ncid, 'west_east', dimid ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get west_east'
             call handle_ncerr( nf_inq_dimlen( ncid, dimid, lon_e ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get south_north id'
             call handle_ncerr( nf_inq_dimid( ncid, 'south_north', dimid ), trim(err_msg) )
             err_msg = 'ftuv_init: failed to get south_north'
             call handle_ncerr( nf_inq_dimlen( ncid, dimid, lat_e ), trim(err_msg) )
          end IF
          CALL wrf_dm_bcast_bytes ( ncoldens_levs , 4 )
          CALL wrf_dm_bcast_bytes ( ndays_of_year , 4 )
          CALL wrf_dm_bcast_bytes ( lon_e , 4 )
          CALL wrf_dm_bcast_bytes ( lat_e , 4 )
          iend = min( ipe,ide-1 )
          jend = min( jpe,jde-1 )
          allocate( coldens(lon_e,lat_e,ncoldens_levs,ndays_of_year), stat=astat )
          if( astat /= 0 ) then
            call wrf_message( 'ftuv_init: failed to allocate coldens' )
            call wrf_abort
          end if
          col_dens(id)%ncoldens_levs = ncoldens_levs
          col_dens(id)%ndays_of_year = ndays_of_year
          allocate( col_dens(id)%col_levs(ncoldens_levs), &
                    col_dens(id)%day_of_year(ndays_of_year), stat=astat )
          if( astat /= 0 ) then
            call wrf_message( 'ftuv_init: failed to allocate col_levs,day_of_year' )
            call wrf_abort
          end if
          allocate( col_dens(id)%o3_col_dens(ips:iend,jps:jend,ncoldens_levs,ndays_of_year), &
                    col_dens(id)%o2_col_dens(ips:iend,jps:jend,ncoldens_levs,ndays_of_year), stat=astat )
          if( astat /= 0 ) then
            call wrf_message( 'ftuv_init: failed to allocate o3_col_dens,o2_col_dens' )
            call wrf_abort
          end if
          col_dens(id)%is_allocated = .true.
            IF ( wrf_dm_on_monitor() ) THEN
            err_msg = 'ftuv_init: failed to get col_levs variable id'
            call handle_ncerr( nf_inq_varid( ncid, 'coldens_levs', varid ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to read col_levs variable'
            call handle_ncerr( nf_get_var_double( ncid, varid, col_dens(id)%col_levs ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to get days_of_year variable id'
            call handle_ncerr( nf_inq_varid( ncid, 'days_of_year', varid ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to read days_of_year variable'
            call handle_ncerr( nf_get_var_double( ncid, varid, col_dens(id)%day_of_year ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to col_dens variable id'
            call handle_ncerr( nf_inq_varid( ncid, 'o3_column_density', varid ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to read col_dens variable'
            call handle_ncerr( nf_get_var_real( ncid, varid, coldens ), trim(err_msg) )
          end if
          CALL wrf_dm_bcast_bytes ( col_dens(id)%col_levs , size ( col_dens(id)%col_levs ) * 8 )
          write(*,*) 'ftuv_init: bcast col_levs'
          CALL wrf_dm_bcast_bytes ( col_dens(id)%day_of_year , size ( col_dens(id)%day_of_year ) * 8 )
          write(*,*) 'ftuv_init: bcast day_of_year'
          CALL wrf_dm_bcast_bytes ( coldens, size(coldens)*4 )
          write(*,*) 'ftuv_init: bcast o3_col_dens'
          col_dens(id)%o3_col_dens(ips:iend,jps:jend,:ncoldens_levs,:ndays_of_year) = &
                        coldens(ips:iend,jps:jend,:ncoldens_levs,:ndays_of_year)
          IF ( wrf_dm_on_monitor() ) THEN
            err_msg = 'ftuv_init: failed to col_dens variable id'
            call handle_ncerr( nf_inq_varid( ncid, 'o2_column_density', varid ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to read col_dens variable'
            call handle_ncerr( nf_get_var_real( ncid, varid, coldens ), trim(err_msg) )
            err_msg = 'ftuv_init: failed to close file ' // trim(filename)
            call handle_ncerr( nf_close( ncid ), trim(err_msg) )
          end if
          CALL wrf_dm_bcast_bytes ( coldens, size(coldens)*4 )
          write(*,*) 'ftuv_init: bcast o2_col_dens'
          col_dens(id)%o2_col_dens(ips:iend,jps:jend,:ncoldens_levs,:ndays_of_year) = &
                        coldens(ips:iend,jps:jend,:ncoldens_levs,:ndays_of_year)
          deallocate( coldens )
          write(*,*) ' '
          write(*,*) 'ftuv_init: coldens variables for domain ',id
          write(*,*) 'ftuv_init: days_of_year'
          write(*,'(1p,5g15.7)') col_dens(id)%day_of_year(:)
          write(*,*) 'ftuv_init: coldens levels'
          write(*,'(1p,5g15.7)') col_dens(id)%col_levs(:)
          write(*,*) ' '
        endif col_dens_allocated
        if( id == 1 ) then
          print*,"num_land_cat: ", num_land_cat
          allocate( luse2usgs(num_land_cat),stat=astat )
          if( astat /= 0 ) then
            CALL wrf_message( 'ftuv_init: failed to allocate luse2usgs')
            CALL wrf_abort
          end if
          if( trim(mminlu_loc) == 'USGS' ) then
            luse2usgs(:) = (/ (i,i=1,num_land_cat) /)
          elseif( trim(mminlu_loc) == 'MODIFIED_IGBP_MODIS_NOAH' ) then
            luse2usgs(:) = (/ 14,13,12,11,15,8,9,10,10,7, &
                              17,4,1,5,24,19,16,21,22,23 /)
          endif
        endif
      endif is_mozart
      if( id == 1 .and. .not. photo_inti_initialized ) then
        write(*,*) 'ftuv_init: initializing aerosol routine'
        call aer_init
        write(*,*) 'ftuv_init: finished'
        photo_inti_initialized = .true.
      endif
      end subroutine ftuv_init
      subroutine handle_ncerr( ret, mes )
      implicit none
      integer, intent(in) :: ret
      character(len=*), intent(in) :: mes
include 'netcdf.inc'
      if( ret /= nf_noerr ) then
         call wrf_message( trim(mes) )
         call wrf_message( trim(nf_strerror(ret)) )
         call wrf_abort
      end if
      end subroutine handle_ncerr
      subroutine photo_inti( chem_opt, nlev, ztopin )
      use module_wave_data, only : nw, wl, wave_data_inti
      use module_ftuv_subs, only : nwint, wlint, schu_inti, inter_inti
      use module_state_description, only : mozart_kpp, mozcart_kpp, mozart_mosaic_4bin_vbs0_kpp
      implicit none
      integer, intent(in) :: chem_opt
      integer, intent(in) :: nlev
      real(dp), intent(in) :: ztopin
      integer :: k, kdis, nabv, iw
      real(dp) :: ztop
      if( chem_opt /= MOZART_KPP .and. &
          chem_opt /= MOZCART_KPP .and. &
          chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then
         ztop = ztopin
         do k = 1,nref
           if( ztop < zref(k) ) then
              exit
           end if
         enddo
         if( k == 1 .or. k > nref ) then
           call wrf_message( 'photo_inti: ztop is not in zref range' )
           call wrf_abort
         endif
         kcon = k + 1
         kdis = nref - kcon
         nabv = kdis/2 + 1
         if( mod(kdis,2) /= 0 ) then
           nabv = nabv + 1
         endif
         nz = nlev + nabv
         write(*,*) '******************************************'
         write(*,*) 'photo_inti: kcon,kdis,nabv,nlev,nz = ',kcon,kdis,nabv,nlev,nz
         write(*,*) '******************************************'
         dobson = 265.0_dp
      else
         nz = nlev
         dobson = 0._dp
      endif
      do iw = 1, nw-1
        if( wl(iw)<400.0_dp ) then
           albedo(iw,1) = 0.05_dp
        else if( (wl(iw)>=400.0_dp ) .and. (wl(iw)<450.0_dp) ) then
           albedo(iw,1) = 0.06_dp
        else if( (wl(iw)>=450.0_dp ) .and. (wl(iw)<500.0_dp) ) then
           albedo(iw,1) = 0.08_dp
        else if( (wl(iw)>=500.0_dp ) .and. (wl(iw)<550.0_dp) ) then
           albedo(iw,1) = 0.10_dp
        else if( (wl(iw)>=550.0_dp ) .and. (wl(iw)<600.0_dp) ) then
           albedo(iw,1) = 0.11_dp
        else if( (wl(iw)>=600.0_dp ) .and. (wl(iw)<640.0_dp) ) then
           albedo(iw,1) = 0.12_dp
        else if( (wl(iw)>=640.0_dp ) .and. (wl(iw)<660.0_dp) ) then
           albedo(iw,1) = 0.135_dp
        else if( wl(iw)>=660.0_dp ) then
           albedo(iw,1) = 0.15_dp
        end if
      end do
      if( chem_opt == MOZART_KPP .or. &
          chem_opt == MOZCART_KPP .or. &
          chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
         albedo(1:17,2) = (/ 0.0747_dp, 0.0755_dp, 0.0767_dp, 0.0783_dp, 0.0802_dp, &
                             0.0825_dp, 0.0852_dp, 0.0882_dp, 0.0914_dp, 0.0908_dp, &
                             0.0763_dp, 0.0725_dp, 0.0689_dp, 0.0632_dp, 0.0570_dp, &
                             0.0585_dp, 0.0535_dp /)
      else
         albedo(1:17,2) = (/ 0.8228_dp, 0.8140_dp, 0.8000_dp, 0.7820_dp, 0.7600_dp, &
                             0.7340_dp, 0.7040_dp, 0.6700_dp, 0.6340_dp, 0.4782_dp, &
                             0.3492_dp, 0.3000_dp, 0.2700_dp, 0.2400_dp, 0.1700_dp, &
                             0.0800_dp, 0.0600_dp /)
      endif
      call schu_inti
      call wave_data_inti( nz )
      call inter_inti( nw, wl, nwint, wlint )
      end subroutine photo_inti
      subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, &
                        along, o3top, o2top, o3toms, lu, zin, tlevin, &
                        airlevin, rhin, xlwcin, o3in, acb1in, &
                        acb2in, aoc1in, aoc2in, aantin, aso4in, &
                        asalin, tauaer300in,tauaer400in,tauaer600in,tauaer999in, &
                        waer300in, waer400in, waer600in, waer999in, &
                        gaer300in, gaer400in, gaer600in, gaer999in, &
                        aer_ra_feedback, prate, radfld, adjcoe, prate0 )
      use module_ftuv_subs, only : calc_zenith, photoin
      implicit none
      integer, intent(in) :: chem_opt
      integer, intent(in) :: lu
      integer, intent(in) :: nlev, njout
      integer, intent(in) :: julday
      real(dp), intent(in) :: gmtp
      real(dp), intent(in) :: alat, along
      real(dp), intent(in) :: o3toms
      real(dp), intent(in) :: o3top
      real(dp), intent(in) :: o2top
      real(dp), intent(in) :: zin(nlev)
      real(dp), intent(in) :: tlevin(nlev)
      real(dp), intent(in) :: airlevin(nlev)
      real(dp), intent(in) :: rhin(nlev)
      real(dp), intent(in) :: xlwcin(nlev)
      real(dp), intent(in) :: o3in(nlev)
      real(dp), intent(in) :: acb1in(nlev)
      real(dp), intent(in) :: acb2in(nlev)
      real(dp), intent(in) :: aoc1in(nlev)
      real(dp), intent(in) :: aoc2in(nlev)
      real(dp), intent(in) :: aantin(nlev)
      real(dp), intent(in) :: aso4in(nlev)
      real(dp), intent(in) :: asalin(nlev)
      real(dp), intent(in) :: tauaer300in(nlev-1)
      real(dp), intent(in) :: tauaer400in(nlev-1)
      real(dp), intent(in) :: tauaer600in(nlev-1)
      real(dp), intent(in) :: tauaer999in(nlev-1)
      real(dp), intent(in) :: waer300in(nlev-1)
      real(dp), intent(in) :: waer400in(nlev-1)
      real(dp), intent(in) :: waer600in(nlev-1)
      real(dp), intent(in) :: waer999in(nlev-1)
      real(dp), intent(in) :: gaer300in(nlev-1)
      real(dp), intent(in) :: gaer400in(nlev-1)
      real(dp), intent(in) :: gaer600in(nlev-1)
      real(dp), intent(in) :: gaer999in(nlev-1)
      INTEGER, INTENT(IN) :: aer_ra_feedback
      real(dp), intent(out) :: prate(nlev,njout)
      real(dp), intent(out) :: radfld(nz,nw-1)
      real(dp), intent(out) :: adjcoe(nz,njout)
      real(dp), intent(out) :: prate0(nz,njout)
      integer :: astat, istat
      integer :: k, n
      real(dp) :: azim, zen
      real(dp), allocatable :: z_ph(:), tlev_ph(:), tlay_ph(:), airlev_ph(:)
      real(dp), allocatable :: rh_ph(:), xlwc_ph(:)
      real(dp), allocatable :: o3_ph(:)
      real(dp), allocatable :: acb1_ph(:), acb2_ph(:)
      real(dp), allocatable :: aoc1_ph(:), aoc2_ph(:)
      real(dp), allocatable :: aant_ph(:), aso4_ph(:), asal_ph(:)
      real(dp), allocatable :: tauaer300_ph(:), tauaer400_ph(:), &
                               tauaer600_ph(:), tauaer999_ph(:), &
                               waer300_ph(:), waer400_ph(:), &
                               waer600_ph(:), waer999_ph(:), &
                               gaer300_ph(:), gaer400_ph(:), &
                               gaer600_ph(:), gaer999_ph(:)
      real(dp), allocatable :: ftuv(:,:)
      call calc_zenith( alat, along, julday, gmtp, azim, zen )
      if( zen == 90.0_dp ) then
        zen = 89.0_dp
      elseif( zen >= 95.0_dp ) then
        prate(:,:) = 0.0_dp
        return
      endif
      astat = 0
      allocate( ftuv(nz,njout), stat=istat )
      astat = astat + istat
      allocate( z_ph(nz), tlev_ph(nz), tlay_ph(nz-1), airlev_ph(nz), stat=istat )
      astat = astat + istat
      allocate( rh_ph(nz), xlwc_ph(nz), stat=istat )
      astat = astat + istat
      allocate( o3_ph(nz), stat=istat )
      astat = astat + istat
      allocate( acb1_ph(nz), acb2_ph(nz), aoc1_ph(nz), aoc2_ph(nz), stat=istat )
      astat = astat + istat
      allocate( aant_ph(nz), aso4_ph(nz), asal_ph(nz), stat=istat )
      astat = astat + istat
      allocate( tauaer300_ph(nz-1), tauaer400_ph(nz-1), tauaer600_ph(nz-1), &
                tauaer999_ph(nz-1), stat=istat)
      astat = astat + istat
      allocate( waer300_ph(nz-1), waer400_ph(nz-1), waer600_ph(nz-1), &
                waer999_ph(nz-1), stat=istat)
      astat = astat + istat
      allocate( gaer300_ph(nz-1), gaer400_ph(nz-1), gaer600_ph(nz-1), &
                gaer999_ph(nz-1), stat=istat)
      astat = astat + istat
      if( astat /= 0 ) then
         call wrf_message( 'ftuv_driver: failed to allocate _ph arrays' )
         call wrf_abort
      endif
      rh_ph(:) = 0.0_dp
      xlwc_ph(:) = 0.0_dp
      acb1_ph(:) = 0.0_dp
      acb2_ph(:) = 0.0_dp
      aoc1_ph(:) = 0.0_dp
      aoc2_ph(:) = 0.0_dp
      aant_ph(:) = 0.0_dp
      aso4_ph(:) = 0.0_dp
      asal_ph(:) = 0.0_dp
      tauaer300_ph(:) = 0.0_dp
      tauaer400_ph(:) = 0.0_dp
      tauaer600_ph(:) = 0.0_dp
      tauaer999_ph(:) = 0.0_dp
      waer300_ph(:) = 0.0_dp
      waer400_ph(:) = 0.0_dp
      waer600_ph(:) = 0.0_dp
      waer999_ph(:) = 0.0_dp
      gaer300_ph(:) = 0.0_dp
      gaer400_ph(:) = 0.0_dp
      gaer600_ph(:) = 0.0_dp
      gaer999_ph(:) = 0.0_dp
      z_ph(1:nlev) = zin(1:nlev)
      tlev_ph(1:nlev) = tlevin(1:nlev)
      airlev_ph(1:nlev) = airlevin(1:nlev)
      rh_ph(1:nlev) = rhin(1:nlev)
      xlwc_ph(1:nlev) = xlwcin(1:nlev)
      o3_ph(1:nlev) = o3in(1:nlev)
      acb1_ph(1:nlev) = acb1in(1:nlev)
      acb2_ph(1:nlev) = acb2in(1:nlev)
      aoc1_ph(1:nlev) = aoc1in(1:nlev)
      aoc2_ph(1:nlev) = aoc2in(1:nlev)
      aant_ph(1:nlev) = aantin(1:nlev)
      aso4_ph(1:nlev) = aso4in(1:nlev)
      asal_ph(1:nlev) = asalin(1:nlev)
      tauaer300_ph(1:nlev-1) = tauaer300in(1:nlev-1)
      tauaer400_ph(1:nlev-1) = tauaer400in(1:nlev-1)
      tauaer600_ph(1:nlev-1) = tauaer600in(1:nlev-1)
      tauaer999_ph(1:nlev-1) = tauaer999in(1:nlev-1)
      waer300_ph(1:nlev-1) = waer300in(1:nlev-1)
      waer400_ph(1:nlev-1) = waer400in(1:nlev-1)
      waer600_ph(1:nlev-1) = waer600in(1:nlev-1)
      waer999_ph(1:nlev-1) = waer999in(1:nlev-1)
      gaer300_ph(1:nlev-1) = gaer300in(1:nlev-1)
      gaer400_ph(1:nlev-1) = gaer400in(1:nlev-1)
      gaer600_ph(1:nlev-1) = gaer600in(1:nlev-1)
      gaer999_ph(1:nlev-1) = gaer999in(1:nlev-1)
      tlay_ph(1:nlev-1) = 0.5_dp*(tlev_ph(1:nlev-1) + tlev_ph(2:nlev))
      if( nz > nlev ) then
         z_ph(nlev+1:nz-1) = zref(kcon:nref:2)
         tlev_ph(nlev+1:nz-1) = tref(kcon:nref:2)
         airlev_ph(nlev+1:nz-1) = airref(kcon:nref:2)
         o3_ph(nlev+1:nz-1) = o3ref(kcon:nref:2)/airref(kcon:nref:2)
         z_ph(nz) = zref(nref)
         tlev_ph(nz) = tref(nref)
         airlev_ph(nz) = airref(nref)
         o3_ph(nz) = o3ref(nref)/airref(nref)
         tlay_ph(nlev) = 0.5_dp*(tlev_ph(nlev) + tref(kcon))
         tlay_ph(nlev+1:) = 0.5_dp*( tlev_ph(nlev+1:nz-1) + tlev_ph(nlev+2:) )
      end if
      call photoin( chem_opt, nz, zen, o3toms, esfact, &
                    o3top, o2top, albedo(:,lu), z_ph, tlev_ph, &
                    tlay_ph, airlev_ph, rh_ph, xlwc_ph, o3_ph, &
                    acb1_ph, acb2_ph, aoc1_ph, aoc2_ph, aant_ph, &
                    aso4_ph, asal_ph, &
                    tauaer300_ph, tauaer400_ph, tauaer600_ph, &
                    tauaer999_ph, waer300_ph, waer400_ph, &
                    waer600_ph, waer999_ph, gaer300_ph, &
                    gaer400_ph, gaer600_ph, gaer999_ph, &
                    aer_ra_feedback, ftuv, adjcoe, radfld )
      do n = 1,njout
        prate(1:nlev-1,n) = ftuv(2:nlev,n)
        prate0(1:nz,n) = ftuv(1:nz,n)
      enddo
      deallocate( ftuv, z_ph, tlev_ph, tlay_ph, airlev_ph, rh_ph, xlwc_ph, &
                  o3_ph, acb1_ph, acb2_ph, aoc1_ph, aoc2_ph, aant_ph, aso4_ph, &
                  asal_ph, tauaer300_ph, tauaer400_ph,tauaer600_ph, tauaer999_ph, &
                  waer300_ph, waer400_ph, waer600_ph, waer999_ph, &
                  gaer300_ph, gaer400_ph, gaer600_ph, gaer999_ph )
      end subroutine photo
      subroutine ftuv_timestep_init( id, julday )
      use module_ftuv_subs, only : sundis
      implicit none
      integer, intent(in) :: id
      integer, intent(in) :: julday
      integer :: m
      real(dp) :: calday
      calday = real( julday,kind=dp)
      if( calday < col_dens(id)%day_of_year(1) ) then
         next = 1
  last = 12
  dels = (365._dp + calday - col_dens(id)%day_of_year(12)) &
                / (365._dp + col_dens(id)%day_of_year(1) - col_dens(id)%day_of_year(12))
      else if( calday >= col_dens(id)%day_of_year(12) ) then
  next = 1
  last = 12
  dels = (calday - col_dens(id)%day_of_year(12)) &
                / (365. + col_dens(id)%day_of_year(1) - col_dens(id)%day_of_year(12))
      else
         do m = 11,1,-1
     if( calday >= col_dens(id)%day_of_year(m) ) then
        exit
     end if
         end do
  last = m
  next = m + 1
  dels = (calday - col_dens(id)%day_of_year(m)) / (col_dens(id)%day_of_year(m+1) - col_dens(id)%day_of_year(m))
      end if
         if( curjulday /= julday ) then
            curjulday = julday
            call sundis( curjulday, esfact )
         endif
      end subroutine ftuv_timestep_init
      subroutine p_interp( o2_exo_col, o3_exo_col, ptop, &
                           id, its, ite, jts, jte )
      implicit none
      integer, intent(in) :: id
      integer, intent(in) :: its, ite
      integer, intent(in) :: jts, jte
      real(dp), intent(in) :: ptop(its:ite,jts:jte)
      real(dp), intent(out) :: o2_exo_col(its:ite,jts:jte)
      real(dp), intent(out) :: o3_exo_col(its:ite,jts:jte)
      integer :: i, j, k, ku, kl
      real(dp) :: pinterp
      real(dp) :: delp
      real(dp) :: tint_vals(2)
lat_loop : &
      do j = jts,jte
long_loop : &
         do i = its,ite
            pinterp = ptop(i,j)
            if( pinterp < col_dens(id)%col_levs(1) ) then
               ku = 1
               kl = 1
               delp = 0._dp
            else
        do ku = 2,col_dens(id)%ncoldens_levs
                  if( pinterp <= col_dens(id)%col_levs(ku) ) then
                     kl = ku - 1
       delp = log( pinterp/col_dens(id)%col_levs(kl) )/log( col_dens(id)%col_levs(ku)/col_dens(id)%col_levs(kl) )
       exit
           end if
        end do
            end if
     tint_vals(1) = col_dens(id)%o2_col_dens(i,j,kl,last) &
                           + delp * (col_dens(id)%o2_col_dens(i,j,ku,last) &
                                     - col_dens(id)%o2_col_dens(i,j,kl,last))
     tint_vals(2) = col_dens(id)%o2_col_dens(i,j,kl,next) &
                           + delp * (col_dens(id)%o2_col_dens(i,j,ku,next) &
                                     - col_dens(id)%o2_col_dens(i,j,kl,next))
     o2_exo_col(i,j) = tint_vals(1) + dels * (tint_vals(2) - tint_vals(1))
     tint_vals(1) = col_dens(id)%o3_col_dens(i,j,kl,last) &
                           + delp * (col_dens(id)%o3_col_dens(i,j,ku,last) &
                                     - col_dens(id)%o3_col_dens(i,j,kl,last))
     tint_vals(2) = col_dens(id)%o3_col_dens(i,j,kl,next) &
                           + delp * (col_dens(id)%o3_col_dens(i,j,ku,next) &
                                     - col_dens(id)%o3_col_dens(i,j,kl,next))
     o3_exo_col(i,j) = tint_vals(1) + dels * (tint_vals(2) - tint_vals(1))
         end do long_loop
      end do lat_loop
      end subroutine p_interp
      end module module_ftuv_driver


!***********************************************************************
!                                                                      *
      SUBROUTINE MATRIX (ncore, j2max)
!                                                                      *
!   This SUBROUTINE calls routines to  form the  Hamiltonian  matrix   *
!   and to diagonalise it.   The total angular momenta and parity of   *
!   the ASF are found;  the eigenvectors are chosen so that the sign   *
!   of the largest element is positive.                                *
!                                                                      *
!   Call(s) to: [LIB92]: ALLOC, CONVRT, DALLOC, HMOUT, IQ              *
!                        WGHTD5.                                       *
!               [RCI92]: MANEIG, QED, SETHAM.                          *
!                                                                      *
!                                         Last revision: 28 Dec 1992   *
!   Modified by Xinghong He               Last revision: 31 Dec 1997   *
!   Block version Xinghong He             Last revision: 12 Jun 1998   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE, LONG
      USE parameter_def,   ONLY: NNNW
      USE memory_man
      USE decide_C
      USE DEBUG_C
      USE def_C
      USE eigv_C
      USE hblock_C
      USE hmat_C
      USE iounit_C
      USE jlabl_C, LABJ=>JLBR, LABP=>JLBP
      USE orb_C, ONLY: ncf, nw, iqa
      USE prnt_C
      USE stat_C
      USE wave_C
      USE blim_C
      USE eigvec1_C
      USE iccu_C
      USE cteilsrk_C
      USE coeils_C
      USE bilst_C
      USE vpilst_C
      USE keilst_C
      USE vinlst_C
      USE fposition_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE auxblk_I
      USE lodcslmpi_I
      USE qed_slfen_I
      USE genmat_I
      USE genmat2_I
      USE hmout_I
      USE iq_I
      USE maneig_I
      USE engout_I
      USE wghtd5_I
      USE mpi_C

      use grasp_rciqed, only: IMCDF => res_unit, setype, sematrix
      use grasp_rciqed_qed, only: qedse
      use grasp_rciqed_cimatrixelements, only: qed_se_mohr

      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: ncore
      INTEGER,  INTENT(IN):: j2max
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      CHARACTER(LEN=8) :: CNUM
      REAL(DOUBLE) :: elsto, eau, ecm, eev, elemnt
      REAL(DOUBLE), DIMENSION(:), pointer :: etot
      INTEGER(LONG) :: nelmnt_a
      INTEGER :: iiatjpo, iiaspar
      INTEGER :: i, j, irestart, ncminpas, jblock, ic, ip, mode, k
!-----------------------------------------------
!     ...Common to all blocks - place here to save CPU time
      CALL auxblk (j2max)
      ! Populate the global array in grasp_rciqed with the matrix elements of
      ! the self-energy operator picked in GETCID.
      if(LSE) then
          call qedse(setype, sematrix)
      endif

!***************************************************************
!      Loop over blocks
!***************************************************************
      ncminpas = 0

      DO 100 jblock = 1, nblock
         ncf    =   ncfblk(jblock)
         nvec   =   nevblk(jblock)
         nvecmx = ncmaxblk(jblock)
         iccut(1)  = iccutblk(jblock)
         !.. Determine position of the previous block in the .res file

         nposition = 7 + nw + nw  ! File position of the previous block
                                  ! in the .res file
         DO i = 1, jblock - 1
            j = (ncfblk(i) - myid - 1 + nprocs) / nprocs
            IF (ncfblk(i) .LT. nprocs) j = ncfblk(i) / (myid+1)
            nposition = nposition + j + 1
         ENDDO

         !.. SETHAM does not handle this extrem case
         IF (nprocs .GT. NCF)                                          &
                         CALL stopmpi ('matrix: too many nodes', myid)

!        ...Obtain ivec() from iccmin()
         IF (nvec .GT. 0) THEN
            CALL alloc (ivec, nvec, 'IVEC', 'MATRIX')
            DO i = 1, nvec
               ivec(i) = iccmin(i+ncminpas)
            ENDDO
            ncminpas = ncminpas + nvec
         ENDIF

!        ...These 3 were allocated in lodcsh2 and deallocated at the end
!        ... of this routine and in the setham. In this block version,
!        ... both allocation and deallocation are placed here. See the
!        ... following goto 80 for reason.
         CALL ALLOC (IQA, NNNW, ncf, 'IQA', 'MATRIX')
         CALL ALLOC (JQSA, NNNW, 3, ncf, 'JQSA', 'MATRIX')
         CALL ALLOC (JCUPA, NNNW, ncf, 'JCUPA', 'MATRIX')

!      ...Load CSF list of the current block
        CALL lodcslmpi (21, ncore, jblock)

         IF (nvec <= 0) THEN
            IF (myid .EQ. 0) WRITE (25) jblock, ncf, nvec, 999, 999
!           ...Generate H matrix of the current block and write to disk
!           ...eav, nelmnt are also obtained from genmat
            CALL genmat (jblock, myid, nprocs, elsto, irestart)
             ! This call is optional, meaning the matrix of this block
               ! does not need to be computed. But don't comment it out
               ! since other programs may assume thet existence of them.
            CALL genmat2 (irestart, nelmnt_a, elsto)
            GOTO 80 ! need to clear memory
         ENDIF
!        ------------------------
         CALL genmat (jblock, myid, nprocs, elsto, irestart)
         CALL genmat2 (irestart, nelmnt_a, elsto)
!
!   Allocate and deallocate memory for the mixing coefficients
!   from the prerun
!
      IF (IPRERUN.EQ.1) CALL ALLOC (EVEC1,NCF*NVEC, 'EVEC1', 'MATRIX')
      IF (IPRERUN.EQ.2) CALL DALLOC (EVEC1, 'EVEC1', 'MATRIX')

! Since maneig needs both nelmnt and nelmnt_a, # of non-zero
! matrix elements computed by current node and the total #
! from all nodes, a new var nelmnt_a is created rathan than
! using the one in the common block.

!        write (*,*) 'Matrix61,myid=',myid
        CALL MANEIG (iiatjpo, iiaspar, nelmnt_a)
!GG        CALL MANEIG (iiatjpo, iiaspar, nelmnt_a, imethod)
!GG         CALL MANEIG (iiatjpo, iiaspar)
!
!   Write out eigenvalues (ENGOUT), dominant components of the
!   eigenvectors (WGHTD5) to stream 24; write out ASF symmetries,
!   eigenvalues  and eigenvectors to RCI92 mixing coefficients file.
!   EAV and ELSTO are added back to energy here
!
        IF (myid .EQ. 0) THEN
! ELSTO has never been in Hamiltonian matrix, yet it was
! added to EAV which was later substracted from H. Thus at
! this point, EAV is correct (it has ELSTO added), EVAL()
! need ELSTO and the correct EAV.
           IF (NCF > 1) then
              DO i = 1, NVEC
                 EVAL(i) = EVAL(i) + ELSTO
              ENDDO
           END IF

           CALL ENGOUT (EAV,EVAL,IiATJPO,iIASPAR,IVEC,NVEC,3)
           CALL WGHTD5 (iiatjpo, iiaspar)

!          ...Write ASF symmetries, eigenvalues, and eigenvectors to RCI92
!          ...MIXing coefficients File; close the file; print a report
           WRITE (25) jblock, ncf, nvec, iiatjpo, iiaspar
           WRITE (25) (ivec(i), i = 1, nvec)
           WRITE (25) EAV,(EVAL(I),I = 1,NVEC)
           WRITE (25) ((EVEC(I+(J-1)*NCF),I = 1,NCF),J = 1,NVEC)

           PRINT *, 'RCI90 MIXing coefficients File generated.'
        ENDIF
!
!   Save the mixing coefficients from the prerun
!
      IF (IPRERUN .EQ. 1) THEN
         DO J = 1, NVEC
            DO I = 1, NCF
               EVEC1(I+(J-1)*NCF) = EVEC(I+(J-1)*NCF)
            ENDDO
         ENDDO
      ENDIF

!        ...Locals
         CALL dalloc (ivec, 'IVEC', 'MATRIX')
!        ...Allocated in maneig
         CALL dalloc (eval, 'EVAL', 'MATRIX')
         CALL dalloc (evec, 'EVEC', 'MATRIX')

   80    CONTINUE

!        ...Locals
         CALL dalloc (IQA, 'IQA', 'MATRIX')
         CALL dalloc (JQSA, 'JQSA', 'MATRIX')
         CALL dalloc (JCUPA, 'JCUPA', 'MATRIX')

  100 CONTINUE
!
!   Close the restart files; nothing will be added to them now
!
      CLOSE (imcdf)
!     ...Clean up
      CALL dalloc (ncfblk, 'NCFBLK', 'MATRIX')
      CALL dalloc (nevblk, 'NEVBLK', 'MATRIX')
      CALL dalloc (ncmaxblk, 'NCMAXBLK', 'MATRIX')
      CALL dalloc (iccutblk, 'ICUTTBLK', 'MATRIX')
      CALL dalloc (iccmin, 'ICCMIN', 'MATRIX') ! allocated in items as pnccmin

      CALL dalloc (VALTEIRK, 'VALTEIRK', 'MATRIX') ! allocated in genintrk
      CALL dalloc (INDTEIRK, 'INDTEIRK', 'MATRIX') ! allocated in genintrk
!
!   Deallocate storage for the integral lists from the
!   Dirac-Coulomb operator; the storage was allocated
!   in IABINT and RKINTC
!
      IF (NCOEI .GT. 0) THEN
         CALL DALLOC (INDOEI, 'INDOEI', 'MATRIX')
         CALL DALLOC (VALOEI, 'VALOEI', 'MATRIX')
      ENDIF
!
!   Deallocate storage for the integral lists from the
!   transverse photon interaction operator; this storage
!   was allocated in BRINT1, brint2,...brint6
!
      IF (LTRANS) THEN
         IF (NTPI(1) .GT. 0) THEN
            CALL DALLOC (INDTP1, 'INDTP1', 'MATRIX')
            CALL DALLOC (VALTP1, 'VALTP1', 'MATRIX')
         ENDIF
         IF (NTPI(2) .GT. 0) THEN
            CALL DALLOC (INDTP2, 'INDTP2', 'MATRIX')
            CALL DALLOC (VALTP2, 'VALTP2', 'MATRIX')
         ENDIF
         IF (NTPI(3) .GT. 0) THEN
            CALL DALLOC (INDTP3, 'INDTP3', 'MATRIX')
            CALL DALLOC (VALTP3, 'VALTP3', 'MATRIX')
         ENDIF
         IF (NTPI(4) .GT. 0) THEN
            CALL DALLOC (INDTP4, 'INDTP4', 'MATRIX')
            CALL DALLOC (VALTP4, 'VALTP4', 'MATRIX')
         ENDIF
         IF (NTPI(5) .GT. 0) THEN
            CALL DALLOC (INDTP5, 'INDTP5', 'MATRIX')
            CALL DALLOC (VALTP5, 'VALTP5', 'MATRIX')
         ENDIF
         IF (NTPI(6) .GT. 0) THEN
            CALL DALLOC (INDTP6, 'INDTP6', 'MATRIX')
            CALL DALLOC (VALTP6, 'VALTP6', 'MATRIX')
         ENDIF
      ENDIF
!
!   Deallocate storage for the nuclear motional energy integral
!   lists; this was allocated in KEINT and VINT
!
      IF (LNMS) THEN
         IF (NKEI .GT. 0) THEN
            CALL DALLOC (INDKEI, 'INDKEI', 'MATRIX')
            CALL DALLOC (VALKEI, 'VALKEI', 'MATRIX')
         ENDIF
      ENDIF
      IF (LSMS) THEN
         IF (NVINTI .GT. 0) THEN
            CALL DALLOC (INDTEI, 'INDTEI', 'MATRIX')
            CALL DALLOC (VALTEI, 'VALTIE', 'MATRIX')
         ENDIF
      ENDIF
!
!   Deallocate storage for the vacuum-polarisation integral list;
!   this was allocated in VPINT
!
      IF (LVP) THEN
         IF (NVPI .GT. 0) THEN
            CALL DALLOC (INDVPI, 'INDVPI', 'MATRIX')
            CALL DALLOC (VALVPI, 'VALVPI', 'MATRIX')
         ENDIF
      ENDIF

      CALL dalloc (PF, 'PF', 'MATRIX') ! lodrwf or lodres
      CALL dalloc (QF, 'QF', 'MATRIX') ! lodrwf or lodres

      RETURN

      END