MODULE Conductancemod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_conductance(vonKarman, &
        heightWeatherMeasurements, &
        zm, &
        zh, &
        d, &
        plantHeight, &
        wind, &
        conductance)
        IMPLICIT NONE
        REAL, INTENT(IN) :: vonKarman
        REAL, INTENT(IN) :: heightWeatherMeasurements
        REAL, INTENT(IN) :: zm
        REAL, INTENT(IN) :: zh
        REAL, INTENT(IN) :: d
        REAL, INTENT(IN) :: plantHeight
        REAL, INTENT(IN) :: wind
        REAL, INTENT(OUT) :: conductance
        REAL:: h
        !- Name: Conductance -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: Conductance Model
    !            * Author: Pierre Martre
    !            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !
    !            * Institution: INRA/LEPSE Montpellier
    !            * ExtendedDescription: The boundary layer conductance is expressed as the wind speed profile above the
    !            canopy and the canopy structure. The approach does not take into account buoyancy
    !            effects.
    !
    !            * ShortDescription: The boundary layer conductance is expressed as the wind speed profile above the
    !            canopy and the canopy structure. The approach does not take into account buoyancy
    !            effects.
    !
        !- inputs:
    !            * name: vonKarman
    !                          ** description : von Karman constant
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 1
    !                          ** default : 0.42
    !                          ** unit : dimensionless
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !            * name: heightWeatherMeasurements
    !                          ** description : reference height of wind and humidity measurements
    !                          ** parametercategory : soil
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10
    !                          ** default : 2
    !                          ** unit : m
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: zm
    !                          ** description : roughness length governing momentum transfer, FAO
    !                          ** parametercategory : constant
    !                          ** inputtype : parameter
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 1
    !                          ** default : 0.13
    !                          ** unit : m
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !            * name: zh
    !                          ** description : roughness length governing transfer of heat and vapour, FAO
    !                          ** parametercategory : constant
    !                          ** inputtype : parameter
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 1
    !                          ** default : 0.013
    !                          ** unit : m
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !            * name: d
    !                          ** description : corresponding to 2/3. This is multiplied to the crop heigth for calculating the zero plane displacement height, FAO
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.67
    !                          ** min : 0
    !                          ** max : 1
    !                          ** unit : dimensionless
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547rl
    !            * name: plantHeight
    !                          ** description : plant Height
    !                          ** datatype : DOUBLE
    !                          ** default : 0
    !                          ** min : 0
    !                          ** max : 1000
    !                          ** unit : mm
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !            * name: wind
    !                          ** description : wind
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 124000
    !                          ** min : 0
    !                          ** max : 1000000
    !                          ** unit : m/d
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
        !- outputs:
    !            * name: conductance
    !                          ** description : the boundary layer conductance
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** unit : m/d
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        h = MAX(10.0, plantHeight) / 100.0
        conductance = wind *  (vonKarman ** 2) /  &
                (LOG((heightWeatherMeasurements - (d * h)) / (zm * h)) *  &
                LOG((heightWeatherMeasurements - (d * h)) / (zh * h)))
    END SUBROUTINE model_conductance

END MODULE


program dv_rad1

    use iso_fortran_env, only: r64 => real64
    use slf_cgs
    use ss73solution
    use globals
    use alphadisk
    use fileunits
    use confort
    use settings

    implicit none

    integer :: i, j
    integer, parameter :: n = 2**9
    real(r64) :: r12, r23, alpha
    real(r64), dimension(n) :: r
    real(r64), dimension(n) :: rho1, T1, H1
    real(r64), dimension(n) :: rho2, T2, H2
    real(r64), dimension(n) :: rho3, T3, H3
    type(config) :: cfg

    integer, parameter :: nz = 2**11
    real(r64) :: z(nz), y(ny,nz), dy(ny,nz), ap(na,nz)
    integer :: nmax

    call rdargvgl()
    call mincf_read(cfg)
    call rdconfgl(cfg)
    call rdconf(cfg)
    call mincf_free(cfg)

    call apx_zonebounds(mbh,mdot,alpha,r12,r23)

    forall (i = 1:n)
        r(i) = 3 * exp( i / real(n) * (log(r23*10)-log(3d0)) )
    end forall

    call apx_sel(mbh, mdot, r, alpha, r12, r23, rho1, T1, H1)

    rho2 = rho1
    T2 = T1
    H2 = H1

    compute_precise_model: do i = 1,n
        call apx_refin(mbh, mdot, r(i), alpha, rho2(i), T2(i), H2(i))

        call init_alpha(mbh, mdot, r(i), alpha)
        call run_alpha(z,nz,y,dy,ap,nmax)
        rho3(i) = ap(c_rho,nz)
        T3(i) = ap(c_Tgas,nz)
        H3(i) = z(1) / 2
        search_height: do j = 1,nz
            if (ap(c_rho,j) .ge. rho3(i) / 2) then
                H3(i) = z(j)
                exit search_height
            end if
        end do search_height
    end do compute_precise_model

    do i = 1,n
        write (6, '(I7,10(1X,Es11.4))') i, r(i), rho1(i), T1(i), H1(i), &
            rho2(i), T2(i), H2(i), rho3(i), T3(i), H3(i)
    end do

contains

    subroutine rdconf(cfg)
        type(config), intent(inout) :: cfg
        character(128) :: buf

        if ( .not. mincf_exists(cfg,'alpha') ) then
            error stop "alpha key is required!"
        end if

        call mincf_get(cfg,'alpha',buf)
        read (buf,*) alpha
    end subroutine

end program


!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This is the ACML implementation of the FFT library

module decomp_2d_fft

  use decomp_2d  ! 2D decomposition module

  implicit none

  private        ! Make everything private unless declared public

  ! engine-specific global variables
  integer, save :: plan_type = 0    ! *** TODO: debug mode 100

  real(mytype), parameter :: scale = 1.0_mytype ! compute unscaled FFT

  ! ACML plans
  complex(mytype), allocatable, dimension(:) :: &
       comm_c2c_x, comm_c2c_y, comm_c2c_z, &  ! for 3D c2c
       comm_c2c_y2, comm_c2c_z2, & ! for y/z sub-steps of 3D r2c
       comm_c2c_x2                 ! for y/x sub-steps of 3D r2c
  real(mytype), allocatable, dimension(:) :: comm_r2c_x, comm_c2r_x
  real(mytype), allocatable, dimension(:) :: comm_r2c_z, comm_c2r_z

  ! common code used for all engines, including global variables,
  ! generic interface definitions and several subroutines
#include "fft_common.f90"

  ! subroutines that generate ACML plans
  ! for several types of 1D multiple FFTs.
#include "acml_plan.f90"

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time initialisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_fft_engine

    implicit none

    if (nrank==0) then
       write(*,*) ' '
       write(*,*) '***** Using the ACML engine *****'
       write(*,*) ' '
    end if

    ! *** Read ACML doc carefully!
    ! Seems that c2c plans can be shared by forward/backward transforms
    ! r2c & c2r must use separate plans (otherwise problem with mode 100)

    ! For C2C transforms
    call c2c_1m_x_plan(comm_c2c_x, ph)
    call c2c_1m_y_plan(comm_c2c_y, ph)
    call c2c_1m_z_plan(comm_c2c_z, ph)

    ! For R2C/C2R tranforms
    if (format == PHYSICAL_IN_X) then
       call r2c_1m_x_plan(comm_r2c_x, ph)
       call c2r_1m_x_plan(comm_c2r_x, ph)
       call c2c_1m_y_plan(comm_c2c_y2, sp)
       call c2c_1m_z_plan(comm_c2c_z2, sp)
    else if (format == PHYSICAL_IN_Z) then
       call r2c_1m_z_plan(comm_r2c_z, ph)
       call c2r_1m_z_plan(comm_c2r_z, ph)
       call c2c_1m_y_plan(comm_c2c_y2, sp)
       call c2c_1m_x_plan(comm_c2c_x2, sp)
    end if

    return
  end subroutine init_fft_engine

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time finalisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine finalize_fft_engine

    implicit none

    deallocate(comm_c2c_x)
    deallocate(comm_c2c_y)
    deallocate(comm_c2c_z)

    if (format == PHYSICAL_IN_X) then
       deallocate(comm_r2c_x)
       deallocate(comm_c2r_x)
       deallocate(comm_c2c_y2)
       deallocate(comm_c2c_z2)
    else if (format==PHYSICAL_IN_Z) then
       deallocate(comm_r2c_z)
       deallocate(comm_c2r_z)
       deallocate(comm_c2c_y2)
       deallocate(comm_c2c_x2)
    end if

    return
  end subroutine finalize_fft_engine

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D FFT - complex to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2c(in, out, isign)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in
    complex(mytype), dimension(:,:,:), intent(OUT) :: out
    integer, intent(IN) :: isign

#ifndef OVERWRITE
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif

    integer :: k

    integer :: info ! error flag

    if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR.  &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then

       ! ===== 1D FFTs in X =====
