MODULE params_model

USE common, ONLY: r_size, slen

IMPLICIT NONE

PUBLIC

!-----------------------------------------------------------------------
! General parameters
!-----------------------------------------------------------------------
!
  ! Now definable via namelist at runtime:

  ! HYCOM 1/4º global grid, 32 levels:
#ifdef DYNAMIC
  INTEGER :: nlon=563
  INTEGER :: nlat=351
  INTEGER :: nlev=32
#else
  INTEGER,PARAMETER :: nlon=563
  INTEGER,PARAMETER :: nlat=351
  INTEGER,PARAMETER :: nlev=32
#endif

  !INTEGER,PARAMETER :: nv3d=4 ! u,v,t,s              !(OCEAN)
  INTEGER,PARAMETER :: nv3d=5 ! u,v,t,s,h             !(OCEAN)(MOM6)(HYCOM)
  INTEGER,PARAMETER :: nv4d=3 ! x,y,z                 !(OCEAN) STEVE: add t,x,y,z,id for DRIFTERS
  !INTEGER,PARAMETER :: nv2d=3 ! ssh,sst,sss          !(OCEAN)
  INTEGER,PARAMETER :: nv2d=3 ! ssh,ubt,vbt           !(OCEAN) !(ALTIMETRY)(HYCOM)

  INTEGER,PARAMETER :: ilev_sfc=1

  ! Initialize via subroutine below:
  INTEGER,SAVE :: nij0           ! Number of gridpoints handled by myrank processor
  INTEGER,SAVE :: nlevall        ! Total number of variables and levels (3d + 2d)
  INTEGER,SAVE :: ngpv           ! Total number of gridpoints, including nij0*nlevall

  INTEGER,PARAMETER :: iv3d_u=1
  INTEGER,PARAMETER :: iv3d_v=2
  INTEGER,PARAMETER :: iv3d_t=3
  INTEGER,PARAMETER :: iv3d_s=4                !(OCEAN)
  INTEGER,PARAMETER :: iv3d_h=5                !(OCEAN)

  INTEGER,PARAMETER :: iv2d_ssh=1                    !(OCEAN) ! time averaged thickness of top model grid cell (m) plus patm/(grav*rho0)
  INTEGER,PARAMETER :: iv2d_ubt=2                    !(OCEAN) ! Barotropic zonal velocity (HYCOM)
  INTEGER,PARAMETER :: iv2d_vbt=3                    !(OCEAN) ! Barotropic meridional velocity (HYCOM)
  INTEGER,PARAMETER :: iv2d_sst=4                    !(OCEAN) ! time averaged sst (Kelvin) passed to atmosphere/ice model (MOM4p1)
  INTEGER,PARAMETER :: iv2d_sss=5                    !(OCEAN) ! time averaged sss (psu) passed to atmosphere/ice models (MOM4p1)
  INTEGER,PARAMETER :: iv2d_eta=6              !(OCEAN) ! eta sea surface perturbation from mom4's ocean_barotropic.res.nc restart file
  INTEGER,PARAMETER :: iv2d_mld=7              !(OCEAN) ! mixed layer depth
  INTEGER,PARAMETER :: iv4d_x=1                !(OCEAN) (DRIFTERS)
  INTEGER,PARAMETER :: iv4d_y=2                !(OCEAN) (DRIFTERS)
  INTEGER,PARAMETER :: iv4d_z=3                !(OCEAN) (DRIFTERS)

  !
  ! Elements
  !
  CHARACTER(4) :: element(nv3d+nv2d+nv4d)
