!=================================================================================================
!
!> @anchor      m_maneuvers
!!
!> @brief       Orbital maneuver modeling
!> @author      Vitali Braun (VB)
!> @author      Christopher Kebschull (CHK)
!!
!> @date

!!
VB:  04.11.2013 (initial design)

!!
CHK: 13.11.2015 (updated to use libslam)

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

!!
CHK: 03.01.2018 (created Manoeuvres_class)

!!

!!
!> @details     This module contains parameters, subroutines and functions required for the
!!              modeling of orbital maneuvers. The individual maneuvers are read from an input
!!              file which is specified in the general NEPTUNE input file.
!!
!> @copyright   Institute of Space Systems / TU Braunschweig
!!
!> @anchor      maneuvers
!!------------------------------------------------------------------------------------------------
module maneuvers

  use slam_types,             only: dp
  use slam_io,                only: openFile, closeFile, SEQUENTIAL, IN_FORMATTED, cdelimit, LOG_AND_STDOUT, message
  use neptune_error_handling, only: E_NO_MANEUVERS, E_MAX_MANEUVERS, E_MANEUVER_DEFINITION, E_SGA_INPUT, &
                                    E_MANEUVER_INIT, setNeptuneError
  use slam_error_handling,    only: isControlled, hasToReturn, hasFailed, FATAL, WARNING, REMARK, &
                                    E_ALLOCATION, checkIn, checkOut, E_OUT_OF_BOUNDS
  use slam_math,              only: mag
  use slam_reduction_class,   only: Reduction_type
  use slam_time,              only: time_t, tokenizeDate, sec_per_day

  implicit none

  private

    !===================================
    !
    ! Maneuver type definition(s)
    !
    !-----------------------------------
    type mnvPhase_t

        real(dp) :: mjd_start                                                   ! MJD of phase start
        real(dp) :: mjd_end                                                     ! MJD of phase end
        real(dp), dimension(3) :: acc                                           ! acceleration vector in UVW frame / km/s**2

    end type mnvPhase_t

    type maneuver_t

        type(time_t) :: start_date                                              ! date of maneuver start
        type(time_t) :: end_date                                                ! date of maneuver end
        integer      :: nphases                                                 ! number of different phases within one maneuver
        type(mnvPhase_t), dimension(:), allocatable :: phase                    ! containing individual maneuver phases

    end type maneuver_t

    type mnv_sequence_t

        real(dp) :: mjd_start                                                   ! MJD start of phase this structure is pointing at
        real(dp) :: mjd_end                                                     ! MJD end of phase this structure is pointing at
        integer  :: midx                                                        ! maneuver index
        integer  :: pidx                                                        ! phase index
        integer  :: trans                                                       ! transition flag: 0 = no transition,
                                                                                !                  1 = transition interval at begin of maneuver
                                                                                !                  2 = transition between two phases
                                                                                !                  3 = transition after a maneuver
    end type mnv_sequence_t

    !** types
    public :: maneuver_t
    public :: mnvPhase_t
    !-----------------------------------

    integer, parameter :: MANEUVER_STACK_SIZE     = 40                          ! number of maneuvers the initial array is capable of storing
    integer, parameter :: MANEUVER_STACK_SIZE_MAX = 200                         ! maximum number of maneuvers which can be handled
    integer, parameter :: MAX_MANEUVER_PHASES     = 50                          ! maximum number of maneuver phases which can be handled per maneuver

    integer, parameter :: NO_TRANSITION = 0
    integer, parameter :: TRANS_START   = 1
    integer, parameter :: TRANS_PHASE   = 2
    integer, parameter :: TRANS_END     = 3

    real(dp), parameter :: transition_time = 10.d0                              ! transition time between two maneuver phases / s
    real(dp), parameter :: transDay       = transition_time/86400.d0            ! duration of thrust transition in days

    type, public :: Manoeuvres_class

        logical :: man_initialized                                              ! initialization flag
        logical :: flag_no_data                                                 ! .true. if no maneuver data available for processing

        character(len=255) :: man_file_name                                     ! maneuver specification file name

        type(maneuver_t),    dimension(:), allocatable :: manv                  ! maneuver data structure
        type(mnv_sequence_t), dimension(:), allocatable :: mnv_sequence         ! structure, which points at the first maneuver phase for index 1,
                                                                                ! the second one for index 2, etc.
    contains

        procedure :: init_maneuvers_file
        procedure :: init_maneuvers_api
        generic   :: init_maneuvers => init_maneuvers_file, init_maneuvers_api
        procedure :: destroy

        !** setter
        procedure :: set_maneuvers_init_flag
        procedure :: set_man_file_name

        !** getter
        procedure :: get_man_file_name
        procedure :: get_manoeuvre_data
        procedure :: get_number_of_manoeuvres
        procedure :: get_maneuver_acceleration

        procedure, private :: read_maneuvre_file
        procedure, private :: init_maneuver_sequence
        procedure, private :: get_current_acc
        procedure, private :: get_current_index

    end type Manoeuvres_class

    ! Constructor
    interface Manoeuvres_class
        module procedure constructor
    end interface Manoeuvres_class

contains

    ! ====================================================================
    !!
    !>  @brief      Constructor that should be used to initialize variables.
    !!
    !!  @author     Christopher Kebschull
    !!  @date

    !!
ChK: 03.01.2017 (initial implementation)

    !!

    !!
    !!  @anchor     constructor
    !!
    ! --------------------------------------------------------------------
    type(Manoeuvres_class) function constructor()
        constructor%man_initialized = .false.                                    ! initialization flag
        constructor%flag_no_data   = .false.
        constructor%man_file_name = "neptune.mnv"
    end function constructor

    !===========================================================================
    !!
    !>  @anchor     destroy
    !!
    !!  @brief      Destroys all that needs destruction
    !!  @author     Christopher Kebschull
    !!
    !!
    !!  @date

    !!
03.01.2018 (initial design)

    !!

    !!
    !---------------------------------------------------------------------------
    subroutine destroy(this)
        class(Manoeuvres_class)    :: this

        if (allocated(this%mnv_sequence)) deallocate(this%mnv_sequence)
        if (allocated(this%manv)) deallocate(this%manv)

    end subroutine destroy

!==========================================================================
!
!> @anchor      set_maneuvers_init_flag
!!
!! @brief       Set initialization flag to .false.
!! @author      Vitali Braun
!!
!! @date

!!
 04.11.2013 (initial design)

!!

!!
!!-------------------------------------------------------------------------
  subroutine set_maneuvers_init_flag(this)

    class(Manoeuvres_class)     :: this

    this%man_initialized = .false.

  end subroutine set_maneuvers_init_flag

  !
  subroutine read_maneuvre_file(this,            &
                                cpath,           & ! <-- CHR()   path to read data from
                                number_phases    & ! --> INT(:)  number of phases from file
                                )
    !** interface
    !-------------------------------------------
    class(Manoeuvres_class)                         :: this
    character(len=*), intent(in)                    :: cpath
    integer, dimension(:), allocatable, intent(out) :: number_phases  ! counting the number of phases for individual maneuvers
    !------------------------------------------

    character(len=255) :: cbuf
    character(len=255) :: cfile
    character(len=3)   :: ctemp
    character(len=26)  :: dateString
    character(len=*), parameter :: csubid = "read_maneuvre_file"
    integer :: i,j    ! loop counter
    integer :: ich    ! input channel
    integer :: ierr   ! error flag
    integer :: iman   ! number of individual maneuvers
    integer :: ios    ! I/O status
    integer :: kphs   ! counter for maneuver phases
    integer :: new_size   ! auxiliary for the reallocation of 'number_phases'

    logical  :: flag_current_maneuver   ! indicator for current maneuver read

    real(dp) :: duration    ! maneuver duration / s

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

    if(this%man_initialized) then   ! return if already initialized
      if(isControlled()) then
        call checkOut(csubid)
      end if
      return
    end if

    iman = 0

    !==========================================================
    !
    ! Start maneuver input file read
    !
    !------------------------------------------

    !** open maneuver data file
    !----------------------------------------------------------------------
    cfile = trim(adjustl(cpath))//cdelimit//trim(adjustl(this%man_file_name))
    ich = openFile(cfile, SEQUENTIAL, IN_FORMATTED)

    call message(' - Reading maneuver data...', LOG_AND_STDOUT)

    !** count number of individual maneuvers (starting with a date tag)
    !-----------------------------------------------------------------

    !** allocate data array for maneuver phases
    allocate(number_phases(MANEUVER_STACK_SIZE))

    do

      read(ich,'(A)',iostat=ios) cbuf

      if(ios /= 0) then
        exit
      else if(index(cbuf,'#') /= 0) then
        cycle
      else if(index(cbuf,'-') /= 0 .and. index(cbuf,':') /= 0) then ! a date tag is available, if a '-' and a ':' are found

        iman = iman + 1

        ! in order to count maneuver phases, save number of phases for last maneuver, before starting to count from anew
        if(iman > 1) then
          !** re-allocate stack if required
          if(iman > size(number_phases)) then  ! re-allocate
            new_size = size(number_phases) + 20
            if(new_size > MANEUVER_STACK_SIZE_MAX) then  ! limit reached
              call setNeptuneError(E_ALLOCATION, FATAL)
              ierr = closeFile(ich)
              return
            else
              deallocate(number_phases)
              allocate(number_phases(new_size))
            end if
          end if
          number_phases(iman - 1) = kphs

        end if

        kphs = 1    ! start counting number of maneuver phases for this maneuver

      else

        kphs = kphs + 1

        if(kphs > MAX_MANEUVER_PHASES) then

          write(ctemp,'(i3)') MAX_MANEUVER_PHASES
          call setNeptuneError(E_MAX_MANEUVERS, FATAL, (/ctemp/))
          ierr = closeFile(ich)
          return

        end if

      end if

    end do

    if(iman == 0) then  !** no maneuvers found

      call setNeptuneError(E_NO_MANEUVERS, REMARK, (/cfile/))
      ierr = closeFile(ich)
      if(isControlled()) then
        call checkOut(csubid)
      end if

      this%flag_no_data = .true.
      return

    end if

    !** save phases for last maneuver, as this has not been counted yet
    number_phases(iman) = kphs

    !** allocated maneuver data structure
    !-------------------------------------
    allocate(this%manv(iman))
    do i = 1, iman

      !** allocate maneuver phases for each maneuver
      this%manv(i)%nphases = number_phases(i)
      allocate(this%manv(i)%phase(this%manv(i)%nphases))

    end do

    !** now finally read data into prepared arrays
    !------------------------------------------------------
    rewind(ich)
    i    = 0
    kphs = 2
    flag_current_maneuver = .false. ! is set to true, as soon as maneuver begins with date tag, set to false as soon as maneuver ends

    do

      read(ich,'(a)',iostat=ios) cbuf
      if(ios /= 0) exit
     if(index(cbuf,'#') /= 0) cycle  ! skip comments

      !** check whether new maneuver begins or only new phase is read
      if(index(cbuf,'-') /= 0 .and. index(cbuf,':') /= 0) then ! a date tag is available, if a '-' and a ':' are found

        i = i + 1
        read(cbuf,*) dateString, duration, (this%manv(i)%phase(1)%acc(j), j=1,3)

        !** convert we to km/s -- UPDATE: not required, as thrust is also given in kg*m/s**2, which cancels out to kg/s after division...
        !manv(i)%phase(1)%we = manv(i)%phase(1)%we/1.d3

        !** compute start and end date (MJD) for current phase, as well as end date for whole maneuver, if only one phase is available
        call tokenizeDate(dateString, this%manv(i)%start_date)

        this%manv(i)%phase(1)%mjd_start = this%manv(i)%start_date%mjd
        this%manv(i)%phase(1)%mjd_end   = this%manv(i)%start_date%mjd + duration/86400.d0

        if(this%manv(i)%nphases == 1) then
          this%manv(i)%end_date%mjd = this%manv(i)%start_date%mjd + duration/86400.d0
          flag_current_maneuver = .false.
        else
          flag_current_maneuver = .true.
        end if

      else if(flag_current_maneuver) then ! read new phase of current maneuver

        read(cbuf,*) duration, (this%manv(i)%phase(kphs)%acc(j), j=1,3)

        ! compute dates
        this%manv(i)%phase(kphs)%mjd_start = this%manv(i)%phase(kphs-1)%mjd_end
        this%manv(i)%phase(kphs)%mjd_end   = this%manv(i)%phase(kphs-1)%mjd_end + duration/86400.d0

        ! check whether end of current maneuver has been reached
        if(kphs == this%manv(i)%nphases) then

          ! compute end date of whole maneuver
          this%manv(i)%end_date%mjd = this%manv(i)%phase(kphs)%mjd_end

          kphs = 2  ! reset counter (note that first phase, kphs=1, is already read within 'if' statement)
          flag_current_maneuver = .false. ! end of maneuver

        else

          kphs = kphs + 1

        end if

      end if

    end do

    ierr = closeFile(ich)

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

    return

  end subroutine read_maneuvre_file

