!-------------------------------------------------------------
!--  Modul for the Saving Control Values
!-------------------------------------------------------------
 MODULE Control_Mod
   USE Kind_Mod
!
!-----------------------------------------------------------------
!---  Scenario
!-----------------------------------------------------------------
!
!--- Identifier for scenario
      CHARACTER(80) :: Bsp        = ''      ! Identifier for scenario

!--- Files
      CHARACTER(80) :: RunFile    = ''    & ! Simulation data file
&                    , MetFile    = ''    & ! Meteorology file
&                    , SysFile    = ''    & ! Chemical mechanism
&                    , ChemFile   = ''    & ! Chemical mechenism (spaccim input)
&                    , InitFile   = ''    & ! Initial concentrations
&                    , DataFile   = ''    & ! Gas and Aqueous DATA
&                    , MWFile     = ''    & ! molecular weights of species
&                    , NetcdfFile = ''    & ! NetCDF output file
&                    , ODEsolver  = ''    & ! Method for Rosenbrock Integration
&                    , TargetFile = ''      ! file for reductions analysis (target species)

      CHARACTER(7)  :: OutputPath   = 'OUTPUT/'  ! path to output folder
      CHARACTER(80) :: FluxMetaFile = ''         ! meta data for unformatted flux data
      CHARACTER(80) :: FluxFile     = ''         ! flux data (unformatted)

      REAL(dp) :: Red_TStart, Red_TEnd     ! time interval for redcution procedure
      REAL(dp) :: eps_red                  ! threshold for reduction procedure
!
!--- Unit Numbers
      INTEGER, PARAMETER :: RunUnit      = 101  &
&                         , MetUnit      = 102  &
&                         , SysUnit      = 103  &
&                         , ChemUnit     = 104  &
&                         , MWUnit       = 105  &
&                         , InitUnit     = 106  &
&                         , DataUnit     = 107  &
&                         , FluxMetaUnit = 109  &
&                         , FluxUnit     = 110  &
&                         , TikZUnit     = 111
!
!-- Set Levels and Parameters for Processes
      REAL(dp) :: LWCLevelmin    & ! Lower level for LWC
&               , LWCLevelmax    & ! Upper level for LWC
&               , Temperature0   & ! Initial temperature
&               , Pressure0        ! Initial pressure for combustion mechanisms

!-- print matrices of the system (alpha, beta, miter, lu_miter, permutvector,..)
      LOGICAL :: MatrixPrint     & ! print certain matrices to file
&              , DebugPrint      & ! debugging rosenbrock steps
&              , NetCdfPrint     & ! print out concs and other stuff to netcdf file
&              , constLWC        & ! true if lwc value is fixed
&              , Teq             & ! if Teq=.TRUE. simulate combustion mechanism
&              , pHSet           & ! Initial pH by charge balance (1=on, 0=off)
&              , WaitBar         & ! ladebalken im terminal bei simulation (=1, default=0)
&              , FluxDataPrint   & ! writing flux data and analyse after simulaiton -> print new reaction file
&              , Simulation      & ! calculation of species concentration
&              , Reduction         ! reduction of chemical species and reactions

      LOGICAL :: KPP_Conversion

      INTEGER :: Error_Est         ! error estimation 1 = inf norm  , 2 = euklid norm

!--- Output of reaction fluxes
      REAL(dp)                    :: StpFlux
      INTEGER                     :: iStpFlux ! number of written flux steps

      INTEGER,          PARAMETER :: newReac_nr    = 1977
      CHARACTER(LEN=*), PARAMETER :: newReac_name  = 'BigRates.dat'
      INTEGER, ALLOCATABLE        :: newReac_List(:)
!-----------------------------------------------------------------
!---  Times
!-----------------------------------------------------------------
!-----------------------------------------------------------------
!--- Times:  < 0 in seconds, > 0 in hours, = 0  meteorology
      REAL(dp) :: tBegin              & ! Model start time
&               , tEnd              & ! Model end time
&               , StpNetcdf           ! Time step for Netcdf output
      INTEGER  :: nOutP

!--- NetCDF globals
      INTEGER, ALLOCATABLE :: iNcdfGas(:), iNcdfAqua(:), iNcdfSolid(:), iNcdfParti(:)
      INTEGER, ALLOCATABLE :: iNCout_G(:), iNCout_A_l(:), iNCout_A_m3(:), iNCout_S(:), iNCout_P(:)
      INTEGER  :: nNcdfGas=0, nNcdfAqua=0, nNcdfSolid=0, nNcdfParti=0 ! number of output spc for each phase
!

!---  Photolysis
      INTEGER :: iDate               ! Current date
      REAL(dp) :: rlat, rlon          ! Latitude, Longitude

!---  Liquid water content parameter

      REAL(dp) :: LWCconst=2.0d-8       ! [l/m3] no cloud
      REAL(dp) :: NCC=1000.0d0

!--  dust factor for damping of photolysis rates, measured JNO2
      REAL(dp) :: Dust = 1.0d0
      REAL(dp) :: minStp = 1.0d-25
      REAL(dp) :: maxStp = 100.0d0

!-- initialize timers
      REAL(dp) :: Timer_Start=0.0d0, Timer_Finish=0.d0
      REAL(dp) :: Tspan(2)
      REAL(dp) :: Tspan_tot(2)

      REAL(dp) :: Time_Read=0.0d0
      REAL(dp) :: TimeRates=0.0d0
      REAL(dp) :: TimeSymbolic=0.0d0
      REAL(dp) :: TimeFac=0.0d0
      REAL(dp) :: TimeSolve=0.0d0
      REAL(dp) :: TimeJac=0.0d0
      REAL(dp) :: TimeNetCDF=0.0d0
      REAL(dp) :: TimeErrCalc=0.0d0
      REAL(dp) :: TimeFluxWrite=0.0d0
      REAL(dp) :: TimeRhsCalc=0.0d0
      REAL(dp) :: TimeReduction=0.0d0

      REAL(dp) :: TimeIntegration=0.0d0
      REAL(dp) :: TimeRateA=0.0d0
      REAL(dp) :: TimeRateE=0.0d0
      REAL(dp) :: TimeJacobianA=0.0d0
      REAL(dp) :: TimeJacobianE=0.0d0
      REAL(dp) :: TimeNetCDFA=0.0d0
!

!--- type for some statistics
      TYPE Output_T
        REAL(dp), ALLOCATABLE :: y(:)    ! y-vector at Tend
        INTEGER :: nsteps     = 0              ! # succ. steps
        INTEGER :: nfailed    = 0              ! # failed steps
        INTEGER :: nRateEvals = 0              ! # Rate evaluation
        INTEGER :: npds       = 0              ! # Jacobian evaluation
        INTEGER :: ndecomps   = 0              ! # LU factorisation
        INTEGER :: nsolves    = 0              ! # solved lin algebra
        REAL(dp) :: Ttimestep = 0.0d0  ! mean Time for one ROW step
      END TYPE Output_T

      TYPE(Output_T) :: Out
!-----------------------------------------------------------------
!---  Numerics
!-----------------------------------------------------------------
!
!
!--- Tolerances for ROW Scheme
      REAL(dp) :: RtolROW        & ! Relative tolerance for ROW method
&               , AtolGas        & ! Absolute tolerance for gas phase
&               , AtolAqua       & ! Absolute tolerance for liquid phase
&               , AtolTemp         ! Absolute tolerance for Temperatur

      INTEGER  :: Ordering     ! default = 8
      INTEGER  :: ParOrdering  ! < 0 serial ordering , 0,1,2 parallel

      REAL(dp), ALLOCATABLE :: ATolAll(:)

!--- Logical variable for PI setsize controler
      LOGICAL :: PI_StepSize

!--- Control Parameter for solving linear algebra
      ! 'cl' for classic jacobian calc or
      ! 'ex' for extended matrix without calc of jac
      CHARACTER(2) :: LinAlg = '??'

!
!-----------------------------------------------------------------
!---  Set Constants and Unit Conversion
!-----------------------------------------------------------------
!
!---  constants
    REAL(dp), PARAMETER :: HOUR       = 3600.0             &
&                        , hourday    = 86400.0            &
&                        , secday     = 4.32d04            &
&                        , mONE       = -1.d0              &
&                        , Pi         = 4.0d0*ATAN(1.0d0)  &
&                        , DR         = Pi / 180.d0        &
&                        , PiHalf     = 2.0d0*ATAN(1.0d0)  &
&                        , Pi34       = 3.0d0/4.0d0/Pi     &
&                        , eps        = EPSILON(1.0d0)     &  ! such that 1+eps>1 with working precision
&                        , small      = TINY(1.0d0)        &  ! smallest pos. real value
&                        , big        = HUGE(1.0d0)        &  ! largest pos. real value
&                        , epsY       = 1.0d-7             &
&                        , SI_am      = 1.66053892173d-27  &  ! Atomic mass unit  [kg]
&                        , SI_na      = 6.0221412927d+23   &  ! Avogadro's number [1/mol]
&                        , SI_kB      = 1.380648813d-23    &  ! Bolzmann constant [J/K]
&                        , SI_Gas     = SI_na * SI_kB         ! Gas constant      [J/mol/K]
!
!--- Real number constants
  REAL(dp), PARAMETER ::   ZERO    =     0.0d0   &
&                      ,  ONE     =     1.0d0   &
&                      ,  TWO     =     2.0d0  ,   rTWO     =   ONE/tWO     &
&                      ,  THREE   =     3.0d0  ,   rTHREE   =   ONE/THREE   &
&                      ,  FOUR    =     4.0d0  ,   rFOUR    =   ONE/FOUR    &
&                      ,  FIVE    =     5.0d0  ,   rFIVE    =   ONE/FIVE    &
&                      ,  SIX     =     6.0d0  ,   rSIX     =   ONE/SIX     &
&                      ,  SEVEN   =     7.0d0  ,   rSEVEN   =   ONE/SEVEN   &
&                      ,  EIGHT   =     8.0d0  ,   rEIGHT   =   ONE/EIGHT   &
&                      ,  NINE    =     9.0d0  ,   rNINE    =   ONE/NINE    &
&                      ,  TEN     =    10.0d0  ,   rTEN     =   ONE/TEN     &
&                      ,  ELEVN   =    11.0d0  ,   rELEVN   =   ONE/ELEVN   &
&                      ,  TWELV   =    12.0d0  ,   rTWELV   =   ONE/TWELV   &
&                      , TWENTY   =    20.0d0  ,   rTWENTY  =   ONE/TWENTY  &
&                      , mTHIRTY  =   -30.0d0  &
&                      , rm300    = mONE/300.d0,   r300     =   ONE/300.d0
!
!--- Orders of magnitude
  REAL(dp), PARAMETER ::  nano    =     1.0d-09    &