! element(iv3d_u) = 'U   '
! element(iv3d_v) = 'V   '
! element(iv3d_t) = 'T   '
! element(iv3d_s) = 'S   '               !(OCEAN)
! element(nv3d+iv2d_ssh) = 'SSH '        !(OCEAN)
! element(nv3d+iv2d_sst) = 'SST '        !(OCEAN)
! element(nv3d+iv2d_sss) = 'SSS '        !(OCEAN)
! if (DO_ALTIMETRY) then
!   element(nv3d+iv2d_eta) = 'eta '      !(OCEAN)
! endif
! if (DO_MLD) then
!   element(nv3d+iv2d_mld) = 'mld'       !(OCEAN)
! endif
! if (DO_DRIFTERS) then
!   element(nv3d+nv2d+iv4d_x) = 'X   '             !(OCEAN) (DRIFTERS)
!   element(nv3d+nv2d+iv4d_y) = 'Y   '             !(OCEAN) (DRIFTERS)
!   element(nv3d+nv2d+iv4d_z) = 'Z   '             !(OCEAN) (DRIFTERS)
! endif

  ! In place of mom4p1's grid_spec.nc data file, used to define the model grid
  CHARACTER(6)  :: gridfile  = '3zt.nc'
  CHARACTER(12) :: gridfile1 = 'blkdat.input'
  CHARACTER(6)  :: gridfile2 = 'bot.nc'
  CHARACTER(6)  :: gridfile3 = '3dh.nc'

  !For input/output of model binary files (converted form HYCOM ab-format):
  CHARACTER(8) :: base  = '.fsd.bin'! (HYCOM)(All variables assembled in one binary file)
  CHARACTER(2) :: base_a  = '.a'! (HYCOM)(All variables assembled in one
  CHARACTER(2) :: base_b  = '.b'! (HYCOM)(All variables assembled in one

  !model input and output file direct/sequential
  INTEGER, PARAMETER :: hycom_io_access = 1  ! 0 == direct, 1 == sequential

  CHARACTER(14) :: SSHclm_file = 'aEtaCds9399.nc'
! CHARACTER(32) :: ts_basefile = 'ocean_temp_salt.res.nc'
! CHARACTER(32) :: uv_basefile = 'ocean_velocity.res.nc'
! CHARACTER(32) :: sf_basefile = 'ocean_sbc.res.nc'
! CHARACTER(32) :: sh_basefile = 'ocean_barotropic.res.nc'
! CHARACTER(32) :: hs_basefile = 'ocean_TS.nc'
!
! ! For grid_spec.nc data file:
! CHARACTER(12) :: gridfile = 'grid_spec.nc'

  !For input/output of model binary files (converted form HYCOM ab-format):
! CHARACTER(slen) :: base  = 'fsd.bin'! (HYCOM)(All variables assembled in one binary file)
  !Otherwise, use netcdf files:
  CHARACTER(6) :: tbase = '3zt.nc' ! Temperature
  CHARACTER(6) :: sbase = '3zs.nc' ! Salinity
  CHARACTER(6) :: ubase = '3zu.nc' ! Zonal Current
  CHARACTER(6) :: vbase = '3zv.nc' ! Merional Current
  CHARACTER(6) :: hbase = '3dh.nc' ! Layer Thickness
  CHARACTER(6) :: ebase = 'fsd.nc' ! Sea Surface Height
  CHARACTER(6) :: drbase           ! (DRIFTERS)

  ! Bounds checking (for output by common_hycom.f90::write_restart)
  LOGICAL :: do_physlimit=.true.
  REAL(r_size) :: max_t = 50.0d0 ! degC
  REAL(r_size) :: min_t = 0.0d0 ! degC
  REAL(r_size) :: max_s = 50.0d0 ! psu
  REAL(r_size) :: min_s =  0.0d0 ! psu
  REAL(r_size) :: max_uv = 10.0 ! m/s
  REAL(r_size) :: min_uv =  -10.0d0 ! m/s
  REAL(r_size) :: max_h = 1000.0d0 !m
  REAL(r_size) :: min_h =  -1000.0d0 !m

  !STEVE: for filtering undef values from netcdf file
  REAL(r_size), PARAMETER :: ncundef = 1.267650600228229E+030 !1.0e18

  LOGICAL,SAVE :: params_model_initialized = .false.

CONTAINS

SUBROUTINE initialize_params_model

  IMPLICIT NONE

  if (params_model_initialized) then
    WRITE(6,*) "initialize_params_model:: already initialized, RETURNING..."
    RETURN
  endif

  nij0=nlon*nlat
  nlevall=nlev*nv3d+nv2d
  ngpv=nij0*nlevall

  params_model_initialized = .true.

END SUBROUTINE initialize_params_model

END MODULE params_model


      subroutine recmon

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine inputs measured loadings to the stream network
!!    for routing through the watershed where the records are summarized
!!    on a monthly basis

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactlpmon(:,:,:)|# cfu/100ml|average amount of less persistent bacteria
!!                                |loaded to stream on a given day in the
!!                                |month
!!    bactpmon(:,:,:)|# cfu/100ml |average amount of persistent bacteria
!!                                |loaded to stream on a given day in the
!!                                |month
!!    cbodmon(:,:,:) |kg/day      |average amount of CBOD loaded to stream
!!                                |on a given day in the month
!!    chlamon(:,:,:) |kg/day      |average amount of chlorophyll a loaded
!!                                |to stream on a given day in the month
!!    cmtl1mon(:,:,:)|kg/day      |average amount of conservative metal #1
!!                                |loaded to stream on a given day in the
!!                                |month
!!    cmtl2mon(:,:,:)|kg/day      |average amount of conservative metal #2
!!                                |loaded to stream on a given day in the
!!                                |month
!!    cmtl3mon(:,:,:)|kg/day      |average amount of conservative metal #3
!!                                |loaded to stream on a given day in the
!!                                |month
!!    curyr         |none         |year of simulation
!!    disoxmon(:,:,:)|kg/day      |average amount of dissolved oxygen loaded to
!!                                |stream on a given day in the month
!!    ievent      |none          |rainfall/runoff code
!!                               |0 daily rainfall/curve number technique
!!                               |1 sub-daily rainfall/Green&Ampt/hourly
!!                               |  routing
!!                               |3 sub-daily rainfall/Green&Ampt/hourly routing
!!    ihout         |none         |hydrograph storage location number
!!    inum1         |none         |file number
!!    flomon(:,:,:) |m^3/day      |average amount of water loaded to stream
!!                                |on a given day in the month
!!    minpmon(:,:,:)|kg P/day     |average amount of soluble P loaded to
!!                                |stream on a given day in the month
!!    i_mo          |none         |month of simulation
!!    mvaro         |none         |max number of variables routed through the
!!                                |reach
!!    nh3mon(:,:,:) |kg N/day     |average amount of NH3-N loaded to
!!                                |stream on a given day in the month
!!    no2mon(:,:,:) |kg N/day     |average amount of NO2-N loaded to
!!                                |stream on a given day in the month
!!    no3mon(:,:,:) |kg N/day     |average amount of NO3-N loaded to
!!                                |stream on a given day in the month
!!    orgnmon(:,:,:)|kg N/day     |average amount of organic N loaded to
!!                                |stream on a given day in the month
!!    orgpmon(:,:,:)|kg P/day     |average amount of organic P loaded to
!!                                |stream on a given day in the month
!!    sedmon(:,:,:) |metric tons/d|average amount of sediment loaded to
!!                                |stream on a given day in the month
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name             |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hhvaroute(2,:,:) |m^3          |volume of water
!!    hhvaroute(3,:,:) |metric tons  |sediment
!!    hhvaroute(4,:,:) |kg N         |organic N
!!    hhvaroute(5,:,:) |kg P         |organic P
!!    hhvaroute(6,:,:) |kg N         |NO3-N
!!    hhvaroute(7,:,:) |kg P         |mineral (soluble) P
!!    hhvaroute(13,:,:)|kg           |chlorophyll-a
!!    hhvaroute(14,:,:)|kg N         |NH3
!!    hhvaroute(15,:,:)|kg N         |NO2
!!    hhvaroute(16,:,:)|kg           |carbonaceous biological oxygen demand
!!    hhvaroute(17,:,:)|kg           |dissolved oxygen
!!    hhvaroute(18,:,:)|# cfu/100ml  |persistent bacteria
!!    hhvaroute(19,:,:)|# cfu/100ml  |less persistent bacteria
!!    hhvaroute(20,:,:)|kg           |conservative metal #1
!!    hhvaroute(21,:,:)|kg           |conservative metal #2
!!    hhvaroute(22,:,:)|kg           |conservative metal #3
!!    varoute(2,:)     |m^3          |volume of water
!!    varoute(3,:)     |metric tons  |sediment
!!    varoute(4,:)     |kg N         |organic N
!!    varoute(5,:)     |kg P         |organic P
!!    varoute(6,:)     |kg N         |NO3-N
!!    varoute(7,:)     |kg P         |mineral (soluble) P
!!    varoute(13,:)    |kg           |chlorophyll-a
!!    varoute(14,:)    |kg N         |NH3
!!    varoute(15,:)    |kg N         |NO2
!!    varoute(16,:)    |kg           |CBOD
!!    varoute(17,:)    |kg           |dissolved oxygen
!!    varoute(18,:)    |# cfu/100ml  |persistent bacteria
!!    varoute(19,:)    |# cfu/100ml  |less persistent bacteria
!!    varoute(20,:)    |kg           |conservative metal #1
!!    varoute(21,:)    |kg           |conservative metal #2
!!    varoute(22,:)    |kg           |conservative metal #3
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name       |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii         |none          |counter
!!    j          |none          |counter
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

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

      use parm

      integer :: ii, j

!! zero flow out variables
      do j = 1, mvaro
        varoute(j,ihout) = 0.
        do ii = 1, nstep
          hhvaroute(j,ihout,ii) = 0.
        end do
      end do

      varoute(2,ihout) = flomon(inum1,curyr,i_mo)
      varoute(3,ihout) = sedmon(inum1,curyr,i_mo)
      varoute(4,ihout) = orgnmon(inum1,curyr,i_mo)
      varoute(5,ihout) = orgpmon(inum1,curyr,i_mo)
      varoute(6,ihout) = no3mon(inum1,curyr,i_mo)
      varoute(7,ihout) = minpmon(inum1,curyr,i_mo)
      varoute(11,ihout) = solpstmon(inum1,curyr,i_mo)
      varoute(12,ihout) = srbpstmon(inum1,curyr,i_mo)
      varoute(13,ihout) = chlamon(inum1,curyr,i_mo)
      varoute(14,ihout) = nh3mon(inum1,curyr,i_mo)
      varoute(15,ihout) = no2mon(inum1,curyr,i_mo)
      varoute(16,ihout) = cbodmon(inum1,curyr,i_mo)
      varoute(17,ihout) = disoxmon(inum1,curyr,i_mo)
      varoute(18,ihout) = bactpmon(inum1,curyr,i_mo)
      varoute(19,ihout) = bactlpmon(inum1,curyr,i_mo)
      varoute(20,ihout) = cmtl1mon(inum1,curyr,i_mo)
      varoute(21,ihout) = cmtl2mon(inum1,curyr,i_mo)
      varoute(22,ihout) = cmtl3mon(inum1,curyr,i_mo)

      !! Assumed equal distribution of sediment
      varoute(23,ihout) = sedmon(inum1,curyr,i_mo) * 0.   ! sand
      varoute(24,ihout) = sedmon(inum1,curyr,i_mo) * 1.   ! silt
      varoute(25,ihout) = sedmon(inum1,curyr,i_mo) * 0.   ! cla
      varoute(26,ihout) = sedmon(inum1,curyr,i_mo) * 0.   ! sag
      varoute(27,ihout) = sedmon(inum1,curyr,i_mo) * 0.   ! lag
      varoute(28,ihout) = 0.                    ! gravel

      if (ievent > 0) then
      do ii = 1, nstep
      hhvaroute(2,ihout,ii) = flomon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(3,ihout,ii) = sedmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(4,ihout,ii) = orgnmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(5,ihout,ii) = orgpmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(6,ihout,ii) = no3mon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(7,ihout,ii) = minpmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(11,ihout,ii) = solpstmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(12,ihout,ii) = srbpstmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(13,ihout,ii) = chlamon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(14,ihout,ii) = nh3mon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(15,ihout,ii) = no2mon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(16,ihout,ii) = cbodmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(17,ihout,ii) = disoxmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(18,ihout,ii) = bactpmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(19,ihout,ii) = bactlpmon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(20,ihout,ii) = cmtl1mon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(21,ihout,ii) = cmtl2mon(inum1,curyr,i_mo) / dfloat(nstep)
      hhvaroute(22,ihout,ii) = cmtl3mon(inum1,curyr,i_mo) / dfloat(nstep)
      end do
      end if

      return
      end


SUBROUTINE forfhs(jatom)
  use lolog, only : loor, lapw,ilo
  use atspdt, only  : LQIND, LM, LQNS, VNS1, VNS2, VNS3, GFAC
  use loint, only : VNS1LO, VNS2LO, VNS3LO
  use param
  IMPLICIT NONE
  INTEGER, intent(in):: JATOM
  !INCLUDE 'param.inc'
  !..................................................................
  !   FORFHS writes the radial non muffin-tin integrals uvu, uevu, ...
  !   and the Gaunt-coefficients for the forces on file 71.
  !..................................................................
  !   Local Scalars
  INTEGER            L0, Ll, LP, LM1
  INTEGER            LQX, M, MP
  COMPLEX*16         TUU, TUD, TDU, TDD
  COMPLEX*16         TUU21, TUU12, TUD21, TDU12, TUU22
  integer jlo,klo
  !
  DO LQX = 1, LQIND(JATOM)
     L0 = LQNS(1,LQX,JATOM) - 1
     LL = LQNS(2,LQX,JATOM)
     LP = LQNS(3,LQX,JATOM) - 1
     LM1 = LQNS(4,LQX,JATOM)
     M = LQNS(5,LQX,JATOM)
     MP = LQNS(6,LQX,JATOM)
     tuu=gfac(lqx,jatom)*vns1(l0+1,lm1,lp+1,jatom)
     tdd=gfac(lqx,jatom)*vns2(l0+1,lm1,lp+1,jatom)
     tud=gfac(lqx,jatom)*vns3(l0+1,lm1,lp+1,jatom)
     tdu=gfac(lqx,jatom)*vns3(lp+1,lm1,l0+1,jatom)
     write(71,'(6i3,4es19.12,/,6(3x),4es19.12)') l0,ll,lp,m,lm(2,lm1,jatom),mp,tuu,tdd,tud,tdu
     IF ((L0 .LE. LOMAX).OR.(LP .LE. LOMAX)) THEN
        tuu21=(0.0d0,0.0d0)
        tuu12=(0.0d0,0.0d0)
        tuu22=(0.0d0,0.0d0)
        tud21=(0.0d0,0.0d0)
        tdu12=(0.0d0,0.0d0)
        IF (L0 .LE. LOMAX) THEN
           do jlo=1,ilo(l0,jatom)
              if (.not.lapw(l0,jatom).and.jlo.eq.1) cycle
              IF (LOOR(L0,jatom)) THEN
                 tuu21=gfac(lqx,jatom)*vns1lo(l0+1,lm1,lp+1,jlo,jatom)
                 tud21=gfac(lqx,jatom)*vns2lo(l0+1,lm1,lp+1,jlo,jatom)
                 IF (LP .LE. LOMAX) THEN
                    do klo=1,ilo(lp,jatom)
                       if (.not.lapw(lp,jatom).and.klo.eq.1) cycle
                       IF (LOOR(LP,jatom)) THEN
                          tuu22= gfac(lqx,jatom)*vns3lo(l0+1,lm1,lp+1,jlo,klo,jatom)
                       ENDIF
                    enddo
                 ENDIF
              ENDIF
           enddo
        ENDIF
        IF (LP .LE. LOMAX) THEN
           do klo=1,ilo(lp,jatom)
              if (.not.lapw(lp,jatom).and.klo.eq.1) cycle
              tuu12=gfac(lqx,jatom)*vns1lo(lp+1,lm1,l0+1,klo,jatom)
              tdu12=gfac(lqx,jatom)*vns2lo(lp+1,lm1,l0+1,klo,jatom)
           enddo
        ENDIF
        write(71,'(6(3x),6es19.12,/,6(3x),4es19.12)') tuu21,tuu12,tuu22,tud21,tdu12
     ENDIF
  ENDDO
  RETURN
END SUBROUTINE forfhs


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine dlwqf3 ( idt    , noseg  , volnew , nobnd  , noq    ,         &
     &                    ipoint , flowtot, disptot, diag   , iscale ,         &
     &                    diagcc , nomat  , amat   , idiag  , fmat   ,         &
     &                    tmat   )

!     Deltares - Delft Software Department

!>/file
!>                fills matrix to be used by the GMRES fast solver, once per substance
!>
!>                Matrix is filled:
!>                - horizontally according to upwind differences in space
!>                - vertically   according to upwind differences in space
!>                It is assumed that any logic on drying and flooding is in the
!>                precomputed flowtot and disptot arrays./n
!>                The routine is very efficient because of the precomputed fmat
!>                and tmat arrays for the from and to locations in the matrix.

!     Created   : Sept.1996 by Leo Postma

!     Modified  : Feb.     1997, Robert Vos  : Check on zero's in the scaling
!                 July     2008, Leo Postma  : WAQ perfomance timers
!                 July     2009, Leo Postma  : double precission version
!                 November 2009, Leo Postma  : streamlined for parallel computing

      use timers                         ! WAQ performance timers
      implicit none

!     Arguments           :

!     Kind        Function         Name                  Description

      integer(4), intent(in   ) :: idt                  !< time step in scu's
      integer(4), intent(in   ) :: noseg                !< Number of computational volumes
      real   (4), intent(in   ) :: volnew(  noseg)      !< segment volumes
      integer(4), intent(in   ) :: nobnd                !< Number of open boundaries
      integer(4), intent(in   ) :: noq                  !< Total number fluxes in the water phase
      integer(4), intent(in   ) :: ipoint(4,noq)        !< from, to, from-1, to+1 volume numbers per flux
      real   (4), intent(in   ) :: flowtot( noq)        !< flows plus additional velos. (dim: noq)
      real   (4), intent(in   ) :: disptot( noq)        !< dispersion plus additional dipers. (dim: noq)
      real   (8), intent(inout) :: diag  (noseg+nobnd)  !< diagonal of the matrix
      integer(4), intent(in   ) :: iscale               !< = 1 row scaling with the diagonal
      real   (8), intent(inout) :: diagcc(noseg+nobnd)  !< copy of (unscaled) diagonal of the matrix
      integer(4), intent(in   ) :: nomat                !< dimension of off-diagonal matrix amat
      real   (8), intent(  out) :: amat  (nomat)        !< matrix with off-diagonal entries
      integer(4), intent(in   ) :: idiag(0:noseg+nobnd) !< position of the diagonals in amat
      integer(4), intent(in   ) :: fmat  (  noq)        !< location from(iq) in matrix
      integer(4), intent(in   ) :: tmat  (  noq)        !< location to  (iq) in matrix

!     Local declarations

      integer(4) iseg           ! current volume
      integer(4) iq , jq        ! current edge
      integer(4) ito, ifrom     ! to and from volume number
      real   (4) q1 , q2        ! flows
      real   (8) dt             ! time step in double

!     WAQ timers

      integer(4) ithandl /0/
      if ( timon ) call timstrt ( "dlwqf3", ithandl )

! set the diagonal

      dt = idt
      do iseg = 1 , noseg
         diag(iseg) = volnew(iseg)/dt
      enddo
      do iseg = noseg+1, noseg+nobnd
         diag(iseg) = 1.0
      enddo

!        reset the entire matrix

      amat = 0.0D0

      do iq = 1 , noq
         ifrom = ipoint(1,iq)
         ito   = ipoint(2,iq)
         if ( ifrom .eq. 0 .or. ito .eq. 0 ) cycle

         if ( flowtot(iq) .gt. 0.0 ) then
           q1 = flowtot(iq)
           q2 = 0.0
         else
           q1 = 0.0
           q2 = flowtot(iq)
         endif

         if ( ifrom .gt. 0  ) then
            diag ( ifrom  ) = diag ( ifrom  ) + q1 + disptot(iq)
            amat (fmat(iq)) = amat (fmat(iq)) + q2 - disptot(iq)
         endif
         if ( ito   .gt. 0  ) then
            diag (  ito   ) = diag (  ito   ) - q2 + disptot(iq)
            amat (tmat(iq)) = amat (tmat(iq)) - q1 - disptot(iq)
         endif
      enddo

!     finally scale the matrix to avoid possible round-off errors in GMRES
!     this scaling may need some adaption for future domain decomposition b.c.

      if ( iscale .eq. 1 ) then
         do iq = 1, noseg + nobnd
            ifrom = idiag(iq-1) + 1
            ito   = idiag(iq)

!      check on zero's required for methods 17 and 18

            if ( abs(diag(iq)) .lt. 1.0d-100) diag(iq) = 1.0

            do jq = ifrom, ito
               amat(jq) = amat(jq) / diag(iq)
            enddo

!           copy of diag for later scaling purposes in DLWQF4

            diagcc(iq) = diag (iq)
            diag  (iq) = 1.0d00
         enddo
      else
         do iq = 1, noseg + nobnd
            diagcc(iq) = 1.0d00
         enddo
      endif

      if ( timon ) call timstop ( ithandl )

      return
      end


*
*     ------------------------------------------------------------------
*              S N
*     ------------------------------------------------------------------
*
*                                      3              k
*       Evaluates the integral of (1/r)  P (r) P (r) Z (i, j; r)  with
*                                         i     j
*   respect to r.
*
      DOUBLE PRECISION FUNCTION SN(I,J,II,JJ,K)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
      CALL ZK(J,JJ,K)
      SN = QUADS(I,II,3)*FINE
      RETURN
      END


MODULE OUTPUT_ANALS
!*************************************************
! OUTPUT THE ANALYSIS RESULT
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!          FEBRUARY 2008,  ZHONGJIE HE.
!
!          DECEMBER 2013, YUANFU XIE:
!          a) CHANGE ANA DIMENSION FOR SAVING MEMORY
!          b) MODIFY THE TPW CALCULATION
!*************************************************

  USE PRMTRS_STMAS
  USE GENERALTOOLS

  USE READ_BACKGRD   , ONLY : ORI_LON, ORI_LAT, END_LON, END_LAT,BK0
  USE DRAWCOUNTOUR   , ONLY : DRCONTOUR, DRCONTOUR_2D
  USE READOBSERVES   , ONLY : X_RADAR, Y_RADAR

  PUBLIC    OUTPTLAPS, OUTPUTANA, TMPOUTPUT
  PRIVATE   BKGMEMRLS, DRCONTOUR_0, RADIALWND
