module iterator_product_test_module
    use :: assert_module, only : assert
    use :: iterator_product_module, only : iterator_product
    use :: iterator_module, only : iterator
    use :: iterator_constraint_wrapper_module, only : iterator_constraint_wrapper
    use :: pleq_constraint_module, only : pleq_constraint
    implicit none
    private

    public :: iterator_product_test

    type :: iterator_product_test
    contains
        procedure :: run => run
        procedure :: cleanup => cleanup
        procedure :: clear => clear
    end type iterator_product_test

    interface iterator_product_test
        module procedure constructor
    end interface iterator_product_test

contains
    function constructor() result(this)
        type(iterator_product_test) :: this

        call this%clear()
    end function constructor

    subroutine run(this, assertion)
        class(iterator_product_test), intent(in) :: this
        type(assert), intent(inout) :: assertion

        integer, dimension(:,:), allocatable :: combined, res
        type(iterator) :: aniterator
        type(iterator), dimension(:), allocatable :: iterators
        type(iterator_constraint_wrapper), dimension(1) :: constraints
        integer :: rank, number_of_states

        combined = get_combined([iterator(1,3)])
        allocate(res(3,1))
        res(:,1) = [1,2,3]
        call assertion%is_equal("iterator_product::rank1_size1", 3, size(combined))
        call assertion%equal("iterator_product::rank1_combined1", all(combined == res) )
        deallocate(res)

        combined = get_combined([iterator(2,3)])
        allocate(res(2,1))
        res(:,1) = [2,3]
        call assertion%is_equal("iterator_product::rank1_size2", 2, size(combined))
        call assertion%equal("iterator_product::rank1_combined2", all(combined == res) )
        deallocate(res)

        combined = get_combined([iterator(1,2), iterator(3,4)])
        allocate(res(4,2))
        res(:,1) = [1, 1, 2, 2]
        res(:,2) = [3, 4, 3, 4]
        call assertion%is_equal("iterator_product::rank2", 2, size(combined, 2))
        call assertion%is_equal("iterator_product::rank2_size1", 4, size(combined, 1))
        call assertion%equal("iterator_product::rank2_combined1", all(combined == res) )
        deallocate(res)

        combined = get_combined_column_major([iterator(1,2), iterator(3,4)])
        allocate(res(4,2))
        res(:,1) = [1, 2, 1, 2]
        res(:,2) = [3, 3, 4, 4]
        call assertion%is_equal("iterator_product::rank2 column major", 2, size(combined, 2))
        call assertion%is_equal("iterator_product::rank2_size1 column major", 4, size(combined, 1))
        call assertion%equal("iterator_product::rank2_combined1 column major", all(combined == res) )
        deallocate(res)

        number_of_states = 12
        aniterator = iterator(1, number_of_states)
        constraints = [ iterator_constraint_wrapper(pleq_constraint()) ]

        rank = 1
        iterators = [aniterator]
        combined = get_combined(iterators)
        call assertion%is_equal("iterator_product::p1::number_of_configs",  &
            size(combined, 1), number_of_states**rank)
        combined = get_combined(iterators, constraints)
        call assertion%is_equal("iterator_product::p1_pleq::number_of_configs",  &
            size(combined, 1), get_triangular_number(number_of_states,rank))

        rank = 2
        iterators = [aniterator, aniterator]

        combined = get_combined(iterators)
        call assertion%is_equal("iterator_product::p2::number_of_configs",  &
            size(combined, 1), number_of_states**rank)
        combined = get_combined(iterators, constraints)
        call assertion%is_equal("iterator_product::p2_pleq::number_of_configs",  &
            size(combined, 1), get_triangular_number(number_of_states,rank))

        rank = 3
        iterators = [aniterator, aniterator, aniterator]

        combined = get_combined(iterators)
        call assertion%is_equal("iterator_product::p3::number_of_configs",  &
            size(combined, 1), number_of_states**rank)
        combined = get_combined(iterators, constraints)
        call assertion%is_equal("iterator_product::p3_pleq::number_of_configs",  &
            size(combined, 1), get_triangular_number(number_of_states,rank))

        rank = 4
        iterators = [aniterator, aniterator, aniterator, aniterator]

        combined = get_combined(iterators)
        call assertion%is_equal("iterator_product::p4::number_of_configs",  &
            size(combined, 1), number_of_states**rank)
        combined = get_combined(iterators, constraints)
        call assertion%is_equal("iterator_product::p4_pleq::number_of_configs",  &
            size(combined, 1), get_triangular_number(number_of_states,rank))

        rank = 5
        iterators = [aniterator, aniterator, aniterator, aniterator, aniterator]

        combined = get_combined(iterators)
        call assertion%is_equal("iterator_product::p5::number_of_configs",  &
            size(combined, 1), number_of_states**rank)
        combined = get_combined(iterators, constraints)
        call assertion%is_equal("iterator_product::p5_pleq::number_of_configs",  &
            size(combined, 1), get_triangular_number(number_of_states,rank))
    end subroutine run

    subroutine cleanup(this)
        class(iterator_product_test), intent(inout) :: this

        call this%clear()
    end subroutine cleanup

    subroutine clear(this)
        class(iterator_product_test), intent(inout) :: this
    end subroutine clear

    function get_combined(iterators, constraints) result(combined)
        type(iterator), dimension(:) :: iterators
        type(iterator_constraint_wrapper), dimension(:), intent(in), optional :: constraints
        integer, dimension(:,:), allocatable :: combined

        type(iterator_product) :: iproduct
        type(iterator) :: aniterator

        iproduct = iterator_product(constraints)
        aniterator = iproduct%get_product_row_major(iterators)
        combined = aniterator%get_all_items()
    end function get_combined

    function get_combined_column_major(iterators, constraints) result(combined)
        type(iterator), dimension(:) :: iterators
        type(iterator_constraint_wrapper), dimension(:), intent(in), optional :: constraints
        integer, dimension(:,:), allocatable :: combined

        type(iterator_product) :: iproduct
        type(iterator) :: aniterator

        iproduct = iterator_product(constraints)
        aniterator = iproduct%get_product_column_major(iterators)
        combined = aniterator%get_all_items()
    end function get_combined_column_major

    function get_triangular_number(nstates, nranks) result(triangular_number)
        integer, intent(in) :: nstates, nranks
        integer :: triangular_number

        integer :: idx

        triangular_number = nstates
        do idx = 1, nranks-1
            triangular_number = triangular_number*(nstates+idx)
        end do

        do idx = nranks, 2, -1
            triangular_number = triangular_number/idx
        end do
    end function get_triangular_number