!=============================================================================
!
!> @anchor      init_maneuvers_file
!!
!! @brief       Initialization of maneuvers module
!! @author      Vitali Braun
!!
!! @date

!!
 04.11.2013 (initial design)

!!

!!
!! @param[in]   cpath       Path to read maneuver specification file from
!! @param[in]   date_start  propagation span start date (no data prior to this date is read)
!! @param[in]   date_end    propagation span end date (no data beyond this date is read)
!!
!! @details     This routine initializes the maneuvers module. Global parameters are set and
!!              maneuver data is read from a specification file into the specific arrays.
!!              Also the begin and end of the maneuver is prepared in order to provide a
!!              smooth maneuver onset and end.
!!
!!              \par Overview
!!
!!

!!
 Finish.

!!

!!
!!------------------------------------------------------------------------------------------------
  subroutine init_maneuvers_file(         &
                              this,      &
                              cpath,     &  ! <-- CHR()   path to read data from
                              date_start,&  ! <-- TYP     propagation start date (no data prior to this date is read)
                              date_end   &  ! <-- TYP     propagation end date (no data beyond this date is read)
                          )

    !** interface
    !-------------------------------------------
    class(Manoeuvres_class)      :: this
    character(len=*), intent(in) :: cpath
    type(time_t),     intent(in) :: date_start
    type(time_t),     intent(in) :: date_end
    !------------------------------------------

    character(len=*), parameter         :: csubid = "init_maneuvers_file"
    integer, dimension(:), allocatable  :: number_phases  ! counting the number of phases for individual maneuvers

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

    if(this%man_initialized) then   ! return if already initialized --> This is not good! A user might call this routine, think to "set" manoeuvers, but actually the call is ignored without feedback
      if(isControlled()) then
        call checkOut(csubid)
      end if
      return
    end if

    !** check input
    if(date_start%mjd > date_end%mjd) then
      call setNeptuneError(E_SGA_INPUT, FATAL)
      return
    end if

    !=====================================================================
    !
    ! Read mnv file
    !
    !---------------------------------------------------------------------

    call this%read_maneuvre_file(cpath,number_phases)

    !=====================================================================
    !
    ! Initialize maneuvre sequence
    !
    !---------------------------------------------------------------------

    call this%init_maneuver_sequence(number_phases)

    this%man_initialized = .true.

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

    return

  end subroutine init_maneuvers_file

!=============================================================================
!
!> @anchor      init_maneuvers_api
!!
!! @brief       Initialization of maneuvers module
!! @author      Christopher Kebschull
!!
!! @date

!!
 21.07.2017 (initial design)

!!

!!
!! @param[in]   manv_in          an array containing the individual manoeuvres
!! @param[in]   number_phases    array of manoeuvre phases
!!
!! @details     This routine initializes the maneuvers module. Global parameters are set and
!!              maneuver data is read from a specification file into the specific arrays.
!!              Also the begin and end of the maneuver is prepared in order to provide a
!!              smooth maneuver onset and end.
!!
!!              \par Overview
!!
!!

!!
 Finish.

!!

!!
!!------------------------------------------------------------------------------------------------
  subroutine init_maneuvers_api( this,           &
                                manv_in,         &  ! <-- TYP     List of manoeuvres planned to occur in propagation time
                                number_phases    &
                                )

    !** interface
    !-------------------------------------------
    class(Manoeuvres_class)                                     :: this
    type(maneuver_t), dimension(:), allocatable, intent(in)     :: manv_in           ! maneuver data structure
    integer,          dimension(:), allocatable, intent(in)     :: number_phases     ! counting the number of phases for individual maneuvers
    !------------------------------------------

    character(len=*), parameter :: csubid = "init_maneuvers_api"

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

    ! Please not that we allow re-initialization

    !=====================================================================
    !
    ! Transfer maneuvre list
    !
    !---------------------------------------------------------------------
    if (allocated(this%manv)) deallocate(this%manv)

    allocate(this%manv(size(manv_in)))

    this%manv = manv_in

    !=====================================================================
    !
    ! Initialize maneuvre sequence
    !
    !---------------------------------------------------------------------

    call this%init_maneuver_sequence(number_phases)

    this%man_initialized = .true.

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

    return

  end subroutine init_maneuvers_api

  subroutine init_maneuver_sequence(this, number_phases)

    class(Manoeuvres_class)                         :: this
    integer, dimension(:), allocatable, intent(in)  :: number_phases             ! counting the number of phases for individual maneuvers

    character(len=*), parameter     :: csubid = "init_maneuver_sequence"
    integer                         :: i,j,k                                    ! loop counter

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

    !=====================================================================
    !
    ! Prepare pointer array, in order to know maneuver sequence wrt. time
    !
    !---------------------------------------------------------------------

    if (allocated(this%mnv_sequence)) deallocate(this%mnv_sequence)

    allocate(this%mnv_sequence(2*sum(number_phases(1:size(this%manv)))+size(this%manv)))  ! enough elements to account for transitions
                                                                                ! between thrust levels (cubic hermite spline, later on)
    k = 0

    do i=1,size(this%manv)

      do j=1,this%manv(i)%nphases

        k = k + 2                                                               ! +2, as between each maneuver phase, also a transition phase will be added
        this%mnv_sequence(k)%midx        = i
        this%mnv_sequence(k)%pidx        = j
        this%mnv_sequence(k)%mjd_start   = this%manv(i)%phase(j)%mjd_start + 0.5d0*transDay
        this%mnv_sequence(k)%mjd_end     = this%manv(i)%phase(j)%mjd_end   - 0.5d0*transDay
        this%mnv_sequence(k)%trans       = NO_TRANSITION

        !** transition phase
        this%mnv_sequence(k-1)%mjd_start = this%mnv_sequence(k)%mjd_start - transDay
        this%mnv_sequence(k-1)%mjd_end   = this%mnv_sequence(k)%mjd_start
        this%mnv_sequence(k-1)%midx      = i
        this%mnv_sequence(k-1)%pidx      = j

        if(j == 1) then

          this%mnv_sequence(k-1)%trans = TRANS_START  ! begin of maneuver

        else if(j <= this%manv(i)%nphases) then

          this%mnv_sequence(k-1)%trans = TRANS_PHASE  ! transition between two phases

        end if

        if(j == this%manv(i)%nphases) then   ! last phase: add transition interval at the end

          this%mnv_sequence(k+1)%mjd_start  = this%manv(i)%phase(j)%mjd_end - 0.5d0*transDay
          this%mnv_sequence(k+1)%mjd_end    = this%mnv_sequence(k+1)%mjd_start + transDay
          this%mnv_sequence(k+1)%midx       = i
          this%mnv_sequence(k+1)%pidx       = j
          this%mnv_sequence(k+1)%trans      = TRANS_END

        end if

      end do

      k = k + 1     ! +1, as between each maneuver phase, also a transition phase will be added later on (see below)

    end do

    !** final step: sort maneuver sequence
!    do
!
!      swapped = .false.
!
!      do i = 1, k-1
!        if(mnv_sequence(i)%mjd_start > mnv_sequence(i+1)%mjd_start) then
!          !** swap values
!          temp             = mnv_sequence(i)
!          mnv_sequence(i)   = mnv_sequence(i+1)
!          mnv_sequence(i+1) = temp
!          swapped  = .true.
!        end if
!      end do
!
!      if(.not. swapped) exit
!
!    end do

    !================================================================
    !
    ! Check whether there are intersections of phases (not allowed!)
    !
    !----------------------------------------------------------------
!    do i=1,size(mnv_sequence)-1
!        write (*,*) i, mnv_sequence(i+1)%mjd_start, mnv_sequence(i)%mjd_end
!      if(mnv_sequence(i+1)%mjd_start < mnv_sequence(i)%mjd_end) then
!        call setNeptuneError(E_MANEUVER_DEFINITION, FATAL)
!        return
!      end if
!    end do
!
!   do i=1,size(mnv_sequence)
!
!     write(*,'(i,x,2(f15.9,x),3(i,x))') i, mnv_sequence(i)%mjd_start, mnv_sequence(i)%mjd_end, mnv_sequence(i)%midx, mnv_sequence(i)%pidx, mnv_sequence(i)%trans
!
!   end do
!
!   stop

!   do i=1,size(manv)
!
!     write(*,*)
!     write(*,*) "Maneuver ",i
!     write(*,*) "-------------------"
!     write(*,*) " Begin date: ", manv(i)%start_date%mjd
!     write(*,*) " End   date: ", manv(i)%end_date%mjd
!
!     do j=1,size(manv(i)%phase)
!       write(*,*) "<-- Phase ", j, " -->"
!       write(*,*) "  -Begin:  ", manv(i)%phase(j)%mjd_start
!       write(*,*) "  -End:    ", manv(i)%phase(j)%mjd_end
!!       write(*,'(a,3(f8.2,x))') "  -Thrust: ", (manv(i)%phase(j)%acc(kphs), kphs=1,3)
!     end do
!   end do
!
!   write(*,*)

!    do dtemp = mnv_sequence(1)%mjd_start-3.d0*transDay, mnv_sequence(size(mnv_sequence))%mjd_end+3.d0*transday, 0.1d0/86400.d0
!
!      write(44,*) dtemp, mag(get_current_acc(dtemp,get_current_index(dtemp))), get_current_index(dtemp)
!
!    end do

!    stop
    !** finally set initial object mass -- not implemented!!
    !mass_old = getObjectMass()
    !mass_new = mass_old

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

    return

  end subroutine init_maneuver_sequence

!=============================================================================
!
!> @anchor      get_maneuver_acceleration
!!
!! @brief       Computes acceleration due to orbital maneuvers
!! @author      Vitali Braun
!!
!! @date

!!
 04.11.2013 (initial design)

!!

!!
!! @param[in]   r_gcrf            current radius vector in GCRF
!! @param[in]   v_gcrf            current velocity vector in GCRF
!! @param[in]   time_mjd          current time MJD
!! @param[in]   lout              (optional), if .true., then no updates are performed
!!
!! @param[out]  acc_atmosphere    acceleration vector in inertial frame
!!
!! @details     This routine computes the acceleration in the GCRF due to orbital
!!              maneuvers.
!!
!!              \par Overview
!!
!!

!!
 Finish.

!!

