module inversion_mod
    use inversion_utils
    use parameters, only : nx, ny, nz, dxi
    use physics, only : f_cor
    use constants, only : zero, two, f12
    use timer, only : start_timer, stop_timer
    implicit none

    integer :: vor2vel_timer,   &
               vtend_timer

    contains

        !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

        ! Given the vorticity vector field (vortg) in physical space, this
        ! returns the associated velocity field (velog) and the velocity
        ! gradient tensor (velgradg).  Note: the
        ! vorticity is modified to be solenoidal and spectrally filtered.
        subroutine vor2vel(vortg,  velog,  velgradg)
            double precision, intent(in)    :: vortg(-1:nz+1, 0:ny-1, 0:nx-1, 3)
            double precision, intent(out)   :: velog(-1:nz+1, 0:ny-1, 0:nx-1, 3)
            double precision, intent(out)   :: velgradg(-1:nz+1, 0:ny-1, 0:nx-1, 5)
            double precision                :: svelog(0:nz, 0:nx-1, 0:ny-1, 3)
            double precision                :: as(0:nz, 0:nx-1, 0:ny-1) &
                                             , bs(0:nz, 0:nx-1, 0:ny-1) &
                                             , cs(0:nz, 0:nx-1, 0:ny-1)
            double precision                :: ds(0:nz, 0:nx-1, 0:ny-1) &
                                             , es(0:nz, 0:nx-1, 0:ny-1)
            double precision                :: ubar(0:nz), vbar(0:nz)
            double precision                :: uavg, vavg
            integer                         :: iz

            call start_timer(vor2vel_timer)

            ! Copy vorticity to velocity field to perform FFT transforms
            ! (FFT transforms overwrite the input array)
            velog = vortg

            !------------------------------------------------------------------
            !Convert vorticity to semi-spectral space as (as, bs, cs): (velog is overwritten in this operation)
            call fftxyp2s(velog(0:nz, :, :, 1), as)
            call fftxyp2s(velog(0:nz, :, :, 2), bs)
            call fftxyp2s(velog(0:nz, :, :, 3), cs)

            !-------------------------------------------------------------
            ! Apply 2D Hou and Li filter:
            !$omp parallel shared(as, bs, cs, filt, nz) private(iz) default(none)
            !$omp do
            do iz = 0, nz
                as(iz, :, :) = filt * as(iz, :, :)
                bs(iz, :, :) = filt * bs(iz, :, :)
                cs(iz, :, :) = filt * cs(iz, :, :)
            enddo
            !$omp end do
            !$omp end parallel

            !Define horizontally-averaged flow by integrating horizontal vorticity:
            ubar(0) = zero
            vbar(0) = zero
            do iz = 0, nz-1
                ubar(iz+1) = ubar(iz) + dz2 * (bs(iz, 0, 0) + bs(iz+1, 0, 0))
                vbar(iz+1) = vbar(iz) - dz2 * (as(iz, 0, 0) + as(iz+1, 0, 0))
            enddo

            ! remove the mean value to have zero net momentum
            uavg = sum(ubar(1:nz-1) + f12 * ubar(nz)) / dble(nz)
            vavg = sum(vbar(1:nz-1) + f12 * vbar(nz)) / dble(nz)
            do iz = 0, nz
                ubar(iz) = ubar(iz) - uavg
                vbar(iz) = vbar(iz) - vavg
            enddo

            !Form source term for inversion of vertical velocity:
            call diffy(as, ds)
            call diffx(bs, es)

            !$omp parallel
            !$omp workshare
            ds = ds - es
            !$omp end workshare
            !$omp end parallel

            !as & bs are now free to re-use

            !Invert to find vertical velocity \hat{w} (store in ds, spectrally):
            call lapinv0(ds)

            !Find \hat{w}' (store in es, spectrally):
            call diffz(ds, es)

            !Find x velocity component \hat{u}:
            call diffx(es, as)
            call diffy(cs, bs)

            !$omp parallel do
            do iz = 0, nz
                as(iz, :, :) = k2l2i * (as(iz, :, :) + bs(iz, :, :))
            enddo
            !$omp end parallel do

            !Add horizontally-averaged flow:
            as(:, 0, 0) = ubar

            svelog(:, :, :, 1) = as

            !Get u in physical space:
            call fftxys2p(as, velog(0:nz, :, :, 1))

            !Find y velocity component \hat{v}:
            call diffy(es, as)
            call diffx(cs, bs)

            !$omp parallel do
            do iz = 0, nz
                as(iz, :, :) = k2l2i * (as(iz, :, :) - bs(iz, :, :))
            enddo
            !$omp end parallel do

            !Add horizontally-averaged flow:
            as(:, 0, 0) = vbar

            svelog(:, :, :, 2) = as

            !Get v in physical space:
            call fftxys2p(as, velog(0:nz, :, :, 2))

            svelog(:, :, :, 3) = ds

            !Get w in physical space:
            call fftxys2p(ds, velog(0:nz, :, :, 3))

            ! compute the velocity gradient tensor
            call vel2vgrad(svelog, velgradg)

            ! use extrapolation in u and v and anti-symmetry in w to fill z grid points outside domain:
            velog(-1, :, :, 1) =  two * velog(0, :, :, 1) - velog(1, :, :, 1) ! u
            velog(-1, :, :, 2) =  two * velog(0, :, :, 2) - velog(1, :, :, 2) ! v
            velog(-1, :, :, 3) = -velog(1, :, :, 3) ! w
            velog(nz+1, :, :, 1) = two * velog(nz, :, :, 1) - velog(nz-1, :, :, 1) ! u
            velog(nz+1, :, :, 2) = two * velog(nz, :, :, 2) - velog(nz-1, :, :, 2) ! v
            velog(nz+1, :, :, 3) = -velog(nz-1, :, :, 3) ! w

            call stop_timer(vor2vel_timer)

        end subroutine

        !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

        ! Compute the gridded velocity gradient tensor
        subroutine vel2vgrad(svelog, velgradg)
            double precision, intent(in)  :: svelog(0:nz, 0:nx-1, 0:ny-1, 3)
            double precision, intent(out) :: velgradg(-1:nz+1, 0:ny-1, 0:nx-1, 5)
            double precision              :: ds(0:nz, 0:nx-1, 0:ny-1) ! spectral derivatives

            ! x component:
            call diffx(svelog(:, :, :, 1), ds)         ! u_x = du/dx in spectral space
            call fftxys2p(ds, velgradg(0:nz, :, :, 1)) ! u_x in physical space

            call diffy(svelog(:, :, :, 1), ds)         ! u_y = du/dy in spectral space
            call fftxys2p(ds, velgradg(0:nz, :, :, 2)) ! u_y in physical space

            call diffx(svelog(:, :, :, 3), ds)         ! w_x = dw/dx in spectral space
            call fftxys2p(ds, velgradg(0:nz, :, :, 4)) ! w_x in physical space

            ! use extrapolation in du/dx and du/dy to fill z grid points outside domain:
            velgradg(  -1, :, :, 1) =  two * velgradg( 0, :, :, 1) - velgradg(   1, :, :, 1) ! lower boundary du/dx
            velgradg(nz+1, :, :, 1) =  two * velgradg(nz, :, :, 1) - velgradg(nz-1, :, :, 1) ! upper boundary du/dx
            velgradg(  -1, :, :, 2) =  two * velgradg( 0, :, :, 2) - velgradg(   1, :, :, 2) ! lower boundary du/dy
            velgradg(nz+1, :, :, 2) =  two * velgradg(nz, :, :, 2) - velgradg(nz-1, :, :, 2) ! upper boundary du/dy

            ! use anti-symmetry for dw/dx to fill z grid points outside domain:
            velgradg(  -1, :, :, 4) = -velgradg(   1, :, :, 4) ! lower boundary dw/dx
            velgradg(nz+1, :, :, 4) = -velgradg(nz-1, :, :, 4) ! upper boundary dw/dx

            ! y & z components:
            call diffy(svelog(:, :, :, 2), ds)         ! v_y = dv/dy in spectral space
            call fftxys2p(ds, velgradg(0:nz, :, :, 3)) ! v_y in physical space

            call diffy(svelog(:, :, :, 3), ds)         ! w_y = dw/dy in spectral space
            call fftxys2p(ds, velgradg(0:nz, :, :, 5)) ! w_y in physical space

            ! use extrapolation in dv/dy to fill z grid points outside domain:
            velgradg(  -1, :, :, 3) = two * velgradg( 0, :, :, 3) - velgradg(   1, :, :, 3) ! lower boundary dv/dy
            velgradg(nz+1, :, :, 3) = two * velgradg(nz, :, :, 3) - velgradg(nz-1, :, :, 3) ! upper boundary dv/dy

            ! use anti-symmetry in dw/dy to fill z grid points outside domain:
            ! w_y(-1) = -w_y(1) and w_y(nz+1) = -w_y(nz-1)
            velgradg(  -1, :, :, 5) = -velgradg(   1, :, :, 5) ! lower boundary dw/dy
            velgradg(nz+1, :, :, 5) = -velgradg(nz-1, :, :, 5) ! upper boundary dw/dy

        end subroutine vel2vgrad

        !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

        ! Compute the gridded vorticity tendency:
        subroutine vorticity_tendency(vortg, velog, tbuoyg, vtend)
            double precision, intent(in)  :: vortg(-1:nz+1, 0:ny-1, 0:nx-1, 3)
            double precision, intent(in)  :: velog(-1:nz+1, 0:ny-1, 0:nx-1, 3)
            double precision, intent(in)  :: tbuoyg(-1:nz+1, 0:ny-1, 0:nx-1)
            double precision, intent(out) :: vtend(-1:nz+1, 0:ny-1, 0:nx-1, 3)
            double precision              :: f(-1:nz+1, 0:ny-1, 0:nx-1, 3)

            call start_timer(vtend_timer)

            ! Eqs. 10 and 11 of MPIC paper
            f(:, : , :, 1) = (vortg(:, :, :, 1) + f_cor(1)) * velog(:, :, :, 1)
            f(:, : , :, 2) = (vortg(:, :, :, 2) + f_cor(2)) * velog(:, :, :, 1) + tbuoyg
            f(:, : , :, 3) = (vortg(:, :, :, 3) + f_cor(3)) * velog(:, :, :, 1)

            call divergence(f, vtend(0:nz, :, :, 1))

            f(:, : , :, 1) = (vortg(:, :, :, 1) + f_cor(1)) * velog(:, :, :, 2) - tbuoyg
            f(:, : , :, 2) = (vortg(:, :, :, 2) + f_cor(2)) * velog(:, :, :, 2)
            f(:, : , :, 3) = (vortg(:, :, :, 3) + f_cor(3)) * velog(:, :, :, 2)

            call divergence(f, vtend(0:nz, :, :, 2))

            f(:, : , :, 1) = (vortg(:, :, :, 1) + f_cor(1)) * velog(:, :, :, 3)
            f(:, : , :, 2) = (vortg(:, :, :, 2) + f_cor(2)) * velog(:, :, :, 3)
            f(:, : , :, 3) = (vortg(:, :, :, 3) + f_cor(3)) * velog(:, :, :, 3)

            call divergence(f, vtend(0:nz, :, :, 3))

            ! Extrapolate to halo grid points
            vtend(-1,   :, :, :) = two * vtend(0,  :, :, :) - vtend(1,    :, :, :)
            vtend(nz+1, :, :, :) = two * vtend(nz, :, :, :) - vtend(nz-1, :, :, :)

            call stop_timer(vtend_timer)

        end subroutine vorticity_tendency

        subroutine divergence(f, div)
            double precision, intent(in)  :: f(-1:nz+1, 0:ny-1, 0:nx-1, 3)
            double precision, intent(out) :: div(0:nz, 0:ny-1, 0:nx-1)
            double precision              :: df(0:nz, 0:ny-1, 0:nx-1)
            integer                       :: i

            ! calculate df/dx with central differencing
            do i = 1, nx-2
                div(0:nz, 0:ny-1, i) = f12 * dxi(1) * (f(0:nz, 0:ny-1, i+1, 1) - f(0:nz, 0:ny-1, i-1, 1))
            enddo
            div(0:nz, 0:ny-1, 0)    = f12 * dxi(1) * (f(0:nz, 0:ny-1, 1, 1) - f(0:nz, 0:ny-1, nx-1, 1))
            div(0:nz, 0:ny-1, nx-1) = f12 * dxi(1) * (f(0:nz, 0:ny-1, 0, 1) - f(0:nz, 0:ny-1, nx-2, 1))

            ! calculate df/dy with central differencing
            do i = 1, ny-2
                df(0:nz, i, 0:nx-1) = f12 * dxi(2) * (f(0:nz, i+1, 0:nx-1, 2) - f(0:nz, i-1, 0:nx-1, 2))
            enddo
            df(0:nz, 0,    0:nx-1) = f12 * dxi(2) * (f(0:nz, 1, 0:nx-1, 2) - f(0:nz, ny-1, 0:nx-1, 2))
            df(0:nz, ny-1, 0:nx-1) = f12 * dxi(2) * (f(0:nz, 0, 0:nx-1, 2) - f(0:nz, ny-2, 0:nx-1, 2))

            div = div + df

            ! calculate df/dz with central differencing
            do i = 0, nz
                df(i, 0:ny-1, 0:nx-1) = f12 * dxi(3) * (f(i+1, 0:ny-1, 0:nx-1, 3) - f(i-1, 0:ny-1, 0:nx-1, 3))
            enddo

            div = div + df

        end subroutine divergence

        !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

        ! Computes a divergent flow field (ud, vd, wd) = grad(phi) where
        ! Lap(phi) = div (given).
        subroutine diverge(div,  ud, vd, wd)
            double precision, intent(inout)  :: div(0:nz, ny, nx)
            double precision, intent(out)    :: ud(0:nz, ny, nx), vd(0:nz, ny, nx), wd(0:nz, ny, nx)
            double precision                 :: ds(0:nz, nx, ny)
            double precision                 :: us(0:nz, nx, ny), vs(0:nz, nx, ny), ws(0:nz, nx, ny)
            double precision                 :: wbar(0:nz)

            !------------------------------------------------------------------
            ! Convert phi to spectral space (in x & y) as ds:
            call fftxyp2s(div, ds)

            ! Compute the x & y-independent part of ds by integration:
            call vertint(ds(:, 1, 1), wbar)

            ! Invert Laplace's operator semi-spectrally with compact differences:
            call lapinv1(ds)

            ! Compute x derivative spectrally:
            call diffx(ds, us)

            ! Reverse FFT to define x velocity component ud:
            call fftxys2p(us, ud)

            ! Compute y derivative spectrally:
            call diffy(ds, vs)

            ! Reverse FFT to define y velocity component vd:
            call fftxys2p(vs, vd)

            ! Compute z derivative by compact differences:
            call diffz(ds, ws)

            ! Set vertical boundary values to zero
            ws(0,  :, :) = zero
            ws(nz, :, :) = zero

            ! Add on the x and y-independent part of wd:
            ws(:, 1, 1) = ws(:, 1, 1) + wbar

            ! Reverse FFT to define z velocity component wd:
            call fftxys2p(ws, wd)

        end subroutine