end module iterator_product_test_module


MODULE Penmanmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_penman(evapoTranspirationPriestlyTaylor, &
        hslope, &
        VPDair, &
        psychrometricConstant, &
        Alpha, &
        lambdaV, &
        rhoDensityAir, &
        specificHeatCapacityAir, &
        conductance, &
        evapoTranspirationPenman)
        IMPLICIT NONE
        REAL, INTENT(IN) :: evapoTranspirationPriestlyTaylor
        REAL, INTENT(IN) :: hslope
        REAL, INTENT(IN) :: VPDair
        REAL, INTENT(IN) :: psychrometricConstant
        REAL, INTENT(IN) :: Alpha
        REAL, INTENT(IN) :: lambdaV
        REAL, INTENT(IN) :: rhoDensityAir
        REAL, INTENT(IN) :: specificHeatCapacityAir
        REAL, INTENT(IN) :: conductance
        REAL, INTENT(OUT) :: evapoTranspirationPenman
        !- Description:
    !            * Title: Penman 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
    !            * Abstract: This method is used when wind and vapor pressure daily data are available
    !
        !- inputs:
    !            * name: evapoTranspirationPriestlyTaylor
    !                          ** description : evapoTranspiration of Priestly Taylor
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** default : 449.367
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: hslope
    !                          ** description : the slope of saturated vapor pressure temperature curve at a given temperature
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.584
    !                          ** min : 0
    !                          ** max : 1000
    !                          ** unit : hPa °C-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: VPDair
    !                          ** description :  vapour pressure density
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 2.19
    !                          ** min : 0
    !                          ** max : 1000
    !                          ** unit : hPa
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: psychrometricConstant
    !                          ** description : psychrometric constant
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.66
    !                          ** min : 0
    !                          ** max : 1
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: Alpha
    !                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 1.5
    !                          ** min : 0
    !                          ** max : 100
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: lambdaV
    !                          ** description : latent heat of vaporization of water
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 2.454
    !                          ** min : 0
    !                          ** max : 10
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: rhoDensityAir
    !                          ** description : Density of air
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 1.225
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: specificHeatCapacityAir
    !                          ** description : Specific heat capacity of dry air
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.00101
    !                          ** min : 0
    !                          ** max : 1
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: conductance
    !                          ** description : conductance
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 598.685
    !                          ** unit : m d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
        !- outputs:
    !            * name: evapoTranspirationPenman
    !                          ** description :  evapoTranspiration of Penman Monteith
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 5000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        evapoTranspirationPenman = evapoTranspirationPriestlyTaylor / Alpha +  &
                (1000.0 * (rhoDensityAir * specificHeatCapacityAir * VPDair *  &
                conductance / (lambdaV * (hslope + psychrometricConstant))))
    END SUBROUTINE model_penman