!!
!------------------------------------------------------------------------------------------------
  subroutine get_maneuver_acceleration(   this,        &
                                        reduction,   &
                                        r_gcrf,      &   ! <-- DBL(3) current radius vector GCRF / km
                                        v_gcrf,      &   ! <-- DBL(3) current velocity vector GCRF / km/s
                                        time_mjd,    &   ! <-- DBL    current epoch
                                        acc_man      &   ! --> DBL(3) acceleration vector in inertial frame
                                    !    lout         &   ! <-- LOG    (optional), if .true., then no updates are performed, only acceleration for time_mjd given
                                    )                    !            which is important if only output for an intermediate step is required, but the current and
                                                         !            prior states have to remain untouched

    !** interface
    !---------------------------------------------------
    class(Manoeuvres_class)             :: this
    type(Reduction_type)               :: reduction
    real(dp),               intent(in)  :: time_mjd
    real(dp), dimension(3), intent(in)  :: r_gcrf
    real(dp), dimension(3), intent(in)  :: v_gcrf
!    logical,  optional,     intent(in)  :: lout

    real(dp), dimension(3), intent(out) :: acc_man
    !---------------------------------------------------

    character(len=*), parameter :: csubid = "get_maneuver_acceleration"

    real(dp), dimension(3) :: acc_uvw    ! current acceleration for given MJD in UVW frame

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

    !** check whether there is maneuver data or not
    if(this%flag_no_data) then

      acc_man = 0.d0

      if(isControlled()) then
        call checkOut(csubid)
      end if

      return

    end if

    !** check whether initialization has been done already...
    if(.not. this%man_initialized) then
      call setNeptuneError(E_MANEUVER_INIT, FATAL)
      return
    end if

    !====================================================
    !
    ! Find out, whether current time corresponds to a
    ! possible maneuver. This is done by computing the
    ! index within the mnv_sequence array. This array holds the
    ! information of each phase of the individual maneuvers.
    ! E.g. mnv_sequence(1) is the start phase (transition) of the first maneuver,
    ! mnv_sequence(2) is the constant thrust phase of the first maneuver,
    ! etc. Now, the index is found by looking at the current date.
    ! The index is given a negative value if it corresponds
    ! to a phase with no thrust - which is actually not mapped by
    ! the mnv_sequence array. Thus, an index of "-1" means that
    ! the integrator is in a phase prior to phase 1, which would be
    ! before the start of the first maneuver. A "-5" would tell that
    ! the time corresponds to a no-thrust phase before phase 5, which itself
    ! would be a start phase of a subsequent maneuver.
    !
    ! <===< ONLY RELEVANT IF MASS UPDATES REQUIRED >===>
    ! The first thing to do, however, is to determine whether there has been a step
    ! forward, or the step size has been reduced and the function is called based
    ! on the same step one more time.
    !
    !----------------------------------------------------
!   if(present(lout)) then
!     lmode = lout
!   else
!     lmode = .false.
!   end if

!    if(lmode) then   ! routine has been called for output purposes - no step updates should be performed!!
!
!      tnew = time_mjd
!      inew = get_current_index(time_mjd)
!
!      if(time_mjd > time_mjd_new) then
!
!       told = time_mjd_new
!       !mold = mass_new
!       iold = idCurrentTime
!
!     else
!
!       told = time_mjd_old
!       !mold = mass_old
!       iold = idLastTime
!
!     end if

!   else

!     if(time_mjd > time_mjd_new) then  ! step forward - update time_mjd_old and time_mjd_new (moving one slot forward)
!                                       ! but also mass_old and the index idLastTime!

!       time_mjd_old = time_mjd_new
!       !mass_old     = mass_new

!       !** update also the mnv_sequence index
!       idLastTime    = idCurrentTime

!     end if

!     time_mjd_new  = time_mjd
!     idCurrentTime = get_current_index(time_mjd)

!     !** and now assign to local variables
!     told = time_mjd_old
!     tnew = time_mjd_new

!     !mold = mass_old

!     iold = idLastTime
!     inew = idCurrentTime

!   end if

!   !** if there was no change in index from subsequent calls, the thrust is zero:
!   if((idCurrentTime <= 0) .and. (idLastTime == idCurrentTime)) then

!     acc_man = 0.d0  ! no mass update
!
!     if(isControlled()) then
!       call checkOut(csubid)
!     end if
!     return

!   end if

    ! 1)  Get current thrust
    acc_uvw = this%get_current_acc(time_mjd, this%get_current_index(time_mjd))

    ! 2)  Convert acceleration to inertial frame, which results in the
    call reduction%uvw2eci(r_gcrf, v_gcrf, acc_uvw, acc_man)

    ! 3)  Update satellite's mass in order to compute current acceleration (stored in module variable mass_new)
    !call updateMass()

    !write(*,*) time_mjd, mag(acc_uvw)

    ! 4)  Finally compute acceleration

    !acc_man(1:3) = thrust_gcrf*1.d-3/mass_new   ! 1.d-3 to account for conversion from 'N' to 'kg*km/s**2'

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

    return

  end subroutine get_maneuver_acceleration

!=============================================================================
!
!> @anchor      getMeanMassFlow
!!
!! @brief       Gets the mean mass flow for a given time interval
!! @author      Vitali Braun
!!
!! @date

!!
 07.11.2013: initial design

!!

!!
!! @detail      This function computes the mean mass flow of an engine for
!!              a given time interval. This is necessary, as the thrust level
!!              may change between subsequent calls of the maneuver acceleration
!!              routine. As the satellite's mass is important for the proper
!!              computation of the acceleration, the first step is to get the
!!              right mass flow
!!
!-----------------------------------------------------------------------------
!  real(dp) function getMeanMassFlow()

    !** make sure that mjd_end > mjd_start
!   if(abs(time_mjd_old - time_mjd_new) < eps9) then  ! same time, so mass flow is for the current step only and does not have to consider an interval

!     mdot = mag(getCurrentThrust(time_mjd_new))/getCurrentExVelocity()
!
!     swap      = mjd_start
!     mjd_start = mjd_end
!     mjd_end   = swap

!   end if

!    getMeanMassFlow = 0.d0

!    return

!  end function getMeanMassFlow

!=============================================================================
!
!> @anchor      get_current_acc
!!
!! @brief       Get the current acceleration for a given MJD in a satellite-based reference frame (UVW)
!! @author      Vitali Braun
!!
!! @param[in]   time_mjd  current MJD
!! @param[in]   idx       current index in mnv_sequence array
!!
!! @date

!!
 06.11.2013: initial design

!!

!!
!-----------------------------------------------------------------------------
  function get_current_acc(this, time_mjd, idx)

    class(Manoeuvres_class) :: this
    real(dp), intent(in)    :: time_mjd
    integer,  intent(in)    :: idx
    real(dp), dimension(3)  :: get_current_acc

    real(dp) :: ttemp   ! MJD transformed to interval [0:1]
    real(dp), dimension(3) :: y1, y2    ! interpolation points for thrust transitions

    !** if index is negative or zero, thrust = 0
    if(idx <= 0) then

      get_current_acc = 0.d0

    else

      if(this%mnv_sequence(idx)%trans == NO_TRANSITION) then  ! constant thrust in this phase

        get_current_acc(1:3) = this%manv(this%mnv_sequence(idx)%midx)%phase(this%mnv_sequence(idx)%pidx)%acc(1:3)

      else

        if(this%mnv_sequence(idx)%trans == TRANS_START) then   ! cubic hermite interpolation for maneuver start

          y1 = 0.d0
          y2(1:3) = this%manv(this%mnv_sequence(idx)%midx)%phase(this%mnv_sequence(idx)%pidx)%acc(1:3)

        else if(this%mnv_sequence(idx)%trans == TRANS_PHASE) then ! cubic hermite interpolation between phases

          y2(1:3) = this%manv(this%mnv_sequence(idx)%midx)%phase(this%mnv_sequence(idx)%pidx)%acc(1:3)
          y1(1:3) = this%manv(this%mnv_sequence(idx-1)%midx)%phase(this%mnv_sequence(idx-1)%pidx)%acc(1:3)

        else if(this%mnv_sequence(idx)%trans == TRANS_END) then ! cubic hermite interpolation for maneuver end

          y1(1:3) = this%manv(this%mnv_sequence(idx)%midx)%phase(this%mnv_sequence(idx)%pidx)%acc(1:3)
          y2(1:3) = 0.d0

        end if

        ttemp = (time_mjd - this%mnv_sequence(idx)%mjd_start)/transDay
        get_current_acc(1:3) = (2.d0*ttemp**3.d0 - 3.d0*ttemp**2.d0 + 1.d0)*y1(1:3) + (3.d0*ttemp**2.d0 - 2.d0*ttemp**3.d0)*y2(1:3)

      end if

    end if

    return

  end function get_current_acc

!=============================================================================
!
!> @anchor      get_current_index
!!
!! @brief       Get the current index within the mnv_sequence array
!! @author      Vitali Braun
!!
!! @param[in]   mjd   current MJD
!!
!! @date

!!
 07.11.2013: initial design

!!

!!
!-----------------------------------------------------------------------------
  integer function get_current_index(this, mjd)

    class(Manoeuvres_class) :: this
    real(dp), intent(in)    :: mjd                                              ! current MJD

    integer :: k    ! loop counter

    ! loop through mnv_sequence array to bracket mjd
    do k = 1, size(this%mnv_sequence)

      if(k == size(this%mnv_sequence) .and. mjd > this%mnv_sequence(k)%mjd_start .and. mjd < this%mnv_sequence(k)%mjd_end) then
        get_current_index = k
        return
      else if(mjd < this%mnv_sequence(k)%mjd_start) then
        exit
      end if

    end do

    if(k == 1) then

      get_current_index = -1  ! prior to first maneuver

    else if(k > size(this%mnv_sequence)) then

      get_current_index =  0  ! after last maneuver phase

    else  ! somewhere in between of all maneuvers...

      get_current_index = k-1
      if((mjd > this%mnv_sequence(k-1)%mjd_end) .and. (mjd < this%mnv_sequence(k)%mjd_start)) then ! in between of two maneuvers
        get_current_index = -(get_current_index + 1)  ! '+1' between phases, the negative index gives the number of the subsequent phase!
      end if

    end if

    return

  end function get_current_index

!=============================================================================
!
!> @anchor      get_man_file_name
!!
!! @brief       Get the name of the maneuver specification file
!! @author      Vitali Braun
!!
!! @date

!!
 04.11.2013: initial design

!!

!!
!-----------------------------------------------------------------------------
  character(len=255) function get_man_file_name(this)

    class(Manoeuvres_class) :: this

    get_man_file_name = this%man_file_name
    return

  end function get_man_file_name

!=============================================================================
!
!> @anchor      get_manoeuvre_data
!!
!! @brief       Returns a manoeuvre form the manoeuvres array
!! @author      Christopher Kebschull
!!
!! @date

!!
 30.04.2019: initial design

!!

!!
!-----------------------------------------------------------------------------
  function get_manoeuvre_data(this,idx) result(manv_record)

    class(Manoeuvres_class) :: this
    integer, intent(in)     :: idx
    type(maneuver_t)        :: manv_record

    character(len=*), parameter :: csubid = 'get_manoeuvre_data'

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

    if(idx < 1 .or. idx > size(this%manv)) then

      call setNeptuneError(E_OUT_OF_BOUNDS, WARNING)
      manv_record%nphases = 0
      return

    end if

    manv_record = this%manv(idx)

    if(isControlled()) then
      call checkOut(csubid)
    end if

  end function get_manoeuvre_data

!=============================================================================
!
!> @anchor      get_number_of_manoeuvres
!!
!! @brief       Returns the size of the manoeuvres array
!! @author      Christopher Kebschull
!!
!! @date

!!
 30.04.2019: initial design

!!

!!
!-----------------------------------------------------------------------------
  integer function get_number_of_manoeuvres(this)

    class(Manoeuvres_class) :: this

    character(len=*), parameter :: csubid = 'get_number_of_manoeuvres'

    get_number_of_manoeuvres = 0

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

    get_number_of_manoeuvres = size(this%manv)

    if(isControlled()) then
      call checkOut(csubid)
    end if

  end function get_number_of_manoeuvres

