! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! 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 3 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, see <http://www.gnu.org/licenses/>.

module getVectorz_module

! data types
USE nrtype

! missing values
USE globalData,only:integerMissing  ! missing integer
USE globalData,only:realMissing     ! missing real number

! access the global print flag
USE globalData,only:globalPrintFlag

! domain types
USE globalData,only:iname_cas       ! named variables for canopy air space
USE globalData,only:iname_veg       ! named variables for vegetation canopy
USE globalData,only:iname_snow      ! named variables for snow
USE globalData,only:iname_soil      ! named variables for soil

! named variables to describe the state variable type
USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space
USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy
USE globalData,only:iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy
USE globalData,only:iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy
USE globalData,only:iname_nrgLayer  ! named variable defining the energy state variable for snow+soil layers
USE globalData,only:iname_watLayer  ! named variable defining the total water state variable for snow+soil layers
USE globalData,only:iname_liqLayer  ! named variable defining the liquid  water state variable for snow+soil layers
USE globalData,only:iname_matLayer  ! named variable defining the matric head state variable for soil layers
USE globalData,only:iname_lmpLayer  ! named variable defining the liquid matric potential state variable for soil layers

! metadata for information in the data structures
USE globalData,only:indx_meta       ! metadata for the variables in the index structure

! constants
USE multiconst,only:&
                    gravity,      & ! acceleration of gravity              (m s-2)
                    Tfreeze,      & ! temperature at freezing              (K)
                    Cp_air,       & ! specific heat of air                 (J kg-1 K-1)
                    LH_fus,       & ! latent heat of fusion                (J kg-1)
                    iden_air,     & ! intrinsic density of air             (kg m-3)
                    iden_ice,     & ! intrinsic density of ice             (kg m-3)
                    iden_water      ! intrinsic density of liquid water    (kg m-3)

! provide access to the derived types to define the data structures
USE data_types,only:&
                    var_i,        & ! data vector (i4b)
                    var_d,        & ! data vector (dp)
                    var_ilength,  & ! data vector with variable length dimension (i4b)
                    var_dlength     ! data vector with variable length dimension (dp)

! provide access to indices that define elements of the data structures
USE var_lookup,only:iLookDIAG             ! named variables for structure elements
USE var_lookup,only:iLookPROG             ! named variables for structure elements
USE var_lookup,only:iLookDERIV            ! named variables for structure elements
USE var_lookup,only:iLookPARAM            ! named variables for structure elements
USE var_lookup,only:iLookINDEX            ! named variables for structure elements

! provide access to routines to update states
USE updatState_module,only:updateSnow     ! update snow states
USE updatState_module,only:updateSoil     ! update soil states

! provide access to functions for the constitutive functions and derivatives
USE snow_utils_module,only:fracliquid     ! compute the fraction of liquid water (snow)
USE snow_utils_module,only:dFracLiq_dTk   ! differentiate the freezing curve w.r.t. temperature (snow)
USE soil_utils_module,only:dTheta_dTk     ! differentiate the freezing curve w.r.t. temperature (soil)
USE soil_utils_module,only:dTheta_dPsi    ! derivative in the soil water characteristic (soil)
USE soil_utils_module,only:dPsi_dTheta    ! derivative in the soil water characteristic (soil)
USE soil_utils_module,only:matricHead     ! compute the matric head based on volumetric water content
USE soil_utils_module,only:volFracLiq     ! compute volumetric fraction of liquid water
USE soil_utils_module,only:crit_soilT     ! compute critical temperature below which ice exists
USE soil_utils_module,only:liquidHead     ! compute the liquid water matric potential

implicit none
private
public::popStateVec
public::getScaling
public::varExtract

! common variables
real(dp),parameter :: valueMissing=-9999._dp ! missing value

