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

!   This code evaluates the zetaz and zetap functions.
!   David H Bailey    2004-07-14

function zetaz (n, izeta)

!   This evaluate zeta sums via Formula 44 in the paper "Special Values of
!   Multidimensional Polylogarithms", by J. M. Borwein et al, CECM 98-106.

use mpmodule
use globdata
implicit none
integer i, ii, j, k, ka, kb, kt1, kt2, m, n, nx
parameter (nx = 100)
integer ia(nx,0:nx+1), ial(0:nx+1), ib(nx,0:nx+1), ibl(0:nx+1), &
  ir(nx), is(nx), it1(nx), it2(nx), izeta(n)
type (mp_real) zetap, t1, t2, t3, zetaz
external zetap

!   Form the ir and is arrays.

k = 0

do m = 1, n
  k = k + 1
  if (k > n) goto 110
  if (izeta(k) <= 1) then
    nerror = 301
    goto 400
  endif
  ir(m) = 0
  is(m) = izeta(k) - 2

100 continue

  k = k + 1
  if (k > n) goto 110
  if (izeta(k) == 1) then
    ir(m) = ir(m) + 1
    goto 100
  else
    k = k - 1
  endif
enddo

nerror = 302
goto 400

110 continue

! write (6, *) 'm =', m
! write (6, *) 'ir array:'
! write (6, '(3i6)') (i, ir(i), i = 1, m)
! write (6, *) 'is array:'
! write (6, '(3i6)') (i, is(i), i = 1, m)

!   Form the ia and ib arrays.

t1 = 0.d0
ial(0) = 0
ial(m+1) = 0
ibl(0) = 0
ibl(m+1) = 0

do j = 1, m
  ka = 0

  do i = j, m
    ka = ka + 1
    if (ka > nx) then
      nerror = 303
      goto 400
    endif
    ia(ka,j) = is(i) + 2

    do ii = 1, ir(i)
      ka = ka + 1
      if (ka > nx) then
        nerror = 304
        goto 400
      endif
      ia(ka,j) = 1
    enddo
  enddo

  ial(j) = ka
  kb = 0

  do i = j, 1, -1
    kb = kb + 1
    if (kb > nx) then
      nerror = 305
      goto 400
    endif
    ib(kb,j) = ir(i) + 2

    do ii = 1, is(i)
      kb = kb + 1
      if (kb > nx) then
        nerror = 306
        goto 400
      endif
      ib(kb,j) = 1
    enddo
  enddo

  ibl(j) = kb
enddo

! write (6, *) 'ia array:'
! write (6, '(3i6)') ((i, j, ia(i,j), i = 1, ial(j)), j = 1, m)
! write (6, *) 'ib array:'
! write (6, '(3i6)') ((i, j, ib(i,j), i = 1, ibl(j)), j = 1, m)

!   Compute the sum.

t3 = 0.d0

do j = 1, m
  do i = 0, is(j) + 1

!    write (6, *) 'i, j =', i, j

    kt1 = 1
    it1(1) = is(j) + 2 - i

    do ii = 1, ir(j)
      kt1 = kt1 + 1
      if (kt1 > nx) then
        nerror = 307
        goto 400
      endif
      it1(kt1) = 1
    enddo

    do ii = 1, ial(j+1)
      kt1 = kt1 + 1
      if (kt1 > nx) then
        nerror = 308
        goto 400
      endif
      it1(kt1) = ia(ii,j+1)
    enddo

    kt2 = 0

    do ii = 1, i
      kt2 = kt2 + 1
      if (kt2 > nx) then
        nerror = 309
        goto 400
      endif
      it2(kt2) = 1
    enddo

    do ii = 1, ibl(j-1)
      kt2 = kt2 + 1
      if (kt2 > nx) then
        nerror = 310
        goto 400
      endif
      it2(kt2) = ib(ii,j-1)
    enddo

    t1 = zetap (kt1, it1)
    if (nerror > 0) goto 500
    t2 = zetap (kt2, it2)
    if (nerror > 0) goto 500

!    write (6, *) 'it1 =', (it1(k), k = 1, kt1)
!    write (6, *) 't1 ='
!    call mpwrite (6, t1)
!    write (6, *) 'it2 =', (it2(k), k = 1, kt2)
!    write (6, *) 't2 ='
!    call mpwrite (6, t2)

    t3 = t3 + t1 * t2
  enddo

  do i = 1, ir(j)
    kt1 = 0

    do ii = 1, i
      kt1 = kt1 + 1
      if (kt1 > nx) then
        nerror = 311
        goto 400
      endif
      it1(kt1) = 1
    enddo

    do ii = 1, ial(j+1)
      kt1 = kt1 + 1
      if (kt1 > nx) then
        nerror = 312
        goto 400
      endif
      it1(kt1) = ia(ii,j+1)
    enddo

    kt2 = 1
    it2(kt2) = ir(j) + 2 - i

    do ii = 1, is(j)
      kt2 = kt2 + 1
      if (kt2 > nx) then
        nerror = 313
        goto 400
      endif
      it2(kt2) = 1
    enddo

    do ii = 1, ibl(j-1)
      kt2 = kt2 + 1
      if (kt2 > nx) then
        nerror = 314
        goto 400
      endif
      it2(kt2) = ib(ii,j-1)
    enddo

    t1 = zetap (kt1, it1)
    if (nerror > 0) goto 500
    t2 = zetap (kt2, it2)
    if (nerror > 0) goto 500

!    write (6, *) 'it1 =', (it1(k), k = 1, kt1)
!    write (6, *) 't1 ='
!    call mpwrite (6, t1)
!    write (6, *) 'it2 =', (it2(k), k = 1, kt2)
!    write (6, *) 't2 ='
!    call mpwrite (6, t2)

    t3 = t3 + t1 * t2
  enddo
enddo

kt1 = 0

do ii = 1, ibl(m)
  kt1 = kt1 + 1
  if (kt1 > nx) then
    nerror = 315
    goto 400
  endif
  it1(kt1) = ib(ii,m)
enddo

t1 = zetap (kt1, it1)
if (nerror > 0) goto 500

! write (6, *) 'final evaluation'
! write (6, *) 'it1 =', (it1(k), k = 1, kt1)
! write (6, *) 't1 ='
! call mpwrite (6, t1)

zetaz = t3 + t1

! write (6, *) 'final result ='
! call mpwrite (6, zetaz)

goto 500

400 continue

write (6, 1)
1 format ('zetaz: program error.')

500 continue

return
end

function zetap (ka, ia)
use mpmodule
use globdata
implicit none
integer i, ka, ia(0:ka-1), j, jmax, ierror
parameter (jmax = 1000000)
type (mp_real) eps, st(0:ka-1), tj, zetap, t1, t2, t3, t4, t5, t6, t7