!=============================================================================
!
!> @anchor      set_man_file_name
!!
!! @brief       Set the name of the maneuver specification file
!! @author      Vitali Braun
!!
!! @param[in]   val   name of maneuver specification file
!!
!! @date

!!
 04.11.2013: initial design

!!

!!
!-------------------------------------------------------------------------------
  subroutine set_man_file_name(this, val)

    class(Manoeuvres_class)         :: this
    character(len=*), intent(in)    :: val

    this%man_file_name = val(1:min(len(val),len(this%man_file_name)))
    return

  end subroutine set_man_file_name

!=============================================================================
!
!> @anchor      updateMass
!!
!! @brief       Update the mass for the given time step
!! @author      Vitali Braun
!!
!! @date

!!
 08.11.2013: initial design

!!

!!
!-----------------------------------------------------------------------------
!  subroutine updateMass()

!   integer  :: k       ! loop counter
!   integer  :: k_start ! starting index
!   integer  :: k_end   ! ending index

!   real(dp) :: dsum    ! sum of product mdot*dt for different phases (basically an integration...)
!   real(dp) :: dt      ! time interval / days
!   real(dp) :: mdot    ! mass flow / kg/s
!   real(dp) :: t1, t2  ! time 1 and 2 for integration / days
!   real(dp) :: thrust_1, thrust_2    ! thrust 1 and 2 for integration / N
!   real(dp) :: we      ! exhaust velocity / km/s

!   dsum = 0.d0

!   write(*,*) "updating mass..."
!   write(*,*) "ID = ", idLastTime, idCurrentTime
!
!   if(idLastTime == 0) then    ! nothing to be done - exit without mass update
!     return
!   end if

!   !** find loop start and end indices from IDs

!   ! 1) k_start
!   if(idLastTime ==  -1) then
!     k_start = 1
!   else if(idLastTime < 0) then
!     k_start = -idLastTime - 1
!   else
!     k_start = idLastTime
!   end if

!   ! 2) k_end
!   if(idCurrentTime == 0) then
!     k_end = size(mnv_sequence)
!   else if(idCurrentTime ==  -1) then
!     k_end = 1
!   else if(idCurrentTime < 0) then
!     k_end = -idCurrentTime - 1
!   else
!     k_end = idCurrentTime
!   end if
!
!   !** loop over relevant phases for update
!   !----------------------------------------------
!   do k = k_start, k_end

!     write(*,*) "k = ", k

!     we   = manv(mnv_sequence(k)%midx)%phase(mnv_sequence(k)%pidx)%we
!     t1   = max(mnv_sequence(k)%mjd_start, time_mjd_old)
!     t2   = min(mnv_sequence(k)%mjd_end, time_mjd_new)
!     dt   = t2 - t1

!     write(*,*) "dt = ", dt*86400.d0
!     !** thrust for phase corresponding to time_mjd_old
!     thrust_1 = mag(getCurrentThrust(t1, k))

!     write(*,*) "thrust1 = ", thrust_1

!     select case(mnv_sequence(k)%trans)
!
!       case(NO_TRANSITION)
!
!         write(*,*) "no_trans"
!         mdot = thrust_1/we

!       case(TRANS_START, TRANS_PHASE, TRANS_END)

!         write(*,*) "start, phase, end"
!         !** compute thrust corresponding to time_mjd_new
!         thrust_2 = mag(getCurrentThrust(t2, k))
!         write(*,*) "thrust2 = ", thrust_2
!         mdot     = 0.5d0*(thrust_2 - thrust_1)/we

!     end select

!     write(*,*) "mdot = ", mdot
!     dsum = dsum + mdot*dt*day_in_sec
!     write(*,*) "dsum = ", dsum

!   end do

!   write(*,*) "mass_new = ", mass_new

!   !** now update mass
!   !-------------------------------
!   mass_new = mass_new - dsum

!   !** also update for satellite model
!   !----------------------------------
!   call setObjectMass(mass_new)

!   write(*,*) "done."
!   return

! end subroutine updateMass

end module maneuvers


c It features the HwU format for histogram booking and output.
c The details of how to process/manipulate the resulting .HwU file,
c in particular how to plot it using gnuplot, I refer the reader to this
c FAQ:
c
c      https://answers.launchpad.net/mg5amcnlo/+faq/2671
c
c It mostly relies on using the following madgraph5 module in standalone
c
c  <MG5_aMC_install_dir>/madgraph/various/histograms.py
c
c You can learn about how to run it and what options are available with
c
c  python <MG5_aMC_install_dir>/madgraph/various/histograms.py --help
c
C----------------------------------------------------------------------
      SUBROUTINE RCLOS()
C     DUMMY IF HBOOK IS USED
C----------------------------------------------------------------------
      END

C----------------------------------------------------------------------
      SUBROUTINE PYABEG
C     USER''S ROUTINE FOR INITIALIZATION
C----------------------------------------------------------------------
      implicit none
      include 'reweight0.inc'
c
c     The type suffix of the histogram title, with syntax
c     |T@<type_name> is semantic in the HwU format. It allows for
c     various filtering when using the histogram.py module
c     (see comment at the beginning of this file).
c     It is in general a good idea to keep the same title for the
c     same observable (if they use the same range) and differentiate
c     them only using the type suffix.
c
      character*8 HwUtype(2)
      data HwUtype/'|T@NOCUT','|T@CUT  '/
      integer i,kk,l
      character*5 cc(2)
      data cc/'     ','Born '/
      integer nwgt,max_weight,nwgt_analysis
      common/cnwgt/nwgt
      common/c_analysis/nwgt_analysis
      parameter (max_weight=maxscales*maxscales+maxpdfs+1)
      character*15 weights_info(max_weight)
      common/cwgtsinfo/weights_info
c Initialize histograms
      call HwU_inithist(nwgt,weights_info)