!***************************************************
!!COMMENT:
!   THIS MODULE IS USED BY THE MAIN PROGRAM, TO OUTPUT THE ANALIZED FIELDS.
!   SUBROUTINES:
!      OUTPTLAPS : OUTPUT THE ANALIZED FIELDS TO LAPS.
!      OUTPUTANA : OUTPUT THE ANALIZED FILEDS TO SOME FILES AND DRAW SOME PICTURES TO CHECK.
!      TMPOUTPUT : OUTPUT THE ANALIZED FILEDS TO SOME FILES AND DRAW SOME PICTURES TO CHECK.
!      BKGMEMRLS : RELEASE THE MEMORYS.
!      DRCONTOUR_0: WRITE SOME FIELDS INTO THE FILES WITH THE FORMAT OF SURFER( A SOFTWARE TO DRAW PICTURES).
!      RADIALWND : TRANSLATE THE U, V FIELDS TO RADIAL WIND FIELD, USED TO DRAW PICTURE.

CONTAINS

SUBROUTINE OUTPTLAPS
!*************************************************
! GET BACKGROUND FOR ANALYSIS
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,T,S,LN
  CHARACTER(LEN=200) :: DR
  REAL     :: XB(MAXGRID(1)),YB(MAXGRID(2)),ZB(MAXGRID(3)),TB(MAXGRID(4))
  REAL     :: XF(FCSTGRD(1)),YF(FCSTGRD(2)),ZF(FCSTGRD(3)),TF(FCSTGRD(4))
  REAL, ALLOCATABLE :: ANA(:,:,:)
  INTEGER  :: FG(MAXDIMS),MG(MAXDIMS)
  REAL     :: Z1(1),T1(1),Z2(1),T2(1),DX,DY

  ! PARAMETERS FOR CONVERTING Q, P AND T TO RH (COPIED FROM lib/degrib/rrpr.F90:
  real, parameter :: svp1=611.2
  real, parameter :: svp2=17.67
  real, parameter :: svp3=29.65
  real, parameter :: svpt0=273.15
  real, parameter :: eps = 0.622
  real, parameter :: r_dry = 287.0
  real            :: tmp,sph,density

  ! VARIABLES NEEDED FOR LAPS: YUANFU
  CHARACTER*9   :: A9
  CHARACTER*3   :: WN(3)=(/'U3','V3','OM'/)	! WIND NAMES
  CHARACTER*3   :: SN(2)=(/'SU','SV'/)		! WIND NAMES
  CHARACTER*4   :: WU(3)=(/'M/S ','M/S ','PA/S'/) ! WIND UNITS
  ! added by shuyuan 20100722
  CHARACTER*3   :: QW(2)=(/'RAI','SNO'/)       ! rain water content   snow water content
  CHARACTER*3   :: RE(1)=(/'REF'/)		! reflectivity  dbz
  CHARACTER*125 :: QWC(2)=(/'ROUR','ROUS'/) ! QW COMMENTS
  CHARACTER*125 :: RC(1)=(/'reflectivity'/) ! reflectivity COMMENTS
  character*10   :: units_3D(2)=(/'kg/m**3','kg/m**3'/)
  !----------------------------------------------------------
  CHARACTER*125 :: WC(3)=(/'3DWIND','3DWIND','3DWIND'/) ! WIND COMMENTS
  CHARACTER*125 :: SC(2)=(/'SFCWIND','SFCWIND'/) ! SFC WIND COMMENTS
  INTEGER       :: I4,ST,IFRAME,ILV(FCSTGRD(3))  ! PRESSURE IN MB NEEDED USING HUMID WRITE ROUTINES
  ! REAL          :: LA(FCSTGRD(1),FCSTGRD(2)),LO(FCSTGRD(1),FCSTGRD(2))
  ! REAL          :: TP(FCSTGRD(1),FCSTGRD(2)),DS,LV(FCSTGRD(3))
  REAL          :: DS,LV(FCSTGRD(3))

  ! YUANFU: MAKE ALL LARGE ARRAYS INTO ALLOCATABLE ONES FROM AUTOMATIC:
  REAL, ALLOCATABLE :: HT(:,:,:),RH(:,:,:),T3(:,:,:),W3(:,:,:,:),SF(:,:,:),SP(:,:),TPW(:,:)

  REAL          :: HEIGHT_TO_ZCOORD3,SSH2,MAKE_RH,MAKE_SSH,RM,A,DLNP
!ADDED BY SHUYUAN 20100722 FOR REFLECTIVITY
  REAL          :: REF_OUT(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3))
  integer       :: istatus  ,N_3D_FIELDS
!Yuanfu test of cloud ice and liquid for temperature:
character :: ext*31,unit*10,comment*30
integer   :: i4_tol,i4_ret,iqc,nref,n2d,n3d
integer   :: istatus2d(FCSTGRD(1),FCSTGRD(2)),istatus3d(FCSTGRD(1),FCSTGRD(2))
integer   :: CLOUD_BASE,CLOUD_TOP,K400
REAL :: closest_radar(FCSTGRD(1),FCSTGRD(2)),AT
REAL ::  rlat,rlon,rhgt
REAL :: FRACTION

  ! Yuanfu add integer arrays for interpolation dimensions:
  integer :: nanal(4),nbkgd(4)

 ! Include a statement function for converting sh to 'rh' = sh/s2r(p) by Yuanfu Xie:
  include 'sh2rh.inc'

i4_tol=900
i4_ret=0
! --------------------

  ! ALLOCATE MEMORY:
  ALLOCATE(HT(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3)),RH(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3)), &
           T3(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3)),W3(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),2), &
           SF(FCSTGRD(1),FCSTGRD(2),2),SP(FCSTGRD(1),FCSTGRD(2)),TPW(FCSTGRD(1),FCSTGRD(2)), &
          STAT=ST)

  DO I=1,FCSTGRD(1)
    XF(I)=(I-1)*1.0D0
  ENDDO
  DO J=1,FCSTGRD(2)
    YF(J)=(J-1)*1.0D0
  ENDDO
  DX=((FCSTGRD(1)-1)*1.0D0)/((MAXGRID(1)-1)*1.0D0)
  DO I=1,MAXGRID(1)
    XB(I)=XF(1)+(I-1)*DX
  ENDDO
  DY=((FCSTGRD(2)-1)*1.0D0)/((MAXGRID(2)-1)*1.0D0)
  DO J=1,MAXGRID(2)
    YB(J)=YF(1)+(J-1)*DY
  ENDDO

!===========
  DO K=1,FCSTGRD(3)
    ZF(K)=Z_FCSTGD(K)
  ENDDO
  DO K=1,MAXGRID(3)
    ZB(K)=Z_MAXGID(K)
  ENDDO