END MODULE


include "interpolate.f90"
!-----------------------------------------
!
! compute du_i/dt += epsilon * w_j * U^k (epsilon=-1)
! arrays are in [j, i, k] convention
! U^k is averaged at i point
! w_j upwinded in the k direction
!

subroutine vortex_force_direc(U, vort, res, order, m, n, l)

  implicit none

  integer, intent(in):: l, m, n, order
  real*8, dimension(m, n, l), intent(in) :: U, vort
  real*8, dimension(m, n, l), intent(inout) :: res

  !f2py intent(inplace):: vort, res, U

  integer:: i, j, k
  real*8:: c1,c2,c3, b1, b2, b3, b4, b5
  real*8:: UU, UU_0, UU_1, U_omega
  real*8,dimension(l) :: qm
  real*8,dimension(0:l-1):: qp
  real*8,dimension(l) :: vU, U_interp, um, up

  c1 = -1./6.
  c2 =  5./6.
  c3 =  2./6.

  b1 = 2./60.
  b2 = -13./60.
  b3 = 47./60.
  b4 = 27./60.
  b5 = -3./60.

  do j = 1,m
     do i = 1,n-1 ! because u_i[:,:,-1] = 0. (BC)
        UU_0 = 0.
        do k=1,l
           UU_1 = 0.5 * ( U(j,i,k) + U(j,i+1,k))
           vU(k) =  vort(j,i,k)!*UU_1
           U_interp(k) = 0.5*(UU_0+UU_1)
           UU = abs(U_interp(k))
           up(k) = 0.5*(U_interp(k)+UU) ! right-going flux
           um(k) = 0.5*(U_interp(k)-UU) ! left-going flux
           UU_0 = UU_1
        enddo
        !
        call interpolate(vU, qp, qm, order, l)
        !
        if (mod(order, 2).eq.0) then
           do k=1,l
                 res(j,i,k) = res(j,i,k)-qm(k)
           enddo
        else
           do k=1,l
              res(j,i,k) = res(j,i,k)-qp(k-1)*up(k)-qm(k)*um(k)
           enddo
        endif
    end do
  end do

end subroutine vortex_force_direc