&                      , micro    =     1.0d-06    &
&                      , milli    =     1.0d-03    &
&                      , kilo     =     1.0d+03    &
&                      , mega     =     1.0d+06    &
&                      , giga     =     1.0d+09
!
!--- Natural logarithms
  REAL(dp), PARAMETER ::   ln10   =     LOG(TEN)    &
&                      ,  rln10   = ONE/LOG(TEN)
!
!--- minimum values if there is no sun
  REAL(dp), PARAMETER ::    EyChiZmin  =  9.357d-14
!
!
!--- Unit Conversion constants
!
!     Pressure
  REAL(dp), PARAMETER :: bar_to_dyncm2 = 1.0d06
  REAL(dp), PARAMETER :: dyncm2_to_Pa  = 1.0d-01
  REAL(dp), PARAMETER :: Pa_to_dyncm2  = 1.0d+01
  REAL(dp), PARAMETER :: bar_to_Pa     = 1.0d05
  REAL(dp), PARAMETER :: atm_to_Pa     = 101325.0d0
!
!     Energy
  REAL(dp), PARAMETER :: cal_to_joule  = 4.184d0
  REAL(dp), PARAMETER :: joule_to_cal  = ONE / cal_to_joule
  REAL(dp), PARAMETER :: joule_to_kcal = milli * joule_to_cal
  REAL(dp), PARAMETER :: kcal_to_joule = kilo * cal_to_joule
  REAL(dp), PARAMETER :: joule_to_erg  = TEN * mega
  REAL(dp), PARAMETER :: erg_to_joule  = rTEN * micro
!
!--- Physical constants ********************************************

!     Universal gas constant [J / mol / K]
  REAL(dp), PARAMETER :: R         = 8.31446210000000D0
  REAL(dp), PARAMETER :: rR        = ONE/R

!
!     Universal gas constant, calorie units [cal / mol / K]
  REAL(dp), PARAMETER :: Rcal      = R * joule_to_cal
  REAL(dp), PARAMETER :: rRcal     = ONE/Rcal
!
!     Universal gas constant, CGS units [erg / mol / K]
  REAL(dp), PARAMETER :: Rerg      = R * joule_to_erg
  REAL(dp), PARAMETER :: rRerg      = ONE/Rerg
!
!     Standard pressure [Pa]
  REAL(dp), PARAMETER :: Patm      = atm_to_Pa
  REAL(dp), PARAMETER :: rPatm     = ONE/Patm

!--- Unit Conversion
    INTEGER :: GasUnit, AquaUnit, GasRateUnit
    REAL(dp) :: GasFac

    INTEGER :: UnitGas=0
    INTEGER :: UnitAqua=0

!-----------------------------------------------------------------
!---  Output control
!-----------------------------------------------------------------

!
!-- input chemical reaction mechnism
    INTEGER, PARAMETER :: LenLine=400
    INTEGER, PARAMETER :: LenName=100
    INTEGER, PARAMETER :: LenType=20

!-- logicals for classic or extended matrix case
    LOGICAL :: CLASSIC  = .FALSE.
    LOGICAL :: EXTENDED = .FALSE.

    LOGICAL :: useMUMPS = .FALSE.
    LOGICAL :: useSparseLU = .FALSE.

    LOGICAL :: ChemKin = .FALSE.

    REAL(dp), ALLOCATABLE :: integrated_rates(:)
    REAL(dp), ALLOCATABLE :: mixing_ratios_spc(:,:)

!-- Type declaration
    TYPE List
      INTEGER,   ALLOCATABLE  :: List(:)
      Real(dp),  ALLOCATABLE  :: ListE(:)
      Real(dp),  ALLOCATABLE  :: ListP(:)
      INTEGER                :: len
    END TYPE List

    TYPE Chain
      CHARACTER(100), ALLOCATABLE :: sName(:,:)
      INTEGER,        ALLOCATABLE :: sIdx(:,:)
      Type(List),     ALLOCATABLE :: rIdx(:)
    END TYPE Chain

    TYPE Families_T
      CHARACTER(LenName), ALLOCATABLE :: Name(:)
      INTEGER,            ALLOCATABLE :: Index(:)
    END TYPE Families_T

    INTEGER, ALLOCATABLE :: maxErrorCounter(:)

 END MODULE Control_Mod


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

module model_mod

!> This is the interface for wrf_hydro and the DART data assimilation infrastructure.

use              types_mod, only : r8, i8, MISSING_R8, obstypelength, earth_radius

use      time_manager_mod, only : time_type, set_time, get_time, set_time_missing, &
                                  set_date, print_time, print_date, set_calendar_type

use          location_mod, only : location_type, get_close_type, get_dist, &
                                  loc_get_close_obs => get_close_obs, &
                                  loc_get_close_state => get_close_state, &
                                  convert_vertical_obs, convert_vertical_state, &
                                  set_location, set_location_missing, VERTISHEIGHT, &
                                  write_location

use         utilities_mod, only : register_module, error_handler, &
                                  E_ERR, E_MSG, file_exist, logfileunit, &
                                  nmlfileunit, do_output, do_nml_file, do_nml_term, &
                                  find_namelist_in_file, check_namelist_read, &
                                  to_upper

use  netcdf_utilities_mod, only : nc_check, nc_add_global_attribute, &
                                  nc_synchronize_file, nc_end_define_mode, &
                                  nc_add_global_creation_time, nc_begin_define_mode

use obs_def_utilities_mod, only : track_status

use         obs_kind_mod,  only : get_index_for_quantity, &
                                  get_name_for_quantity, &
                                  get_quantity_for_type_of_obs, &
                                  QTY_BUCKET_MULTIPLIER, &
                                  QTY_RUNOFF_MULTIPLIER, &
                                  QTY_STREAM_FLOW

use  ensemble_manager_mod, only : ensemble_type

use distributed_state_mod, only : get_state

use      dart_time_io_mod, only : write_model_time

use     default_model_mod, only : adv_1step, nc_write_model_vars

use        noah_hydro_mod, only : configure_lsm, configure_hydro, &
                                  n_link, linkLong, linkLat, linkAlt, get_link_tree, &
                                  BucketMask, full_to_connection, get_downstream_links, &
                                  read_hydro_global_atts, write_hydro_global_atts, &
                                  read_noah_global_atts, write_noah_global_atts, &
                                  get_hydro_domain_filename

use   state_structure_mod, only : add_domain,      get_domain_size,   &
                                  get_index_start, get_index_end,     &
                                  get_num_domains, get_num_variables, &
                                  get_num_dims,    get_dim_name,      &
                                  get_dim_length,  get_variable_name, &
                                  get_model_variable_indices,         &
                                  get_varid_from_kind,                &
                                  get_dart_vector_index,              &
                                  get_variable_size,                  &
                                  state_structure_info

use     mpi_utilities_mod, only : my_task_id

use        random_seq_mod, only : random_seq_type, init_random_seq,   &
                                  random_gaussian, random_gamma

use netcdf

implicit none
private

! Required by DART code - will be called from filter and other DART executables
! These interfaces are fixed and cannot be changed in any way.

public :: static_init_model,      &
          init_time,              &
          init_conditions,        &
          pert_model_copies,      &
          get_model_size,         &
          read_model_time,        &
          shortest_time_between_assimilations, &
          get_state_meta_data,    &
          model_interpolate,      &
          get_close_obs,          &
          get_close_state,        &
          nc_write_model_atts,    &
          end_model

! Also required, but the default routines are sufficient.

public :: nc_write_model_vars,    &
          adv_1step,              &
          convert_vertical_obs,   &
          convert_vertical_state, &
          write_model_time

! Not required, but useful

public :: get_number_of_links

! version controlled file description for error handling, do not edit
character(len=*), parameter :: source   = "wrf_hydro/model_mod.f90"
character(len=*), parameter :: revision = ""
character(len=*), parameter :: revdate  = ""

logical, save :: module_initialized = .false.

character(len=512) :: string1, string2, string3

integer(i8) :: model_size
type(time_type) :: time_step

! Codes for interpreting the columns of the variable_table
integer, parameter :: VT_VARNAMEINDX  = 1 ! ... variable name
integer, parameter :: VT_KINDINDX     = 2 ! ... DART kind
integer, parameter :: VT_MINVALINDX   = 3 ! ... minimum value if any
integer, parameter :: VT_MAXVALINDX   = 4 ! ... maximum value if any
integer, parameter :: VT_STATEINDX    = 5 ! ... update (state) or not
integer, parameter :: MAX_STATE_VARIABLES     = 40
integer, parameter :: NUM_STATE_TABLE_COLUMNS = 5

integer :: domain_count
integer :: idom, idom_hydro = -1, idom_parameters = -1, idom_lsm = -1

! Model namelist declarations with defaults
integer             :: assimilation_period_days       = 0
integer             :: assimilation_period_seconds    = 3600
character(len=128)  :: lsm_model_choice               = 'noahMP'
character(len=256)  :: domain_order(3)                = ''
character(len=256)  :: domain_shapefiles(3)           = ''
integer             :: debug                          = 0
real(r8)            :: model_perturbation_amplitude   = 0.002
real(r8)            :: max_link_distance              = 10000.0   ! 10 km
real(r8)            :: streamflow_4_local_multipliers = 1.0e-5
character(len=256)  :: perturb_distribution           = 'lognormal'

character(len=obstypelength) :: &
    lsm_variables(  NUM_STATE_TABLE_COLUMNS,MAX_STATE_VARIABLES) = '', &
    hydro_variables(NUM_STATE_TABLE_COLUMNS,MAX_STATE_VARIABLES) = '', &
    parameters(     NUM_STATE_TABLE_COLUMNS,MAX_STATE_VARIABLES) = ''

namelist /model_nml/ assimilation_period_days,       &
                     assimilation_period_seconds,    &
                     lsm_model_choice,               &
                     domain_order,                   &
                     domain_shapefiles,              &
                     debug,                          &
                     model_perturbation_amplitude,   &
                     perturb_distribution,           &
                     max_link_distance,              &
                     streamflow_4_local_multipliers, &
                     lsm_variables,                  &
                     hydro_variables,                &
                     parameters

type domain_locations
   private
   type(location_type), allocatable :: location(:,:,:)
end type domain_locations

type(domain_locations), allocatable :: domain_info(:)

contains

!------------------------------------------------------------------
!> One-time initialization of the model. This reads the namelists
!> and determines what 'domains' are being used and fills the
!> appropriate metadata for the module (location arrays, etc).