!=================
!  OPEN(2,FILE=DR(1:LN)//'P_LEVEL.DAT',STATUS='OLD',ACTION='READ')
!  DO K=1,MAXGRID(3)
!    READ(2,*)ZB(K)
!  ENDDO
!  CLOSE(2)
!==================
  DO T=1,FCSTGRD(4)
    TF(T)=(ITIME2(2)-ITIME2(1))*(T-1)/(FCSTGRD(4)-1)
  ENDDO
  DO T=1,MAXGRID(4)
    TB(T)=(ITIME2(2)-ITIME2(1))*(T-1)/(MAXGRID(4)-1)
  ENDDO

  ! Output time frame: 2 current by Yuanfu Xie 2014 Feb.
  iframe = 2
  nanal = maxgrid
  nanal(4) = 1 ! Only output time frame
  nbkgd = fcstgrd
  nbkgd(4) = 1 ! Only output time frame

  ! HEIGHT FROM HYDROSTATIC:
  ! WRITE(15,*) MAXGRID,GRDBKGD0(1:MAXGRID(1),1:MAXGRID(2),1:MAXGRID(3),2,3)
  ! DO K=2,MAXGRID(3)
  !   DO J=1,MAXGRID(2)
   !    DO I=1,MAXGRID(1)
   !      GRDBKGD0(I,J,K,1:MAXGRID(4),3) = GRDBKGD0(I,J,K-1,1:MAXGRID(4),3)-287.0/9.8*0.5* &
! 	  (GRDBKGD0(I,J,K,1:MAXGRID(4),4)+GRDBKGD0(I,J,K-1,1:MAXGRID(4),4))* &
   !        (LOG(PPM(K))-LOG(PPM(K-1)))
   !    ENDDO
   !  ENDDO
  ! ENDDO
  ! WRITE(15,*) MAXGRID,GRDBKGD0(1:MAXGRID(1),1:MAXGRID(2),1:MAXGRID(3),2,3)
  print*,'Increment 1: ',maxval(ABS(grdbkgd0(1:maxgrid(1),1:maxgrid(2),1:maxgrid(3),iframe,1)))
  print*,'Increment 2: ',maxval(ABS(grdbkgd0(1:maxgrid(1),1:maxgrid(2),1:maxgrid(3),iframe,2)))
  print*,'Increment 3: ',maxval(ABS(grdbkgd0(1:maxgrid(1),1:maxgrid(2),1:maxgrid(3),iframe,3)))
  print*,'Increment 4: ',maxval(ABS(grdbkgd0(1:maxgrid(1),1:maxgrid(2),1:maxgrid(3),iframe,4)))
  print*,'Increment 5: ',maxval(ABS(grdbkgd0(1:maxgrid(1),1:maxgrid(2),1:maxgrid(3),iframe,5)))
  IF (NUMSTAT .GT. 5) print*,'Increment 6: ',maxval(ABS(grdbkgd0(1:maxgrid(1),1:maxgrid(2),maxgrid(3),iframe,raincont)))

  ! Yuanfu: Change Ana to a 3 dimensional array to save space:
  ! ALLOCATE MEMORY:
  ALLOCATE(ANA(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3)),STAT=ST)

  ! PRESSURE LEVELS:
  CALL GET_PRES_1D(LAPSI4T,FCSTGRD(3),LV,ST)
  ILV = LV/100.0   ! INTEGER PRESSURES NEEDED IN HUMID LH3 OUTPUT

  ! LOOP THROUGH ALL ANALYSIS VARIABLES:
  DO S=1,NUMSTAT
    print * ,'------------------------------------------------------'
    ANA = 0.0
    IF (UNIFORM .EQ. 0) THEN
      CALL BKGTOFINE(1,nanal,XB,YB,ZB,TB(iframe), &
                     nbkgd,XF,YF,ZF,TF(iframe),GRDBKGD0(:,:,:,iframe,S),ANA)
    ELSE
      CALL uniform_interpolation3(maxgrid,fcstgrd,GRDBKGD0(:,:,:,iframe,S),ANA)
    ENDIF
    ! CALL BKGTOFINE(1,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,GRDBKGD0(:,:,:,:,S),ANA)

    ! MAKE SURE INTERPOLATED SH ANALYSIS POSITIVE:
    IF (S .EQ. HUMIDITY) THEN
      DO K=1,FCSTGRD(3)
      DO J=1,FCSTGRD(2)
      DO I=1,FCSTGRD(1)

        ! Convert 'RH' = SH/s2r(p) back to SH by Yuanfu Xie:
        ANA(I,J,K) = &
          MAX(-BK0(I,J,K,iframe,HUMIDITY),ANA(I,J,K))*s2r(lv(k)/100.0)
        BK0(I,J,K,iframe,HUMIDITY) = BK0(I,J,K,iframe,HUMIDITY)*s2r(lv(k)/100.0)

      ENDDO
      ENDDO
      ENDDO
    ENDIF

    ! ADD INCREMENT ANA TO BK0:
    DO K=1,FCSTGRD(3)
    DO J=1,FCSTGRD(2)
    DO I=1,FCSTGRD(1)
      BK0(I,J,K,iframe,S) = BK0(I,J,K,iframe,S)+ANA(I,J,K)
    ENDDO
    ENDDO
    ENDDO
    print*,'bko_max=',maxval(BK0(1:fcstgrd(1),1:fcstgrd(2),1:fcstgrd(3),iframe,S)),S
    print*,'        ',maxval(ANA)
    print*,'bko_min=',minval(BK0(1:fcstgrd(1),1:fcstgrd(2),1:fcstgrd(3),iframe,S)),S
    print*,'        ',minval(ANA)
  ENDDO

  CALL GET_GRID_SPACING_ACTUAL(LATITUDE((FCSTGRD(1)-1)/2+1,(FCSTGRD(2)-1)/2+1), &
                               LONGITUD((FCSTGRD(1)-1)/2+1,(FCSTGRD(2)-1)/2+1),DS,ST)

  CALL GET_R_MISSING_DATA(RM,ST)

  ! OUTPUT: WIND BY YUANFU --

  ! INTERPOLATE SURFACE WIND:
  ! HT = BK0(:,:,:,1,3)
  ! W3 = BK0(:,:,:,1,1:2)
  ! DO J=1,FCSTGRD(2)
  ! DO I=1,FCSTGRD(1)
  !   SP(I,J) = HEIGHT_TO_ZCOORD3(TP(I,J),HT,LV,FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),I,J,ST)
  !   K = INT(SP(I,J))
  !   A = SP(I,J)-K
  !   SF(I,J,1:2) = (1.0-A)*W3(I,J,K,1:2)+A*W3(I,J,K+1,1:2)
  ! ENDDO
  ! ENDDO

  ! WRITE SURFACE WIND (THIS IS ALSO REQIRED TO PLOT 3D WIND ON-THE-FLY):
  ! CALL PUT_LAPS_MULTI_2D(I4,'lwm',SN,WU,SC,SF,FCSTGRD(1),FCSTGRD(2),2,ST)
  ! CALL WIND_POST_PROCESS(I4,'lw3',WN,WU,WC,W3(1,1,1,1),W3(1,1,1,2), &
  !                        FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),3,SF(1,1,1),SF(1,1,2),TP, &
  !                        LA,LO,DS,SP,RM,.TRUE.,ST)

  ! WRITE TEMPERATURE: W3 ARRAY SERVES AS WORKING ARRAY:
  ! T3(:,:,:) = BK0(:,:,:,1,4)
  ! CALL WRITE_TEMP_ANAL(I4,FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),T3,HT,W3,A9,ST)

  ! OUTPUT TIME FRAME:
  IFRAME = 2	! TEMPORARY TESTING BY YUANFU XIE

  ! USE LAPS WRITE BALANCED FIELD:
  ! VERTICAL VELOCITY:
  T3 = 0.0 ! ALSO TEST FOR X Y BOUNDARIES: EXTRAPOLATE LATER YUANFU
  ! CENTER FINITE DIFFERNCE REQUIRE 2*DELTA X (or Y):
  DS = 2.0*DS
  DO K=2,FCSTGRD(3)
    DO J=2,FCSTGRD(2)-1
      DO I=2,FCSTGRD(1)-1
        ! V3(K)=V3(K-1)-DZ*(UX+VY):
        T3(I,J,K) = T3(I,J,K-1) - 0.5* &
          (LV(K)-LV(K-1))*( &
          (BK0(I+1,J,K,IFRAME,1)-BK0(I-1,J,K,IFRAME,1))/DS+ &
          (BK0(I,J+1,K,IFRAME,2)-BK0(I,J-1,K,IFRAME,2))/DS )
      ENDDO
    ENDDO
  ENDDO

  ! According a discussion with Dan, specific humidity is adjusted by Q_r (rain content) using ssh2 routine of LAPS:
GOTO 111
  DO K=1,FCSTGRD(3)
    DO J=1,FCSTGRD(2)
      DO I=1,FCSTGRD(1)
        ! Assume saturation: TD = T:
        IF (BK0(I,J,K,IFRAME,raincont) .GT. 0.0) &
          BK0(I,J,K,IFRAME,5) = SSH2(LV(k)/100.0,BK0(I,J,K,IFRAME,4)-273.15,BK0(I,J,K,IFRAME,4)-273.15,-132.0)
      ENDDO
    ENDDO
  ENDDO
111 continue ! skip SH adjustment according to q_r

  ! Adjust SH by bounds:
goto 222
  do k=1,fcstgrd(3)
  do j=1,fcstgrd(2)
  do i=1,fcstgrd(1)
    bk0(i,j,k,iframe,5) = max(bk0(i,j,k,iframe,5),bk0(i,j,k,iframe,raincont))
  enddo
  enddo
  enddo
222 continue

  ! CONVERTED FROM P, Q T: NOTE: Q is in g/kg
  DO K=1,FCSTGRD(3)
    DO J=1,FCSTGRD(2)
      DO I=1,FCSTGRD(1)
        ! sph = BK0(I,J,K,IFRAME,5)*0.001
        ! tmp = BK0(I,J,K,IFRAME,4)
        ! RH(I,J,K) = 1.E2 * (LV(k)*sph/(sph*(1.-eps) + eps))/(svp1*exp(svp2*(tmp-svpt0)/(tmp-svp3)))
        IF (BK0(I,J,K,IFRAME,5) .GE. 0.0) THEN
          RH(I,J,K) = MAKE_RH(LV(k)/100.0,BK0(I,J,K,IFRAME,4)-273.15,BK0(I,J,K,IFRAME,5),-132.0)

          ! Ensure no RH greater than 1.0:
          IF (RH(I,J,K) .GT. 1.0) THEN
            RH(I,J,K) = 1.0
            BK0(I,J,K,IFRAME,5) = &
              MAKE_SSH(LV(k)/100.0,BK0(I,J,K,IFRAME,4)-273.15,1.0,-132.0)
          ENDIF

          ! Percentage:
          RH(I,J,K) = RH(I,J,K)*100.0
        ELSE
          RH(I,J,K) = 0.0
        ENDIF
      ENDDO
    ENDDO
  ENDDO
  print*,'Max/Min RH: ',maxval(RH),minval(RH)

  ! HEIGHT FROM HYDROSTATIC:
  ! BK0(1:FCSTGRD(1),1:FCSTGRD(2),1,IFRAME,3) = 0.0
  goto 1
  DO K=4,FCSTGRD(3)
    DO J=1,FCSTGRD(2)
      DO I=1,FCSTGRD(1)
        BK0(I,J,K,IFRAME,3) = BK0(I,J,K-1,IFRAME,3)-287.0/9.8*0.5* &
	  (BK0(I,J,K,IFRAME,4)+BK0(I,J,K-1,IFRAME,4))* &
          (LOG(LV(K))-LOG(LV(K-1)))
      ENDDO
    ENDDO
  ENDDO
1 continue

  ! Temperature adjustment according to rain and snow: Testing by YUANFU
  ! SKIP FOR NOW AS CWB DOMAIN FOR MORAKOT, THIS CAUSES VERY LARGE TEMP INCREMENT
  GOTO 11
  DO K=1,FCSTGRD(3)
    DO J=1,FCSTGRD(2)
      DO I=1,FCSTGRD(1)
        ! Dry density:
        density = LV(K)/r_dry/BK0(I,J,K,IFRAME,4)
        ! Adjusted temperature:
        BK0(I,J,K,IFRAME,4) = LV(K)/r_dry/ &
          (density+BK0(I,J,K,IFRAME,raincont)*0.001+BK0(I,J,K,IFRAME,snowcont)*0.001)
      ENDDO
    ENDDO
  ENDDO
11 CONTINUE
  ! Temperature adjustment according to cloud ice and liquid: Test by Yuanfu
  ext = "vrz"
  BK0(:,:,:,1,NUMSTAT+1) = 0.0      ! Reflectivity
  call read_multiradar_3dref(lapsi4t, &
      900,0,      & ! 900 tolerate
      .true.,-10.0, & ! apply_map: true; ref missing data value: 10
      fcstgrd(1),fcstgrd(2),fcstgrd(3),ext,latitude,longitud,topogrph, &
      .false.,.false., & ! l_low_fill: false; l_high_fill: false
      bk0(1,1,1,iframe,3),bk0(1,1,1,1,numstat+1),rlat,rlon,rhgt,unit,iqc,closest_radar, &
      nref,n2d,n3d,istatus2d,istatus3d)
  ext = "lwc"
  BK0(:,:,:,IFRAME,NUMSTAT+1) = 0.0 ! Cloud liquid
  BK0(:,:,:,IFRAME,NUMSTAT+2) = 0.0 ! Cloud ice
  CALL GET_LAPS_3DGRID(LAPSI4T,i4_tol,i4_ret, &
               FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),ext,"lwc", &
               unit,comment,BK0(1,1,1,IFRAME,NUMSTAT+1),ST)
  CALL GET_LAPS_3DGRID(LAPSI4T,i4_tol,i4_ret, &
               FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),ext,"ice", &
               unit,comment,BK0(1,1,1,IFRAME,NUMSTAT+2),ST)
  print*,'Max cloud liquid: ',maxval(BK0(:,:,:,IFRAME,NUMSTAT+1))
  print*,'Max cloud ice   : ',maxval(BK0(:,:,:,IFRAME,NUMSTAT+2))
 goto 333
  ! Adjust temperature according to cloud:
  DO J=1,FCSTGRD(2)
    DO I=1,FCSTGRD(1)
      AT=0.0
      CLOUD_BASE = FCSTGRD(3)+1
      CLOUD_TOP = 0
      DO K=1,FCSTGRD(3)
        IF (LV(K) .EQ. 40000) THEN
          IF (BK0(I,J,K,1,NUMSTAT+1) .GT. 5 .AND. &
              BK0(I,J,K,1,NUMSTAT+1) .LT.100.0 ) &
            AT=BK0(I,J,K,1,NUMSTAT+1)/10.0
          K400 = K
        ENDIF
        IF (BK0(I,J,K,IFRAME,NUMSTAT+1) .GT. 0.0 .OR. &
            BK0(I,J,K,IFRAME,NUMSTAT+2) .GT. 0.0) THEN
          CLOUD_BASE = MIN0(K,CLOUD_BASE)
          CLOUD_TOP  = MAX0(K,CLOUD_TOP)
        ENDIF
      ENDDO

      ! Only adjust when cloud top is above 400mb
      IF (CLOUD_TOP .LT. K400 .OR. AT .LE. 0.0) cycle

      IF (CLOUD_BASE .LE. K400) THEN
        DO K=CLOUD_BASE,K400
          BK0(I,J,K,IFRAME,4) = BK0(I,J,K,IFRAME,4)+ &
            AT*(K-CLOUD_BASE)/FLOAT(MAX(K400-CLOUD_BASE,1))
        ENDDO
      ENDIF
      DO K=K400+1,CLOUD_TOP
        BK0(I,J,K,IFRAME,4) = BK0(I,J,K,IFRAME,4)+ &
          AT*(CLOUD_TOP-K)/FLOAT(MAX(CLOUD_TOP-K400,1))
      ENDDO
    ENDDO
  ENDDO