contains

 ! **********************************************************************************************************
 ! public subroutine popStateVec: populate model state vectors
 ! **********************************************************************************************************
 subroutine popStateVec(&
                        ! input: data structures
                        nState,                  & ! intent(in):    number of desired state variables
                        prog_data,               & ! intent(in):    model prognostic variables for a local HRU
                        diag_data,               & ! intent(in):    model diagnostic variables for a local HRU
                        indx_data,               & ! intent(in):    indices defining model states and layers
                        ! output
                        stateVec,                & ! intent(out):   model state vector
                        err,message)               ! intent(out):   error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! input: data structures
 integer(i4b),intent(in)         :: nState                 ! number of desired state variables
 type(var_dlength),intent(in)    :: prog_data              ! prognostic variables for a local HRU
 type(var_dlength),intent(in)    :: diag_data              ! diagnostic variables for a local HRU
 type(var_ilength),intent(in)    :: indx_data              ! indices defining model states and layers
 ! output
 real(dp),intent(out)            :: stateVec(:)            ! model state vector (mixed units)
 integer(i4b),intent(out)        :: err                    ! error code
 character(*),intent(out)        :: message                ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! local variables
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! state subsets
 integer(i4b)                    :: iState                 ! index of state within the snow+soil domain
 integer(i4b)                    :: iLayer                 ! index of layer within the snow+soil domain
 integer(i4b)                    :: ixStateSubset          ! index within the state subset
 logical(lgt),dimension(nState)  :: stateFlag              ! flag to denote that the state is populated
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! make association with variables in the data structures
 fixedLength: associate(&
 ! model states for the vegetation canopy
 scalarCanairTemp    => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1)       ,& ! intent(in) : [dp]     temperature of the canopy air space (K)
 scalarCanopyTemp    => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1)       ,& ! intent(in) : [dp]     temperature of the vegetation canopy (K)
 scalarCanopyWat     => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1)        ,& ! intent(in) : [dp]     mass of total water on the vegetation canopy (kg m-2)
 scalarCanopyLiq     => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1)        ,& ! intent(in) : [dp]     mass of liquid water on the vegetation canopy (kg m-2)
 ! model state variable vectors for the snow-soil layers
 mLayerTemp          => prog_data%var(iLookPROG%mLayerTemp)%dat                ,& ! intent(in) : [dp(:)]  temperature of each snow/soil layer (K)
 mLayerVolFracWat    => prog_data%var(iLookPROG%mLayerVolFracWat)%dat          ,& ! intent(in) : [dp(:)]  volumetric fraction of total water (-)
 mLayerVolFracLiq    => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat          ,& ! intent(in) : [dp(:)]  volumetric fraction of liquid water (-)
 mLayerMatricHead    => prog_data%var(iLookPROG%mLayerMatricHead)%dat          ,& ! intent(in) : [dp(:)]  matric head (m)
 mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat       ,& ! intent(in) : [dp(:)]  matric potential of liquid water (m)
 ! indices defining specific model states
 ixCasNrg            => indx_data%var(iLookINDEX%ixCasNrg)%dat                 ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable
 ixVegNrg            => indx_data%var(iLookINDEX%ixVegNrg)%dat                 ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable
 ixVegHyd            => indx_data%var(iLookINDEX%ixVegHyd)%dat                 ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass)
 ! vector of energy and hydrology indices for the snow and soil domains
 ixSnowSoilNrg       => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat            ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain
 ixSnowSoilHyd       => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat            ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain
 nSnowSoilNrg        => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1)         ,& ! intent(in) : [i4b]    number of energy state variables in the snow+soil domain
 nSnowSoilHyd        => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1)         ,& ! intent(in) : [i4b]    number of hydrology state variables in the snow+soil domain
 ! type of model state variabless
 ixStateType_subset  => indx_data%var(iLookINDEX%ixStateType_subset)%dat       ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables
 ixHydType           => indx_data%var(iLookINDEX%ixHydType)%dat                ,& ! intent(in) : [i4b(:)] index of the type of hydrology states in snow+soil domain
 ! number of layers
 nSnow               => indx_data%var(iLookINDEX%nSnow)%dat(1)                 ,& ! intent(in) : [i4b]    number of snow layers
 nSoil               => indx_data%var(iLookINDEX%nSoil)%dat(1)                 ,& ! intent(in) : [i4b]    number of soil layers
 nLayers             => indx_data%var(iLookINDEX%nLayers)%dat(1)                & ! intent(in) : [i4b]    total number of layers
 )  ! end association with variables in the data structures
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message='popStateVec/'

 ! -----
 ! * initialize state vectors...
 ! -----------------------------

 ! initialize flags
 stateFlag(:) = .false.

 ! build the state vector for the temperature of thecanopy air space
 ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy
 do concurrent (iState=1:size(ixCasNrg),ixCasNrg(iState)/=integerMissing)
  stateVec( ixCasNrg(iState) )  = scalarCanairTemp       ! transfer canopy air temperature to the state vector
  stateFlag( ixCasNrg(iState) ) = .true.                 ! flag to denote that the state is populated
 end do

 ! build the state vector for the temperature of the vegetation canopy
 ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy
 do concurrent (iState=1:size(ixVegNrg),ixVegNrg(iState)/=integerMissing)
  stateVec( ixVegNrg(iState) )  = scalarCanopyTemp       ! transfer vegetation temperature to the state vector
  stateFlag( ixVegNrg(iState) ) = .true.                 ! flag to denote that the state is populated
 end do

 ! build the state vector for the water in the vegetation canopy
 ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy
 do concurrent (iState=1:size(ixVegHyd),ixVegHyd(iState)/=integerMissing)
  stateFlag( ixVegHyd(iState) ) = .true.                 ! flag to denote that the state is populated
  select case(ixStateType_subset( ixVegHyd(iState) ))
   case(iname_watCanopy); stateVec( ixVegHyd(iState) )  = scalarCanopyWat        ! transfer total canopy water to the state vector
   case(iname_liqCanopy); stateVec( ixVegHyd(iState) )  = scalarCanopyLiq        ! transfer liquid canopy water to the state vector
   case default; stateFlag( ixVegHyd(iState) ) = .false. ! flag to denote that the state is populated
  end select
 end do

 ! build the energy state vector for the snow and soil domain
 if(nSnowSoilNrg>0)then
  do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing)   ! (loop through non-missing energy state variables in the snow+soil domain)
   ixStateSubset            = ixSnowSoilNrg(iLayer)  ! index within the state vector
   stateVec(ixStateSubset)  = mLayerTemp(iLayer)     ! transfer temperature from a layer to the state vector
   stateFlag(ixStateSubset) = .true.                 ! flag to denote that the state is populated
  end do  ! looping through non-missing energy state variables in the snow+soil domain
 endif

 ! build the hydrology state vector for the snow+soil domains
 ! NOTE: ixVolFracWat  and ixVolFracLiq can also include states in the soil domain, hence enable primary variable switching
 if(nSnowSoilHyd>0)then
  do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing)   ! (loop through non-missing hydrology state variables in the snow+soil domain)
   ixStateSubset            = ixSnowSoilHyd(iLayer)   ! index within the state vector
   stateFlag(ixStateSubset) = .true.                  ! flag to denote that the state is populated
   select case( ixHydType(iLayer) )
    case(iname_watLayer); stateVec(ixStateSubset) = mLayerVolFracWat(iLayer)           ! total water state variable for snow+soil layers
    case(iname_liqLayer); stateVec(ixStateSubset) = mLayerVolFracLiq(iLayer)           ! liquid water state variable for snow+soil layers
    case(iname_matLayer); stateVec(ixStateSubset) = mLayerMatricHead(iLayer-nSnow)     ! total water matric potential variable for soil layers
    case(iname_lmpLayer); stateVec(ixStateSubset) = mLayerMatricHeadLiq(iLayer-nSnow)  ! liquid matric potential state variable for soil layers
    case default; stateFlag(ixStateSubset) = .false.  ! flag to denote that the state is populated
   end select
  end do  ! looping through non-missing energy state variables in the snow+soil domain
 endif

 ! check that we populated all state variables
 if(count(stateFlag)/=nState)then
  print*, 'stateFlag = ', stateFlag
  message=trim(message)//'some state variables unpopulated'
  err=20; return
 endif

 end associate fixedLength      ! end association to variables in the data structure where vector length does not change
 end subroutine popStateVec

 ! **********************************************************************************************************
 ! public subroutine getScaling: get scale factors
 ! **********************************************************************************************************
 subroutine getScaling(&
                       ! input: data structures
                       diag_data,               & ! intent(in):    model diagnostic variables for a local HRU
                       indx_data,               & ! intent(in):    indices defining model states and layers
                       ! output
                       fScale,                  & ! intent(out):   function scaling vector (mixed units)
                       xScale,                  & ! intent(out):   variable scaling vector (mixed units)
                       sMul,                    & ! intent(out):   multiplier for state vector (used in the residual calculations)
                       dMat,                    & ! intent(out):   diagonal of the Jacobian matrix (excludes fluxes)
                       err,message)               ! intent(out):   error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 USE nr_utility_module,only:arth                   ! get a sequence of numbers arth(start, incr, count)
 USE f2008funcs_module,only:findIndex              ! finds the index of the first value within a vector
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! input: data structures
 type(var_dlength),intent(in)    :: diag_data              ! diagnostic variables for a local HRU
 type(var_ilength),intent(in)    :: indx_data              ! indices defining model states and layers
 ! output: state vectors
 real(dp),intent(out)            :: fScale(:)              ! function scaling vector (mixed units)
 real(dp),intent(out)            :: xScale(:)              ! variable scaling vector (mixed units)
 real(qp),intent(out)            :: sMul(:)    ! NOTE: qp  ! multiplier for state vector (used in the residual calculations)
 real(dp),intent(out)            :: dMat(:)                ! diagonal of the Jacobian matrix (excludes fluxes)
 ! output: error control
 integer(i4b),intent(out)        :: err                    ! error code
 character(*),intent(out)        :: message                ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! local variables
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! scaling parameters
 real(dp),parameter              :: fScaleLiq=0.01_dp      ! func eval: characteristic scale for volumetric liquid water content (-)
 real(dp),parameter              :: fScaleMat=10._dp       ! func eval: characteristic scale for matric head (m)
 real(dp),parameter              :: fScaleNrg=1000000._dp  ! func eval: characteristic scale for energy (J m-3)
 real(dp),parameter              :: xScaleLiq=0.1_dp       ! state var: characteristic scale for volumetric liquid water content (-)
 real(dp),parameter              :: xScaleMat=10._dp       ! state var: characteristic scale for matric head (m)
 real(dp),parameter              :: xScaleTemp=1._dp       ! state var: characteristic scale for temperature (K)
 ! state subsets
 integer(i4b)                    :: iLayer                 ! index of layer within the snow+soil domain
 integer(i4b)                    :: ixStateSubset          ! index within the state subset
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! make association with variables in the data structures
 fixedLength: associate(&
 ! model diagnostic variables
 canopyDepth         => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1)      ,& ! intent(in):  [dp]     canopy depth (m)
 volHeatCapVeg       => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in) : [dp]     bulk volumetric heat capacity of vegetation (J m-3 K-1)
 mLayerVolHeatCap    => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat        ,& ! intent(in) : [dp(:)]  bulk volumetric heat capacity in each snow and soil layer (J m-3 K-1)
 ! indices defining specific model states
 ixCasNrg            => indx_data%var(iLookINDEX%ixCasNrg)%dat                 ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable
 ixVegNrg            => indx_data%var(iLookINDEX%ixVegNrg)%dat                 ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable
 ixVegHyd            => indx_data%var(iLookINDEX%ixVegHyd)%dat                 ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass)
 ! vector of energy and hydrology indices for the snow and soil domains
 ixSnowSoilNrg       => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat            ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain
 ixSnowSoilHyd       => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat            ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain
 nSnowSoilNrg        => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1)         ,& ! intent(in) : [i4b]    number of energy state variables in the snow+soil domain
 nSnowSoilHyd        => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1)         ,& ! intent(in) : [i4b]    number of hydrology state variables in the snow+soil domain
 ! type of model state variabless
 ixStateType_subset  => indx_data%var(iLookINDEX%ixStateType_subset)%dat       ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables
 ! number of layers
 nSnow               => indx_data%var(iLookINDEX%nSnow)%dat(1)                 ,& ! intent(in) : [i4b]    number of snow layers
 nSoil               => indx_data%var(iLookINDEX%nSoil)%dat(1)                 ,& ! intent(in) : [i4b]    number of soil layers
 nLayers             => indx_data%var(iLookINDEX%nLayers)%dat(1)                & ! intent(in) : [i4b]    total number of layers
 )  ! end association with variables in the data structures
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message='getScaling/'

 ! -----
 ! * define scaling vectors...
 ! ---------------------------

 ! define the function and variable scaling factors for energy
 where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer)
  fScale = 1._dp / fScaleNrg  ! 1/(J m-3)
  xScale = 1._dp  ! K
 endwhere

 ! define the function and variable scaling factors for water on the vegetation canopy
 where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy)
  fScale = 1._dp / (fScaleLiq*canopyDepth*iden_water)  ! 1/(kg m-2)
  xScale = 1._dp  ! (kg m-2)
 endwhere

 ! define the function and variable scaling factors for water in the snow+soil domain
 where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer)
  fScale = 1._dp / fScaleLiq  ! (-)
  xScale = 1._dp  ! (-)
 end where

 ! define the function and variable scaling factors for water in the snow+soil domain
 where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer)
  fScale = 1._dp / fScaleLiq  ! (-)
  xScale = 1._dp  ! (m)
 end where

 ! -----
 ! * define components of derivative matrices that are constant over a time step (substep)...
 ! ------------------------------------------------------------------------------------------

 ! define the multiplier for the state vector for residual calculations (vegetation canopy)
 ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer)
 where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air   ! volumetric heat capacity of air (J m-3 K-1)
 where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg     ! volumetric heat capacity of the vegetation (J m-3 K-1)
 where(ixStateType_subset==iname_watCanopy) sMul = 1._dp             ! nothing else on the left hand side
 where(ixStateType_subset==iname_liqCanopy) sMul = 1._dp             ! nothing else on the left hand side

 ! compute terms in the Jacobian for vegetation (excluding fluxes)
 ! NOTE: This is computed outside the iteration loop because it does not depend on state variables
 ! NOTE: Energy for vegetation is computed *within* the iteration loop as it includes phase change
 ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer)
 where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air   ! volumetric heat capacity of air (J m-3 K-1)
 where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing       ! populated within the iteration loop
 where(ixStateType_subset==iname_watCanopy) dMat = 1._dp             ! nothing else on the left hand side
 where(ixStateType_subset==iname_liqCanopy) dMat = 1._dp             ! nothing else on the left hand side

 ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain)
 if(nSnowSoilNrg>0)then
  do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing)   ! (loop through non-missing energy state variables in the snow+soil domain)
   ixStateSubset        = ixSnowSoilNrg(iLayer)      ! index within the state vector
   sMul(ixStateSubset)  = mLayerVolHeatCap(iLayer)   ! transfer volumetric heat capacity to the state multiplier
   dMat(ixStateSubset)  = realMissing                ! diagonal element populated within the iteration loop
  end do  ! looping through non-missing energy state variables in the snow+soil domain
 endif

 ! define the hydrology multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain)
 if(nSnowSoilHyd>0)then
  do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing)   ! (loop through non-missing energy state variables in the snow+soil domain)
   ixStateSubset        = ixSnowSoilHyd(iLayer)      ! index within the state vector
   sMul(ixStateSubset)  = 1._dp                      ! state multiplier = 1 (nothing else on the left-hand-side)
   dMat(ixStateSubset)  = 1._dp                      ! diagonal element = 1 (nothing else on the left-hand-side)
  end do  ! looping through non-missing energy state variables in the snow+soil domain
 endif

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

 end associate fixedLength      ! end association to variables in the data structure where vector length does not change
 end subroutine getScaling

 ! **********************************************************************************************************
 ! public subroutine varExtract: extract variables from the state vector and compute diagnostic variables
 ! **********************************************************************************************************
 subroutine varExtract(&
                       ! input
                       stateVec,                                  & ! intent(in):    model state vector (mixed units)
                       diag_data,                                 & ! intent(in):    model diagnostic variables for a local HRU
                       prog_data,                                 & ! intent(in):    model prognostic variables for a local HRU
                       indx_data,                                 & ! intent(in):    indices defining model states and layers
                       ! output: variables for the vegetation canopy
                       scalarCanairTempTrial,                     & ! intent(out):   trial value of canopy air temperature (K)
                       scalarCanopyTempTrial,                     & ! intent(out):   trial value of canopy temperature (K)
                       scalarCanopyWatTrial,                      & ! intent(out):   trial value of canopy total water (kg m-2)
                       scalarCanopyLiqTrial,                      & ! intent(out):   trial value of canopy liquid water (kg m-2)
                       scalarCanopyIceTrial,                      & ! intent(out):   trial value of canopy ice content (kg m-2)
                       ! output: variables for the snow-soil domain
                       mLayerTempTrial,                           & ! intent(out):   trial vector of layer temperature (K)
                       mLayerVolFracWatTrial,                     & ! intent(out):   trial vector of volumetric total water content (-)
                       mLayerVolFracLiqTrial,                     & ! intent(out):   trial vector of volumetric liquid water content (-)
                       mLayerVolFracIceTrial,                     & ! intent(out):   trial vector of volumetric ice water content (-)
                       mLayerMatricHeadTrial,                     & ! intent(out):   trial vector of total water matric potential (m)
                       mLayerMatricHeadLiqTrial,                  & ! intent(out):   trial vector of liquid water matric potential (m)
                       ! output: error control
                       err,message)                                 ! intent(out):   error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------
 implicit none
 ! input
 real(dp),intent(in)             :: stateVec(:)                     ! model state vector (mixed units)
 type(var_dlength),intent(in)    :: diag_data                       ! diagnostic variables for a local HRU
 type(var_dlength),intent(in)    :: prog_data                       ! prognostic variables for a local HRU
 type(var_ilength),intent(in)    :: indx_data                       ! indices defining model states and layers
 ! output: variables for the vegetation canopy
 real(dp),intent(out)            :: scalarCanairTempTrial           ! trial value of canopy air temperature (K)
 real(dp),intent(out)            :: scalarCanopyTempTrial           ! trial value of canopy temperature (K)
 real(dp),intent(out)            :: scalarCanopyWatTrial            ! trial value of canopy total water (kg m-2)
 real(dp),intent(out)            :: scalarCanopyLiqTrial            ! trial value of canopy liquid water (kg m-2)
 real(dp),intent(out)            :: scalarCanopyIceTrial            ! trial value of canopy ice content (kg m-2)
 ! output: variables for the snow-soil domain
 real(dp),intent(out)            :: mLayerTempTrial(:)              ! trial vector of layer temperature (K)
 real(dp),intent(out)            :: mLayerVolFracWatTrial(:)        ! trial vector of volumetric total water content (-)
 real(dp),intent(out)            :: mLayerVolFracLiqTrial(:)        ! trial vector of volumetric liquid water content (-)
 real(dp),intent(out)            :: mLayerVolFracIceTrial(:)        ! trial vector of volumetric ice water content (-)
 real(dp),intent(out)            :: mLayerMatricHeadTrial(:)        ! trial vector of total water matric potential (m)
 real(dp),intent(out)            :: mLayerMatricHeadLiqTrial(:)     ! trial vector of liquid water matric potential (m)
 ! output: error control
 integer(i4b),intent(out)        :: err                             ! error code
 character(*),intent(out)        :: message                         ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! local variables
 integer(i4b)                    :: iLayer                          ! index of layer within the snow+soil domain
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! make association with variables in the data structures
 associate(&
 ! number of model layers, and layer type
 nSnow                   => indx_data%var(iLookINDEX%nSnow)%dat(1)                 ,& ! intent(in):  [i4b]    total number of snow layers
 nSoil                   => indx_data%var(iLookINDEX%nSoil)%dat(1)                 ,& ! intent(in):  [i4b]    total number of soil layers
 nLayers                 => indx_data%var(iLookINDEX%nLayers)%dat(1)               ,& ! intent(in):  [i4b]    total number of snow and soil layers
 ! indices defining model states and layers
 ixCasNrg                => indx_data%var(iLookINDEX%ixCasNrg)%dat(1)              ,& ! intent(in):  [i4b]    index of canopy air space energy state variable
 ixVegNrg                => indx_data%var(iLookINDEX%ixVegNrg)%dat(1)              ,& ! intent(in):  [i4b]    index of canopy energy state variable
 ixVegHyd                => indx_data%var(iLookINDEX%ixVegHyd)%dat(1)              ,& ! intent(in):  [i4b]    index of canopy hydrology state variable (mass)
 ixSnowSoilNrg           => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat            ,& ! intent(in):  [i4b(:)] indices IN THE STATE SUBSET for energy states in the snow+soil subdomain
 ixSnowSoilHyd           => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat            ,& ! intent(in):  [i4b(:)] indices IN THE STATE SUBSET for hydrology states in the snow+soil subdomain
 nSnowSoilNrg            => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1)         ,& ! intent(in):  [i4b]    number of energy state variables in the snow+soil domain
 nSnowSoilHyd            => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1)         ,& ! intent(in):  [i4b]    number of hydrology variables in the snow+soil domain
 ! indices defining type of model state variables
 ixStateType_subset      => indx_data%var(iLookINDEX%ixStateType_subset)%dat       ,& ! intent(in):  [i4b(:)] [state subset] type of desired model state variables
 ixHydType               => indx_data%var(iLookINDEX%ixHydType)%dat                ,& ! intent(in):  [i4b(:)] index of the type of hydrology states in snow+soil domain
 ! model states for the vegetation canopy
 scalarCanairTemp        => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1)       ,& ! intent(in):  [dp]     temperature of the canopy air space (K)
 scalarCanopyTemp        => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1)       ,& ! intent(in):  [dp]     temperature of the vegetation canopy (K)
 scalarCanopyWat         => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1)        ,& ! intent(in):  [dp]     mass of total water on the vegetation canopy (kg m-2)
 ! model state variable vectors for the snow-soil layers
 mLayerTemp              => prog_data%var(iLookPROG%mLayerTemp)%dat                ,& ! intent(in):  [dp(:)]  temperature of each snow/soil layer (K)
 mLayerVolFracWat        => prog_data%var(iLookPROG%mLayerVolFracWat)%dat          ,& ! intent(in):  [dp(:)]  volumetric fraction of total water (-)
 mLayerMatricHead        => prog_data%var(iLookPROG%mLayerMatricHead)%dat          ,& ! intent(in):  [dp(:)]  total water matric potential (m)
 mLayerMatricHeadLiq     => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat       ,& ! intent(in):  [dp(:)]  liquid water matric potential (m)
 ! model diagnostic variables from a previous solution
 scalarCanopyLiq         => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1)        ,& ! intent(in):  [dp(:)]  mass of liquid water on the vegetation canopy (kg m-2)
 scalarCanopyIce         => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1)        ,& ! intent(in):  [dp(:)]  mass of ice on the vegetation canopy (kg m-2)
 mLayerVolFracLiq        => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat          ,& ! intent(in):  [dp(:)]  volumetric fraction of liquid water (-)
 mLayerVolFracIce        => prog_data%var(iLookPROG%mLayerVolFracIce)%dat           & ! intent(in):  [dp(:)]  volumetric fraction of ice (-)
 ) ! association with variables in the data structures

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

 ! initialize error control
 err=0; message='varExtract/'

 ! *** extract state variables for the vegetation canopy

 ! initialize to state variable from the last update
 scalarCanairTempTrial = scalarCanairTemp
 scalarCanopyTempTrial = scalarCanopyTemp
 scalarCanopyWatTrial  = scalarCanopyWat
 scalarCanopyLiqTrial  = scalarCanopyLiq
 scalarCanopyIceTrial  = scalarCanopyIce

 ! check if computing the vegetation flux
 if(ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixVegHyd/=integerMissing)then

  ! extract temperature of the canopy air space
  if(ixCasNrg/=integerMissing) scalarCanairTempTrial = stateVec(ixCasNrg)

  ! extract canopy temperature
  if(ixVegNrg/=integerMissing) scalarCanopyTempTrial = stateVec(ixVegNrg)

  ! extract intercepted water
  if(ixVegHyd/=integerMissing)then
   select case( ixStateType_subset(ixVegHyd) )
    case(iname_liqCanopy); scalarCanopyLiqTrial = stateVec(ixVegHyd)
    case(iname_watCanopy); scalarCanopyWatTrial = stateVec(ixVegHyd)
    case default; err=20; message=trim(message)//'case not found: expect iname_liqCanopy or iname_watCanopy'; return
   end select
  endif

 endif  ! not computing the vegetation flux

 ! *** extract state variables from the snow+soil sub-domain

 ! initialize to the state variable from the last update
 mLayerTempTrial          = mLayerTemp
 mLayerVolFracWatTrial    = mLayerVolFracWat
 mLayerVolFracLiqTrial    = mLayerVolFracLiq
 mLayerVolFracIceTrial    = mLayerVolFracIce
 mLayerMatricHeadTrial    = mLayerMatricHead      ! total water matric potential
 mLayerMatricHeadLiqTrial = mLayerMatricHeadLiq   ! liquid water matric potential

 ! overwrite with the energy values from the state vector
 if(nSnowSoilNrg>0)then
  do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing)   ! (loop through non-missing energy state variables in the snow+soil domain)
   mLayerTempTrial(iLayer) = stateVec( ixSnowSoilNrg(iLayer) )
  end do  ! looping through non-missing energy state variables in the snow+soil domain
 endif

 ! overwrite with the hydrology values from the state vector
 if(nSnowSoilHyd>0)then
  do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing)   ! (loop through non-missing hydrology state variables in the snow+soil domain)
   select case( ixHydType(iLayer) )
    case(iname_watLayer); mLayerVolFracWatTrial(iLayer)          = stateVec( ixSnowSoilHyd(iLayer) ) ! total water state variable for snow+soil layers
    case(iname_liqLayer); mLayerVolFracLiqTrial(iLayer)          = stateVec( ixSnowSoilHyd(iLayer) ) ! liquid water state variable for snow+soil layers
    case(iname_matLayer); mLayerMatricHeadTrial(iLayer-nSnow)    = stateVec( ixSnowSoilHyd(iLayer) ) ! total water matric potential variable for soil layers
    case(iname_lmpLayer); mLayerMatricHeadLiqTrial(iLayer-nSnow) = stateVec( ixSnowSoilHyd(iLayer) ) ! liquid matric potential state variable for soil layers
    case default ! do nothing
   end select
  end do  ! looping through non-missing energy state variables in the snow+soil domain
 endif

 end associate

 end subroutine varExtract

