    module GeneralSetup
    use CalcLike
    use MonteCarlo
    use GeneralTypes
    use BaseParameters
    use SampleCollector
    use ImportanceSampling
    use minimize
    use IO
    use ParamPointSet
    implicit none

    integer, parameter :: action_MCMC=0, action_importance=1, action_maxlike=2, action_hessian=3, action_tests=4

    Type :: TSetup
        integer :: action = action_MCMC
        integer :: sampling_method = sampling_metropolis
        integer :: samples
        class(TGeneralConfig), allocatable:: Config
        class(TLikeCalculator), allocatable:: LikeCalculator
        class(TSampleCollector), allocatable :: SampleCollector
        class(TSamplingAlgorithm), allocatable :: SamplingAlgorithm
        class(TImportanceSampler), allocatable :: ImportanceSampler
    contains
    procedure :: Init => TSetup_Init
    procedure :: ReadParams  => TSetup_ReadParams
    procedure :: DoneInitialize => TSetup_DoneInitialize !Called again after other things configured
    procedure :: GetMinimizer => TSetup_GetMinimizer
    procedure :: DoSampling => TSetup_DoSampling
    procedure :: DoTests => TSetup_DoTests
    end type

    class(TSetup), allocatable :: Setup

    contains

    subroutine TSetup_Init(this)
    class(TSetup) :: this

    if (.not. allocated(this%LikeCalculator)) allocate(TGenericLikeCalculator::this%LikeCalculator)
    if (.not. allocated(this%Config)) allocate(TGeneralConfig::this%Config)

    end subroutine TSetup_Init

    subroutine TSetup_ReadParams(this, Ini)
    !Called after Init
    class(TSetup) :: this
    class(TSettingIni) :: Ini

    call this%Config%ReadParams(Ini)
    this%action = Ini%Read_Int('action',action_MCMC,min=0,max=action_tests)
    if (this%action/=action_importance) use_fast_slow = Ini%Read_Logical('use_fast_slow',.true.)

    call this%LikeCalculator%InitWithParams(Ini, this%Config)

    if (this%action==action_MCMC) then
        allocate(TMpiChainCollector::this%SampleCollector)
        call this%SampleCollector%InitWithParams(Ini, this%Config)
        this%sampling_method = Ini%Read_Int('sampling_method',sampling_metropolis)
        if (this%sampling_method == sampling_metropolis) then
            allocate(TMetropolisSampler::this%SamplingAlgorithm)
        else if (this%sampling_method == sampling_fast_dragging) then
            allocate(TFastDraggingSampler::this%SamplingAlgorithm)
            use_fast_slow = .true.
        else
            call MpiStop('Sampling method not currently supported')
        end if
        call this%SamplingAlgorithm%ReadParams(Ini)
        this%samples = Ini%Read_Int('samples')
    else if (this%action == action_importance) then
        allocate(TImportanceSampler::this%ImportanceSampler)
        call this%ImportanceSampler%ReadParams(Ini)
        if (this%ImportanceSampler%redo_theory) call this%Config%Calculator%ReadImportanceParams(Ini)
    end if

    end subroutine TSetup_ReadParams

    subroutine TSetup_DoneInitialize(this)
    !Called after likelihoods, base parameters, etc initialized
    class(TSetup), target :: this

    if (allocated(this%SamplingAlgorithm)) then
        call this%SamplingAlgorithm%Init(this%LikeCalculator, this%SampleCollector)
        select type (Sampler=>this%SamplingAlgorithm)
        class is (TChainSampler)
            if (allocated(this%SampleCollector)) then
                select type (Collector=>this%SampleCollector)
                class is (TMpiChainCollector)
                    Collector%Sampler => Sampler
                    if (BaseParams%covariance_has_new) &
                        & Collector%MPi%MPI_Max_R_ProposeUpdate = Collector%Mpi%MPI_Max_R_ProposeUpdateNew
                end select
            end if
            call Sampler%SetCovariance(BaseParams%covariance_estimate)
        end select
    end if

    if (allocated(this%ImportanceSampler)) then
        call this%ImportanceSampler%Init(this%LikeCalculator)
    end if

    end subroutine TSetup_DoneInitialize

    subroutine TSetup_GetMinimizer(this, Minimizer)
    class(TSetup), target :: this
    class(TMinimizer), allocatable :: Minimizer

    allocate(TPowellMinimizer::Minimizer)
    Minimizer%LikeCalculator=>this%LikeCalculator

    end subroutine TSetup_GetMinimizer

    subroutine TSetup_DoSampling(this, Params)
    class(TSetup), target :: this
    class(ParamSet) :: Params
    real(mcp) mult
    real(mcp) StartLike
    character(LEN=:), allocatable :: fname

    select type (Sampler=>this%SamplingAlgorithm)
    class is (TChainSampler)
        if (new_chains) then
            call BaseParams%SetStartPositions(Params)
            StartLike=LogZero
        else
            call IO_ReadLastChainParams(rootname//'.txt', mult, StartLike, Params%P, params_used)
            if (allocated(this%SampleCollector)) then
                call this%SampleCollector%ReadCheckpoint()
            end if
        end if
        fname = rootname//'.txt'
        call ChainOutFile%CreateOpenFile(fname, append = .not. new_chains)

        if (Feedback > 0 .and. MPIRank==0) write (*,*) 'starting Monte-Carlo'
        call Sampler%SampleFrom(Params, StartLike, this%samples)
        call ChainOutFile%Close()
        class default
        call MpiStop('Sampling not implemented')
    end select
    if (Feedback > 0) write (*,*) 'finished'

    end subroutine TSetup_DoSampling

    subroutine TSetup_DoTests(this, output_root, paramsvals, check_compare)
    !This runs likelihoods for fixed values of parameters and outputs the likelihoods and timings
    !e.g. for likelihood testing between versions, performance testing, etc.
    !also can set output_root to write out theory calculation and derived quantities for specific parameters
    class(TSetup) :: this
    character(LEN=*) :: output_root
    real(mcp), intent(in) :: paramsvals(:)
    real(mcp), intent(in) :: check_compare
    Type(ParamSet) :: Params
    real(mcp) :: logLike, time
    Type(TTimer) Timer

    Params%P(:num_params) = paramsvals(:num_params)
    this%LikeCalculator%timing = .true.
    call Timer%Start()
    logLike = this%LikeCalculator%GetLogLike(Params)
    time = Timer%Time()
    write(*,*) '   loglike     chi-sq'
    if (Feedback <=2) call DataLikelihoods%WriteLikelihoodContribs(stdout, Params%likelihoods)
    if (logLike == logZero) then
        write(*,*) 'Test likelihoods done, parameter point rejected (logZero or outside prior)'
    else
        write(*,'("Test likelihoods done, total logLike, chi-eq = ",2f11.3)') logLike, logLike*2
        if (check_compare /= logZero) then
            write(*,'("Expected likelihoods,  total logLike, chi-eq = ",2f11.3)')  check_compare, check_compare*2
            if (abs(check_compare-LogLike) < 0.05) then
                write(*,*) '...OK, delta = ', logLike-check_compare
            else
                error stop  '** Likelihoods do not match **'
            end if
        end if
        write(*,*) 'Likelihood calculation time (seconds)= '//RealToStr(time)
        if (output_root/='') then
            call this%LikeCalculator%WriteParamPointTextData(output_root, Params)
            call this%LikeCalculator%WriteParamsHumanText(output_root//'.pars', Params, LogLike)
        end if
    end if
    call DoStop()

    end subroutine TSetup_DoTests

    end module GeneralSetup


!
!     ------------------------------------------------------------------
!     O R T H
!
!     ------------------------------------------------------------------
!
      SUBROUTINE ORTH
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE NOR_C
      use ndims_C
      use non30_C
      use ovrlap_C
!
!
!     Determine the orthogonality between initial and final state
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  00:00:10  11/17/01
!...Switches:

      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NWD = 128
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: M1, I, NCOM1, NOR1, NOR11, NOR2, J, IJ
!-----------------------------------------------
!      POINTER(QNOC,NOCCSH(1)),(QNELCSH,NELCSH(8,1)),
!     :       (QNOCORB,NOCORB(8,1)),(QJ1,J1QNRD(15,1))
!      POINTER(QIAJCMP,IAJCMP(1)),(QLJCOMP,LJCOMP(1)),
!     :       (QNJCOMP,NJCOMP(1)),(QIAJCLD,IAJCLD(1)),
!     :       (QLJCLSD,LJCLSD(1))
!      COMMON /NDIMS/ QNOC,QNELCSH,QNOCORB,QJ1,NCFG
!      COMMON /NON30/ QIAJCMP,QNJCOMP,QLJCOMP,QIAJCLD,QLJCLSD,MAXORB
!      POINTER (QIORTH,IORTH(1))
!      COMMON/OVRLAP/MU,NU,MUP,NUP,NONORT,NOVLPS,IROWMU,IROWNU,ICOLMU,
!     1 ICOLNU,NORTH,IORDER,NCALLS,LMU,LNU,LMUP,LNUP,JMU,JNU,JMUP,JNUP,
!     2 QIORTH
!
!
!   SET UP OF IORTH VECTOR
!   THE COMMON SET (NCOM) IS ASSUMED TO BE ORTHOGONAL TO BOTH
!   NORBI AND NORBF SETS
!
      IF (NORBI == 0) RETURN
      M1 = NORBI*NORBF
      IORTH(:M1) = 0
      NORTH = 0
!
!  | 1....NCOM | NCOM1.....NOR1 | NOR11.....NOR2|
!  |   NCOM    |     NORBI      |     NORBF     |
!  |   <= NWD  |     <= NWD     |     <=NWD     |
!
!  THIS LIMITATION IS LINKED TO THE DIMENSION OF BUFFER(NWD) IN
!  ANALYSE SUBROUTINE, where <= stands for LESS THAN or EQUAL.
!
      NCOM1 = NCOM + 1
      NOR1 = NCOM + NORBI
      NOR11 = NOR1 + 1
      NOR2 = NOR1 + NORBF
      DO J = NCOM1, NOR1
         DO I = NOR11, NOR2
            IJ = NORBF*(J - NCOM1) + I - NOR1
            IF (LJCOMP(I) /= LJCOMP(J)) CYCLE
            NORTH = NORTH + 1
            IORTH(IJ) = 1
         END DO
      END DO
      RETURN
      END SUBROUTINE ORTH


      subroutine hruyr

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine writes annual HRU output to the output.hru file

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bio_yrms(:)   |metric tons/ha|annual biomass (dry weight) in the HRU
!!    cpnm(:)       |NA            |four character code to represent crop name
!!    deepst(:)     |mm H2O        |depth of water in deep aquifer
!!    hru_km(:)     |km^2          |area of HRU in square kilometers
!!    hru_sub(:)    |none          |subbasin in which HRU is located
!!    hrugis(:)     |none          |GIS code printed to output files(output.hru,.rch)
!!    hruyro(1,:)   |mm H2O        |precipitation in HRU during year
!!    hruyro(2,:)   |mm H2O        |amount of precipitation falling as freezing
!!                                 |rain/snow in HRU during year
!!    hruyro(3,:)   |mm H2O        |amount of snow melt in HRU during year
!!    hruyro(4,:)   |mm H2O        |amount of surface runoff to main channel
!!                                 |from HRU during year (ignores impact of
!!                                 |transmission losses)
!!    hruyro(5,:)   |mm H2O        |amount of lateral flow contribution to main
!!                                 |channel from HRU during year
!!    hruyro(6,:)   |mm H2O        |amount of groundwater flow contribution to
!!                                 |main channel from HRU during year
!!    hruyro(7,:)   |mm H2O        |amount of water moving from shallow aquifer
!!                                 |to plants or soil profile in HRU during year
!!    hruyro(8,:)   |mm H2O        |amount of water recharging deep aquifer in
!!                                 |HRU during year
!!    hruyro(9,:)   |mm H2O        |total amount of water entering both aquifers
!!                                 |from HRU during year
!!    hruyro(10,:)  |mm H2O        |water yield (total amount of water entering
!!                                 |main channel) from HRU during year
!!    hruyro(11,:)  |mm H2O        |amount of water percolating out of the soil
!!                                 |profile and into the vadose zone in HRU
!!                                 |during year
!!    hruyro(12,:)  |mm H2O        |actual evapotranspiration in HRU during year
!!    hruyro(13,:)  |mm H2O        |amount of transmission losses from tributary
!!                                 |channels in HRU for year
!!    hruyro(14,:)  |metric tons/ha|sediment yield from HRU for year
!!    hruyro(17,:)  |kg N/ha       |amount of nitrogen applied in continuous
!!                                 |fertilizer operation during year in HRU
!!    hruyro(18,:)  |kg P/ha       |amount of phosphorus applied in continuous
!!                                 |fertilizer operation during year in HRU
!!    hruyro(23,:)  |mm H2O        |amount of water removed from shallow aquifer
!!                                 |in HRU for irrigation during year
!!    hruyro(24,:)  |mm H2O        |amount of water removed from deep aquifer
!!                                 |in HRU for irrigation during year
!!    hruyro(25,:)  |mm H2O        |potential evapotranspiration in HRU during
!!                                 |year
!!    hruyro(26,:)  |kg N/ha       |annual amount of N (organic & mineral)
!!                                 |applied in HRU during grazing
!!    hruyro(27,:)  |kg P/ha       |annual amount of P (organic & mineral)
!!                                 |applied in HRU during grazing
!!    hruyro(28,:)  |kg N/ha       |annual amount of N (organic & mineral)
!!                                 |auto-applied in HRU
!!    hruyro(29,:)  |kg P/ha       |annual amount of P (organic & mineral)
!!                                 |auto-applied in HRU
!!    hruyro(31,:)  |stress days   |water stress days in HRU during year
!!    hruyro(32,:)  |stress days   |temperature stress days in HRU during year
!!    hruyro(33,:)  |stress days   |nitrogen stress days in HRU during year
!!    hruyro(34,:)  |stress days   |phosphorus stress days in HRU during year
!!    hruyro(35,:)  |kg N/ha       |organic nitrogen in surface runoff in HRU
!!                                 |during year
!!    hruyro(36,:)  |kg P/ha       |organic phosphorus in surface runoff in HRU
!!                                 |during year
!!    hruyro(37,:)  |kg N/ha       |nitrate in surface runoff in HRU during year
!!    hruyro(38,:)  |kg N/ha       |nitrate in lateral flow in HRU during year
!!    hruyro(39,:)  |kg P/ha       |soluble phosphorus in surface runoff in HRU
!!                                 |during year
!!    hruyro(40,:)  |kg N/ha       |amount of nitrogen removed from soil by plant
!!                                 |uptake in HRU during year
!!    hruyro(41,:)  |kg N/ha       |nitrate percolating past bottom of soil
!!                                 |profile in HRU during year
!!    hruyro(42,:)  |kg P/ha       |amount of phosphorus removed from soil by
!!                                 |plant uptake in HRU during year
!!    hruyro(43,:)  |kg P/ha       |amount of phosphorus moving from labile
!!                                 |mineral to active mineral pool in HRU during
!!                                 |year
!!    hruyro(44,:)  |kg P/ha       |amount of phosphorus moving from active
!!                                 |mineral to stable mineral pool in HRU during
!!                                 |year
!!    hruyro(45,:)  |kg N/ha       |amount of nitrogen applied to HRU in
!!                                 |fertilizer and grazing operations during
!!                                 |year
!!    hruyro(46,:)  |kg P/ha       |amount of phosphorus applied to HRU in
!!                                 |fertilizer and grazing operations during
!!                                 |year
!!    hruyro(47,:)  |kg N/ha       |amount of nitrogen added to soil by fixation
!!                                 |in HRU during year
!!    hruyro(48,:)  |kg N/ha       |amount of nitrogen lost by denitrification
!!                                 |in HRU during year
!!    hruyro(49,:)  |kg N/ha       |amount of nitrogen moving from active organic
!!                                 |to nitrate pool in HRU during year
!!    hruyro(50,:)  |kg N/ha       |amount of nitrogen moving from active organic
!!                                 |to stable organic pool in HRU during year
!!    hruyro(51,:)  |kg P/ha       |amount of phosphorus moving from organic to
!!                                 |labile mineral pool in HRU during year
!!    hruyro(52,:)  |kg N/ha       |amount of nitrogen moving from fresh organic
!!                                 |to nitrate and active organic pools in HRU
!!                                 |during year
!!    hruyro(53,:)  |kg P/ha       |amount of phosphorus moving from fresh
!!                                 |organic to the labile mineral and organic
!!                                 |pools in HRU during year
!!    hruyro(54,:)  |kg N/ha       |amount of nitrogen added to soil in rain
!!                                 |during year
!!    hruyro(61,:)  |metric tons/ha|daily soil loss predicted with USLE equation
!!    hruyro(63,:)  |# bacteria/ha |less persistent bacteria transported to main
!!                                 |channel from HRU during year
!!    hruyro(64,:)  |# bacteria/ha |persistent bacteria transported to main
!!                                 |channel from HRU during year
!!    hruyro(65,:)  |kg N/ha       |nitrate loading from groundwater in HRU to
!!                                 |main channel during year
!!    hruyro(66,:)  |kg P/ha       |soluble P loading from groundwater in HRU to
!!                                 |main channel during year
!!    hruyro(67,:)  |kg P/ha       |loading of mineral P attached to sediment
!!                                 |in HRU to main channel during year
!!    icr(:)        |none          |sequence number of crop grown within the
!!                                 |current year
!!    idplt(:)      |none          |land cover code from crop.dat
!!    ipdvas(:)     |none          |output variable codes for output.hru file
!!    isproj        |none          |special project code:
!!                                 |1 test rewind (run simulation twice)
!!    itots         |none          |number of output variables printed (output.hru)
!!    iyr           |year          |current year of simulation (eg 1980)
!!    lai_yrmx(:)   |none          |maximum leaf area index for the year in the
!!                                 |HRU
!!    mhruo         |none          |maximum number of variables written to
!!                                 |HRU output file (output.hru)
!!    nhru          |none          |number of HRUs in watershed
!!    nmgt(:)       |none          |management code (for GIS output only)
!!    nro(:)        |none          |sequence number of year in rotation
!!    shallst(:)    |mm H2O        |depth of water in shallow aquifer
!!    sol_sw(:)     |mm H2O        |amount of water stored in the soil profile
!!                                 |on any given day
!!    yldanu(:)     |metric tons/ha|annual yield (dry weight) in the HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii          |none          |counter
!!    j           |none          |HRU number
!!    pdvas(:)    |varies        |array to hold HRU output values
!!    pdvs(:)     |varies        |array to hold selected HRU output values
!!                               |when user doesn't want to print all
!!    sb          |none          |subbasin number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

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

      use parm

      integer :: j, sb, ii, iflag
      real, dimension (mhruo) :: pdvas, pdvs
      character (len=4) :: cropname

      do j = 1, nhru
        iflag = 0
	    sb = hru_sub(j)

        do ii = 1, itoth
          if (ipdhru(ii) == j) iflag = 1
        end do

        if (iflag == 1) then

        pdvas = 0.
        pdvs = 0.

        pdvas(1) = hruyro(1,j)
        pdvas(2) = hruyro(2,j)
        pdvas(3) = hruyro(3,j)
        pdvas(4) = hruyro(22,j)
        pdvas(5) = hruyro(25,j)
        pdvas(6) = hruyro(12,j)
        pdvas(7) = hruyro(21,j) / Real(366 - leapyr)
        pdvas(8) = sol_sw(j)
        pdvas(9) = hruyro(11,j)
        pdvas(10) = hruyro(9,j)
        pdvas(11) = hruyro(8,j)
        pdvas(12) = hruyro(7,j)
        pdvas(13) = hruyro(23,j)
        pdvas(14) = hruyro(24,j)
        pdvas(15) = shallst(j)
        pdvas(16) = deepst(j)
        pdvas(17) = hruyro(19,j)
        pdvas(18) = hruyro(4,j)
        pdvas(19) = hruyro(13,j)
        pdvas(20) = hruyro(5,j)
        pdvas(21) = hruyro(6,j)
        pdvas(22) = hruyro(10,j)
        pdvas(23) = hruyro(20,j) / Real(366 - leapyr)
        pdvas(24) = hruyro(57,j) / Real(366 - leapyr)
        pdvas(25) = hruyro(55,j) / Real(366 - leapyr)
        pdvas(26) = hruyro(56,j) / Real(366 - leapyr)
        pdvas(27) = hruyro(30,j) / Real(366 - leapyr)
        pdvas(28) = hruyro(58,j) / Real(366 - leapyr)
        pdvas(29) = hruyro(14,j)
        pdvas(30) = hruyro(61,j)
        pdvas(31) = hruyro(45,j)
        pdvas(32) = hruyro(46,j)
        pdvas(33) = hruyro(28,j)
        pdvas(34) = hruyro(29,j)
        pdvas(35) = hruyro(26,j)
        pdvas(36) = hruyro(27,j)
        pdvas(37) = hruyro(17,j)
        pdvas(38) = hruyro(18,j)
        pdvas(39) = hruyro(54,j)
        pdvas(40) = hruyro(47,j)
        pdvas(41) = hruyro(52,j)
        pdvas(42) = hruyro(49,j)
        pdvas(43) = hruyro(50,j)
        pdvas(44) = hruyro(53,j)
        pdvas(45) = hruyro(51,j)
        pdvas(46) = hruyro(43,j)
        pdvas(47) = hruyro(44,j)
        pdvas(48) = hruyro(48,j)
        pdvas(49) = hruyro(40,j)
        pdvas(50) = hruyro(42,j)
        pdvas(51) = hruyro(35,j)
        pdvas(52) = hruyro(36,j)
        pdvas(53) = hruyro(67,j)
        pdvas(54) = hruyro(37,j)
        pdvas(55) = hruyro(38,j)
        pdvas(56) = hruyro(41,j)
        pdvas(57) = hruyro(65,j)
        pdvas(58) = hruyro(39,j)
        pdvas(59) = hruyro(66,j)
        pdvas(60) = hruyro(31,j)
        pdvas(61) = hruyro(32,j)
        pdvas(62) = hruyro(33,j)
        pdvas(63) = hruyro(34,j)
        pdvas(64) = bio_yrms(j)
        pdvas(65) = lai_yrmx(j)
        pdvas(66) = yldanu(j)
        pdvas(67) = hruyro(63,j)
        pdvas(68) = hruyro(64,j)
        pdvas(69) = wtab(j)  !! based on 30 day antecedent climate(mm) (prec,et)
!       pdvas(70) = wtabelo   !! based on depth from soil surface (mm)
        pdvas(70) = wat_tbl(j)   !! based on depth from soil surface (mm): Dmoriasi 4/08/2014
!!      added current snow content in the hru (not summed)
        pdvas(71) = sno_hru(j)

!!      added current soil carbon for first layer
        pdvas(72) = cmup_kgh(j)    !! first soil layer only
!!      added current soil carbon integrated - ggreagating all soil layers
        pdvas(73) = cmtot_kgh(j)

!!    adding qtile to output.hru write 3/2/2010 gsm
        pdvas(74) = hruyro(62,j)
!!    tileno3 - output.hru
        pdvas(75) = hruyro(68,j)
!!    latno3 - output.hru
        pdvas(76) = hruyro(69,j)
!!    gwq deep
        pdvas(77) = hruyro(70,j)
!!    latq contribution
        pdvas(78) = hruyro(71,j)
!!      phos due to crack flow (tvap)
        pdvas(79) = hruyro(72,j)

# GWP edits
        pdvas(80) = hruyro(73,j) / Real(366 - leapyr)
        pdvas(81) = hruyro(74,j) / Real(366 - leapyr)
        pdvas(82) = hruyro(75,j) / Real(366 - leapyr)
        pdvas(83) = hruyro(76,j) / Real(366 - leapyr)
        pdvas(84) = hruyro(77,j) / Real(366 - leapyr)
        pdvas(85) = hruyro(78,j) / Real(366 - leapyr)
        pdvas(86) = hruyro(79,j) / Real(366 - leapyr)
        pdvas(87) = hruyro(80,j) / Real(366 - leapyr)
        pdvas(88) = hruyro(81,j) / Real(366 - leapyr)
        pdvas(89) = hruyro(82,j) / Real(366 - leapyr)

# end GWP edits

        if (ipdvas(1) > 0) then
          do ii = 1, itots
            pdvs(ii) = pdvas(ipdvas(ii))
          end do

        idplant = idplt(j)
        if (idplant > 0) then
          cropname = cpnm(idplant)
        else
          cropname = "NOCR"
        endif

          if (iscen == 1 .and. isproj == 0) then
          write (28,1000) cropname, j, subnum(j), hruno(j), sb,
     &             nmgt(j), iyr, hru_km(j), (pdvs(ii), ii = 1, itots)
          else if (isproj == 1) then
          write (21,1000) cropname, j, subnum(j), hruno(j),
     &            sb, nmgt(j), iyr, hru_km(j), (pdvs(ii), ii = 1, itots)
          else if (iscen == 1 .and. isproj == 2) then
          write (28,2000) cropname, j, subnum(j), hruno(j), sb,
     &    nmgt(j), iyr, hru_km(j), (pdvs(ii), ii = 1, itots), iyr
          endif
        else
          if (iscen == 1 .and. isproj == 0) then
          write (28,1001) cropname, j, subnum(j), hruno(j), sb,
     &            nmgt(j), iyr, hru_km(j), (pdvas(ii), ii = 1, mhruo)
          else if (isproj == 1) then
          write (21,1001) cropname, j, subnum(j), hruno(j),
     &           sb, nmgt(j), iyr, hru_km(j), (pdvas(ii), ii = 1, mhruo)
          else if (iscen == 1 .and. isproj == 2) then
          write (28,1001) cropname, j, subnum(j), hruno(j), sb,
     &    nmgt(j), iyr, hru_km(j), (pdvas(ii), ii = 1, mhruo), iyr
          endif
        end if
        end if
      end do

      return

 1000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x,
     *e10.5,1x,e10.5,8e10.3,6f10.3)
 2000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x,
     *e10.5,1x,e10.5,5e10.3,6f10.3,1x,i4)
 1001 format (a4,i7,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x,
     *e10.5,1x,e10.5,3e10.3,6f10.3,1x,i4)
      end


      MODULE solrot_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  11:04:15  03/09/06
      SUBROUTINE solrot (NI, NJ, XI, XJ, WJ, WK, KR, E1B, E2A, ENUC, CUTOFF, IB)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(IN) :: NI
      INTEGER, INTENT(IN) :: NJ
      REAL(DOUBLE), DIMENSION(3), INTENT(IN) :: XI
      REAL(DOUBLE), DIMENSION(3), INTENT(IN) :: XJ
      REAL(DOUBLE), DIMENSION(100), INTENT(OUT) :: WJ
      REAL(DOUBLE), DIMENSION(100), INTENT(OUT) :: WK
      INTEGER, INTENT(INOUT) :: KR
      REAL(DOUBLE), DIMENSION(10), INTENT(INOUT) :: E1B
      REAL(DOUBLE), DIMENSION(10), INTENT(INOUT) :: E2A
      REAL(DOUBLE), INTENT(OUT) :: ENUC
      REAL(DOUBLE), INTENT(IN) :: CUTOFF
      INTEGER, INTENT(IN) :: IB
      END SUBROUTINE
      END INTERFACE
      END MODULE