333 continue

  ! TOTAL PRECIPITABLE WATER:
  DO J=1,FCSTGRD(2)
  DO I=1,FCSTGRD(1)
    TPW(I,J) = 0.0
    DO K=1,FCSTGRD(3)-1
      IF (LV(K) .LE. p_sfc_f(i,j)) THEN
        ! above topography: summed up
        TPW(I,J) = TPW(I,J) + 0.5* &
                 (BK0(I,J,K,IFRAME,5)+BK0(I,J,K+1,IFRAME,5))* &
                 (LV(K)-LV(K+1))/100.0 ! PRESSURE IN MB

      ELSEIF (LV(K+1) .LE. p_sfc_f(i,j)) THEN
        TPW(I,J) = TPW(I,J) + BK0(I,J,K+1,IFRAME,5)* &
                   (p_sfc_f(i,j)-LV(k+1))/100.0
      ENDIF
    ENDDO
    ! FROM G/KG TO CM:
    TPW(I,J) = TPW(I,J)/100.0/9.8 ! FOLLOWING DAN'S INT_IPW.F ROUTINE
  ENDDO
  ENDDO
  PRINT*,'TPW max/min: ', maxval(TPW),minval(TPW)

  ! KG/KG FOR BALANCE NETCDF:
  BK0(1:FCSTGRD(1),1:FCSTGRD(2),1:FCSTGRD(3),IFRAME,5) = 0.001* &
    BK0(1:FCSTGRD(1),1:FCSTGRD(2),1:FCSTGRD(3),IFRAME,5)
  CALL WRITE_BAL_LAPS(LAPSI4T,BK0(1,1,1,IFRAME,3),BK0(1,1,1,IFRAME,1), &
                          BK0(1,1,1,IFRAME,2),BK0(1,1,1,IFRAME,4), &
                          T3,RH,BK0(1,1,1,IFRAME,5),FCSTGRD(1),FCSTGRD(2), &
                          FCSTGRD(3),LV,ST)

  ! WRITE TEMPERATURE AND WIND INTO LAPSPRD:
  CALL WRITE_TEMP_ANAL(LAPSI4T,FCSTGRD(1),FCSTGRD(2),FCSTGRD(3), &
       BK0(1,1,1,IFRAME,4),BK0(1,1,1,IFRAME,3),DR,ST)

  ! WRITE WIND BY COMPONENTS:
  CALL PUT_LAPS_MULTI_3D_JACKET(LAPSI4T,'lw3',WN,WU,WC, &
                     BK0(1,1,1,IFRAME,1),BK0(1,1,1,IFRAME,2),T3, &
                     FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),3,ST)

  ! WRITE SP TO FILE FOLLOWING DAN'S LQ3_DRIVE1A.f:
  WRITE(*,*) 'WRITE-FILE...'
  CALL WRITEFILE(LAPSI4T,'STMAS SH analysis',ILV,BK0(1,1,1,IFRAME,5), &
                 FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),ST)

  ! WRITE TOTAL PRECIPITABLE WATER TO lh4 FILE:
  WRITE(*,*) 'WRITE-LH4...'
  CALL WRITE_LH4(LAPSI4T,TPW,1.0,FCSTGRD(1),FCSTGRD(2),ST)

  ! WRITE RH TO LH3:
  WRITE(*,*) 'WRITE-LH3...'
  CALL LH3_COMPRESS(BK0(1,1,1,IFRAME,5),BK0(1,1,1,IFRAME,4),LAPSI4T,ILV, &
                    -132.0,FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),0,ST)

  ! END OF OUTPUT TO LAPS BY YUANFU

! --------ADDED BY SHUYUAN 201007---------------------------------
! CALCULATE AND OUTPUT REFLECTIVITY
  ! CHECK IF RAIN AND SNOW IS ANALYZED:
  IF (NUMSTAT .LE. 5) GOTO 555 ! BY YUANFU
  DO K=1,FCSTGRD(3)
  DO J=1,FCSTGRD(2)
  DO I=1,FCSTGRD(1)
    REF_OUT(I,J,K)= 0.
    if(BK0(I,J,K,iframe,raincont).GT. 0.0 ) then
      REF_OUT(I,J,K)=REF_OUT(I,J,K)+43.1+17.5*ALOG10(BK0(I,J,K,iframe,raincont))
    else
     ! LAPS uses -10 as base value for reflectivity:
     REF_OUT(I,J,K)=-10.
    endif

    if( REF_OUT(I,J,K) .LT. 0.) then
      ! LAPS uses -10 as base value for reflectivity:
      REF_OUT(I,J,K)=-10.
    endif
  ENDDO
  ENDDO
  ENDDO
  print*,'ref_max=',maxval(REF_OUT(1:fcstgrd(1),1:fcstgrd(2),1:fcstgrd(3)))
  print*,'ref_min=',minval(REF_OUT(1:fcstgrd(1),1:fcstgrd(2),1:fcstgrd(3)))
  call put_laps_3d(LAPSI4T,'lps',RE,'dBZ',RC,REF_OUT(1,1,1),FCSTGRD(1),FCSTGRD(2),FCSTGRD(3))

  !RAIN CONTENT(AIR DENSITY* RAIN WATER MIXING RATIO(kg/m3),
  !SNOW CONTENT(AIR DENSITY * SNOW WATER MIXING RATIO)
  N_3D_FIELDS=2   ! variable number
  istatus=0
  !convert rc sc to rour rous
  DO K=1,FCSTGRD(3)
  DO J=1,FCSTGRD(2)
  DO I=1,FCSTGRD(1)
    if(BK0(I,J,K,iframe,raincont) .NE. 0)then
      BK0(I,J,K,iframe,raincont)=BK0(I,J,K,iframe,raincont)/1000.  ! kg/m3
    endif
    if(BK0(I,J,K,iframe,snowcont) .NE. 0)then
      BK0(I,J,K,iframe,snowcont)=BK0(I,J,K,iframe,snowcont)/1000.   !20100907
    endif
  ENDDO
  ENDDO
  ENDDO
  print*,'bko6_max=',maxval(BK0(1:fcstgrd(1),1:fcstgrd(2),1:fcstgrd(3),iframe,raincont))
  print*,'bko7_max=',maxval(BK0(1:fcstgrd(1),1:fcstgrd(2),1:fcstgrd(3),iframe,snowcont))
  ! OUT PUT SNOW CONTENT(SNO) AND RAI
  call put_laps_3d_multi_R(LAPSI4T,'lwc',QW,units_3D,QWC ,  &
            BK0(1,1,1,iframe,raincont),BK0(1,1,1,iframe,snowcont),     &
            FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),            &
            FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),N_3D_FIELDS,istatus)
!--END OUTPUT REF RAI SNO  BY SHUYUAN---------------------

  ! SKIP OUTPUT RAIN AND SNOW IF NOT ANALYZED:
555 CONTINUE

  CALL BKGMEMRLS
  DEALLOCATE(Z_FCSTGD)
  ! FINALLY RELEASE THE BACKGROUND ARRAYS: BY YUANFU
  DEALLOCATE(BK0)
  ! FINALLY RELEASE MEMORY FOR LAT/LON/TOPO:
  DEALLOCATE(LATITUDE, LONGITUD, TOPOGRPH)
  RETURN
END SUBROUTINE OUTPTLAPS

SUBROUTINE OUTPUTANA
!*************************************************
! GET BACKGROUND FOR ANALYSIS
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!          FEBRUARY 2008, BY ZHONGJIE HE
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,L,T,S,LN
  CHARACTER(LEN=200) :: DR
  REAL     :: XB(MAXGRID(1)),YB(MAXGRID(2)),ZB(MAXGRID(3)),TB(MAXGRID(4))
  REAL     :: XF(FCSTGRD(1)),YF(FCSTGRD(2)),ZF(FCSTGRD(3)),TF(FCSTGRD(4))
  REAL     :: BK1(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),FCSTGRD(4),NUMSTAT)
  INTEGER  :: FG(MAXDIMS),MG(MAXDIMS)
  REAL     :: Z1(1),T1(1),Z2(1),T2(1),DX,DY,DT

! ADDED BY ZHONGJIE HE==========
  REAL  :: UU(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3))
  REAL  :: VV(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3))
  REAL  :: WW(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3))
  REAL  :: UV(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3))
  REAL  :: W0(FCSTGRD(1),FCSTGRD(2),FCSTGRD(3),FCSTGRD(4))

  REAL  :: D1,D2,DD
!===============================

! --------------------
  DO I=1,FCSTGRD(1)
    XF(I)=(I-1)*1.0D0
  ENDDO
  DO J=1,FCSTGRD(2)
    YF(J)=(J-1)*1.0D0
  ENDDO
  DX=((FCSTGRD(1)-1)*1.0D0)/((MAXGRID(1)-1)*1.0D0)
  DO I=1,MAXGRID(1)
    XB(I)=XF(1)+(I-1)*DX
  ENDDO
  DY=((FCSTGRD(2)-1)*1.0D0)/((MAXGRID(2)-1)*1.0D0)
  DO J=1,MAXGRID(2)
    YB(J)=YF(1)+(J-1)*DY
  ENDDO
  CALL GET_DIRECTORY('static',DR,LN)
!================
  DO K=1,FCSTGRD(3)
    ZF(K)=Z_FCSTGD(K)
  ENDDO
  DO K=1,MAXGRID(3)
    ZB(K)=Z_MAXGID(K)
  ENDDO