end module getVectorz_module


      subroutine avhrr32(z0, p0, t0, u0, ux, nlev,
     *co2, n2o, f11, f12, ch4,
     *od, wght, ntau)
      INCLUDE "avhrr.inc"
      real co2, n2o, ch4, f11, f12
      real z0(mm)
      real od(12,mm)
      real wght(12)
      integer ntau,nlev
      real wi(8),xi(8),p0(mq),p(mm),t0(mq),t(mm),bnu(mm),u0(mq),u(mm),
     *uch4(mm),un2o(mm),tau(6,mm),tauch4(6,mm),taun2o(6,mm),
     *tauf(6,6,6,mm),x(mm,8),y(mm,8),sx(6,6,6,mm),sy(6,6,6,mm),f(6),
     *fch4(6),fn2o(6),fac(mm),tsx(mq),tsy(mq)
      data xi /.01986,.10167,.23723,.40828,
     *         .59172,.76277,.89833,.98014/
      data wi /.05062,.11119,.15685,.18134,
     *         .18134,.15685,.11119,.05062/
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c0      omega=2660.5
c0      delw=360.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c1      omega=2525.0
c1      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
      omega=2595.0
      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c3      omega=2667.5
c3      delw=75.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c4      omega=2740.0
c4      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c5      omega=2817.5
c5      delw=85.0
      omegas=omega
      sigma=5.67e-05
      sconst=1.368e+06
      tsun=5710.0
      fsun=sigma*tsun**4
      mlv=nlyr
      do 5 m=1,nlyr
        t(m)=(t0(m)+t0(m+1))/2.0
        p(m)=(p0(m)+p0(m+1))/2.0
        call flux_32(bnu(m),omega,t(m))
        fac(m)=z0(m+1)-z0(m)