if (ka == 0) then
  t1 = 1.d0
  goto 100
endif
eps = 0.5d0 ** 24 * mpreal (10.d0) ** nepsilon1

do i = 0, ka - 2
  st(i) = 0.d0
enddo

st(ka-1) = 1.d0
t1 = 0.d0
t2 = 1.d0

do j = 1, jmax
  tj = j
  t2 = 0.5d0 * t2
  t3 = t2 * st(0) / tj ** ia(0)
  t1 = t1 + t3

  do i = 1, ka - 1
    st(i-1) = st(i-1) + st(i) / tj ** ia(i)
    call mpgetpar ('mpier', ierror)
    if (ierror > 0) then
      nerror = 316
      goto 100
    endif
  enddo

  if (abs (t3) < eps .and. j > 20 * ka) goto 100
enddo

100 continue

zetap = t1
return
end


       SUBROUTINE Effective_Gradient(N,Ea,Eb,Ga,Gb,ParG,PerpG,G)
       implicit none

C      Computes the parallel and perpendicular compenents of the Effective Gradient,
C      As well as the effective gradient itself.

       integer n, i
       double precision Ea, Eb, Ga(N), Gb(N), G(N), ParG(N), PerpG(N), npg, pp
       double precision facPP, facP
       parameter (facPP=140.d0,facP=1.d0)
C  These factors are only really important for the first step
C  The "difference gradient" is typically ca. 0.075 Hartree/Bohr.
C      i.e. 0.14 Hartree/Angstrom.
C  Assuming this is constant, this gives a Hessian term for the func (Ea-Eb)**2
C     of ca. 0.01 Hartree**2 / Angstrom**2  (0.14**2 / 2)
C  The Hessian term along "normal" coordinates is empirically about 1.4 Hartree / Angstrom**2
C  Using facPP ~ 140 /Hartree means that along this coordinate, too, the Hessian is about right.

       npg = 0.d0
       pp = 0.d0
       do i = 1, n
           PerpG(i) = Ga(i) - Gb(i)
           npg = npg + PerpG(i)**2
           pp = pp + Ga(i) * PerpG(i)
       end do
       npg = sqrt(npg)
       pp = pp / npg
       do i = 1, n
           ParG(i) = Ga(i) - PerpG(i) / npg * pp
           G(i) = (Ea - Eb) * facPP * PerpG(i) + facP * ParG(i)
       end do
       return

       END