subroutine vortex_force_flip(U, vort, res, order, m, n, l)
  ! directions 1 and 2 are swapped compared to above
  ! the force is counted with a +
  implicit none

  integer, intent(in):: l, m, n, order
  real*8, dimension(m, n, l), intent(in) :: U, vort
  real*8, dimension(m, n, l), intent(inout) :: res

  !f2py intent(inplace):: vort, res, U

  integer:: i, j, k
  real*8:: c1,c2,c3, b1, b2, b3, b4, b5
  real*8:: UU, UU_0, UU_1, U_omega
  real*8,dimension(n):: qm
  real*8,dimension(0:n-1):: qp
  real*8,dimension(n) :: vU, U_interp, up, um

  c1 = -1./6.
  c2 =  5./6.
  c3 =  2./6.

  b1 = 2./60.
  b2 = -13./60.
  b3 = 47./60.
  b4 = 27./60.
  b5 = -3./60.

  do j = 1,m
     do k=1,l-1
        UU_0 = 0.
        do i=1,n
           UU_1 = 0.5 * ( U(j,i,k) + U(j,i,k+1))
           vU(i) =  vort(j,i,k)!*UU_1
           U_interp(i) = 0.5*(UU_0+UU_1)
           UU = abs(U_interp(i))
           up(i) = 0.5*(U_interp(i)+UU) ! right-going flux
           um(i) = 0.5*(U_interp(i)-UU) ! left-going flux
           UU_0 = UU_1
        enddo!
        !
        call interpolate(vU, qp, qm, order, n)

        if (mod(order, 2).eq.0) then
           do i=1,n
              res(j,i,k) = res(j,i,k)+qm(i)
           enddo
        else
           do i=1,n
              res(j,i,k) = res(j,i,k)+qp(i-1)*up(i)+qm(i)*um(i)
           enddo
        endif

     enddo
  enddo

end subroutine vortex_force_flip


*DECK STRSL
      SUBROUTINE STRSL (T, LDT, N, B, JOB, INFO)
C***BEGIN PROLOGUE  STRSL
C***PURPOSE  Solve a system of the form  T*X=B or TRANS(T)*X=B, where
C            T is a triangular matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2A3
C***TYPE      SINGLE PRECISION (STRSL-S, DTRSL-D, CTRSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM,
C             TRIANGULAR MATRIX
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     STRSL solves systems of the form
C
C                   T * X = B
C     or
C                   TRANS(T) * X = B
C
C     where T is a triangular matrix of order N.  Here TRANS(T)
C     denotes the transpose of the matrix T.
C
C     On Entry
C
C         T         REAL(LDT,N)
C                   T contains the matrix of the system.  The zero
C                   elements of the matrix are not referenced, and
C                   the corresponding elements of the array can be
C                   used to store other information.
C
C         LDT       INTEGER
C                   LDT is the leading dimension of the array T.
C
C         N         INTEGER
C                   N is the order of the system.
C
C         B         REAL(N).
C                   B contains the right hand side of the system.
C
C         JOB       INTEGER
C                   JOB specifies what kind of system is to be solved.
C                   If JOB is
C
C                        00   solve T*X=B, T lower triangular,
C                        01   solve T*X=B, T upper triangular,
C                        10   solve TRANS(T)*X=B, T lower triangular,
C                        11   solve TRANS(T)*X=B, T upper triangular.
C
C     On Return
C
C         B         B contains the solution, if INFO .EQ. 0.
C                   Otherwise B is unaltered.
C
C         INFO      INTEGER
C                   INFO contains zero if the system is nonsingular.
C                   Otherwise INFO contains the index of
C                   the first zero diagonal element of T.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  STRSL
      INTEGER LDT,N,JOB,INFO
      REAL T(LDT,*),B(*)
C
C
      REAL SDOT,TEMP
      INTEGER CASE,J,JJ
C***FIRST EXECUTABLE STATEMENT  STRSL
C
C        CHECK FOR ZERO DIAGONAL ELEMENTS.
C
         DO 10 INFO = 1, N
            IF (T(INFO,INFO) .EQ. 0.0E0) GO TO 150
   10    CONTINUE
         INFO = 0
C
C        DETERMINE THE TASK AND GO TO IT.
C
         CASE = 1
         IF (MOD(JOB,10) .NE. 0) CASE = 2
         IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2
         GO TO (20,50,80,110), CASE
C
C        SOLVE T*X=B FOR T LOWER TRIANGULAR
C
   20    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 40
            DO 30 J = 2, N
               TEMP = -B(J-1)
               CALL SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1)
               B(J) = B(J)/T(J,J)
   30       CONTINUE
   40       CONTINUE
         GO TO 140