c       u(m)=fac(m)*(u0(m)+u0(m+1))/2.0*6.023e+23/2.687e+19/18.01534
        u(m)=fac(m)*(u0(m)+u0(m+1))/2.0
        uch4(m)=p(m)*1.01325e+06/(1.3805e-16*t(m))*ch4*1e-6*fac(m)*
     *       1.0e+05/6.023e+23*16.04303
        un2o(m)=p(m)*1.01325e+06/(1.3805e-16*t(m))*n2o*1e-6*fac(m)*
     *       1.0e+05/6.023e+23*44.0128
 5    continue
      do 7 m=1,nlev
        tsx(m)=0.0
        tsy(m)=0.0
 7    continue
      call flux_32(back,omega,t0(1))
      call flux_32(bsun,omegas,tsun)
      bsun=bsun/fsun*sconst
      call ck_32(ni,mlv,u,delw,f,p,t,tau)
      call ckch4_32(nch4,mlv,uch4,delw,fch4,p,t,tauch4)
      call ckn2o_32(nn2o,mlv,un2o,delw,fn2o,p,t,taun2o)
      do 10 m=1,nlyr
        do i=1,ni
         do ia=1,nch4
          do ib=1,nn2o
c           tauf(i,ia,ib,m)=tau(i,m)
c           tauf(i,ia,ib,m)=tauch4(ia,m)
c           tauf(i,ia,ib,m)=taun2o(ib,m)
            tauf(i,ia,ib,m)=tau(i,m)+tauch4(ia,m)+taun2o(ib,m)
          end do
         end do
        end do
 10   continue
      do 90 i=1,ni
       do 85 ia=1,nch4
       do 83 ib=1,nn2o
        do 30 m=nlyr,1,-1
          do 20 j=1,8
           if(m.eq.nlyr)then