program fridays
   implicit none
   integer :: days(1:12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
   integer :: year, k, y, m
   read *, year
   if (mod(year, 400) == 0 .or. (mod(year, 4) == 0 .and. mod(year, 100) /= 0)) days(2) = 29
   y = year - 1
   k = 44 + y + y/4 + 6*(y/100) + y/400
   do m = 1, 12
      k = k + days(m)
      print "(I4,A1,I2.2,A1,I2)", year, '-', m, '-', days(m) - mod(k, 7)
   end do
end program


! Задание 1.2 в учебнике

program ex_1_2
    implicit none

    integer, parameter      :: R_ = 4, L_ = 6
    character(*), parameter :: input_file = "../data/input.txt", &
                               output_file = "output.txt", &
                               E_ = "UTF-8"
    integer                 :: Out = 0, In = 0, i
    real(R_)                :: vals(L_), xs(L_), x

    open (file=input_file, encoding=E_, newunit=In)
        read(In,'(6f5.2)') vals
        read(In,'(f5.2 )') x
    close (In)

    forall (i=0:L_)
        xs(L_-i) = x ** i
    end forall

    open (file=output_file, encoding=E_, newunit=Out)
        write(Out,*) 'Result = ', dot_product(vals, xs)
    close (Out)

end program ex_1_2


program problem66
  use fmzm
  implicit none
  integer, parameter      :: len=100
  integer, dimension(len) :: array
  integer                 :: D, bestD
  type(im)                :: bestx,temp

  call fm_set(200)

  bestD=-1
  bestx=to_im(-1)
  do D=1,1000
     if (mod(sqrt(dble(D)),1.0) == 0.0) cycle
     call cf(D,array)
     temp=solve(D,array)
     if (temp>bestx) then
        bestx=temp
        bestD=D
     end if
  end do

  print *, bestD, im_format('i50', bestx)

contains

  subroutine cf(D,array)
    use fmzm
    implicit none
    integer, intent(in)     :: D
    integer, dimension(len) :: array
    integer                 :: i
    type(fm)                :: temp,one

    one=to_fm(1)
    temp=mod(sqrt(to_fm(D)),one)
    do i=1,len
       temp=1.0/temp
       array(i)=int(temp)
       temp=mod(temp,one)
    end do

  end subroutine cf

  ! Reference: https://en.wikipedia.org/wiki/Pell%27s_equation
  function solve(D,array)
    use fmzm
    implicit none
    integer, intent(in)                 :: D
    integer, dimension(len), intent(in) :: array
    type(im)                            :: numerator,denomenator,temp,solve
    integer                             :: i,n

    solve=to_im(-1)
    do n=1,len
       numerator=to_im(1)
       denomenator=to_im(array(n))

       do i=n-1,1,-1
          numerator=to_im(array(i))*denomenator+numerator
          temp=numerator
          numerator=denomenator
          denomenator=temp
       end do

       temp=to_im(sqrt(dble(D)))
       numerator=numerator+temp*denomenator

       if (numerator**2 - D*denomenator**2 == 1) then
          solve=numerator
          go to 100
       end if
    end do

100 continue

  end function solve

end program problem66


PROGRAM F030

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER (LEN=10) :: STR

    INTEGER :: SUM_VAL       = 0
    INTEGER :: SUM_OF_POWERS = 0

    INTEGER :: I, J, STR_LEN

    DO I = 2, 1000000

        WRITE(STR, '(I10)') I
        STR = ADJUSTL(STR)

        STR_LEN = LEN_TRIM(STR)

        SUM_OF_POWERS = 0

        DO J = 1, STR_LEN
            SUM_OF_POWERS = SUM_OF_POWERS                                      &
                          + ((IACHAR(STR(J:J))-IACHAR('0')) ** 5)
        END DO

        IF (SUM_OF_POWERS == I) SUM_VAL = SUM_VAL + I

    END DO

    PRINT ('(I0)'), SUM_VAL

END PROGRAM F030


!> Compute enclosing rectangle around flagged points.
!! save some info., even tho. usage might be low and rect. scrapped.
!!
!! \param[in] badpts  x,y coords of cells around which a rectangle
!! is to be made and compute efficiency on
!! \param[in] npt     num. of badpts. in the cluster.
!! \param[out] usage   ratio of flagged to unflagged badpts. in new grid
!!                measures goodness of fit and clustering
!! \param[out] intrect stores some info. for grid created herein.
!!                sometimes rect = rnode, sometimes = temp. array.
!!                sometimes intrect = node.
!!                depending on calling prog. (grdfit or expand)

subroutine moment(intrect, badpts, npt, usage)
    !
    ! :::::::::::::::::::::::: MOMENT ::::::::::::::::::::::::::::::::::
    !  moment = compute enclosing rectangle around flagged points.
    !  save some info., even tho. usage might be low and rect. scrapped.
    !
    ! input parameters:
    !     badpts      = x,y coords of flagged badpts grouped into clusters
    !                   are in the first two rows
    !     npt         = num. of badpts. in the cluster.
    !
    ! output parameters:
    !     usage       = ratio of flagged to unflagged badpts. in new grid
    !                   measures goodness of fit and clustering
    !    intrect( )    = stores some info. for grid created herein.
    !                   sometimes rect = rnode, sometimes = temp. array.
    !                   sometimes intrect = node.
    !                   depending on calling prog. (grdfit or expand)
    !
    !
    ! :::::::::::::::::::::::: MOMENT ::::::::::::::::::::::::::::::::::
    !

    use amr_module, only: ndilo, ndjlo, ndihi, ndjhi, nsize

    ! Input
    integer, intent(in) :: npt
    real(kind=8), intent(in) :: badpts(2, npt)
    integer, intent(in out) ::  intrect(nsize)
    real(kind=8), intent(out) :: usage

    ! Locals
    real(kind=8) :: e_min(2), e_max(2), side(2)

    ! Compute length of enclosing rectangles to include all flagged badpts
    do i = 1, 2
        e_min(i) = minval(badpts(i, :))
        e_max(i) = maxval(badpts(i, :))
    end do

    ! From length of the sides determine rect corners
    ! transform to cell numebrs (subtract 0.5)
    intrect(ndilo) = nint(e_min(1) - 0.5d0)
    intrect(ndjlo) = nint(e_min(2) - 0.5d0)
    intrect(ndihi) = nint(e_max(1) - 0.5d0)
    intrect(ndjhi) = nint(e_max(2) - 0.5d0)

    ! Compute usage
    side(1) = real(intrect(ndihi) - intrect(ndilo) + 1, kind=8)
    side(2) = real(intrect(ndjhi) - intrect(ndjlo) + 1, kind=8)
    usage = real(npt, kind=8) / (side(1) * side(2))

end subroutine moment


SUBROUTINE Tunneling_B(D_BARE,N_SITES,N_BODIES,STATE,H_J,INFO)

  USE CREATIONDESTRUCTION
  IMPLICIT NONE
  INTEGER,                               INTENT(IN)    :: D_BARE,N_SITES,N_BODIES
  INTEGER,    DIMENSION(D_BARE,N_SITES), INTENT(IN)    :: STATE
  COMPLEX*16, DIMENSION(D_BARE,D_BARE),  INTENT(OUT)   :: H_J
  INTEGER,                               INTENT(INOUT) :: INFO

  INTEGER, DIMENSION(N_SITES) :: NEW_STATE,STATE_J,STATE_I

  INTEGER :: N,I_,J_,k_
  N = D_BARE

  H_J = 0
  J_=1
  K_=1
  DO k_=1,N_SITES-1 ! loop though all sites
     DO J_=1,N
        DO I_=J_+1,N
           !WRITE(*,*) K_,J_,I_,STATE(J_,:)
            !WRITE(*,*) STATE(I_,:)
            STATE_J = STATE(J_,:)
            STATE_I = STATE(I_,:)
            NEW_STATE = TUNNELING_(k_,STATE_J)
            !write(*,*) NEW_STATE,dot_product((NEW_STATE-STATE_I),(NEW_STATE-STATE_I))
            IF(dot_product((NEW_STATE-STATE_I),(NEW_STATE-STATE_I)).EQ.0) THEN
                H_J(I_,J_) = SQRT(1.0*STATE_J(k_)*(STATE_J(k_+1)+1))
                H_J(J_,I_) = SQRT(1.0*STATE_J(k_)*(STATE_J(k_+1)+1))
            END IF
        END DO
     END DO

     DO J_=1,N
         STATE_J = STATE(J_,:)
         STATE_I = STATE(J_,:)
         NEW_STATE = TUNNELING_(k_,STATE_J)
         IF(dot_product((NEW_STATE-STATE_I),(NEW_STATE-STATE_I)).EQ.0) THEN
            H_J(J_,J_) = SQRT(1.0*STATE_J(k_)*(STATE_J(k_+1)+1))
         END IF
     END DO
  END DO

END SUBROUTINE Tunneling_B

SUBROUTINE Onsite_twobody_B(D_BARE,N_SITES,N_BODIES,STATE,H_U,INFO)

    USE CREATIONDESTRUCTION

    IMPLICIT NONE
    INTEGER,                               INTENT(IN)    :: D_BARE,N_SITES,N_BODIES
    INTEGER,    DIMENSION(D_BARE,N_SITES), INTENT(IN)    :: STATE
    COMPLEX*16, DIMENSION(D_BARE,D_BARE),  INTENT(OUT)   :: H_U
    INTEGER,                               INTENT(INOUT) :: INFO

    DOUBLE PRECISION, DIMENSION(N_SITES) :: NEW_STATE

    INTEGER :: N,I_,J_,k_
    N = D_BARE

    H_U = 0
    DO k_=1,N_SITES ! loop though all sites
        DO J_=1,N
            H_U(J_,J_) = STATE(J_,k_)
            H_U(J_,J_) = H_U(J_,J_)*(H_U(J_,J_)-1.0)
        END DO
    END DO

END SUBROUTINE Onsite_twobody_B

SUBROUTINE Tunneling_F(D_BARE,N_SITES,N_BODIES,STATE,H_J,INFO)

  USE CREATIONDESTRUCTION
  IMPLICIT NONE
  INTEGER,                               INTENT(IN)    :: N_SITES
  INTEGER,    DIMENSION(2),              INTENT(IN)    :: D_BARE,N_BODIES
  INTEGER,    DIMENSION(D_BARE(1)+D_BARE(2),N_SITES),      INTENT(IN)    :: STATE
  COMPLEX*16, DIMENSION(D_BARE(1)+D_BARE(2),D_BARE(1)+D_BARE(2)), INTENT(OUT)   :: H_J
  INTEGER,                               INTENT(INOUT) :: INFO

  INTEGER, DIMENSION(N_SITES) :: NEW_STATE,STATE_J,STATE_I

  COMPLEX*16, DIMENSION(D_BARE(1),D_BARE(1)) :: T_UP
  COMPLEX*16, DIMENSION(D_BARE(2),D_BARE(2)) :: T_DOWN
  COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: T

  INTEGER :: N,I_,J_,k_,l_
  INTEGER, DIMENSION(3) :: N_

  N_(1) = D_BARE(1)
  N_(2) = D_BARE(2)
  N_(3) = D_BARE(1)*D_BARE(2)
  ALLOCATE(T(N_(3),N_(3)))

  T_UP   = 0
  T_DOWN = 0
  H_J    = 0
  T      = 0
  DO k_=1,N_SITES ! loop though all sites
    DO l_=1,2 ! loop through spin up and spin down
        N = D_BARE(l_)
        DO J_=1,N ! Nested loop through all spin up/down states
            DO I_=J_,N
                STATE_J = STATE(J_ + (l_-1)*D_BARE(1),:)
                STATE_I = STATE(I_ + (l_-1)*D_BARE(1),:)
                NEW_STATE = TUNNELING_F_(k_,STATE_J)

                !write(*,*) NEW_STATE,dot_product((NEW_STATE-STATE_I),(NEW_STATE-STATE_I))
                IF(dot_product((NEW_STATE-STATE_I),(NEW_STATE-STATE_I)).EQ.0) THEN
                    IF(l_.EQ.1) THEN
                        T_UP(I_,J_) = 1.0
                        T_UP(J_,I_) = 1.0
                    ELSE
                        T_DOWN(I_,J_) = 1.0
                        T_DOWN(J_,I_) = 1.0
                    END IF

                END IF
            END DO
        END DO

        DO J_=1,N
            STATE_J = STATE(J_+(l_-1)*D_BARE(1),:)
            STATE_I = STATE(J_+(l_-1)*D_BARE(1),:)
            NEW_STATE = TUNNELING_F_(k_,STATE_J)
            IF(dot_product((NEW_STATE-STATE_I),(NEW_STATE-STATE_I)).EQ.0) THEN
                IF(l_.EQ.1) THEN
                    T_UP(J_,J_) = 1.0
                ELSE
                    T_DOWN(J_,J_) = 1.0
                END IF
            END IF
        END DO
    END DO
    CALL TENSORMULT(N_,T_UP,T_DOWN,T,INFO)
    H_J = H_J + T
  END DO

END SUBROUTINE Tunneling_F

SUBROUTINE Onsite_twobody_F(D_BARE,N_SITES,N_BODIES,STATE,H_U,INFO)

  USE CREATIONDESTRUCTION
  IMPLICIT NONE
  INTEGER,                               INTENT(IN)    :: N_SITES
  INTEGER,    DIMENSION(2),              INTENT(IN)    :: D_BARE,N_BODIES
  INTEGER,    DIMENSION(D_BARE(1)+D_BARE(2),N_SITES),      INTENT(IN)    :: STATE
  COMPLEX*16, DIMENSION(D_BARE(1)+D_BARE(2),D_BARE(1)+D_BARE(2)), INTENT(OUT)   :: H_U
  INTEGER,                               INTENT(INOUT) :: INFO

  INTEGER, DIMENSION(N_SITES) :: NEW_STATE,STATE_J,STATE_I

  INTEGER :: N,I_,J_,k_,l_

  COMPLEX*16, DIMENSION(D_BARE(1),D_BARE(1)) :: T_UP
  COMPLEX*16, DIMENSION(D_BARE(2),D_BARE(2)) :: T_DOWN
  COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: T

  INTEGER, DIMENSION(3) :: N_

  H_U = 0
  T_UP   = 0
  T_DOWN = 0
  N_(1) = D_BARE(1)
  N_(2) = D_BARE(2)
  N_(3) = D_BARE(1)*D_BARE(2)
  ALLOCATE(T(N_(3),N_(3)))

  !write(*,*) N_
  T = 0.0
  DO l_=1,N_(2)
      DO k_=1,N_(1)
          !write(*,*) N_,(l_-1)*N_(1)+k_,(l_-1)*N_(1)+k_,DOT_PRODUCT(STATE(k_,:),STATE(N_(1)+l_,:))
        T((l_-1)*N_(1)+k_,(l_-1)*N_(1)+k_) = DOT_PRODUCT(STATE(k_,:),STATE(N_(1)+l_,:))
    END DO
  END DO
  H_U = T
END SUBROUTINE Onsite_twobody_F


module LIF

implicit none

contains

!$ FTT vectorize
elemental real function updateF(v, vth) result(f)
    real, intent(in) :: v, vth

    if ( (v - vth) > 0.0 ) then
        f = 1.0
    else
        f = 0.0
    end if

end function updateF

!$ FTT vectorize
elemental real function updateV(v, f) result(vnew)
    real, intent(in) :: v, f

    vnew = v - f*v

end function updateV

!$ FTT vectorize
pure subroutine update(V, F, vth)
    real, intent(inout) :: V(:), F(:)
    real, intent(in) :: vth

    F = updateF(V, vth)
    V = updateV(V, F)

end subroutine update

end module LIF


SUBROUTINE UpdateGhostLayerYCurvilinear(var,S,NNx,NNy,CompGrid,alpha,beta,GhostGridX,GhostGridY)
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: NNx, NNy, rank, alpha, beta, i,j, GhostGridX, GhostGridY, diffa
REAL(KIND=long), DIMENSION(NNx,NNy) :: var, S
REAL(KIND=long), DIMENSION(2*alpha+1) :: Stencile, Stenciln
REAL(KIND=long) :: ex, ey, nx, ny, tmp, diagn
INTEGER, DIMENSION(2*alpha+1) :: idx
IF (alpha/=beta) THEN
	print*,'ERROR: alpha/=beta. (UpdateGhostLayerYCurvilinear)'
END IF
rank = 2*beta+1 !GD change: 2*alpha+1
DO i = -alpha,alpha
	idx(i+alpha+1) = i
END DO
! two boundaries
j=1
DO i = 1+GhostGridX, NNx-GhostGridX
	if (i-1<alpha+1) then
		diffa = (alpha+1)-(i-1)
	else if (i+1>NNx-alpha) then
		diffa = (NNx-alpha)-(i+1) !GD: change (NNx-beta)-(i+1)
	else
		diffa = 0
	end if

	! use geometric factors for wall boundary
!	ex = CompGrid%CurvilinearStuff%ex(i,j+GhostGridY)
	ey = CompGrid%CurvilinearStuff%ey(i,j+GhostGridY)
!	nx = CompGrid%CurvilinearStuff%nx(i,j+GhostGridY)
	ny = CompGrid%CurvilinearStuff%ny(i,j+GhostGridY)

	Stencile = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,1+alpha-diffa,1)
	Stenciln = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,1+GhostGridY,1)
	diagn = ny*Stenciln(1)

	tmp = ey * DOT_PRODUCT(Stencile,var(i+idx+diffa,j+GhostGridY) ) + ny * DOT_PRODUCT( Stenciln(2:rank),var(i,2:rank) )

    var(i,j) = (S(i,j+GhostGridY) - tmp) / diagn