!=============== JUST FOR TEST DATA
!  OPEN(2,FILE=DR(1:LN)//'P_LEVEL.DAT',STATUS='OLD',ACTION='READ')
!  DO K=1,MAXGRID(3)
!    READ(2,*)ZB(K)
!  ENDDO
!  CLOSE(2)

!  DO K=1,MAXGRID(3)
!    ZB(K)=ZF(1)+(K-1)*(ZF(FCSTGRD(3))-ZF(1))/(MAXGRID(3)-1.0)
!  ENDDO
! ===============

  DO T=1,FCSTGRD(4)
    TF(T)=(T-1)*1.0
  ENDDO
  IF(MAXGRID(4).GE.2) DT=((FCSTGRD(4)-1)*1.0)/(MAXGRID(4)-1.0)
  DO T=1,MAXGRID(4)
    TB(T)=TF(1)+(T-1)*DT
  ENDDO

! ADDED BY ZHONGJIE HE==========

!  CALL FCST2BKGD(NUMDIMS,NGPTOBS,NUMSTAT,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,DIFFTOUT,BK1)
  CALL BKGTOFINE(NUMSTAT,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,GRDBKGD0,BK1)
!  CALL FCST2BKGD(NUMDIMS,NGPTOBS,1,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,WWWOUT,W0)
  CALL BKGTOFINE(1,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,WWWOUT,W0)

  DEALLOCATE(DIFFTOUT)
  DEALLOCATE(WWWOUT)

  DO K=1,FCSTGRD(3)
  DO J=1,FCSTGRD(2)
  DO I=1,FCSTGRD(1)
    UU(I,J,K)=BK1(I,J,K,1,U_CMPNNT)
    VV(I,J,K)=BK1(I,J,K,1,V_CMPNNT)
!    WW(I,J,K)=W0(I,J,K,1)
!    D1=ORI_LON+(END_LON-ORI_LON)/FLOAT(FCSTGRD(1)-1)*(I-1)
!    D1=D1-X_RADAR
!    D2=ORI_LAT+(END_LAT-ORI_LAT)/FLOAT(FCSTGRD(2)-1)*(J-1)
!    D2=D2-Y_RADAR
!    DD=SQRT(D1*D1+D2*D2)
!    UV(I,J,K)=UU(I,J,K)*D1/DD+VV(I,J,K)*D2/DD
  ENDDO
  ENDDO
  ENDDO

  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,UU,'UD.GRD')
  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,VV,'VD.GRD')
!  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,WW,'WD.GRD')
!  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,UV,'RD.GRD')

!===============================

!  CALL FCST2BKGD(NUMDIMS,NGPTOBS,NUMSTAT,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,GRDBKGD0,BK1)
  CALL BKGTOFINE(NUMSTAT,MAXGRID,XB,YB,ZB,TB,FCSTGRD,XF,YF,ZF,TF,GRDBKGD0,BK1)

! ADDED BY ZHONGJIE HE==========
  DO K=1,FCSTGRD(3)
  DO J=1,FCSTGRD(2)
  DO I=1,FCSTGRD(1)
    UU(I,J,K)=BK1(I,J,K,1,U_CMPNNT)
    VV(I,J,K)=BK1(I,J,K,1,V_CMPNNT)
    WW(I,J,K)=W0(I,J,K,1)
!    D1=ORI_LON+(END_LON-ORI_LON)/FLOAT(FCSTGRD(1)-1)*(I-1)
!    D1=D1-X_RADAR
!    D2=ORI_LAT+(END_LAT-ORI_LAT)/FLOAT(FCSTGRD(2)-1)*(J-1)
!    D2=D2-Y_RADAR
!    DD=SQRT(D1*D1+D2*D2)
!    UV(I,J,K)=UU(I,J,K)*D1/DD+VV(I,J,K)*D2/DD
  ENDDO
  ENDDO
  ENDDO

  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,UU,'UA.GRD')
  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,VV,'VA.GRD')
  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,WW,'WA.GRD')
!  CALL DRCONTOUR(ORI_LON,END_LON,ORI_LAT,END_LAT,NUMDIMS,FCSTGRD,UV,'RA.GRD')
!===============================

  CALL BKGMEMRLS
  DEALLOCATE(Z_FCSTGD)
  DEALLOCATE(Z_MAXGID)

!============= to check the analysis field======
  OPEN(1,FILE='STMAS_ANAL.DAT',ACTION='WRITE')
    WRITE(1,*) FCSTGRD(1:4)
    DO L=1,FCSTGRD(4)
    DO K=1,FCSTGRD(3)
    DO J=1,FCSTGRD(2)
    DO I=1,FCSTGRD(1)
      WRITE(1,*) BK1(I,J,K,L,U_CMPNNT),BK1(I,J,K,L,V_CMPNNT),BK1(I,J,K,L,TEMPRTUR),W0(I,J,K,L)
    ENDDO
    ENDDO
    ENDDO
    ENDDO
  CLOSE(1)
!===========================================

  RETURN
END SUBROUTINE OUTPUTANA

SUBROUTINE TMPOUTPUT
!*************************************************
! OUTPUT ANALYSIS
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,T,S
  INTEGER  :: IC,JC
! --------------------
  OPEN(2,FILE='ANALYSIS.DAT')
  DO S=1,NUMSTAT
    DO T=1,1      ! NUMGRID(4)
    DO K=1,1      ! NUMGRID(3)
    DO J=1,NUMGRID(2)
    DO I=1,NUMGRID(1)
      WRITE(2,*) GRDBKGD0(I,J,K,T,S)
    ENDDO
    ENDDO
    ENDDO
    ENDDO
  ENDDO
  CLOSE(2)
!  CALL DRCONTOUR_0(PRESSURE,'Z.GRD')
  CALL DRCONTOUR_0(U_CMPNNT,'U.GRD')
  CALL DRCONTOUR_0(V_CMPNNT,'V.GRD')
!  CALL DRCONTOUR_0(4,'T.GRD')
  IC=(NUMGRID(1)+1)/2
  JC=(NUMGRID(2)+1)/2
  CALL RADIALWND(IC,JC)
  CALL BKGMEMRLS
  RETURN
END SUBROUTINE TMPOUTPUT

SUBROUTINE BKGMEMRLS
!*************************************************
! RELEASE MEMORY FOR BACKGROUND ARRAY
! HISTORY: SEPTEMBER 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
  DEALLOCATE(GRDBKGD0)
  DEALLOCATE(XX0)
  DEALLOCATE(YY0)
  DEALLOCATE(CR0)
  DEALLOCATE(DG0)
  DEALLOCATE(DN0)
  IF(IFPCDNT.EQ.0 .OR. IFPCDNT.EQ.2)THEN
    DEALLOCATE(ZZ0)
    DEALLOCATE(ZZB)
  ELSEIF(IFPCDNT.EQ.1)THEN
    DEALLOCATE(PP0,PPM)
  ENDIF
  RETURN
END SUBROUTINE BKGMEMRLS

SUBROUTINE DRCONTOUR_0(S,FN)
!*************************************************
! DRAW THE ANALYSIS (AFFILIATE)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER   :: I,J,K,T,S,IU
  REAL      :: MX,MN
  CHARACTER(LEN=5) :: FN
! --------------------
  K=2 !(NUMGRID(3)+1)/2 !NUMGRID(3)
  T=(NUMGRID(4)+1)/2 !NUMGRID(4) !1
  IU=2
  OPEN(IU,FILE=FN,STATUS='UNKNOWN')
  MX=-1000.0
  MN=1000.0
  DO I=1,NUMGRID(1)
  DO J=1,NUMGRID(2)
    IF(GRDBKGD0(I,J,K,T,S).LT.9000.0)THEN
      IF(GRDBKGD0(I,J,K,T,S).GT.MX)MX=GRDBKGD0(I,J,K,T,S)
      IF(GRDBKGD0(I,J,K,T,S).LT.MN)MN=GRDBKGD0(I,J,K,T,S)
    ENDIF
  ENDDO
  ENDDO
  WRITE(IU,'(A4)')'DSAA'
  WRITE(IU,'(2I4)')NUMGRID(1),NUMGRID(2)
  WRITE(IU,*)ORIPSTN(1),ORIPSTN(1)+(NUMGRID(1)-1)*GRDSPAC(1)
  WRITE(IU,*)ORIPSTN(2),ORIPSTN(2)+(NUMGRID(2)-1)*GRDSPAC(2)
  WRITE(IU,*)MN,MX
  DO I=1,NUMGRID(1)
  DO J=1,NUMGRID(2)
    IF(GRDBKGD0(I,J,K,T,S).GT.9000.0)GRDBKGD0(I,J,K,T,S)=2.E38
  ENDDO
  ENDDO
  DO J=1,NUMGRID(2)
    WRITE(IU,*)(GRDBKGD0(I,J,K,T,S),I=1,NUMGRID(1))
  ENDDO
  CLOSE(IU)
  RETURN
END SUBROUTINE DRCONTOUR_0

SUBROUTINE RADIALWND(IC,JC)
!*************************************************
! DRAW RADIAL WIND (AFFILIATE)
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: IU,IC,JC,I,J,K,T
  REAL     :: DX,DY,DD,MN,MX
  REAL     :: UV(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4))
! --------------------
  DO T=1,NUMGRID(4)
  DO K=1,NUMGRID(3)
  DO J=1,NUMGRID(2)
  DO I=1,NUMGRID(1)
    IF(I.EQ.IC.AND.J.EQ.JC)THEN
      UV(I,J,K,T)=2.E38
      CYCLE
    ENDIF
    DX=1.0D0*(I-IC)
    DY=1.0D0*(J-JC)
    DD=SQRT(DX*DX+DY*DY)
    UV(I,J,K,T)=GRDBKGD0(I,J,K,T,U_CMPNNT)*DX/DD+GRDBKGD0(I,J,K,T,V_CMPNNT)*DY/DD
  ENDDO
  ENDDO
  ENDDO
  ENDDO
  K=(NUMGRID(3)+1)/2 !NUMGRID(3)
  T=(NUMGRID(4)+1)/2 !NUMGRID(4) !1
  IU=2
  OPEN(IU,FILE='RADIAL.GRD',STATUS='UNKNOWN')
  MX=-1000.0
  MN=1000.0
  DO I=1,NUMGRID(1)
  DO J=1,NUMGRID(2)
    IF(UV(I,J,K,T).LT.9000.0)THEN
      IF(UV(I,J,K,T).GT.MX)MX=UV(I,J,K,T)
      IF(UV(I,J,K,T).LT.MN)MN=UV(I,J,K,T)
    ENDIF
  ENDDO
  ENDDO
  WRITE(IU,'(A4)')'DSAA'
  WRITE(IU,'(2I4)')NUMGRID(1),NUMGRID(2)
  WRITE(IU,*)ORIPSTN(1),ORIPSTN(1)+(NUMGRID(1)-1)*GRDSPAC(1)
  WRITE(IU,*)ORIPSTN(2),ORIPSTN(2)+(NUMGRID(2)-1)*GRDSPAC(2)
  WRITE(IU,*)MN,MX
  DO I=1,NUMGRID(1)
  DO J=1,NUMGRID(2)
    IF(UV(I,J,K,T).GT.9000.0)UV(I,J,K,T)=2.E38
  ENDDO
  ENDDO
  DO J=1,NUMGRID(2)
    WRITE(IU,*)(UV(I,J,K,T),I=1,NUMGRID(1))
  ENDDO
  CLOSE(IU)
  RETURN
END SUBROUTINE RADIALWND

!!added by shuyuan 20100729!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine put_laps_3d_multi_R(i4time,EXT,var_3d &  ! in
             ,units_3d,comment_3d       &            ! in
             ,array1,array2              &           ! in
             ,NX_L_1,NY_L_1,NZ_L_1     &             ! in
             ,NX_L_2,NY_L_2,NZ_L_2      &            ! in
             ,N_3D_FIELDS,istatus)              !in out

   real array1(NX_L_1,NY_L_1,NZ_L_1) !variable for output
   real array2(NX_L_2,NY_L_2,NZ_L_2) !variable for output

   character*125 comment_3D(N_3D_FIELDS) !variable comment
   character*10 units_3D(N_3D_FIELDS)    !variable unit
   character*3 var_3D(N_3D_FIELDS)      !variable name
   character*(*) EXT                    ! file name suffix and file derictory
   integer :: l

   write(6,*)' Subroutine put_laps_3d_multi_R...'

   l = 1
   call put_laps_multi_3d(i4time,EXT,var_3d(l),units_3d(l), &
        comment_3d(l),array1,NX_L_1,NY_L_1,NZ_L_1,1,istatus)
   if(istatus .ne. 1)return
   if(l .eq. N_3D_FIELDS)return

   l = 2
   call put_laps_multi_3d_append(i4time,EXT,var_3d(l),units_3d(l),   &
        comment_3d(l),array2,NX_L_2,NY_L_2,NZ_L_2,1,istatus)
   if(istatus .ne. 1)return
   if(l .eq. N_3D_FIELDS)return

   write(6,*)' Error: N_3D_FIELDS exceeds limit ',N_3D_FIELDS

   return
 end subroutine put_laps_3d_multi_R