c           y(m,j)=bnu(m)*(1.0-exp(-tauf(i,ia,ib,m)/xi(j)))
            y(m,j)=bsun*0.6*exp(-tauf(i,ia,ib,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,ib,m)/xi(j)))
           else
            y(m,j)=y(m+1,j)*exp(-tauf(i,ia,ib,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,ib,m)/xi(j)))
           end if
 20       continue
 30     continue
        do 50 m=1,nlyr
          sx(i,ia,ib,m)=0.0
          sy(i,ia,ib,m)=0.0
          do 40 j=1,8
           if(m.eq.1)then
c            x(m,j)=back*exp(-tauf(i,ia,ib,m)/xi(j))+
c     *      bnu(m)*(1.0-exp(-tauf(i,ia,ib,m)/xi(j)))
            x(m,j)=(0.10*y(m,j)+0.90*back)*exp(-tauf(i,ia,ib,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,ib,m)/xi(j)))
           else
            x(m,j)=x(m-1,j)*exp(-tauf(i,ia,ib,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,ib,m)/xi(j)))
           end if
 40       continue
 50     continue
        do 70 m=1,nlyr
          do 60 j=1,8
            sx(i,ia,ib,m)=sx(i,ia,ib,m)+2.0*x(m,j)*wi(j)*xi(j)
            sy(i,ia,ib,m)=sy(i,ia,ib,m)+2.0*y(m,j)*wi(j)*xi(j)
 60       continue
 70     continue
        do 80 m=1,nlyr
           tsx(m+1)=tsx(m+1)+sx(i,ia,ib,m)*delw*f(i)*fch4(ia)*fn2o(ib)
           tsy(m)=tsy(m)+sy(i,ia,ib,m)*delw*f(i)*fch4(ia)*fn2o(ib)
 80     continue
        tb=tb+back*delw*f(i)*fch4(ia)*fn2o(ib)
        tsx(1)=tb
 83    continue
 85    continue
 90   continue
      tb=0.10*tsy(1)+0.90*tb
      tsx(1)=tb
      tsy(nlev)=tsy(nlev)+bsun*0.60*delw
      do 95 m=1,nlev