END DO
j = NNy
DO i = 1+GhostGridX, NNx-GhostGridX
	if (i-1<alpha+1) then
		diffa = (alpha+1)-(i-1)
	else if (i+1>NNx-alpha) then
		diffa = (NNx-alpha)-(i+1)
	else
		diffa = 0
	end if

	! use geometric factors for wall boundary
!	ex = CompGrid%CurvilinearStuff%ex(i,j-GhostGridY)
	ey = CompGrid%CurvilinearStuff%ey(i,j-GhostGridY)
!	nx = CompGrid%CurvilinearStuff%nx(i,j-GhostGridY)
	ny = CompGrid%CurvilinearStuff%ny(i,j-GhostGridY)

	Stencile = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,1+alpha-diffa,1)
	Stenciln = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,rank-GhostGridY,1)

	diagn = ny*Stenciln(rank)

	tmp = ey * DOT_PRODUCT(Stencile,var(i+idx+diffa,j-GhostGridY) ) + ny * DOT_PRODUCT( Stenciln(1:rank-1),var(i,j-rank+1:j-1) )

    var(i,j) = (S(i,j-GhostGridY)- tmp) / diagn
END DO
END SUBROUTINE UpdateGhostLayerYCurvilinear


*DECK COSGEN
      SUBROUTINE COSGEN (N, IJUMP, FNUM, FDEN, A)