c Set method for error estimation to '0', i.e., use Poisson statistics
c for the uncertainty estimate
      call set_error_estimation(0)
      nwgt_analysis=nwgt
      do i=1,1
       l=(i-1)*1
       call HwU_book(l+1,'total rate      '//HwUtype(i),2,0.d0,2.d0)
      enddo

      END

C----------------------------------------------------------------------
      SUBROUTINE PYAEND(IEVT)
C     USER''S ROUTINE FOR TERMINAL CALCULATIONS, HISTOGRAM OUTPUT, ETC
C----------------------------------------------------------------------
      REAL*8 XNORM
      INTEGER I,KK,l,nwgt_analysis
      integer NPL
      parameter(NPL=15000)
      common/c_analysis/nwgt_analysis
c Collect accumulated results.
      xnorm=1d0
      call finalize_histograms(ievt)
c Write the histograms to disk.
      open (unit=99,file='MADatNLO.HwU',status='unknown')
      call HwU_output(99,xnorm)
      close (99)
      END

C----------------------------------------------------------------------
      SUBROUTINE PYANAL
C     USER''S ROUTINE TO ANALYSE DATA FROM EVENT
C----------------------------------------------------------------------
      implicit double precision(a-h, o-z)
      implicit integer(i-n)
      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
      include 'reweight0.inc'
      INTEGER KK,i,l
      real*8 tot
      data tot/0.5d0/
      integer nwgt_analysis,max_weight
      common/c_analysis/nwgt_analysis
      parameter (max_weight=maxscales*maxscales+maxpdfs+1)
      double precision ww(max_weight),www(max_weight)
      common/cww/ww
c
      DOUBLE PRECISION EVWEIGHT
      COMMON/CEVWEIGHT/EVWEIGHT
      INTEGER IFAIL
      COMMON/CIFAIL/IFAIL

      IF(IFAIL.EQ.1)RETURN
      IF (WW(1).EQ.0D0) THEN
         WRITE(*,*)'WW(1) = 0. Stopping'
         STOP
      ENDIF
c
C INCOMING PARTONS MAY TRAVEL IN THE SAME DIRECTION: IT''S A POWER-SUPPRESSED
C EFFECT, SO THROW THE EVENT AWAY
      IF(SIGN(1.D0,P(3,3)).EQ.SIGN(1.D0,P(4,3)))THEN
         WRITE(*,*)'WARNING 111 IN PYANAL'
        GOTO 999
      ENDIF
      DO I=1,nwgt_analysis
         WWW(I)=EVWEIGHT*ww(i)/ww(1)
      ENDDO
C
      do i=1,1
         l=(i-1)*1
         call HwU_fill(l+1,tot,WWW)
      enddo
      call HwU_add_points
C
 999  END


        LOGICAL FUNCTION PROMPTGRID()

C***********************************************************************
C Version "$Id: promptgrid.f 1 2017-06-10 18:05:20Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (C) 2003-2013 Baron Advanced Meteorological Systems,
C (C) 2007-2013 Carlie J. Coats, Jr., and
C (C) 2014 UNC Institute for the Environment.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  function body starts at line 52
C
C  RETURNS:  TRUE iff success
C
C  FUNCTION:
C       Prompts user repeatedly for grid/coordinate system name, then
C       uses DSCGRID or DSCOORD to put grid/coordinate system description
C       into FDESC3.EXT data structures.
C
C  PRECONDITIONS REQUIRED:
C       Valid GRIDDESC file
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C       DSCOORD, DSCGRID, GETSTR, GETYN, M3WARN
C
C  REVISION  HISTORY:
C       prototype 11/95 by CJC
C       Modified 03/2010 by CJC: F9x changes for I/O API v3.1
C***********************************************************************

      IMPLICIT NONE

C...........   INCLUDES:

      INCLUDE 'PARMS3.EXT'      ! I/O API constants
      INCLUDE 'FDESC3.EXT'      ! I/O API file description data structure

C...........   EXTERNAL FUNCTIONS and their descriptions:

        LOGICAL, EXTERNAL :: DSCOORD, DSCGRID, GETYN

C...........   Local Variables:

        CHARACTER*16  	ANAME, CNAME

C***********************************************************************
C   begin body of function  PROMPTGRID

11      CONTINUE

            CALL GETSTR( 'Enter name for output coordinate system',
     &                   'UTM_17', GDNAM3D )

            IF ( DSCOORD( GDNAM3D, GDTYP3D,
     &                          P_ALP3D, P_BET3D, P_GAM3D,
     &                          XCENT3D, YCENT3D ) ) THEN

                XORIG3D = DBLE( BADVAL3 )
                YORIG3D = DBLE( BADVAL3 )
                XCELL3D = DBLE( BADVAL3 )
                YCELL3D = DBLE( BADVAL3 )
                NCOLS3D = IMISS3
                NROWS3D = IMISS3
                NTHIK3D = IMISS3

                PROMPTGRID = .TRUE.

            ELSE IF ( DSCGRID( GDNAM3D, ANAME, GDTYP3D,     !  retry with dscgrid()
     &                         P_ALP3D, P_BET3D, P_GAM3D,
     &                         XCENT3D, YCENT3D, XORIG3D, YORIG3D,
     &                         XCELL3D, YCELL3D,
     &                         NCOLS3D, NROWS3D, NTHIK3D ) ) THEN

                PROMPTGRID = .TRUE.

            ELSE

                WRITE( *,'( 5X, A )' )
     &              'Could not get description for coordinate system "'
     &              // TRIM( CNAME ) // '"'

                IF ( GETYN( 'Try again?', .TRUE. ) ) THEN
                    GO TO  11
                ELSE
                    CALL M3EXIT( 'PROMPTGRID', 0, 0,
     &                           'Bad grid/coordinate system', 2 )
                END IF      !  if retry getstr() or not

            END IF          !  if dscoord() failed; end of loop

        GDNAM3D = CNAME

        RETURN

        END FUNCTION PROMPTGRID


!GFORTRAN subroutine lfmregrid_sub(nx_bg,ny_bg,nzbg,nzbg_tp,nzbg_sh,nzbg_uv,nzbg_ww,fname_in,NX_L,NY_L,NZ_L,gproj,bgmodel,cmodel,laps_data_root,mtype,laps_reftime,laps_valtime,l_process_grib,l_process_cdf,l_grib_fua,l_grib_fsf,l_cdf_fua,l_cdf_fsf)
!GFORTRAN modifications begin
subroutine lfmregrid_sub(nx_bg,ny_bg,nzbg,nzbg_tp,nzbg_sh,nzbg_uv,nzbg_ww,&
                         fname_in,NX_L,NY_L,NZ_L,gproj,bgmodel,cmodel,&
                         laps_data_root,mtype,laps_reftime,laps_valtime,&
                         l_process_grib,l_process_cdf,l_grib_fua,l_grib_fsf,&
                         l_cdf_fua,l_cdf_fsf)
!GFORTRAN modifications end

!use mem_namelist
use storage_module, ONLY: get_plvls
integer, parameter :: maxbglvl = 52 ! Dimension is maxbglvl in 'degrib_nav' routine

character*256 fname_in, fullname_in, laps_data_root, fname_bg, bgpath
character*132 cmodel
character*4 af_bg
character*2   gproj
character*256 syscmd
character*30 mtype

integer bgmodel

integer ct,n2df,n3df
parameter (n2df = 11)
parameter (n3df = 4)

real sgrid(NX_L,NY_L,n2df)
real pgrid(NX_L,NY_L,n3df*NZ_L)
character*132 com2d(n2df)
character*132 com3d(n3df*NZ_L)
character*3 name2d(n2df)
character*3 name3d(n3df*NZ_L)
integer lvls3d(n3df*NZ_L)  ! mb for pressure grid

real pres_1d(NZ_L) ! pa
real pr1d_pa(NZ_L) ! pa
real pr1d_mb(NZ_L) ! mb

! *** Background model grid data.
!
real  prbght(nx_bg,ny_bg,nzbg) !Pressure (mb) ht and temp
real  prbgsh(nx_bg,ny_bg,nzbg) !Pressure (mb) q
real  prbguv(nx_bg,ny_bg,nzbg) !Pressure (mb) u- v-components
real  prbgww(nx_bg,ny_bg,nzbg) !Pressure (mb) omega
real  pr(nzbg)

real  htbg(nx_bg,ny_bg,nzbg)   !Height (m)
real  tpbg(nx_bg,ny_bg,nzbg)   !Temperature (K)
real  shbg(nx_bg,ny_bg,nzbg)   !Specific humidity (kg/kg)
real  tdbg(nx_bg,ny_bg,nzbg)   !Dewpoint (K)
real  uwbg(nx_bg,ny_bg,nzbg)   !U-wind (m/s)
real  vwbg(nx_bg,ny_bg,nzbg)   !V-wind (m/s)
real  wwbg(nx_bg,ny_bg,nzbg)   !W-wind (pa/s)
real plvl_grib(maxbglvl) ! Dimension is maxbglvl in 'degrib_nav' routine

real  mslpbg(nx_bg,ny_bg)         !mslp  (mb)
real  htbg_sfc(nx_bg,ny_bg)
real  prbg_sfc(nx_bg,ny_bg)
real  shbg_sfc(nx_bg,ny_bg)       !Specific humidity (kg/kg)
real  uwbg_sfc(nx_bg,ny_bg)
real  vwbg_sfc(nx_bg,ny_bg)
real  tdbg_sfc(nx_bg,ny_bg)
real  tpbg_sfc(nx_bg,ny_bg)
real  t_at_sfc(nx_bg,ny_bg)
real  pcpbg(nx_bg,ny_bg)          !Precip at surface, ACPC (k/m^2)

!     Local input model variables for the time being
real r01(nx_bg,ny_bg)
real lmr(nx_bg,ny_bg)
real llr(nx_bg,ny_bg)
real swi(nx_bg,ny_bg)
real s8a(nx_bg,ny_bg)
real tpw(nx_bg,ny_bg)

real htvi(nx_bg,ny_bg,NZ_L)
real tpvi(nx_bg,ny_bg,NZ_L)
real shvi(nx_bg,ny_bg,NZ_L)
real uwvi(nx_bg,ny_bg,NZ_L)
real vwvi(nx_bg,ny_bg,NZ_L)
real wwvi(nx_bg,ny_bg,NZ_L)

real lat(NX_L,NY_L)         ! LAPS lat
real lon(NX_L,NY_L)         ! LAPS lon
real topo(NX_L,NY_L)        ! LAPS lon
real grx(NX_L,NY_L)         ! hinterp factor (background grid x index)
real gry(NX_L,NY_L)         ! hinterp factor (background grid y index)
real lmr_laps(NX_L,NY_L)
real tsf_laps(NX_L,NY_L)
real dsf_laps(NX_L,NY_L)
real psf_laps(NX_L,NY_L)
real usf_laps(NX_L,NY_L)
real vsf_laps(NX_L,NY_L)
real swi_laps(NX_L,NY_L)
real s8a_laps(NX_L,NY_L)
real tpw_laps(NX_L,NY_L)
real rto_laps(NX_L,NY_L)
real r01_laps(NX_L,NY_L)

real ssh, k_to_c

logical wrapped, l_process_grib, l_process_cdf
logical     l_grib_fua,l_grib_fsf,l_cdf_fua,l_cdf_fsf

write(6,*)
write(6,*)' Subroutine lfmregrid_sub...'
write(6,*)' nx_bg/ny_bg = ',nx_bg,ny_bg
write(6,*)' cmodel = ',cmodel

write(6,*)' l_grib_fua,l_grib_fsf,l_cdf_fua,l_cdf_fsf:', l_grib_fua,l_grib_fsf,l_cdf_fua,l_cdf_fsf

call get_laps_domain(NX_L,NY_L,'nest7grid' &
                    ,lat,lon,topo,istatus)
if (istatus.lt.1)then
    print *,'Error reading lat, lon, topo data from get_laps_domain'
    stop
endif

call get_pres_1d(i4_valtime,NZ_L,pr1d_pa,istatus)
if(istatus.ne.1)then
   print*,'Error returned from get_pres_1d'
   print*,'Check pressures.nl or nk_laps in nest7grid.parms'
   stop
endif
pr1d_mb(:)=pr1d_pa(:)/100.  ! Pa to mb

if(l_process_grib .eqv. .true.)then
!   bgmodel = 13
!   if(mtype .eq. 'nam')then
!       cmodel = 'NAM'
!   else
!       cmodel = 'HRRR'
!   endif
!   write(6,*)' calling get_bkgd_mdl_info for cmodel: ',trim(cmodel)
!   call get_bkgd_mdl_info(bgmodel,cmodel,fname_in  &
!     ,nx_bg,ny_bg,nzbg,nzbg_tp,nzbg_sh,nzbg_uv,nzbg_ww &
!     ,gproj,dlat,dlon,centrallat,centrallon,dxbg,dybg &
!     ,Lat0,Lat1,Lon0,sw,ne,cgrddef,istatus)

    if(.true.)then
        call get_basename(fname_in,fname_bg)
        call get_directory_length(fname_in,lend)
        bgpath=fname_in(1:lend)
        af_bg=fname_bg(10:13)
        write(6,*)' calling read_bgdata: dims are ',nx_bg,ny_bg,nzbg,nzbg_tp,nzbg_sh,nzbg_uv,nzbg_ww
        call read_bgdata(nx_bg,ny_bg, &
           nzbg,nzbg_tp,nzbg_sh,nzbg_uv,nzbg_ww,'lapsb' &
          ,bgpath,fname_bg,af_bg,fname_in,cmodel,bgmodel &
          ,prbght,prbgsh,prbguv,prbgww &
          ,htbg, tpbg,uwbg,vwbg,shbg,wwbg &
          ,htbg_sfc,prbg_sfc,shbg_sfc,tdbg_sfc,tpbg_sfc &
          ,t_at_sfc,uwbg_sfc,vwbg_sfc,mslpbg,pcpbg,lmr,tpw,swi,istatus)

        write(6,*)' returned from read_bgdata'

        istatus=ishow_timer()

        nx_pr = 1
        ny_pr = 1

        call get_plvls(plvl_grib, 100, nlvl_grib)
        write(6,*)' grib plvls info: ',nlvl_grib,plvl_grib(1:nlvl_grib)
        nzbg_ht = 0
        do k = 1,nlvl_grib
            if(plvl_grib(k) .lt. 150000)then
                nzbg_ht = nzbg_ht + 1
            endif
        enddo ! k

        write(6,*)' Reset nzbg_ht, etc. to ',nzbg_ht

        nzbg_tp=nzbg_ht
        nzbg_sh=nzbg_ht
        nzbg_uv=nzbg_ht
        nzbg_ww=nzbg_ht

        ixmin = 1
        ixmax = nx_bg
        iymin = 1
        iymax = ny_bg

        nz_laps = NZ_L
        write(6,*)' calling vinterp: dims are ',nx_bg,ny_bg,nzbg_ht,nz_laps
        call vinterp(nz_laps,nx_bg,ny_bg,nx_pr,ny_pr &
               ,ixmin,ixmax,iymin,iymax &
               ,nzbg_ht,nzbg_tp,nzbg_sh,nzbg_uv,nzbg_ww &
               ,pr1d_mb,prbght,prbgsh,prbguv,prbgww &
               ,htbg,tpbg,shbg,uwbg,vwbg,wwbg &
               ,htvi,tpvi,shvi,uwvi,vwvi,wwvi)

        nx_laps = NX_L
        ny_laps = NY_L

!       if((l_cdf_fua .eqv. .true.) .OR. (l_grib_fua .eqv. .true.))then
        if(.false.)then

        write(6,*)' calling init_hinterp'
        wrapped = .false.
        bgmodel = 0
        call init_hinterp(nx_bg,ny_bg,NX_L,NY_L,gproj, &
                          lat,lon,grx,gry,bgmodel,cmodel,wrapped)

        print*,'use bilinear_laps_3d for T ',trim(cmodel)
        call bilinear_laps_3df(grx,gry,nx_bg,ny_bg &
                              ,nx_laps,ny_laps,nz_laps,tpvi,tp)

        istatus=ishow_timer()
        print*,'use bilinear_laps_3d for Q ',trim(cmodel)
        call bilinear_laps_3df(grx,gry,nx_bg,ny_bg &
                              ,nx_laps,ny_laps,nz_laps,shvi,sh)

        endif

        if(istatus .eq. 1)then
            write(6,*)' calling write_lga'
            call write_lga(nx_laps,ny_laps,nz_laps,laps_reftime, &
                           bgvalid,cmodel,missingflag,pr1d_mb,ht,tp,sh,uw,vw,ww,istatus)
            if(istatus.ne.1)then
             print*,'Error writing lga - returning to main'
            endif

        endif
    endif
endif

if(l_process_cdf .eqv. .true.)then
!   fullname_in = trim(fname_in)//'.fsf'

    write(6,*)' Calling read_fuafsf_cdf'

!   Initialize variables
    tpw = r_missing_data

    call read_fuafsf_cdf(fname_in &
                    ,nx_bg, ny_bg, nzbg &
                    ,htbg, pr, wwbg, shbg, tpbg, uwbg, vwbg &
                    ,uwbg_sfc, vwbg_sfc, tpbg_sfc, tdbg_sfc &
                    ,prbg_sfc, mslpbg, htbg_sfc &
                    ,r01 &
                    ,pcpbg &
                    ,lmr, llr, s8a, swi, tpw &
                    ,istatus)
    if(istatus.ne.1 .AND. istatus.ne.-1)then
        print*,'Error returned: read_fuafsf_cdf'
        return
    endif

endif

! if(l_process_cdf .eqv. .true.)then
if(.true.)then
    wrapped = .false.
    bgmodel = 0

    write(6,*)' Calling init_hinterp'

    call init_hinterp(nx_bg,ny_bg,NX_L,NY_L,gproj, &
                  lat,lon,grx,gry,bgmodel,cmodel,wrapped)

    if((l_grib_fua .eqv. .true.) .OR. (l_cdf_fua .eqv. .true.))then
        call get_pres_1d(i4_valtime,NZ_L,pres_1d,istatus)
        lz = NZ_L
        ct=1

        print*,'use bilinear_laps_3df for T3 starting at pgrid level',ct
        call bilinear_laps_3df(grx,gry,nx_bg,ny_bg &
                              ,NX_L,NY_L,NZ_L,tpbg,pgrid(1,1,ct))
        name3d(ct:ct+lz-1)='T3 '; com3d(ct:ct+lz-1)='Temperature'; lvls3d(ct:ct+lz-1)=nint(pres_1d(lz:1:-1)/100.); ct=ct+lz

        if(trim(cmodel) .eq. 'HRRR')then
!         Convert sh from dpt into actual sh
          itesth = 1; jtesth = 1
          itestl = 506; jtestl = 128
          if(NX_L .gt. itestl .and. NY_L .gt. jtestl)then ! DFW LAPS grid location (HWT domain)
              itesth = nint(grx(506,128))
              jtesth = nint(gry(506,128))
              write(6,*)' Convert sh from dpt to actual sh at lat/lon ',lat(itestl,jtestl),lon(itestl,jtestl)
              write(6,*)' LAPS gridpt',itestl,jtestl,' HRRR gridpt',itesth,jtesth
          endif

          do k = 1,NZ_L
            kflip = (NZ_L+1) - k
            p_mb = pres_1d(kflip) / 100.
            do i = 1,nx_bg
            do j = 1,ny_bg
                sh_orig = shbg(i,j,k)
                td_c = k_to_c(shbg(i,j,k))
                shbg(i,j,k) = ssh(p_mb,td_c) / 1000.
                if(i .eq. itesth .and. j .eq. jtesth)then
                    write(6,11)p_mb,tpbg(i,j,k),sh_orig,td_c,shbg(i,j,k)
                endif
11              format(' p,t,sh_orig,td_c,sh: ',4f10.3,f10.4)
            enddo ! j
            enddo ! i
          enddo ! k
        endif

        istatus=ishow_timer()

        print*,'use bilinear_laps_3df for SH starting at pgrid level',ct
        write(6,*)shbg(1,1,:)
        call bilinear_laps_3df(grx,gry,nx_bg,ny_bg &
                              ,NX_L,NY_L,NZ_L,shbg,pgrid(1,1,ct))
        write(6,*)pgrid(1,1,ct:ct+lz-1)
        name3d(ct:ct+lz-1)='SH '; com3d(ct:ct+lz-1)='Specific Humidity'; lvls3d(ct:ct+lz-1)=nint(pres_1d(lz:1:-1)/100.); ct=ct+lz

        istatus=ishow_timer()

        print*,'use bilinear_laps_3df for U3 starting at pgrid level',ct
        call bilinear_laps_3df(grx,gry,nx_bg,ny_bg &
                              ,NX_L,NY_L,NZ_L,uwbg,pgrid(1,1,ct))
        name3d(ct:ct+lz-1)='U3 '; com3d(ct:ct+lz-1)='U-component Wind'; lvls3d(ct:ct+lz-1)=nint(pres_1d(lz:1:-1)/100.); ct=ct+lz

        istatus=ishow_timer()

        print*,'use bilinear_laps_3df for V3 starting at pgrid level',ct
        call bilinear_laps_3df(grx,gry,nx_bg,ny_bg &
                              ,NX_L,NY_L,NZ_L,vwbg,pgrid(1,1,ct))
        name3d(ct:ct+lz-1)='V3 '; com3d(ct:ct+lz-1)='V-component Wind'; lvls3d(ct:ct+lz-1)=nint(pres_1d(lz:1:-1)/100.); ct=ct+lz

        istatus=ishow_timer()

    else
        write(6,*)' Skip 3D interpolation - FUA processing set to FALSE'

    endif

    if(.false.)then

        write(6,*)' Calling hinterp_field_2d for lmr'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                              grx,gry,lmr,lmr_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for tsf'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                              grx,gry,tpbg_sfc,tsf_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for dsf'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                              grx,gry,tdbg_sfc,dsf_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for psf'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                              grx,gry,prbg_sfc,psf_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for usf'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                              grx,gry,uwbg_sfc,usf_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for vsf'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                              grx,gry,vwbg_sfc,vsf_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for swi'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                             grx,gry,swi,swi_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for rto'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                             grx,gry,pcpbg,rto_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for r01'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                             grx,gry,pcpbg,r01_laps,wrapped)

        write(6,*)' Calling hinterp_field_2d for tpw'
        call hinterp_field_2d(nx_bg,ny_bg,NX_L,NY_L,1, &
                             grx,gry,tpw,tpw_laps,wrapped)

    else

        write(6,*)' Calling bilinear_laps_2d for lmr'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,lmr,lmr_laps)

        write(6,*)' Calling bilinear_laps_2d for tsf'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,tpbg_sfc,tsf_laps)

        write(6,*)' Calling bilinear_laps_2d for dsf'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,tdbg_sfc,dsf_laps)

        write(6,*)' Calling bilinear_laps_2d for psf'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,prbg_sfc,psf_laps)

        write(6,*)' Calling bilinear_laps_2d for usf'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,uwbg_sfc,usf_laps)

        write(6,*)' Calling bilinear_laps_2d for vsf'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,vwbg_sfc,vsf_laps)

        write(6,*)' Calling bilinear_laps_2d for swi'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,swi,swi_laps)

        write(6,*)' Calling bilinear_laps_2d for rto'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,pcpbg,rto_laps)

        write(6,*)' Calling bilinear_laps_2d for r01'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,pcpbg,r01_laps)

        write(6,*)' Calling bilinear_laps_2d for tpw'
        call bilinear_laps_2d(grx,gry,nx_bg,ny_bg,NX_L,NY_L,tpw,tpw_laps)

    endif

    s8a_laps = r_missing_data

    where (rto_laps(:,:) .ne. r_missing_data)
        rto_laps(:,:) = rto_laps(:,:) / 1000.
    endwhere
    where (r01_laps(:,:) .ne. r_missing_data)
        r01_laps(:,:) = r01_laps(:,:) / 1000.
    endwhere
    where (tpw_laps(:,:) .ne. r_missing_data)
        tpw_laps(:,:) = tpw_laps(:,:) / 1000.
    endwhere

    write(6,*)' lmr ranges: ',minval(lmr),maxval(lmr),minval(lmr_laps),maxval(lmr_laps)
    write(6,*)' tsf ranges: ',minval(tpbg_sfc),maxval(tpbg_sfc),minval(tsf_laps),maxval(tsf_laps)
    write(6,*)' dsf ranges: ',minval(tdbg_sfc),maxval(tdbg_sfc),minval(dsf_laps),maxval(dsf_laps)
    write(6,*)' psf ranges: ',minval(prbg_sfc),maxval(prbg_sfc),minval(psf_laps),maxval(psf_laps)
    write(6,*)' usf ranges: ',minval(uwbg_sfc),maxval(uwbg_sfc),minval(usf_laps),maxval(usf_laps)
    write(6,*)' vsf ranges: ',minval(vwbg_sfc),maxval(vwbg_sfc),minval(vsf_laps),maxval(vsf_laps)
    write(6,*)' swi ranges: ',minval(swi),maxval(swi),minval(swi_laps),maxval(swi_laps)
    write(6,*)' s8a ranges: ',minval(s8a),maxval(s8a),minval(s8a_laps),maxval(s8a_laps)
    write(6,*)' rto ranges: ',minval(pcpbg),maxval(pcpbg),minval(rto_laps),maxval(rto_laps)
    write(6,*)' r01 ranges: ',minval(r01),maxval(r01),minval(r01_laps),maxval(r01_laps)
    write(6,*)' tpw ranges: ',minval(tpw),maxval(tpw),minval(tpw_laps),maxval(tpw_laps)

    write(6,*)' Setup output arrays'
    ct=1
    sgrid(1:NX_L,1:NY_L,ct) = lmr_laps; name2d(ct)='LMR'; com2d(ct)='Composite Reflectivity'     ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = tsf_laps; name2d(ct)='TSF'; com2d(ct)='Sfc Temperature'            ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = dsf_laps; name2d(ct)='DSF'; com2d(ct)='Sfc Dewpoint Temperature'   ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = psf_laps; name2d(ct)='PSF'; com2d(ct)='Surface Pressure'           ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = usf_laps; name2d(ct)='USF'; com2d(ct)='Sfc U-Component Wind'       ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = vsf_laps; name2d(ct)='VSF'; com2d(ct)='Sfc V-Component Wind'       ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = swi_laps; name2d(ct)='SWI'; com2d(ct)='Incoming SW Radiation'      ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = s8a_laps; name2d(ct)='S8A'; com2d(ct)='11u Brightness Temperature' ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = rto_laps; name2d(ct)='RTO'; com2d(ct)='Run Total Precip Accum'     ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = r01_laps; name2d(ct)='R01'; com2d(ct)='Incremental Precip Accum'   ; ct=ct+1
    sgrid(1:NX_L,1:NY_L,ct) = tpw_laps; name2d(ct)='TPW'; com2d(ct)='Precipitable Water Depth'   ; ct=ct+1

    if(ct-1 .ne. n2df)then
        write(6,*)' ERROR in lfmregrid_sub: value of ct is inconsistent with n2df ',ct,n2df
    endif