end module inversion_mod


module lag_traj
!$$$ module documentation block
!           .      .    .                                       .
! module:   lag_traj
!   prgmmr: meunier          org:                     date: 2009-03-11
!
! abstract:  This module contain, the trajectory model used to forecast
!            the position of superpressure balloon when used in data
!            assimilation.
!            - A model based on a Runge-Kutta (4th order)
!            algorithm is fully implemented (non-linear, linear and
!            adjoint).
!            - A model based on a Runge-Kutta (2nd order)
!            algorithm is fully implemented (non-linear, linear and
!            adjoint).
!
! module history log:
!   2009-03-11  meunier
!   2011-08-01  lueken  - replaced F90 with f90 (no machine logic),
!                         and remove double &
!
! Subroutines Included: (public)
!   - lag_initlparam : Initialisation subroutine that must be called before
!                      using the models
!
!   - lag_rk2iter_nl : Non-linear model (retrieve also the parameters needed
!                      by the tangent linear and adjoint versions
!   - lag_rk2iter_tl : Tangent linear model
!   - lag_rk2iter_ad : Adjoint model
!
! Functions Included: (public)
!
! variable definitions:
!
! Warnings:  The wind field need to be comformed to those used in lag_fields
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use constants, only: zero,one,two,rearth,pi

  ! Interpolation module
  use lag_interp, only: lag_int3d_nl,lag_int3d_tl,lag_int3d_ad

  implicit none

  private

  public:: lag_poledist,lag_trajfail

  public:: lag_stepduration,lag_iteduration
  public:: lag_rk4itenpara_r,lag_rk4itenpara_i
  public:: lag_rk2itenpara_r,lag_rk2itenpara_i

  public:: lag_initlparam
  public:: lag_d_haversin
  public:: lag_rk2iter_nl,lag_rk2iter_tl,lag_rk2iter_ad

  ! Number of parameters needed by the tangent linear model, for one step
  ! of the Runge-Kutta (4th order) trajectory model
  integer(i_kind),parameter::lag_rk4stepnpara_r=57  ! real numbers
  integer(i_kind),parameter::lag_rk4stepnpara_i=32  ! integer numbers
  ! Number of parameters needed by the tangent linear model, for one step
  ! of the Runge-Kutta (2nd order) trajectory model
  integer(i_kind),parameter::lag_rk2stepnpara_r=29  ! real numbers
  integer(i_kind),parameter::lag_rk2stepnpara_i=16  ! integer numbers

  real(r_kind)::lag_stepduration= 900.0_r_kind  ! Duration in sec. of 1 step

  real(r_kind)::lag_iteduration   ! Duration in sec. of 1 iteration (composed
                                  ! of several steps)

  ! Value used if the balloon is to close from the pole
  real(r_kind),parameter::lag_trajfail= -99999._r_kind
  ! Distance to the pole in latitude from which the trajectory is not computed
  ! anymore. (in radians).
  real(r_kind),parameter::lag_poledist= 8.72664626e-3_r_kind !(=0.5deg)

  ! Number of parameters needed by the tangent linear model, for one iteration
  ! of the Runge-Kutta (4th order) trajectory model
  integer(i_kind)::lag_rk4itenpara_r,lag_rk4itenpara_i
  ! Number of parameters needed by the tangent linear model, for one iteration
  ! of the Runge-Kutta (2nd order) trajectory model
  integer(i_kind)::lag_rk2itenpara_r,lag_rk2itenpara_i

  ! Number of steps needed to achieve one iteration
  integer(i_kind)::lag_nstepiter

  ! Array indexes for the storage of the NL RK4 model parameters
  integer(i_kind),parameter::irk4_loc_0=1
  integer(i_kind),parameter::irk4_loc_half_p =9
  integer(i_kind),parameter::irk4_loc_half_pp=17
  integer(i_kind),parameter::irk4_loc_1_p=25

  integer(i_kind),parameter::irk4_wei_0=1
  integer(i_kind),parameter::irk4_wei_half_p =9
  integer(i_kind),parameter::irk4_wei_half_pp=17
  integer(i_kind),parameter::irk4_wei_1_p=25

  integer(i_kind),parameter::irk4_ldu_0=33
  integer(i_kind),parameter::irk4_ldu_half_p =35
  integer(i_kind),parameter::irk4_ldu_half_pp=37
  integer(i_kind),parameter::irk4_ldu_1_p=39
  integer(i_kind),parameter::irk4_ldv_0=41
  integer(i_kind),parameter::irk4_ldv_half_p =43
  integer(i_kind),parameter::irk4_ldv_half_pp=45
  integer(i_kind),parameter::irk4_ldv_1_p=47

  integer(i_kind),parameter::irk4_tstep=49

  integer(i_kind),parameter::irk4_lon_0=50
  integer(i_kind),parameter::irk4_lon_half_p =52
  integer(i_kind),parameter::irk4_lon_half_pp=54
  integer(i_kind),parameter::irk4_lon_1_p=56

  ! Array indexes for the storage of the NL RK2 model parameters
  integer(i_kind),parameter::irk2_loc_0=1
  integer(i_kind),parameter::irk2_loc_1_p=9

  integer(i_kind),parameter::irk2_wei_0=1
  integer(i_kind),parameter::irk2_wei_1_p=9

  integer(i_kind),parameter::irk2_ldu_0=17
  integer(i_kind),parameter::irk2_ldu_1_p=19
  integer(i_kind),parameter::irk2_ldv_0=21
  integer(i_kind),parameter::irk2_ldv_1_p=23

  integer(i_kind),parameter::irk2_tstep=25

  integer(i_kind),parameter::irk2_lon_0=26
  integer(i_kind),parameter::irk2_lon_1_p=28

  contains

  ! ------------------------------------------------------------------------
  ! Calculate derived global variables (required before using the models
  ! for iterations)
  ! ------------------------------------------------------------------------
  subroutine lag_initlparam
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_initlparam
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    lag_nstepiter=ceiling(lag_iteduration/lag_stepduration)

    lag_rk4itenpara_r=lag_nstepiter*lag_rk4stepnpara_r
    lag_rk4itenpara_i=lag_nstepiter*lag_rk4stepnpara_i+1
    lag_rk2itenpara_r=lag_nstepiter*lag_rk2stepnpara_r
    lag_rk2itenpara_i=lag_nstepiter*lag_rk2stepnpara_i+1

  end subroutine lag_initlparam
  ! ------------------------------------------------------------------------
  ! Utility subroutine to add a lattitude/longitude deplacement to a given point
  ! given in lon/lat coordinates (check the criteria one latitude and correct
  ! the longitude to remain between 0 and 2pi)
  ! ------------------------------------------------------------------------
  subroutine add_position(lon,lat,dlon,dlat)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    add_position
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lon,lat
!    dlon,dlat
!
!   output argument list:
!    lon,lat
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),intent(inout) :: lon,lat
    real(r_kind),intent(in   ) :: dlon,dlat

    ! Check for a previous failure if m2lon
    if (dlon==lag_trajfail .or. lon==lag_trajfail .or. lat==lag_trajfail) then
       lat=lag_trajfail; lon=lag_trajfail
       return
    end if

    ! Pole crossing problem to handle first :
    if (abs(lat+dlat)< pi/two-lag_poledist) then
       lat=lat+dlat
       lon=lon+dlon
    else  ! Too close of the pole
       lat=lag_trajfail
       lon=lag_trajfail
       return
    end if

    ! Because we use radians : make longitude remain between 0 and 2pi
    do while (lon<zero)
       lon=lon+two*pi
    end do
    do while (lon>=two*pi)
       lon=lon-two*pi
    end do

  end subroutine add_position

  ! ------------------------------------------------------------------------
  ! Convert a delta_y (meters) in a delta_latitude (radians) - linear operator
  ! ------------------------------------------------------------------------
  function m2lat_tl(rv_dy)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    m2lat_tl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_dy
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! distance in meters along a latitude line
    real(r_kind),intent(in   ) :: rv_dy
    ! equivalent distance in radians
    real(r_kind)::m2lat_tl

    m2lat_tl=rv_dy/rearth
  end function m2lat_tl

  ! ------------------------------------------------------------------------
  ! Convert a delta_x (meters) in a delta_longitude (radians)
  ! ------------------------------------------------------------------------
  function m2lon_nl(rv_orig_lat,rv_dx,lspec_r)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    m2lon_nl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_orig_lat
!    rv_dx
!
!   output argument list:
!    lspec_r
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! latitude of the starting point
    real(r_kind)                      ,intent(in   ) :: rv_orig_lat
    ! distance in meters along a longitude line
    real(r_kind)                      ,intent(in   ) :: rv_dx
    ! parameters needed for the TL and adjoint (optional)
    real(r_kind),dimension(2),optional,intent(  out) :: lspec_r
    ! equivalent distance in radians
    real(r_kind)::m2lon_nl

    ! Check distance to pole
    if (abs(rv_orig_lat-pi/two)<lag_poledist .or. &
        abs(rv_orig_lat+pi/two)<lag_poledist) then
       m2lon_nl=lag_trajfail
       if (present(lspec_r)) lspec_r=zero
    end if

    ! Ok...
    m2lon_nl=rv_dx/(rearth*cos(rv_orig_lat))

    if (present(lspec_r)) then
       lspec_r(1)=one/(rearth*cos(rv_orig_lat))
       lspec_r(2)=(rv_dx/rearth)*&
          sin(rv_orig_lat)/(cos(rv_orig_lat)**2)
    end if
  end function m2lon_nl

  ! ------------------------------------------------------------------------
  ! Tangent linear version
  ! ------------------------------------------------------------------------
  function m2lon_tl(lspec_r,rv_dorig_lat,rv_dx)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    m2lon_tl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_r