!>-----------------------------------------------------------------------------------------------
!> @brief       NEPTUNE - NPI Ephemeris Propagation Tool with Uncertainty Extrapolation
!!
!> @author      Vitali Braun (VB)
!< @author      Christopher Kebschull (CHK)
!!
!> @date

!!
VB:  18.12.2012 (Geopotential + EOP)

!!
VB:  24.01.2013 (Atmosphere)

!!
VB:  28.02.2013 (Third bodies)

!!
VB:  14.03.2013 (Solar radiation pressure)

!!
VB:  20.04.2013 (Interface/API redesign)

!!
VB:  21.04.2013 (Logfile initialization)

!!
VB:  09.10.2013 (Interface/API redesign)

!!
CHK: 13.11.2013 (updated to use libslam)

!!
VB:  24.01.2016 (Introduced reference frame check in NEPTUNE propagator)

!!
VB:  20.05.2016 (updated to have only statements for all use statements)

!!
VB:  14.06.2016 (removed autoconfiguration, as it is not used)

!!
ChK: 24.12.2017 (using a neptune class now)

!!

!!
!> @details     This is the NEPTUNE (NPI Ephemeris
!!              Propagation Tool with Uncertainty Extrapolation) module.
!!              It is initialized via the routine 'setNeptuneVar' and a subsequent call
!!              to 'init_neptune'. Propagation is done via the routine 'neptune'.
!!
!> @copyright   Institute of Space Systems / TU Braunschweig
!!
!> @anchor      libneptune
!!
!> @todo        create output file for correlation matrix vs. time
!!
!!------------------------------------------------------------------------------------------------
module libneptune

    use slam_astro,             only: initAstroConstants, isAstroInitialized, getEarthRadius, getEarthGeopotentialRadius
    use averaging,              only: setMeanElements
    use slam_astro_conversions, only: rv2coe
    use derivatives,            only: PERT_ALBEDO, PERT_DRAG, PERT_JUPITER, PERT_MANEUVERS, PERT_MARS, &
                                    PERT_MERCURY, PERT_MOON, PERT_NEPTUNE, PERT_OCEAN_TIDES, PERT_SATURN, PERT_SOLID_TIDES, PERT_SRP, PERT_SUN, &
                                    PERT_URANUS, PERT_VENUS, PERT_WIND
    use neptune_error_handling, only: E_INTEGRATION_ABORT, E_MIN_ALTITUDE, E_NEPTUNE_INIT, E_UNSUPPORTED_FRAME, &
                                    E_INVALID_SATELLITE, setNeptuneError
    use slam_error_handling,    only: hasToReturn, isControlled, hasFailed, isSetErrorHandling, E_FILE_NOT_FOUND, WARNING, FATAL, &
                                    E_MISSING_PARAMETER, ERRORS, initErrorHandler, ALL_MSG, getLogfileChannel, &
                                    setLogFileName, getLogFileName, setLogFileChannel, setLogVerbosity, setCliVerbosity, checkIn, checkOut
    use slam_io,                only: SWITCHED_ON, SWITCHED_OFF, SEQUENTIAL, FT_LOG, openFile, cdelimit, LOGFILE, LOG_AND_STDOUT, message, write_progress
    use slam_math,              only: eps3, eps9, eps15, identity_matrix, mag, undefined, rad2deg, cross
    use neptuneClass,           only: Neptune_class
    use neptuneClock,           only: Clock_class
    use neptuneParameters,      only: OPTION_CORRELATION, OPTION_COV_METHOD, OPTION_GEO_MODEL, OPTION_INT_LOGFILE, &
                                    OPTION_OUTPUT, OPTION_PROPS, PAR_CDRAG, PAR_CREFL, PAR_CROSS_SECTION, PAR_INT_ABSEPS, PAR_INT_RELEPS, PAR_INT_COV_STEP, &
                                    PAR_MASS, PROP_CONSTANT, PROP_FILE, C_INITIAL_STATE, C_PAR_EARTH_RADIUS
    use numint,                 only: MAX_RESETS
    use satellite,              only: ORIENT_SPHERE
    use slam_strings,           only: toString
    use slam_time,              only: time_t, gd2mjd, date2longstring, operator(>)
    use slam_types,             only: dp
    use slam_rframes,           only: FRAME_NAME_LENGTH => MAX_ID_LENGTH, getFrameName, REF_FRAME_GCRF
    use slam_orbit_types,       only: state_t, kepler_t, covariance_t

    implicit none

    private

    !========================================================================
    !
    ! PUBLIC elements
    !
    !-------------------------------
    public :: init_neptune                                                      ! initialization
    public :: propagate                                                         ! propagation of state vector and covariance
    public :: propagate_set                                                     ! propagation of state vector, covariance and state error transition matrix