subroutine static_init_model()

character(len=*), parameter :: routine = 'static_init_model'

integer  :: iunit, io, domainID
integer  :: n_lsm_fields
integer  :: n_hydro_fields
integer  :: n_parameters
integer  :: vsize

character(len=obstypelength) :: var_names(MAX_STATE_VARIABLES)
real(r8) :: var_ranges(MAX_STATE_VARIABLES,2)
logical  :: var_update(MAX_STATE_VARIABLES)
integer  :: var_qtys(  MAX_STATE_VARIABLES)

character(len=256) :: domain_name

if ( module_initialized ) return ! only need to do this once

! Print module information to log file and stdout.
call register_module(source, revision, revdate)

! Since this routine calls other routines that could call this routine
! we'll say we've been initialized pretty dang early.
module_initialized = .true.

! Read the DART namelist, and record.
call find_namelist_in_file("input.nml", "model_nml", iunit)
read(iunit, nml = model_nml, iostat = io)
call check_namelist_read(iunit, io, "model_nml")

if (do_nml_file()) write(nmlfileunit, nml=model_nml)
if (do_nml_term()) write(     *     , nml=model_nml)

! Set the time aspects of the model
call set_calendar_type('Gregorian')
time_step  = set_time(assimilation_period_seconds, assimilation_period_days)

! Determine the order of the domains contributing to the DART state vector.

if ( len_trim(domain_order(1)) == 0 ) then
   write(string1,*) 'The domain_order is incorrectly specified.'
   write(string2,*) 'The domain_order cannot be empty, it should be something like:'
   write(string3,*) 'domain_order = "hydro", "parameters"'
   call error_handler(E_ERR, routine, string1, &
              source, revision, revdate, text2=string2, text3=string3)
endif

! Determine the composition of the DART state vector.
! If the domain_shapefiles are not listed in the same order as
! the domain_order, the variables are not found. The error messages are like:
! domain 1 variable # 1 "qlink1" from file "parameters.nc": NetCDF: Variable not found
! The clue is that the domain number and the file are not as expected.

if ( .not. file_exist(domain_shapefiles(1)) ) then
   write(string1,*) 'Domain 1 shapefile "', trim(domain_shapefiles(1)), &
                    '" does not exist.'
   write(string2,*) 'There must be a domain 1.'
   call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2)
endif

DOMAINS: do domainID = 1,size(domain_order)

   if (len_trim(domain_order(domainID)) == 0) exit DOMAINS

   domain_name = domain_order(domainID)
   call to_upper(domain_name)

   if ( .not. file_exist(domain_shapefiles(domainID)) ) then
      write(string1,'("Domain shapefile",1x, i3, 1x, A," does not exist.")')  &
                     domainID, '"'//trim(domain_shapefiles(domainID))//'"'
      call error_handler(E_ERR,routine,string1,source,revision,revdate)
   endif

   if (index(domain_name,'HYDRO') > 0) then

      call configure_hydro()
      call read_hydro_global_atts(domain_shapefiles(domainID))
      call verify_variables(hydro_variables, domain_shapefiles(domainID), &
                  n_hydro_fields, var_names, var_qtys, var_ranges, var_update)
      idom_hydro = add_domain(domain_shapefiles(domainID), &
                       n_hydro_fields, var_names, &
                         kind_list=var_qtys, &
                        clamp_vals=var_ranges(1:n_hydro_fields,:), &
                       update_list=var_update)

      if (debug > 99) call state_structure_info(idom_hydro)

      vsize = get_variable_size(idom_hydro,1)
      if ( vsize /= n_link ) then
         write(string1,*)'restart file, domain file not consistent.'
         write(string2,*)'number of links ',vsize, &
                         ' from "'//trim(domain_shapefiles(domainID))//'"'
         write(string3,*)'number of links ',int(n_link,i8), &
                         ' from "'//get_hydro_domain_filename()//'"'
         call error_handler(E_ERR, routine, string1, &
                    source, revision, revdate, text2=string2, text3=string3)
      endif

   elseif (index(domain_name,'PARAMETER') > 0) then

      call verify_variables(parameters, domain_shapefiles(domainID), n_parameters, &
                       var_names, var_qtys, var_ranges, var_update)
      idom_parameters = add_domain(domain_shapefiles(domainID), &
                            n_parameters, var_names, &
                              kind_list=var_qtys, &
                             clamp_vals=var_ranges(1:n_parameters,:), &
                            update_list=var_update )
      if (debug > 99) call state_structure_info(idom_parameters)

      !>@todo check the size of the parameter variables against nlinks

   elseif (index(domain_name,'LSM') > 0) then

      call configure_lsm(lsm_model_choice)
      call read_noah_global_atts(domain_shapefiles(domainID))
      call verify_variables(lsm_variables, domain_shapefiles(domainID), n_lsm_fields, &
                       var_names, var_qtys, var_ranges, var_update)
      idom_lsm = add_domain(domain_shapefiles(domainID), &
                     n_lsm_fields, var_names, &
                         kind_list=var_qtys, &
                        clamp_vals=var_ranges(1:n_lsm_fields,:), &
                       update_list=var_update)
      if (debug > 99) call state_structure_info(idom_lsm)

   else

      write(string1,*)'domain_order ="',trim(domain_name),'" unsupported."'
      write(string2,*)'Must be "hydro", "parameter", or "lsm"'
      call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2)

   endif

enddo DOMAINS

if (idom_parameters > 0 .and. idom_hydro < 1) then
   write(string1,*) 'Since we are getting parameter locations from the hydro domain'
   write(string2,*) 'the hydro shapefile must exist.'
   call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2)
endif

! Now that we know the composition of the DART state, determine the model size.

domain_count = get_num_domains()
model_size = 0
do idom = 1,domain_count
   model_size = model_size + get_domain_size(idom)
enddo

! Each domain has its own array of locations.

allocate(domain_info(domain_count))
call configure_domains()

end subroutine static_init_model

!------------------------------------------------------------------
!> Returns a time that is somehow appropriate for starting up a new
!> instance of the model. This is only used if the namelist parameter
!> start_from_restart is set to .false. in the program perfect_model_obs.

subroutine init_time(time)

type(time_type), intent(out) :: time

! for now, just set to 0
time = set_time(0,0)

write(string1,*) 'no good way to specify initial time'
call error_handler(E_ERR,'init_time',string1,source,revision,revdate)

end subroutine init_time

!------------------------------------------------------------------
!> Companion to init_time(). Returns a model state vector, x, that is
!> an appropriate initial condition for starting an integration of the model.
!> At present, this is only used if the namelist parameter
!> start_from_restart is set to .false. in the program perfect_model_obs.

subroutine init_conditions(x)

real(r8), intent(out) :: x(:)

x = MISSING_R8

write(string1,*) 'no good way to specify initial conditions'
call error_handler(E_ERR,'init_conditions',string1,source,revision,revdate)

end subroutine init_conditions

!------------------------------------------------------------------
!> Perturbs a model state for generating initial ensembles.
!> The perturbed state is referenced by the state_ens_handle.
!> We do not know how to generate an ensemble for an LSM,
!> so this will skip that domain.

subroutine pert_model_copies(state_ens_handle, ens_size, pert_amp, interf_provided)

type(ensemble_type), intent(inout) :: state_ens_handle
integer,             intent(in)    :: ens_size
real(r8),            intent(in)    :: pert_amp
logical,             intent(out)   :: interf_provided

character(len=*), parameter :: routine = 'pert_model_copies'

logical, save :: seed_unset = .true.
integer, save :: seed
type(random_seq_type) :: random_seq

real(r8) :: stddev, rng, m_shape, m_scale
real(r8) :: new_state, in_mean
integer  :: j, k, copy, ivar
integer  :: start_ind, end_ind
logical  :: positive
integer, parameter :: NTRIES = 100

if ( .not. module_initialized ) call static_init_model

if ( idom_lsm > 0 ) then
   string1 = 'LSM cannot be started from a single vector - not perturbing that domain.'
   string2 = 'LSM cannot be started from a single vector - not perturbing that domain.'
   string3 = 'LSM cannot be started from a single vector - not perturbing that domain.'
   call error_handler(E_MSG, routine, string1, text2=string2, text3=string3)
endif

! If you want the default model perturbations specified by the
! ensemble_manager (which uses input.nml:ensemble_manager_nml:perturbation_amplitude)
! interf_provided = .false. and return.

interf_provided = .true.   ! .true. means we have our own way of perturbing

! Generate a unique (but repeatable - if task count is same)
! seed for each ensemble member
if (seed_unset) then
   seed = (my_task_id()+1) * 1000
   seed_unset = .false.
endif

if ( debug > 99 ) then
   write(string1,*)'seed_unset is ',seed_unset,'; seed is ',seed
   call error_handler(E_MSG,routine,string1)
endif

call init_random_seq(random_seq, seed)
seed = seed + 1  ! next ensemble member gets a different seed

stddev = model_perturbation_amplitude

DOMAIN : do idom = 1, domain_count

   if (idom == idom_lsm) cycle DOMAIN

   do ivar = 1, get_num_variables(idom)

      ! This is where we can skip variables we do not want to perturb
      ! or change the stddev based on the variable dynamic range
      ! for the dynamic range option, wrf, mpas_atm have examples.

      start_ind = get_index_start(idom, ivar)
      end_ind   = get_index_end(  idom, ivar)

      do j = 1, state_ens_handle%my_num_vars

         if (state_ens_handle%my_vars(j) >= start_ind .and. &
             state_ens_handle%my_vars(j) <= end_ind   ) then

            do copy = 1, ens_size

               if (trim(perturb_distribution) == 'lognormal') then
                  rng = random_gaussian(random_seq, 0.0_r8, 1.0_r8)
                  state_ens_handle%copies(copy,j) = &
                            state_ens_handle%copies(copy,j)*exp(stddev*rng)

               elseif (trim(perturb_distribution) == 'trunc-normal') then

                  state_ens_handle%copies(copy,j) = max(0.0_r8, &
                            random_gaussian(random_seq, state_ens_handle%copies(copy,j), stddev))

               elseif (trim(perturb_distribution) == 'gamma') then

                  in_mean = state_ens_handle%copies(copy,j)

                  m_scale = 0.5_r8 * (sqrt(in_mean**2 + 4.0_r8*stddev**2) - in_mean)
                  m_shape = in_mean / m_scale + 1.0_r8
                  state_ens_handle%copies(copy,j) = random_gamma(random_seq, m_shape, m_scale)

               elseif (trim(perturb_distribution) == 'pos-gaussian') then

                  positive = .false.

                  !>@todo might want to make sure it is also within the
                  !> variable bounds from the namelist
                  POSDEF : do k=1,NTRIES ! prevent runoff from being negative
                     new_state = random_gaussian(random_seq, &
                                        state_ens_handle%copies(copy,j), stddev)
                     if ( new_state >= 0.0_r8 ) then
                        positive = .true.
                        state_ens_handle%copies(copy,j) = new_state
                        exit POSDEF
                     endif
                  enddo POSDEF

                  if (.not. positive) then
                     write(string1,*)'tried ',NTRIES, &
                                     ' times to get something >= 0.0_r8 and failed'
                     write(string2,*)'state value = ',state_ens_handle%copies(copy,j)
                     call error_handler(E_ERR, routine, string1, &
                                source, revision, revdate, text2=string2)
                  endif

               else

                  write(string1,*)'pert_model_copies'
                  write(string2,*)'Distribution "', trim(perturb_distribution), '" is not valid.'
                  call error_handler(E_ERR, routine, string1, &
                       source, revision, revdate, text2=string2)

               endif

            enddo
         endif
      enddo
   enddo