C
C        SOLVE T*X=B FOR T UPPER TRIANGULAR.
C
   50    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 70
            DO 60 JJ = 2, N
               J = N - JJ + 1
               TEMP = -B(J+1)
               CALL SAXPY(J,TEMP,T(1,J+1),1,B(1),1)
               B(J) = B(J)/T(J,J)
   60       CONTINUE
   70       CONTINUE
         GO TO 140
C
C        SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
C
   80    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 100
            DO 90 JJ = 2, N
               J = N - JJ + 1
               B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1)
               B(J) = B(J)/T(J,J)
   90       CONTINUE
  100       CONTINUE
         GO TO 140
C
C        SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
C
  110    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 130
            DO 120 J = 2, N
               B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1)
               B(J) = B(J)/T(J,J)
  120       CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END


c     interpolation and extrapolation by m-th order polynomial
c     maximum m = 3. Change nmax if needed.
c     Input x and y arrays, returns y value y0 at requested x value x0.
c     Dies on error.

      subroutine terp (x, y, n, m, x0, y0)
      implicit double precision (a-h, o-z)

      dimension x(n), y(n)

c     Find out between which x points x0 lies
      i = locat (x0, n, x)
      k = min( max(i-m/2,1) , n-m )
      call polint( x(k), y(k), m+1, x0, y0, dy)

      return
      end

      function locat (x, n, xx)
      integer  u, m, n
      double precision x, xx(n)

c     Binary search for index of grid point immediately below x.
c     Array xx required to be monotonic increasing.
c     Returns
c     0            x <  xx(1)
c     1            x =  xx(1)
c     i            x =  xx(i)
c     n            x >= xx(n)

      locat = 0
      u = n+1

   10 if (u-locat .gt. 1)  then
         m = (u + locat) / 2
         if (x .lt. xx(m))  then
            u = m
         else
            locat = m
         endif
         goto 10
      endif

      return
      end

c     These routines, terp1 and locat1, are special versions to
c     be used with ff2chi, which uses some single and some double
c     precision.  They are the same as the routines in terp.f.

      subroutine terp1 (x, y, n, x0, y0)
      implicit double precision (a-h, o-z)

      real x(n), y(n)

c     Find out between which x points x0 lies
      i = locat1 (x0, n, x)
c     if i < 1, set i=1, if i > n-1, set i=n-1
      i = max (i, 1)
      i = min (i, n-1)

      if (x(i+1) - x(i) .eq. 0)  stop 'TERP-1'

      y0 = y(i) +  (x0 - x(i)) * (y(i+1) - y(i)) / (x(i+1) - x(i))

      return
      end

      function locat1 (x, n, xx)
      integer  u, m, n
      double precision x
      real xx(n)

c     Binary search for index of grid point immediately below x.
c     Array xx required to be monotonic increasing.
c     Returns
c     0            x <  xx(1)
c     1            x =  xx(1)
c     i            x =  xx(i)
c     n            x >= xx(n)

      locat1 = 0
      u = n+1

   10 if (u-locat1 .gt. 1)  then
         m = (u + locat1) / 2
         if (x .lt. xx(m))  then
            u = m
         else
            locat1 = m
         endif
         goto 10
      endif

      return
      end