C***BEGIN PROLOGUE  COSGEN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to GENBUN
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (COSGEN-S, CMPCSG-C)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     This subroutine computes required cosine values in ascending
C     order.  When IJUMP .GT. 1 the routine computes values
C
C        2*COS(J*PI/L) , J=1,2,...,L and J .NE. 0(MOD N/IJUMP+1)
C
C     where L = IJUMP*(N/IJUMP+1).
C
C
C     when IJUMP = 1 it computes
C
C            2*COS((J-FNUM)*PI/(N+FDEN)) ,  J=1, 2, ... ,N
C
C     where
C        FNUM = 0.5, FDEN = 0.0, for regular reduction values.
C        FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1
C        FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2
C        FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2
C                                in POISN2 only.
C
C***SEE ALSO  GENBUN
C***ROUTINES CALLED  PIMACH
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  COSGEN
      DIMENSION       A(*)
C
C
C***FIRST EXECUTABLE STATEMENT  COSGEN
      PI = PIMACH(DUM)
      IF (N .EQ. 0) GO TO 105
      IF (IJUMP .EQ. 1) GO TO 103
      K3 = N/IJUMP+1
      K4 = K3-1
      PIBYN = PI/(N+IJUMP)
      DO 102 K=1,IJUMP
         K1 = (K-1)*K3
         K5 = (K-1)*K4
         DO 101 I=1,K4
            X = K1+I
            K2 = K5+I
            A(K2) = -2.*COS(X*PIBYN)
  101    CONTINUE
  102 CONTINUE
      GO TO 105
  103 CONTINUE
      NP1 = N+1
      Y = PI/(N+FDEN)
      DO 104 I=1,N
         X = NP1-I-FNUM
         A(I) = 2.*COS(X*Y)
  104 CONTINUE
  105 CONTINUE
      RETURN
      END


FUNCTION FHYDCN(VOID,BMECH4,BMECH5,BMECH6,IBMECHK)

  ! **  FHYDCN IS HYDRAULIC CONDUCTIVITY DIVIDED BY 1+VOID RATIO
  !

  IMPLICIT NONE

  INTEGER :: IBMECHK
  REAL :: FHYDCN,VOID,BMECH4,BMECH5,BMECH6,TMP,FHYDCNLOG

  IF( BMECH4 > 0.0 )THEN
    TMP=(VOID-BMECH5)/BMECH6
    IF( IBMECHK == 0 )THEN
      FHYDCN=BMECH4*EXP(TMP)/(1.+VOID)
    ELSE
      FHYDCN=BMECH4*EXP(TMP)
    END IF
  ELSE
    FHYDCNLOG=0.00816448*(VOID**3)-0.232453*(VOID**2)+2.5759*VOID -28.581
    FHYDCN=EXP(FHYDCNLOG)
  ENDIF

END FUNCTION


program check
implicit none
real :: x,y
integer :: i
x = 2.0
i = 2
y =x*((2**i)/3)
print*,y
y = x* ((2.0**i/3))
print*,y
end program check


! $UWHPSC/codes/fortran/boolean1.f90

program boolean1

    implicit none
    integer :: i,k
    logical :: ever_zero

    ever_zero = .false.
    do i=1,10
        k = 3*i - 1
        ever_zero = (ever_zero .or. (k == 0))
        enddo

    if (ever_zero) then
        print *, "3*i - 1 takes the value 0 for some i"
    else
        print *, "3*i - 1 is never 0 for i tested"
    endif

end program boolean1


!> @ingroup is_sorted
!>
!> @brief
!> Checks if a vector of #<data><full># values is sorted.
!>
!> @details
!> Checks if a vector of #<data><full># values is sorted according to the specified ordering.
!>
!> @retval sorted
!> Indicated if the vector of #<data><full># values is sorted according to the specified ordering.
!>
!> | Value | Meaning                  |
!> |:-----:|:------------------------ |
!> | true  | The vector is sorted     |
!> | false | The vector is not sorted |
!>
!> @param #<data><var>#
!> The vector of #<data><full># values to be checked for being sorted.
!>
!> @param ascending
!> Indicates if the ordering to be checked for is ascending or decending.
!>
!> | Value | Meaning         |
!> |:-----:|:--------------- |
!> | true  | Ascending order |
!> | false | Decending order |
!>
!> @note
!> An empty or single value vector is considered sorted.
!>
!> @author Arin R. Bratt
!> @date 12/07/2014

pure function is_sorted#data#(#<data><var>#,ascending) result(sorted)

  ! Parameters
  #<data><full>#, intent(in) :: #<data><var>#(:)
  logical, intent(in) :: ascending

  ! Result
  logical :: sorted

  ! Check ascending and call the right function.
  if (ascending) then
     sorted = is_sorted_asc#data#(#<data><var>#)
  else
     sorted = is_sorted_dec#data#(#<data><var>#)
  end if

end function is_sorted#data#


      subroutine growop(imngmt,month,ityp,extinc,sumgd,alai,dm)
c
c     + + + PURPOSE + + +
c     Computes optimum biomass growth (dm) for a given day.
c
c     Called from YLDOPT and YOPTP.
c     Author(s): Arnold
c     Reference in User Guide:
c
c     Changes:
c           1) Substituted GDD for (TAVE - BTEMP(ITYP)) in EPIC
c              Equation 2.235.
c           2) Changed order of parameters to copnform to WEPP Coding
c              Convention.  (Swapped 1st & 5th (last).)
c
c     Version: This module recoded from Arnold's WEPP Post-version 92.25.
c     Date recoded: 07/09/92.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxcrp.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pntype.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      real sumgd, alai, dm, extinc
      integer imngmt, month, ityp