enddo DOMAIN

end subroutine pert_model_copies

!------------------------------------------------------------------
!> Returns the number of items in the state vector as an integer.

function get_model_size()

integer(i8) :: get_model_size

get_model_size = model_size

end function get_model_size

!-----------------------------------------------------------------------
!> The LSM restart files have "time".
!> We are always using the 'most recent' which is, by defn, the last one.
!> LSM restart filename "RESTART.2004010102_DOMAIN1" has
!>     Times = '2004-01-01_02:00:00' ;
!> The data is valid @ 2004-01-01_02:00:00

function read_model_time(filename)

type(time_type) :: read_model_time
character(len=*),  intent(in)  :: filename

character(len=*), parameter :: routine = 'read_model_time'

integer, parameter :: STRINGLENGTH = 19
character(len=STRINGLENGTH), allocatable, dimension(:) :: datestring
character(len=STRINGLENGTH)                            :: datestring_scalar
integer :: year, month, day, hour, minute, second
integer :: DimID, VarID, strlen, ntimes
logical :: isLsmFile
integer :: ncid, io

io = nf90_open(filename, NF90_NOWRITE, ncid)
call nc_check(io,routine,'open',filename)

! Test if "Time" is a dimension in the file.
isLsmFile = nf90_inq_dimid(ncid, 'Time', DimID) == NF90_NOERR

if(isLsmFile) then ! Get the time from the LSM restart file

   ! TJH ... my preference is to read the dimension IDs for the Times variable
   ! and cycle over the dimension IDs to get the lengths and check compatibility
   ! This has the assumption that Times(DateStrLen,Time)

   ! Get the dimensions for the strings of times
   io = nf90_inq_dimid(ncid, 'Time', DimID)
   call nc_check(io, routine,'inq_dimid','Time',filename)

   io = nf90_inquire_dimension(ncid, DimID, len=ntimes)
   call nc_check(io, routine,'inquire_dimension','Time',filename)

   io = nf90_inq_dimid(ncid, 'DateStrLen', DimID)
   call nc_check(io, routine,'inq_dimid','DateStrLen',filename)

   io = nf90_inquire_dimension(ncid, DimID, len=strlen)
   call nc_check(io, routine,'inquire_dimension','DateStrLen',filename)

   if (strlen /= STRINGLENGTH) then
      write(string1,*)'DatStrLen string length ',strlen,' /= ',STRINGLENGTH
      call error_handler(E_ERR,routine, string1, source, revision, revdate)
   endif

   ! Get all the Time strings, use the last one.
   io = nf90_inq_varid(ncid, 'Times', VarID)
   call nc_check(io, routine, 'inq_varid','Times',filename)

   allocate(datestring(ntimes))

   io = nf90_get_var(ncid, VarID, datestring)
   call nc_check(io, routine, 'get_var','Times',filename)

else ! Get the time from the hydro or parameter file

   io = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'Restart_Time', len=strlen)
   call nc_check(io, routine, 'inquire_attribute','Restart_Time', filename)

   io = nf90_get_att(ncid, NF90_GLOBAL, 'Restart_Time', datestring_scalar)
   call nc_check(io, routine, 'get_att','Restart_Time', filename)

   ntimes = 1
   allocate(datestring(ntimes))
   datestring(1) = datestring_scalar

endif

io = nf90_close(ncid)
call nc_check(io, routine, 'close', filename)

read(datestring(ntimes),'(i4,5(1x,i2))') year, month, day, hour, minute, second

read_model_time = set_date(year, month, day, hour, minute, second)

if ( do_output() .and. debug > 0 ) write(*,*)'routine: Last time string is '//trim(datestring(ntimes))
if ( do_output() .and. debug > 0 ) call print_date(read_model_time,' valid time is ')

deallocate(datestring)

end function read_model_time

!------------------------------------------------------------------
!> Returns the smallest increment in time that the model is capable
!> of advancing the state in a given implementation, or the shortest
!> time you want the model to advance between assimilations.
!> This interface is required for all applications.

function shortest_time_between_assimilations()

type(time_type) :: shortest_time_between_assimilations

shortest_time_between_assimilations = time_step

end function shortest_time_between_assimilations

!------------------------------------------------------------------
!> Given an integer index into the state vector structure, returns the
!> associated location. A second intent(out) optional argument
!> returns the DART 'QUANTITY' (i.e. QTY_STREAM_FLOW) for this index.
!> This interface is required for computing distances.

subroutine get_state_meta_data(index_in, location, var_type)

integer(i8),         intent(in)  :: index_in
type(location_type), intent(out) :: location
integer,             intent(out), optional :: var_type

integer :: iloc, jloc, kloc, varid, domid

call get_model_variable_indices(index_in, iloc, jloc, kloc, varid, domid, var_type)

location = domain_info(domid)%location(iloc,jloc,kloc)

if (do_output() .and. debug > 99) then
   call write_location(0,location,charstring=string1)
   write(*,*)'gsmd index,i,j,k = ',index_in, iloc, jloc, kloc, trim(string1)
endif

end subroutine get_state_meta_data

!------------------------------------------------------------------
!> Given a state handle, a location, and a DART QUANTITY,
!> return the expected estimate of the model state quantity at that location.
!> This function returns the estimates for the entire ensemble in a single call.
!>
!> The return code for successful return must be 0, any positive number is
!> an error, and the expected_obs array contains unreliable values.
!> Negative values are reserved for use by the DART framework.
!> Distinct positive values for different types of errors are used
!> to aid in diagnosing problems.
!>
!> Since the initial implementation is for identity observations of
!> streamflow, this routine is not being used.

subroutine model_interpolate(state_handle, ens_size, location, obs_type, &
                             expected_obs, istatus)

type(ensemble_type), intent(in) :: state_handle
integer,             intent(in) :: ens_size
type(location_type), intent(in) :: location
integer,             intent(in) :: obs_type
real(r8),           intent(out) :: expected_obs(ens_size)
integer,            intent(out) :: istatus(ens_size)

character(len=*), parameter :: routine = 'model_interpolate'

real(r8) :: closest_dist, distance
integer  :: domid, varid, closest_i, closest_j, closest_k
integer  :: i,j,k
integer(i8) :: closest_index

expected_obs(:) = MISSING_R8
istatus(:)      = 1  ! presume failure

varid = -1
domid = -1
! Use the obs_type to figure out which variable we need, and in what domain.
DOMLOOP : do idom = 1,domain_count
   varid = get_varid_from_kind(idom, obs_type)
   if (varid > 0) then
      domid = idom
      exit DOMLOOP
   endif
enddo DOMLOOP

if (varid < 0) then
   istatus = 2 ! variable is not present in DART state
   return
endif

! Now we know the domain and the variable ID
! but we want to know the closest location to the variable on its grid
!>@todo only do this for the smaller grids ... there has to be a better way
!> for the larger grids

!>@todo might also need to check if the closest is in the same/right watershed
!>      as the observation ... somehow

!>@todo If the parameter domain has both 1D and 2D parameters ... we have to revisit this.

closest_dist = huge(1.0_r8)

do k = 1,size(domain_info(domid)%location,3)
do j = 1,size(domain_info(domid)%location,2)
do i = 1,size(domain_info(domid)%location,1)
   distance = get_dist(location, domain_info(domid)%location(i,j,k), no_vert=.false.)
   if (distance < closest_dist) then
      closest_dist  = distance
      closest_i     = i
      closest_j     = j
      closest_k     = k
   endif
enddo
enddo
enddo

closest_index = get_dart_vector_index(closest_i, closest_j, closest_k, domid, varid)
expected_obs  = get_state(closest_index, state_handle)
istatus       = 0

end subroutine model_interpolate

!-----------------------------------------------------------------------
!> Given an observation and its TYPE (the 'base') and a list of observations
!> and their TYPEs, returns the subset close to the base,
!> their local indices (on each task), and their distances.
!>
!> Normally, the definition of 'close' is a simple distance, however
!> identity streamflow observations allow us to determine the close
!> upstream/downstream streamflow observations by exploiting the
!> available wrf_hydro metadata.
!>
!> All other observations impact ALL observations (even identity streamflow)
!> in the cutoff radius without upstream/downstream consideration.

subroutine get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, &
                         num_close, close_ind, dist, ens_handle)

type(get_close_type), intent(in)    :: gc           !< handle to a get_close structure
type(location_type),  intent(inout) :: base_loc     !< location of interest
type(location_type),  intent(inout) :: locs(:)      !< all locations on my task
integer,              intent(in)    :: base_type    !< observation TYPE
integer,              intent(in)    :: loc_qtys(:)  !< QTYs for all locations
integer,              intent(in)    :: loc_types(:) !< TYPEs for all locations
integer,              intent(out)   :: num_close    !< how many are close
integer,              intent(out)   :: close_ind(:) !< index on task of close locs
real(r8),             optional, intent(out) :: dist(:)      !< distances (in radians)
type(ensemble_type),  optional, intent(in)  :: ens_handle

character(len=*), parameter :: routine = 'get_close_obs'

! vars for determining stream connectivity - the length of these arrays has
! an upper bound determined by the stream network size

integer     :: stream_nclose
integer(i8) :: stream_indices(n_link)
real(r8)    :: stream_dists(n_link)

! vars for determining who is on my task -
! these are the same size as the intent(out) variables

integer     :: obs_nclose
integer     :: obs_indices(size(close_ind))
real(r8)    :: obs_dists(size(close_ind))
integer(i8) :: loc_indx(size(close_ind))