C     cycle_02.f
C     A simple example of cycle with break within the loop.
C     Output: i = 1...19 k = 19
C     Source: http://annefou.github.io/Fortran/basics/control.html

      program odd_number
      implicit none
      integer :: n, k
      n = 19
      k = 0
      do while (.true.)
        k = k + 1
        if (k > n) exit
        if (mod(k,2) .eq. 0) cycle
        write(*,10) k, n
      enddo

 10   format('k = ', i3, '; n = ', i8)
      end program odd_number


    !Proposal density
    !Using the covariance matrix to give the proposal directions typically
    !significantly increases the acceptance rate and gives faster movement
    !around parameter space.
    !We generate a random basis in the eigenvectors, then cycle through them
    !proposing changes to each, then generate a new random basis
    !The distance proposal in the random direction is given by a two-D Gaussian
    !radial function mixed with an exponential, which is quite robust to wrong width estimates
    !See http://cosmologist.info/notes/cosmomc.pdf

    module propose
    use RandUtils
    use settings
    use GeneralTypes
    implicit none

    Type IndexCycler
        integer n
        integer :: loopix=0
    end Type IndexCycler

    Type, extends(IndexCycler) :: CyclicIndexRandomizer
        integer, allocatable :: indices(:)
    contains
    procedure :: Next
    end Type CyclicIndexRandomizer

    Type, extends(IndexCycler) :: RandDirectionProposer
        integer :: propose_count = 0
        real(mcp), allocatable, dimension(:,:) :: R
    contains
    procedure :: ProposeVec
    procedure :: Propose_r
    end type RandDirectionProposer

    Type, extends(RandDirectionProposer) :: BlockProposer
        integer :: block_start
        integer, allocatable :: used_param_indices(:)
        integer, allocatable :: params_changed(:), used_params_changed(:)
        real(mcp), allocatable :: mapping_matrix(:,:)
    contains
    procedure :: UpdateParams
    end Type BlockProposer

    Type, extends(TCheckpointable) :: TCovmatProposer
        real(mcp), allocatable :: propose_matrix(:,:)
    contains
    procedure :: SetCovariance => TCovmatProposer_SetCovariance
    procedure :: SaveState => TCovmatProposer_SaveState
    procedure :: LoadState => TCovmatProposer_LoadState
    end type

    Type, extends(TCovmatProposer) :: BlockedProposer
        integer :: nBlocks
        integer, allocatable :: indices(:), ProposerForIndex(:)
        Type(CyclicIndexRandomizer) :: Slow, Fast, All
        Type(BlockProposer), allocatable :: Proposer(:)
        integer :: oversample_fast = 1
        real(mcp) :: propose_scale = 2.4_mcp
        integer, private  :: fast_ix = 0
    contains
    procedure :: Init
    procedure :: SetCovariance => BlockedProposer_SetCovariance
    procedure :: GetBlockProposal
    procedure :: GetProposal
    procedure :: GetProposalSlow
    procedure :: GetProposalFast
    procedure :: GetProposalFastDelta
    end Type BlockedProposer

    logical :: propose_rand_directions = .true.

    contains

    function Next(this)
    Class(CyclicIndexRandomizer) :: this
    integer Next

    this%loopix = mod(this%loopix, this%n) + 1
    if (this%loopix == 1) then
        if (.not. allocated(this%indices)) allocate(this%indices(this%n))
        call randIndices(this%indices, this%n, this%n)
    end if
    Next = this%indices(this%loopix)

    end function Next

    subroutine RotMatrix(M,n)
    integer, intent(in) :: n
    real(mcp) M(n,n)
    integer i

    if (propose_rand_directions .and. n > 1) then
        call RandRotation(M, n)
    else
        M = 0
        do i = 1, n
            M(i,i) = sign(1._mcp, real(ranmar(),mcp)-0.5_mcp)
        end do
    end if

    end subroutine RotMatrix

    function ProposeVec(this, wid) result(vec)
    Class(RandDirectionProposer) :: this
    real(mcp) :: vec(this%n)
    real(mcp) :: wid

    if (mod(this%loopix,this%n)==0) then
        !Get a new random rotation
        if (.not. allocated(this%R)) allocate(this%R(this%n,this%n))
        call RotMatrix(this%R, this%n)
        this%loopix = 0
    end if
    this%loopix = this%loopix + 1
    this%propose_count= this%propose_count + 1
    vec = this%R(:,this%loopix) * ( this%Propose_r() * wid )

    end function ProposeVec

    function Propose_r(this) result(r_fac)
    !distance proposal function (scale is 1)
    Class(RandDirectionProposer), intent(in) :: this
    integer i,n
    real(mcp) r_fac

    if (ranmar() < 0.33d0) then
        r_fac = randexp1()
    else
        n = min(this%n, 2)
        r_fac = 0
        do i = 1, n
            r_fac = r_fac + Gaussian1()**2
        end do
        r_fac = sqrt( r_fac / n )
    end if

    end function Propose_r

    subroutine UpdateParams(this, P, vec)
    Class(BlockProposer) :: this
    real(mcp) :: P(:)
    real(mcp):: vec(this%n)

    P(this%params_changed) =  P(this%params_changed) + matmul(this%mapping_matrix, vec)

    end subroutine UpdateParams

    subroutine Init(this, parameter_blocks, slow_block_max, oversample_fast, propose_scale)
    !slow_block_max determines which parameter blocks are grouped together as being 'slow'
    Class(BlockedProposer), target :: this
    type(int_arr) :: parameter_blocks(:)
    integer, intent(in) :: slow_block_max
    integer used_blocks(size(parameter_blocks))
    integer, intent(in), optional :: oversample_fast
    real(mcp), intent(in), optional :: propose_scale
    integer i, ix, n, np
    Type(BlockProposer), pointer :: BP

    if (present(oversample_fast)) then
        this%oversample_fast = oversample_fast
    endif
    if (present(propose_scale)) then
        this%propose_scale = propose_scale
    end if
    this%nBlocks = size(parameter_blocks)
    n=0
    this%All%n=0
    this%Slow%n=0
    do i=1, this%nBlocks
        np = size(parameter_blocks(i)%P)
        if (np >0) then
            this%All%n = this%All%n+ np
            if (i <= slow_block_max) this%Slow%n= this%Slow%n + np
            n=n+1
            used_blocks(n)=i
        end if
    end do
    this%Fast%n = this%All%n - this%Slow%n
    this%nBlocks = n
    allocate(this%Proposer(this%nBlocks))
    allocate(this%indices(this%All%n))
    allocate(this%ProposerForIndex(this%All%n))
    this%indices=0
    ix = 1
    do i=1, this%nBlocks
        !loop from slow to fast
        BP => this%Proposer(i)
        BP%block_start = ix
        BP%n = size(parameter_blocks(used_blocks(i))%P)
        allocate(BP%used_param_indices(BP%n))
        BP%used_param_indices = parameter_blocks(used_blocks(i))%P
        this%indices(ix:ix+BP%n-1) = BP%used_param_indices
        this%ProposerForIndex(ix:ix+BP%n-1) = i
        ix = ix + BP%n
    end do
    if (any(this%indices==0)) stop 'DecomposeCovariance: not all used parameters blocked'
    do i=1, this%nBlocks
        BP => this%Proposer(i)
        allocate(BP%used_params_changed(this%All%n-BP%block_start+1))
        allocate(BP%params_changed(this%All%n-BP%block_start+1))
        BP%used_params_changed = this%indices(BP%block_start:this%All%n)
        BP%params_changed = params_used(BP%used_params_changed)
    end do

    end subroutine Init

    subroutine BlockedProposer_SetCovariance(this, propose_matrix)
    !take covariance of used parameters (propose_matrix), and construct orthonormal parmeters
    !where orthonormal parameters are grouped in blocks by speed, so changes in slowest block
    !changes slow and fast parameters, but changes in the fastest block only changes fast parameters
    use MatrixUtils
    Class(BlockedProposer), target :: this
    real(mcp), intent(in) :: propose_matrix(:,:)
    real(mcp) corr(num_params_used,num_params_used)
    real(mcp) :: sigmas(num_params_used), L(num_params_used,num_params_used)
    integer i, j
    Type(BlockProposer), pointer :: BP

    if (.not. allocated(this%propose_matrix)) then
        allocate(this%propose_matrix, source=propose_matrix)
    else
        this%propose_matrix=propose_matrix
    end if
    do i = 1, num_params_used
        sigmas(i) = sqrt(propose_matrix(i,i))
        corr(i,:) = propose_matrix(i,:) / sigmas(i)
    end do
    do i = 1, num_params_used
        corr(:,i) = corr(:,i) / sigmas(i)
    end do
    L = corr(this%indices,this%indices)
    call Matrix_Cholesky(L,zeroed=.true.)
    do i=1, this%nBlocks
        BP => this%Proposer(i)
        if (.not. allocated(BP%mapping_matrix)) allocate(BP%mapping_matrix(size(BP%used_params_changed), BP%n))
        do j = 1, size(BP%used_params_changed)
            BP%mapping_matrix(j,:)  =  sigmas(BP%used_params_changed(j)) * &
            L(BP%block_start+j-1,BP%block_start:BP%block_start+BP%n-1)
        end do
    end do
    end subroutine BlockedProposer_SetCovariance

    subroutine GetBlockProposal(this, P, i)
    class(BlockedProposer) :: this
    integer, intent(in) :: i !i must be first in gfortran
    real(mcp) :: P(:)

    call this%Proposer(i)%UpdateParams(P, this%Proposer(i)%Proposevec(this%propose_scale))

    end subroutine GetBlockProposal

    subroutine GetProposal(this, P)
    class(BlockedProposer) :: this
    real(mcp) :: P(:)

    if (this%fast_ix/=0) then
        call  GetProposalFast(this, P)
        this%fast_ix=this%fast_ix-1
    else
        if (this%All%Next() > this%Slow%n) then
            call  GetProposalFast(this, P)
            this%fast_ix = this%oversample_fast-1
        else
            call  GetProposalSlow(this, P)
        end if
    end if

    end subroutine GetProposal

    subroutine GetProposalSlow(this, P)
    class(BlockedProposer) :: this
    real(mcp) :: P(:)

    call this%GetBlockProposal(P, this%ProposerForIndex(this%Slow%Next()))

    end subroutine GetProposalSlow

    subroutine GetProposalFast(this, P)
    class(BlockedProposer) :: this
    real(mcp) :: P(:)

    call this%GetBlockProposal(P, this%ProposerForIndex(this%Slow%n + this%Fast%Next()))

    end subroutine GetProposalFast

    subroutine GetProposalFastDelta(this, P)
    class(BlockedProposer) :: this
    real(mcp) :: P(:)

    P=0
    call this%GetProposalFast(P)

    end subroutine GetProposalFastDelta

    subroutine TCovmatProposer_SetCovariance(this, propose_matrix)
    class(TCovmatProposer), target :: this
    real(mcp), intent(in) :: propose_matrix(:,:)
    !only inherited otherwise do nothing
    end subroutine TCovmatProposer_SetCovariance

    subroutine TCovmatProposer_LoadState(this,F)
    class(TCovmatProposer) :: this
    class(TFileStream) :: F
    real(mcp) :: cov(num_params_used,num_params_used)

    if (.not. F%ReadItem(cov)) call MpiStop('error reading proposal covariance')
    call this%SetCovariance(cov)

    end subroutine TCovmatProposer_LoadState

    subroutine TCovmatProposer_SaveState(this,F)
    class(TCovmatProposer) :: this
    class(TFileStream) :: F

    call F%Write(this%propose_matrix)

    end subroutine TCovmatProposer_SaveState

    end module propose