c
c     + + + ARGUMENT DEFINITIONS + + +
c     sumgd  - gdd accumulated thus far in the growing season
c     alai   - adjusted leaf area index
c     dm     - optimum above-ground biomass (kg/m^2)
c     extinc - radiation extinction coefficient for current crop
c     imngmt - current cropping system (annual or perennial)
c     month  - current month
c     ityp   - current crop
c
c     + + + COMMON BLOCKS + + +
      include 'ccrpgro.inc'
c       read: beinp(ntype), otemp(ntype)
c
      include 'ccrpprm.inc'
c -- XXX -- NOTE: DECLARATION in CCRPPRM.INC needs to be changed from
c                 "10" to a *PARAMETER* !! -- CRM -- 7/31/92
c       read: btemp(10)
c
      include 'ccrpvr3.inc'
c       read: xmxlai(ntype)
c     modify: gdd
c
      include 'cobclim.inc'
c       read: radave(12), obmint(12), obmaxt(12)
c
c     + + + END SPECIFICATIONS + + +
c
      real par, tave, temstr
      tave = (obmaxt(month)+obmint(month)) / 2.0
c
      if (tave.gt.btemp(ityp)) then
        gdd = tave - btemp(ityp)
        sumgd = sumgd + gdd
c
c       ------ Compute temperature stress parameter (temstr) from
c       ratio of growing degree days (gdd) to difference between
c       optimum temperature for plant growth (otemp) and base
c       daily air temperature (btemp).  TEMSTR is really the
c       *complement* of temperature stress; ie, 1 - temperature
c       stress.  By the way it is defined, TEMSTR must range
c       between zero and one.
c       (EPIC Equation 2.235)
c
c       Original Code:
c       temstr = sin(1.5708 * (tave - btemp(ityp)) / (
c       1           otemp(ityp) - btemp(ityp)))
        temstr = sin(1.5708*gdd/(otemp(ityp)-btemp(ityp)))
        if (temstr.lt.0.0) temstr = 0.0
c
c       ------ Compute photosynthetically active radiation (par) from
c       observed average monthly solar radiation (radave) and leaf
c       area index (?) (dlai).
c       (EPIC Equation 2.192 with modifications.  0.2092 is used to
c       convert the units from Langleys to MJ/m**2.  0.05 is added
c       to LAI to "get the equation started"; otherwise, the values
c       never seem to depart from the baseline.  CRM -- 6/25/92.)
c
        par = 0.02092 * radave(month) * (1.0-exp(-extinc*(alai+0.05)))
c
c       ------ Compute dry matter (dm) from inputted biomass conversion factor
c       (beinp) and PAR.
c       (EPIC Equation 2.193 with modifications.  Change in daylength
c       is ignored.  The right side is divided by 10 to implement a
c       change in units.  CRM -- 6/25/92.)
c
c       Original Code:
c       dm = dm + (beinp(ityp) * par / 10000.0) * temstr
        dm = dm + 0.0001 * beinp(ityp) * par * temstr
c
c       Annuals
        if (imngmt.eq.1) then
          alai = (xmxlai(ityp)*dm) / (dm+0.5512*exp(-6.8*dm))
c       Perennials
        else
          alai = (xmxlai(ityp)*dm) / (dm+0.2756*exp(-13.6*dm))
        end if
c
      end if
c
      return
      end


program diffusion_solvers
   use solvers
   real(wp), dimension(0:151) :: u, w, x
   real(wp), dimension(2) :: timers
   real(wp) :: t, tmax, t0, t1, t2
   integer :: i, j, k

   call initialize(x,u); w = u
   t = 0d0; tmax = 1d-1; timers=0d0
   call WriteInitial(x,u)
   j=0
   do
      j = j+1
! evolve via different methods
      call cpu_time(t0)
      call crank(t,x,u) ! crank-nicolson step
      call cpu_time(t1)
      call super(t,x,w) ! super time stepping step
      call cpu_time(t2)

! update timers
      timers(1) = timers(1) + t1 - t0
      timers(2) = timers(2) + t2 - t1
      t = t+dta
      if(t > tmax) exit
   enddo
   call WriteFinal(x,t,u,w)
   print *,"---"
   print *," CN:",timers(1)/real(j)/1d-6," microseconds/step"
   print *,"STS:",timers(2)/real(j)/1d-6," microseconds/step"
   print '(i0,a)',j," total steps employed"

 contains
   !> @brief output the distribution in curve format
   subroutine WriteInitial(x,u)
     real(wp), dimension(0:151), intent(in) :: x, u
     integer :: i, ierr

     open(unit=10,file='diffusion0000.curve',iostat=ierr)
     if(ierr/=0) then
        print *,"error: unable to open file: ierr=",ierr
        stop
     endif
     write(10,*) "# temp_cn"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), u(i)
     enddo
     write(10,*) "# temp_sts"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), u(i)
     enddo
     write(10,*) "# exact"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), u(i)
     enddo
     write(10,*) "# sts-cn"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), 0d0
     enddo
     close(10)
   end subroutine WriteInitial

   !> @brief write the distribution in curve format
   subroutine WriteFinal(x,t,u,w)
     real(wp), dimension(0:151), intent(in) :: x,u,w
     real(wp), intent(in) :: t
     real(wp) :: exact
     integer :: i, ierr

     open(unit=10,file='diffusion0001.curve',iostat=ierr)
     if(ierr/=0) then
        print *,"error: unable to open file: ierr=",ierr
        stop
     endif
     write(10,*) "# temp_cn"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), u(i)
     enddo
     write(10,*) "# temp_sts"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), w(i)
     enddo
     write(10,*) "# exact"
     do i=1,150
        exact = sin(pi*x(i))*exp(-pi*pi*t)
        write(10,'(f11.4,2x,es15.4)') x(i), exact
     enddo
     write(10,*) "# sts-cn"
     do i=1,150
        write(10,'(f11.4,2x,es15.4)') x(i), w(i)-u(i)
     enddo
     close(10)
   end subroutine WriteFinal
end program diffusion_solvers


program rk_4
  use tools

  implicit none
  real(dp) :: x0, x_point, y0, h

  x0 = 0.0; y0 = 1.0; h = 0.05
  x_point = 0.25 !the value of x at which y is to be calculated

  write (*, form_header3) 'itn', 'x', 'y'
  write (*, line3) '-------', '-------', '-------'

  call rungkut_4(x0, y0, x_point, h)

  print *, ''
  print *, 'result:'
  write (*, form_result2r) x0, '-- given value of x'
  write (*, form_result2r) y0, '-- the required value of y'