!   if(n3df .eq. 0)NZ_L = 1
!   syscmd = 'rm -f '//trim(fullname_in)
!   call system (syscmd)

    write(6,*)
    write(6,*)' Calling output_laps_rg: NX_L,NY_L,NZ_L is ',NX_L,NY_L,NZ_L
    write(6,*)' laps_data_root is: ',laps_data_root
    write(6,*)' pgrid is ',pgrid(1,1,:)
!GFORTRAN    call output_laps_rg(laps_data_root,mtype,domnum_in,laps_reftime,laps_valtime,pgrid,sgrid,name2d,name3d,com2d,com3d,lvls3d,n2df,n3df,pres_1d,NX_L,NY_L,NZ_L)
!GFORTRAN modifications begin
    call output_laps_rg(laps_data_root,mtype,domnum_in,laps_reftime,&
                        laps_valtime,pgrid,sgrid,name2d,name3d,com2d,com3d,&
                        lvls3d,n2df,n3df,pres_1d,NX_L,NY_L,NZ_L)
!GFORTRAN modifications end

endif ! .true. (formerly l_process_cdf)

write(6,*)' End of lfmregrid_sub'

return

end

subroutine get_basename(fullname,basename)

character*(*) fullname,basename

call get_directory_length(fullname,lend)
call s_len(fullname,lenfn)

basename = fullname(lend+1:lenfn)

write(6,*)' basename = ',trim(basename)

return
end


program qlknn_test
    use qlknn_primitives
    use qlknn_disk_io
    implicit none
    integer :: n_trails, trial, verbosity, rho
    real, dimension(10,24) :: input
    real :: start, finish
    real, dimension(10) :: perturb
    real, dimension(24,7) :: qlknn_out
    namelist /test/ input
    print *, "Hello World!"
    open(10,file='test.nml',action='READ')
    read(10,nml=test)

    n_trails = 1
    verbosity = 0
#ifdef __PGI
    call load_all_nets_from_disk('/u/sim/QLKNN_networks', verbosity)
#else
    call load_all_nets_from_disk('.', verbosity)