integer     :: iloc, base_qty
integer(i8) :: full_index
type(location_type) :: location

integer :: iunit

iunit = my_task_id() + 200

if (present(dist)) dist = huge(1.0_r8)  !something far away

! Get the traditional list of ALL observations that are close.

call loc_get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, &
                       obs_nclose, obs_indices, obs_dists, ens_handle)

! Check to see if we can return early (i.e. observation is not an identity obs).
! This could include streamflow observations that have not been georeferenced
! to the channel network.

if (base_type > 0) then
   num_close = obs_nclose
   close_ind(1:num_close) = obs_indices(1:obs_nclose)
   if (present(dist)) dist(1:num_close) = obs_dists(1:obs_nclose)
   RETURN
endif

! Everything below here only pertains to identity observations.

full_index = abs(base_type)
call get_state_meta_data(full_index, location, base_qty)

if (base_qty /= QTY_STREAM_FLOW) then
   num_close = obs_nclose
   close_ind(1:num_close) = obs_indices(1:obs_nclose)
   if (present(dist)) dist(1:num_close) = obs_dists(1:obs_nclose)
   RETURN
endif

! Everything below here only pertains to identity STREAMFLOW observations.

loc_indx = abs(loc_types) ! convert identity type to absolute state vector index

if (debug > 99) then
   write(string1,'("PE ",I3)') my_task_id()
   write(iunit,*)trim(string1), ' loc_qtys ', loc_qtys
   write(iunit,*)trim(string1), ' loc_types', loc_types
   write(iunit,*)'                     iloc,  obs_indices, obs_dists, loc_indx'
   do iloc = 1,obs_nclose
      write(iunit,*)trim(string1),' lgco: ',iloc, &
                    obs_indices(iloc), &
                    obs_dists(iloc), &
                    loc_indx(iloc)
   enddo
endif

! Only the upstream/downstream streamflow obs are close.
! 'stream_indices' contains the GLOBAL indices into the DART state vector.
! These may or may not be on my task.

call get_close_streamflows(base_qty, base_type, &
                           stream_nclose, stream_indices, stream_dists)

! determine which of the global indices are mine

call get_my_close(stream_nclose, stream_indices, stream_dists, loc_indx, &
            num_close, close_ind, dist)

if (debug > 99) then
   write(string1,'("PE ",I3)') my_task_id()
   do iloc = 1,num_close
      write(iunit,*)trim(string1),' gco: ', iloc, close_ind(iloc), dist(iloc)
   enddo
endif

if (debug > 99) then
   write(string1,'("PE ",I3)') my_task_id()
   write(iunit,*)trim(string1),' gco: ',num_close, close_ind(1:num_close), dist(1:num_close)
endif

!>@todo what if the first close_ind list is based on a cutoff that is not wholly
!> compatible with the max_link_distance? i.e. what if stream_indices has some
!> that are not in the close_ind list?

end subroutine get_close_obs

!-----------------------------------------------------------------------
!> Given a location, return the subset of close states that are local to
!> the mpi task.

subroutine get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, &
                         num_close, close_ind, dist, ens_handle)

type(get_close_type), intent(in)    :: gc           !< handle to a get_close structure
type(location_type),  intent(inout) :: base_loc     !< location of interest
integer,              intent(in)    :: base_type    !< observation TYPE
type(location_type),  intent(inout) :: locs(:)      !< locations on my task
integer,              intent(in)    :: loc_qtys(:)  !< QTYs for locations on my task
integer(i8),          intent(in)    :: loc_indx(:)  !< indices into DART state on my task
integer,              intent(out)   :: num_close    !< how many are close
integer,              intent(out)   :: close_ind(:) !< indices in the the locs array
real(r8),             optional, intent(out) :: dist(:)      !< distances
type(ensemble_type),  optional, intent(in)  :: ens_handle

character(len=*),parameter :: routine = 'get_close_state'

! vars for determining stream ... Must be 3*n_link
! if the subsurface or surface parameters are part of the state.
integer     :: stream_nclose
integer(i8), allocatable :: stream_indices(:)
real(r8), allocatable    :: stream_dists(:)

! vars for determining who is on my task
integer     :: state_nclose
integer     :: state_indices(size(close_ind))
real(r8)    :: state_dists(size(close_ind))
real(r8)    :: stream_ens_mean(1)

integer :: iclose, iparam, start_indx, num_close_tmp, close_index
integer :: ivars, num_vars_hydro_dom

!integer     :: istream
integer     :: iloc, base_qty
integer(i8) :: full_index
type(location_type) :: location ! required argument to get_state_meta_data()

integer :: iunit

character(len=NF90_MAX_NAME) :: var_name

iunit = my_task_id() + 100

if (present(dist)) dist = huge(1.0_r8)  !something far away

allocate (stream_indices(model_size), stream_dists(model_size))

! Get the traditional list of ALL state locations that are close.
!>@todo state_indices is not being used ... when we have a more complicated state

call loc_get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, &
                         state_nclose, state_indices, state_dists, ens_handle)

if (debug > 99) then
   call write_location(iunit,base_loc)
   write(string1,'("PE ",I3)') my_task_id()
   do iloc = 1,state_nclose

      write(iunit,*)trim(string1),' loc_get_close_state: ',iloc, &
                state_dists(iloc), &
                state_indices(iloc), &
                loc_indx(state_indices(iloc))
   enddo
   write(iunit,*)''
endif

! Now we have to figure out how to make parts of the state that are
! not in the same huc far away

! Initialize variables
stream_nclose  = 0
stream_indices = 0
stream_dists   = huge(1.0_r8)

!>@todo If the variable is on the same link geometry, we can get the
!> upstream/downstream links

! If the observation is a traditional (i.e. non-identity) observation
! there is nothing more to do and simply return.

if (base_type > 0) then
   num_close = state_nclose
   close_ind(1:num_close) = state_indices(1:num_close)
   if (present(dist)) dist(1:num_close) = state_dists(1:num_close)
   deallocate (stream_indices, stream_dists)
   RETURN
endif

! Everything below here only pertains to identity observations.
full_index = abs(base_type)
call get_state_meta_data(full_index, location, base_qty)
! identity observations that are not streamflows need no further consideration

if (base_qty /= QTY_STREAM_FLOW) then
   num_close = state_nclose
   close_ind(1:num_close) = state_indices(1:num_close)
   if (present(dist)) dist(1:num_close) = state_dists(1:num_close)
   deallocate (stream_indices, stream_dists)
   RETURN
endif

! 'stream_indices' contains the GLOBAL indices into the DART state vector.
! These may or may not be on my task.
call get_close_streamflows(base_qty, base_type, &
                           stream_nclose, stream_indices, stream_dists)
if (debug > 3) then
   write(string1,'("PE ",I3)') my_task_id()
   do iloc = 1,stream_nclose
      write(iunit,*)trim(string1),' gcs: after gc_streamflows: ', &
                iloc, stream_dists(iloc), stream_indices(iloc)
   enddo
endif

! check all other variables in the hydro domain and apply
! the same 'get close' logic to them.

num_vars_hydro_dom = get_num_variables(idom_hydro)