!!!!from cloud_deriv_subs!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine put_laps_multi_3d_append(i4time,EXT,var_2d,units_2d, &
                         comment_2d,field_3d,ni,nj,nk,nf,istatus)

        logical ltest_vertical_grid

        character*150 DIRECTORY
        character*(*) EXT

        character*125 comment_3d(nk*nf),comment_2d(nf)
        character*10 units_3d(nk*nf),units_2d(nf)
        character*3 var_3d(nk*nf),var_2d(nf)
        integer LVL_3d(nk*nf)
        character*4 LVL_COORD_3d(nk*nf)

        real field_3d(ni,nj,nk,nf)

        istatus = 0

        call get_directory(ext,directory,len_dir)

        do l = 1,nf
            write(6,11)directory,ext(1:5),var_2d(l)
11          format(' Writing 3d ',a50,1x,a5,1x,a3)
        enddo ! l

        do l = 1,nf
          do k = 1,nk

            iscript_3d = (l-1) * nk + k

            units_3d(iscript_3d)   = units_2d(l)
            comment_3d(iscript_3d) = comment_2d(l)
            if(ltest_vertical_grid('HEIGHT'))then
                lvl_3d(iscript_3d) = zcoord_of_level(k)/10
                lvl_coord_3d(iscript_3d) = 'MSL'
            elseif(ltest_vertical_grid('PRESSURE'))then

                lvl_3d(iscript_3d) = nint(zcoord_of_level(k))/100
                lvl_coord_3d(iscript_3d) = 'HPA'
            else
                write(6,*)' Error, vertical grid not supported,'  &
                         ,' this routine supports PRESSURE or HEIGHT'
                istatus = 0
                return
            endif

            var_3d(iscript_3d) = var_2d(l)

          enddo ! k
        enddo ! l

        CALL WRITE_LAPS_MULTI(I4TIME,DIRECTORY,EXT,ni,nj, &
        nk*nf,nk*nf,VAR_3D,LVL_3D,LVL_COORD_3D,UNITS_3D,  &
                           COMMENT_3D,field_3d,ISTATUS)

        if(istatus .ne. 1)return

        istatus = 1

        return
        end subroutine put_laps_multi_3d_append
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE OUTPUT_ANALS


!----------------------------------------------------------------------------
! This file is part of UCLALES.
!
! UCLALES is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! UCLALES is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 199-2007, Bjorn B. Stevens, Dep't Atmos and Ocean Sci, UCLA
!----------------------------------------------------------------------------
!
MODULE step

  USE mo_submctl, ONLY : spec, nice
  USE util, ONLY : getMassIndex, calc_correlation
  USE mo_structured_datatypes, ONLY : FloatArray1d, FloatArray3d, FloatArray4d ! poista vika

  IMPLICIT NONE

  INTEGER :: istpfl = 1
  REAL    :: timmax = 18000.
  LOGICAL :: corflg = .FALSE.

  REAL    :: frqhis =  9000.
  REAL    :: radfrq =  0.

  REAL    :: time   =  0.
  REAL    :: strtim =  0.0    ! In decimal days, 0.5 mid-day
  LOGICAL :: outflg = .TRUE.