end program rk_4


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.
!
! This module implements basic unit testing.
module unittest

  use globvars, only: dp, sp, ip, dp_epsilon, sp_epsilon

  implicit none

  private

  public :: unittest_init

  public :: unittest_assert_equal
  public :: unittest_assert_not_equal
  public :: unittest_assert_true
  public :: unittest_assert_false
  public :: unittest_assert_le
  public :: unittest_assert_lt
  public :: unittest_assert_ge
  public :: unittest_assert_gt

  interface unittest_assert_equal
     ! Equality test
     module procedure unittest_assert_equal_dp
     module procedure unittest_assert_equal_sp
     module procedure unittest_assert_equal_int
  end interface unittest_assert_equal

  interface unittest_assert_not_equal
     ! Not equality test
     module procedure unittest_assert_not_equal_dp
     module procedure unittest_assert_not_equal_sp
     module procedure unittest_assert_not_equal_int
  end interface unittest_assert_not_equal

  interface unittest_assert_le
     ! Less than or equal test
     module procedure unittest_assert_le_dp
     module procedure unittest_assert_le_sp
     module procedure unittest_assert_le_int
  end interface unittest_assert_le

  interface unittest_assert_lt
     ! Less than test
     module procedure unittest_assert_lt_dp
     module procedure unittest_assert_lt_sp
     module procedure unittest_assert_lt_int
  end interface unittest_assert_lt

  interface unittest_assert_ge
     ! Greater than or equal test
     module procedure unittest_assert_ge_dp
     module procedure unittest_assert_ge_sp
     module procedure unittest_assert_ge_int
  end interface unittest_assert_ge

  interface unittest_assert_gt
     ! Greater than test
     module procedure unittest_assert_gt_dp
     module procedure unittest_assert_gt_sp
     module procedure unittest_assert_gt_int
  end interface unittest_assert_gt

  real(dp) :: eps_dp
  real(sp) :: eps_sp
  integer(ip) :: eps_int
contains

  subroutine unittest_init(sp_eps, dp_eps, int_eps)
    ! Module initializaiton routine
    !
    ! dp_eps :: optional threshold for double-precision comparison
    !   If this is not set, the machine epsilon is used
    ! sp_eps :: optional threshold for single-precision comparison
    !   If this is not set, the machine epsilon is used
    ! int_eps :: optional threshold for integer comparison
    !   If this is not set, 0 is used (exact comparison)
    real(sp), intent(in), optional :: sp_eps
    real(dp), intent(in), optional :: dp_eps
    integer(ip), intent(in), optional :: int_eps

    if (present(dp_eps)) then
       eps_dp = dp_eps
    else
       eps_dp = dp_epsilon
    end if

    if (present(sp_eps)) then
       eps_sp = sp_eps
    else
       eps_sp = sp_epsilon
    end if

    if (present(int_eps)) then
       eps_int = int_eps
    else
       eps_int = 0_ip
    end if

  end subroutine unittest_init

  pure logical function unittest_assert_equal_dp(a, b, eps) result(val)
    ! Equality test for double precision reals
    !
    ! a :: 1st value
    ! b :: 2nd value
    ! eps :: optional custom threshold for equality
    real(dp), intent(in) :: a
    real(dp), intent(in) :: b
    real(dp), intent(in), optional :: eps

    if (present(eps)) then
       val = (abs(a - b) .lt. eps)
    else
       val = (abs(a - b) .lt. eps_dp)
    end if

  end function unittest_assert_equal_dp

  pure logical function unittest_assert_equal_sp(a, b, eps) result(val)
    ! Equality test for single precision reals. Duplicate of
    ! unittest_assert_equal_dp
    real(sp), intent(in) :: a
    real(sp), intent(in) :: b
    real(sp), intent(in), optional :: eps

    if (present(eps)) then
       val = (abs(a - b) .lt. eps)
    else
       val = (abs(a - b) .lt. eps_dp)
    end if

  end function unittest_assert_equal_sp

  pure logical function unittest_assert_equal_int(a, b, eps) result(val)
    ! Equality test for integers. Duplicate of unittest_assert_equal_dp
    integer(ip), intent(in) :: a
    integer(ip), intent(in) :: b
    integer(ip), intent(in), optional :: eps

    if (present(eps)) then
       val = (abs(a - b) .lt. eps)
    else
       val = (abs(a - b) .lt. eps_int)
    end if

  end function unittest_assert_equal_int

  pure logical function unittest_assert_not_equal_dp(a, b, eps) result(val)
    ! Not equality test for double precision reals
    !
    ! a :: 1st value
    ! b :: 2nd value
    ! eps :: optional custom threshold for double precision equality
    real(dp), intent(in) :: a
    real(dp), intent(in) :: b
    real(dp), intent(in), optional :: eps

    val = .not. unittest_assert_equal_dp(a, b, eps)

  end function unittest_assert_not_equal_dp

  pure logical function unittest_assert_not_equal_sp(a, b, eps) result(val)
    ! Not equality test for single precision reals. Duplicate of
    ! unittest_not_equal_dp
    real(sp), intent(in) :: a
    real(sp), intent(in) :: b
    real(sp), intent(in), optional :: eps

    val = .not. unittest_assert_equal_sp(a, b, eps)

  end function unittest_assert_not_equal_sp

  pure logical function unittest_assert_not_equal_int(a, b, eps) result(val)
    ! Not equality test for integers. Duplicate of unittest_assert_not_equal_dp
    integer(ip), intent(in) :: a
    integer(ip), intent(in) :: b
    integer(ip), intent(in), optional :: eps

    val = .not. unittest_assert_equal_int(a, b, eps)

  end function unittest_assert_not_equal_int

  pure logical function unittest_assert_true(a) result(val)
    ! Boolean true test
    !
    ! a :: logical / boolean value
    logical, intent(in) :: a

    val = a

  end function unittest_assert_true

  pure logical function unittest_assert_false(a) result(val)
    ! Boolean false test
    !
    ! a :: logical / boolean value
    logical, intent(in) :: a

    val = (.not. a)

  end function unittest_assert_false

  pure logical function unittest_assert_le_dp(a, b, eps) result(val)
    ! Less than or equal test for double precision reals
    !
    ! a :: 1st value
    ! b :: 2nd value
    ! eps :: optional custom threshold for double precision equality
    real(dp), intent(in) :: a
    real(dp), intent(in) :: b
    real(dp), intent(in), optional :: eps

    include "./unittest_src/assert_le.src"
  end function unittest_assert_le_dp

  pure logical function unittest_assert_le_sp(a, b, eps) result(val)
    ! Less than or equal test for single precision reals. Duplicate of
    ! unittest_assert_le_dp
    real(sp), intent(in) :: a
    real(sp), intent(in) :: b
    real(sp), intent(in), optional :: eps

    include "./unittest_src/assert_le.src"
  end function unittest_assert_le_sp

  pure logical function unittest_assert_lt_dp(a, b, eps) result(val)
    ! Less than test for double precision reals
    !
    ! a :: 1st value
    ! b :: 2nd value
    ! eps :: optional threshold for comparison
    real(dp), intent(in) :: a
    real(dp), intent(in) :: b
    real(dp), intent(in), optional :: eps

    if (present(eps)) then
       val = ((a - b) .lt. eps)
    else
       val = ((a - b) .lt. eps_dp)
    end if

  end function unittest_assert_lt_dp

  pure logical function unittest_assert_lt_sp(a, b, eps) result(val)
    ! Less than test for single precision reals. Duplicate of
    ! unittest_assert_lt_dp
    real(sp), intent(in) :: a
    real(sp), intent(in) :: b
    real(sp), intent(in), optional :: eps

    if (present(eps)) then
       val = ((a - b) .lt. eps)
    else
       val = ((a - b) .lt. eps_sp)
    end if

  end function unittest_assert_lt_sp

  pure logical function unittest_assert_ge_dp(a, b, eps) result(val)
    ! Greater than or equal test for double precision reals
    !
    ! a :: 1st value
    ! b :: 2nd value
    ! eps :: optional custom threshold for double precision equality
    real(dp), intent(in) :: a
    real(dp), intent(in) :: b
    real(dp), intent(in), optional :: eps

    include "./unittest_src/assert_ge.src"
  end function unittest_assert_ge_dp

  pure logical function unittest_assert_ge_sp(a, b, eps) result(val)
    ! Greater than or equal test for single precision reals. Duplicate of
    ! unittest_assert_get_dp
    real(sp), intent(in) :: a
    real(sp), intent(in) :: b
    real(sp), intent(in), optional :: eps

    include "./unittest_src/assert_ge.src"
  end function unittest_assert_ge_sp

  pure logical function unittest_assert_gt_dp(a, b, eps) result(val)
    ! Greater than test for double precision reals
    !
    ! a :: 1st value
    ! b :: 2nd value
    real(dp), intent(in) :: a
    real(dp), intent(in) :: b
    real(dp), intent(in), optional :: eps

    if (present(eps)) then
       val = ((a - b) .gt. eps)
    else
       val = ((a - b) .gt. eps_dp)
    end if

  end function unittest_assert_gt_dp

  pure logical function unittest_assert_gt_sp(a, b, eps) result(val)
    ! Greater than test for single precision reals. Duplicate of
    ! unittest_assert_gt_dp
    real(sp), intent(in) :: a
    real(sp), intent(in) :: b
    real(sp), intent(in), optional :: eps

    if (present(eps)) then
       val = ((a - b) .gt. eps)
    else
       val = ((a - b) .gt. eps_sp)
    end if

  end function unittest_assert_gt_sp

  pure logical function unittest_assert_le_int(a, b, eps) result(val)
    ! Less than or equal test for integers. Duplicate of unittest_assert_le_dp
    integer(ip), intent(in) :: a
    integer(ip), intent(in) :: b
    integer(ip), intent(in), optional :: eps

    include "./unittest_src/assert_le.src"
  end function unittest_assert_le_int

  pure logical function unittest_assert_lt_int(a, b, eps) result(val)
    ! Less than test for integers. Duplicate of unittest_assert_lt_dp
    integer(ip), intent(in) :: a
    integer(ip), intent(in) :: b
    integer(ip), intent(in), optional :: eps

    if (present(eps)) then
       val = ((a - b) .lt. eps)
    else
       val = ((a - b) .lt. eps_int)
    end if

  end function unittest_assert_lt_int

  pure logical function unittest_assert_ge_int(a, b, eps) result(val)
    ! Greater than or equal test for integers. Duplicate of
    ! unittest_assert_ge_dp
    integer(ip), intent(in) :: a
    integer(ip), intent(in) :: b
    integer(ip), intent(in), optional :: eps

    include "./unittest_src/assert_ge.src"
  end function unittest_assert_ge_int

  pure logical function unittest_assert_gt_int(a, b, eps) result(val)
    ! Greater than test for integers. Duplicate of unittest_assert_gt_dp
    integer(ip), intent(in) :: a
    integer(ip), intent(in) :: b
    integer(ip), intent(in), optional :: eps

    if (present(eps)) then
       val = ((a - b) .gt. eps)
    else
       val = ((a - b) .gt. eps_int)
    end if

  end function unittest_assert_gt_int