contains

  !========================================================================
  !!
  !>  @anchor     init_neptune
  !!
  !>  @brief      Performs the NEPTUNE initialization
  !>  @author     Vitali Braun
  !!
  !>  @param[in]  neptune         The NEPTUNE class instance
  !>  @param[in]  initial_state   (optional) Initial state vector (state_t)
  !!
  !>  @date

  !!
13.02.2014 (added doxygen header)

  !!
18.02.2014 (added epoch as input parameter)

  !!
23.04.2014 (changed 'initial_state' and 'epoch' to optional parameters)

  !!
14.06.2016 (removed autoconfiguration)

  !!
14.03.2017 (removed epoch input parameter, as no longer used)

  !!

  !!
  !----------------------------------------------------
  integer function init_neptune(neptune,initial_state_in)

    type(Neptune_class)                 :: neptune
    type(state_t),optional,intent(in)   :: initial_state_in

    type(state_t)                       :: initial_state
    character(len=255)                  :: cmess                                ! message string
    character(len=*), parameter :: csubid = "init_neptune"                      ! subroutine id

    integer  :: ierr                                                            ! error flag

    type(time_t)            :: startEpoch, endEpoch, tempStartEpoch, tempEndEpoch

    init_neptune = 0

    !** check whether error handling has been initialized before - if not, NEPTUNE will apply its own scheme...
    if(.not. isSetErrorHandling()) then
      call initErrorHandler(control = 'YES', errAction = 'RETURN', traceback = 'YES')
    end if

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    !-------------------------------------------------------
    !
    !   Initialization procedure
    !
    !--------------------------------
    !
    !   1) Initialize logfile
    !   2) Initialize astrodynamics constants
    !   3) Satellite configuration
    !   4) Initialize perturbation methods and integration parameters
    !   5) Initialize correlation routines
    !   6) Prepare output files
    !
    !--------------------------------------------------------

    !==============================================================
    !
    ! 1) Initialize logfile
    !
    !--------------------------------------------------------
    if(getLogfileChannel() == 0) then !** open logfile
      ierr = setLogfileName("neptune.log")
      ierr = setLogfileChannel(openFile(getLogfileName(), SEQUENTIAL, FT_LOG))
      ierr = setLogVerbosity(ALL_MSG)
      ierr = setCliVerbosity(ERRORS)
    end if

    !==============================================================
    !
    ! 2) Initialize astrodynamical constants
    !
    !----------------------------------------------
    if(.not. isAstroInitialized()) then
      call initAstroConstants(neptune%iopt(OPTION_GEO_MODEL))  ! using selected model
    end if
    !----------------------------------------------

    !==============================================================
    !
    ! 3) Satellite configuration
    !
    !----------------------------------------------
    if(neptune%iopt(OPTION_PROPS) == PROP_CONSTANT) then                        ! cannon ball model

      ! Reseting the satellite at this point as the init_neptune procedure could be called multiple times.
      ! Making sure the new satellite has an initialized surfaces array.
      call neptune%satellite_model%resetObject()

      !** Mass
      if(neptune%isSetMass) then
        neptune%satellite_model%mass  = neptune%ipar(PAR_MASS)
      else
        cmess = "Satellite mass not defined."
        call setNeptuneError(E_INVALID_SATELLITE, FATAL, (/cmess/))
        return
      end if

      !** Drag coefficient
      if(neptune%isSetCdrag) then
        neptune%satellite_model%cdrag = neptune%ipar(PAR_CDRAG)
      else
        cmess = "Drag coefficient not defined."
        call setNeptuneError(E_INVALID_SATELLITE, FATAL, (/cmess/))
        return
      end if

      !** SRP coefficient
      if(neptune%isSetCsrp) then

        neptune%satellite_model%surface(1)%reflSpec = neptune%ipar(PAR_CREFL) - 1.d0             ! the specular reflectivity coefficient is saved,
                                                                                ! while the SRP coefficient is used in a cannon-ball model
        neptune%satellite_model%surface(1)%reflDiff = 0.d0                                       ! no diffuse reflectivity in this case

      else
        cmess = "SRP coefficient not defined."
        call setNeptuneError(E_INVALID_SATELLITE, FATAL, (/cmess/))
        return
      end if

      !** Area
      if(neptune%isSetArea) then
        neptune%satellite_model%surface(1)%area = neptune%ipar(PAR_CROSS_SECTION)                ! in km**2
      else
        cmess = "Cross-section area not defined."
        call setNeptuneError(E_INVALID_SATELLITE, FATAL, (/cmess/))
        return
      end if

      !** normal angle (not required for sphere, but has to be initialised...)
      neptune%satellite_model%surface(1)%normal_angle(:) = 0.d0

      neptune%satellite_model%surface(1)%orientation = ORIENT_SPHERE
      neptune%satellite_model%surface(1)%id = 1
      neptune%satellite_model%nsurfaces = 1

      call neptune%satellite_model%initObject()

      if(hasFailed()) return

    else if(neptune%iopt(OPTION_PROPS) == PROP_FILE) then  ! read surfaces definition file

      call neptune%satellite_model%initObject()
      call neptune%satellite_model%readSurfaceDefinitionFile(neptune%getInputPath())

    end if

    !** initial orbit
    if(present(initial_state_in)) then
      initial_state = initial_state_in
      ierr = neptune%setNeptuneVar("INITIAL_STATE", initial_state)
    end if

    !** check for start and end epoch being available
    call neptune%getStartEpoch(tempStartEpoch, ierr)
    if(ierr /= 0) then  ! epoch missing
      call setNeptuneError(E_MISSING_PARAMETER, FATAL, (/'startEpoch (provide via setNeptuneVar)'/))
      return
    end if

    call neptune%getEndEpoch(tempEndEpoch, ierr)
    if(ierr /= 0) then  ! epoch missing
      call setNeptuneError(E_MISSING_PARAMETER, FATAL, (/'endEpoch - (provide via setNeptuneVar)'/))
      return
    end if

    !** For the following routines, it is required to have startEpoch < endEpoch.
    !   Therefore, check if there is backward propagation...
    if(tempEndEpoch > tempStartEpoch) then
        endEpoch   = tempEndEpoch
        startEpoch = tempStartEpoch
    else
        endEpoch   = tempStartEpoch
        startEpoch = tempEndEpoch
    end if

    !============================================================
    !
    ! 4) Initialize perturbation methods
    !----------------------------------------------

    ! 4-1) Geopotential

    call neptune%gravity_model%initGravityPotential(                &
                               neptune%getDataPath(),               & ! <-- CHR path of coefficients data file
                               neptune%iopt(OPTION_GEO_MODEL)       & ! <-- INT model to be used
                             )

    ! 4-2) Earth orientation parameters
    if(neptune%reduction%getEopFlag()) then
      call neptune%reduction%initEOP(       &
                    neptune%getDataPath())
    end if

    ! 4-3) Earth's atmosphere

    if(neptune%derivatives_model%getPertSwitch(PERT_DRAG)) then
      if(neptune%derivatives_model%getPertSwitch(PERT_WIND)) then  ! wind only switched on, if drag perturbations are considered
        call neptune%atmosphere_model%setHorizontalWind(.true.)
      else
        call neptune%atmosphere_model%setHorizontalWind(.false.)
      end if

      call neptune%atmosphere_model%initAtmosphere( &
                          neptune%getDataPath())
      if(hasFailed()) return

    end if

    ! 4-4) Perturbations requiring Sun's or Moon's position

    if(neptune%derivatives_model%getPertSwitch(PERT_MOON)        .or. &
       neptune%derivatives_model%getPertSwitch(PERT_SUN)         .or. &
       neptune%derivatives_model%getPertSwitch(PERT_MERCURY)     .or. &
       neptune%derivatives_model%getPertSwitch(PERT_VENUS)       .or. &
       neptune%derivatives_model%getPertSwitch(PERT_JUPITER)     .or. &
       neptune%derivatives_model%getPertSwitch(PERT_SATURN)      .or. &
       neptune%derivatives_model%getPertSwitch(PERT_URANUS)      .or. &
       neptune%derivatives_model%getPertSwitch(PERT_NEPTUNE)     .or. &
       neptune%derivatives_model%getPertSwitch(PERT_MARS)        .or. &
       neptune%derivatives_model%getPertSwitch(PERT_ALBEDO)      .or. &
       neptune%derivatives_model%getPertSwitch(PERT_SRP)         .or. &
       neptune%derivatives_model%getPertSwitch(PERT_SOLID_TIDES) .or. &
       neptune%derivatives_model%getPertSwitch(PERT_OCEAN_TIDES) .or. &
       neptune%iopt(OPTION_PROPS) == PROP_FILE ) then     ! also if surface definition is used, as Sun-oriented surfaces may be used

      call neptune%solarsystem_model%initSolarSystem(   &
                                neptune%getDataPath(),  &
                                'DE-421',               &
                                endEpoch                &
                                )
      if(hasFailed()) return
    end if

    ! 4-5) Albedo
    if(neptune%derivatives_model%getPertSwitch(PERT_ALBEDO)) then
      call neptune%radiation_model%initAlbedo()
      if(hasFailed()) return
    end if

    ! 4-6) Tides
    if(neptune%derivatives_model%getPertSwitch(PERT_SOLID_TIDES) .or. neptune%derivatives_model%getPertSwitch(PERT_OCEAN_TIDES)) then
      call neptune%tides_model%initTides()
      if(hasFailed()) return
    end if

    ! 4-7) Maneuvers
    ! This might be a bit un-nice: IF maneuvers have been initialized using the API, this call is performed but actually "ignored"
    if(neptune%derivatives_model%getPertSwitch(PERT_MANEUVERS)) then
      call neptune%manoeuvres_model%init_maneuvers(neptune%getInputPath(), startEpoch, endEpoch)
      if(hasFailed()) return
    end if

    ! 4-8) numerical integration parameters
    if(neptune%flag_init_tolerances(1)) then    !** relative tolerance
      call neptune%numerical_integrator%setIntegrationTolerance( trel = neptune%ipar(PAR_INT_RELEPS))
      if(hasFailed()) return
    end if

    if(neptune%flag_init_tolerances(2)) then !** absolute tolerance
      call neptune%numerical_integrator%setIntegrationTolerance( tabs = neptune%ipar(PAR_INT_ABSEPS))
      if(hasFailed()) return
    end if

    !===================================================================
    !
    ! 5) Covariance/correlation matrix initialization
    !
    !---------------------------------------------------------------
    if(neptune%iopt(OPTION_CORRELATION) == SWITCHED_ON) then
      call neptune%correlation_model%initCorrelation(neptune%gravity_model)
      if(hasFailed()) return
    end if

    ! 5.1) set covariance matrix integration step size
    call neptune%numerical_integrator%setCovarianceIntegrationStep(neptune%ipar(PAR_INT_COV_STEP))
    if(hasFailed()) return

    ! 5.2) set covariance matrix integration method
    call neptune%numerical_integrator%setCovarianceIntegrationMethod(neptune%iopt(OPTION_COV_METHOD))
    if(hasFailed()) return

    ! 5.3) write general header (ALSO FOR OTHER OUTPUT FILES)
    call neptune%output%write_header(neptune%gravity_model,             &
                                        neptune%atmosphere_model,       &
                                        neptune%manoeuvres_model,       &
                                        neptune%radiation_model,        &
                                        neptune%satellite_model,        &
                                        neptune%thirdbody_model,        &
                                        neptune%numerical_integrator,   &
                                        neptune%derivatives_model,      &
                                        neptune%version_model,          &
                                        neptune%reduction,              &
                                        neptune%correlation_model,      &
                                        0,                              &
                                        "")
    if(hasFailed()) return

    ! 5.4) Open integration logfile (if required)
    if(neptune%iopt(OPTION_INT_LOGFILE) == SWITCHED_ON) then

      call neptune%numerical_integrator%setIntegrationLogfile('ON')
      if(hasFailed()) return

      !** write specific information
      call neptune%output%write_header(neptune%gravity_model,                           &
                        neptune%atmosphere_model,                                       &
                        neptune%manoeuvres_model,                                       &
                        neptune%radiation_model,                                        &
                        neptune%satellite_model,                                        &
                        neptune%thirdbody_model,                                        &
                        neptune%numerical_integrator,                                   &
                        neptune%derivatives_model,                                      &
                        neptune%version_model,                                          &
                        neptune%reduction,                                              &
                        neptune%correlation_model,                                      &
                        neptune%numerical_integrator%getIntegrationLogfileChannel(),    &
                        neptune%numerical_integrator%getIntegrationLogfileName())
      if(hasFailed()) return

    end if

    neptune%neptuneInitialized = .true.

    !** done!
    if(isControlled()) then
      call checkOut(csubid)
    end if

  end function init_neptune

  !========================================================================
  !
  !>  @anchor     propagate
  !!
  !>  @brief      NEPTUNE propagation routine
  !<  @author     Vitali Braun
  !!
  !>  @date

  !!
 04.07.2013 (documentation started)

  !!
 30.07.2013 (added correlation matrix handling)

  !!
 06.02.2014 (added getData functionality)

  !!
 25.11.2014 (changed 'reset' handling, so that NEPTUNE really stops, if a step can not be passed)

  !!
 24.01.2016 (added reference frame check for input)

  !!
 14.06.2016 (backward propagation now working - but testing still needed)

  !!

  !!
  !! @details     This routine is called for the propagation of the state
  !!              vector and the covariance matrix, after NEPTUNE has been
  !!              initialized by calling init_neptune.
  !!
  !> @param[in]   neptune     the neptune class
  !> @param[in]   state_in    input state vector (GCRF expected, but checked)
  !> @param[in]   covar_in    input covariance matrix (GCRF expected, but checked)
  !> @param[in]   epoch       propagation start(1) and end(2) epoch
  !> @param[out]  state_out   output state vector (GCRF)
  !> @param[out]  covar_out   covariance output matrix (GCRF)
  !> @param[in]   flag_reset  resetting the numerical integrator manually
  !!
  !> @todo        Get averaging right
  !!
  !!----------------------------------------------------
  subroutine propagate(          &
                      neptune,   &
                      state_in,  &   ! <-- TYP    input state vector (GCRF)
                      covar_in,  &   ! <-- TYP    input covariance matrix (GCRF)
                      epoch,     &   ! <-- TYP    propagation start and end epoch [epoch(1) : start epoch, epoch(2) : end epoch]
                      state_out, &   ! --> TYP    output state vector
                      covar_out, &   ! --> TYP    output covariance matrix
                      flag_reset &   ! <-- LOG    reset flag
                    )
      implicit none

      !** interface
      !------------------------------------------------------
      type(Neptune_class)        ,intent(inout)  :: neptune
      type(state_t),              intent(in)      :: state_in
      type(covariance_t),         intent(in)      :: covar_in
      type(time_t), dimension(2), intent(in)      :: epoch
      logical,                    intent(in)      :: flag_reset

      type(state_t),              intent(out)     :: state_out
      type(covariance_t),         intent(out)     :: covar_out
      !------------------------------------------------------
      type(covariance_t)                          :: set_in
      type(covariance_t)                          :: set_out

      call identity_matrix(set_in%elem)

      call propagate_set(neptune,  &
                        state_in,  &   ! <-- TYP    input state vector (GCRF)
                        covar_in,  &   ! <-- TYP    input covariance matrix (GCRF)
                        set_in,    &   ! <-- TYP    input set matrix
                        epoch,     &   ! <-- TYP    propagation start and end epoch [epoch(1) : start epoch, epoch(2) : end epoch]
                        state_out, &   ! --> TYP    output state vector
                        covar_out, &   ! --> TYP    output covariance matrix
                        set_out,   &   ! --> TYP    output set matrix
                        flag_reset &   ! <-- LOG    reset flag)
                      )

  end subroutine propagate

  !========================================================================
  !
  !>  @anchor     propagate
  !!
  !>  @brief      NEPTUNE propagation routine
  !<  @author     Vitali Braun
  !!
  !>  @date

  !!
 04.07.2013 (documentation started)

  !!
 30.07.2013 (added correlation matrix handling)

  !!
 06.02.2014 (added getData functionality)

  !!
 25.11.2014 (changed 'reset' handling, so that NEPTUNE really stops, if a step can not be passed)

  !!
 24.01.2016 (added reference frame check for input)

  !!
 14.06.2016 (backward propagation now working - but testing still needed)

  !!

  !!
  !! @details     This routine is called for the propagation of the state
  !!              vector and the covariance matrix, after NEPTUNE has been
  !!              initialized by calling init_neptune.
  !!
  !> @param[in]   neptune     the neptune class
  !> @param[in]   state_in    input state vector (GCRF expected, but checked)
  !> @param[in]   covar_in    input covariance matrix (GCRF expected, but checked)
  !> @param[in]   epochs      propagation start(1) and end(last) epoch
  !> @param[out]  state_out   output state vector (GCRF)
  !> @param[out]  covar_out   covariance output matrix (GCRF)
  !> @param[in]   flag_reset  resetting the numerical integrator manually
  !!
  !> @todo        Get averaging right
  !!
  !!----------------------------------------------------
  subroutine propagate_set(      &
                      neptune,   &
                      state_in,  &   ! <-- TYP    input state vector (GCRF)
                      covar_in,  &   ! <-- TYP    input covariance matrix (GCRF)
                      set_in,    &   ! <-- TYP    input set matrix
                      epochs,    &   ! <-- TYP    propagation start and end epoch [epoch(1) : start epoch, epoch(last) : end epoch]
                      state_out, &   ! --> TYP    output state vector
                      covar_out, &   ! --> TYP    output covariance matrix
                      set_out,   &   ! --> TYO    output set matrix
                      flag_reset &   ! <-- LOG    reset flag
                    )

    implicit none

    !** interface
    !------------------------------------------------------
    type(Neptune_class),        intent(inout)   :: neptune
    type(state_t),              intent(in)      :: state_in
    type(covariance_t),         intent(in)      :: covar_in
    type(covariance_t),         intent(in)      :: set_in
    type(time_t), dimension(:), intent(in)      :: epochs
    logical,                    intent(in)      :: flag_reset

    type(state_t),              intent(out)     :: state_out
    type(covariance_t),         intent(out)     :: covar_out
    type(covariance_t),         intent(out)     :: set_out
    !------------------------------------------------------

    character(len=*), parameter         :: csubid = "neptune"
    character(len=2)                    :: cresets                              ! number of resets in integration routine
    character(len=FRAME_NAME_LENGTH)    :: frameName                            ! reference frame name
    integer                 :: ierr                                             ! error flag
    integer                 :: nresets                                          ! number of subsequent resets for one integration step
    integer                 :: reset                                            ! initialisation flag
    integer                 :: otype                                            ! characterising orbit type

    logical                 :: flag_backward                                    ! backward propagation flag
    logical                 :: flag_exit                                        ! exit flag

    real(dp),dimension(6,6) :: corrMat                                          ! correlation matrix
    real(dp),dimension(6,6) :: cumSet                                           ! cumulated state transition matrix
    real(dp)                :: dtmp                                             ! auxiliary
    real(dp)                :: delta_time                                       ! step size actually used for each propagation step
    real(dp)                :: end_epoch_sec                                    ! end epoch in seconds (MJD)
    real(dp),dimension(:),allocatable :: step_epochs_sec                        ! intermediate epochs in seconds (MJD)
    real(dp)                :: lastPropCounter                                  ! saving the last prop_counter for which output has taken place
    real(dp)                :: lastPropCounterSuccess                           ! saving the last prop_counter for which a step was successful
    real(dp)                :: prop_counter                                     ! propagation time counter in seconds
    real(dp)                :: request_time                                     ! requested time in numerical integration loop
    real(dp)                :: propCounterAtReset                               ! propCounter at last reset - required to prevent infinite loops
    real(dp),dimension(6,6) :: set                                              ! state error transition matrix
    real(dp)                :: start_epoch_sec                                  ! start epoch in seconds (MJD)
    type(kepler_t)          :: kep                                              ! mean kepler elements for correlation matrix computation
    type(state_t)           :: last_state_out                                   ! saving the last state vector which has been written to output
    type(Clock_class)       :: nep_clock                                        ! scheduling/clock unit to control the stepsize-related actions
    integer                 :: step_counter
    integer                 :: i_epoch
    logical                 :: suppressed_output                                ! Indicates that output and storage should not be triggered due to an intermediate call to the numerical integrator
    logical                 :: intermediate_integrator_call                     ! Indicates that an intermediate call to the integrator is performed
    real(dp)                :: manoeuvre_change_counter                           ! Is the start or end epoch of a manoeuvre
    real(dp)                :: restored_request_time                            ! Requested time before the intermediate step got necessary
    logical                 :: force_no_interpolation
    real(dp)                :: upcoming_maneuver_epoch_mjd

    restored_request_time = 0.d0
    prop_counter = 0.0d0
    propCounterAtReset = 0.0d0
    lastPropCounterSuccess = 0.0d0

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    !** check if initialization has been performed
    if(.not. neptune%neptuneInitialized) then
      call setNeptuneError(E_NEPTUNE_INIT, FATAL)
      return
    end if

    !============================================================
    !
    !   Input check
    !
    !--------------------------------------------------

    ! check state vector reference frame (should be GCRF, if not: add conversions here...)
    if(state_in%frame /= REF_FRAME_GCRF) then
      ! if necessary, introduce conversions here for other frames - at the moment it only works for GCRF, therefore an exception is thrown
      ! try first, if frame is a known one:
      frameName = getFrameName(state_in%frame)
      if(hasFailed()) return ! unknown frame
        call setNeptuneError(E_UNSUPPORTED_FRAME, FATAL, (/getFrameName(state_in%frame)/))
        return
      end if

    ! check covariance matrix reference frame (should be GCRF, if not: add conversions here...)
    if(covar_in%frame /= REF_FRAME_GCRF) then
      ! if necessary, introduce conversions here for other frames - at the moment it only works for GCRF, therefore an exception is thrown
      ! try first, if frame is a known one
      frameName = getFrameName(covar_in%frame)
      if(hasFailed()) return ! unknown frame
        call setNeptuneError(E_UNSUPPORTED_FRAME, FATAL, (/getFrameName(covar_in%frame)/))
        return
      end if

    !** check for state vector being an orbit actually
    if(mag(state_in%r) < getEarthRadius()) then
      call setNeptuneError(E_MIN_ALTITUDE, FATAL)
      return
    end if

    ! now set eventually missing input parameters
    ierr = neptune%setNeptuneVar(C_INITIAL_STATE, state_in)
    ierr = neptune%setNeptuneVar(C_PAR_EARTH_RADIUS, toString(getEarthGeopotentialRadius()))

    !** dump all inputs
    !call neptune%dump_input("neptune_dump_file.out")

    ! this only happens, if called with dump flag (checked in the routine)
    !call neptune%write_input_to_dump()

    ! prepare output files if requested (checked in the routine)
    call neptune%output%prepare_output(neptune%gravity_model,   &
                            neptune%atmosphere_model,           &
                            neptune%manoeuvres_model,           &
                            neptune%radiation_model,            &
                            neptune%satellite_model,            &
                            neptune%solarsystem_model,          &
                            neptune%thirdbody_model,            &
                            neptune%numerical_integrator,       &
                            neptune%derivatives_model,          &
                            neptune%version_model,              &
                            neptune%reduction,                  &
                            neptune%correlation_model)

    ! init progress writing (if requested)
    if(neptune%has_to_write_progress()) call write_progress(neptune%get_progress_file_name(), -1.d0, 0.d0)  ! step parameter doesn't matter here

    nresets = 0

    ! set start and end epoch - we work with an offset here, where
    ! the start epoch is at 0 seconds and the end epoch reflects the propagation span
    call neptune%setStartEpoch(epochs(1))
    start_epoch_sec = 0.d0 ! epoch(1)%mjd*86400.d0 ! in seconds

    call neptune%setEndEpoch(epochs(size(epochs)))
    end_epoch_sec   = (epochs(size(epochs))%mjd-epochs(1)%mjd)*86400.d0 ! in seconds

    !============================================================
    !
    !   Initialise propagation time counter
    !
    !------------------------------------------------------------
    if (size(epochs) > 2) then
      if (allocated(step_epochs_sec)) deallocate(step_epochs_sec)
      allocate(step_epochs_sec(size(epochs)-1))
      do i_epoch = 2, size(epochs)
        ! Handle intermediate steps
        step_epochs_sec(i_epoch-1) = (epochs(i_epoch)%mjd-epochs(i_epoch-1)%mjd)*86400.d0 ! in seconds
      end do
      !write (*,*) step_epochs_sec
      nep_clock = Clock_class(start_epoch_sec, end_epoch_sec, step_epochs_sec)
    else
      nep_clock = Clock_class(start_epoch_sec, end_epoch_sec)
    end if
    ! Initialize the counters
    call nep_clock%init_counter(neptune)

    prop_counter = start_epoch_sec

    !=====================================================
    !
    ! Consider backward propagation
    !
    !---------------------------------------------
    if(epochs(2)%mjd < epochs(1)%mjd) then
      flag_backward = .true.
    else
      flag_backward = .false.
    end if

    !============================================================
    !
    !   Initialise covariance matrix propagation
    !
    !--------------------------------------------------
    if(neptune%numerical_integrator%getCovariancePropagationFlag()) then

      cumSet = set_in%elem
      !call identity_matrix(cumSet)  ! initial state error transition matrix is the unity matrix
      call neptune%numerical_integrator%resetCountSetMatrix()    ! the counter for the number of calls to the getStateTransitionMatrix routine is being reset

      !** correlation matrix
      if(neptune%correlation_model%getNoisePropagationFlag()) then
        !** provide mean elements for correlation computations (HAS TO BE ADAPTED LATER ON!!)
        !--------------------------------------------------------------------------------------
        call rv2coe(state_in, kep, otype) ! <-- ADAPT here
        call setMeanElements(kep)
        !-------------------------------------------------------
        call message(' - Computing correlation matrix...', LOG_AND_STDOUT)
        call neptune%correlation_model%updateCorrelationMatrix(     &
                                        neptune%gravity_model,      &
                                        state_in%r,                 &
                                        abs(end_epoch_sec-start_epoch_sec))
      end if

    end if

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

    !** set integrator initialisation flag
    if(flag_reset) then
      reset = 1

      !** in case of reset - also reset stored array index in neptuneGet module!
      if(neptune%getStoreDataFlag()) then
        call neptune%resetStoreCounter()
      end if

      ! reset also the count of subroutine calls to the integrator
      call neptune%numerical_integrator%resetCountIntegrator()

    else
      reset = 0
    end if

    !** initialise output state
    state_out = state_in
    covar_out = covar_in
    set_out = set_in

    if(neptune%has_to_write_progress()) call write_progress(neptune%get_progress_file_name(), 0.d0, neptune%get_progress_step())
    step_counter = 0
    suppressed_output = .false.
    intermediate_integrator_call = .false.
    restored_request_time = request_time
    do
      step_counter = step_counter + 1
      ! Check exit clause
      flag_exit = nep_clock%has_finished(prop_counter)

      !===============================================
      !
      ! Output if requested
      !
      !---------------------------------------------
      ! The output is suppressed when an intermediate step is needed
      ! (e.g. for start or end of a manoeuvre, which needs an exact start and end epoch and a reset of the integrator)
      if((nep_clock%has_to_write_output() .and. .not. suppressed_output) .or. flag_exit) then
        ! make sure, that the final result is also written to output
        if(neptune%output%get_output_switch()) then
          call neptune%output%output(neptune%gravity_model, &
                            neptune%atmosphere_model,       &
                            neptune%manoeuvres_model,       &
                            neptune%radiation_model,        &
                            neptune%satellite_model,        &
                            neptune%solarsystem_model,      &
                            neptune%thirdbody_model,        &
                            neptune%tides_model,            &
                            neptune%numerical_integrator,   &
                            neptune%derivatives_model,      &
                            neptune%reduction,              &
                            prop_counter,                   &
                            state_out,                      &
                            covar_out)
          if(hasFailed()) then    ! error occurred during output - abort propagation
            call neptune%output%close_open_files(neptune%numerical_integrator)
            return
          end if
          last_state_out  = state_out
          lastPropCounter = prop_counter
          call nep_clock%toggle_output_flag()
        end if

        if(neptune%getStoreDataFlag()) then
          dtmp = epochs(1)%mjd + prop_counter/86400.d0
          call neptune%storeData(state_out%r, state_out%v, dtmp)
          ! store covariance matrix data if requested
          if(neptune%numerical_integrator%getCovariancePropagationFlag()) then
            call neptune%storeSetData(cumSet, dtmp)
            call neptune%storeCovData(covar_out%elem, dtmp)
          end if
          last_state_out   = state_out
          lastPropCounter  = prop_counter
        end if
        call nep_clock%toggle_output_flag()
      end if
      !---------------------------------------------

      if(flag_exit) exit

      ! Check if the previous call was an intermediate integrator call (due to a manoeuvre start or end)
      if (intermediate_integrator_call) then
        ! ... if so we will restore the original request time
        request_time = restored_request_time
      else
        ! No previous intermediate call - we can just proceed as planned
        request_time = nep_clock%get_next_step(neptune,prop_counter)
        ! Save the current requested time in case we determine that an intermediate call must be done due to an immenant manoeuvre start or end
        restored_request_time = request_time
        ! Create a point to restore to when the propagation fails
        last_state_out   = state_out
        lastPropCounter  = prop_counter
      end if

      ! Check whether there is a manoeuvre change (start or end)
      force_no_interpolation = .false.
      neptune%manoeuvres_model%ignore_maneuver_start = .false.
      suppressed_output = .false.
      intermediate_integrator_call = .false.
      if (neptune%derivatives_model%getPertSwitch(PERT_MANEUVERS)) then

        !call message(' Maneuver change at '//toString(epochs(1)%mjd + manoeuvre_change_counter/86400.d0)//' ('//toString(manoeuvre_change_counter)//')', LOG_AND_STDOUT)

        ! Reset when we are starting into the new maneuver or no-maneuver interval
        if (abs(prop_counter - manoeuvre_change_counter) < epsilon(1.d0)) then
          reset = 1
          !force_no_interpolation = .true.
          ! reset also the count of subroutine calls to the integrator
          call neptune%numerical_integrator%resetCountIntegrator()
          call message(' - Performing reset of intergator for upcoming maneuver '//toString(epochs(1)%mjd + manoeuvre_change_counter/86400.d0)//' ('//toString(manoeuvre_change_counter)//')', LOGFILE)
        end if

        ! Get the next manoeuvre change epoch
        upcoming_maneuver_epoch_mjd = neptune%manoeuvres_model%get_upcoming_manoeuvre_change_epoch(epochs(1)%mjd + prop_counter/86400.d0)
        if (upcoming_maneuver_epoch_mjd > 0.d0) then
          manoeuvre_change_counter = (upcoming_maneuver_epoch_mjd - epochs(1)%mjd) * 86400.d0
          !call message(' New maneuver change at: '//toString(epochs(1)%mjd + manoeuvre_change_counter/86400.d0)//' ('//toString(manoeuvre_change_counter)//')', LOG_AND_STDOUT)
          ! Check whether the manoeuvre change is more immenent than the step proposed
          if (.not. flag_backward .and. (manoeuvre_change_counter < request_time .and. manoeuvre_change_counter > prop_counter) &
            .or. flag_backward .and. (manoeuvre_change_counter > request_time .and. manoeuvre_change_counter < prop_counter)) then
            if (abs(manoeuvre_change_counter - request_time) > epsilon(1.d0)) then
              ! The manoeuvre_change_counter does not coincide with a storage and output epoch - surpress the output!
              suppressed_output = .true.
              call message(' - Suppressing intermediate integrator output ', LOGFILE)
            end if
            ! Override the request time with the up coming manoeuvre start or end epoch
            request_time = manoeuvre_change_counter
            intermediate_integrator_call = .true.
            force_no_interpolation = .true.
            neptune%manoeuvres_model%ignore_maneuver_start = .true.
            call message(' - Adding intermediate integrator call for planned maneuver at '//toString(epochs(1)%mjd + request_time/86400.d0)//' ('//toString(request_time)//')', LOGFILE)
          end if
        end if
      end if

      !call message(' Going into integrator loop at '//toString(epochs(1)%mjd + prop_counter/86400.d0)//'  ('//toString(prop_counter)//')', LOG_AND_STDOUT)
      !call message(' prop counter: '//toString(prop_counter)//' request_time: '//toString(request_time)//' difference: '//toString(prop_counter - request_time), LOG_AND_STDOUT)

      !====================================================================================
      !
      ! Integration of position, velocity and state error transition matrix
      !
      !--------------------------------------------------------------------------------
      do

        if (neptune%derivatives_model%getPertSwitch(PERT_MANEUVERS)) then
          if (upcoming_maneuver_epoch_mjd > 0.d0) then
            ! Reset when the timestep of the integrator is greater than
            if (.not. flag_backward .and. (manoeuvre_change_counter < (prop_counter + neptune%numerical_integrator%get_current_step_size()) .and. manoeuvre_change_counter > prop_counter) &
            .or. flag_backward .and. (manoeuvre_change_counter > (prop_counter - neptune%numerical_integrator%get_current_step_size()) .and. manoeuvre_change_counter < prop_counter)) then
              reset = 1
              force_no_interpolation = .true.
              ! reset also the count of subroutine calls to the integrator
              call neptune%numerical_integrator%resetCountIntegrator()
              call message(' - Performing reset of intergator for upcoming maneuver due to time step size '//toString(epochs(1)%mjd + manoeuvre_change_counter/86400.d0)//' ('//toString(manoeuvre_change_counter)//')', LOG_AND_STDOUT)
            end if
          end if
        end if

        call neptune%numerical_integrator%integrateStep(         &
                            neptune%gravity_model,               &              ! <->  TYPE  Gravity model
                            neptune%atmosphere_model,            &              ! <->  TYPE  Atmosphere model
                            neptune%manoeuvres_model,            &              ! <->  TYPE  Manoeuvres model
                            neptune%radiation_model,             &              ! <->  TYPE  Radiation model
                            neptune%satellite_model,             &              ! <->  TYPE  Satellite  model
                            neptune%solarsystem_model,           &              ! <->  TYPE  Solarsysten model
                            neptune%thirdbody_model,             &              ! <->  TYPE  Third body model
                            neptune%tides_model,                 &              ! <->  TYPE  Tides model
                            neptune%derivatives_model,           &              ! <->  TYPE  Derivatives model
                            neptune%reduction,                   &              ! <->  TYPE  Reduction
                            request_time,                        &              ! <--  DBL   requested time (s)
                            force_no_interpolation,              &              ! <--  LOGI  indicates no interpolation => perfect last step for big changes in acceleration (i.e. maneuvers)
                            prop_counter,                        &              ! <--> DBL   current time (s)
                            state_out%r,                         &              ! <--> DBL() radius vector (km)
                            state_out%v,                         &              ! <--> DBL() velocity vector (km/s)
                            reset,                               &              ! <--> INT   reset flag
                            delta_time                           &              ! -->  DBL   propagated time (s)
                          )

        ! progress output immediately after integration step
        if(neptune%has_to_write_progress()) then
            dtmp = abs(prop_counter - start_epoch_sec)/abs(end_epoch_sec - start_epoch_sec)
            call write_progress(neptune%get_progress_file_name(), dtmp, neptune%get_progress_step())
        end if

        if(hasFailed()) then
          call neptune%output%close_open_files(neptune%numerical_integrator)
          return
        end if

        if(reset == 1) then     ! in case of a reset the last output state has to be re-established,
                                ! as the original state_out is overwritten after each call
          nresets            = nresets + 1
          propCounterAtReset = prop_counter

          if(nresets == MAX_RESETS) then    ! cancel execution if 'caught' within one step
            write(cresets,'(i2)') MAX_RESETS
            call setNeptuneError(E_INTEGRATION_ABORT, FATAL, (/cresets/))
            return
          end if

          if(neptune%output%get_output_switch() .or. neptune%getStoreDataFlag()) then    ! this has only to be done in a mode, where output is requested...
            if((.not. flag_backward .and. (lastPropCounterSuccess < lastPropCounter)) .or. &
               (      flag_backward .and. (lastPropCounterSuccess > lastPropCounter))) then
              ! This is the usual case when the intergator cannot go on and needs a valid state to restart from.
              state_out    = last_state_out
              prop_counter = lastPropCounter
            else if ((.not. flag_backward .and. (prop_counter > request_time)) .or. &
                    (       flag_backward .and. (prop_counter < request_time))) then
              ! This case may happen when the integrator oversteps the requested time
              !  and usually would start interpolation. Though, due to integration issues
              !  he never gets to the point of interpolation but sets the prop_counter anyway.
              !  This leads to an invalid state, which is also written to output at a time,
              !  which was not even requested.
              state_out    = last_state_out
              prop_counter = lastPropCounter
            end if
          end if
        else if((.not. flag_backward .and. (prop_counter > propCounterAtReset)) .or. &
                (      flag_backward .and. (prop_counter < propCounterAtReset))) then  ! reset 'nresets' flag
          nresets = 0
          lastPropCounterSuccess = prop_counter
        end if

        ! Exit the integration loop when the desired time is reached
        if (intermediate_integrator_call) then
          if (abs(prop_counter - request_time) < epsilon(1.0d0)) exit
        else
          if(nep_clock%has_finished_step(prop_counter)) exit
        end if

      end do
      !---------------------------------------------------------------------------------------------------------

      nresets = 0   ! reset the counter as step was successful

      !===========================================================================
      !
      ! Update of state error transition matrix and computation of covariance
      ! matrix for output
      !
      !---------------------------------------------------------------------------
      if(neptune%numerical_integrator%getCovariancePropagationFlag() &
        .and. nep_clock%has_to_update_covariance()) then
          call neptune%numerical_integrator%getStateTransitionMatrix(           &
                                       neptune%gravity_model,                   & ! <--> TYPE Gravity model
                                       neptune%atmosphere_model,                & ! <--> TYPE Atmosphere model
                                       neptune%manoeuvres_model,                & ! <--> TYPE Manoeuvres model
                                       neptune%radiation_model,                 & ! <--> TYPE Radiation model
                                       neptune%satellite_model,                 & ! <--> TYPE Satellite model
                                       neptune%solarsystem_model,               & ! <--> TYPE Solarsystem model
                                       neptune%thirdbody_model,                 & ! <--> TYPE Third body model
                                       neptune%tides_model,                     & ! <--> TYPE Tides model
                                       neptune%derivatives_model,               & ! <->  TYPE Atmosphere model
                                       neptune%reduction,                       & ! <->  TYPE Reduction
                                       state_out%r,                             & ! <--  DBL() radius vector (km)
                                       state_out%v,                             & ! <--  DBL() velocity vector (km/s)
                                       request_time,                            & ! <--  DBL   requested time
                                       set                                      & ! <--> DBL() state error transition matrix
                                     )
          if(hasFailed()) return

          !** cumulate state transition matrix
          cumSet = matmul(set,cumSet)
          set_out%elem = cumSet

          !** compute new covariance matrix for given time
          covar_out%elem = matmul(matmul(cumSet,covar_in%elem),transpose(cumSet))
          if(neptune%correlation_model%getNoisePropagationFlag()) then
              corrMat                 = neptune%correlation_model%getCorrelationMatrix(request_time)
              covar_out%elem(1:6,1:6) = covar_out%elem(1:6,1:6) + corrMat
          end if
          call nep_clock%toggle_cov_update_flag()

      else if(neptune%numerical_integrator%getCovariancePropagationFlag() &
        .and. nep_clock%has_to_save_covariance()) then
          call neptune%numerical_integrator%save_covariance_state(state_out, request_time)
      end if
    end do

    !** close open files
    call neptune%output%close_open_files(neptune%numerical_integrator)

    !** done!
    if(isControlled()) then
      call checkOut(csubid)
    end if
    return

  end subroutine propagate_set

end module libneptune


!OPTION! -cont -msg o
!! this command should fix the problem of copying arrays in a subroutine call
!>
!!AD: Interface between the les_phy_interface and various turbulence schems suitable
!!    for LES. At present it only has classical Smagorinsky scheme.
!!
!! @author Kristina Froehlich, DWD, Offenbach (2010-01-25)
!!
!! @par Revision History
!! Initial Kristina Froehlich, DWD, Offenbach (2010-01-25)
!! Modified by Anurag Dipankar, MPIM (2013-07-01)
!!
!! @par Copyright and License
!!
!! This code is subject to the DWD and MPI-M-Software-License-Agreement in
!! its most recent form.
!! Please see the file LICENSE in the root of the source tree for this code.
!! Where software is supplied by third parties, it is indicated in the
!! headers of the routines.
!!

!----------------------------
#include "omp_definitions.inc"
!----------------------------

MODULE mo_les_turb_interface

  USE mo_kind,                 ONLY: wp
  USE mo_exception,            ONLY: message
  USE mo_model_domain,         ONLY: t_patch
  USE mo_intp_data_strc,       ONLY: t_int_state
  USE mo_impl_constants,       ONLY: min_rlcell_int, ismag
  USE mo_impl_constants_grf,   ONLY: grf_bdywidth_c
  USE mo_loopindices,          ONLY: get_indices_c
  USE mo_nonhydro_types,       ONLY: t_nh_prog, t_nh_diag, t_nh_metrics
  USE mo_nwp_phy_types,        ONLY: t_nwp_phy_diag, t_nwp_phy_tend
  USE mo_nwp_lnd_types,        ONLY: t_lnd_prog, t_lnd_diag
  USE mo_run_config,           ONLY: msg_level, iqv, iqc
  USE mo_atm_phy_nwp_config,   ONLY: atm_phy_nwp_config
  USE mo_nonhydrostatic_config,ONLY: kstart_moist
  USE mo_sgs_turbulence,       ONLY: drive_subgrid_diffusion
  USE mo_sgs_turbmetric,       ONLY: drive_subgrid_diffusion_m
  USE mo_les_config,           ONLY: les_config

  IMPLICIT NONE

  PRIVATE

  PUBLIC  ::  les_turbulence

CONTAINS
  !!
  !!-------------------------------------------------------------------------
  !!
SUBROUTINE les_turbulence  ( tcall_turb_jg,                   & !>in
                          & p_patch,                          & !>in
                          & p_metrics,                        & !>in
                          & p_int,                            & !>in
                          & p_prog,                           & !>in
                          & p_prog_rcf,                       & !>inout
                          & p_diag ,                          & !>inout
                          & prm_diag, prm_nwp_tend,           & !>inout
                          & lnd_prog_now,                     & !>in
                          & lnd_prog_new,                     & !>inout only for idealized LES
                          & lnd_diag                          ) !>in

  TYPE(t_patch),        TARGET,INTENT(in)   :: p_patch        !!<grid/patch info.
  TYPE(t_int_state),    INTENT(in),TARGET   :: p_int          !< single interpolation state
  TYPE(t_nh_metrics)          ,INTENT(inout)   :: p_metrics  ! SBr, CHa:in->inout
  TYPE(t_nh_prog),      TARGET,INTENT(inout):: p_prog          !<the prog vars
  TYPE(t_nh_prog),      TARGET,INTENT(inout):: p_prog_rcf      !<call freq
  TYPE(t_nh_diag),      TARGET,INTENT(inout):: p_diag          !<the diag vars
  TYPE(t_nwp_phy_diag),        INTENT(inout):: prm_diag        !< atm phys vars
  TYPE(t_nwp_phy_tend), TARGET,INTENT(inout):: prm_nwp_tend    !< atm tend vars
  TYPE(t_lnd_prog),            INTENT(in)   :: lnd_prog_now    !< prog vars for sfc
  TYPE(t_lnd_prog),            INTENT(inout):: lnd_prog_new    !< prog vars for sfc
  TYPE(t_lnd_diag),            INTENT(inout):: lnd_diag        !< diag vars for sfc
  REAL(wp),                    INTENT(in)   :: tcall_turb_jg   !< time interval for turbulence

  ! Local array bounds

  INTEGER :: rl_start, rl_end
  INTEGER :: i_startblk, i_endblk    !> blocks
  INTEGER :: i_startidx, i_endidx    !< slices
  INTEGER :: i_nchdom                !< domain index

  ! Local scalars:
  INTEGER :: jc,jk,jb,jg      !loop indices

  INTEGER  :: nlev            !< number of full levels

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

  ! number of vertical levels
  nlev   = p_patch%nlev

  ! local variables related to the blocking
  i_nchdom  = MAX(1,p_patch%n_childdom)
  jg        = p_patch%id

  IF (msg_level >= 15) CALL message('mo_les_turb_interface:', 'turbulence')

  !For 3D turbulence the whole patch needs to be passed. Therefore, this call
  !is made outside the block loop next. However, the tendencies it calculates
  !is then used inside the block loop (see at the end) to update u,v,t,qv,qc
  IF ( atm_phy_nwp_config(jg)%inwp_turb==ismag )THEN

    ! if les metrics is choosen, drive the subgrid diffusion from mo_sgs_turbmetric
    IF (les_config(jg)%les_metric) THEN
      CALL drive_subgrid_diffusion_m(p_prog,       & !inout for w (it is updated inside)
                                     p_prog_rcf,   & !in
                                     p_diag,       & !inout
                                     p_metrics,    & !in
                                     p_patch,      & !in
                                     p_int,        & !in
                                     lnd_prog_now, & !in
                                     lnd_prog_new, & !inout only for idealized cases
                                     lnd_diag,     & !inout
                                     prm_diag,     & !inout
                                     prm_nwp_tend, & !inout
                                     tcall_turb_jg & !in
                                     )

    ELSE
      CALL drive_subgrid_diffusion(p_prog,       & !inout for w (it is updated inside)
                                   p_prog_rcf,   & !in
                                   p_diag,       & !inout
                                   p_metrics,    & !inout, SBr, CHa:in->inout
                                   p_patch,      & !in
                                   p_int,        & !in
                                   lnd_prog_now, & !in
                                   lnd_prog_new, & !inout only for idealized cases
                                   lnd_diag,     & !inout
                                   prm_diag,     & !inout
                                   prm_nwp_tend, & !inout
                                   tcall_turb_jg & !in
                                   )
    END IF

  END IF

  ! exclude boundary interpolation zone of nested domains
  rl_start = grf_bdywidth_c+1
  rl_end   = min_rlcell_int

  i_startblk = p_patch%cells%start_blk(rl_start,1)
  i_endblk   = p_patch%cells%end_blk(rl_end,i_nchdom)

!$OMP PARALLEL
!$OMP DO PRIVATE(jb,jc,jk,i_startidx,i_endidx) ICON_OMP_GUIDED_SCHEDULE
  DO jb = i_startblk, i_endblk

    CALL get_indices_c(p_patch, jb, i_startblk, i_endblk, &
      & i_startidx, i_endidx, rl_start, rl_end)

    ! Update wind speed, QV and temperature with turbulence tendencies
    ! Note: the update of wind speed is done here in order to pass u and v at the correct time level
    ! to turbtran and the convection scheme. However, the update of the prognostic variable vn
    ! is done at the end of the NWP interface by first interpolating the u/v tendencies to the
    ! velocity points (in order to minimize interpolation errors) and then adding the tendencies
    ! to vn
    DO jk = 1, nlev
      DO jc = i_startidx, i_endidx
        p_prog_rcf%tracer(jc,jk,jb,iqv) =MAX(0._wp, p_prog_rcf%tracer(jc,jk,jb,iqv) &
             &           + tcall_turb_jg*prm_nwp_tend%ddt_tracer_turb(jc,jk,jb,iqv))
        p_diag%temp(jc,jk,jb) = p_diag%temp(jc,jk,jb)  &
         &  + tcall_turb_jg*prm_nwp_tend%ddt_temp_turb(jc,jk,jb)
        p_diag%u(jc,jk,jb) = p_diag%u(jc,jk,jb) + tcall_turb_jg*prm_nwp_tend%ddt_u_turb(jc,jk,jb)
        p_diag%v(jc,jk,jb) = p_diag%v(jc,jk,jb) + tcall_turb_jg*prm_nwp_tend%ddt_v_turb(jc,jk,jb)
      ENDDO
    ENDDO
    ! QC is updated only in that part of the model domain where moisture physics is active
    DO jk = kstart_moist(jg), nlev
      DO jc = i_startidx, i_endidx
        p_prog_rcf%tracer(jc,jk,jb,iqc) =MAX(0._wp, p_prog_rcf%tracer(jc,jk,jb,iqc) &
             &           + tcall_turb_jg*prm_nwp_tend%ddt_tracer_turb(jc,jk,jb,iqc))
      ENDDO
    ENDDO

  ENDDO ! jb
!$OMP END DO NOWAIT
!$OMP END PARALLEL

END SUBROUTINE les_turbulence

END MODULE mo_les_turb_interface