if (num_vars_hydro_dom > 1) then
   ! more than 1 variable (streamflow) in the hydro domain

   num_close_tmp = stream_nclose

   ! Already did streamflow (var #1), now add the other variables
   ! hence, the start from 2
   do ivars = 2, num_vars_hydro_dom
      start_indx = get_index_start(idom_hydro, ivars)

      VARloop: do iclose = 1, num_close_tmp
         close_index = stream_indices(iclose)

         ! Remove the masked bucket variables from the close set.
         ! Making them "far" from the observation is a solution to the
         ! fact that the bucket is not present on the entire channel network.
         ! This way filter will not touch them and they won't be updated.
         if (get_variable_name(idom_hydro, ivars) == 'z_gwsubbas' .and. &
             BucketMask(close_index) == 0) cycle VARloop

         stream_nclose                 = stream_nclose + 1
         stream_indices(stream_nclose) = start_indx - 1 + close_index
         stream_dists(  stream_nclose) = stream_dists(iclose)
      enddo VARloop

   enddo
endif

! Localize the parameters:
! If the ensemble mean streamflow is "near" zero then the next block is ignored.
! This is not great, but at this stage we do not have access to the individual
! state values.

stream_ens_mean = get_state(full_index, ens_handle)
! stream_ens_mean = 1.0_r8  ! this is to test model_mod_check ... has no access to get_state()

! Since the parameter domain has exactly the same geometry/connectivity as the
! streamflow, we can add the domain offset (start_indx) to the close streamflow
! indices to determine the DART state location of the matching close parameters.
! With two parameters, the list of close indices is triple that of the list of
! close streamflow indices. The corresponding parameters may be on other tasks

if (idom_parameters > 0 .and. &
    stream_ens_mean(1) > streamflow_4_local_multipliers) then

   num_close_tmp = stream_nclose
   do iparam = 1, get_num_variables(idom_parameters)

      start_indx = get_index_start(idom_parameters, iparam)

      !>@todo  should check to make sure that stream_nclose is < 3*n_link

      do iclose = 1, num_close_tmp
         stream_nclose                 = stream_nclose + 1
         stream_indices(stream_nclose) = start_indx - 1 + stream_indices(iclose)
         stream_dists(  stream_nclose) = stream_dists(iclose)
      enddo
   enddo
endif

if (debug > 99) then
   do iloc = 1,stream_nclose
      write(iunit,*)trim(string1),' augmented: ', &
                    iloc, stream_indices(iloc), stream_dists(iloc)
   enddo
endif

! determine which of the global indices are mine

call get_my_close(stream_nclose, stream_indices, stream_dists, loc_indx, &
            num_close, close_ind, dist)

if (debug > 99) then
   write(string1,'("PE ",I3)') my_task_id()
   do iloc = 1,num_close
      write(iunit,*)trim(string1),' gmc: ', iloc, close_ind(iloc), &
                        loc_indx(close_ind(iloc)), dist(iloc)
   enddo
endif

!>@todo Have to consolidate the stream_indices and the state_indices.
!> The identity streamflow observations can be close to (other) traditional states.

!TJH STATELOOP: do iloc = 1,state_nclose
!TJH
!TJH    if (loc_qtys(iloc) /= QTY_STREAM_FLOW) cycle STATELOOP
!TJH
!TJH    ! All streamflow states are far away until proven otherwise
!TJH    dist(iloc) = huge(1.0_r8)
!TJH
!TJH    STREAMLOOP : do istream = 1,stream_nclose
!TJH       if ( close_ind(iloc) == stream_indices(istream) ) then
!TJH          dist(iloc) = stream_dists(istream)
!TJH          EXIT STREAMLOOP
!TJH       endif
!TJH    enddo STREAMLOOP
!TJH
!TJH enddo STATELOOP

if (debug > 99) then
   write(string1,'("PE ",I3)') my_task_id()
   write(iunit,*) trim(string1),' get_close_state:num_close ',num_close
   write(iunit,*) trim(string1),' get_close_state:close_ind ',close_ind(1:num_close)
   write(iunit,*) trim(string1),' get_close_state:dist      ',dist(1:num_close)
endif

deallocate (stream_indices, stream_dists)

end subroutine get_close_state

!-----------------------------------------------------------------------
!> Given an streamflow, return the subset of streamflows that are
!> in the same  HUC or watershed or ... The subset is a list of
!> absolute indices into the DART state vector.

subroutine get_close_streamflows(base_qty, identity_index, &
                                 num_close, close_indices, distances)

integer,     intent(in)  :: base_qty         !< observation TYPE
integer,     intent(in)  :: identity_index   !< identity observation
integer,     intent(out) :: num_close
integer(i8), intent(out) :: close_indices(:) !< full DART indices
real(r8),    intent(out) :: distances(:)     !< in radians

!   X radians      2PI radians
!   --------- as  -------------
!   distance      circumference
!
!   X *         circumference = 2PI * distance
!   X * PI * 2 * earth_radius = 2PI * distance
!   X (radians)               = distance/earth_radius

character(len=*),parameter :: routine = 'get_close_streamflows'

integer     :: stream_nclose
integer(i8) :: stream_indices(n_link)
real(r8)    :: stream_distances(n_link)

integer     :: depth
integer(i8) :: full_index
real(r8)    :: reach_length
integer     :: connection_index

integer :: iunit

iunit = my_task_id() + 100

! make sure the base_qty translates to a streamflow

if (base_qty /= QTY_STREAM_FLOW) then
   write(string1,*)'Only identity observation of stream flow are allowed.'
   write(string2,*)'stream flow observations are QTY ',QTY_STREAM_FLOW
   write(string3,*)'routine called with observation QTY of ',base_qty, identity_index
   call error_handler(E_ERR, routine, string1, &
              source, revision, revdate, text2=string2, text3=string3)
endif

! Initialize variables
depth         = 1             ! starting value for recursive routine
reach_length  = 0.0_r8        ! starting value for recursive routine
stream_nclose = 0
distances     = huge(1.0_r8)  !something far away

! we are working with identity observations - streamflow observations
! These can only impact states on the vector-based network.
full_index = abs(identity_index)

connection_index = full_to_connection(full_index)

if (connection_index < 0) then
   call error_handler(E_ERR,routine,'unable to relate',source,revision,revdate)
endif

! determine the upstream close bits
call get_link_tree(connection_index, max_link_distance, depth, &
                   reach_length, stream_nclose, stream_indices, stream_distances)
! augment the list with the downstream close bits

call get_downstream_links(connection_index, max_link_distance, depth, &
                   stream_nclose, stream_indices, stream_distances)

num_close                  = stream_nclose
close_indices(1:num_close) = stream_indices(1:stream_nclose)
distances(1:num_close)     = stream_distances(1:stream_nclose) / 1000.0_r8  ! to km
distances(1:num_close)     = distances(1:num_close) / earth_radius          ! to radians

if (debug > 99) then
   write(string1,'("PE ",I3)') my_task_id()
   write(iunit,*)trim(string1),' gc_streamflows:num_close     ',num_close
   write(iunit,*)trim(string1),' gc_streamflows:close_indices ',close_indices(1:num_close)
   write(iunit,*)trim(string1),' gc_streamflows:distances     ',distances(1:num_close)
endif

end subroutine get_close_streamflows

!------------------------------------------------------------------
!> Write attributes and metadata to the DART output and diagnostic files

subroutine nc_write_model_atts(ncid, domain_id)

integer, intent(in) :: ncid      ! netCDF file identifier
integer, intent(in) :: domain_id

call nc_begin_define_mode(ncid) ! put file into define mode.

if (domain_id == idom_lsm ) then

   call write_noah_global_atts(ncid)

elseif (domain_id == idom_hydro ) then

   call write_hydro_global_atts(ncid)

elseif (domain_id == idom_parameters ) then

   continue  ! no metadata for parameters.

endif

call nc_end_define_mode(ncid)

! Flush the buffer and leave netCDF file open
call nc_synchronize_file(ncid)

end subroutine nc_write_model_atts

!------------------------------------------------------------------
!> Shutdown and clean-up

subroutine end_model()

do idom = 1,domain_count
   deallocate(domain_info(idom)%location)
enddo
deallocate(domain_info)

end subroutine end_model

!=======================================================================
! End of the required interfaces
!=======================================================================

!-----------------------------------------------------------------------
!> given the list of variables and a filename, check user input
!> return the handle to the open netCDF file and the number of variables
!> in this 'domain'

subroutine verify_variables( variable_table, filename, ngood, &
                       var_names, var_qtys, var_ranges, var_update)

character(len=*), intent(in)  :: variable_table(:,:)
character(len=*), intent(in)  :: filename
integer,          intent(out) :: ngood
character(len=*), intent(out) :: var_names(:)
real(r8),         intent(out) :: var_ranges(:,:)
logical,          intent(out) :: var_update(:)
integer ,         intent(out) :: var_qtys(:)

character(len=*), parameter :: routine = 'verify_variables'

integer  :: io, i, quantity
real(r8) :: minvalue, maxvalue

character(len=NF90_MAX_NAME) :: varname
character(len=NF90_MAX_NAME) :: dartstr
character(len=NF90_MAX_NAME) :: minvalstring
character(len=NF90_MAX_NAME) :: maxvalstring
character(len=NF90_MAX_NAME) :: state_or_aux

ngood = 0
MyLoop : do i = 1, size(variable_table,2)

   varname      = variable_table(VT_VARNAMEINDX,i)
   dartstr      = variable_table(VT_KINDINDX   ,i)
   minvalstring = variable_table(VT_MINVALINDX ,i)
   maxvalstring = variable_table(VT_MAXVALINDX ,i)
   state_or_aux = variable_table(VT_STATEINDX  ,i)

   if ( varname == ' ' .and. dartstr == ' ' ) exit MyLoop ! Found end of list.

   if ( varname == ' ' .or.  dartstr == ' ' ) then
      string1 = 'model_nml: variable list not fully specified'
      string2 = 'reading from "'//trim(filename)//'"'
      call error_handler(E_ERR,routine, string1, &
                 source, revision, revdate, text2=string2)
   endif

   ! The internal DART routines check if the variable name is valid.

   ! Make sure DART kind is valid
   quantity = get_index_for_quantity(dartstr)
   if( quantity < 0 ) then
      write(string1,'(''there is no obs_kind "'',a,''" in obs_kind_mod.f90'')') &
                    trim(dartstr)
      call error_handler(E_ERR,routine,string1,source,revision,revdate)
   endif

   ! All good to here - fill the output variables

   ngood = ngood + 1
   var_names( ngood)   = varname
   var_qtys(  ngood)   = quantity
   var_ranges(ngood,:) = (/ MISSING_R8, MISSING_R8 /)
   var_update(ngood)   = .false.   ! at least initially

   ! convert the [min,max]valstrings to numeric values if possible
   read(minvalstring,*,iostat=io) minvalue
   if (io == 0) var_ranges(ngood,1) = minvalue

   read(maxvalstring,*,iostat=io) maxvalue
   if (io == 0) var_ranges(ngood,2) = maxvalue

   call to_upper(state_or_aux)
   if (state_or_aux == 'UPDATE') var_update(ngood) = .true.

enddo MyLoop

if (ngood == MAX_STATE_VARIABLES) then
   string1 = 'WARNING: you may need to increase "MAX_STATE_VARIABLES"'
   write(string2,'(''you have specified at least '',i4,'' perhaps more.'')') ngood
   call error_handler(E_MSG,routine,string1,source,revision,revdate,text2=string2)
endif

end subroutine verify_variables

!-----------------------------------------------------------------------
!> Sets the location information arrays for each domain
!> Each location array is declared to be 3D to make it easy to use
!> the state_structure routines.

subroutine configure_domains()

character(len=*), parameter :: routine = 'configure_domains'

integer :: i,j,k, var_size, num_vars, ivar

do idom = 1,domain_count

   if (idom == idom_hydro) then
      j = 1
      k = 1
      allocate( domain_info(idom)%location(n_link,j,k) )
      do i = 1,n_link
         domain_info(idom)%location(i,j,k) = &
                set_location(linkLong(i),linkLat(i),linkAlt(i),VERTISHEIGHT)
      enddo

   elseif (idom == idom_lsm) then

      string1 = 'LSM locations unsupported for now'
      call error_handler(E_ERR, routine, string1, source, revision, revdate)

   elseif (idom == idom_parameters) then

      num_vars = get_num_variables(idom)
      var_size = 0
      do ivar = 1, num_vars
         var_size = var_size + get_variable_size(idom,ivar)
      enddo
      if (var_size /= num_vars) then ! spatially varying parameters case
         j = 1
         k = 1
         allocate( domain_info(idom)%location(n_link,j,k) )
         do i = 1,n_link
            domain_info(idom)%location(i,j,k) = set_location(linkLong(i),linkLat(i),linkAlt(i),VERTISHEIGHT)
         enddo
      else ! global parameters case   !>@todo do we support this now
         i = 1
         j = 1
         k = 1
         allocate( domain_info(idom)%location(i,j,k) )
         domain_info(idom)%location(i,j,k) = set_location(35.38_r8, 33.60_r8, linkAlt(i), VERTISHEIGHT)
      endif
   endif
enddo

end subroutine configure_domains

!-----------------------------------------------------------------------
!> determine the indices of the objects that are on this task
!>
!> num_superset		length of the superset of desired indices
!> superset_indices	superset of desired indices
!> superset_distances	superset of desired distances
!> my_task_indices      all possible indices ON MY TASK (i.e. a local subset)
!> num_close		length of desired elements ON MY TASK (i.e. intersection)
!> close_ind(:)		the list of desired indices ON MY TASK
!> dist(:)		the corresponding distances of the desired indices

subroutine get_my_close(num_superset, superset_indices, superset_distances, &
                        my_task_indices, num_close, close_ind, dist)

integer,          intent(in)  :: num_superset
integer(i8),      intent(in)  :: superset_indices(:)
real(r8),         intent(in)  :: superset_distances(:)
integer(i8),      intent(in)  :: my_task_indices(:)
integer,          intent(out) :: num_close
integer,          intent(out) :: close_ind(:)
real(r8),         intent(out) :: dist(:)

integer :: itask, isuper

num_close = 0

do itask = 1,size(my_task_indices)
   do isuper = 1,num_superset

      ! if stuff on my task ... equals ... global stuff I want ...
      if ( my_task_indices(itask) == superset_indices(isuper) ) then
          num_close            = num_close + 1
          close_ind(num_close) = itask
          dist(num_close)      = superset_distances(isuper)
      endif

   enddo
enddo

end subroutine get_my_close

!------------------------------------------------------------------
!> Returns the number of links in the state vector

function get_number_of_links()

integer(i8) :: get_number_of_links

get_number_of_links = n_link

end function get_number_of_links

!===================================================================
! End of model_mod
!===================================================================

end module model_mod


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This program 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 2 of the License, or
! (at your option) any later version.
!
! 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, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! elastic solver

  subroutine compute_forces_viscoelastic_GPU()

  use constants, only: CUSTOM_REAL,NGLLX,NDIM

  use specfem_par, only: myrank,NPROC,ninterface,max_nibool_interfaces_ext_mesh,nibool_interfaces_ext_mesh, &
    my_neighbours,ninterface_elastic,inum_interfaces_elastic,ibool_interfaces_ext_mesh, &
    num_fluid_solid_edges,nspec_bottom,nspec_left,nspec_right,nspec_top, &
    STACEY_ABSORBING_CONDITIONS,PML_BOUNDARY_CONDITIONS,any_poroelastic,any_acoustic,SIMULATION_TYPE

  use specfem_par, only: nspec_outer_elastic,nspec_inner_elastic

  use specfem_par_gpu, only: Mesh_pointer,ANY_ANISOTROPY,deltatf,deltatover2f,b_deltatover2f, &
    buffer_send_vector_gpu,buffer_recv_vector_gpu, &
    b_buffer_send_vector_gpu,b_buffer_recv_vector_gpu, &
    request_send_recv_vector_gpu,b_request_send_recv_vector_gpu

  implicit none

  ! local parameters
  integer:: iphase
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_bottom) :: b_absorb_elastic_bottom_slice
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_left) :: b_absorb_elastic_left_slice
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_right) :: b_absorb_elastic_right_slice
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_top) :: b_absorb_elastic_top_slice

  ! check
  if (PML_BOUNDARY_CONDITIONS ) &
    call exit_MPI(myrank,'PML conditions not yet implemented for routine compute_forces_viscoelastic_GPU()')

  ! distinguishes two runs: for points on MPI interfaces, and points within the partitions
  do iphase = 1,2

    ! elastic term
    ! contains both forward SIM_TYPE==1 and backward SIM_TYPE==3 simulations
    call compute_forces_viscoelastic_cuda(Mesh_pointer, iphase, deltatf, &
                                          nspec_outer_elastic, &
                                          nspec_inner_elastic, &
                                          ANY_ANISOTROPY)

    ! while inner elements compute "Kernel_2", we wait for MPI to
    ! finish and transfer the boundary terms to the device asynchronously
    if (NPROC > 1) then
      if (iphase == 2) then
        !daniel: todo - this avoids calling the fortran vector send from CUDA routine
        ! wait for asynchronous copy to finish
        call sync_copy_from_device(Mesh_pointer,iphase,buffer_send_vector_gpu)

        ! sends MPI buffers
        call assemble_MPI_vector_send_cuda(NPROC, &
                    buffer_send_vector_gpu,buffer_recv_vector_gpu, &
                    ninterface,max_nibool_interfaces_ext_mesh, &
                    nibool_interfaces_ext_mesh, &
                    my_neighbours, &
                    request_send_recv_vector_gpu,ninterface_elastic,inum_interfaces_elastic)

        ! transfers MPI buffers onto GPU
        call transfer_boundary_to_device(NPROC,Mesh_pointer,buffer_recv_vector_gpu, &
                    ninterface,max_nibool_interfaces_ext_mesh, &
                    request_send_recv_vector_gpu,ninterface_elastic,inum_interfaces_elastic)
      endif ! inner elements
    endif

    ! computes additional contributions
    if (iphase == 1) then
      ! adds elastic absorbing boundary term to acceleration (Stacey conditions)
      if (STACEY_ABSORBING_CONDITIONS) then
        call compute_stacey_viscoelastic_GPU(iphase,b_absorb_elastic_bottom_slice,b_absorb_elastic_left_slice, &
                                             b_absorb_elastic_right_slice,b_absorb_elastic_top_slice)
      endif

      ! acoustic coupling
      if (any_acoustic) then
        if (num_fluid_solid_edges > 0) then
          call compute_coupling_el_ac_cuda(Mesh_pointer,iphase, &
                                           num_fluid_solid_edges)
        endif
      endif

      ! poroelastic coupling
      ! poroelastic coupling
      if (any_poroelastic) then
        stop 'Error GPU simulation: poroelastic coupling not implemented yet'
      endif

      ! adds source term (single-force/moment-tensor solution)
      call compute_add_sources_viscoelastic_GPU(iphase)
    endif

    ! assemble all the contributions between slices using MPI
    if (NPROC > 1) then
      if (iphase == 1) then
        ! sends accel values to corresponding MPI interface neighbors

        ! transfers boundary region to host asynchronously. The
        ! MPI-send is done from within compute_forces_viscoelastic_cuda,
        ! once the inner element kernels are launched, and the
        ! memcpy has finished. see compute_forces_viscoelastic_cuda: ~ line 1655
        call transfer_boundary_from_device_a(Mesh_pointer)

        ! adjoint simulations
        if (SIMULATION_TYPE == 3) then
           call transfer_boun_accel_from_device(Mesh_pointer, &
                        b_buffer_send_vector_gpu, &
                        3) ! -- 3 == adjoint b_accel
           call assemble_MPI_vector_send_cuda(NPROC, &
                        b_buffer_send_vector_gpu,b_buffer_recv_vector_gpu, &
                        ninterface,max_nibool_interfaces_ext_mesh, &
                        nibool_interfaces_ext_mesh, &
                        my_neighbours, &
                        b_request_send_recv_vector_gpu,ninterface_elastic,inum_interfaces_elastic)
        endif !adjoint

      else
        ! waits for send/receive requests to be completed and assembles values
        call assemble_MPI_vector_write_cuda(NPROC,Mesh_pointer, &
                                            buffer_recv_vector_gpu,ninterface, &
                                            max_nibool_interfaces_ext_mesh, &
                                            nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
                                            request_send_recv_vector_gpu, &
                                            1,ninterface_elastic,inum_interfaces_elastic)

        ! adjoint simulations
        if (SIMULATION_TYPE == 3) then
          call assemble_MPI_vector_write_cuda(NPROC,Mesh_pointer, &
                                              b_buffer_recv_vector_gpu,ninterface, &
                                              max_nibool_interfaces_ext_mesh, &
                                              nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
                                              b_request_send_recv_vector_gpu, &
                                              3,ninterface_elastic,inum_interfaces_elastic)
        endif !adjoint
      endif
    endif ! NPROC > 1

  enddo

  ! multiplies with inverse of mass matrix (note: rmass has been inverted already)
  call kernel_3_a_cuda(Mesh_pointer,deltatover2f,b_deltatover2f)

  end subroutine compute_forces_viscoelastic_GPU

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