cbm         write(6,100)m-1,tsx(m),tb-tsx(m),tsy(m)
 95   continue
      do i1=1,2
       do i2=1,2
        do i3=1,3
         do m=1,nlyr
          od(1+(i3-1)+(i2-1)*3+(i1-1)*3*2,m) =
     *tauf(i1,i2,i3,m)
          wght(1+(i3-1)+(i2-1)*3+(i1-1)*3*2) =
     *f(i1) * fch4(i2) * fn2o(i3)
         enddo
        enddo
       enddo
      enddo
      ntau=12
 100  format(i3,3f15.7)
      end
c *********************************************************************
      subroutine flux_32(bnu,omega,t)
      INCLUDE "avhrr.inc"
      bnu=0.0
      z=3.14159
      bnu=z/1000.0*((2.*6.625e-27)*(2.997925e+10)**2
     *    *omega**3)/(exp(min(88.0,1.4388*omega/t))-1.0)
      return
      end
c *********************************************************************
      subroutine ck_32(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=2
      f(1)=0.832661
      f(2)=0.167339
      k(1)=0.003144265
      do i=2,ni
        k(i)=48.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0209,0.0209,0.0209,0.0209,0.0209,0.0209,0.0209,0.0209,0.0209,
     *0.0413,0.0720,0.1181,0.1857,0.2860,0.4310,0.6411,0.8655,1.3127,
     *1.9164,
     *1.466e-04,1.466e-04,1.466e-04,1.466e-04,1.466e-04,1.466e-04,
     *1.466e-04,1.466e-04,1.466e-04,2.931e-04,5.130e-04,8.469e-04,
     *1.339e-03,2.050e-03,3.059e-03,4.495e-03,5.951e-03,9.188e-03,
     *1.396e-02,
     *-3.031e-07,-3.031e-07,-3.031e-07,-3.031e-07,-3.031e-07,-3.031e-07,
     *-3.031e-07,-3.031e-07,-3.031e-07,-5.094e-07,-9.437e-07,-1.303e-06,
     *-1.619e-06,-2.250e-06,-3.119e-06,-5.266e-06,-8.319e-06,-1.471e-05,
     *-2.123e-05/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.2408,1.2408,1.2408,1.2408,1.2408,1.2408,1.2408,1.2408,1.2408,
     *1.2385,1.2563,1.2300,1.2219,1.2113,1.1955,1.1732,1.0584,1.0669,
     *1.0368,
     *8.653e-03,8.653e-03,8.653e-03,8.653e-03,8.653e-03,8.653e-03,
     *8.653e-03,8.653e-03,8.653e-03,8.640e-03,8.624e-03,8.596e-03,
     *8.552e-03,8.479e-03,8.367e-03,8.219e-03,7.444e-03,7.612e-03,
     *7.355e-03,
     *-1.087e-05,-1.087e-05,-1.087e-05,-1.087e-05,-1.087e-05,-1.087e-05,
     *-1.087e-05,-1.087e-05,-1.087e-05,-1.078e-05,-1.065e-05,-1.063e-05,
     *-1.005e-05,-1.000e-05,-9.950e-06,-9.622e-06,-8.787e-06,-7.806e-06,
     *-7.594e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end
c**********************************************************************
      subroutine ckch4_32(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=2
      f(1)=0.854106
      f(2)=0.145894
      k(1)=2.0090607
      do i=2,ni
        k(i)=24.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0349,0.0349,0.0349,0.0349,0.0349,0.0349,0.0349,0.0349,0.0349,
     *0.0576,0.0951,0.1442,0.2190,0.3227,0.4629,0.6455,0.8713,1.1482,
     *1.4573,
     *-5.525e-05,-5.525e-05,-5.525e-05,-5.525e-05,-5.525e-05,-5.525e-05,
     *-5.525e-05,-5.525e-05,-5.525e-05,-8.713e-05,-1.256e-04,-1.724e-04,
     *-2.186e-04,-3.213e-04,-4.741e-04,-7.211e-04,-1.007e-03,-1.513e-03,
     *-2.032e-03,
     *1.875e-08,1.875e-08,1.875e-08,1.875e-08,1.875e-08,1.875e-08,
     *1.875e-08,1.875e-08,1.875e-08,-1.562e-08,-1.344e-07,-4.219e-06,
     *3.437e-08,1.575e-06,3.247e-06,5.997e-06,9.216e-06,1.511e-05,
     *1.507e-05/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.2321,1.2321,1.2321,1.2321,1.2321,1.2321,1.2321,1.2321,1.2321,
     *1.2273,1.2186,1.2075,1.1900,1.1651,1.1323,1.0885,1.0302,0.9709,
     *0.9005,
     *-1.090e-03,-1.090e-03,-1.090e-03,-1.090e-03,-1.090e-03,-1.090e-03,
     *-1.090e-03,-1.090e-03,-1.090e-03,-1.101e-03,-1.076e-03,-1.088e-03,
     *-1.057e-03,-1.035e-03,-1.004e-03,-9.739e-04,-8.859e-04,-7.886e-04,
     *-6.649e-04,
     *5.572e-06,5.572e-06,5.572e-06,5.572e-06,5.572e-06,5.572e-06,
     *5.572e-06,5.572e-06,5.572e-06,5.206e-06,5.787e-06,5.563e-06,
     *5.694e-06,5.263e-06,4.628e-06,4.459e-06,3.122e-06,2.509e-06,
     *2.503e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end
c**********************************************************************
      subroutine ckn2o_32(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=3
      f(1)=0.668178
      f(2)=0.248540
      f(3)=0.083282
      k(1)=17.0622393
      do i=2,ni
        k(i)=8.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.01703,0.01703,0.01703,0.01703,0.01703,0.01703,
     *0.01703,0.01703,0.01703,0.03731,0.06718,0.10397,
     *0.16562,0.25877,0.39737,0.59672,0.86234,1.16586,
     *1.47071,
     *1.965E-04,1.965E-04,1.965E-04,1.965E-04,1.965E-04,1.965E-04,
     *1.965E-04,1.965E-04,1.965E-04,2.875E-04,4.894E-04,7.641E-04,
     *1.162E-03,1.781E-03,2.691E-03,4.006E-03,5.979E-03,8.487E-03,
     *1.088E-02,
     *8.437E-07,8.437E-07,8.437E-07,8.437E-07,8.437E-07,8.437E-07,
     *8.437E-07,8.437E-07,8.437E-07,1.225E-06,8.656E-07,1.834E-06,
     *1.631E-06,2.028E-06,3.047E-06,2.178E-06,1.250E-06,8.769E-06,
     *1.780E-05/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.05480,0.05480,0.05480,0.05480,0.05480,0.05480,
     *0.05480,0.05480,0.05480,0.07811,0.11178,0.16211,
     *0.23725,0.34539,0.48627,0.65651,0.87918,1.15664,
     *1.45212,
     *3.943E-04,3.943E-04,3.943E-04,3.943E-04,3.943E-04,3.943E-04,
     *3.943E-04,3.943E-04,3.943E-04,5.045E-04,6.142E-04,7.469E-04,
     *9.075E-04,1.192E-03,1.556E-03,1.566E-03,9.789E-04,1.514E-04,
     *-4.506E-04,
     *1.363E-06,1.363E-06,1.363E-06,1.363E-06,1.363E-06,1.363E-06,
     *1.363E-06,1.363E-06,1.363E-06,1.944E-06,3.287E-06,4.072E-06,
     *3.737E-06,3.259E-06,3.912E-06,1.136E-05,1.465E-05,1.280E-05,
     *9.872E-06/
      data ( (coefk(3,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.38653,1.38653,1.38653,1.38653,1.38653,1.38653,
     *1.38653,1.38653,1.38653,1.35160,1.32052,1.29430,
     *1.26967,1.24171,1.20387,1.15143,1.06761,0.94384,
     *0.79703,
     *1.688E-03,1.688E-03,1.688E-03,1.688E-03,1.688E-03,1.688E-03,
     *1.688E-03,1.688E-03,1.688E-03,1.615E-03,1.477E-03,1.339E-03,
     *1.156E-03,9.571E-04,6.251E-04,4.246E-04,3.944E-04,3.654E-04,
     *2.709E-04,
     *6.000E-06,6.000E-06,6.000E-06,6.000E-06,6.000E-06,6.000E-06,
     *6.000E-06,6.000E-06,6.000E-06,5.522E-06,6.284E-06,6.441E-06,
     *6.112E-06,5.891E-06,5.609E-06,3.409E-06,1.603E-06,1.141E-06,
     *9.219E-07/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end


!========================================================================
!
!                   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 software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

 subroutine prepare_timerun_GPU()

  use specfem_par

  implicit none

  ! local parameters
  real :: free_mb,used_mb,total_mb
  integer :: nspec_elastic

  nspec_elastic = nspec - count_nspec_acoustic

  ! GPU_MODE now defined in Par_file
  if(myrank == 0 ) then
    write(IOUT,*)
    write(IOUT,*) "GPU Preparing Fields and Constants on Device."
    call flush_IOUT()
  endif

!!!!!!!!!!! Parametres fournis

! ibool(i,j,ispec)                       : convertisseur numero du point GLL local (i,j) de l'element ispec => global (iglob)
! ninterface                             : nombre d'interfaces de la partition locale avec les autres partitions
! max_nibool_interfaces_ext_mesh         : nombre maximum de points GLL contenus sur une interface
! nibool_interfaces_ext_mesh(i)          : nombre de points GLL contenus sur l'interface i
! ibool_interfaces_ext_mesh(iGGL,i)      : numero global iglob du ieme point GLL (iGLL) de l'interface i
! numabs                                 : tableau des elements spectraux situes en zone absorbante
! abs_boundary_ij(i,j,ispecabs)          : coordonnee locale i de j eme point GLL de l'element absorbant ispecabs
! abs_boundary_normal(i,j,ispecabs)      : i eme coordonnee du vecteur normal du j eme point GLL de l'element absorbant ispecabs
! abs_boundary_jacobian1Dw(i,ispecabs)   : i eme jacobienne ponderee de l'element absorbant jspecabs
! nelemabs                               : nombre d'elements absorbant
! cote_abs(ispecabs)                     : numero du cote (1=b, 2=r, 3=t, 4=l ) auquel appartient l'element absorbant ispecabs
! ib_left                                : correspondance entre le numero d'element absorbant global et son numero sur le cote
! ispec_is_inner                         : booleen vrai si l'element est a l'interieur d'une partition
! sourcearray_loc(i_src,dim,i,j)         : tableau de ponderation de l'intensite de la source pour chaque point GLL (i,j)
!                                          de l'element spectral qui contient la source locale i_src
! ispec_selected_source(i)               : numero d'element spectral contenant la source locale i
! recloc(i)                              : convertisseur numero rec local i => numero rec global
! ispec_selected_rec(i)                  : numero d'element spectral du receveur i
! nrecloc                                : nombre de receveurs locaux
! count_nspec_acoustic                   : nombre local d'elements spectraux acoustiques

  ! prepares general fields on GPU
  !! JC JC here we will need to add GPU support for the C-PML routines

  call prepare_constants_device(Mesh_pointer, &
                                NGLLX, nspec, nglob, &
                                xix, xiz, gammax, gammaz, &
                                kappastore, mustore, &
                                ibool, &
                                ninterface, max_nibool_interfaces_ext_mesh, &
                                nibool_interfaces_ext_mesh, ibool_interfaces_ext_mesh, &
                                hprime_xx,hprimewgll_xx, &
                                wxgll,&
                                STACEY_BOUNDARY_CONDITIONS, &
                                nspec_bottom,&
                                nspec_left,&
                                nspec_right,&
                                nspec_top,&
                                numabs, abs_boundary_ij, &
                                abs_boundary_normal, &
                                abs_boundary_jacobian1Dw, &
                                nelemabs, &
                                cote_abs, &
                                ib_bottom, &
                                ib_left, &
                                ib_right, &
                                ib_top, &
                                ispec_is_inner, &
                                nsources_local, &
                                sourcearray_loc,source_time_function_loc,&
                                NSTEP,ispec_selected_source_loc, &
                                recloc, ispec_selected_rec, &
                                nrec, nrecloc, &
                                cosrot_irecf,sinrot_irecf,&
                                SIMULATION_TYPE, &
                                USE_MESH_COLORING_GPU, &
                                count_nspec_acoustic,nspec_elastic,&
                                myrank,SAVE_FORWARD, &
                                xir_store_loc, &
                                gammar_store_loc)

!!! Parametres fournis

! rmass_inverse_acoustic                 : matrice acoustique inversee de taille nglob (nglob_acoustic = nglob s'il existe des elements acoustiques)
! num_phase_ispec_acoustic               : max entre nb d'element spectraux acoustiques interieur et exterieur
! phase_ispec_inner_acoustic(i,j)        : i eme element spectral acoustique interieur si j=2 exterieur si j=1
! acoustic(i)                            : vrai si l'element spectral i est acoustique
! nelem_acoustic_surface                 : nombre d'elements spectraux situes sur une surface libre acoustique
! free_ac_ispec                          : numero d'element spectral du i eme element acoustique sur surface libre
! free_surface_ij(i,j,ispec)             : i eme coordonnee du j eme point GLL de l'element spectral libre ispec
! b_reclen_potential                     : place en octet prise par b_nelem_acoustic_surface * GLLX
! any_elastic                            : vrai s'il existe des elements elastiques
! num_fluid_solid_edges                  : nombre d'elements spectraux sur une frontiere elastique/acoustique
! coupling_ac_el_ispec                   : tableau des elements spectraux frontiere ACOUSTIQUE
! coupling_ac_el_ij                      : coordonnees locales des points GLL sur la frontiere elastique/acoustique
! coupling_ac_el_normal(i,j,ispec)       : i eme coordonne de la normale au point GLL j de l'element frontiere ispec
! coupling_ac_el_jacobian1Dw(i,ispec)    : jacobienne ponderee du i eme point GLL de l'element frontiere ispec
! num_colors_outer_acoustic              : a initialiser plus tard quand USE_COLOR_MESH sera implemente
! num_colors_inner_acoustic              : a initialiser plus tard quand USE_COLOR_MESH sera implemente
! num_elem_colors_acoustic               : a initialiser plus tard quand USE_COLOR_MESH sera implemente

  ! prepares fields on GPU for acoustic simulations
  if( any_acoustic ) then
    call prepare_fields_acoustic_device(Mesh_pointer, &
                                rmass_inverse_acoustic,rhostore,kappastore, &
                                num_phase_ispec_acoustic,phase_ispec_inner_acoustic, &
                                acoustic, &
                                nelem_acoustic_surface, &
                                free_ac_ispec,free_surface_ij, &
                                any_elastic, num_fluid_solid_edges, &
                                coupling_ac_el_ispec,coupling_ac_el_ij, &
                                coupling_ac_el_normal,coupling_ac_el_jacobian1Dw, &
                                ninterface_acoustic,inum_interfaces_acoustic, &
                                num_colors_outer_acoustic,num_colors_inner_acoustic, &
                                num_elem_colors_acoustic)

    if( SIMULATION_TYPE == 3 ) &
      call prepare_fields_acoustic_adj_dev(Mesh_pointer, &
                                APPROXIMATE_HESS_KL)

  endif

!!! Parametres fournis

! rmass_inverse_elastic                 : matrice elastique inversee de taille nglob_acoustic (nglob_acoustic = nglob s'il existe des elements acoustiques)
! num_phase_ispec_elastic               : max entre nb d'element spectraux elastiques interieur et exterieur
! phase_ispec_inner_elastic(i,j)        : i eme element spectral elastique interieur si j=2 exterieur si j=1
! elastic(i)                            : vrai si l'element spectral i est elastique
! num_colors_outer_elastic              : a initialiser plus tard quand USE_COLOR_MESH sera implemente
! num_colors_inner_elastic              : a initialiser plus tard quand USE_COLOR_MESH sera implemente
! num_elem_colors_elastic               : a initialiser plus tard quand USE_COLOR_MESH sera implemente

  ! prepares fields on GPU for elastic simulations
  !?!? JC JC here we will need to add GPU support for the new C-PML routines
  if( any_elastic ) then
    call prepare_fields_elastic_device(Mesh_pointer, &
                                rmass_inverse_elastic_one,rmass_inverse_elastic_three, &
                                rho_vp,rho_vs, &
                                num_phase_ispec_elastic,phase_ispec_inner_elastic, &
                                elastic, &
                                nspec_left,&
                                nspec_right,&
                                nspec_top,&
                                nspec_bottom,&
                                any_acoustic, &
                                num_colors_outer_elastic,num_colors_inner_elastic, &
                                num_elem_colors_elastic, &
                                ANY_ANISOTROPY, &
                                c11store,c12store,c13store, &
                                c15store,c23store, &
                                c25store,c33store,c35store,c55store,ninterface_elastic,inum_interfaces_elastic)

    if( SIMULATION_TYPE == 3 ) &
      call prepare_fields_elastic_adj_dev(Mesh_pointer, &
                                NDIM*NGLOB_AB, &
                                APPROXIMATE_HESS_KL)

  endif

  ! prepares fields on GPU for poroelastic simulations
  if( any_poroelastic ) then
    stop 'todo poroelastic simulations on GPU'
  endif

  ! prepares needed receiver array for adjoint runs
  if( SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3 ) &
    call prepare_sim2_or_3_const_device(Mesh_pointer, &
                                which_proc_receiver,nrecloc,nrec,source_adjointe,NSTEP)

  ! synchronizes processes
  call sync_all()

  ! puts acoustic initial fields onto GPU
  if( any_acoustic ) then
    call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
                                      potential_dot_acoustic,potential_dot_dot_acoustic,Mesh_pointer)

    if( SIMULATION_TYPE == 3 ) &
      call transfer_b_fields_ac_to_device(NGLOB_AB,b_potential_acoustic, &
                                          b_potential_dot_acoustic,b_potential_dot_dot_acoustic,Mesh_pointer)
  endif

  ! puts elastic initial fields onto GPU
  if( any_elastic ) then
    ! transfer forward and backward fields to device with initial values
    call transfer_fields_el_to_device(NDIM*NGLOB_AB,displ_2D,veloc_2D,accel_2D,Mesh_pointer)
    if(SIMULATION_TYPE == 3) &
      call transfer_b_fields_to_device(NDIM*NGLOB_AB,b_displ_2D,b_veloc_2D,b_accel_2D,Mesh_pointer)
  endif

  ! synchronizes processes
  call sync_all()

  ! outputs GPU usage to files for all processes
  call output_free_device_memory(myrank)

  ! outputs usage for main process
  if( myrank == 0 ) then
    call get_free_device_memory(free_mb,used_mb,total_mb)
    write(IOUT,*) "GPU usage: free  =",free_mb," MB",nint(free_mb/total_mb*100.0),"%"
    write(IOUT,*) "           used  =",used_mb," MB",nint(used_mb/total_mb*100.0),"%"
    write(IOUT,*) "           total =",total_mb," MB",nint(total_mb/total_mb*100.0),"%"
    write(IOUT,*)
    call flush_IOUT()
  endif

  end subroutine prepare_timerun_GPU


      subroutine read_radar_info(c4_radarname,rlat_radar,rlon_radar
     :                                       ,rheight_radar,istatus)

      character*4 c4_radarname
      character*80 c80_line

      call getenv('RADARNAME',c4_radarname)

      write(6,*)'read_radar_info: RADARNAME = ',c4_radarname

      open(11,file='radarinfo.dat',status='old')

 10   read(11,1,err=900)c80_line
 1    format(a)

      if(c80_line(1:4) .eq. c4_radarname)then ! We've got the right radar
          read(c80_line,2)ideg_lat,imin_lat,isec_lat
     1                   ,ideg_lon,imin_lon,isec_lon
     1                   ,iheight
 2        format(26x,i2,6x,i2,6x,i2,7x,i3,5x,i2,6x,i2,6x,i4)
          rlat_radar =  float(ideg_lat) + float(imin_lat)/60.
     1                                  + float(isec_lat)/3600.
          rlon_radar = -float(ideg_lon) - float(imin_lon)/60.
     1                                  - float(isec_lon)/3600.
          rheight_radar = iheight
          write(6,*)' rlat_radar,rlon_radar,rheight_radar '
     1               ,rlat_radar,rlon_radar,rheight_radar
          istatus = 1
          close(11)
          return
      endif

      goto 10

 900  istatus = 0
      close(11)
      write(6,*)'read_radar_info: Radar data not found'
      return

 999  istatus = 1

      return
      end