#endif
    call cpu_time(start)
    do trial = 1,n_trails
        !perturb = 1e-1 * (/rand(), rand(), rand(), rand(), rand(), rand(), rand(), rand(), rand(), rand()/)
        !do rho = 1, 24
        !    input(:, rho) = input(:, rho) + perturb
        !end do
        call evaluate_QLKNN_10D(input, nets, rotdiv_nets, qlknn_out, verbosity)
    end do
    call cpu_time(finish)
    print '("Time = ",f9.3," milliseconds.")',1e3*(finish-start)/n_trails

end program qlknn_test


Subroutine hjan1b
  Parameter (maxptn=400001, maxstr=150001)
  Parameter (dr=0.2, dt=0.2)
  Dimension dnrg1b(50), dtg1b(50)
  Dimension snrg1b(50), stg1b(50)
  Double Precision gx5, gy5, gz5, ft5, px5, py5, pz5, e5, xmass5
  Common /para1/mul
  Common /prec2/gx5(maxptn), gy5(maxptn), gz5(maxptn), ft5(maxptn), px5(maxptn), py5(maxptn), pz5(maxptn), e5(maxptn), xmass5(maxptn), ityp5(maxptn)
  Common /ilist8/lstrg1(maxptn), lpart1(maxptn)
  Common /srec1/nsp, nst, nsi
  Common /hjcrdn/yp(3, 300), yt(3, 300)
  Common /hjjet2/nsg, njsg(maxstr), iasg(maxstr, 3), k1sg(maxstr, 100), k2sg(maxstr, 100), pxsg(maxstr, 100), pysg(maxstr, 100), pzsg(maxstr, 100), pesg(maxstr, 100), pmsg(maxstr, 100)
  Common /arevt/iaevt, iarun, miss
  Common /arout/iout
  Save
  Data iw/0/
  If (isevt==iaevt .And. isrun==iarun) Then
    Do i = 1, 50
      dnrg1b(i) = snrg1b(i)
      dtg1b(i) = stg1b(i)
    End Do
  Else
    Do i = 1, 50
      snrg1b(i) = dnrg1b(i)
      stg1b(i) = dtg1b(i)
    End Do
    isevt = iaevt
    isrun = iarun
    iw = iw + 1
  End If
  Do i = 1, mul
    j = lstrg1(i)
    If (j<=nsp) Then
      k = j
      gx0 = yp(1, j)
      gy0 = yp(2, j)
    Else If (j<=nsp+nst) Then
      k = j - nsp
      gx0 = yt(1, k)
      gy0 = yt(2, k)
    Else
      k = j - nsp - nst
      gx0 = 0.5*(yp(1,iasg(k,1))+yt(1,iasg(k,2)))
      gy0 = 0.5*(yp(2,iasg(k,1))+yt(2,iasg(k,2)))
    End If
    r0 = sqrt((sngl(gx5(i))-gx0)**2+(sngl(gy5(i))-gy0)**2)
    ir = 1 + int(r0/dr)
    If (ir>50 .Or. ir<1) Goto 100
    dnrg1b(ir) = dnrg1b(ir) + 1.0
    100 Continue
    diff2 = sngl(ft5(i)**2-gz5(i)**2)
    If (diff2<0.) Then
      Write (6, *) '5:I,ft5,gz5,diff2=', i, ft5(i), gz5(i), diff2
      tau7 = 1E-6
    Else
      tau7 = sqrt(diff2)
    End If
    it = 1 + int(tau7/dt)
    If (it>50 .Or. it<1) Goto 200
    dtg1b(it) = dtg1b(it) + 1.0
    200 Continue
  End Do
  Return
End Subroutine hjan1b


!***********************************************************************
!                                                                      *
      SUBROUTINE MCTIN(IOPAR, JKP, NAME)
!                                                                      *
!   This routine loads  coefficients with parity and  rank specified   *
!   by KP(JKP) into the arrays ISLDR and XSLDR.  IOPAR is the parity   *
!   (+/- 1) and is determined from the sign of  KP(JKP).               *
!                                                                      *
!                                         Last revision: 28 Dec 1992   *
!   Updated by Jacek Bieron               Last revision: 10 Mar 1994   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  07:26:50   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE parameter_def,   ONLY: KEYORB, NNNW
      USE debug_C
      USE decide_C
      USE def_C
      USE foparm_C
      USE OFFD_C
      USE orb_C
      USE OSC_C
      USE mpi_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE alcnsa_I
      USE alcnta_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: IOPAR
      INTEGER, INTENT(IN) :: JKP
      CHARACTER  :: NAME(2)*24
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NFILE = 93
      INTEGER, PARAMETER :: NFILE1 = 237
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NFILE2,M,K,IBLKI,IBLKF,I,LABL,NCSF,J,nprocsd,myidd
      REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL
      LOGICAL :: AVAIL
!-----------------------------------------------
!
!   Read the data back as required by OSCL conventions
!
      NFILE2 = NFILE1 + JKP

      M = 0
      K = 0
!
      READ (NFILE2) IBLKI,IBLKF,NW,NKP,nprocsd,myidd
      READ (NFILE2) NINT
!
      DO I = 1, NINT
!
         READ (NFILE2) LABL, NCSF
!
         M = M + 1
!bieron
         IF (M >= NSDIM) CALL ALCNSA (JJA, JJB, HB1, HB2, HC1, &
            HC2, HM1, HM2, LAB, NPTR, NSDIM, 2)
         LAB(M) = LABL
!
!   Read configuration pairs and coefficients for this integral
!
    4    CONTINUE
         IF (NCSF + K > NTDIM) THEN
            CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 2)
            GO TO 4
         ENDIF
         NPTR(M) = K
         READ (NFILE2) (ISLDR(J + K),ISLDR1(J + K),XSLDR(J + K),J=1,NCSF)
!          write(*,*) (ISLDR(J+K),XSLDR(J+K),J = 1,NCSF)
         K = K + NCSF
!
      END DO
!
!   Close (and hence release) the scratch file
!
!     IF (AVAIL) THEN
!
!        CLOSE (unit=NFILE,status="DELETE")
!      ENDIF
!
      NPTR(M+1) = K
      NINTEG = M
!
      RETURN
!
  301 FORMAT(/,/,/,1X,I8,' MCT coefficients generated for rank ',I2,&
         ' and parity ',I2,/,/)
      RETURN
!
      END SUBROUTINE MCTIN


    module atp_util_mod
    use sim_tensor_mod
    use sim_util_mod
    use atp_element_mod
    use output_mod
    implicit none

    private

    public  ::  solve_incr      ! Attempt to solve one increment
    public  ::  apply_load      ! Apply the external loads
    public  ::  apply_bc        ! Apply the boundary conditions (prescribed displacements)
    public  ::  get_result      ! Get the results from the particular increment
    public  ::  gen_free_dofs   ! Obtain the free degrees of freedom for particular step
    public  ::  setup_solve_incr    ! Initiate variables for solve_incr
    public  ::  get_equilibrium_didnt_converge_count ! As name implies

    ! Parameters
    double precision, parameter :: pi = acos(-1.d0)  !Define pi

    ! Simulation variables
    integer         :: equilibrium_didnt_converge_count     ! Count number of times equilibrium did not converge
    logical         :: full_output                          ! Should the info be output every time no convergence?

    contains
    !==========================================================================================================
    !Iteration subroutines

subroutine setup_solve_incr(set_full_output)
implicit none
    logical set_full_output
    full_output = set_full_output
    equilibrium_didnt_converge_count = 0
end subroutine