! absorbing boundary term for elastic media (Stacey conditions)

  subroutine compute_stacey_viscoelastic_GPU(iphase,b_absorb_elastic_bottom_slice,b_absorb_elastic_left_slice, &
                                             b_absorb_elastic_right_slice, b_absorb_elastic_top_slice)

  use constants, only: CUSTOM_REAL,NGLLX,NDIM

  use specfem_par, only: nspec_bottom,nspec_left,nspec_top,nspec_right,b_absorb_elastic_left,b_absorb_elastic_right, &
                          b_absorb_elastic_bottom, b_absorb_elastic_top,SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it, &
                          nelemabs

  use specfem_par_gpu, only: Mesh_pointer

  implicit none

  ! communication overlap
  integer :: iphase

  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_bottom) :: b_absorb_elastic_bottom_slice
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_left) :: b_absorb_elastic_left_slice
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_right) :: b_absorb_elastic_right_slice
  real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,nspec_top) :: b_absorb_elastic_top_slice

  ! checks if anything to do
  if (nelemabs == 0) return

  if (SIMULATION_TYPE == 3) then
    ! gets absorbing contribution buffers
    b_absorb_elastic_bottom_slice(1,:,:) = b_absorb_elastic_bottom(1,:,:,NSTEP-it+1)
    b_absorb_elastic_left_slice(1,:,:) = b_absorb_elastic_left(1,:,:,NSTEP-it+1)
    b_absorb_elastic_right_slice(1,:,:) = b_absorb_elastic_right(1,:,:,NSTEP-it+1)
    b_absorb_elastic_top_slice(1,:,:) = b_absorb_elastic_top(1,:,:,NSTEP-it+1)

    b_absorb_elastic_bottom_slice(2,:,:) = b_absorb_elastic_bottom(2,:,:,NSTEP-it+1)
    b_absorb_elastic_left_slice(2,:,:) = b_absorb_elastic_left(2,:,:,NSTEP-it+1)
    b_absorb_elastic_right_slice(2,:,:) = b_absorb_elastic_right(2,:,:,NSTEP-it+1)
    b_absorb_elastic_top_slice(2,:,:) = b_absorb_elastic_top(2,:,:,NSTEP-it+1)
  endif

  call compute_stacey_viscoelastic_cuda(Mesh_pointer,iphase,b_absorb_elastic_left_slice, &
                   b_absorb_elastic_right_slice,b_absorb_elastic_top_slice,b_absorb_elastic_bottom_slice)

  ! adjoint simulations: stores absorbed wavefield part
  if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
    ! writes out absorbing boundary value only when second phase is running
    b_absorb_elastic_bottom(1,:,:,it) = b_absorb_elastic_bottom_slice(1,:,:)
    b_absorb_elastic_right(1,:,:,it) = b_absorb_elastic_right_slice(1,:,:)
    b_absorb_elastic_top(1,:,:,it) = b_absorb_elastic_top_slice(1,:,:)
    b_absorb_elastic_left(1,:,:,it) = b_absorb_elastic_left_slice(1,:,:)

    b_absorb_elastic_bottom(2,:,:,it) = b_absorb_elastic_bottom_slice(2,:,:)
    b_absorb_elastic_right(2,:,:,it) = b_absorb_elastic_right_slice(2,:,:)
    b_absorb_elastic_top(2,:,:,it) = b_absorb_elastic_top_slice(2,:,:)
    b_absorb_elastic_left(2,:,:,it) = b_absorb_elastic_left_slice(2,:,:)
  endif

  end subroutine compute_stacey_viscoelastic_GPU

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