!    rv_dorig_lat
!    rv_dx
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),dimension(2),intent(in   ) :: lspec_r
    real(r_kind)             ,intent(in   ) :: rv_dorig_lat
    real(r_kind)             ,intent(in   ) :: rv_dx
    real(r_kind)::m2lon_tl

    m2lon_tl=lspec_r(1)*rv_dx + lspec_r(2)*rv_dorig_lat
  end function m2lon_tl

  ! ------------------------------------------------------------------------
  ! Adjoint version
  ! ------------------------------------------------------------------------
  subroutine m2lon_ad(lspec_r,ad_m2lon_l,ad_rv_dorig_lat,ad_rv_dx)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    m2lon_ad
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_r
!    ad_m2lon_l
!    ad_rv_dorig_lat
!    ad_rv_dx
!
!   output argument list:
!    ad_rv_dorig_lat
!    ad_rv_dx
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),dimension(2),intent(in   ) :: lspec_r
    real(r_kind)             ,intent(in   ) :: ad_m2lon_l
    real(r_kind)             ,intent(inout) :: ad_rv_dorig_lat
    real(r_kind)             ,intent(inout) :: ad_rv_dx

    ad_rv_dorig_lat =ad_rv_dorig_lat+lspec_r(2)*ad_m2lon_l
    ad_rv_dx        =ad_rv_dx       +lspec_r(1)*ad_m2lon_l
  end subroutine m2lon_ad

  ! ------------------------------------------------------------------------
  ! Haversine function
  ! ------------------------------------------------------------------------
  function lag_haversin(rv_theta)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_haversin
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_theta
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),intent(in   ) :: rv_theta
    real(r_kind)::lag_haversin
    lag_haversin=sin(rv_theta/2)**2
  end function lag_haversin
  ! ------------------------------------------------------------------------
  ! Inverse-haversine function
  ! ------------------------------------------------------------------------
  function lag_haversin_inv(rv_z)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_haversin_inv
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_z
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),intent(in   )::rv_z
    real(r_kind)::lag_haversin_inv
    lag_haversin_inv=two*asin(sqrt(rv_z))
  end function lag_haversin_inv

  ! ------------------------------------------------------------------------
  ! Haversine Formula : Calculate the distance between 2 lat/lon points
  ! ------------------------------------------------------------------------
  function lag_d_haversin(rv_lon1,rv_lat1,rv_lon2,rv_lat2)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_d_haversin
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_lon1,rv_lat1,rv_lon2,rv_lat2
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),intent(in   ) :: rv_lon1,rv_lat1,rv_lon2,rv_lat2
    real(r_kind)::lag_d_haversin

    ! Detect missing values
    if(rv_lon1==lag_trajfail .or. rv_lat1==lag_trajfail .or. &
       rv_lon2==lag_trajfail .or. rv_lat2==lag_trajfail) then
       lag_d_haversin=lag_trajfail
       return
    end if

    lag_d_haversin=lag_haversin_inv( &
       lag_haversin(rv_lat1-rv_lat2) + &
       cos(rv_lat1)*cos(rv_lat2)*lag_haversin(rv_lon1-rv_lon2) &
       )*rearth
  end function lag_d_haversin

  ! ------------------------------------------------------------------------
  ! Give the distance in meters between two lattitude circles
  ! ------------------------------------------------------------------------
  function lag_d_lat(rv_lat1,rv_lat2)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_d_lat
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_lat1,rv_lat2
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),intent(in   ) :: rv_lat1,rv_lat2
    real(r_kind)::lag_d_lat

    ! Detect missing values
    if(rv_lat1==lag_trajfail .or. rv_lat2==lag_trajfail) then
       lag_d_lat=lag_trajfail
       return
    end if

    lag_d_lat=(rv_lat2-rv_lat1)*rearth
  end function lag_d_lat

  ! ------------------------------------------------------------------------
  ! Give the distance in meters between two longitude circles, given the
  ! latitude of the first point
  ! ------------------------------------------------------------------------
  function lag_d_lon(rv_lon1,rv_lon2,rv_lat1)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_d_lon
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    rv_lon1,rv_lon2,rv_lat1
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    real(r_kind),intent(in   ) :: rv_lon1,rv_lon2,rv_lat1
    real(r_kind)::lag_d_lon

    real(r_kind)::angle_diff

    ! Detect missing values
    if(rv_lon1==lag_trajfail .or. rv_lon2==lag_trajfail .or. &
       rv_lat1==lag_trajfail) then
       lag_d_lon=lag_trajfail
       return
    end if

    angle_diff=rv_lon2-rv_lon1
    if (angle_diff> pi) angle_diff=angle_diff-two*pi
    if (angle_diff<-pi) angle_diff=angle_diff+two*pi

    lag_d_lon=angle_diff*rearth*cos(rv_lat1)
  end function lag_d_lon

  ! ------------------------------------------------------------------------
  ! RK4 MODEL IMPLEMENTATION FOR ONE TIME STEP -----------------------------
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Implementation of the Runge-Kutta algorithm : Non linear
  ! ------------------------------------------------------------------------
  subroutine lag_rk4_nl(lon,lat,p,ufield,vfield,tstep,lspec_i,lspec_r)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk4_nl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lon,lat,p