!Solve one increment
subroutine solve_incr(Rpos, H0, load, disp, temp, dtemp, time, dt, free_dofs, known_dofs, gp_F, gp_s, gp_sv, gp_strain, u, du, &
    iter, niter, lconv, pnewdt, kinc, kstep, props, cmname, umat_address, nlgeom, iter_err_norm, denergy)
    use types_mod
    use umat_mod
    implicit none
        !Input/Output variables
        double precision, intent(in)    :: Rpos(:,:), H0   !Element nodal coordinates, dim = (nnod, nel) (nnod = number of nodes in element)
        double precision, intent(inout) :: load(:), disp(:) !External loads and displacements
        double precision, intent(in)    :: temp, dtemp, time(2), dt ! Time and temperature
        double precision, intent(inout) :: gp_F(:,:,:), gp_s(:,:,:), gp_sv(:,:,:), gp_strain(:,:,:)  !Values at gauss points (dim(*),ngp,nel)
        double precision, intent(inout) :: u(:), du(:)  !Displacements (uz, phi, ur1,ur2,ur3,...,urN)
        type(iter_typ)                  :: iter         ! Iteration settings
        double precision, intent(out)   :: pnewdt       ! Variable used to request shorter time step
        double precision, intent(in)    :: props(:)     ! Material parameters
        integer, intent(out)            :: niter        ! Number of iterations used
        integer, intent(in)             :: kinc, kstep  ! Current increment and step
        integer, intent(in)             :: free_dofs(:) ! List over the non-prescribed (i.e. free) degrees of freedom
        integer, intent(in)             :: known_dofs(:)! List over the degrees of freedom with known load
        logical, intent(out)            :: lconv        ! Local convergence bool
        character(len=80), intent(in)   :: cmname       ! Material name sent to umat
        procedure(umat_template),pointer:: umat_address ! Addresss to umat subroutine
        logical, intent(in)             :: nlgeom       ! Bool to determine if nonlinear geometry effects should be accounted for
        double precision, intent(in)    :: iter_err_norm(:)	!Scaling to obtain averaged stresses from the residuals
        double precision, intent(out)   :: denergy(4)   ! sse, spd, scd, rpl increment, integrated over the body (i.e. total energy, not specific)

        !Internal variables
        double precision :: K(size(u), size(u)), R(size(u))
        double precision :: error, error_old, alpha
        double precision :: Ke(size(Rpos,1)+2, size(Rpos,1)+2), Re(size(Rpos,1)+2)
        integer          :: nel, nnod, ndof_tot, k1, k2, dof(size(Rpos,1)+2)
        double precision :: gp_F0(9, size(gp_F, dim=2), size(gp_F, dim=3))
        double precision :: gp_s0(6, size(gp_s, dim=2), size(gp_s, dim=3))
        double precision :: gp_strain0(6, size(gp_strain,dim=2), size(gp_strain,dim=3))
        double precision :: u_old(size(u)), ue(size(Rpos,1)+2)
        double precision :: Rscale      ! Scale factor for the equilibrium equations
        double precision, allocatable :: gp_sv0(:,:,:)
        double precision :: elem_denergy(4)         ! sse, spd, scd, rpl increment, integrated over element

        allocate(gp_sv0(size(gp_sv,dim=1), size(gp_sv,dim=2), size(gp_sv,dim=3)))

        nnod= size(Rpos,1) !Number of nodes per element
        nel = size(Rpos,2) !Number of elements
        ndof_tot = 2 + 1+(nnod-1)*nel

        lconv = .true.

        dof(1:2) = (/1,2/) ! All elements have the axial and torsion dofs

        error_old = huge(1.d0)  ! Ensure that error is decreasing the first time, to avoid line search.
        alpha = 1.d0            ! Initial alpha line search factor

        u_old = u   !Save old u to make it possible to calculate total du as input to the next step's guess
        u = u + du  !du contains correct displacements for prescribed displacement increment

        gp_F0 = gp_F
        gp_s0 = gp_s
        gp_sv0= gp_sv
        gp_strain0 = gp_strain
        pnewdt = 1.d0
        niter = 0
        do while(.true.)
            ! Step 0: Reset values for each iteration attempt
            gp_F  = gp_F0
            gp_s  = gp_s0
            gp_sv = gp_sv0
            gp_strain = gp_strain0
            denergy = 0.d0

            R       = 0.d0
            Rscale  = 0.d0
            K       = 0.d0

            ! Step 1: Assemble system
            do k1=1,nel
                do k2=1,nnod
                    dof(k2+2) = (k2+2) + (nnod-1)*(k1-1)
                enddo

                ! Get element displacements
                ue = u(dof)

                ! Call element routine
                if (nlgeom) then
                    call element_nlgeom( Ke, Re, ue, gp_s(:,:,k1), gp_sv(:,:,k1), gp_F(:,:,k1), Rpos(:,k1), H0, &
                    kinc, kstep, k1, pnewdt, props, cmname, dtemp, temp, time, dt, umat_address, elem_denergy)
                else
                    call element_lingeom( Ke, Re, ue, gp_strain(:,:,k1), gp_s(:,:,k1), gp_sv(:,:,k1), gp_F(:,:,k1), Rpos(:,k1), H0, &
                    kinc, kstep, k1, pnewdt, props, cmname, dtemp, temp, time, dt, umat_address, elem_denergy)
                endif

                if (pnewdt<1.d0) then
                    lconv = .false.
                    exit
                endif

                K(dof,dof)  = K(dof, dof) + Ke
                R(dof)      = R(dof)      + Re
                Rscale      = Rscale + sqrt(sum((Re*iter_err_norm(dof))**2))	! Add the average stress contributions to Rscale
                denergy = denergy + elem_denergy
            enddo
            if (.not.lconv) then
                exit
            endif

            ! Apply external loads (include potential effect on stiffness if nlgeom=true)
            call apply_load(R, K, load, H0, Rpos, u, known_dofs, nlgeom)

            ! Step 2: Check residual
            if (free_dofs(1)/=-1) then
                error = sqrt(sum((R(known_dofs)*iter_err_norm(known_dofs))**2))/max(Rscale,1.d0)
            !   error = sqrt(sum(R(known_dofs)**2))
            else
                error = 0.d0
            endif

            ! Step 2: Solve increment update, depending on error
            if (error<iter%tol) then
                lconv = .true.
                exit
            elseif ((error>error_old).and.(niter>iter%ls_start)) then
                u = u - du
                alpha = alpha*iter%ls_alpha_factor
                du = alpha*du
            else !tol<error<error_old
                alpha = 1.d0
                call solve_mateq(K, R, du, lconv, free_dofs, known_dofs)

                if (.not.lconv) then
                    pnewdt = 0.5d0
                    call write_output('Could not solve matrix equation, attempting a smaller time increment', 'status', 'sim:atp')
                    lconv = .false.
                    exit
                endif
            endif

            ! Step 3: Update solution
            u = u + du
            niter = niter + 1
            error_old = error

            ! Step 4: Check for max number of iterations
            if (niter>iter%max) then
                lconv = .false.
                pnewdt = 0.75d0
                if (full_output) then
                    call write_output('Could not find equilibrum in '//int2str(iter%max)//' attempts, using smaller time step', 'status', 'sim:atp')
                else
                    equilibrium_didnt_converge_count = equilibrium_didnt_converge_count + 1
                endif
                exit
            endif
        enddo

        du = u - u_old  !Output total displacement increment

        ! Insert the previously unknown values into load/disp vectors
        call get_result(R, load, disp, H0, Rpos, u, free_dofs, known_dofs, nlgeom)

end subroutine

!Load and boundary conditions
subroutine apply_load(R, K, load, H0, Rpos, u, known_dofs, nlgeom)
    implicit none
    double precision    :: R(:), K(:,:), load(:), H0, Rpos(:,:), u(:)
    integer             :: known_dofs(:), n
    logical             :: nlgeom
    double precision    :: h, ri, ro

    n    = size(u)

    h = H0                                  ! Height
    ri = Rpos(1,1)                          ! Inner radius
    ro = Rpos(size(Rpos,1),size(Rpos,2))    ! Outer radius

    if (nlgeom) then    ! get current:
        h  = H0 + u(1)  ! height,
        ri = ri + u(3)  ! inner radius and
        ro = ro + u(n)  ! outer radius
    endif

    ! Axial force
    if (any(known_dofs==1)) then
        R(1) = R(1) - load(1)
    endif

    ! Torque
    if (any(known_dofs==2)) then
        R(2) = R(2) - load(2)
    endif

    ! Internal pressure
    if (any(known_dofs==3)) then
        R(3) = R(3) - load(3)*(2.d0*ri*pi)*h
        if (nlgeom) then
            K(3,1)  = K(3,1) - load(3)*(2.d0*ri*pi)
            K(3,3)  = K(3,3) - load(3)*(2.d0*pi)*h
        endif
    endif

    ! External pressure
    if (any(known_dofs==n)) then
        R(n) = R(n) + load(4)*(2.d0*ro*pi)*h
        if (nlgeom) then
            K(n,1)  = K(n,1) + load(4)*(2.d0*ro*pi)
            K(n,n)  = K(n,n) + load(4)*(2.d0*pi)*h
        endif
    endif

end subroutine

subroutine apply_bc(disp, disp_new, du, ctrl, disp_conv)
    implicit none
    double precision, intent(in)    :: disp(:), disp_new(:), disp_conv(:)
    integer, intent(in)             :: ctrl(:)
    double precision                :: du(:)
    integer                         :: ctrl_dofs(size(ctrl)), k1

    ctrl_dofs = (/1, 2, 3, size(du)/)

    do k1=1,4
        if (ctrl(k1)>0) then !Displacement control
            du(ctrl_dofs(k1)) = (disp_new(k1)-disp(k1))*disp_conv(k1)
        endif
    enddo

end subroutine

subroutine get_result(R, load, disp, H0, Rpos, u, free_dofs, known_dofs, nlgeom)
    implicit none
    double precision    :: R(:), load(:), disp(:), H0, Rpos(:,:), u(:)
    integer             :: free_dofs(:), known_dofs(:)
    logical             :: nlgeom
    integer             :: n, pos(4), k1
    double precision    :: h, ri, ro, disp_conv(4)

    n    = size(u)
    pos = (/1,2,3,n/)
    h = H0                                  ! Height
    ri = Rpos(1,1)                          ! Inner radius
    ro = Rpos(size(Rpos,1),size(Rpos,2))    ! Outer radius

    ! Note that this is not the same disp_conv as the globally defined (if ri<1.d-12)
    disp_conv = (/H0, 1.d0, ri, ro/)        ! Must be before nlgeom changes below.
    if (ri<1.d-12) then  ! If inner radius = 0, then strain is infinity. Hence the output is the inner displacement which should be zero!
        disp_conv(3) = huge(1.d0)
    endif

    if (nlgeom) then    ! get current:
        h  = H0 + u(1)  ! height,
        ri = ri + u(3)  ! inner radius and
        ro = ro + u(n)  ! outer radius
    endif

    ! Update outputs
    do k1 = 1,4
        if (any(free_dofs==pos(k1))) then       ! Displacement to be determined
            disp(k1) = u(pos(k1))/disp_conv(k1) ! Obtain resulting strains
        endif
        if (.not.any(known_dofs==pos(k1))) then ! Force to be determined
            if (pos(k1)<=2) then                ! Axial force or torque
                load(k1) = R(pos(k1))           ! Obtain resulting load for axial force or torque
            elseif (pos(k1)==3) then            ! Inner pressure
                if (ri<1.d-12) then             ! If inner radius is equal to zero (i.e. very small)
                    load(3) = 0.d0              ! Set load to zero
                else
                    load(3) = R(pos(k1))/(2*pi*ri*h)
                endif
            else                                ! Outer pressure
                load(4) = -R(pos(k1))/(2*pi*ro*h)
            endif
        endif
    enddo

end subroutine

!Generate free_dofs
subroutine gen_free_dofs(free_dofs, known_dofs, ndof_tot, ctrl, intpres_extstrn)
    implicit none
        integer, allocatable :: free_dofs(:)            ! The free degrees of freedom
        integer, allocatable :: known_dofs(:)           ! The degrees of freedom with known load
        integer              :: ctrl(4)                 ! The control parameters (axial, torsion, inside, outside)
        logical              :: intpres_extstrn         ! If internal pressure and external strain used with strain control
        integer              :: ctrl_dofs(4)            ! Degree of freedom for dofs directly controlled by ctrl
        integer              :: ndof_tot, nfree
        integer              :: k1, k2, k3

        nfree = ndof_tot-count(ctrl>0)  ! Get number of free dofs

        if (nfree==0) then  ! If no free degrees of freedom, we handle this special case separately!
            allocate(free_dofs(1))
            free_dofs = -1
            allocate(known_dofs, source=free_dofs)
        else
            allocate(free_dofs(nfree))
            ctrl_dofs = (/1, 2, 3, ndof_tot/)
            ! Find free dofs amongst the first specified in ctrl
            k2 = 1
            do k1 = 1,3
                if (ctrl(k1)<0) then ! Force controlled
                    free_dofs(k2) = ctrl_dofs(k1)
                    k2 = k2 + 1
                endif
            enddo

            if (k2<=nfree) then  ! There are additional dofs
                k3 = 4  ! Three dofs (axial, tors, inner are before the additional dofs)
                do k1=k2,nfree
                    free_dofs(k1) = k3
                    k3 = k3 + 1
                enddo
            endif

            ! We want sorted dofs, hence if ctrl(4)<0 then this dof should be put at the end
            ! Then the last is overwritten, but it is actually ndof_tot so the code below is not needed:
            !if (ctrl(4)<0) then
            !    free_dofs(nfree) = ndof_tot
            !endif
            ! Normally, the known_dofs (load known) corresponds to free_dofs (disp unknown)
            allocate(known_dofs, source=free_dofs)
            ! In the special case of known external pressure and external strain,
            ! with unknown internal disp and internal pressure, they are different:
            if (intpres_extstrn) then
                k1 = count(ctrl(1:2)<0)+1
                if (free_dofs(nfree)==ndof_tot) then
                    ! For special intpres_extstrn mode the external strain should be controlled
                    call write_output('For the special intpres_extstrn mode the external strain must be controlled', 'error', 'sim:atp')
                elseif (free_dofs(k1)/=3) then
                    call write_output('For the special intpres_extstrn mode the internal pressure should be set as controlled', 'error', 'sim:atp')
                endif

                known_dofs(k1:) = free_dofs(k1:)+1
            endif

        endif

end subroutine

function get_equilibrium_didnt_converge_count() result (equilibrium_didnt_converge_count_out)
implicit none
    integer equilibrium_didnt_converge_count_out
    equilibrium_didnt_converge_count_out = equilibrium_didnt_converge_count
end function

end module


!>    @brief dummy routine for gradient/adjoint generation (trick the AD tool)
!>    @param[in] icode specify the physical value
!>    @param[in] species transport species index
!>    @param[in,out] x_solution solution vector of the solved linear system, may be also the start input
!>    @param[in] errorc error
!>    @param[in] apar setup explicit or implicit solver (disabled), default 1.0
!>    @param[in] ctrl solver code
!>    @param[in] ismpl local sample index
      SUBROUTINE solve(icode,species,x_solution,errorc,apar,ctrl,ismpl)
        use arrays
        use mod_genrl
        IMPLICIT NONE
        integer :: ismpl
        DOUBLE PRECISION apar, errorc, x_solution(i0*j0*k0)
        INTEGER icode, species, ctrl
        IF (icode>=-10 .OR. species>=-100 .OR. errorc>=0.0d0 .OR. apar>=0.0d0 .OR. ctrl>=-1000) THEN
          CALL dcopy(i0*j0*k0,      w(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,a(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,b(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,c(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,d(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,e(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,f(1,1,1,ismpl),1,x_solution,1)
          CALL daxpy(i0*j0*k0,1.0d0,g(1,1,1,ismpl),1,x_solution,1)
        END IF
        RETURN
      END

!>    @brief dummy routine for time meassurement
!>    @param[out] tick time
      SUBROUTINE cpu_time(tick)
        use mod_genrl
        IMPLICIT NONE
        DOUBLE PRECISION tick
        INTRINSIC dble
        tick = dble(I0*J0*K0)
        RETURN
      END