! for elastic solver on GPU

  subroutine compute_add_sources_viscoelastic_GPU(iphase)

  use specfem_par, only: NSTEP,SIMULATION_TYPE,nadj_rec_local,it

  use specfem_par_gpu, only: Mesh_pointer

  implicit none

  integer,intent(in) :: iphase

  ! forward simulations
  if (SIMULATION_TYPE == 1) call compute_add_sources_el_cuda(Mesh_pointer,iphase,it)

  ! adjoint simulations
  if (SIMULATION_TYPE == 3 .and. nadj_rec_local > 0 .and. it < NSTEP) then
    call add_sources_el_sim_type_2_or_3(Mesh_pointer,iphase, NSTEP -it + 1, nadj_rec_local,NSTEP)
  endif

  ! adjoint simulations
  if (SIMULATION_TYPE == 3) call compute_add_sources_el_s3_cuda(Mesh_pointer,iphase,NSTEP -it + 1)

  end subroutine compute_add_sources_viscoelastic_GPU


subroutine bkgcov(cstate)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    bkgcov    perform hor & vert of background error
!   prgmmr: kleist         org: np22                date: 2004-07-22
!
! abstract: perform horizontal and vertical parts of background error
!
! program history log:
!   2004-07-22  kleist
!   2004-10-26  kleist - remove u,v
!   2004-11-03  treadon - move definition of horizontal scale weighting
!                         factors to namelist
!   2004-11-22  derber - add openMP
!   2008-06-05  safford - rm unused vars
!   2010-03-01  zhu     - make changes for generalizing control vectors
!                       - replace explicit use of each control variable
!                         by a control_state 'cstate'
!                       - use nrf* for generalized control variables
!                       - make changes to interfaces of sub2grid and grid2sub
!   2010-04-28  todling - update to use gsi_bundle
!   2011-06-29  todling - no explict reference to internal bundle arrays
!   2012-06-25  parrish - replace sub2grid/grid2sub with general_sub2grid/general_grid2sub.
!                         Remove arrays sst, slndt, sicet.  These are now contained as
!                         motley variables in input/output bundle cstate.  Remove unused variables
!                         nnnn1o,latlon11.
!
!   input argument list:
!     cstate   - bundle containing control fields
!
!   output argument list:
!                 all after smoothing, combining scales
!     cstate   - bundle containing control fields
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  use gridmod, only: nlat,nlon
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use general_sub2grid_mod, only: general_sub2grid,general_grid2sub
  use general_commvars_mod, only: s2g_raf
  implicit none

! Passed Variables
  type(gsi_bundle),intent(inout) :: cstate

! Local Variables
  integer(i_kind) n,n3d,istatus,nlevs
  real(r_kind),dimension(nlat*nlon*s2g_raf%nlevs_alloc):: hwork
  real(r_kind),pointer,dimension(:,:,:):: ptr3d=>NULL()

  nlevs=s2g_raf%nlevs_loc
  n3d=cstate%n3d

! Multiply by background error variances, and break up skin temp
! into components
  call bkgvar(cstate,0)

! Apply vertical smoother
!$omp parallel do  schedule(dynamic,1) private(n,ptr3d,istatus)
  do n=1,n3d
     call gsi_bundlegetpointer ( cstate,cstate%r3(n)%shortname,ptr3d,istatus )
     call frfhvo(ptr3d,n)
  end do

! Convert from subdomain to full horizontal field distributed among processors
  call general_sub2grid(s2g_raf,cstate%values,hwork)

! Apply horizontal smoother for number of horizontal scales
  call smoothrf(hwork,nlevs)

! Put back onto subdomains
  call general_grid2sub(s2g_raf,hwork,cstate%values)

! Apply vertical smoother
!$omp parallel do  schedule(dynamic,1) private(n,ptr3d,istatus)
  do n=1,n3d
     call gsi_bundlegetpointer ( cstate,cstate%r3(n)%shortname,ptr3d,istatus )
     call frfhvo(ptr3d,n)
  end do

! Multiply by background error variances, and combine sst,sldnt, and sicet
! into skin temperature field
  call bkgvar(cstate,1)

  return
end subroutine bkgcov
! -----------------------------------------------------------------------------
subroutine ckgcov(z,cstate,nval_lenz)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    ckgcov   sqrt of bkgcov
!   prgmmr: kleist         org: np22                date: 2004-07-22
!
! abstract: perform horizontal and vertical parts of background error
!
! program history log:
!   2007-04-24  parrish
!   2008-12-04  todling - turn sst,slndt,sicet to locals per GSI May08
!                         update to bkgcov above.
!   2010-03-15  zhu - use nrf* and cstate for generalized control variable
!                   - make changes to interface of grid2sub
!   2010-04-28  todling - udpate to use gsi_bundle
!   2011-06-29  todling - no explict reference to internal bundle arrays
!   2011-09-05  todling - add explicit reference to navl_lenz, and remove connection through jfunc
!   2012-06-25  parrish - replace grid2sub with general_grid2sub.
!                         Remove arrays sst, slndt, sicet.  These are now contained as
!                         motley variables in input/output bundle cstate.  Remove unused variables
!                         nnnn1o,latlon11,nval_levs.
!   2016-03-25  todling - revisit beta multiplier term
!
!   input argument list:
!     z        - long vector input control fields
!     cstate   - bundle containing control fields
!     nlevs    - number of vertical levels for smoothing
!     nval_lenz- length of sqrt-B control vector
!
!   output argument list:
!                 all after smoothing, combining scales
!     cstate   - bundle containing control fields
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  use gridmod, only: nlat,nlon
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use general_sub2grid_mod, only: general_grid2sub
  use general_commvars_mod, only: s2g_raf
  use hybrid_ensemble_parameters, only: l_hyb_ens
  use hybrid_ensemble_isotropic, only: sqrt_beta_s_mult
  implicit none

! Passed Variables
  integer(i_kind)    ,intent(in   ) :: nval_lenz
  type(gsi_bundle),intent(inout) :: cstate
  real(r_kind),dimension(nval_lenz),intent(in   ) :: z

! Local Variables
  integer(i_kind) k,n3d,istatus,nlevs
  real(r_kind),dimension(nlat*nlon*s2g_raf%nlevs_alloc):: hwork
  real(r_kind),dimension(:,:,:),pointer:: ptr3d=>NULL()

  nlevs=s2g_raf%nlevs_loc

! Apply horizontal smoother for number of horizontal scales
  call sqrt_smoothrf(z,hwork,nlevs)

! Put back onto subdomains
  call general_grid2sub(s2g_raf,hwork,cstate%values)

! Apply vertical smoother
  n3d=cstate%n3d
!$omp parallel do  schedule(dynamic,1) private(k,ptr3d,istatus)
  do k=1,n3d
     call gsi_bundlegetpointer ( cstate,cstate%r3(k)%shortname,ptr3d,istatus )
     call frfhvo(ptr3d,k)
  end do

! Multiply by background error variances, and combine sst,sldnt, and sicet
! into skin temperature field
  call bkgvar(cstate,1)

! Apply static betas
  if(l_hyb_ens) call sqrt_beta_s_mult(cstate)

  return
end subroutine ckgcov
! -----------------------------------------------------------------------------
subroutine ckgcov_ad(z,cstate,nval_lenz)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    ckgcov_ad  adjoint of ckgcov
!   prgmmr: kleist         org: np22                date: 2004-07-22
!
! abstract: perform horizontal and vertical parts of background error
!
! program history log:
!   2007-04-24  parrish
!   2008-12-04  todling - turn sst,slndt,sicet to locals per GSI May08
!                         update to bkgcov above.
!   2010-03-15  zhu - use nrf* and cstate for generalized control variable
!                   - make changes to interface of sub2grid
!   2010-04-15  treadon - add %values to cstate in bkgvar call
!   2010-04-28  todling - update to use gsi_bundle
!   2011-06-29  todling - no explict reference to internal bundle arrays
!   2011-09-05  todling - add explicit reference to navl_lenz, and remove connection through jfunc
!   2012-06-25  parrish - replace sub2grid with general_sub2grid.
!                         Remove arrays sst, slndt, sicet.  These are now contained as
!                         motley variables in input/output bundle cstate.  Remove unused variables
!                         nnnn1o,latlon11.
!   2016-03-25  todling - revisit beta multiplier term
!
!   input argument list:
!     z        - long vector adjoint input/output control fields
!     cstate   - bundle containing control fields
!     nlevs    - number of vertical levels for smoothing
!     nval_lenz- length of sqrt-B control vector
!
!   output argument list:
!                 all after smoothing, combining scales
!     cstate   - bundle containing adjoint control fields
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  use gridmod, only: nlat,nlon
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use general_sub2grid_mod, only: general_sub2grid
  use general_commvars_mod, only: s2g_raf
  use hybrid_ensemble_parameters, only: l_hyb_ens
  use hybrid_ensemble_isotropic, only: sqrt_beta_s_mult
  implicit none

! Passed Variables
  integer(i_kind)    ,intent(in   ) :: nval_lenz
  type(gsi_bundle),intent(inout) :: cstate
  real(r_kind),dimension(nval_lenz),intent(inout) :: z

! Local Variables
  integer(i_kind) k,n3d,istatus,nlevs
  real(r_kind),dimension(nlat*nlon*s2g_raf%nlevs_alloc):: hwork
  real(r_kind),dimension(:,:,:),pointer:: ptr3d=>NULL()

  nlevs=s2g_raf%nlevs_loc

! Apply static betas
  if(l_hyb_ens) call sqrt_beta_s_mult(cstate)

! Multiply by background error variances, and break up skin temp
! into components
  call bkgvar(cstate,0)

! Apply vertical smoother
  n3d=cstate%n3d
!$omp parallel do  schedule(dynamic,1) private(k,ptr3d,istatus)
  do k=1,n3d
     call gsi_bundlegetpointer ( cstate,cstate%r3(k)%shortname,ptr3d,istatus )
     call frfhvo(ptr3d,k)
  end do

! Convert from subdomain to full horizontal field distributed among processors
  call general_sub2grid(s2g_raf,cstate%values,hwork)

! Apply horizontal smoother for number of horizontal scales
  call sqrt_smoothrf_ad(z,hwork,nlevs)

  return
end subroutine ckgcov_ad