!    ufield,vfield
!    tstep
!
!   output argument list:
!    lon,lat,p
!    lspec_i
!    lspec_r
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! longitude, latitude, pressure of the balloon
    real(r_kind)                                          ,intent(inout) :: lon,lat,p
    ! components of the wind fields (2nd dimension for vertical level)
    real(r_kind)   ,dimension(:,:)                        ,intent(in   ) :: ufield,vfield
    ! Time step (seconds)
    real(r_kind)                                          ,intent(in   ) :: tstep
    ! Parameters for the TL and Adjoint (optional)
    integer(i_kind),dimension(lag_rk4stepnpara_i),optional,intent(  out) :: lspec_i
    real(r_kind)   ,dimension(lag_rk4stepnpara_r),optional,intent(  out) :: lspec_r

    logical::lv_spec

    ! Calculated positions
    real(r_kind),dimension(3)::pos_half_p,pos_half_pp,pos_1_p,pos_1_pp
    ! Interpolated winds
    real(r_kind)::rv_intu_0,rv_intu_half_p,rv_intu_half_pp,rv_intu_1_p
    real(r_kind)::rv_intv_0,rv_intv_half_p,rv_intv_half_pp,rv_intv_1_p
    ! Temporary
    integer(i_kind),dimension(8) ::tmp_ispec_int
    real(r_kind)   ,dimension(10)::tmp_rspec_int
    real(r_kind)   ,dimension(2) ::tmp_rspec_lon
    real(r_kind)::dlon_tmp,dlat_tmp

    lv_spec=present(lspec_i) .and. present(lspec_r)

    ! Detect missing values
    if(lon==lag_trajfail .or. lat==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    ! 1st step of the 4th order scheme : calculate the approximate
    ! of the half-timestep position, using an explicit scheme
    if (lv_spec) then
       rv_intu_0=lag_int3d_nl(ufield,lon,lat,p,tmp_ispec_int,tmp_rspec_int)
       lspec_i(irk4_loc_0:(irk4_loc_0+7))=tmp_ispec_int
       lspec_r(irk4_wei_0:(irk4_wei_0+7))=tmp_rspec_int(1:8)
       lspec_r(irk4_ldu_0:(irk4_ldu_0+1))=tmp_rspec_int(9:10)
       rv_intv_0=lag_int3d_nl(vfield,lon,lat,p,tmp_ispec_int,tmp_rspec_int)
       lspec_r(irk4_ldv_0:(irk4_ldv_0+1))=tmp_rspec_int(9:10)
       dlat_tmp=m2lat_tl(tstep/two*rv_intv_0)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/two*rv_intu_0,tmp_rspec_lon)
       lspec_r(irk4_lon_0:(irk4_lon_0+1))=tmp_rspec_lon
    else
       rv_intu_0=lag_int3d_nl(ufield,lon,lat,p)
       rv_intv_0=lag_int3d_nl(vfield,lon,lat,p)
       dlat_tmp=m2lat_tl(tstep/two*rv_intv_0)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/two*rv_intu_0)
    end if
    pos_half_p(1)=lon; pos_half_p(2)=lat
    pos_half_p(3)=p
    call add_position(pos_half_p(1),pos_half_p(2),dlon_tmp,dlat_tmp)

    if (pos_half_p(1)==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    ! 2nd step : calculate a second approximate of the half-timestep
    ! position, using an implicit scheme (with guest given by the position
    ! previously calculated)
    if (lv_spec) then
       rv_intu_half_p=lag_int3d_nl(ufield,&
          pos_half_p(1),pos_half_p(2),pos_half_p(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_i(irk4_loc_half_p:(irk4_loc_half_p+7))=tmp_ispec_int
       lspec_r(irk4_wei_half_p:(irk4_wei_half_p+7))=tmp_rspec_int(1:8)
       lspec_r(irk4_ldu_half_p:(irk4_ldu_half_p+1))=tmp_rspec_int(9:10)
       rv_intv_half_p=lag_int3d_nl(vfield,&
          pos_half_p(1),pos_half_p(2),pos_half_p(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_r(irk4_ldv_half_p:(irk4_ldv_half_p+1))=tmp_rspec_int(9:10)
       dlat_tmp=m2lat_tl(tstep/two*rv_intv_half_p)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/two*rv_intu_half_p,tmp_rspec_lon)
       lspec_r(irk4_lon_half_p:(irk4_lon_half_p+1))=tmp_rspec_lon
    else
       rv_intu_half_p=lag_int3d_nl(ufield,&
          pos_half_p(1),pos_half_p(2),pos_half_p(3))
       rv_intv_half_p=lag_int3d_nl(vfield,&
          pos_half_p(1),pos_half_p(2),pos_half_p(3))
       dlat_tmp=m2lat_tl(tstep/two*rv_intv_half_p)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/two*rv_intu_half_p)
    end if
    pos_half_pp(1)=lon; pos_half_pp(2)=lat
    pos_half_pp(3)=p
    call add_position(pos_half_pp(1),pos_half_pp(2),dlon_tmp,dlat_tmp)

    if (pos_half_pp(1)==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    ! 3rd step : calculate the first estimate of the final position, using
    ! a midpoint rule predictor
    if (lv_spec) then
       rv_intu_half_pp=lag_int3d_nl(ufield,&
          pos_half_pp(1),pos_half_pp(2),pos_half_pp(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_i(irk4_loc_half_pp:(irk4_loc_half_pp+7))=tmp_ispec_int
       lspec_r(irk4_wei_half_pp:(irk4_wei_half_pp+7))=tmp_rspec_int(1:8)
       lspec_r(irk4_ldu_half_pp:(irk4_ldu_half_pp+1))=tmp_rspec_int(9:10)
       rv_intv_half_pp=lag_int3d_nl(vfield,&
          pos_half_pp(1),pos_half_pp(2),pos_half_pp(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_r(irk4_ldv_half_pp:(irk4_ldv_half_pp+1))=tmp_rspec_int(9:10)
       dlat_tmp=m2lat_tl(tstep*rv_intv_half_pp)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep*rv_intu_half_pp,tmp_rspec_lon)
       lspec_r(irk4_lon_half_pp:(irk4_lon_half_pp+1))=tmp_rspec_lon
    else
       rv_intu_half_pp=lag_int3d_nl(ufield,&
          pos_half_pp(1),pos_half_pp(2),pos_half_pp(3))
       rv_intv_half_pp=lag_int3d_nl(vfield,&
          pos_half_pp(1),pos_half_pp(2),pos_half_pp(3))
       dlat_tmp=m2lat_tl(tstep*rv_intv_half_pp)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep*rv_intu_half_pp)
    end if
    pos_1_p(1)=lon; pos_1_p(2)=lat
    pos_1_p(3)=p
    call add_position(pos_1_p(1),pos_1_p(2),dlon_tmp,dlat_tmp)

    if (pos_1_p(1)==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    ! Final step : calculate the final position  of the balloon using a
    ! Simpson's rules corrector
    if (lv_spec) then
       rv_intu_1_p=lag_int3d_nl(ufield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_i(irk4_loc_1_p:(irk4_loc_1_p+7))=tmp_ispec_int
       lspec_r(irk4_wei_1_p:(irk4_wei_1_p+7))=tmp_rspec_int(1:8)
       lspec_r(irk4_ldu_1_p:(irk4_ldu_1_p+1))=tmp_rspec_int(9:10)
       rv_intv_1_p=lag_int3d_nl(vfield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_r(irk4_ldv_1_p:(irk4_ldv_1_p+1))=tmp_rspec_int(9:10)
       dlat_tmp=m2lat_tl(tstep/6_r_kind*( &
          rv_intv_0 + &
          rv_intv_half_p *two + rv_intv_half_pp *two +&
          rv_intv_1_p))
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/6_r_kind*( &
          rv_intu_0 + &
          rv_intu_half_p *two + rv_intu_half_pp *two +&
          rv_intu_1_p) , tmp_rspec_lon)
       lspec_r(irk4_lon_1_p:(irk4_lon_1_p+1))=tmp_rspec_lon
    else
       rv_intu_1_p=lag_int3d_nl(ufield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3))
       rv_intv_1_p=lag_int3d_nl(vfield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3))
       dlat_tmp=m2lat_tl(tstep/6_r_kind*( &
          rv_intv_0 + &
          rv_intv_half_p *two + rv_intv_half_pp *two +&
          rv_intv_1_p))
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/6_r_kind*( &
          rv_intu_0 + &
          rv_intu_half_p *two + rv_intu_half_pp *two +&
          rv_intu_1_p))
    end if
    pos_1_pp(1)=lon; pos_1_pp(2)=lat
    pos_1_pp(3)=p
    call add_position(pos_1_pp(1),pos_1_pp(2),dlon_tmp,dlat_tmp)

    if (pos_1_pp(1)==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    !Save the time step
    if (lv_spec) lspec_r(irk4_tstep)=tstep

    ! return values
    lon=pos_1_pp(1)
    lat=pos_1_pp(2)
    p  =pos_1_pp(3)

  end subroutine lag_rk4_nl

  ! ------------------------------------------------------------------------
  ! Implementation of the Runge-Kutta algorithm-> TLM
  ! ------------------------------------------------------------------------
  subroutine lag_rk4_tl(lspec_i,lspec_r,lon,lat,p,ufield,vfield)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk4_tl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_i
!    lspec_r
!    lon,lat,p
!    ufield,vfield
!
!   output argument list:
!    lon,lat,p
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    integer(i_kind),dimension(:)  ,intent(in   ) :: lspec_i
    real(r_kind)   ,dimension(:)  ,intent(in   ) :: lspec_r
    real(r_kind)                  ,intent(inout) :: lon,lat,p
    real(r_kind)   ,dimension(:,:),intent(in   ) :: ufield,vfield

    ! Calculated positions
    real(r_kind),dimension(3)::pos_half_p,pos_half_pp,pos_1_p,pos_1_pp
    ! Interpolated winds
    real(r_kind)::rv_intu_0,rv_intu_half_p,rv_intu_half_pp,rv_intu_1_p
    real(r_kind)::rv_intv_0,rv_intv_half_p,rv_intv_half_pp,rv_intv_1_p
    ! Temporary
    integer(i_kind),dimension(8) ::tmp_ispec_int
    real(r_kind)   ,dimension(10)::tmp_rspec_int

    ! failure check
    if (lspec_r(irk4_tstep)==zero) then
       lon=zero; lat=zero; p=zero; return
    end if

    ! 1st step of the 4th order scheme : calculate the approximate
    ! of the half-timestep position, using an explicit scheme
    tmp_ispec_int      =lspec_i(irk4_loc_0:(irk4_loc_0+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_0:(irk4_wei_0+7))
    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_0:(irk4_ldu_0+1))
    rv_intu_0=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       lon,lat,ufield)
    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_0:(irk4_ldv_0+1))
    rv_intv_0=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       lon,lat,vfield)
    pos_half_p(2)=lat+m2lat_tl(lspec_r(irk4_tstep)/two*rv_intv_0)
    pos_half_p(1)=lon+m2lon_tl(lspec_r(irk4_lon_0:(irk4_lon_0+1)),&
       pos_half_p(2),lspec_r(irk4_tstep)/two*rv_intu_0)
    pos_half_p(3)=p

    ! 2nd step : calculate a second approximate of the half-timestep
    ! position, using an implicit scheme (with guest given by the position
    ! previously calculated)
    tmp_ispec_int      =lspec_i(irk4_loc_half_p:(irk4_loc_half_p+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_half_p:(irk4_wei_half_p+7))
    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_half_p:(irk4_ldu_half_p+1))
    rv_intu_half_p=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_half_p(1),pos_half_p(2),ufield)
    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_half_p:(irk4_ldv_half_p+1))
    rv_intv_half_p=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_half_p(1),pos_half_p(2),vfield)
    pos_half_pp(2)=lat+m2lat_tl(lspec_r(irk4_tstep)/two*rv_intv_half_p)
    pos_half_pp(1)=lon+m2lon_tl(lspec_r(irk4_lon_half_p:(irk4_lon_half_p+1)),&
       pos_half_pp(2),lspec_r(irk4_tstep)/two*rv_intu_half_p)
    pos_half_pp(3)=p

    ! 3rd step : calculate the first estimate of the final position, using
    ! a midpoint rule predictor
    tmp_ispec_int      =lspec_i(irk4_loc_half_pp:(irk4_loc_half_pp+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_half_pp:(irk4_wei_half_pp+7))
    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_half_pp:(irk4_ldu_half_pp+1))
    rv_intu_half_pp=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_half_pp(1),pos_half_pp(2),ufield)
    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_half_pp:(irk4_ldv_half_pp+1))
    rv_intv_half_pp=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_half_pp(1),pos_half_pp(2),vfield)
    pos_1_p(2)=lat+m2lat_tl(lspec_r(irk4_tstep)*rv_intv_half_pp)
    pos_1_p(1)=lon+m2lon_tl(lspec_r(irk4_lon_half_pp:(irk4_lon_half_pp+1)),&
       pos_1_p(2),lspec_r(irk4_tstep)*rv_intu_half_pp)
    pos_1_p(3)=p

    ! Final step : calculate the final position  of the balloon using a
    ! Simpson's rules corretor
    tmp_ispec_int      =lspec_i(irk4_loc_1_p:(irk4_loc_1_p+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_1_p:(irk4_wei_1_p+7))
    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_1_p:(irk4_ldu_1_p+1))
    rv_intu_1_p=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_1_p(1),pos_1_p(2),ufield)
    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_1_p:(irk4_ldv_1_p+1))
    rv_intv_1_p=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_1_p(1),pos_1_p(2),vfield)
    pos_1_pp(2)=lat+m2lat_tl(lspec_r(irk4_tstep)/6_r_kind*(&
       rv_intv_0 + &
       rv_intv_half_p *two + rv_intv_half_pp *two +&
       rv_intv_1_p))
    pos_1_pp(1)=lon+m2lon_tl(lspec_r(irk4_lon_1_p:(irk4_lon_1_p+1)),&
       pos_1_pp(2),lspec_r(irk4_tstep)/6_r_kind*(&
       rv_intu_0 + &
       rv_intu_half_p *two + rv_intu_half_pp *two +&
       rv_intu_1_p))
    pos_1_pp(3)=p

    ! return values
    lon=pos_1_pp(1)
    lat=pos_1_pp(2)
    p  =pos_1_pp(3)

  end subroutine lag_rk4_tl

  ! ------------------------------------------------------------------------
  ! Implementation of the Runge-Kutta algorithm-> ADJOINT
  ! ------------------------------------------------------------------------
  subroutine lag_rk4_ad(lspec_i,lspec_r,&
    ad_lon,ad_lat,ad_p,ad_ufield,ad_vfield)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk4_ad
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_i
!    lspec_r
!    ad_lon,ad_lat,ad_p
!    ad_ufield,ad_vfield
!
!   output argument list:
!    ad_lon,ad_lat,ad_p
!    ad_ufield,ad_vfield
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    use constants, only: three
    implicit none

    integer(i_kind),dimension(:)  ,intent(in   ) :: lspec_i
    real(r_kind)   ,dimension(:)  ,intent(in   ) :: lspec_r
    real(r_kind)                  ,intent(inout) :: ad_lon,ad_lat,ad_p
    real(r_kind)   ,dimension(:,:),intent(inout) :: ad_ufield,ad_vfield

    ! Calculated positions
    real(r_kind),dimension(3)::ad_pos_half_p,ad_pos_half_pp,ad_pos_1_p,ad_pos_1_pp
    ! Interpolated winds
    real(r_kind)::ad_rv_intu_0,ad_rv_intu_half_p,ad_rv_intu_half_pp,ad_rv_intu_1_p
    real(r_kind)::ad_rv_intv_0,ad_rv_intv_half_p,ad_rv_intv_half_pp,ad_rv_intv_1_p
    ! Temporary
    integer(i_kind),dimension(8) ::tmp_ispec_int
    real(r_kind)   ,dimension(10)::tmp_rspec_int
    real(r_kind)::rv_tmp

    ! failure check
    if (lspec_r(irk4_tstep)==zero) then
       return
    end if

    ! zeroing local variables
    ad_pos_half_p=zero; ad_pos_half_pp=zero
    ad_pos_1_p=zero; ad_pos_1_pp=zero
    ad_rv_intu_0=zero;
    ad_rv_intu_half_p=zero;ad_rv_intu_half_pp=zero
    ad_rv_intu_1_p=zero
    ad_rv_intv_0=zero;
    ad_rv_intv_half_p=zero;ad_rv_intv_half_pp=zero
    ad_rv_intv_1_p=zero

    ! initialising tmp values
    ad_pos_1_pp(1)=ad_lon
    ad_pos_1_pp(2)=ad_lat
    ad_pos_1_pp(3)=ad_p
    ad_lon=zero; ad_lat=zero; ad_p=zero;

    ! Final step : calculate the final position  of the balloon using a
    ! Simpson's rules corretor
    ad_p=ad_p+ad_pos_1_pp(3)

    ad_lon=ad_lon+ad_pos_1_pp(1)
    rv_tmp=zero
    call m2lon_ad(lspec_r(irk4_lon_1_p:(irk4_lon_1_p+1)),ad_pos_1_pp(1),&
       ad_pos_1_pp(2),rv_tmp)
    ad_rv_intu_0      =ad_rv_intu_0+lspec_r(irk4_tstep)/6_r_kind*rv_tmp
    ad_rv_intu_half_p =ad_rv_intu_half_p+lspec_r(irk4_tstep)/three*rv_tmp
    ad_rv_intu_half_pp=ad_rv_intu_half_pp+lspec_r(irk4_tstep)/three*rv_tmp
    ad_rv_intu_1_p    =ad_rv_intu_1_p+lspec_r(irk4_tstep)/6_r_kind*rv_tmp

    ad_lat=ad_lat+ad_pos_1_pp(2)
    ad_rv_intv_0      =ad_rv_intv_0+&
       m2lat_tl(lspec_r(irk4_tstep)/6_r_kind*ad_pos_1_pp(2))
    ad_rv_intv_half_p =ad_rv_intv_half_p+&
       m2lat_tl(lspec_r(irk4_tstep)/three*ad_pos_1_pp(2))
    ad_rv_intv_half_pp=ad_rv_intv_half_pp+&
       m2lat_tl(lspec_r(irk4_tstep)/three*ad_pos_1_pp(2))
    ad_rv_intv_1_p    =ad_rv_intv_1_p+&
       m2lat_tl(lspec_r(irk4_tstep)/6_r_kind*ad_pos_1_pp(2))

    tmp_ispec_int      =lspec_i(irk4_loc_1_p:(irk4_loc_1_p+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_1_p:(irk4_wei_1_p+7))

    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_1_p:(irk4_ldv_1_p+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intv_1_p,ad_pos_1_p(1),ad_pos_1_p(2),ad_vfield)

    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_1_p:(irk4_ldu_1_p+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intu_1_p,ad_pos_1_p(1),ad_pos_1_p(2),ad_ufield)

    ! 3rd step : calculate the first estimate of the final position, using
    ! a midpoint rule predictor
    ad_p=ad_p+ad_pos_1_p(3)

    ad_lon=ad_lon+ad_pos_1_p(1)
    rv_tmp=zero
    call m2lon_ad(lspec_r(irk4_lon_half_pp:(irk4_lon_half_pp+1)),&
       ad_pos_1_p(1),ad_pos_1_p(2),rv_tmp)
    ad_rv_intu_half_pp=ad_rv_intu_half_pp+lspec_r(irk4_tstep)*rv_tmp

    ad_lat=ad_lat+ad_pos_1_p(2)
    ad_rv_intv_half_pp=ad_rv_intv_half_pp+&
       m2lat_tl(lspec_r(irk4_tstep)*ad_pos_1_p(2))

    tmp_ispec_int      =lspec_i(irk4_loc_half_pp:(irk4_loc_half_pp+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_half_pp:(irk4_wei_half_pp+7))

    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_half_pp:(irk4_ldv_half_pp+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intv_half_pp,ad_pos_half_pp(1),ad_pos_half_pp(2),ad_vfield)

    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_half_pp:(irk4_ldu_half_pp+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intu_half_pp,ad_pos_half_pp(1),ad_pos_half_pp(2),ad_ufield)

    ! 2nd step : calculate a second approximate of the half-timestep
    ! position, using an implicit scheme (with guest given by the position
    ! previously calculated)
    ad_p=ad_p+ad_pos_half_pp(3)

    ad_lon=ad_lon+ad_pos_half_pp(1)
    rv_tmp=zero
    call m2lon_ad(lspec_r(irk4_lon_half_p:(irk4_lon_half_p+1)),&
       ad_pos_half_pp(1),ad_pos_half_pp(2),rv_tmp)
    ad_rv_intu_half_p=ad_rv_intu_half_p+lspec_r(irk4_tstep)/two*rv_tmp

    ad_lat=ad_lat+ad_pos_half_pp(2)
    ad_rv_intv_half_p=ad_rv_intv_half_p+&
       m2lat_tl(lspec_r(irk4_tstep)/two*ad_pos_half_pp(2))

    tmp_ispec_int      =lspec_i(irk4_loc_half_p:(irk4_loc_half_p+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_half_p:(irk4_wei_half_p+7))

    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_half_p:(irk4_ldv_half_p+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intv_half_p,ad_pos_half_p(1),ad_pos_half_p(2),ad_vfield)

    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_half_p:(irk4_ldu_half_p+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intu_half_p,ad_pos_half_p(1),ad_pos_half_p(2),ad_ufield)

    ! 1st step of the 4th order scheme : calculate the approximate
    ! of the half-timestep position, using an explicit scheme
    ad_p=ad_p+ad_pos_half_p(3)

    ad_lon=ad_lon+ad_pos_half_p(1)
    rv_tmp=zero
    call m2lon_ad(lspec_r(irk4_lon_0:(irk4_lon_0+1)),ad_pos_half_p(1),&
       ad_pos_half_p(2),rv_tmp)
    ad_rv_intu_0=ad_rv_intu_0+lspec_r(irk4_tstep)/two*rv_tmp

    ad_lat=ad_lat+ad_pos_half_p(2)
    ad_rv_intv_0=ad_rv_intv_0+m2lat_tl(lspec_r(irk4_tstep)/two*ad_pos_half_p(2))

    tmp_ispec_int      =lspec_i(irk4_loc_0:(irk4_loc_0+7))
    tmp_rspec_int(1:8) =lspec_r(irk4_wei_0:(irk4_wei_0+7))

    tmp_rspec_int(9:10)=lspec_r(irk4_ldv_0:(irk4_ldv_0+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intv_0,ad_lon,ad_lat,ad_vfield)

    tmp_rspec_int(9:10)=lspec_r(irk4_ldu_0:(irk4_ldu_0+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intu_0,ad_lon,ad_lat,ad_ufield)

  end subroutine lag_rk4_ad

  ! ------------------------------------------------------------------------
  ! RK2 MODEL IMPLEMENTATION FOR ONE TIME STEP -----------------------------
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Implementation of the Runge-Kutta algorithm (2nd order) : Non linear
  ! (Heun's Method)
  ! ------------------------------------------------------------------------
  subroutine lag_rk2_nl(lon,lat,p,ufield,vfield,tstep,lspec_i,lspec_r)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk2_nl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lon,lat,p
!    ufield,vfield
!    tstep
!
!   output argument list:
!    lon,lat,p
!    lspec_i
!    lspec_r
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! longitude, latitude, pressure of the balloon
    real(r_kind)                                          ,intent(inout) :: lon,lat,p
    ! components of the wind fields (2nd dimension for vertical level)
    real(r_kind)   ,dimension(:,:)                        ,intent(in   ) :: ufield,vfield
    ! Time step (seconds)
    real(r_kind)                                          ,intent(in   ) :: tstep
    ! Parameters for the TL and Adjoint (optional)
    integer(i_kind),dimension(lag_rk2stepnpara_i),optional,intent(  out) :: lspec_i
    real(r_kind)   ,dimension(lag_rk2stepnpara_r),optional,intent(  out) :: lspec_r

    logical::lv_spec

    ! Calculated positions
    real(r_kind),dimension(3)::pos_1_p,pos_1_pp
    ! Interpolated winds
    real(r_kind)::rv_intu_0,rv_intu_1_p
    real(r_kind)::rv_intv_0,rv_intv_1_p

    ! Temporary
    integer(i_kind),dimension(8) ::tmp_ispec_int
    real(r_kind)   ,dimension(10)::tmp_rspec_int
    real(r_kind)   ,dimension(2) ::tmp_rspec_lon
    real(r_kind)::dlon_tmp,dlat_tmp

    lv_spec=present(lspec_i) .and. present(lspec_r)

    ! Detect missing values
    if(lon==lag_trajfail .or. lat==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    ! 1st step of the 2nd order scheme : calculate the approximate
    ! of the final position position, using an explicit scheme
    if (lv_spec) then
       rv_intu_0=lag_int3d_nl(ufield,lon,lat,p,tmp_ispec_int,tmp_rspec_int)
       lspec_i(irk2_loc_0:(irk2_loc_0+7))=tmp_ispec_int
       lspec_r(irk2_wei_0:(irk2_wei_0+7))=tmp_rspec_int(1:8)
       lspec_r(irk2_ldu_0:(irk2_ldu_0+1))=tmp_rspec_int(9:10)
       rv_intv_0=lag_int3d_nl(vfield,lon,lat,p,tmp_ispec_int,tmp_rspec_int)
       lspec_r(irk2_ldv_0:(irk2_ldv_0+1))=tmp_rspec_int(9:10)
       dlat_tmp=m2lat_tl(tstep*rv_intv_0)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep*rv_intu_0,tmp_rspec_lon)
       lspec_r(irk2_lon_0:(irk2_lon_0+1))=tmp_rspec_lon
    else
       rv_intu_0=lag_int3d_nl(ufield,lon,lat,p)
       rv_intv_0=lag_int3d_nl(vfield,lon,lat,p)
       dlat_tmp=m2lat_tl(tstep*rv_intv_0)
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep*rv_intu_0)
    end if
    pos_1_p(1)=lon; pos_1_p(2)=lat
    pos_1_p(3)=p
    call add_position(pos_1_p(1),pos_1_p(2),dlon_tmp,dlat_tmp)

    if (pos_1_p(1)==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    ! 2nd step : calculate the first estimate of the final position, using
    ! a heun method
    if (lv_spec) then
       rv_intu_1_p=lag_int3d_nl(ufield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_i(irk2_loc_1_p:(irk2_loc_1_p+7))=tmp_ispec_int
       lspec_r(irk2_wei_1_p:(irk2_wei_1_p+7))=tmp_rspec_int(1:8)
       lspec_r(irk2_ldu_1_p:(irk2_ldu_1_p+1))=tmp_rspec_int(9:10)
       rv_intv_1_p=lag_int3d_nl(vfield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3),&
          tmp_ispec_int,tmp_rspec_int)
       lspec_r(irk2_ldv_1_p:(irk2_ldv_1_p+1))=tmp_rspec_int(9:10)
       dlat_tmp=m2lat_tl(tstep/two*(rv_intv_0+rv_intv_1_p))
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/two*(rv_intu_0+rv_intu_1_p),&
          tmp_rspec_lon)
       lspec_r(irk2_lon_1_p:(irk2_lon_1_p+1))=tmp_rspec_lon
    else
       rv_intu_1_p=lag_int3d_nl(ufield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3))
       rv_intv_1_p=lag_int3d_nl(vfield,&
          pos_1_p(1),pos_1_p(2),pos_1_p(3))
       dlat_tmp=m2lat_tl(tstep/two*(rv_intv_0+rv_intv_1_p))
       dlon_tmp=m2lon_nl(lat+dlat_tmp,tstep/two*(rv_intu_0+rv_intu_1_p))
    end if
    pos_1_pp(1)=lon; pos_1_pp(2)=lat
    pos_1_pp(3)=p
    call add_position(pos_1_pp(1),pos_1_pp(2),dlon_tmp,dlat_tmp)

    if (pos_1_pp(1)==lag_trajfail) then
       if (lv_spec) then
          lspec_i=0; lspec_r=zero
       end if
       lon=lag_trajfail; lat=lag_trajfail; return
    end if

    !Save the time step
    if (lv_spec) lspec_r(irk2_tstep)=tstep

    ! return values
    lon=pos_1_pp(1)
    lat=pos_1_pp(2)
    p  =pos_1_pp(3)

  end subroutine lag_rk2_nl

  ! ------------------------------------------------------------------------
  ! Implementation of the Runge-Kutta algorithm (2nd order) : Tangent linear
  ! (Heun's Method)
  ! ------------------------------------------------------------------------
  subroutine lag_rk2_tl(lspec_i,lspec_r,lon,lat,p,ufield,vfield)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk2_tl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_i
!    lspec_r
!    lon,lat,p
!    ufield,vfield
!
!   output argument list:
!    lon,lat,p
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! Parameters for the TL and Adjoint
    integer(i_kind),dimension(lag_rk2stepnpara_i),intent(in   ) :: lspec_i
    real(r_kind)   ,dimension(lag_rk2stepnpara_r),intent(in   ) :: lspec_r
    ! longitude, latitude, pressure of the balloon
    real(r_kind)                                 ,intent(inout) :: lon,lat,p
    ! components of the wind fields (2nd dimension for vertical level)
    real(r_kind)   ,dimension(:,:)               ,intent(in   ) :: ufield,vfield

    ! Calculated positions
    real(r_kind),dimension(3)::pos_1_p,pos_1_pp
    ! Interpolated winds
    real(r_kind)::rv_intu_0,rv_intu_1_p
    real(r_kind)::rv_intv_0,rv_intv_1_p

    ! Temporary
    integer(i_kind),dimension(8) ::tmp_ispec_int
    real(r_kind)   ,dimension(10)::tmp_rspec_int

    ! failure check
    if (lspec_r(irk2_tstep)==zero) then
       lon=zero; lat=zero; p=zero; return
    end if

    ! 1st step of the 2nd order scheme : calculate the approximate
    ! of the final position position, using an explicit scheme
    tmp_ispec_int      =lspec_i(irk2_loc_0:(irk2_loc_0+7))
    tmp_rspec_int(1:8) =lspec_r(irk2_wei_0:(irk2_wei_0+7))
    tmp_rspec_int(9:10)=lspec_r(irk2_ldu_0:(irk2_ldu_0+1))
    rv_intu_0=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       lon,lat,ufield)
    tmp_rspec_int(9:10)=lspec_r(irk2_ldv_0:(irk2_ldv_0+1))
    rv_intv_0=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       lon,lat,vfield)
    pos_1_p(2)=lat+m2lat_tl(lspec_r(irk2_tstep)*rv_intv_0)
    pos_1_p(1)=lon+m2lon_tl(lspec_r(irk2_lon_0:(irk2_lon_0+1)),&
       pos_1_p(2),lspec_r(irk2_tstep)*rv_intu_0)
    pos_1_p(3)=p

    ! 2nd step : calculate the first estimate of the final position, using
    ! a heun method
    tmp_ispec_int      =lspec_i(irk2_loc_1_p:(irk2_loc_1_p+7))
    tmp_rspec_int(1:8) =lspec_r(irk2_wei_1_p:(irk2_wei_1_p+7))
    tmp_rspec_int(9:10)=lspec_r(irk2_ldu_1_p:(irk2_ldu_1_p+1))
    rv_intu_1_p=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_1_p(1),pos_1_p(2),ufield)
    tmp_rspec_int(9:10)=lspec_r(irk2_ldv_1_p:(irk2_ldv_1_p+1))
    rv_intv_1_p=lag_int3d_tl(tmp_ispec_int,tmp_rspec_int,&
       pos_1_p(1),pos_1_p(2),vfield)
    pos_1_pp(2)=lat+m2lat_tl(lspec_r(irk2_tstep)/two*&
       (rv_intv_0+rv_intv_1_p))
    pos_1_pp(1)=lon+m2lon_tl(lspec_r(irk2_lon_1_p:(irk2_lon_1_p+1)),&
       pos_1_pp(2),lspec_r(irk2_tstep)/two*(rv_intu_0+rv_intu_1_p))
    pos_1_pp(3)=p

    ! return values
    lon=pos_1_pp(1)
    lat=pos_1_pp(2)
    p  =pos_1_pp(3)

  end subroutine lag_rk2_tl

  ! ------------------------------------------------------------------------
  ! Implementation of the Runge-Kutta algorithm (2nd order) : Adjoint
  ! (Heun's Method)
  ! ------------------------------------------------------------------------
  subroutine lag_rk2_ad(lspec_i,lspec_r,ad_lon,ad_lat,ad_p,&
    ad_ufield,ad_vfield)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk2_ad
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_i
!    lspec_r
!    ad_lon,ad_lat,ad_p
!    ad_ufield,ad_vfield
!
!   output argument list:
!    ad_lon,ad_lat,ad_p
!    ad_ufield,ad_vfield
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! Parameters for the TL and Adjoint
    integer(i_kind),dimension(lag_rk2stepnpara_i),intent(in   ) :: lspec_i
    real(r_kind)   ,dimension(lag_rk2stepnpara_r),intent(in   ) :: lspec_r
    ! longitude, latitude, pressure of the balloon
    real(r_kind)                                 ,intent(inout) :: ad_lon,ad_lat,ad_p
    ! components of the wind fields (2nd dimension for vertical level)
    real(r_kind)   ,dimension(:,:)               ,intent(inout) :: ad_ufield,ad_vfield

    ! Calculated positions
    real(r_kind),dimension(3)::ad_pos_1_p,ad_pos_1_pp
    ! Interpolated winds
    real(r_kind)::ad_rv_intu_0,ad_rv_intu_1_p
    real(r_kind)::ad_rv_intv_0,ad_rv_intv_1_p

    ! Temporary
    integer(i_kind),dimension(8) ::tmp_ispec_int
    real(r_kind)   ,dimension(10)::tmp_rspec_int
    real(r_kind)::rv_tmp

    ! failure check
    if (lspec_r(irk2_tstep)==zero) then
       return
    end if

    ! zeroing local variables
    ad_pos_1_p  =zero; ad_pos_1_pp   =zero;
    ad_rv_intu_0=zero; ad_rv_intu_1_p=zero;
    ad_rv_intv_0=zero; ad_rv_intv_1_p=zero;

    ! initialising tmp values
    ad_pos_1_pp(1)=ad_lon
    ad_pos_1_pp(2)=ad_lat
    ad_pos_1_pp(3)=ad_p
    ad_lon=zero; ad_lat=zero; ad_p=zero;

    ! 2nd step : calculate the first estimate of the final position, using
    ! a heun method
    ad_p=ad_p+ad_pos_1_pp(3)

    ad_lon=ad_lon+ad_pos_1_pp(1)
    rv_tmp=zero
    call m2lon_ad(lspec_r(irk2_lon_1_p:(irk2_lon_1_p+1)),&
       ad_pos_1_pp(1),ad_pos_1_pp(2),rv_tmp)
    ad_rv_intu_0  =ad_rv_intu_0  +lspec_r(irk2_tstep)/two*rv_tmp
    ad_rv_intu_1_p=ad_rv_intu_1_p+lspec_r(irk2_tstep)/two*rv_tmp

    ad_lat=ad_lat+ad_pos_1_pp(2)
    ad_rv_intv_0  =ad_rv_intv_0  +&
       m2lat_tl(lspec_r(irk2_tstep)/two*ad_pos_1_pp(2))
    ad_rv_intv_1_p=ad_rv_intv_1_p+&
       m2lat_tl(lspec_r(irk2_tstep)/two*ad_pos_1_pp(2))

    tmp_ispec_int      =lspec_i(irk2_loc_1_p:(irk2_loc_1_p+7))
    tmp_rspec_int(1:8) =lspec_r(irk2_wei_1_p:(irk2_wei_1_p+7))

    tmp_rspec_int(9:10)=lspec_r(irk2_ldv_1_p:(irk2_ldv_1_p+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intv_1_p,ad_pos_1_p(1),ad_pos_1_p(2),ad_vfield)

    tmp_rspec_int(9:10)=lspec_r(irk2_ldu_1_p:(irk2_ldu_1_p+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intu_1_p,ad_pos_1_p(1),ad_pos_1_p(2),ad_ufield)

    ! 1st step of the 2nd order scheme : calculate the approximate
    ! of the final position position, using an explicit scheme
    ad_p=ad_p+ad_pos_1_p(3)

    ad_lon=ad_lon+ad_pos_1_p(1)
    rv_tmp=zero
    call m2lon_ad(lspec_r(irk2_lon_0:(irk2_lon_0+1)),&
       ad_pos_1_p(1),ad_pos_1_p(2),rv_tmp)
    ad_rv_intu_0  =ad_rv_intu_0  +lspec_r(irk2_tstep)*rv_tmp

    ad_lat=ad_lat+ad_pos_1_p(2)
    ad_rv_intv_0  =ad_rv_intv_0  +&
       m2lat_tl(lspec_r(irk2_tstep)*ad_pos_1_p(2))

    tmp_ispec_int      =lspec_i(irk2_loc_0:(irk2_loc_0+7))
    tmp_rspec_int(1:8) =lspec_r(irk2_wei_0:(irk2_wei_0+7))

    tmp_rspec_int(9:10)=lspec_r(irk2_ldv_0:(irk2_ldv_0+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intv_0,ad_lon,ad_lat,ad_vfield)

    tmp_rspec_int(9:10)=lspec_r(irk2_ldu_0:(irk2_ldu_0+1))
    call lag_int3d_ad(tmp_ispec_int,tmp_rspec_int,&
       ad_rv_intu_0,ad_lon,ad_lat,ad_ufield)

  end subroutine lag_rk2_ad

  ! --------------------------------------------------------------------------
  ! RK2 MODEL IMPLEMENTATION FOR ONE ITERATION (discomposed in sev. time steps)
  ! --------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Implementation for the RK2 non linear model
  ! ------------------------------------------------------------------------
  subroutine lag_rk2iter_nl(lon,lat,p,ufield,vfield,tstep,lspec_i,lspec_r)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk2iter_nl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lon,lat,p
!    ufield,vfield
!    tstep
!
!   output argument list:
!    lon,lat,p
!    lspec_i
!    lspec_r
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    ! longitude, latitude, pressure of the balloon
    real(r_kind)                         ,intent(inout) :: lon,lat,p
    ! components of the wind fields (2nd dimension for vertical level)
    real(r_kind)   ,dimension(:,:)       ,intent(in   ) :: ufield,vfield
    ! Time step (seconds)
    real(r_kind)                         ,intent(in   ) :: tstep
    ! Parameters for the TL and Adjoint (optional)
    integer(i_kind),dimension(:),optional,intent(  out) :: lspec_i
    real(r_kind)   ,dimension(:),optional,intent(  out) :: lspec_r

    logical::lv_spec

    ! Time step for each step of the algo
    real(r_kind),dimension(:),allocatable::tstep_iter
    ! Total number of steps
    integer(i_kind)::nsteps

    integer(i_kind),dimension(:),allocatable::tmp_ispec
    real(r_kind),dimension(:),allocatable::tmp_rspec
    real(r_kind)::tstep_tmp
    integer(i_kind)::i,tmp_begin

    lv_spec=present(lspec_i) .and. present(lspec_r)

    ! determine the time step for each step
    allocate(tstep_iter(lag_nstepiter))
    tstep_iter=zero
    nsteps=0
    tstep_tmp=tstep
    do i=1,lag_nstepiter
       if (tstep_tmp>zero) then
          nsteps=nsteps+1
          if (tstep_tmp/lag_stepduration>=one) then
             tstep_iter(i)=lag_stepduration
             tstep_tmp=tstep_tmp-lag_stepduration
          else
             tstep_iter(i)=tstep_tmp
             tstep_tmp=zero
          end if
       else
          tstep_iter(i)=zero
       end if
    end do

    ! save the number of time steps and intialise parameters
    if (lv_spec) then
       lspec_i=0
       lspec_r=zero
       lspec_i(1)=nsteps
    end if

    ! run each iteration
    allocate(tmp_ispec(lag_rk2stepnpara_i))
    allocate(tmp_rspec(lag_rk2stepnpara_r))
    do i=1,nsteps
       if (lv_spec) then
          call lag_rk2_nl(lon,lat,p,ufield,vfield,tstep_iter(i),&
             tmp_ispec,tmp_rspec)
          tmp_begin=2+(i-1)*lag_rk2stepnpara_i
          lspec_i(tmp_begin:(tmp_begin+lag_rk2stepnpara_i-1))=tmp_ispec
          tmp_begin=1+(i-1)*lag_rk2stepnpara_r
          lspec_r(tmp_begin:(tmp_begin+lag_rk2stepnpara_r-1))=tmp_rspec
       else
          call lag_rk2_nl(lon,lat,p,ufield,vfield,tstep_iter(i))
       end if
       ! Failure check
       if (lon==lag_trajfail .or. lat==lag_trajfail) then
          lon=lag_trajfail; lat=lag_trajfail
          if (lv_spec) then
             lspec_i=0; lspec_r=zero
          end if
          return
       end if
    end do

    !cleaning
    deallocate(tstep_iter,tmp_ispec,tmp_rspec)

  end subroutine lag_rk2iter_nl

  ! ------------------------------------------------------------------------
  ! Implementation for the RK2 tangent-linear model
  ! ------------------------------------------------------------------------
  subroutine lag_rk2iter_tl(lspec_i,lspec_r,lon,lat,p,ufield,vfield)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk2iter_tl
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_i
!    lspec_r
!    lon,lat,p
!    ufield,vfield
!
!   output argument list:
!    lon,lat,p
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    integer(i_kind),dimension(:)  ,intent(in   ) :: lspec_i
    real(r_kind)   ,dimension(:)  ,intent(in   ) :: lspec_r
    real(r_kind)                  ,intent(inout) :: lon,lat,p
    real(r_kind)   ,dimension(:,:),intent(in   ) :: ufield,vfield

    integer(i_kind)::i,tmp_begin_i,tmp_begin_r

    ! Failure check
    if (lspec_i(1)==0) then
       lon=zero; lat=zero; p=zero;
       return
    end if

    ! run each iteration
    do i=1,lspec_i(1)
       tmp_begin_i=2+(i-1)*lag_rk2stepnpara_i
       tmp_begin_r=1+(i-1)*lag_rk2stepnpara_r
       call lag_rk2_tl(&
          lspec_i(tmp_begin_i:(tmp_begin_i+lag_rk2stepnpara_i-1)),&
          lspec_r(tmp_begin_r:(tmp_begin_r+lag_rk2stepnpara_r-1)),&
          lon,lat,p,ufield,vfield)
    end do

  end subroutine lag_rk2iter_tl

  ! ------------------------------------------------------------------------
  ! Implementation for the RK2 adjoint model
  ! ------------------------------------------------------------------------
  subroutine lag_rk2iter_ad(lspec_i,lspec_r,ad_lon,ad_lat,ad_p,ad_ufield,ad_vfield)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_rk2iter_ad
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!    lspec_i
!    lspec_r
!    ad_lon,ad_lat,ad_p
!    ad_ufield,ad_vfield
!
!   output argument list:
!    ad_lon,ad_lat,ad_p
!    ad_ufield,ad_vfield
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    integer(i_kind),dimension(:)  ,intent(in   ) :: lspec_i
    real(r_kind)   ,dimension(:)  ,intent(in   ) :: lspec_r
    real(r_kind)                  ,intent(inout) :: ad_lon,ad_lat,ad_p
    real(r_kind)   ,dimension(:,:),intent(inout) :: ad_ufield,ad_vfield

    integer(i_kind)::i,tmp_begin_i,tmp_begin_r

    ! Failure check
    if (lspec_i(1)==0) then
       return
    end if

    ! run each iteration
    do i=lspec_i(1),1,-1
       tmp_begin_i=2+(i-1)*lag_rk2stepnpara_i
       tmp_begin_r=1+(i-1)*lag_rk2stepnpara_r
       call lag_rk2_ad(&
          lspec_i(tmp_begin_i:(tmp_begin_i+lag_rk2stepnpara_i-1)),&
          lspec_r(tmp_begin_r:(tmp_begin_r+lag_rk2stepnpara_r-1)),&
          ad_lon,ad_lat,ad_p,ad_ufield,ad_vfield)
    end do

  end subroutine lag_rk2iter_ad

end module lag_traj


*****************************************************************************
*                          ORBEL_EL2XV.F
*****************************************************************************
*     PURPOSE: To compute cartesian positions and velocities given
*               central mass, ialpha ( = +1 for hyp., 0 for para. and
*               -1 for ellipse), and orbital elements.
C       input:
c            gm       ==> G times central mass (real scalar)
c	     ialpha   ==> conic section type ( see PURPOSE, integer scalar)
C	     a        ==> semi-major axis or pericentric distance if a parabola
c                          (real scalar)
c            e        ==> eccentricity (real scalar)
C            inc      ==> inclination  (real scalar)
C            capom    ==> longitude of ascending node (real scalar)
C	     omega    ==> argument of perihelion (real scalar)
C	     capm     ==> mean anomoly(real scalar)
*
c       Output:
c            x,y,z    ==>  position of object (real scalars)
c            vx,vy,vz ==>  velocity of object (real scalars)
c
*     ALGORITHM:  See Fitzpatrick "Principles of Cel. Mech."
*     REMARKS: All angles are in RADIANS
*
*     AUTHOR:  M. Duncan.
*     DATE WRITTEN:  May 11, 1992.
*     REVISIONS: May 26 - now use better Kepler solver for ellipses
*                 and hyperbolae called EHYBRID.F and FHYBRID.F
***********************************************************************

	subroutine orbel_el2xv(gm,ialpha,a,e,inc,capom,omega,capm,
     &                x,y,z,vx,vy,vz)

      include '../swift.inc'

c...  Inputs Only:
	integer ialpha
	real*8 gm,a,e,inc,capom,omega,capm

c...  Outputs:
	real*8 x,y,z,vx,vy,vz

c...  Internals:
	real*8 cape,capf,zpara,em1
	real*8 sp,cp,so,co,si,ci
	real*8 d11,d12,d13,d21,d22,d23
	real*8 scap,ccap,shcap,chcap
	real*8 sqe,sqgma,xfac1,xfac2,ri,vfac1,vfac2
        real*8 orbel_ehybrid,orbel_fhybrid,orbel_zget

c----
c...  Executable code

        if(e.lt.0.0) then
           write(*,*) ' ERROR in orbel_el2xv: e<0, setting e=0!!1'
           e = 0.0
        endif

c...    check for inconsistencies between ialpha and e
        em1 = e - 1.d0
        if(
     &     ((ialpha.eq.0) .and. (abs(em1).gt.TINY))  .or.
     &     ((ialpha.lt.0) .and. (e.gt.1.0d0))  .or.
     &     ((ialpha.gt.0) .and. (e.lt.1.0d0)) )  then
        write(*,*) 'ERROR in orbel_el2xv: ialpha and e inconsistent'
             write(*,*) '                       ialpha = ',ialpha
             write(*,*) '                            e = ',e
        endif

C Generate rotation matrices (on p. 42 of Fitzpatrick)
C
	call orbel_scget(omega,sp,cp)
	call orbel_scget(capom,so,co)
	call orbel_scget(inc,si,ci)
	d11 = cp*co - sp*so*ci
	d12 = cp*so + sp*co*ci
	d13 = sp*si
	d21 = -sp*co - cp*so*ci
	d22 = -sp*so + cp*co*ci
	d23 = cp*si

C--
C Get the other quantities depending on orbit type ( i.e. IALPHA)
C
	if (ialpha .eq. -1) then
	  cape = orbel_ehybrid(e,capm)
	  call orbel_scget(cape,scap,ccap)
	  sqe = sqrt(1.d0 -e*e)
	  sqgma = sqrt(gm*a)
	  xfac1 = a*(ccap - e)
	  xfac2 = a*sqe*scap
	  ri = 1.d0/(a*(1.d0 - e*ccap))
	  vfac1 = -ri * sqgma * scap
	  vfac2 = ri * sqgma * sqe * ccap
	endif
c--
	if (ialpha .eq. +1) then
	  capf = orbel_fhybrid(e,capm)
	  call orbel_schget(capf,shcap,chcap)
	  sqe = sqrt(e*e - 1.d0 )
	  sqgma = sqrt(gm*a)
	  xfac1 = a*(e - chcap)
	  xfac2 = a*sqe*shcap
	  ri = 1.d0/(a*(e*chcap - 1.d0))
	  vfac1 = -ri * sqgma * shcap
	  vfac2 = ri * sqgma * sqe * chcap
	endif
C--
	if (ialpha .eq. 0) then
	  zpara = orbel_zget(capm)
	  sqgma = sqrt(2.d0*gm*a)
	  xfac1 = a*(1.d0 - zpara*zpara)
	  xfac2 = 2.d0*a*zpara
	  ri = 1.d0/(a*(1.d0 + zpara*zpara))
	  vfac1 = -ri * sqgma * zpara
	  vfac2 = ri * sqgma
	endif
C--
	x =  d11*xfac1 + d21*xfac2
	y =  d12*xfac1 + d22*xfac2
	z =  d13*xfac1 + d23*xfac2
	vx = d11*vfac1 + d21*vfac2
	vy = d12*vfac1 + d22*vfac2
	vz = d13*vfac1 + d23*vfac2

	return
	end    ! orbel_el2xv

c-----------------------------------------------------------------------


!***********************************************************************
! Computes the potential evapotranspiration using the Penman-Monteith
! formulation according to Murray (1967), shown equation 13 in Irmak and others (2012)
! Irmak, Suat, Kabenge, Isa, Skaggs, K.E., and Mutiibwa, Denis, 2012
!   Trend and magnitude of changes in climate variables and reference
!   evapotranspiration over 116-yr period in the Platte River Basin,
!   central Nebraska-USA: Journal of Hydrology, V. 420-421, p. 228-244
!***********************************************************************
      MODULE PRMS_POTET_PM
        IMPLICIT NONE
        ! Local Variables
        CHARACTER(LEN=8), SAVE :: MODNAME
        !REAL, SAVE, ALLOCATABLE :: Tavgc_ante(:)
        ! Declared Parameters
        REAL, SAVE, ALLOCATABLE :: Pm_n_coef(:, :), Pm_d_coef(:, :), Crop_coef(:, :)
      END MODULE PRMS_POTET_PM

!***********************************************************************
      INTEGER FUNCTION potet_pm()
      USE PRMS_POTET_PM
      USE PRMS_MODULE, ONLY: Process, Nhru, Save_vars_to_file, Init_vars_from_file
      USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_area, Basin_area_inv, Hru_elev_meters
      USE PRMS_CLIMATEVARS, ONLY: Basin_potet, Potet, Tavgc, Swrad, Tminc, Tmaxc, &
     &    Tempc_dewpt, Vp_actual, Lwrad_net, Vp_slope, Vp_sat
      USE PRMS_CLIMATE_HRU, ONLY: Humidity_hru, Windspeed_hru
      USE PRMS_SOLTAB, ONLY: Soltab_potsw
      USE PRMS_SET_TIME, ONLY: Nowmonth, Jday
      IMPLICIT NONE
! Functions
      INTRINSIC SQRT, DBLE, LOG, SNGL
      INTEGER, EXTERNAL :: declparam, getparam
      REAL, EXTERNAL :: sat_vapor_press
      EXTERNAL read_error, print_module, potet_pm_restart
! Local Variables
      INTEGER :: i, j
      REAL :: elh, prsr, psycnst, heat_flux, net_rad, vp_deficit, a, b, c
      REAL :: A1, B1, t1, num, den, stab, sw
      CHARACTER(LEN=80), SAVE :: Version_potet
!***********************************************************************
      potet_pm = 0

      IF ( Process(:3)=='run' ) THEN
        Basin_potet = 0.0D0
        DO j = 1, Active_hrus
          i = Hru_route_order(j)

!...ATMOSPHERIC PRESSURE FOR ALTITUDE, KPA:
          !prsr = 101.3 - 0.003215*Hru_elev_feet(i)
          prsr = 101.3 * (((293.0-0.0065*Hru_elev_meters(i))/293.0)**5.26)

!...LATENT HEAT OF VAPORIZATION AT AVG TEMPERATURE, CAL/GRAM:
          ! elh = 597.3 - 0.5653*Tavgc(i) ! same as potet_jh
!...LATENT HEAT OF VAPORIZATION AT AVG TEMPERATURE, JOULES/GRAM:
          elh = (597.3 - 0.5653*Tavgc(i)) * 4.184
          ! elh = 2501.0 - 2.361*Tavgc(i)
          ! elh = 2500.8 - 2.36*Tavgc(i) + 0.0016*Tavgc(i)**2 - 0.00006*Tavgc(i)**3

!...PSCHOMETRIC CONSTANT AT AVG TEMPERATURE FOR ALTITUDE, KPA:
          ! psycnst = 1.6286*prsr/(elh*4.184) ! 4.184 converts CAL to JOULES
          ! psychrometric constant, kilopascals per degrees C
          ! atmospheric pressure for altitude, kPa
          ! Cp = 1.005 approximate specific heat capacity of air at 20 degrees C, increases with temp
          ! MW = 0.622 = molecular weight of water
          ! 1.615755627 = Cp / MW
          psycnst = 1.615755627*prsr/elh

!   heat flux density to the ground,  MJ / m2 / day
!          heat_flux = -4.2 * (Tavgc_ante(i)-Tavgc(i)) ! could use solrad_tmax or running avg instead of Tavgc_ante
          heat_flux = 0.0 ! Irmak and others (2012) says equal to zero for daily time step ! G

! Dew point temperature (Lawrence(2005) eqn. 8), degrees C
          A1 = 17.625
          B1 = 243.04
          t1 = A1 * Tavgc(i) / (B1 + Tavgc(i))
          num = B1 * (LOG(Humidity_hru(i)/100.0) + t1)
          den = A1 - LOG(Humidity_hru(i)/100.0) - t1
          Tempc_dewpt(i) = num / den

! Actual vapor pressure (Irmak eqn. 12), KPA
! divide by 10 to convert millibar to kpa
          Vp_actual(i) = sat_vapor_press(Tempc_dewpt(i)) / 10.0 ! ea

!...SATURATION VAPOR PRESSURE AT AVG TEMP, KILOPASCALS (KPA):
! divide by 10 to convert millibar to kpa
          Vp_sat(i) = sat_vapor_press(Tavgc(i)) / 10.0

          ! saturation vapor pressure deficit
          vp_deficit = Vp_sat(i) - Vp_actual(i)

!...SLOPE OF SATURATION VAPOR PRESSURE CURVE AT AVG TEMP, KPA/DEG(CELSIUS), Irmak 2012, eqn 18
          Vp_slope(i) = 4098.0*Vp_sat(i)/((Tavgc(i)+237.3)**2) ! delta

! The long wave equation uses the soltab values in the denominator. There
! are cases when soltab is zero for certain HRUs (depending on slope/aspect)
! for certain months. If this value is zero, reset it to a small value so
! there is no divide by zero.
          IF (Soltab_potsw(Jday,i) <= 10.0) THEN
            stab = 10.0
          ELSE
            stab = Soltab_potsw(Jday,i)
          ENDIF

          IF (Swrad(i) <= 10.0) THEN
            sw = 10.5
          ELSE
            sw = Swrad(i)
          ENDIF

!
! Net long wave rediation (Irmak eqn. 10) MJ / m2/ day
! 4.903E-09 = Stefan-Boltzmann constant

           Lwrad_net(i) = 4.903E-09 * (((Tmaxc(i) + 273.16)**4 + (Tminc(i) + 273.16)**4)/2.0 ) &
      &                  * (0.34 - 0.14*SQRT(Vp_actual(i)) * ((1.35*sw) / stab) - 0.35)

! Net radiation (Irmak eqn. 8) MJ / m2 / day
! 1 Langley = 0.04184 MJ/m2
          net_rad = Swrad(i)*0.04184 - Lwrad_net(i) - heat_flux

          a = Vp_slope(i) * net_rad / elh / 1000000.0
          b = psycnst * Pm_n_coef(i,Nowmonth) * Windspeed_hru(i) * vp_deficit / (Tavgc(i) + 273.0)
          c = (Vp_slope(i) + psycnst * (1.0 + Pm_d_coef(i,Nowmonth) * Windspeed_hru(i)))

!  PM equation with corp_coef in mm/day
!          Potet(i) = (a + b)/c
          Potet(i) = Crop_coef(i,Nowmonth) * (a + b)/c
          Potet(i) = Potet(i) / 25.4

          IF ( Potet(i)<0.0 ) Potet(i) = 0.0
          Basin_potet = Basin_potet + DBLE( Potet(i)*Hru_area(i) )
!          Tavgc_ante(i) = Tavgc(i)
        ENDDO
        Basin_potet = Basin_potet*Basin_area_inv

      ELSEIF ( Process(:4)=='decl' ) THEN
        Version_potet = 'potet_pm.f90 2016-07-20 15:31:00Z'
        CALL print_module(Version_potet, 'Potential Evapotranspiration', 90)
        MODNAME = 'potet_pm'

        ! Declare Parameters
        ALLOCATE ( Pm_n_coef(Nhru,12) )
        IF ( declparam(MODNAME, 'pm_n_coef', 'nhru,nmonths', 'real', &
     &       '900.0', '850.0', '950.0', &
     &       'Penman-Monteith coefficient', &
     &       'Monthly (January to December) Penman-Monteith potential ET N temperauture coefficient for each HRU', &
     &       'degrees Celsius per day')/=0 ) CALL read_error(1, 'pm_n_coef')

        ALLOCATE ( Pm_d_coef(Nhru,12) )
        IF ( declparam(MODNAME, 'pm_d_coef', 'nhru,nmonths', 'real', &
     &       '0.34', '0.25', '0.45', &
     &       'Penman-Monteith coefficient', &
     &       'Monthly (January to December) Penman-Monteith potential ET D wind-speed coefficient for each HRU', &
     &       'seconds/meters')/=0 ) CALL read_error(1, 'pm_d_coef')

        ALLOCATE ( Crop_coef(Nhru,12) )
        IF ( declparam(MODNAME, 'crop_coef', 'nhru,nmonths', 'real', &
     &       '1.0', '0.0', '2.0', &
     &       'Crop coefficient for each HRU', &
     &       'Crop coefficient for each HRU', &
     &       'decimal fraction')/=0 ) CALL read_error(1, 'crop_coef')

!******Get parameters
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( Init_vars_from_file==1 ) THEN
          CALL potet_pm_restart(1)
        ELSE
          Vp_sat = 0.0
!          Tavgc_ante = Tavgc
        ENDIF
        IF ( getparam(MODNAME, 'pm_n_coef', Nhru*12, 'real', Pm_n_coef)/=0 ) CALL read_error(2, 'pm_n_coef')
        IF ( getparam(MODNAME, 'pm_d_coef', Nhru*12, 'real', Pm_d_coef)/=0 ) CALL read_error(2, 'pm_d_coef')
        IF ( getparam(MODNAME, 'crop_coef', Nhru*12, 'real', Crop_coef)/=0 ) CALL read_error(2, 'crop_coef')

        !ALLOCATE ( Tavgc_ante(Nhru) )
        !Tavgc_ante = Tavgc

      ELSEIF ( Process(:5)=='clean' ) THEN
        IF ( Save_vars_to_file==1 ) CALL potet_pm_restart(0)
      ENDIF

      END FUNCTION potet_pm

!***********************************************************************
!     Write to or read from restart file
!***********************************************************************
      SUBROUTINE potet_pm_restart(In_out)
      USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit
      USE PRMS_POTET_PM
      IMPLICIT NONE
      ! Argument
      INTEGER, INTENT(IN) :: In_out
      EXTERNAL check_restart
      ! Local Variable
      CHARACTER(LEN=8) :: module_name
!***********************************************************************
      IF ( In_out==0 ) THEN
        WRITE ( Restart_outunit ) MODNAME
!        WRITE ( Restart_outunit ) Tavgc_ante
      ELSE
        READ ( Restart_inunit ) module_name
        CALL check_restart(MODNAME, module_name)
!        READ ( Restart_inunit ) Tavgc_ante
      ENDIF
      END SUBROUTINE potet_pm_restart


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

program p
implicit none

integer, parameter :: n=36
integer, dimension(n) :: rslts, expect

integer, dimension(9) :: some_array = (/ 5, 2, 3, 4, 1, 5, 1, 3, 4 /)
integer, parameter, dimension(9) :: some_parameter_array = (/ 5, 2, 3, 4, 1, 5, 1, 3, 4 /)
integer, dimension(1) :: loc

integer, dimension(1:3,1:3) :: some_matrix = reshape(some_parameter_array, (/ 3, 3 /))
integer, parameter, dimension(1:3,1:3) :: some_parameter_matrix = reshape(some_parameter_array, (/ 3, 3 /))

! array, constant input, constant output.
integer, parameter, dimension(1) :: &
        param_array_minloc = minloc(some_parameter_array), &
        param_array_minloc_back = minloc(some_parameter_array, back=.TRUE.), &
        param_array_maxloc = maxloc(some_parameter_array), &
        param_array_maxloc_back = maxloc(some_parameter_array, back=.TRUE.)

! matrix, constant input, constant output.
integer, parameter, dimension(2) :: &
        param_matrix_minloc = minloc(some_parameter_matrix), &
        param_matrix_minloc_back = minloc(some_parameter_matrix, back=.TRUE.), &
        param_matrix_maxloc = maxloc(some_parameter_matrix), &
        param_matrix_maxloc_back = maxloc(some_parameter_matrix, back=.TRUE.)

rslts(1:1) = minloc(some_array)
rslts(2:2) = minloc(some_array, back=.TRUE.)
rslts(3:3) = maxloc(some_array)
rslts(4:4) = maxloc(some_array, back=.TRUE.)

rslts(5:5) = minloc(some_parameter_array)
rslts(6:6) = minloc(some_parameter_array, back=.TRUE.)
rslts(7:7) = maxloc(some_parameter_array)
rslts(8:8) = maxloc(some_parameter_array, back=.TRUE.)

rslts(9:10) = minloc(some_matrix)
rslts(11:12) = minloc(some_matrix, back=.TRUE.)
rslts(13:14) = maxloc(some_matrix)
rslts(15:16) = maxloc(some_matrix, back=.TRUE.)

rslts(17:18) = minloc(some_parameter_matrix)
rslts(19:20) = minloc(some_parameter_matrix, back=.TRUE.)
rslts(21:22) = maxloc(some_parameter_matrix)
rslts(23:24) = maxloc(some_parameter_matrix, back=.TRUE.)

! rslts(25:25) = param_array_minloc
rslts(25:25) = (/ 5 /) ! test inhibited as param_array_minloc is not correct. This is issue flang-compiler/flang#763.
rslts(26:26) = param_array_minloc_back
rslts(27:27) = param_array_maxloc
rslts(28:28) = param_array_maxloc_back

! rslts(25:26) = param_matrix_minloc
rslts(29:30) = (/ 2, 2 /) ! test inhibited as param_matrix_minloc is not correct. This is issue flang-compiler/flang#763.
rslts(31:32) = param_matrix_minloc_back
rslts(33:34) = param_matrix_maxloc
rslts(35:36) = param_matrix_maxloc_back

call check(rslts, expect, n)

data expect / 5, 7, 1, 6, &
              5, 7, 1, 6, &

              ! some_matrix
              2, 2, &
              1, 3, &
              1, 1, &
              3, 2, &

              ! some_parameter_matrix
              2, 2, &
              1, 3, &
              1, 1, &
              3, 2, &

              ! param_array_{min,max}loc{,_back}
              5, 7, 1, 6, &

              ! param_matrix_{min,max}loc{,_back}
              2, 2, &
              1, 3, &
              1, 1, &
              3, 2 /

end


      Program DIAPHRAGM

C-----------------------------------------------------------------------
c
c     1D BURSTING DIAPHRAGM PROBLEM - LCPFCT Test # 3        August 1992
c
c  This program runs a very simple 1D bursting diaphragm test problem
c  using LCPFCT and its utility routines.  The fluid is ideal and
c  inviscid with constant GAMMA = 1.667.  The end walls are reflecting
c  so the fluid should be totally contained in the domain.
c
C-----------------------------------------------------------------------
         use, intrinsic :: iso_fortran_env,only: stdout=>output_unit
         implicit none

         Integer   NPT, ALPHA, BC1, BCN,   MAXSTP,     IPRINT
         Parameter ( NPT = 202 )
         Integer   NX, NXP,    MX, ISTEP,  JSTEP, I,   LOUT
         Real      TIME,       DELTAX,     DELTAT
         REAL      XGRID(NPT), XNEXT(NPT), DXOFF,      DX_OSC
         Real      RHOSUM,     RHVSUM,     PRESUM,     ERGSUM
         Real      VNEW(NPT),  PNEW(NPT),  TNEW(NPT)
         Real      VELX,       VXPAND,     SCALEG
         Real      ERG_IN,     ERGAMB,     RELAX

         Real      RHO_IN,     PRE_IN,     VEL_IN,     GAMMA0
         Real      RHOAMB,     PREAMB,     VELAMB,     GAMMAM
         Real      RHON(NPT),  RVXN(NPT),  RVTN(NPT),  ERGN(NPT)
         Common    / ARRAYS / RHON,   RVXN,   RVTN,   ERGN,   RELAX,
     &                        RHO_IN, PRE_IN, VEL_IN, GAMMA0,
     &                        RHOAMB, PREAMB, VELAMB, GAMMAM

 1000 Format ( '1', /, '    LCPFCT Test # 3 - Bursting Diaphragm:',
     &         '   Step =', I4, '   NX =', I3, '   DT =', F6.3, / )
 1001 Format ( 2X, I3, 6F12.5 )
 1002 Format ( '    I    Density  Temperature   Pressure  ',
     &    '  Velocity     Energy    Interfaces', / )
 1003 Format ( '0 Conservation Sums ', /, 5X, F12.5, 12X, 3F12.5, / )

c  The Bursting Diaphragm run control parameters are specified here.
c  (change for other cases) . . .
C-----------------------------------------------------------------------
      DELTAX = 1.0  ! Cell size
      DELTAT = 0.05 ! Timestep for the calculation
      ALPHA  =   1  ! (1 = Cartesian, 2 = Cylindrical, 3 = Spherical)
      LOUT   =  stdout  ! Logical unit number of printed output device
      NX     = 100  ! Number of cells in the computational domain
      MX     =  60  ! Number of cells initialized behind the shock
      MAXSTP = 1601 ! Maximum number of timesteps of length DELTAT
      IPRINT =  50  ! Frequency of intermediate result printouts

c  Initialize the variables in Common for use in GASDYN . . .
C-----------------------------------------------------------------------
      RHO_IN =  1.0    ! Initial mass density behind the diaphragm
      PRE_IN = 10.0    ! Initial (higher) pressure behind the diaphragm
      VEL_IN =  0.0    ! Initial velocity
      VXPAND =  3.1    ! Characteristic system expansion velocity
      DX_OSC =  0.125  ! Amplitude of the grid jiggling after step 200
      GAMMA0 = 1.66667 ! Gas constant
      PREAMB =  1.0    ! Ambient (unshocked) pressure on the right
      RHOAMB =  1.0    ! Density of the unshocked fluid on the right
      VELAMB =  0.0    ! Initial velocity
      RELAX  =  0.002  ! Relaxation rate, used when BC1, BCN = 2
      GAMMAM = GAMMA0 - 1.0
      ERGAMB = PREAMB/(GAMMA0 - 1.0) + 0.5*RHOAMB*VELAMB**2
      ERG_IN = PRE_IN/(GAMMA0 - 1.0) + 0.5*RHO_IN*VEL_IN**2

c  Set up the fluid variables with the diaphragm at interface MX+1 . . .
C-----------------------------------------------------------------------
      Do I = MX+1, NX
         RHON(I) = RHOAMB
         RVXN(I) = RHOAMB*VELAMB
         RVTN(I) = 0.0
         ERGN(I) = ERGAMB
      Enddo
      Do I = 1, MX
         RHON(I) = RHO_IN
         RVXN(I) = RHO_IN*VEL_IN
         RVTN(I) = 0.0
         ERGN(I) = ERG_IN
      Enddo

c  Begin loop over timesteps . . .
C-----------------------------------------------------------------------
      BC1 = 1
      BCN = 1
      Call RESIDIFF ( 0.998 )

      TIME = 0.0
      Do 9999 ISTEP = 1, MAXSTP

c  Define the cell interface locations and physical variables.  The grid
c  is expanded at the rate VELX at I = NXP after step 201 (as the shock
c  approaches the boundary) by making XNEXT at the end of the timestep
c  proportionately larger than XGRID at the beginning of the step.  The
c  system length is then renormalized to its original size, capturing
c  the similarity solution by equating the grid expansion to the shock
c  velocity.  A small jiggle is added to this systematic expansion to
c  show the added flexibility of the continuity solver.
C-----------------------------------------------------------------------
         NXP = NX + 1
         If ( ISTEP .gt. 200 ) Then
            VELX = VXPAND
            DXOFF = DX_OSC
            If ( MOD(ISTEP,2) .eq. 0 ) DXOFF = - DX_OSC
         Else
            VELX = 0.0
            DXOFF = 0.0
         End If

         Do I = 1, NXP
            XGRID(I)  = FLOAT(I-MX-1)*DELTAX
            XNEXT(I) = XGRID(I)
         Enddo
         SCALEG = (VELX*DELTAT + XGRID(NXP))/XGRID(NXP)
         Do I = 3, NX-2
            XNEXT(I)   = (XNEXT(I) + DXOFF)*SCALEG
            XGRID(I)   = XGRID(I) - DXOFF
         Enddo
         Call MAKEGRID ( XGRID, XNEXT, 1, NXP, ALPHA )

c  The results are printed when required . . .
C-----------------------------------------------------------------------
         If ( MOD(ISTEP-1, IPRINT) .eq. 0) Then
            JSTEP = ISTEP - 1
            IPRINT = 2*(ISTEP - 1)
            If ( ISTEP .lt. 200 ) IPRINT = 50
            Write ( LOUT, 1000 ) JSTEP, NX, DELTAT
            Do I = 1, NX
               VNEW(I) = RVXN(I)/RHON(I)
               PNEW(I) = GAMMAM*(ERGN(I) - 0.5*RVXN(I)*VNEW(I))
               TNEW(I) = PNEW(I)/RHON(I)
            Enddo
            Write (  LOUT, 1002 )
            Write (  LOUT, 1001 ) ( I, RHON(I), TNEW(I), PNEW(I),
     &           VNEW(I), ERGN(I), XGRID(I), I = 1, NX )
            Call CONSERVE (RHON, 1, NX, RHOSUM)
            Call CONSERVE (PNEW, 1, NX, PRESUM)
            Call CONSERVE (RVXN, 1, NX, RHVSUM)
            Call CONSERVE (ERGN, 1, NX, ERGSUM)
            Write (  LOUT, 1003 ) RHOSUM, PRESUM, RHVSUM, ERGSUM
         End If

c  The FCT integration of the continuity equations is performed . . .
C-----------------------------------------------------------------------
         Call GASDYN ( 1, NX, BC1, BCN, DELTAT )
         TIME = TIME + DELTAT

 9999 Continue    ! End of the loop over timesteps.

      End Program


      subroutine  rplot(nres,res,fsup,count,title,rm,al,nx,ny)
c
c     ******************************************************************
c     *                                                                *
c     *   plots the convergence rate                                   *
c     *                                                                *
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
      common/psp/ npgrid,npcp,npcnv
c
c     ******************************************************************
c
      integer  :: nres,nx,ny
      integer  :: npgrid,npcp,npcnv
c
c     ******************************************************************
c
      real     :: rm,al
      real     :: res,fsup,count
c
c     ******************************************************************
c
      character(80) :: title
c
c     ******************************************************************
c
      dimension   res(*),fsup(*),count(*)
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i
c
c     ******************************************************************
c
      real     :: rate,rmin,rmax,res1,fsupf
      real     :: yscal,yint,ylo,yhi
      real     :: xscal,xmax,xint
      real     :: xp,yp
c
c     ******************************************************************
c
      character(80) :: b
c
c     ******************************************************************
c
      rate      = (res(nres)/res(1))**(1./count(nres))
c
c     open a new page
c
c     open  (18,file='CNV.PLOT',access='append')
      open  (18,file='CNV.PLOT',position='append')

      npcnv = npcnv +1
      call initpl(2.,1.25,1.,npcnv)
c
c     write the subtitles
c
      write (b,12)  title
   12 format(a80)
      call symbol(0.,0.,.14,b,0.,80)
      write (b,14)  rm,al
   14 format('Mach ',f11.3,4x,'Alpha',f11.3)
      call symbol(0.,-.25,.14,b,0.,36)
      write (b,16)  res(1),res(nres)
   16 format('Resid1 ',e9.3,4x,'Resid2 ',e9.3)
      call symbol(0.,-.5,.14,b,0.,36)
      write (b,18)  count(nres),rate
   18 format('Work ',f11.2,4x,'Rate ',f11.4)
      call symbol(0.,-.75,.14,b,0.,36)
      write (b,20)  nx,ny
   20 format('Grid   ',i4,'x',i4)
      call symbol(0.,-1.,.14,b,0.,16)
c
c     calculate the vertical scale
c     depending on the magnitude of the reduction in the error
c
      rmin      = 0.
      rmax      = 0.
      res1      = res(1)
      fsupf     = fsup(nres)
      if (abs(fsupf).gt.1.e-06)  fsupf = 1./fsupf

      do i=1,nres
         fsup(i)   = fsup(i)*fsupf
         res(i)    = log(res(i)/res1)
         rmax      = max(rmax,res(i))
         rmin      = min(rmin,res(i))
      end do

      yscal     = 1./log(10.)
      yint      = 2.
      if (yscal*rmin.lt.-12.) yint = 4.
      ylo       = -6.*yint
      yhi       = 2.*yint
      yscal     = yscal/yint
c
c     calculate the horizontal scale
c     depending on the number of cycles
c
      xmax      = 300.
      xint      = 50.

      if (count(nres).gt.300.) then
         xmax = 600.
         xint = 100.
      end if

      if (count(nres).gt.600.) then
         xmax = 1200.
         xint = 200.
      end if

      if (count(nres).gt.1200.) then
         xmax = 3000.
         xint = 500.
      end if

      if (count(nres).gt.3000.) then
         xmax = 6000.
         xint = 1000.
      end if

      xscal     = 1./xint
c
c     draw the axes
c
      call xaxis(0.,xmax,xint,-.5,1.,6.,-1,-1,'Work',4,12,0)
      call yaxis(ylo,yhi,yint,-.5,1.,8.,-1,-1,'Log(error)',10,12,0)
      call yaxis(-.2,1.4,.2,5.5,1.,8.,1,1,'Nsup',4,12,0)
c
c     plot the convergence history
c
      xp        = xscal*count(1)  -.5
      yp        = 7.
      call plot(xp,yp,3)

      do i=2,nres
         xp        = xscal*count(i)  -.5
         yp        = min(2.,yscal*res(i))  +7.
         call plot(xp,yp,2)
      end do
c
c     plot the number of supersonic points
c
      xp        = xscal*count(1) - .5
      yp        = 5.*fsup(1) + 2.
      call plot(xp,yp,3)

      do  i=2,nres
         xp        = xscal*count(i) - .5
         yp        = 5.*fsup(i) + 2.
         call plot(xp,yp,2)
      end do
c
c     close the plot file
c
      call endplt
      endfile 18
      close (18)

      return

      end


program prec
implicit none
integer(kind=16) :: i
i = 627615
call root_pers(i)
i = 39390
call root_pers(i)
i = 588225
call root_pers(i)
i = 393900588225
call root_pers(i)
end program

subroutine root_pers(i)
implicit none
integer(kind=16) :: N, s, a, i
write(*,*) 'Number: ', i
n = i
a = 0
do while(n.ge.10)
  a = a + 1
  s = 0
  do while(n.gt.0)
    s = s + n-int(real(n,kind=8)/10.0D0,kind=8) * 10_8
    n = int(real(n,kind=16)/real(10,kind=8),kind=8)
  end do
  n = s
end do
write(*,*) 'digital root = ', s
write(*,*) 'additive persistance = ', a
end subroutine


      REAL*4 FUNCTION SIND(ARG)

!PURPOSE: Calculate sine from angle in deg.

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      REAL*4        ARG                 !Sine argument in degrees

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA  RPD/0.017453292519943/

!CODE:

      SIND = SIN(ARG*RPD)
      RETURN
      END


subroutine  ADVECT
  use simsphere_mod

! **  This subroutine calculates the geostrophic temperature
! **  advection based on the thermal wind equation and the
! **  vertical distribution of geostrophic wind.

!     INCLUDE 'modvars.h'

! **  The depth of the layer over which we compute geostrophic
! **  temperature advection is 1000 metres, Z(5)-Z(1)

  DATA DZ /1000/

  DTDX =  CF * OTEMP / (GRAV*DZ)*(VGD(5)-VGD(1))
  DTDY =  -CF * OTEMP / (GRAV*DZ)*(UGD(5)-UGD(1))
  ADVGT = -(UGD(3)*DTDX + VGD(3)*DTDY)

! **  Assume that actual temperature change is one-half that of
! **  geostrophic temperature advection.

  ADVGT = ADVGT/2

  return
end


PROGRAM main

  USE mo_kind,  ONLY: dp, i4
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_qhull, ONLY: qhull ! sums between two elements in first dimension (multiply with constant)

  IMPLICIT NONE

  INTEGER(i4), PARAMETER :: dim = 2
  INTEGER(i4), PARAMETER :: npoints = 3

  REAL(dp), DIMENSION(dim,npoints) :: points

  INTEGER(i4) :: out, i
  LOGICAL :: isgood
  CHARACTER(len=250) :: str1, str2, ofile

  isgood = .true.

  points(:,1) = (/ 0.0_dp, 1.0_dp /)
  points(:,2) = (/ 0.38782323776762651_dp, 0.49585832137731267_dp /)
  points(:,3) = (/ 1.0_dp, 0.0_dp /)

  ofile = 'qhull_make_check_test_file'

  out = qhull(points, outfile=ofile)

  open(unit=101, file='qhull.res', action='read')
  open(unit=102, file=ofile, action='read')
  do i=1, 11
     read(101,*) str1
     read(102,*) str2
     if (trim(str1) /= trim(str2)) isgood = .false.
  end do

  if (isgood) then
     write(*,*) 'mo_qhull ', color('o.k.', c_green)
  else
     write(*,*) 'mo_qhull ', color('failed!', c_red)
  endif

END PROGRAM main