#ifndef OVERWRITE
       allocate (wk1(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
#endif

#ifdef OVERWRITE

#ifdef DOUBLE_PREC
       call zfft1mx(isign,scale,.true.,ph%xsz(2)*ph%xsz(3),ph%xsz(1), &
            in,1,ph%xsz(1),in,1,ph%xsz(1),comm_c2c_x,info)
#else
       call cfft1mx(isign,scale,.true.,ph%xsz(2)*ph%xsz(3),ph%xsz(1), &
            in,1,ph%xsz(1),in,1,ph%xsz(1),comm_c2c_x,info)
#endif

#else

#ifdef DOUBLE_PREC
       call zfft1mx(isign,scale,.false.,ph%xsz(2)*ph%xsz(3),ph%xsz(1), &
            in,1,ph%xsz(1),wk1,1,ph%xsz(1),comm_c2c_x,info)
#else
       call cfft1mx(isign,scale,.false.,ph%xsz(2)*ph%xsz(3),ph%xsz(1), &
            in,1,ph%xsz(1),wk1,1,ph%xsz(1),comm_c2c_x,info)
#endif

#endif

       ! ===== Swap X --> Y =====
#ifdef OVERWRITE
       call transpose_x_to_y(in,wk2_c2c,ph)
#else
       call transpose_x_to_y(wk1,wk2_c2c,ph)
#endif

       ! ===== 1D FFTs in Y =====
       do k=1, ph%ysz(3)  ! loop through Z-planes
#ifdef DOUBLE_PREC
          call zfft1mx(isign,scale,.true.,ph%ysz(1),ph%ysz(2), &
               wk2_c2c(:,:,k),ph%ysz(1),1,wk2_c2c(:,:,k),ph%ysz(1), &
               1,comm_c2c_y,info)
#else
          call cfft1mx(isign,scale,.true.,ph%ysz(1),ph%ysz(2), &
               wk2_c2c(:,:,k),ph%ysz(1),1,wk2_c2c(:,:,k),ph%ysz(1), &
               1,comm_c2c_y,info)
#endif
       end do

       ! ===== Swap Y --> Z =====
       call transpose_y_to_z(wk2_c2c,out,ph)

       ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
       call zfft1mx(isign,scale,.true.,ph%zsz(1)*ph%zsz(2),ph%zsz(3), &
            out,ph%zsz(1)*ph%zsz(2),1,out,ph%zsz(1)*ph%zsz(2),1, &
            comm_c2c_z,info)
#else
       call cfft1mx(isign,scale,.true.,ph%zsz(1)*ph%zsz(2),ph%zsz(3), &
            out,ph%zsz(1)*ph%zsz(2),1,out,ph%zsz(1)*ph%zsz(2),1, &
            comm_c2c_z,info)
#endif

    else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
         .OR. &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then

       ! ===== 1D FFTs in Z =====
#ifndef OVERWRITE
       allocate (wk1(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
#endif

#ifdef OVERWRITE

#ifdef DOUBLE_PREC
       call zfft1mx(isign,scale,.true.,ph%zsz(1)*ph%zsz(2),ph%zsz(3), &
            in,ph%zsz(1)*ph%zsz(2),1,in,ph%zsz(1)*ph%zsz(2),1, &
            comm_c2c_z,info)
#else
       call cfft1mx(isign,scale,.true.,ph%zsz(1)*ph%zsz(2),ph%zsz(3), &
            in,ph%zsz(1)*ph%zsz(2),1,in,ph%zsz(1)*ph%zsz(2),1, &
            comm_c2c_z,info)
#endif

#else

#ifdef DOUBLE_PREC
       call zfft1mx(isign,scale,.false.,ph%zsz(1)*ph%zsz(2),ph%zsz(3), &
            in,ph%zsz(1)*ph%zsz(2),1,wk1,ph%zsz(1)*ph%zsz(2),1, &
            comm_c2c_z,info)
#else
       call cfft1mx(isign,scale,.false.,ph%zsz(1)*ph%zsz(2),ph%zsz(3), &
            in,ph%zsz(1)*ph%zsz(2),1,wk1,ph%zsz(1)*ph%zsz(2),1, &
            comm_c2c_z,info)
#endif

#endif

       ! ===== Swap Z --> Y =====
#ifdef OVERWRITE
       call transpose_z_to_y(in,wk2_c2c,ph)
#else
       call transpose_z_to_y(wk1,wk2_c2c,ph)
#endif

       ! ===== 1D FFTs in Y =====
       do k=1, ph%ysz(3)  ! loop through Z-planes
#ifdef DOUBLE_PREC
          call zfft1mx(isign,scale,.true.,ph%ysz(1),ph%ysz(2), &
               wk2_c2c(:,:,k),ph%ysz(1),1,wk2_c2c(:,:,k),ph%ysz(1),1, &
               comm_c2c_y,info)
#else
          call cfft1mx(isign,scale,.true.,ph%ysz(1),ph%ysz(2), &
               wk2_c2c(:,:,k),ph%ysz(1),1,wk2_c2c(:,:,k),ph%ysz(1),1, &
               comm_c2c_y,info)
#endif
       end do

       ! ===== Swap Y --> X =====
       call transpose_y_to_x(wk2_c2c,out,ph)

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call zfft1mx(isign,scale,.true.,ph%xsz(2)*ph%xsz(3),ph%xsz(1), &
            out,1,ph%xsz(1),out,1,ph%xsz(1),comm_c2c_x,info)
#else
       call cfft1mx(isign,scale,.true.,ph%xsz(2)*ph%xsz(3),ph%xsz(1), &
            out,1,ph%xsz(1),out,1,ph%xsz(1),comm_c2c_x,info)
#endif

    end if

    return
  end subroutine fft_3d_c2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D forward FFT - real to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_r2c(in_r, out_c)

    implicit none

    real(mytype), dimension(:,:,:), intent(INOUT) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c

#ifndef OVERWRITE
    real(mytype), allocatable, dimension(:,:,:) :: in_r_copy
#endif
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
    integer :: i,j,k
    integer :: info

    real(mytype), allocatable, dimension(:) :: tmp, zbuf_r
    complex(mytype), allocatable, dimension(:) :: zbuf_c

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in X =====
       allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
#ifndef OVERWRITE
       ! need a copy of input as dz/scfftm overwrite the input
       allocate(in_r_copy(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
       in_r_copy = in_r
#endif

#ifdef OVERWRITE

#ifdef DOUBLE_PREC
       call dzfftm(ph%xsz(2)*ph%xsz(3),ph%xsz(1),in_r,comm_r2c_x,info)
#else
       call scfftm(ph%xsz(2)*ph%xsz(3),ph%xsz(1),in_r,comm_r2c_x,info)
#endif

#else

#ifdef DOUBLE_PREC
       call dzfftm(ph%xsz(2)*ph%xsz(3),ph%xsz(1),in_r_copy, &
            comm_r2c_x,info)
#else
       call scfftm(ph%xsz(2)*ph%xsz(3),ph%xsz(1),in_r_copy, &
            comm_r2c_x,info)
#endif

#endif

       ! translate Hermitian storage into half-plus-1-complex-storage
       allocate(tmp(ph%xsz(1)))
       do k=1,ph%xsz(3)
          do j=1,ph%xsz(2)
#ifdef OVERWRITE
             tmp(1:ph%xsz(1)) = in_r(1:ph%xsz(1),j,k)
#else
             tmp(1:ph%xsz(1)) = in_r_copy(1:ph%xsz(1),j,k)
#endif
             call to_complex(tmp, ph%xsz(1), wk1(:,j,k))
          end do
       end do
#ifdef OVERWRITE
       deallocate(tmp)
#else
       deallocate(tmp, in_r_copy)
#endif

       ! remove the scaling
       wk1 = wk1 * sqrt(real(ph%xsz(1), kind=mytype))

       ! ===== Swap X --> Y =====
       call transpose_x_to_y(wk1,wk2_r2c,sp)

       ! ===== 1D FFTs in Y =====
       do k=1,sp%ysz(3) ! compute one z-plane at a time
#ifdef DOUBLE_PREC
          call zfft1mx(-1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#else
          call cfft1mx(-1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#endif
       end do

       ! ===== Swap Y --> Z =====
       call transpose_y_to_z(wk2_r2c,out_c,sp)

       ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
       call zfft1mx(-1,scale,.true.,sp%zsz(1)*sp%zsz(2),sp%zsz(3), &
            out_c,sp%zsz(1)*sp%zsz(2),1,out_c,sp%zsz(1)*sp%zsz(2),1, &
            comm_c2c_z2, info)
#else
       call cfft1mx(-1,scale,.true.,sp%zsz(1)*sp%zsz(2),sp%zsz(3), &
            out_c,sp%zsz(1)*sp%zsz(2),1,out_c,sp%zsz(1)*sp%zsz(2),1, &
            comm_c2c_z2, info)
#endif

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in Z =====
       ! note that there is no expert driver to perform multiple 1D r2c
       ! FFTs in ACML --> need to copy numbers into buffers and then
       ! make multiple calls to simple driver.
       allocate(zbuf_r(ph%zsz(3)))
       allocate(zbuf_c(sp%zsz(3)))
       allocate(wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
       do j=1,ph%zsz(2)
          do i=1,ph%zsz(1)
             ! copy data set along Z into a buffer
             do k=1,ph%zsz(3)
                zbuf_r(k) = in_r(i,j,k)
             end do
             ! 1D r2c FFT
#ifdef DOUBLE_PREC
             call dzfft(1,ph%zsz(3),zbuf_r,comm_r2c_z,info)
#else
             call scfft(1,ph%zsz(3),zbuf_r,comm_r2c_z,info)
#endif
             ! The result is in Hermitian storage, convert to complex
             call to_complex(zbuf_r,ph%zsz(3),zbuf_c)
             ! copy back into 3D data structure
             do k=1,sp%zsz(3)
                wk1(i,j,k) = zbuf_c(k)
             end do
          end do
       end do
       ! remove ACML scaling, the parallel library never scales anything
       wk1 = wk1 * sqrt(real(ph%zsz(3), kind=mytype))

       ! ===== Swap Z --> Y =====
       call transpose_z_to_y(wk1,wk2_r2c,sp)

       ! ===== 1D FFTs in Y =====
       do k=1,sp%ysz(3) ! compute one z-plane at a time
#ifdef DOUBLE_PREC
          call zfft1mx(-1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#else
          call cfft1mx(-1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#endif
       end do

       ! ===== Swap Y --> X =====
       call transpose_y_to_x(wk2_r2c,out_c,sp)

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call zfft1mx(-1,scale,.true.,sp%xsz(2)*sp%xsz(3),sp%xsz(1), &
            out_c,1,sp%xsz(1),out_c, 1, sp%xsz(1),comm_c2c_x2, info)
#else
       call cfft1mx(-1,scale,.true.,sp%xsz(2)*sp%xsz(3),sp%xsz(1), &
            out_c,1,sp%xsz(1),out_c, 1, sp%xsz(1),comm_c2c_x2, info)
#endif

    end if

    return
  end subroutine fft_3d_r2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D inverse FFT - complex to real
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2r(in_c, out_r)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r

#ifndef OVERWRITE
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif
    complex(mytype), allocatable, dimension(:,:,:) :: wk3
    integer :: i,j,k
    integer :: info

    real(mytype), allocatable, dimension(:) :: tmp, zbuf_r
    complex(mytype), allocatable, dimension(:) :: zbuf_c

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in Z =====
#ifndef OVERWRITE
       allocate(wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
#endif

#ifdef OVERWRITE

#ifdef DOUBLE_PREC
       call zfft1mx(1,scale,.true.,sp%zsz(1)*sp%zsz(2),sp%zsz(3),  &
            in_c,sp%zsz(1)*sp%zsz(2),1,in_c, sp%zsz(1)*sp%zsz(2), 1, &
            comm_c2c_z2, info)
#else
       call cfft1mx(1,scale,.true.,sp%zsz(1)*sp%zsz(2),sp%zsz(3),  &
            in_c,sp%zsz(1)*sp%zsz(2),1,in_c, sp%zsz(1)*sp%zsz(2), 1, &
            comm_c2c_z2, info)
#endif

#else

#ifdef DOUBLE_PREC
       call zfft1mx(1,scale,.false.,sp%zsz(1)*sp%zsz(2),sp%zsz(3),  &
            in_c,sp%zsz(1)*sp%zsz(2),1,wk1, sp%zsz(1)*sp%zsz(2), 1, &
            comm_c2c_z2, info)
#else
       call cfft1mx(1,scale,.false.,sp%zsz(1)*sp%zsz(2),sp%zsz(3),  &
            in_c,sp%zsz(1)*sp%zsz(2),1,wk1, sp%zsz(1)*sp%zsz(2), 1, &
            comm_c2c_z2, info)
#endif

#endif

       ! ===== Swap Z --> Y =====
#ifdef OVERWRITE
       call transpose_z_to_y(in_c,wk2_r2c,sp)
#else
       call transpose_z_to_y(wk1,wk2_r2c,sp)
#endif

       ! ===== 1D FFTs in Y =====
       do k=1,sp%ysz(3) ! compute one z-plane at a time
#ifdef DOUBLE_PREC
          call zfft1mx(1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#else
          call cfft1mx(1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#endif
       end do

       ! ===== Swap Y --> X =====
       allocate (wk3(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
       call transpose_y_to_x(wk2_r2c,wk3,sp)

       ! translate half-plus-1-complex-storage into Hermitian storage
       allocate(tmp(ph%xsz(1)))
       do k=1,ph%xsz(3)
          do j=1,ph%xsz(2)
             call to_hermitian(wk3(:,j,k), ph%xsz(1), tmp)
             out_r(1:ph%xsz(1),j,k) = tmp(1:ph%xsz(1))
          end do
       end do
       deallocate(tmp)
       out_r = out_r * sqrt(real(ph%xsz(1),kind=mytype))

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call zdfftm(ph%xsz(2)*ph%xsz(3),ph%xsz(1),out_r,comm_c2r_x,info)
#else
       call csfftm(ph%xsz(2)*ph%xsz(3),ph%xsz(1),out_r,comm_c2r_x,info)
#endif

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in X =====
#ifndef OVERWRITE
       allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
#endif

#ifdef OVERWRITE

#ifdef DOUBLE_PREC
       call zfft1mx(1,scale,.true.,sp%xsz(2)*sp%xsz(3),sp%xsz(1), &
            in_c,1,sp%xsz(1),in_c,1,sp%xsz(1),comm_c2c_x2,info)
#else
       call cfft1mx(1,scale,.true.,sp%xsz(2)*sp%xsz(3),sp%xsz(1), &
            in_c,1,sp%xsz(1),in_c,1,sp%xsz(1),comm_c2c_x2,info)
#endif

#else

#ifdef DOUBLE_PREC
       call zfft1mx(1,scale,.false.,sp%xsz(2)*sp%xsz(3),sp%xsz(1), &
            in_c,1,sp%xsz(1),wk1,1,sp%xsz(1),comm_c2c_x2,info)
#else
       call cfft1mx(1,scale,.false.,sp%xsz(2)*sp%xsz(3),sp%xsz(1), &
            in_c,1,sp%xsz(1),wk1,1,sp%xsz(1),comm_c2c_x2,info)
#endif

#endif

       ! ===== Swap X --> Y =====
#ifdef OVERWRITE
       call transpose_x_to_y(in_c,wk2_r2c,sp)
#else
       call transpose_x_to_y(wk1,wk2_r2c,sp)
#endif

       ! ===== 1D FFTs in Y =====

       do k=1,sp%ysz(3) ! compute one z-plane at a time
#ifdef DOUBLE_PREC
          call zfft1mx(1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#else
          call cfft1mx(1,scale,.true.,sp%ysz(1),sp%ysz(2),  &
               wk2_r2c(:,:,k),sp%ysz(1),1,wk2_r2c(:,:,k),sp%ysz(1),1, &
               comm_c2c_y2,info)
#endif
       end do

       ! ===== Swap Y --> Z =====
       allocate (wk3(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
       call transpose_y_to_z(wk2_r2c,wk3,sp)

       ! ===== 1D FFTs in Z =====
       ! note that there is no expert driver to perform multiple 1D c2r
       ! FFTs in ACML --> need to copy numbers into buffers and then
       ! make multiple calls to simple driver.
       allocate(zbuf_r(ph%zsz(3)))
       allocate(zbuf_c(sp%zsz(3)))
       do j=1,ph%zsz(2)
          do i=1,ph%zsz(1)
             ! copy data set along Z into a buffer
             do k=1,sp%zsz(3)
                zbuf_c(k) = wk3(i,j,k)
             end do
             ! convert complex storage to Hermitian storage
             call to_hermitian(zbuf_c,ph%zsz(3),zbuf_r)
             ! 1D c2r FFT
#ifdef DOUBLE_PREC
             call zdfft(1,ph%zsz(3),zbuf_r,comm_c2r_z,info)
#else
             call csfft(1,ph%zsz(3),zbuf_r,comm_c2r_z,info)
#endif
             ! copy back into 3D data structure
             do k=1,ph%zsz(3)
                out_r(i,j,k) = zbuf_r(k)
             end do
          end do
       end do
       ! remove ACML scaling, the parallel library never scales anything
       out_r = out_r * sqrt(real(ph%zsz(3),kind=mytype))

    end if

    return
  end subroutine fft_3d_c2r

  ! Two utility routines to convert internal storage format

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Rearrange Hermitian storage data as half-plus-1-complex-storage data
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine to_complex(in,n,out)

    implicit none

    integer, intent(IN) :: n
    real(mytype), dimension(0:n-1), intent(IN) :: in
    complex(mytype), dimension(0:n/2), intent(OUT) :: out

    integer :: i

    ! Let out(i) be the full-complex spectral representation of real input
    ! Let 'in' be an Hermitian storage array of length 'n' (0-based)
    !  - in(i) contains the real part of out(i) for i=0,...,n/2
    !  - in(n−i) contains the imaginary part of out(i) for i=1,...,(n−1)/2

    out(0) = cmplx(in(0),0._mytype,kind=mytype)

    if (n == n/2*2) then   ! n is even, n/2 is larger than (n-1)/2 by 1
       do i=1,(n-1)/2
          out(i) = cmplx(in(i),in(n-i),kind=mytype)
       end do
       out(n/2) = cmplx(in(n/2),0._mytype,kind=mytype)
    else                   ! n is odd, then n/2 == (n-1)/2
       do i=1,n/2
          out(i) = cmplx(in(i),in(n-i),kind=mytype)
       end do
    end if

    return
  end subroutine to_complex

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! The opposite of the above
  !   Also need to be conjudated before inverse transform
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine to_hermitian(in,n,out)

    implicit none

    integer, intent(IN) :: n
    complex(mytype), dimension(0:n/2), intent(IN) :: in
    real(mytype), dimension(0:n-1), intent(OUT) :: out

    integer :: i

    out(0) = real(in(0),kind=mytype)

    if (n == n/2*2) then   ! n is even, n/2 is larger than (n-1)/2 by 1
       do i=1,(n-1)/2
          out(i) = real(in(i),kind=mytype)
          out(n-i) = -aimag(in(i))
       end do
       out(n/2) = real(in(n/2), kind=mytype)
    else                   ! n is odd, then n/2 == (n-1)/2
       do i=1,n/2
          out(i) = real(in(i),kind=mytype)
          out(n-i) = -aimag(in(i))
       end do
    end if

    return
  end subroutine to_hermitian

end module decomp_2d_fft


module ffte
use iso_fortran_env, only: real64
use types, only: dp
implicit none
private
public fft3_inplace, ifft3_inplace, dp_ffte, factor

! FFTE is using REAL*8, which is 8 bytes real = 64 bit real = real64
integer, parameter:: dp_ffte=kind(1._real64)

interface
    subroutine FACTOR(N, IP)
    integer, intent(in) :: n
    integer, intent(out) :: ip(*)
    end subroutine

    subroutine ZFFT3D(A,NX,NY,NZ,IOPT)
    import :: dp_ffte
    complex(dp_ffte), intent(inout) :: A(*)
    integer, intent(in) :: NX, NY, NZ, IOPT
    end subroutine
end interface

contains

subroutine fft3_inplace(x)
complex(dp), intent(inout) :: x(:, :, :)
call zfft3d(x, size(x, 1), size(x, 2), size(x, 3), 0)
call zfft3d(x, size(x, 1), size(x, 2), size(x, 3), -1)
end subroutine

subroutine ifft3_inplace(x)
complex(dp), intent(inout) :: x(:, :, :)
call zfft3d(x, size(x, 1), size(x, 2), size(x, 3), 0)
call zfft3d(x, size(x, 1), size(x, 2), size(x, 3), 1)
x = x * size(x)
end subroutine

end module


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_EQKD_PRO_Z

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_EQKD_PRO_Z

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_EQKD_PRO_Z( NI , NJ , NK , EQKD_PRO_Z )

    USE MR_MOD_OPERATOR_UV

    USE MR_MOD_CALC_QADV_N_QDIF_Z
    USE MR_MOD_INTERP_Z

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) :: EQKD_PRO_Z

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,1:NK) :: HYD_T_Z
    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,0:NK) :: HYD_T_Z_W

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    CALL MR_CALC_T_Z_UV_W( NI , NJ , NK , UV , RB , W , EKZ , VZW , HYD_T_Z_W , TUV0=TBUV )

  ! CALCULATE MECHANICAL PRODUCTION
    CALL MR_INV_INTERP_Z_UV_FROM_UVW( NI , NJ , NK , HYD_T_Z_W , HYD_T_Z )
    DO K = 1 , NK
      HYD_T_Z(:,:,1:2, K ) = ( JUV .MRUVTFM. HYD_T_Z(:,:,1:2, K ) )
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          EQKD_PRO_Z( I , J , K ) = SUM( HYD_T_Z( I , J ,1:2, K ) * HYD_T_Z( I , J ,1:2, K ) ) / ( EKZ * VZWW( I , J , K ) )
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_EQKD_PRO_Z

  END MODULE MR_MOD_CALC_EQKD_PRO_Z


SUBROUTINE TIMEEVOLUTIONOPERATOR(ID,D_BARE,NM,NF,MODES_NUM,FIELD,T1,T2,U,INFO)
  ! TIME EVOLUTION OPERATOR OF A MULTIMODE DRESSED SYSTEM. THE EVOLUTION OPERATOR IS WRITEN IN THE BASIS USED TO EXPRESS THE
  ! MULTIMODE FLOQUET HAMILTONIAN
  ! U : MATRIX OF AMPLITUED OF PROBABILITIES FOR TRANSITIONS BETWEEN T1 TO T2
!!$  NM             (IN)   : NUMBER OF MODES
!!$  NF             (IN)   : TOTAL NUMBER OF FREQUENCIES
!!$  MODES_NUM      (IN)   : VECTOR (NM) INDICATING THE NUMBER OF HARMONICS OF EACH MODE
!!$  D_BARE         (IN)   : DIMENSION OF THE BARE HILBERT SPACE
!!$  FIELD          (IN)   : STRUCTURE DESCRIBING THE COUPLINGS
!!$  T1             (IN)   : INITIAL TIME
!!$  T2             (IN)   : FINAL TIME
!!$  U              (OUT)  : TRANFORMATION BETWEEN THE EXTENDED BARE BASIS AND THE FLOQUET STATES, DIMENSION (D_BARE,D)
!!$  INFO           (INOUT): (POSSIBLE) ERROR FLAG

    USE ATOMIC_PROPERTIES
    USE TYPES
    USE SUBINTERFACE
    USE SUBINTERFACE_LAPACK
!    USE FLOQUETINIT_
    USE ARRAYS

    IMPLICIT NONE
    TYPE(ATOM) ,                                INTENT(IN)    :: ID
    INTEGER,                                    INTENT(IN)    :: D_BARE
    INTEGER,                                    INTENT(IN)    :: NM,NF
    INTEGER,          DIMENSION(NM),            INTENT(IN)    :: MODES_NUM
    TYPE(MODE),       DIMENSION(NF),            INTENT(IN)    :: FIELD  ! FIELDS PROPERTIES: FREQUENCY, AMPLITUDES AND PHASES
    DOUBLE PRECISION,                           INTENT(IN)    :: T1
    DOUBLE PRECISION,                           INTENT(IN)    :: T2
    COMPLEX*16,       DIMENSION(D_BARE,D_BARE), INTENT(OUT)   :: U
    INTEGER,                                    INTENT(INOUT) :: INFO

    INTEGER :: TOTAL_FREQUENCIES
    DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E_FLOQUET
    COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: U_F

    TOTAL_FREQUENCIES = SUM(MODES_NUM,1)

    IF(ID%id_system .NE. 6) CALL SETHAMILTONIANCOMPONENTS(ID,size(modes_num,1),total_frequencies,MODES_NUM,FIELD,INFO)
    !if id%id_system == 6, then the system is not a spin and the hamiltonian couplings should be defined by hand.

    !---- FIND THE MULTIMODE FLOQUET SPECTRUM
    CALL MULTIMODEFLOQUETMATRIX(ID,size(modes_num,1),total_frequencies,MODES_NUM,FIELD,INFO)
    !write(*,*) A*field(3)%omega/hbar,h_floquet(1,1)

    ALLOCATE(E_FLOQUET(SIZE(H_FLOQUET,1)))
    ALLOCATE(U_F(SIZE(H_FLOQUET,1),SIZE(H_FLOQUET,1)))
    E_FLOQUET = 0.0
    !CALL WRITE_MATRIX(ABS(H_FLOQUET))
    CALL LAPACK_FULLEIGENVALUES(H_FLOQUET,SIZE(H_FLOQUET,1),E_FLOQUET,INFO)
    U_F = H_FLOQUET ! FOURIER DECOMPOSITION OF THE STATES DRESSED BY MODE NUMBER
    !CALL WRITE_MATRIX(ABS(H_FLOQUET))
    DEALLOCATE(H_FLOQUET)
    !write(*,*) E_FLOQUET
    !--- EVALUATE TIME-EVOLUTION OPERATOR IN THE BARE BASIS
    CALL MULTIMODETIMEEVOLUTINOPERATOR(SIZE(U_F,1),SIZE(MODES_NUM,1),MODES_NUM,U_F,E_FLOQUET,ID%D_BARE,FIELD,T1,T2,U,INFO)
!    WRITE(*,*) (FIELD(3)%OMEGA)/(2*pi),T2,abs(U)**2

    DEALLOCATE(E_FLOQUET)
    DEALLOCATE(U_F)

END SUBROUTINE TIMEEVOLUTIONOPERATOR


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine carbon_seal(node1,node2,nodem,nelem,lakon,
     &     nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &     nodef,idirf,df,R,physcon,dvi,numf,set,mi,ttime,time,iaxial)
!
!     carbon seal element calculated with Richter method
!      Richter "Rohrhydraulik", Springer ,1971,p. 175
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(4),idirf(4),index,iflag,
     &     inv,mi(*),iaxial
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),R,d,l,
     &     p1,p2,T1,physcon(*),dvi,pi,s,T2,ttime,time
!
      if (iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif (iflag.eq.1)then
!
         index=ielprop(nelem)
         d=prop(index+1)
         s=prop(index+2)
         l=prop(index+3)
         pi=4.d0*datan(1.d0)
!
         p1=v(2,node1)
         p2=v(2,node2)
         if(p1.ge.p2) then
            inv=1
            T1=v(0,node1)+physcon(1)
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            T1=v(0,node2)+physcon(1)
         endif
!
         if(lakon(nelem)(2:6).eq.'CARBS') then
!
!     gapflow
!     Richter "Rohrhydraulik", Springer ,1971,p. 175
!
            xflow=inv*Pi*d*s**3*(P1**2-P2**2)/(24.d0*R*T1*dvi*l)

         elseif(lakon(nelem)(2:6).ne.'CARBS') then
            write(*,*) '*WARNING in Carbon_seal.f'
            write(*,*) 'unable to perform carbon seal calculation'
            write(*,*) 'check input file'
         endif
!
      elseif (iflag.eq.2)then
!
         numf=4
         p1=v(2,node1)
         p2=v(2,node2)
         if(p1.ge.p2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            T1=v(0,node1)+physcon(1)
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            T1=v(0,node2)+physcon(1)
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
         endif
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=2
!
         index=ielprop(nelem)
         d=prop(index+1)
         s=prop(index+2)
         l=prop(index+3)
         pi=4.d0*datan(1.d0)

!
         if (lakon(nelem)(2:6).eq.'CARBS') then
!
            f=xflow*T1-pi*d*s**3*(P1**2-P2**2)/(24.d0*R*dvi*l)
!
            df(1)=-(pi*d*s**3*P1)/(12.d0*R*dvi*l)
            df(2)=xflow
            df(3)=T1
            df(4)=(pi*d*s**3*P2)/(12.d0*R*dvi*l)
!
         endif

      elseif(iflag.eq.3) then
         p1=v(2,node1)
         p2=v(2,node2)
         if(p1.ge.p2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            T1=v(0,node1)+physcon(1)
            T2=v(0,node2)+physcon(1)
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            T1=v(0,node2)+physcon(1)
            T2=v(0,node1)+physcon(1)
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
         endif

         write(1,*) ''
         write(1,55) ' from node',node1,
     &' to node', node2,':   air massflow rate=',xflow
 55      FORMAT(1X,A,I6,A,I6,A,e11.4,A,A,e11.4,A)

         if(inv.eq.1) then
            write(1,56)'       Inlet node  ',node1,':   Tt1=',T1,
     &           ' , Ts1=',T1,' , Pt1=',P1

            write(1,*)'             Element',nelem,lakon(nelem)

            write(1,56)'       Outlet node ',node2,':   Tt2=',T2,
     &           ' , Ts2=',T2,' , Pt2=',P2
!
         else if(inv.eq.-1) then
            write(1,56)'       Inlet node  ',node2,':    Tt1=',T1,
     &           ' , Ts1=',T1,' , Pt1=',P1
     &
            write(1,*)'             Element',nelem,lakon(nelem)

            write(1,56)'       Outlet node ',node1,':    Tt2=',T2,
     &           ' , Ts2=',T2,' , Pt2=',P2

         endif

 56      FORMAT(1X,A,I6,A,e11.4,A,e11.4,A,e11.4,A)
      endif
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


C$Procedure ZZCHRLAT ( Chord latitude  )

      SUBROUTINE ZZCHRLAT ( MIDLAT, DLON, EPTLAT )

C$ Abstract
C
C     Given the latitude of a midpoint of chord on a circle of constant
C     latitude, and given the longitude extent of the chord, compute
C     the latitude of the chord's endpoints. The coordinate system is
C     "latitudinal," aka planetocentric.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     COORDINATES
C     LATITUDE
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'dsktol.inc'

      DOUBLE PRECISION      MIDLAT
      DOUBLE PRECISION      DLON
      DOUBLE PRECISION      EPTLAT

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MIDLAT     I   is the latitude of the midpoint of a chord of a
C                    latitude circle.
C     DLON       I   is the longitude extent of the chord.
C     EPTLAT     O   is the latitude of the endpoints of the chord.
C
C$ Detailed_Input
C
C     MIDLAT     is the latitude of the midpoint of a chord of a circle
C                of constant latitude. Units are radians. The range of
C                MIDLAT is -pi : pi.
C
C     DLON       is the extent in longitude of the chord. DLON is the
C                difference of the longitudes of the endpoints of the
C                chords, expressed as a non-negative value. Units are
C                radians. DLON must be strictly less than pi.
C
C$ Detailed_Output
C
C     EPTLAT     is the latitude of the circle to which the chord
C                is tangent. Units are radians.
C
C$ Parameters
C
C     ANGMRG is a tolerance used to determine whether the input latitude
C     is within range. See 'dsktol.inc' for further information.
C
C$ Exceptions
C
C     1)  If the input longitude extent DLON is negative, or if the
C         extent is greater than or equal to pi radians, the error
C         SPICE(VALUEOUTOFRANGE) is signaled.
C
C     2)  If the input latitude is outside the range
C
C             -pi/2 - ANGMRG  :  pi/2 + ANGMRG
C
C         the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     In the remarks below, the coordinate system is presumed to be
C     latitudinal.
C
C     A "chord" of a circle is a line segment having endpoints on the
C     circle.
C
C     This routine supports partitioning of a tessellated spheroid
C     surface into bands of plates covering specified latitude ranges.
C     Note that, for a plate edge that is a chord of a positive
C     latitude circle, the maximum latitude on the chord is attained at
C     the chord's midpoint. So a set of plates lying on or above the
C     plate containing the latitude circle cannot actually cover the
C     latitude range above the circle: rays emanating from the origin
C     can pass above the latitude circle and miss the set of plates. An
C     analogous situation exists for circles of negative latitude.
C
C     In order to generate a set of plates that cover a positive
C     latitude band, the plates can be arranged so that the maximum
C     latitude of the lowest plate edges is less than or equal to the
C     lower latitude bound of the band. An analogous solution can be
C     derived for bands of negative latitude. This routine can be used
C     to solve these problems: it can compute the latitude of a circle
C     ---where the circle is horizontal and centered on the z axis---
C     in which a regular polygon must be inscribed so that the maximum
C     latitude on the polygon is less than a specified value, or such
C     that the minimum latitude on the polygon is greater than a
C     specified value.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C
C     1)  Find the latitude circle on which a line segment's endpoints
C         must lie, if the longitude extent of the segment is 60
C         degrees, and if the latitude of the segment's midpoint is 30
C         degrees.
C
C
C     Example code begins here.
C
C
C           PROGRAM EX1
C           IMPLICIT NONE
C
C     C
C     C     SPICELIB functions
C     C
C           DOUBLE PRECISION      DPR
C           DOUBLE PRECISION      RPD
C
C     C
C     C     Local variables
C     C
C           DOUBLE PRECISION      DLON
C           DOUBLE PRECISION      EP     ( 3, 2 )
C           DOUBLE PRECISION      EPTLAT
C           DOUBLE PRECISION      MIDLAT
C           DOUBLE PRECISION      MIDLON
C           DOUBLE PRECISION      MIDRAD
C           DOUBLE PRECISION      MIDPT  ( 3 )
C           DOUBLE PRECISION      OUTLAT
C
C     C
C     C     Let the segment have a longitude extent
C     C     of 60 degrees.
C     C
C           DLON   = 60.D0 * RPD()
C
C     C
C     C     Let the midpoint of the segment have
C     C     a latitude of 30 degrees.
C     C
C           MIDLAT = 30.D0 * RPD()
C
C     C
C     C     Find the latitude of the segment's endpoints.
C     C
C           CALL ZZCHRLAT ( MIDLAT, DLON, EPTLAT )
C
C           WRITE (*,*) 'Endpoint latitude (deg) = ', EPTLAT*DPR()
C
C     C
C     C     Generate the endpoints and the latitude
C     C     of the segment's midpoint.
C     C
C     C     Note that the scale is arbitrary: we can set it
C     C     to 1.0. The longitudes of the endpoints are
C     C     arbitrary as well; only the difference is known.
C     C
C           CALL LATREC ( 1.D0, 0.D0, EPTLAT, EP(1,1) )
C           CALL LATREC ( 1.D0, DLON, EPTLAT, EP(1,2) )
C
C           CALL VLCOM  ( 0.5D0, EP(1,1),
C          .              0.5D0, EP(1,2), MIDPT )
C
C           CALL RECLAT ( MIDPT, MIDRAD, MIDLON, OUTLAT )
C
C           WRITE (*,*) 'Check: difference (deg) = ',
C          .            (MIDLAT - OUTLAT) * DPR()
C
C           END
C
C
C     When this program was executed on a PC/Linux/gfortran 64-bit
C     platform, the output was:
C
C
C        Endpoint latitude (deg) =    26.565051177077986
C        Check: difference (deg) =   6.36110936292703354E-015
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 20-APR-2016 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     find latitude of chord's endpoints on latitude circle
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      BRCKTD
      DOUBLE PRECISION      HALFPI
      DOUBLE PRECISION      PI

      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      MLAT

C
C     Use discovery check-in.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

      IF ( ( DLON .LT. 0.D0 ) .OR. ( DLON .GE. PI() ) )  THEN

         CALL CHKIN  ( 'ZZCHRLAT'                          )
         CALL SETMSG ( 'The input longitude extent was #; '
     .   //            'this value must be in the range '
     .   //            '[0 : pi ) radians.'                )
         CALL ERRDP  ( '#', DLON                           )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'            )
         CALL CHKOUT ( 'ZZCHRLAT'                          )
         RETURN

      END IF

      IF (  ABS(MIDLAT)  .GT.  ( HALFPI()+ANGMRG )  ) THEN

         CALL CHKIN  ( 'ZZCHRLAT'                          )
         CALL SETMSG ( 'The input latitude was #; this '
     .   //            'value must be in the interval '
     .   //            '-pi/2 : pi/2 (radians).'           )
         CALL ERRDP  ( '#', MIDLAT                         )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'            )
         CALL CHKOUT ( 'ZZCHRLAT'                          )
         RETURN

      END IF

C
C     The input latitude is, at worst, slightly out of range.
C     Bracket it.
C
      MLAT = BRCKTD( MIDLAT, -HALFPI(), HALFPI() )

C
C     The endpoint latitude EPTLAT is defined by
C
C        EPTLAT = atan ( tan(MLAT) * cos( DLON/2 ) )
C
C     For numerical robustness, we'll re-write this using
C     the two-argument arctangent function and well-behaved
C     trig functions as input arguments:
C
      EPTLAT = ATAN2 ( SIN(MLAT) * COS(DLON/2),  COS(MLAT) )

      RETURN
      END


subroutine rfdpar1(be,rate,m)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    rfdpar
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine finds the quadratic factors and (if present) the
!            single linear factor of the generic quasi-Gaussian recursive
!            filter of degree m.
!
!
! program history log:
!   1998-01-01  purser
!   2004-06-22  treadon - update documentation
!   2004-06-23  purser  - update documentation
!   2011-07-03  todling - use general interface to FORTRAN intrisic math
!
!   input argument list:
!     m    - the degree of the recursive filter
!
!   output argument list:
!     be   - Recursive filter "beta" coefficients for characteristic modes
!     rate - Decay rate factors for the characteristic modes of the filter
!
!   remarks:
!            This is one of several possible variants of
!            the construction procedure described in Purser et al, 2003, MWR
!            131, 1524--1535. An earlier version, with additional material,
!            is Purser et al. 2001: NCEP Office Note 431. The style of
!            filtering implemented here treats the (in general, complex)
!            characteristic eigenmodes of the idealized degree-m recursive
!            filter additively. This style was motivated by evidence that
!            this approach led to better control of amplitude in the case
!            of spatial variations of filtering or grid scale. However, the
!            exact construction and application of the filter parameters in
!            this style differs from the published descriptions (referenced
!            above) which do not attempt to analyze and separate the spatial
!            eigenmodes of the filter as is done here.
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use constants, only: zero,half,one
  implicit none

  integer(i_kind)          ,intent(in   ) :: m
  real(r_kind),dimension(*),intent(  out) :: be,rate

  integer(i_kind),parameter:: nn=12
  real(r_kind),parameter:: qcrit=0.001_r_kind

  logical polish
  integer(i_kind) j2,jreal,ipow,jimag,kmod2,i
  real(r_kind) qa,q,r
  real(r_kind),dimension(nn,nn):: van
  complex(r_kind) ca,cb,cc
  complex(r_kind),dimension(nn):: croot
  complex(r_kind),dimension(0:nn):: cof

  data polish/.true./

  polish=.true.
  kmod2=mod(m,2)
! Set up the coefficients of the polynomial in z of degree m that approximates
! the function, exp(z/2):
  cof=zero
  cof(0)=one
  do i=1,m
     cof(i)=half*cof(i-1)/float(i)
  enddo
! Locate the m roots of this polynomial:
  call zroots(cof,m,croot,polish)

! If m is even, all roots are complex; if odd, there is one real root,
! which is the first in the list, croot, returned by subr. zroots:
  if(kmod2==1)then    ! treat the single real root:
     r=-real(croot(1),r_kind)
     q=-aimag(croot(1))
     qa=abs(q)
     if(qa>qcrit) then
        write(6,*)'RFDPAR1:  imaginary root qa=',qa,' > qcrit=',qcrit
        call stop2(69)
     endif
     r=sqrt(r)
     rate(1)=r
     van(1,1)=one
     van(2,1)=r
     do i=3,m
        van(i,1)=van(i-1,1)*r*r
     enddo
  endif
! The complex roots occur in conjugate pairs and emerge from zroots
! ordered by their real parts. It is therefore sufficient to use stride-2
! when looping through the part of the list, croot, that contains the
! complex roots.
  do j2=2,m,2         ! loop over remaining independent complex roots
     jreal=kmod2+j2-1
     jimag=kmod2+j2
     ca=-croot(j2)
     cb=sqrt(ca)
     r=real(cb,r_kind)
     q=aimag(cb)
     if(r<zero)then
        cb=-cb
        r=-r
        q=-q
     endif
     rate(jreal)=r
     rate(jimag)=q
     van(1,jreal)=one
     van(1,jimag)=zero
     do i=2,m
        ipow=i*2-3
        cc=cb**ipow
        van(i,jreal)=real(cc,r_kind)
        van(i,jimag)=-aimag(cc)
     enddo
  enddo
  be(1)=one
  do i=2,m
     be(i)=zero
  enddo
  call linmm(van,be,m,1,nn,m)
  return
end subroutine rfdpar1

subroutine rfdpar2(be,rate,turn,samp,m)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    rfdpar2
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine sets the "turning conditions" for a recursive
!            that intercepts a domain boundary.
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser - added documentation
!   2011-07-03  todling - use mathkinds for math-intrisic
!
!   input argument list:
!     be   - Recursive filter coefficients listed by characteristic modes
!     rate - Decay rate factors for the characteristic modes of the filter
!     m    - degree of the recursive filter
!
!   output argument list:
!     turn - square matrix of "turning coefficients" for bounded domain
!     samp - amplitude adjustment factor related to normalization.
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero,half,two
  implicit none

  integer(i_kind)            ,intent(in   ) :: m
  real(r_kind),dimension(m)  ,intent(in   ) :: be,rate
  real(r_kind),dimension(m,m),intent(  out) :: turn
  real(r_kind)               ,intent(  out) :: samp

  integer(i_kind) kr,li,lr,ki,kmod2
  real(r_kind) beki,bekr,be1,r1,s
  complex(r_kind) cbe,crl,cl1,c1l,crk,crj,cbeh,clk,clj
  complex(r_kind) clkr,clki

  kmod2=mod(m,2)
  s=zero
  if(kmod2==1)then     ! the first root is real:
     r1=rate(1)
     be1=be(1)
     turn(1,1)=be1/(two*r1)
     s=s+turn(1,1)*be1
     do lr=kmod2+1,m,2
        li=lr+1
        cbe=cmplx(be(lr),be(li),r_kind)
        crl=cmplx(rate(lr),rate(li),r_kind)
        cl1=cbe/(r1+crl)
        turn(lr,1)=real(cl1,r_kind)
        turn(li,1)=aimag(cl1)
        c1l=be1/(r1+crl)
        turn(1,lr)=real(c1l,r_kind)
        turn(1,li)=-aimag(c1l)
        s=s+turn(lr,1)*be1+turn(1,lr)*be(lr)+turn(1,li)*be(li)
     enddo
  endif
  do kr=kmod2+1,m,2
     ki=kr+1
     crk=cmplx(rate(kr),rate(ki),r_kind)
     crj=conjg(crk)
     bekr=be(kr)
     beki=be(ki)
     do lr=kmod2+1,m,2
        li=lr+1
        cbeh=half*cmplx(be(lr),be(li),r_kind)
        crl=cmplx(rate(lr),rate(li),r_kind)
        clk=cbeh/(crl+crk)
        clj=cbeh/(crl+crj)
        clkr=clk+clj
        clki=clk-clj
        turn(lr,kr)= real(clkr,r_kind)
        turn(li,kr)= aimag(clkr)
        turn(lr,ki)=-aimag(clki)
        turn(li,ki)= real(clki,r_kind)
        s=s+turn(lr,kr)*bekr+turn(lr,ki)*beki
     enddo
  enddo
  samp=half/s
  return
end subroutine rfdpar2

subroutine rfdparv(dsh,rate,al,n,m)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    rfdparv
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract: Convert filter mode decay rates and effective grid steps into
!           actual recursive filter "alpha" coefficients for each
!           characteristic mode of the filter.
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser - added documentation
!   2004-08-18  derber - remove complex variables, add intent
!
!   input argument list:
!     dsh  - Effective grid step in covariance-scale units
!     rate - Decay rate factors for the characteristic modes of the filter
!     n    - size of the grid in the active direction
!     m    - degree of the recursive filter
!
!   output argument list:
!     al   - "alpha" coefficients for each of the characteristic modes
!
!$$$
  use kinds, only: r_kind,i_kind
  implicit none

  integer(i_kind)            ,intent(in   ) :: n,m
  real(r_kind),dimension(n)  ,intent(in   ) :: dsh
  real(r_kind),dimension(m)  ,intent(in   ) :: rate
  real(r_kind),dimension(n,m),intent(  out) :: al

  integer(i_kind) i,kr,ki,kmod2
  real(r_kind):: c0i,c0r,c1,c2

  kmod2=mod(m,2)
  if(kmod2 == 1)then
     c0r=-rate(1)
     do i=1,n
        al(i,1)=exp(c0r*dsh(i))
     enddo
  endif
  do kr=kmod2+1,m,2
     ki=kr+1
     c0i=-rate(ki)
     c0r=-rate(kr)
     do i=1,n
        c1=c0i*dsh(i)
        c2=exp(c0r*dsh(i))
        al(i,kr)=c2*cos(c1)
        al(i,ki)=c2*sin(c1)
     end do
  enddo
  return
end subroutine rfdparv

subroutine linmm(a,b,m,mm,na,nb)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    linmm
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine carries out the linear inversion for a system of
!            m equations with mm right-hand side vectors.
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser  - added documentation
!   2013-01-26  parrish - WCOSS debug compile error -- change input a from intent(in) to intent(inout)
!
!   input argument list:
!     a    - the system matrix (not preserved on output)
!     b    - the right-hand side vectors (output as solution vectors)
!     m    - the order of the system matrix
!     mm   - the number of right-hand side vectors.
!     na   - first fortran dimension of array, a
!     nb   - forst fortran dimension of array, b
!
!   output argument list:
!     b    - the mm solution vectors
!
!$$$
  use kinds, only: r_kind,i_kind
  implicit none

  integer(i_kind)             ,intent(in   ) :: m,mm,na,nb
  real(r_kind),dimension(na,*),intent(inout) :: a
  real(r_kind),dimension(nb,*),intent(inout) :: b

  integer(i_kind),dimension(m):: ipiv    ! <- numerical pivot sequence
  real(r_kind) d

  call ldum(a,ipiv,d,m,na) ! <- perform an L-D-U decomposition with pivoting
  call udlmm(a,b,ipiv,m,mm,na,nb) ! <- perform back-substitutions

  return
end subroutine linmm

subroutine ldum(a,ipiv,d,m,na)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    ldum
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine performs an L-D-U decomposition (in place) with
!            a partial pivoting sequence
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser  - added documentation
!
!   input argument list:
!     a    - matrix of a linear system
!     m    - order of the system matrix
!     na   - first fortran dimension of matrix, a
!
!   output argument list:
!     a    - pivoted L-D-U decomposed system matrix
!     ipiv - pivoting sequence code (list of successive row-swap targets)
!     d    - (real) determinant sign-change flag, +1 or -1.
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero,one
  implicit none

  integer(i_kind)                ,intent(in   ) :: m,na
  integer(i_kind),dimension(m)   ,intent(  out) :: ipiv
  real(r_kind)   ,dimension(na,*),intent(inout) :: a
  real(r_kind)                   ,intent(  out) :: d

  integer(i_kind),parameter:: nn=500

  integer(i_kind) k,ibig,jm,i,jp,j
  real(r_kind) aa,aam,t,abig,ajji,aij,ajj
  real(r_kind),dimension(nn):: s

  if(m>nn) then
     write(6,*)'LDUM:  matrix order m=',m,' greater than assumed limit nn=',nn
     call stop2(67)
  endif
  do i=1,m
     aam=zero
     do j=1,m
        aa=abs(a(i,j))
        if(aa>aam) then
           aam=aa
        end if
     enddo
     if (aam==zero) then
        write(6,*)'LDUM:  row ',i,' of matrix in ldum vanishes'
        call stop2(65)
     endif
     s(i)=one/aam
  enddo
  d=one
  ipiv(m)=m ! <- set default to "no swap"
  do j=1,m-1
     jp=j+1
     abig=s(j)*abs(a(j,j))
     ibig=j
     do i=jp,m
        aa=s(i)*abs(a(i,j))
        if(aa>abig)then
           ibig=i
           abig=aa
        endif
     enddo
!  swap rows, recording changed sign of determinant
     ipiv(j)=ibig
     if(ibig/=j)then
        d=-d ! <- change sign of determinant each time a row-swap occurs
        do k=1,m
           t=a(j,k)
           a(j,k)=a(ibig,k)
           a(ibig,k)=t
        enddo
        s(ibig)=s(j)
     endif
     ajj=a(j,j)
     if(ajj==zero)then
        jm=j-1
        write(6,*)'LDUM:  ***failure*** matrix singular, rank=',jm
        call stop2(66)
     endif
     ajji=one/ajj
     do i=jp,m
        aij=ajji*a(i,j)
        a(i,j)=aij
        do k=jp,m
           a(i,k)=a(i,k)-aij*a(j,k)
        enddo
     enddo
  enddo
  return
end subroutine ldum

subroutine udlmm(a,b,ipiv,m,mm,na,nb)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    udlmm
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine performs the L, the D and the U back-substitution
!            steps on each of the mm right-hand side vectors, taking due
!            account of the encoded pivoting sequence. Note: the calls to
!            subr. dsbvr could be replaced by the f90 intrinsic, "dot_product",
!            (or "sum"), not available when this routine was originally coded.
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser  - added documentation
!
!   input argument list:
!     a    - L-D-U pivoted factors of matrix, stored in place
!     b    - mm right-hand sides
!     ipiv - pivoting sequence of transposition image indexes
!     m    - order of matrix
!     mm   - number of right-hand sides
!     na   - first fortran dimension of a
!     nb   - first fortran dimension of b
!
!   output argument list:
!     b    - mm solution vectors
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: one
  implicit none

  integer(i_kind)                ,intent(in   ) :: na,nb,m,mm
  integer(i_kind),dimension(m)   ,intent(in   ) :: ipiv
  real(r_kind)   ,dimension(na,*),intent(in   ) :: a
  real(r_kind)   ,dimension(nb,*),intent(inout) :: b

  integer(i_kind) k,i,l
  real(r_kind) s,aiii
  do k=1,mm !loop over columns of b
     do i=1,m
        l=ipiv(i)
        s=b(l,k)
        b(l,k)=b(i,k)
        call dsbvr(b(1,k),a(i,1),s,i-1,na)
        b(i,k)=s
     enddo
     b(m,k)=b(m,k)/a(m,m)
     do i=m-1,1,-1
        aiii=one/a(i,i)
        call dsbvr(b(i+1,k),a(i,i+1),b(i,k),m-i,na)
        b(i,k)=b(i,k)*aiii
     enddo
  enddo
  return
end subroutine udlmm

subroutine dsbvr(d,a,s,m,na)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    dsbvr
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  Subtract the dot product of vector d and matrix row a(1,:)
!            from scalar s. (Note: this is a carry-over from the pre-f90 era;
!            a more succinct version of the same task can now be accomplished
!            by using the dot_product intrinsic in the routine that calls this
!            one.)
!
! program history log:
!   1998-01-01  purser
!   2009-08-10  lueken updated subprogram doc block
!
!   input argument list:
!    na,m
!    s
!    d
!    a
!
!   output argument list:
!    s
!
! attributes:
!   language: f90
!   machine:
!
!$$$
  use kinds, only: r_kind,i_kind
  implicit none

  integer(i_kind)             ,intent(in   ) :: na,m
  real(r_kind)                ,intent(inout) :: s
  real(r_kind),dimension(m)   ,intent(in   ) :: d
  real(r_kind),dimension(na,*),intent(in   ) :: a

  integer(i_kind) i

  do i=1,m
     s=s-d(i)*a(1,i)
  enddo
  return
end subroutine dsbvr

subroutine zroots(a,m,roots,polish)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    zroots
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine is the root-finding procedure adapted from
!            Press et al. 1992: Numerical Recipes for fortran 77, Cambridge.
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser  - added documentation
!   2004-10-28  treadon - replace "tiny" with "tiny_r_kind"
!   2005-03-29  treadon - define small = sqrt(tiny_r_kind)
!   2011-07-03  todling - use mathkinds for math-intrisic
!
!   input argument list:
!     a    - complex array of m+1 polynomial coefficients
!     m    - degree of polynomial
!     polish - logical flag to determine whether to "polish" the root values
!
!   output argument list:
!     roots - array of m complex roots listed in increasing order of real prts
!
!$$$
  use kinds, only: r_kind,i_kind
  use constants, only: zero,two,tiny_r_kind
  implicit none

  logical                     ,intent(in   ) :: polish
  integer(i_kind)             ,intent(in   ) :: m
  complex(r_kind),dimension(*),intent(in   ) :: a
  complex(r_kind),dimension(m),intent(  out) :: roots

  integer(i_kind),parameter:: maxm=101

  integer(i_kind) j,i,jj
  real(r_kind)::  small,twosmall2
  complex(r_kind) x,b,c
  complex(r_kind),dimension(maxm):: ad

  small=sqrt(tiny_r_kind)
  twosmall2=two*small*small

  do j=1,m+1
     ad(j)=a(j)
  end do
  do j=m,1,-1
     x=cmplx(zero,zero,r_kind)
     call laguer(ad,j,x,small,.false.)
     if(abs(aimag(x)) <= twosmall2*abs(real(x,r_kind))) then
        x=cmplx(real(x,r_kind),zero,r_kind)
     end if
     roots(j)=x
     b=ad(j+1)
     do jj=j,1,-1
        c=ad(jj)
        ad(jj)=b
        b=x*b+c
     end do
  end do
  if (polish) then
     do j=1,m
        call laguer(a,m,roots(j),small,.true.)
     end do
  endif
  do j=2,m
     x=roots(j)
     do i=j-1,1,-1
        if(real(roots(i),r_kind)<=real(x,r_kind))then
           roots(i+1)=x
           cycle
        end if
        roots(i+1)=roots(i)
     end do
     roots(1)=x
  end do
  return
end subroutine zroots

subroutine laguer(a,m,x,small,polish)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    laguer
!     prgmmr:    purser      org:  np20              date:  1998-01-01
!
! abstract:  This routine is an adaptation of the "Numerical Recipes"
!            root-refining "Laguerre's Method" subroutine. See Numerical
!            Recipes in Fortran 77, 2nd Ed., by Press, Teukolsky, Vetterling
!            and Flannery, Cambridge.
!
! program history log:
!   1998-01-01  purser
!   2004-06-23  purser  - update documentation
!   2011-07-02  todling - adjust smalls for single precision
!
!   input argument list:
!     a    - complex array of m+1 polynomial coefficients
!     m    - degree of the polynomial
!     small - a small real +ve number comparable with machine precision
!     polish - logical flag to determine whether to "polish" result to
!              high precision
!
!   output argument list:
!     x    - one of the complex roots of the polynomial
!
!$$$
  use kinds, only: r_kind,i_kind,r_single,r_double
  use constants, only: zero,two
  implicit none

  logical                     ,intent(in   ) :: polish
  complex(r_kind),dimension(*),intent(in   ) :: a(*)
  complex(r_kind)             ,intent(inout) :: x
  integer(i_kind)             ,intent(in   ) :: m
  real(r_kind)                ,intent(in   ) :: small

  integer(i_kind),parameter:: maxit=100

  integer(i_kind) iter,j
  real(r_kind) abx,cdx,err,dxold
  real(r_kind) smalls
  complex(r_kind) dx,x1,b,d,f,g,h,sq,gp,gm,g2

  if(r_kind==r_single) then
     smalls=6.8e-4_r_kind
  else if(r_kind==r_double) then
     smalls=6.8e-8_r_kind
  else
     write(6,*)'LAGUER:  unsupported precision r_kind=', r_kind
     call stop2(99)
  endif

  dxold=abs(x)
  do iter=1,maxit
     b=a(m+1)
     err=abs(b)
     d=zero
     f=zero
     abx=abs(x)
     do j=m,1,-1
        f=x*f+d
        d=x*d+b
        b=x*b+a(j)
        err=abs(b)+abx*err
     end do
     err=smalls*err
     if(abs(b)<=err) then
        return
     else
        g=d/b
        g2=g*g
        h=g2-two*f/b
        sq=sqrt((m-1)*(m*h-g2))
        gp=g+sq
        gm=g-sq
        if(abs(gp)<abs(gm)) then
           gp=gm
        end if
        dx=m/gp
     endif
     x1=x-dx
     if(x==x1)return
     x=x1
     cdx=abs(dx)
     dxold=cdx
     if(.not.polish)then
        if(cdx<=small*abs(x))return
     endif
  end do
  write(6,*)'LAGUER:  ***warning*** too many iterations'
  return
end subroutine laguer


!	Find estimated conditional expectations and conditional covariance matrices for weighted sums.
!	Responses are in dat.
!	numcat provides ranges for underlying observations.
!	numcatobs provides ranges for observations.
!	mask indicates items to use for computations.
!	beta is the parameter vector.
!	lintran is the linear transformation for the latent vector.
!	postdensity contains posterior weights.
!	theta contains posterior quadrature points.
!	wtsum is a matrix used to compute linear combinations of the observations.
!	covsum is the conditional covariance of wtsum.
!	meansum is the conditional mean of wtsum.

subroutine eapwtsum(dat,numcat,numcatobs,mask,beta,lintran,postdensity,theta,wtsum,covsum,meansum)
implicit none
interface

!	Multinomial covariance matrix.
!	density is vector of probabilities.
!	meanth is vector of means.
!	quadpoint is array of weights.
	function mcovth(density,meanth,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),meanth(:),quadpoint(:,:)
		real(kind=8)::mcovth(size(meanth),size(meanth))
	end function mcovth
!	Multinomial mean.
!	density is vector of probabilities
!	quadpoint is array of weights.
	function mmeanth(density,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),quadpoint(:,:)
		real(kind=8)::mmeanth(size(quadpoint,1))
	end function mmeanth
!	probvec is used to compute underlying item probabilities.
!   numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
	function probvec(numcat,mask,locations,scales,theta)
		implicit none
		integer,intent(in)::numcat(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
		real(kind=8)::probvec(size(locations))
	end function probvec

end interface
integer,intent(in)::dat(:,:),numcat(:),numcatobs(:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::beta(:),lintran(:,:),postdensity(:,:),theta(:,:,:),&
	wtsum(:,:)
real(kind=8),intent(out)::covsum(:,:,:),meansum(:,:)
!	item is an item.
!	ncat is the total number of underlying categories.
!	obs is observation number.
!	quad counts quadrature points.
!	resp is a single response.
!	row is a row counter.

integer::item,ncat,obs,quad,resp(size(mask)),row

!	locations is for location parameters.

!	meanquad is for means for quadrature points.
!	newtheta is lintran(theta).
!	probcat is used for underlying marginal conditional probabilities.
!	scales is for scale parameters.

real(kind=8)::locations(sum(numcat)),&
	meanquad(size(wtsum,1),size(postdensity,1)),newtheta(size(lintran,1)),&
	probcat(sum(numcat)),scales(size(lintran,1),sum(numcat))

!	Set up parameter arrays for simplified processing.
ncat=sum(numcat)
!	Item scale parameters.
locations=beta(1:ncat)
scales=reshape(beta(ncat+1:ncat*(1+size(lintran,1))),(/size(lintran,1),ncat/))

!	Obtain results for each observation.
do obs=1,size(postdensity,2)

!	Cycle through quadrature points.
	meanquad=0.0_8
	do quad=1,size(postdensity,1)
		newtheta=matmul(lintran,theta(:,quad,obs))

! Probability computation.

		probcat=probvec(numcat,mask,locations,scales,newtheta)

		if(size(wtsum,1)>0)then
			row=1

			do item=1,size(mask)
				if(mask(item)) meanquad(:,quad)=meanquad(:,quad)+&
                    mmeanth(probcat(row:row+numcat(item)-1),wtsum(:,row:row+numcat(item)-1))
				row=row+numcat(item)
			end do

		end if
	end do

!	mean and covariance.
	meansum(:,obs)=mmeanth(postdensity(:,obs),meanquad)
    covsum(:,:,obs)=mcovth(postdensity(:,obs),meansum(:,obs),meanquad)

end do
return
end subroutine eapwtsum


MODULE precision
    ! dp = double precision
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

PROGRAM precision_using_module
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp), DIMENSION(20000000):: A
    REAL(KIND = dp):: X
    X = SIZE(A)-1
    PRINT *, KIND(x), x

END PROGRAM precision_using_module


subroutine ordena(n,v)

!-----------------------------------------------------------------------
!****f* Mathru/ordena
! NAME
! DESCRIPTION
!    This routine orders array v cording to its first column
! USES
! USED BY
!***
!-----------------------------------------------------------------------
  use       typre
  implicit   none
  integer(ip), intent(in)    :: n
  real(rp),    intent(inout) :: v(2,n)
  integer(ip)                :: i,j
  real(rp)                   :: v1,v2

  do j=2,n
     v1=v(1,j)
     v2=v(2,j)
     do i=j-1,1,-1
        if(v(1,i)<=v1) go to 30
        v(1,i+1)=v(1,i)
        v(2,i+1)=v(2,i)
     end do
     i=0
30   v(1,i+1)=v1
     v(2,i+1)=v2
  end do

end subroutine ordena


*----------------------------------------------------------------------*
      logical function next_part_pair(init,restrict,ipart,
     &     inum,nsum,inummin,inummax)
*----------------------------------------------------------------------*
*     create next partitioning of a pair of integer numbers inum(1:2)
*     into nsum summands (inummin.le.value.le.inummax for each element)
*      -- returned on ipart(1:2,nsum)
*     the numbers are ordered in increasing sequence, with the convention
*     inum=(/j,i+1/) is for all i,j,k greater than inum=(/k,i/)
*     if init==.true. the first possible partitioning is created
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      logical, intent(in) ::
     &     init, restrict
      integer, intent(in) ::
     &     inum(2), nsum, inummin, inummax
      integer, intent(inout) ::
     &     ipart(2,nsum)

      logical ::
     &     succ, init_loc
      integer ::
     &     ipscr(nsum), ipscr2(2,nsum), idx, isum, ibase,
     &     inumidx, inummaxidx

      logical, external ::
     &     next_part_number

      if (ntest.ge.100) then
        write(lulog,*) '=========================='
        write(lulog,*) ' this is next_part_pair'
        write(lulog,*) '=========================='
        write(lulog,*) '  inum = /',inum(1),char(92)
        write(lulog,*) '        ',char(92),inum(2),'/'
        write(lulog,*) '  nsum,inummin,inummax: ',
     &                nsum,inummin,inummax
        if (init) then
          write(lulog,*) 'initiating ...'
        else
          write(lulog,*) 'partitioning on entry: '
          write(lulog,'(2x,">",10i4)') ipart(1,1:nsum)
          write(lulog,'(2x,">",10i4)') ipart(2,1:nsum)
        end if
      end if

      ! base for element ordering function:
      ibase = inummax*nsum+1

      ! create auxiliary array
      if (.not.init) then
        do idx = 1, nsum
          ipscr(idx) = ipart(1,idx)+ipart(2,idx)*ibase
        end do
      end if

      inumidx = inum(1)+inum(2)*ibase
      inummaxidx = inummax*(ibase+1)

      init_loc = init
      succ = .false.
      do while(next_part_number(init_loc,restrict,ipscr,
     &     inumidx,nsum,inummin,inummaxidx))

        init_loc = .false.
        succ = .true.
        do idx = 1, nsum
          ipscr2(1,idx) = mod(ipscr(idx),ibase)
          ipscr2(2,idx) = ipscr(idx)/ibase
          succ = succ.and.
     &         ipscr2(1,idx).le.inummax.and.ipscr2(2,idx).le.inummax
        end do
        if (succ) then
          ipart(1:2,1:nsum) = ipscr2(1:2,1:nsum)
          exit
        end if

      end do

      if (ntest.ge.100) then
        if (succ) then
          write(lulog,*) '  created partitioning: '
          write(lulog,'(2x,">",10i4)') ipart(1,1:nsum)
          write(lulog,'(2x,">",10i4)') ipart(2,1:nsum)
        else
          write(lulog,*) ' no (further) partitioning possible'
        end if
      end if

      next_part_pair = succ

      return
      end


      PROGRAM LA_SGGESX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GGESX
!  .. "Local Scalars" ..
      INTEGER :: I, J, N
      INTERFACE
         LOGICAL FUNCTION SELECT(X, Y, Z)
           USE LA_PRECISION, ONLY: WP => SP
           REAL(WP), INTENT(IN) :: X, Y, Z
         END FUNCTION SELECT
      END INTERFACE
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), RCONDE(:), RCONDV(:), VSL(:,:)
      REAL(WP), ALLOCATABLE :: ALPHAR(:), ALPHAI(:), BETA(:), VSR(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GGESX Example Program Results'
      N = 5
      ALLOCATE( A(N,N),  B(N,N), ALPHAR(N), ALPHAI(N), BETA(N), &
                VSL(N,N), VSR(N,N), RCONDE(2), RCONDV(2) )

      OPEN(UNIT=21,FILE='gges.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(A(I,:));
      ENDDO

      OPEN(UNIT=21,FILE='gges.mb',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix B : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(B(I,:));
      ENDDO

      WRITE(*,*)
      WRITE(*,*) 'CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, SELECT=SELECT,', &
                               ' RCONDE=RCONDE, RCONDV=RCONDV )'
      CALL LA_GGESX( A, B, ALPHAR, ALPHAI, BETA, SELECT=SELECT, &
                     RCONDE=RCONDE, RCONDV=RCONDV )

      WRITE(*,*)
      WRITE(*,*)'RCONDE = ', RCONDE
      WRITE(*,*)'RCONDV = ', RCONDV

      END PROGRAM LA_SGGESX_EXAMPLE
! CONTAINS
    LOGICAL FUNCTION SELECT( ALPHAR, ALPHAI, BETA )
      USE LA_PRECISION, ONLY: WP => SP
      REAL(WP), INTENT(IN) :: ALPHAR, ALPHAI, BETA
      INTRINSIC EPSILON, ABS
!
      IF ( ABS(BETA) > EPSILON(1.0_WP) ) THEN
         IF ( ABS(ALPHAI/BETA) < 3.0_WP) THEN
            SELECT = .TRUE.
         ELSE
            SELECT = .FALSE.
         ENDIF
      ELSE
         SELECT = .FALSE.
      ENDIF

    END FUNCTION SELECT


! PROGRAM TO TEST THE OPTIONAL ARGUMENTS TO RESHAPE
  INTERFACE
     SUBROUTINE WRITE_MATRIX(A)
         REAL, DIMENSION(:,:) :: A
     END SUBROUTINE  WRITE_MATRIX
  END INTERFACE

  REAL, DIMENSION (1:9) :: B = (/ 11, 12, 13, 14, 15, 16, 17, 18, 19 /)
  REAL, DIMENSION (1:9) :: A = (/ 1, 1, 1, 2, 2, 2, 3, 3, 3 /)
  REAL, DIMENSION (1:9) :: Bpack,Apack,Cfill

  REAL, DIMENSION (1:3, 1:3) :: C, D, E
  REAL, DIMENSION (1:4, 1:4) :: F, G, H

  INTEGER, DIMENSION (1:2) :: ORDER1 = (/ 1, 2 /)
  INTEGER, DIMENSION (1:2) :: ORDER2 = (/ 2, 1 /)
  REAL, DIMENSION (1:16)   :: PAD1 = (/ -1, -2, -3, -4, -5, -6, -7, -8, &
                                 &   -9, -10, -11, -12, -13, -14, -15, -16 /)

  Cfill=0
  Bpack = pack(B,A==2,Cfill)

  print*, Bpack
  ! C = RESHAPE( B, (/ 3, 3 /) )
  ! CALL WRITE_MATRIX(C)

  ! D = RESHAPE( B, (/ 3, 3 /), ORDER = ORDER1)
  ! CALL WRITE_MATRIX(D)

  ! E = RESHAPE( B, (/ 3, 3 /), ORDER = ORDER2)
  ! CALL WRITE_MATRIX(E)

  ! F = RESHAPE( B, (/ 4, 4 /), PAD = PAD1)
  ! CALL WRITE_MATRIX(F)

  ! G = RESHAPE( B, (/ 4, 4 /), PAD = PAD1, ORDER = ORDER1)
  ! CALL WRITE_MATRIX(G)

  ! H = RESHAPE( B, (/ 4, 4 /), PAD = PAD1, ORDER = ORDER2)
  ! CALL WRITE_MATRIX(H)

  END

  SUBROUTINE WRITE_MATRIX(A)
  REAL, DIMENSION(:,:) :: A
  WRITE(*,*)
  DO I = LBOUND(A,1), UBOUND(A,1)
     WRITE(*,*) (A(I,J), J = LBOUND(A,2), UBOUND(A,2))
  END DO
  END SUBROUTINE WRITE_MATRIX


program P2579

    integer :: stairs_count
    integer, dimension(300) :: points

    integer :: current, current_skipped, prev, prev_temp

    read (*,*) stairs_count

    do i = 1, stairs_count
        read (*,*) points(i)
    end do

    prev = 0
    current = points(1)
    current_skipped = points(1)

    do i = 2, stairs_count
        prev_temp = max(current, current_skipped)
        current = points(i) + current_skipped
        current_skipped = points(i) + prev
        prev = prev_temp
    end do
    write (*, '(I0)') max(current, current_skipped)

end program


module eval_conductivity
    use conductivity_def

contains

    subroutine conductivity(rq,rho,T,chi,Gamma,eta,mu_e,ionic,Tns,kappa)
        use exceptions_lib
        use constants_def
        use nucchem_def, only: composition_info_type
        use neutron_conductivity
        use electron_conductivity
        use photon_conductivity

        type(conductivity_general_info), pointer :: rq
        real(dp), intent(in) :: rho, T, chi, Gamma, eta, mu_e   ! mu_e is in MeV
        type(composition_info_type), intent(in) :: ionic
        real(dp), intent(in) :: Tns ! superfluid critical temperature, neutrons
        type(conductivity_components), intent(out) :: kappa
        real(dp) :: nn, nion, ne, kF, xF, eF, Gamma_e, kappa_e_pre
        real(dp) :: kappa_n_pre, kfn, mnstar, tau, v, R
        real(dp) :: nu, nu_c, K_opacity, lgrho, alpha
        ! consider putting these in the general info structure
        real(dp), parameter :: eQ_threshold = 1.0e-8_dp
        real(dp), parameter :: sf_reduction_threshold = 1.0e-10_dp
        integer :: ierr
        type(alert) :: scattering_options=alert(scope='conductivity')
        type(failure) :: nimp_error=failure(scope='conductivity')
        type(failure) :: nph_error=failure(scope='conductivity')

        call clear_kappa
        lgrho = log10(rho)

        ! electrons; always included
        ne = rho/amu*ionic%Ye
        kF = (threepisquare*ne)**onethird
        xF = hbar*kF/Melectron/clight
        eF = sqrt(1.0_dp+xF**2)
        Gamma_e = Gamma/ionic%Z53
        kappa_e_pre = onethird*pi**2*boltzmann**2*T*ne/Melectron/eF
        nu = 0.0_dp
        nu_c = 0.0_dp

        ! electron-electron scattering
        select case (rq% ee_scattering_fmla)
        case(icond_sy06)
            nu_c = ee_SY06(ne,T)
        case(icond_pcy)
            nu_c = ee_PCY(ne,T)
        case default
            call scattering_options% report( &
            &   'unknown option for ee scattering: using SY06')
            nu_c = ee_SY06(ne,T)
        end select
        nu = nu + nu_c
        if (nu_c > tiny(1.0_dp)) kappa% ee = kappa_e_pre/nu_c

        ! electron-ion scattering
        nu_c = eion( &
        &   kF,Gamma_e,eta,ionic%Ye,ionic%Z,ionic%Z2,ionic%Z53,ionic%A)
        nu = nu + nu_c
        if (nu_c > tiny(1.0_dp)) kappa% ei = kappa_e_pre/nu_c

        ! electron-impurity scattering
        select case(rq% eQ_scattering_fmla)
        case(icond_eQ_potekhin)
            nu_c = eQ(kF,T,ionic%Ye,ionic%Z,ionic%Z2,ionic%A,ionic%Q)
        case(icond_eQ_page)
            nu_c = eQ_page( &
            &    kF,T,ionic%Ye,ionic%Z,ionic%Z2,ionic%A,ionic%Q)
        case default
            call scattering_options% report( &
            &   'unknown option for eQ scattering: using Potekhin')
            nu_c = eQ(kF,T,ionic%Ye,ionic%Z,ionic%Z2,ionic%A,ionic%Q)
        end select
        nu = nu + nu_c
        if (ionic%Q > eQ_threshold) kappa% eQ = kappa_e_pre/nu_c

        kappa% electron_total = kappa_e_pre/nu

        ! neutrons
        if (ionic% Yn > 0.0_dp) then
            if (rq% include_neutrons) then
                nu = 0.0_dp
                nu_c = 0.0_dp
                nn = rho/amu*ionic% Yn/(1.0-chi)
                kFn = (threepisquare*nn)**onethird
                nion = rho/amu*(1.0-ionic%Yn)/ionic%A
                mnstar = Mneutron
                kappa_n_pre = onethird*pi**2*boltzmann**2*T*nn/mnstar

                ! superfluid reduction factor
                R = 1.0
                if (T < Tns) then
                    tau = T/Tns
                    v = sqrt(1.0-tau)*(1.456-0.157/sqrt(tau) + 1.764/tau)
                    R = (0.4186+sqrt(1.007**2+(0.5010*v)**2))**2.5 * &
                    &   exp(1.456-sqrt(1.456**2+v**2))
                    if (R < sf_reduction_threshold) R = 0.0
                end if

                nu_c = n_imp(nn,nion,T,ionic,ierr)
                if (nimp_error% raised(ierr)) then
                    nu_c = 0.0_dp
                else
                    kappa% nQ = kappa_n_pre/nu_c*R
                    nu = nu + nu_c
                end if

                nu_c = n_phonon(nn,nion,T,ionic, ierr)
                if (nph_error% raised(ierr)) then
                    nu_c = 0.0_dp
                else
                    kappa% np = kappa_n_pre/nu_c*R
                    nu = nu + nu_c
                end if

                if (nu > 0.0_dp) kappa% neutron_total = kappa_n_pre/nu*R
            end if

            ! superfluid phonons
            if (rq% include_superfluid_phonons .and. T < Tns) then
                kappa% sf =  sPh(nn/density_n,nion/density_n,T,ionic)
            end if
        end if

        ! photons
        K_opacity = 0.0_dp
        kappa% kap = 0.0_dp
        if (lgrho < rq% rad_full_off_lgrho) then
            kappa% kap = Rosseland_kappa(rho,T,mu_e,ionic)
            if (lgrho > rq% rad_full_on_lgrho) then
                alpha = (lgrho-rq% rad_full_on_lgrho)/(rq% rad_full_off_lgrho-rq% rad_full_on_lgrho)
                kappa% kap = kappa% kap * (1.0_dp-alpha)
            end if
            K_opacity = 4.0_dp*onethird*arad*clight*T**3/rho/kappa% kap
        end if

        kappa% total = kappa% electron_total  &
        &   + kappa% neutron_total + kappa% sf &
        &   + K_opacity

        contains
        subroutine clear_kappa()
            kappa% total = 0.0_dp
            kappa% ee  = 0.0_dp
            kappa% ei = 0.0_dp
            kappa% eQ = 0.0_dp
            kappa% sf = 0.0_dp
            kappa% kap = 0.0_dp
            kappa% nQ = 0.0_dp
            kappa% np = 0.0_dp
            kappa% electron_total = 0.0_dp
            kappa% neutron_total = 0.0_dp
        end subroutine clear_kappa
    end subroutine conductivity

end module eval_conductivity