CONTAINS
   !
   ! ----------------------------------------------------------------------
   ! Subroutine model:  This is the main driver for the model's time
   ! integration.  It calls the routine tstep, which steps through the
   ! physical processes active on a time-step and updates variables.  It
   ! then checks to see whether or not different output options are
   ! satisfied.
   SUBROUTINE stepper

      USE mpi_interface, ONLY : myid, double_scalar_par_max, mpiroot
      USE mo_vector_state, ONLY : a_uc, a_vc, a_wc, a_up, a_vp, a_wp
      USE grid, ONLY : dtl, dtlt,  &
                       dtlv, dtlong, nzp, nyp, nxp, level
      USE thrm, ONLY : thermo
      USE mo_output, ONLY : write_main, close_main, write_ps, close_ps,    &
                            write_ts, close_ts, tsflg, psflg, ts_intvl,    &
                            ps_intvl, main_intvl
      USE mo_history, ONLY : write_hist

      LOGICAL, PARAMETER :: StopOnCFLViolation = .FALSE.
      REAL, PARAMETER :: cfl_upper = 0.50, cfl_lower = 0.30

      REAL         :: t1,t2,tplsdt,begtime
      REAL(kind=8) :: cflmax,gcflmax
      INTEGER      :: istp
      LOGICAL :: cflflg
      !
      ! Timestep loop for program
      !
      begtime = time
      istp = 0

      CALL cpu_time(t1)

      DO WHILE (time + 0.1*dtl < timmax)

         istp = istp+1
         tplsdt = time + dtl + 0.1*dtl

         tsflg = ( mod(tplsdt,ts_intvl) < dtl .OR. time >= timmax .OR. time == dtl )
         psflg = ( mod(tplsdt,ps_intvl) < dtl .OR. time >= timmax .OR. time == dtl )

         CALL t_step(cflflg,cflmax)

         time = time + dtl

         CALL double_scalar_par_max(cflmax,gcflmax)
         cflmax = gcflmax

         IF (cflmax > cfl_upper .OR. cflmax < cfl_lower) THEN
            CALL tstep_reset(nzp,nxp,nyp,a_up%d,a_vp%d,a_wp%d,a_uc%d,a_vc%d,a_wc%d,     &
                             dtl,dtlong,cflmax,cfl_upper,cfl_lower)
            dtlv = 2.*dtl
            dtlt = dtl
         END IF

         !
         ! output control
         !
         IF (psflg) &
              CALL write_ps(time)

         IF (tsflg) &
              CALL write_ts(time)

         IF ((mod(tplsdt,frqhis) < dtl .OR. time >= timmax) .AND. outflg)   &
            CALL write_hist(2, time)

         IF ((mod(tplsdt,main_intvl) < dtl .OR. time >= timmax) .AND. outflg) THEN
            CALL thermo(level)
            CALL write_main(time)
         END IF

         IF (cflflg) THEN
            cflflg = .FALSE.
            IF (StopOnCFLViolation) CALL write_hist(-1,time)
         END IF

         IF(myid == 0) THEN
            CALL cpu_time(t2) ! t2-t1 is the actual time from output
            IF (mod(istp,istpfl) == 0 ) THEN
               PRINT "('   Timestep # ',i6," //     &
                  "'   Model time(sec)=',f10.2,3x,'CPU time(sec)=',f8.3)",     &
                  istp, time, t2-t1
               CALL cpu_time(t1)
            END IF
         END IF

      END DO

      CALL write_hist(1, time)
      CALL close_main()
      IF (myid == mpiroot) THEN
         CALL close_ps()
         CALL close_ts()
      END IF

   END SUBROUTINE stepper
   !
   !----------------------------------------------------------------------
   ! Subroutine tstep_reset: Called to adjust current velocity and reset
   ! timestep based on cfl limits
   !
   SUBROUTINE tstep_reset(n1,n2,n3,up,vp,wp,uc,vc,wc,dtl,dtmx,cfl,c1,c2)

      INTEGER, INTENT (in)      :: n1,n2,n3
      REAL, INTENT (in)         :: up(n1,n2,n3),vp(n1,n2,n3),wp(n1,n2,n3),dtmx,c1,c2
      REAL(kind=8), INTENT (IN) :: cfl
      REAL, INTENT (inout)      :: uc(n1,n2,n3),vc(n1,n2,n3),wc(n1,n2,n3),dtl

      INTEGER :: i,j,k
      REAL    :: cbar, dtl_old

      cbar = (c1+c2)*0.5
      dtl_old = dtl

      IF (cfl > c1) dtl = min(dtmx,dtl*cbar/c1)
      IF (cfl < c2) dtl = min(dtmx,dtl*cbar/c2)

      DO j = 1, n3
         DO i = 1, n2
            DO k = 1, n1
               uc(k,i,j) = up(k,i,j) + (uc(k,i,j)-up(k,i,j))*dtl/dtl_old
               vc(k,i,j) = vp(k,i,j) + (vc(k,i,j)-vp(k,i,j))*dtl/dtl_old
               wc(k,i,j) = wp(k,i,j) + (wc(k,i,j)-wp(k,i,j))*dtl/dtl_old
            END DO
         END DO
      END DO

   END SUBROUTINE tstep_reset

   !
   !----------------------------------------------------------------------
   ! Subroutine set_LES_runtime: Set the status of process switches e.g.
   ! if they have a defined spinup time etc.
   !
   SUBROUTINE set_LES_runtime(time)
     USE mcrp, ONLY : sed_aero,   &
                      sed_cloud,  &
                      sed_precp,  &
                      sed_ice,    &
                      bulk_autoc
     USE grid, ONLY : level
     IMPLICIT NONE

     REAL, INTENT(in) :: time

     IF ( sed_aero%switch .AND. time > sed_aero%delay ) sed_aero%state = .TRUE.
     IF ( sed_cloud%switch .AND. time > sed_cloud%delay ) sed_cloud%state = .TRUE.
     IF ( sed_precp%switch .AND. time > sed_precp%delay ) sed_precp%state = .TRUE.
     IF ( sed_ice%switch .AND. time > sed_ice%delay ) sed_ice%state = .TRUE.
     IF ( bulk_autoc%switch .AND. time > bulk_autoc%delay ) bulk_autoc%state = .TRUE.
     IF (level < 5) THEN
        sed_ice%state = .FALSE.
     END IF

   END SUBROUTINE set_LES_runtime

   !
   !----------------------------------------------------------------------
   ! Subroutine t_step: Called by driver to timestep through the LES
   ! routines.  Within many subroutines, data is accumulated during
   ! the course of a timestep for the purposes of statistical analysis.
   !
   SUBROUTINE t_step(cflflg,cflmax)

      USE grid, ONLY : level,dtlt,      &
                       nxp,nyp,nzp,   &
                       a_nactd,  a_vactd
      USE mo_vector_state, ONLY : a_wp
      USE mo_field_state, ONLY : Diag, Prog
      USE sgsm, ONLY : diffuse
      USE srfc, ONLY : surface
      USE thrm, ONLY : thermo
      USE mcrp, ONLY : micro
      USE prss, ONLY : poisson
      USE advf, ONLY : fadvect, newdroplet
      USE advl, ONLY : ladvect
      USE forc, ONLY : forcings
      USE util, ONLY : maskactiv !Juha: Included for SALSA

      USE mo_salsa_driver, ONLY : run_SALSA

      USE constrain_SALSA, ONLY : SALSA_diagnostics, tend_constrain2

      LOGICAL, INTENT (out)      :: cflflg
      REAL(KIND=8), INTENT (out) :: cflmax

      REAL    :: zwp(nzp,nxp,nyp)  !! FOR SINGLE-COLUMN RUNS

      INTEGER :: nspec

      CALL set_LES_runtime(time)

      zwp = 0.5  ! single column run vertical velocity

      cflflg = .FALSE.

      ! Reset ALL tendencies here.
      !----------------------------------------------------------------
      ! "Scalar" timestep
      CALL tend0(.FALSE.)

      ! Put the newly activated to zero
      IF (level >= 4) THEN
         a_vactd = 0.
         a_nactd = 0.
      END IF

      CALL surface()

      CALL diffuse

      CALL sponge(0)

      IF (level >= 1) CALL forcings(time,strtim)

      CALL update_sclrs
      CALL tend0(.TRUE.)
      CALL thermo(level)

      ! SALSA timestep
      ! -----------------------
      IF (level >= 4) THEN

         nspec = spec%getNSpec(type="wet") ! Aerosol components + water

         IF ( nxp == 5 .AND. nyp == 5 ) THEN
            ! 1D -runs
            CALL run_SALSA(Diag,Prog,nzp,nxp,nyp,nspec,   &
                           zwp,a_nactd,a_vactd,dtlt,      &
                           time,level,.FALSE.             )
         ELSE
            !! for 2D or 3D runs
            CALL run_SALSA(Diag,Prog,nzp,nxp,nyp,nspec,   &
                           a_wp%d,a_nactd,a_vactd,dtlt,     &
                           time,level,.FALSE.             )

         END IF !nxp==5 and nyp == 5

         CALL tend_constrain2()
         CALL update_sclrs
         CALL tend0(.TRUE.)
         CALL SALSA_diagnostics(.FALSE.)
         CALL thermo(level)

      END IF ! level >= 4

      !-------------------------------------------
      ! "Deposition" timestep
      ! Dont perform sedimentation or level 3 autoconversion during spinup (internal switches implemented)
      CALL micro(level)
      IF (level >= 4) CALL tend_constrain2()
      CALL update_sclrs
      CALL tend0(.TRUE.)
      IF (level >= 4) CALL SALSA_diagnostics(.TRUE.)
      CALL thermo(level)

      !-------------------------------------------
      ! "Advection" timestep
      CALL fadvect

      IF (level >= 4) CALL tend_constrain2()
      CALL update_sclrs
      CALL tend0(.TRUE.)
      IF (level >= 4) CALL SALSA_diagnostics(.TRUE.)
      CALL thermo(level)

      CALL corlos

      CALL ladvect

      CALL buoyancy

      CALL sponge(1)

      CALL poisson

      CALL cfl (cflflg, cflmax)

      IF (level >= 4) CALL SALSA_diagnostics(.TRUE.)
      CALL thermo(level)

   END SUBROUTINE t_step
   !
   !----------------------------------------------------------------------
   ! Subroutine tend0: sets all tendency arrays to zero
   !
   SUBROUTINE tend0(sclonly)

     USE grid, ONLY : nscl, a_st, newsclr
     USE mo_vector_state, ONLY : a_ut, a_vt, a_wt

      LOGICAL, INTENT(in) :: sclonly ! If true, only put scalar tendencies to zero

      INTEGER :: n

      IF( .NOT. sclonly) THEN
         a_ut%d = 0.; a_vt%d = 0.; a_wt%d = 0.
      END IF
      DO n = 1, nscl
         CALL newsclr(n)
         a_st = 0.
      END DO

   END SUBROUTINE tend0

   !
   !----------------------------------------------------------------------
   ! Subroutine cfl: Driver for calling CFL computation subroutine
   !
   SUBROUTINE cfl(cflflg,cflmax)

      USE grid, ONLY : nxp,nyp,nzp,dxi,dyi,dtlt
      USE mo_vector_state, ONLY : a_up, a_vp, a_wp
      USE mo_aux_state, ONLY : dzt
      !USE stat, ONLY : fill_scalar

      LOGICAL, INTENT(out) :: cflflg
      REAL(KIND=8), INTENT (out)   :: cflmax
      REAL, PARAMETER :: cflnum = 0.95

      cflmax =  cfll(nzp,nxp,nyp,a_up%d,a_vp%d,a_wp%d,dxi,dyi,dzt,dtlt)

      cflflg = (cflmax > cflnum)
      IF (cflflg) PRINT *, 'Warning CFL Violation :', cflmax

   END SUBROUTINE cfl
   !
   !----------------------------------------------------------------------
   ! Subroutine cfll: Checks CFL criteria, brings down the model if the
   ! maximum thershold is exceeded
   !
   REAL(KIND=8) FUNCTION cfll(n1,n2,n3,u,v,w,dxi,dyi,dzt,dtlt)

      INTEGER, INTENT (in) :: n1, n2, n3
      REAL, DIMENSION (n1,n2,n3), INTENT (in) :: u, v, w
      REAL, INTENT (in)    :: dxi,dyi,dtlt
      TYPE(FloatArray1d), INTENT(in) :: dzt

      INTEGER :: i, j, k
      cfll = 0.
      DO j = 3, n3-2
         DO i = 3, n2-2
            DO k = 1, n1
               cfll = max(cfll, dtlt*2.* max(abs(u(k,i,j)*dxi),             &
                      abs(v(k,i,j)*dyi), abs(w(k,i,j)*dzt%d(k))))
            END DO
         END DO
      END DO

   END FUNCTION cfll
   !
   !----------------------------------------------------------------------
   ! Subroutine update_sclrs:  Updates scalars by applying tendency and
   ! boundary conditions
   !
   SUBROUTINE update_sclrs

      USE grid, ONLY : a_sp, a_st, nscl, nxyzp, nxp, nyp, nzp, &
                       dtlt, newsclr, isgstyp
      USE mo_aux_state, ONLY : dzt
      USE mo_progn_state, ONLY : a_qp
      USE sgsm, ONLY : tkeinit
      USE util, ONLY : sclrset

      INTEGER :: n

      DO n = 1, nscl
         CALL newsclr(n)
         CALL update(nzp,nxp,nyp,a_sp,a_st,dtlt)
         CALL sclrset('mixd',nzp,nxp,nyp,a_sp,dzt%d)
      END DO

      IF (isgstyp == 2) THEN
         CALL tkeinit(nxyzp,a_qp%d)
      END IF

   END SUBROUTINE update_sclrs
   !
   ! ----------------------------------------------------------------------
   ! Subroutine update:
   !
   SUBROUTINE update(n1,n2,n3,a,fa,dt)

      INTEGER, INTENT(in)   :: n1, n2, n3
      REAL, INTENT (in)     :: fa(n1,n2,n3),dt
      REAL, INTENT (inout)  :: a(n1,n2,n3)
      INTEGER :: i, j, k

      DO j = 3, n3-2
         DO i = 3, n2-2
            DO k = 2, n1-1
               a(k,i,j) = a(k,i,j) + fa(k,i,j)*dt
            END DO
         END DO
      END DO

   END SUBROUTINE update
   !
   ! ----------------------------------------------------------------------
   ! Subroutine buoyancy:
   !
   SUBROUTINE buoyancy

     USE grid, ONLY : nxp, nyp, nzp, th00, level
     USE mo_vector_state, ONLY : a_wt
     !USE stat, ONLY : sflg, comp_tke
     USE mo_diag_state, ONLY : a_rv, a_rc, a_theta, a_srp, a_ri, a_riri
     USE mo_progn_state, ONLY : a_rp
     USE mo_aux_state, ONLY : pi1
     USE util, ONLY : ae1mm
     USE thrm, ONLY : update_pi1

     REAL :: awtbar(nzp), a_tmp1(nzp,nxp,nyp), rv(nzp,nxp,nyp), rc(nzp,nxp,nyp)

     IF (level < 4) THEN
        rv = a_rv%d ! Water vapor
        rc = a_rp%d - a_rv%d ! Total condensate (cloud + precipitation)
     ELSE IF (level == 4) THEN
        rv = a_rp%d ! Water vapor
        rc = a_rc%d + a_srp%d
     ELSE IF (level == 5) THEN
        rv = a_rp%d
        rc = a_rc%d + a_srp%d + a_ri%d + a_riri%d  ! Total condensed water (aerosol+cloud+precipitation+ice)
     END IF
     call boyanc(nzp,nxp,nyp,a_wt%d,a_theta,rv,th00,a_tmp1,rc)

     CALL ae1mm(nzp,nxp,nyp,a_wt%d,awtbar)
     CALL update_pi1(nzp,awtbar,pi1)

   END SUBROUTINE buoyancy
   !
   ! ----------------------------------------------------------------------
   ! Subroutine boyanc:
   !
   SUBROUTINE boyanc(n1,n2,n3,wt,th,rv,th00,scr,rc)

     USE defs, ONLY : g, ep2

     INTEGER, INTENT(in) :: n1,n2,n3
     REAL, INTENT(in)    :: th00
     TYPE(FloatArray3d), INTENT(in) :: th

     REAL, INTENT(in)    :: rv(n1,n2,n3)  ! water vapor
     REAL, INTENT(in)    :: rc(n1,n2,n3)  ! Total condensed water (aerosol, cloud, rain, ice and snow) mixing ratio

     REAL, INTENT(inout) :: wt(n1,n2,n3)
     REAL, INTENT(out)   :: scr(n1,n2,n3)

     INTEGER :: k, i, j
     REAL    :: gover2

     gover2 = 0.5*g

     do j=3,n3-2
        do i=3,n2-2
           do k=1,n1
              scr(k,i,j)=gover2*((th%d(k,i,j)*(1.+ep2*rv(k,i,j))-th00)/th00-rc(k,i,j))
           end do

           do k=2,n1-2
              wt(k,i,j)=wt(k,i,j)+scr(k,i,j)+scr(k+1,i,j)
           end do
        end do
     end do

   END SUBROUTINE boyanc
   !
   ! ----------------------------------------------------------------------
   ! Subroutine corlos:  This is the coriolis driver, its purpose is to
   ! from the coriolis accelerations for u and v and add them into the
   ! accumulated tendency arrays of ut and vt.
   !
   SUBROUTINE corlos

     USE defs, ONLY : omega
     USE mo_aux_state, ONLY : u0, v0
      USE grid, ONLY : nxp, nyp, nzp, cntlat
      USE mo_vector_state, ONLY : a_uc, a_vc, a_ut, a_vt

      LOGICAL, SAVE :: initialized = .FALSE.
      REAL, SAVE    :: fcor

      INTEGER :: i, j, k

      IF (corflg) THEN
         IF (.NOT. initialized) fcor = 2.*omega*sin(cntlat*0.01745329)
         DO j = 3, nyp-2
            DO i = 3, nxp-2
               DO k = 2, nzp
                  a_ut%d(k,i,j) = a_ut%d(k,i,j) - fcor*(v0%d(k)-0.25*                   &
                                (a_vc%d(k,i,j)+a_vc%d(k,i+1,j)+a_vc%d(k,i,j-1)+a_vc%d(k,i+1,j-1)))
                  a_vt%d(k,i,j) = a_vt%d(k,i,j) + fcor*(u0%d(k)-0.25*                   &
                                (a_uc%d(k,i,j)+a_uc%d(k,i-1,j)+a_uc%d(k,i,j+1)+a_uc%d(k,i-1,j+1)))
               END DO
            END DO
         END DO
         initialized = .TRUE.
      END IF

   END SUBROUTINE corlos
   !
   ! ----------------------------------------------------------------------
   ! Subroutine sponge: does the rayleigh friction for the momentum terms,
   ! and newtonian damping of thermal term the damping is accumulated with the
   ! other tendencies
   !
   SUBROUTINE sponge (isponge)

      USE grid, ONLY : nfpt, spng_tfct, spng_wfct, nzp, nxp, nyp, th00
      USE mo_vector_state, ONLY : a_up, a_vp, a_wp, a_ut, a_vt, a_wt
      USE mo_progn_state, ONLY : a_tp, a_tt
      USE mo_aux_state, ONLY : u0, v0, th0

      INTEGER, INTENT (in) :: isponge

      INTEGER :: i, j, k, kk

      IF (maxval(spng_tfct) > epsilon(1.) .AND. nfpt > 1) THEN
         DO j = 3, nyp-2
            DO i = 3, nxp-2
               DO k = nzp-nfpt, nzp-1
                  kk = k+1-(nzp-nfpt)
                  IF (isponge == 0) THEN
                     a_tt%d(k,i,j) = a_tt%d(k,i,j) - spng_tfct(kk)*                   &
                                   (a_tp%d(k,i,j)-th0%d(k)+th00)
                  ELSE
                     a_ut%d(k,i,j) = a_ut%d(k,i,j) - spng_tfct(kk)*(a_up%d(k,i,j)-u0%d(k))
                     a_vt%d(k,i,j) = a_vt%d(k,i,j) - spng_tfct(kk)*(a_vp%d(k,i,j)-v0%d(k))
                     a_wt%d(k,i,j) = a_wt%d(k,i,j) - spng_wfct(kk)*(a_wp%d(k,i,j))
                  END IF
               END DO
            END DO
         END DO
      END IF

   END SUBROUTINE sponge

END MODULE step