end module unittest


!*robodoc*u* tests/testABH
!  NAME
!    testABH
!  SYNOPSIS

!$Id: testABH.f90 389 2017-03-22 16:31:21Z mexas $

program testABH

!  PURPOSE
!    Checking: cgca_redand, part of cgca_m2red
!  DESCRIPTION
!    Checking collective AND reduction over a logical coarray.
!    Works only when the number of images is 2**p,
!    where p is an integer, so use 2, 4, 8, 16, 32, etc. images.
!  NOTES
!    The program must be called with 2 command line arguments,
!    both positive integers. These are codimensions along 1 and 2.
!    The number of images must be such that
!    codimension3 = num_images()/( codimension1 * codimension3 )
!    is a positive integer. Example:
!      cafrun -np 16 ./testABH.x 2 2      ! OpenCoarrays
!    or
!      ./testABH.x 2 2                    ! Intel, Cray
!    which will make the third codimension equal to 16/(2*2)=4.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  USES
!    cgca testaux
!  USED BY
!    Part of CGPACK test suite
!  SOURCE

use testaux

implicit none

real, parameter :: l2 = log(real(2))
logical, parameter :: nodebug = .false.
real :: num
integer(kind=idef) :: p, nimages, img, codim(3)[*]
logical(kind=ldef) :: z[*]

!*********************************************************************72
! first executable statement

nimages=num_images()
img = this_image()

! check than n is a power of 2
p = nint(log(real(nimages))/l2)
if ( 2**p .ne. nimages)                                                &
      error stop "number of images is not a power of 2"

! do a check on image 1
if (img .eq. 1) then
 call getcodim(nimages,codim)
 ! print a banner
 call banner("ABH")
 write (*,'(a,i0,a)') "running on ", nimages, " images in a 3D grid"
end if

! Trying to separate the output
sync all

! initialise random number seed
call cgca_irs(nodebug)

! assign z
call random_number(num)

if (num .gt. 0.5) then
 z = .true.
else
 z = .false.
end if

z = .true.
if (img .eq. nimages) z = .false.

write (*,*) "image", img, "z", z

! Trying to separate the output
sync all

! call collective AND
call cgca_redand(z,p)

write (*,*) "image", img, "answer", z

end program testABH

!*roboend*


program tst
   write (6,"(a,es15.8)") "2.0**(-0.0) = ",2.0**(-0.0)
end program tst