subroutine rp1(maxmx,num_eqn,num_waves,num_aux,num_ghost,num_cells, &
               ql,qr,auxl,auxr,wave,s,amdq,apdq)

! Solve Riemann problems for the 1D shallow water equations
!   (h)_t + (u h)_x = 0
!   (uh)_t + ( uuh + .5*gh^2 )_x = 0
! using Roe's approximate Riemann solver with entropy fix for
! transonic rarefractions.

! waves: 2
! equations: 2

! Conserved quantities:
!       1 depth
!       2 momentum

! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

    implicit none

    integer, intent(in) :: maxmx, num_eqn, num_waves, num_aux, num_ghost, &
                            num_cells
    real(kind=8), intent(in), dimension(num_eqn,1-num_ghost:maxmx+num_ghost) :: ql, qr
    real(kind=8), intent(in), dimension(num_aux,1-num_ghost:maxmx+num_ghost) :: auxl, auxr
    real(kind=8), intent(out) :: s(num_waves, 1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(out) :: wave(num_eqn, num_waves, 1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(out), dimension(num_eqn,1-num_ghost:maxmx+num_ghost) :: amdq,apdq

    ! local variables:
    real(kind=8) :: a1,a2,ubar,cbar,s0,s1,s2,s3,hr1,uhr1,hl2,uhl2,sfract,df
    real(kind=8) :: delta(2)
    integer :: i,m,mw

    logical :: efix

    data efix /.true./    !# Use entropy fix for transonic rarefactions

    ! Gravity constant set in setprob.f or the shallow1D.py file
    real(kind=8) :: grav
    common /cparam/ grav

    ! Main loop of the Riemann solver.
    do 30 i=2-num_ghost,num_cells+num_ghost

        ! compute  Roe-averaged quantities:
        ubar = (qr(2,i-1)/dsqrt(qr(1,i-1)) + ql(2,i)/dsqrt(ql(1,i)))/ &
               ( dsqrt(qr(1,i-1)) + dsqrt(ql(1,i)) )
        cbar=dsqrt(0.5d0*grav*(qr(1,i-1) + ql(1,i)))

        ! delta(1)=h(i)-h(i-1) and  delta(2)=hu(i)-hu(i-1)
        delta(1) = ql(1,i) - qr(1,i-1)
        delta(2) = ql(2,i) - qr(2,i-1)

        ! Compute coeffs in the evector expansion of delta(1),delta(2)
        a1 = 0.5d0*(-delta(2) + (ubar + cbar) * delta(1))/cbar
        a2 = 0.5d0*( delta(2) - (ubar - cbar) * delta(1))/cbar

        ! Finally, compute the waves.
        wave(1,1,i) = a1
        wave(2,1,i) = a1*(ubar - cbar)
        s(1,i) = ubar - cbar

        wave(1,2,i) = a2
        wave(2,2,i) = a2*(ubar + cbar)
        s(2,i) = ubar + cbar

    30 enddo

    ! Compute fluctuations amdq and apdq
    ! ------------------------------------

    if (efix) go to 110

    ! No entropy fix
    ! ----------------------------------------------
    ! amdq = SUM s*wave   over left-going waves
    ! apdq = SUM s*wave   over right-going waves

    do m=1,2
        do i=2-num_ghost, num_cells+num_ghost
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do mw=1,num_waves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                endif
            enddo
        enddo
    enddo

    ! with no entropy fix we are done...
    return

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

    110 continue

    ! With entropy fix
    ! ------------------

    ! compute flux differences amdq and apdq.
    ! First compute amdq as sum of s*wave for left going waves.
    ! Incorporate entropy fix by adding a modified fraction of wave
    ! if s should change sign.

    do 200 i=2-num_ghost,num_cells+num_ghost

        ! ------------------------------------------------------
        ! check 1-wave:
        ! ---------------

        ! u-c in left state (cell i-1)
        s0 = qr(2,i-1)/qr(1,i-1) - dsqrt(grav*qr(1,i-1))

        ! check for fully supersonic case:
        if (s0 >= 0.d0 .and. s(1,i) > 0.d0)  then
            ! everything is right-going
            do m=1,2
                amdq(m,i) = 0.d0
                enddo
            go to 200
        endif

        ! u-c to right of 1-wave
        hr1  = qr(1,i-1) + wave(1,1,i)
        uhr1 = qr(2,i-1) + wave(2,1,i)
        s1 =  uhr1/hr1 - dsqrt(grav*hr1)

        if (s0 < 0.d0 .and. s1 > 0.d0) then
            ! transonic rarefaction in the 1-wave
            sfract = s0 * (s1-s(1,i)) / (s1-s0)
        else if (s(1,i) < 0.d0) then
            ! 1-wave is leftgoing
            sfract = s(1,i)
        else
            ! 1-wave is rightgoing
            sfract = 0.d0   !# this shouldn't happen since s0 < 0
        endif

        do m=1,2
            amdq(m,i) = sfract*wave(m,1,i)
            enddo

        ! -------------------------------------------------------
        ! check 2-wave:
        ! ---------------
        ! u+c in right state  (cell i)
        s3 = ql(2,i)/ql(1,i) + dsqrt(grav*ql(1,i))

        ! u+c to left of 2-wave
        hl2  = ql(1,i) - wave(1,2,i)
        uhl2 = ql(2,i) - wave(2,2,i)
        s2 = uhl2/hl2 + dsqrt(grav*hl2)

        if (s2 < 0.d0 .and. s3 > 0.d0) then
            ! transonic rarefaction in the 2-wave
            sfract = s2 * (s3-s(2,i)) / (s3-s2)
        else if (s(2,i) < 0.d0) then
            ! 2-wave is leftgoing
            sfract = s(2,i)
        else
            ! 2-wave is rightgoing
            go to 200
        endif

        do m=1,2
            amdq(m,i) = amdq(m,i) + sfract*wave(m,2,i)
            enddo

    200 enddo

    ! compute the rightgoing flux differences:
    ! df = SUM s*wave   is the total flux difference and apdq = df - amdq

    do m=1,2
        do i = 2-num_ghost, num_cells+num_ghost
            df = 0.d0
            do mw=1,num_waves
                df = df + s(mw,i)*wave(m,mw,i)
                enddo
            apdq(m,i) = df - amdq(m,i)
            enddo
        enddo

    return

    end subroutine rp1


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.

    use geoclaw_module, only: sea_level
    use grid_module, only: xcell

    ! uncomment if any of these needed...
    use geoclaw_module, only: dry_tolerance, grav

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i
    real(kind=8) :: x0,width,eta

    x0 = -60.d3   ! initial location of step
    width = 30.e3

    do i=1,mx
      !if (xcell(i) > x0) then
      if ((xcell(i) < x0-width) .or. (xcell(i) > x0)) then
          eta = 0.d0
        else
          eta = 1.d0
        endif
      q(1,i) = max(0.0, eta - aux(1,i))
      q(2,i) = eta*sqrt(grav*q(1,i))  ! right-going

   enddo

end subroutine qinit


MODULE matrices
USE global
USE funlib
USE kinematics
USE matrix_base
USE cmatrix_base
USE binary_tree
IMPLICIT NONE
CONTAINS
  SUBROUTINE CaleyMatrix(NLOOPLINE,PCL,M2L,matrix,det)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,0:3),INTENT(IN)::PCL
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(0:3)::rij
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::matrix
    REAL(KIND(1d0)),INTENT(OUT)::det
    INTEGER::i,j
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij(0:3)=PCL(i,0:3)-PCL(j,0:3)
          matrix(i,j)=scalarprod(rij(0:3),rij(0:3))-M2L(i)-M2L(j)
          IF(i.LT.j)THEN
             matrix(j,i)=matrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    det=MNXNDET(NLOOPLINE,matrix)
    RETURN
  END SUBROUTINE CaleyMatrix

  SUBROUTINE Complex_CaleyMatrix(NLOOPLINE,PCL,M2L,matrix,det)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,0:3),INTENT(IN)::PCL
    COMPLEX(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(0:3)::rij
    COMPLEX(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::matrix
    COMPLEX(KIND(1d0)),INTENT(OUT)::det
    INTEGER::i,j
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij(0:3)=PCL(i,0:3)-PCL(j,0:3)
          matrix(i,j)=scalarprod(rij(0:3),rij(0:3))-M2L(i)-M2L(j)
          IF(i.LT.j)THEN
             matrix(j,i)=matrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    det=CMNXNDET(NLOOPLINE,matrix)
    RETURN
  END SUBROUTINE Complex_CaleyMatrix

  SUBROUTINE CaleyMatrix2(NLOOPLINE,PijMatrix,M2L,matrix,det)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(IN)::PijMatrix ! PijMatrix(i,j)=Pi.Pj
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::matrix
    REAL(KIND(1d0)),INTENT(OUT)::det
    INTEGER::i,j
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          matrix(i,j)=PijMatrix(i,i)+PijMatrix(j,j)-2d0*PijMatrix(i,j)-M2L(i)-M2L(j)
          IF(i.LT.j)THEN
             matrix(j,i)=matrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    det=MNXNDET(NLOOPLINE,matrix)
    RETURN
  END SUBROUTINE CaleyMatrix2

  SUBROUTINE GramMatrix(NLOOPLINE,PCL,M2L,matrix,det)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,0:3),INTENT(IN)::PCL
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(0:3)::rij
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::matrix
    REAL(KIND(1d0)),INTENT(OUT)::det
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,0:3)::PE
    INTEGER::i,j
    CALL PCL2PE(NLOOPLINE,PCL,PE)
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          matrix(i,j)=scalarprod(PE(i,0:3),PE(j,0:3))
          IF(i.LT.j)THEN
             matrix(j,i)=matrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    det=MNXNDET(NLOOPLINE,matrix)
    RETURN
  END SUBROUTINE GramMatrix
  ! hep-ph/0303184
  SUBROUTINE RSMatrices(NLOOPLINE,PCL,M2L,rmatrix,smatrix,rdet,sdet)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
!    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,0:3),INTENT(IN)::PCL
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(0:3)::rij
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::rmatrix
    REAL(KIND(1d0)),DIMENSION(0:NLOOPLINE,0:NLOOPLINE),INTENT(OUT)::smatrix
    REAL(KIND(1d0)),INTENT(OUT)::rdet,sdet
    INTEGER::i,j
    LOGICAL::find
    TYPE(rsmatrices_node),POINTER::item
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3)::PCL1
    IF(RECYCLING)THEN
       PCL1(1,0:3)=0d0
       DO i=2,NLOOPLINE
          PCL1(i,0:3)=PCL(i,0:3)-PCL(1,0:3)
       ENDDO
       ALLOCATE(item)
       item%NLOOPLINE=NLOOPLINE
       item%M2L(1:NLOOPLINE)=M2L(1:NLOOPLINE)
       item%PCL(1:NLOOPLINE,0:3)=PCL1(1:NLOOPLINE,0:3)
       CALL rsmatrices_bt_search(item,rsmatrices_save,find)
       IF(find)THEN
          rdet=item%detR
          sdet=item%detS
          RMATRIX(1:NLOOPLINE,1:NLOOPLINE)=&
               item%RMATRIX(1:NLOOPLINE,1:NLOOPLINE)
          SMATRIX(0:NLOOPLINE,0:NLOOPLINE)=&
               item%SMATRIX(0:NLOOPLINE,0:NLOOPLINE)
          DEALLOCATE(item)
          RETURN
       ENDIF
    ENDIF
    smatrix(0,0)=0d0
    DO i=1,NLOOPLINE
       smatrix(0,i)=1d0
       smatrix(i,0)=1d0
    ENDDO
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij(0:3)=PCL(i,0:3)-PCL(j,0:3)
          rmatrix(i,j)=scalarprod(rij(0:3),rij(0:3))-M2L(i)-M2L(j)
          smatrix(i,j)=rmatrix(i,j)
          IF(i.LT.j)THEN
             rmatrix(j,i)=rmatrix(i,j)
             smatrix(j,i)=smatrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    rdet=MNXNDET(NLOOPLINE,rmatrix)
    sdet=MNXNDET(NLOOPLINE+1,smatrix(0:NLOOPLINE,0:NLOOPLINE))
    IF(RECYCLING)THEN
       item%detS=sdet
       item%detR=rdet
       item%SMATRIX(0:NLOOPLINE,0:NLOOPLINE)=SMATRIX(0:NLOOPLINE,0:NLOOPLINE)
       item%RMATRIX(1:NLOOPLINE,1:NLOOPLINE)=RMATRIX(1:NLOOPLINE,1:NLOOPLINE)
    ENDIF
    RETURN
  END SUBROUTINE RSMATRICES

  SUBROUTINE CRSMatrices(NLOOPLINE,PCL,M2L,rmatrix,smatrix,rdet,sdet)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,0:3),INTENT(IN)::PCL
    COMPLEX(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(0:3)::rij
    COMPLEX(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::rmatrix
    COMPLEX(KIND(1d0)),DIMENSION(0:NLOOPLINE,0:NLOOPLINE),INTENT(OUT)::smatrix
    COMPLEX(KIND(1d0)),INTENT(OUT)::rdet,sdet
    INTEGER::i,j
    LOGICAL::find
    TYPE(crsmatrices_node),POINTER::item
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3)::PCL1
    IF(RECYCLING)THEN
       PCL1(1,0:3)=0d0
       DO i=2,NLOOPLINE
          PCL1(i,0:3)=PCL(i,0:3)-PCL(1,0:3)
       ENDDO
       ALLOCATE(item)
       item%NLOOPLINE=NLOOPLINE
       item%M2L(1:NLOOPLINE)=M2L(1:NLOOPLINE)
       item%PCL(1:NLOOPLINE,0:3)=PCL1(1:NLOOPLINE,0:3)
       CALL crsmatrices_bt_search(item,crsmatrices_save,find)
       IF(find)THEN
          rdet=item%detR
          sdet=item%detS
          RMATRIX(1:NLOOPLINE,1:NLOOPLINE)=&
               item%RMATRIX(1:NLOOPLINE,1:NLOOPLINE)
          SMATRIX(0:NLOOPLINE,0:NLOOPLINE)=&
               item%SMATRIX(0:NLOOPLINE,0:NLOOPLINE)
          DEALLOCATE(item)
          RETURN
       ENDIF
    ENDIF
    smatrix(0,0)=DCMPLX(0d0)
    DO i=1,NLOOPLINE
       smatrix(0,i)=DCMPLX(1d0)
       smatrix(i,0)=DCMPLX(1d0)
    ENDDO
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij(0:3)=PCL(i,0:3)-PCL(j,0:3)
          rmatrix(i,j)=scalarprod(rij(0:3),rij(0:3))-M2L(i)-M2L(j)
          smatrix(i,j)=rmatrix(i,j)
          IF(i.LT.j)THEN
             rmatrix(j,i)=rmatrix(i,j)
             smatrix(j,i)=smatrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    rdet=CMNXNDET(NLOOPLINE,rmatrix)
    sdet=CMNXNDET(NLOOPLINE+1,smatrix(0:NLOOPLINE,0:NLOOPLINE))
    IF(RECYCLING)THEN
       item%detS=sdet
       item%detR=rdet
       item%SMATRIX(0:NLOOPLINE,0:NLOOPLINE)=SMATRIX(0:NLOOPLINE,0:NLOOPLINE)
       item%RMATRIX(1:NLOOPLINE,1:NLOOPLINE)=RMATRIX(1:NLOOPLINE,1:NLOOPLINE)
    ENDIF
    RETURN
  END SUBROUTINE CRSMATRICES

  SUBROUTINE RSMatrices2(NLOOPLINE,PijMatrix,M2L,rmatrix,smatrix,rdet,sdet)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE,1:NLOOPLINE),INTENT(IN)::PijMatrix ! PijMatrix(i,j)=Pi.Pj
    REAL(KIND(1d0)),DIMENSION(1:NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::rmatrix
    REAL(KIND(1d0)),DIMENSION(0:NLOOPLINE,0:NLOOPLINE),INTENT(OUT)::smatrix
    REAL(KIND(1d0)),INTENT(OUT)::rdet,sdet
    INTEGER::i,j
    smatrix(0,0)=0d0
    DO i=1,NLOOPLINE
       smatrix(0,i)=1d0
       smatrix(i,0)=1d0
    ENDDO
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rmatrix(i,j)=PijMatrix(i,i)+PijMatrix(j,j)-2d0*PijMatrix(i,j)-M2L(i)-M2L(j)
          smatrix(i,j)=rmatrix(i,j)
          IF(i.LT.j)THEN
             rmatrix(j,i)=rmatrix(i,j)
             smatrix(j,i)=smatrix(i,j)
          ENDIF
       ENDDO
    ENDDO
    rdet=MNXNDET(NLOOPLINE,rmatrix)
    sdet=MNXNDET(NLOOPLINE+1,smatrix(0:NLOOPLINE,0:NLOOPLINE))
    RETURN
  END SUBROUTINE RSMATRICES2
  ! in hep - ph/0509141
  SUBROUTINE XYZMATRICES(NLOOPLINE,PCL,M2L,XMATRIX,YMATRIX,ZMATRIX,detY,detZ)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3),INTENT(IN)::PCL
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(2:NLOOPLINE,2:NLOOPLINE),INTENT(OUT)::ZMATRIX
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::YMATRIX,XMATRIX
    REAL(KIND(1d0)),INTENT(OUT)::detY,detZ
    INTEGER::i,j
    REAL(KIND(1d0)),DIMENSION(0:3)::ri1,rj1,rij
    LOGICAL::find
    TYPE(xyzmatrices_node),POINTER::item
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3)::PCL1
    IF(RECYCLING)THEN
       PCL1(1,0:3)=0d0
       DO i=2,NLOOPLINE
          PCL1(i,0:3)=PCL(i,0:3)-PCL(1,0:3)
       ENDDO
       ALLOCATE(item)
       item%NLOOPLINE=NLOOPLINE
       item%M2L(1:NLOOPLINE)=M2L(1:NLOOPLINE)
       item%PCL(1:NLOOPLINE,0:3)=PCL1(1:NLOOPLINE,0:3)
       CALL xyzmatrices_bt_search(item,xyzmatrices_save,find)
       IF(find)THEN
          detY=item%detY
          detZ=item%detZ
          YMATRIX(1:NLOOPLINE,1:NLOOPLINE)=&
               item%YMATRIX(1:NLOOPLINE,1:NLOOPLINE)
          XMATRIX(1:NLOOPLINE,1:NLOOPLINE)=&
               item%XMATRIX(1:NLOOPLINE,1:NLOOPLINE)
          ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)=&
               item%ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)
          DEALLOCATE(item)
          RETURN
       ENDIF
    ENDIF
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij(0:3)=PCL(i,0:3)-PCL(j,0:3)
          YMATRIX(i,j)=-scalarprod(rij(0:3),rij(0:3))+M2L(i)+M2L(j)
          IF(i.GE.2)THEN
             ri1(0:3)=PCL(i,0:3)-PCL(1,0:3)
             rj1(0:3)=PCL(j,0:3)-PCL(1,0:3)
             ZMATRIX(i,j)=2d0*scalarprod(ri1(0:3),rj1(0:3))
             XMATRIX(i,j)=ZMATRIX(i,j)
          ELSE
             IF(j.EQ.1)THEN
                XMATRIX(i,j)=2*M2L(1)
             ELSE
                ri1(0:3)=PCL(j,0:3)-PCL(1,0:3)
                XMATRIX(i,j)=scalarprod(ri1(0:3),ri1(0:3))-M2L(j)+M2L(1)
             ENDIF
          ENDIF
          IF(i.LT.j)THEN
             YMATRIX(j,i)=YMATRIX(i,j)
             XMATRIX(j,i)=XMATRIX(i,j)
             IF(i.GE.2)THEN
                ZMATRIX(j,i)=ZMATRIX(i,j)
             ENDIF
          ENDIF
       ENDDO
    ENDDO
    detZ=MNXNDET(NLOOPLINE-1,ZMATRIX(2:NLOOPLINE,2:NLOOPLINE))
    detY=MNXNDET(NLOOPLINE,YMATRIX(1:NLOOPLINE,1:NLOOPLINE))
    IF(RECYCLING)THEN
       item%detY=detY
       item%detZ=detZ
       item%XMATRIX(1:NLOOPLINE,1:NLOOPLINE)=XMATRIX(1:NLOOPLINE,1:NLOOPLINE)
       item%YMATRIX(1:NLOOPLINE,1:NLOOPLINE)=YMATRIX(1:NLOOPLINE,1:NLOOPLINE)
       item%ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)=ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)
    ENDIF
    RETURN
  END SUBROUTINE XYZMATRICES

  SUBROUTINE CXYZMATRICES(NLOOPLINE,PCL,M2L,XMATRIX,YMATRIX,ZMATRIX,detY,detZ)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3),INTENT(IN)::PCL
    COMPLEX(KIND(1d0)),DIMENSION(NLOOPLINE),INTENT(IN)::M2L
    COMPLEX(KIND(1d0)),DIMENSION(2:NLOOPLINE,2:NLOOPLINE),INTENT(OUT)::ZMATRIX
    COMPLEX(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::YMATRIX,XMATRIX
    COMPLEX(KIND(1d0)),INTENT(OUT)::detY,detZ
    INTEGER::i,j
    REAL(KIND(1d0)),DIMENSION(0:3)::ri1,rj1,rij
    LOGICAL::find
    TYPE(cxyzmatrices_node),POINTER::item
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,0:3)::PCL1
    IF(RECYCLING)THEN
       PCL1(1,0:3)=0d0
       DO i=2,NLOOPLINE
          PCL1(i,0:3)=PCL(i,0:3)-PCL(1,0:3)
       ENDDO
       ALLOCATE(item)
       item%NLOOPLINE=NLOOPLINE
       item%M2L(1:NLOOPLINE)=M2L(1:NLOOPLINE)
       item%PCL(1:NLOOPLINE,0:3)=PCL1(1:NLOOPLINE,0:3)
       CALL cxyzmatrices_bt_search(item,cxyzmatrices_save,find)
       IF(find)THEN
          detY=item%detY
          detZ=item%detZ
          YMATRIX(1:NLOOPLINE,1:NLOOPLINE)=&
               item%YMATRIX(1:NLOOPLINE,1:NLOOPLINE)
          XMATRIX(1:NLOOPLINE,1:NLOOPLINE)=&
               item%XMATRIX(1:NLOOPLINE,1:NLOOPLINE)
          ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)=&
               item%ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)
          DEALLOCATE(item)
          RETURN
       ENDIF
    ENDIF
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij(0:3)=PCL(i,0:3)-PCL(j,0:3)
          YMATRIX(i,j)=-scalarprod(rij(0:3),rij(0:3))+M2L(i)+M2L(j)
          IF(i.GE.2)THEN
             ri1(0:3)=PCL(i,0:3)-PCL(1,0:3)
             rj1(0:3)=PCL(j,0:3)-PCL(1,0:3)
             ZMATRIX(i,j)=2d0*scalarprod(ri1(0:3),rj1(0:3))
             XMATRIX(i,j)=ZMATRIX(i,j)
          ELSE
             IF(j.EQ.1)THEN
                XMATRIX(i,j)=2*M2L(1)
             ELSE
                ri1(0:3)=PCL(j,0:3)-PCL(1,0:3)
                XMATRIX(i,j)=scalarprod(ri1(0:3),ri1(0:3))-M2L(j)+M2L(1)
             ENDIF
          ENDIF
          IF(i.LT.j)THEN
             YMATRIX(j,i)=YMATRIX(i,j)
             XMATRIX(j,i)=XMATRIX(i,j)
             IF(i.GE.2)THEN
                ZMATRIX(j,i)=ZMATRIX(i,j)
             ENDIF
          ENDIF
       ENDDO
    ENDDO
    detZ=CMNXNDET(NLOOPLINE-1,ZMATRIX(2:NLOOPLINE,2:NLOOPLINE))
    detY=CMNXNDET(NLOOPLINE,YMATRIX(1:NLOOPLINE,1:NLOOPLINE))
    IF(RECYCLING)THEN
       item%detY=detY
       item%detZ=detZ
       item%XMATRIX(1:NLOOPLINE,1:NLOOPLINE)=XMATRIX(1:NLOOPLINE,1:NLOOPLINE)
       item%YMATRIX(1:NLOOPLINE,1:NLOOPLINE)=YMATRIX(1:NLOOPLINE,1:NLOOPLINE)
       item%ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)=ZMATRIX(2:NLOOPLINE,2:NLOOPLINE)
    ENDIF
    RETURN
  END SUBROUTINE CXYZMATRICES

  SUBROUTINE XYZMATRICES2(NLOOPLINE,PijMatrix,M2L,XMATRIX,YMATRIX,ZMATRIX,detY,detZ)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::NLOOPLINE
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(IN)::PijMatrix ! PijMatrix(i,j)=pi.pj
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE),INTENT(IN)::M2L
    REAL(KIND(1d0)),DIMENSION(2:NLOOPLINE,2:NLOOPLINE),INTENT(OUT)::ZMATRIX
    REAL(KIND(1d0)),DIMENSION(NLOOPLINE,NLOOPLINE),INTENT(OUT)::YMATRIX,XMATRIX
    REAL(KIND(1d0)),INTENT(OUT)::detY,detZ
    INTEGER::i,j
    REAL(KIND(1d0))::ri1,rj1,rij
    DO i=1,NLOOPLINE
       DO j=i,NLOOPLINE
          rij=PijMatrix(i,i)+PijMatrix(j,j)-2d0*PijMatrix(i,j)
          YMATRIX(i,j)=-rij+M2L(i)+M2L(j)
          IF(i.GE.2)THEN
             ZMATRIX(i,j)=2d0*(PijMatrix(i,j)+PijMatrix(1,1)-PijMatrix(i,1)-PijMatrix(j,1))
             XMATRIX(i,j)=ZMATRIX(i,j)
          ELSE
             IF(j.EQ.1)THEN
                XMATRIX(i,j)=2*M2L(1)
             ELSE
                ri1=PijMatrix(i,i)+PijMatrix(1,1)-2d0*PijMatrix(i,1)
                XMATRIX(i,j)=ri1-M2L(j)+M2L(1)
             ENDIF
          ENDIF
          IF(i.LT.j)THEN
             YMATRIX(j,i)=YMATRIX(i,j)
             XMATRIX(j,i)=XMATRIX(i,j)
             IF(i.GE.2)THEN
                ZMATRIX(j,i)=ZMATRIX(i,j)
             ENDIF
          ENDIF
       ENDDO
    ENDDO
    detZ=MNXNDET(NLOOPLINE-1,ZMATRIX(2:NLOOPLINE,2:NLOOPLINE))
    detY=MNXNDET(NLOOPLINE,YMATRIX(1:NLOOPLINE,1:NLOOPLINE))
    RETURN
  END SUBROUTINE XYZMATRICES2

END MODULE matrices


	SUBROUTINE MPOWER
     . (ALPHA,PHI,P0,N,M,PSI,resultPOWER,ERR)
!MS$ATTRIBUTES REFERENCE :: resultPOWER
!MS$ATTRIBUTES REFERENCE :: ERR
	IMPLICIT NONE

	REAL ALPHA,PHI,P0,N,M,PSI,resultPOWER
	INTEGER ERR
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine the power associated with matched case-control
C	studies.
C  Input prompted for from user:
C	ALPHA	Type I error probability for a two sided test
C	PHI		Correlation coefficient for exposure between
C			matched cases and controls
C	P0		Probability of exposure in control group
C	N		Number of case patients
C	M		Number of matched controls per case patient
C	PSI		Odds ratio
C
C  Output:
C	POWER	Probability of rejecting the null hypothesis that
C			PSI=1 given N cases, M controls per case, and a
C			type I error probability ALPHA when the true odds
C			ratio equals PSI
C	Error flag
C			0=no error
C			1=no matched table exists with P0, PSI, and R
C			2=expected number of M-tuples with an exposed case and
C			at least 1 unexposed control is <=5
C  Notes:
C   .	This routine was written by Dale Plummer.
C   .	Reference:
C	    Dupont, WD: "Power Calculations for Matched Case-Control
C	    Studies", Biometrics, 1988; 44:1157-1168.
C   .	Link with subroutines in file SUBS.FOR
C
C-Declarations----------------------------------------------------------
C
C
C  Functions
C
	REAL ZCRVALUE
C
C  Locals
C
	REAL ZALPHA
	INTEGER IN,IM
C
C-Code------------------------------------------------------------------
C
	IM=M
	IN=N
C
C    Call the working routine.
C
	ZALPHA=ZCRVALUE(ALPHA/2.)
	CALL POWFCN(ZALPHA,IN,PHI,P0,IM,PSI,resultPOWER,ERR)
C
C  Done.
C
	RETURN
	END


program solve_24
  use helpers
  implicit none
  real                 :: vector(4), reals(4), p, q, r, s
  integer              :: numbers(4), n, i, j, k, a, b, c, d
  character, parameter :: ops(4) = (/ '+', '-', '*', '/' /)
  logical              :: last
  real,parameter       :: eps = epsilon(1.0)

  do n=1,12
    call random_number(vector)
    reals   = 9 * vector + 1
    numbers = int(reals)
    call Insertion_Sort(numbers)

    permutations: do
      a = numbers(1); b = numbers(2); c = numbers(3); d = numbers(4)
      reals = real(numbers)
      p = reals(1);   q = reals(2);   r = reals(3);   s = reals(4)
      ! combinations of operators:
      do i=1,4
        do j=1,4
          do k=1,4
            if      ( abs(op(op(op(p,i,q),j,r),k,s)-24.0) < eps ) then
              write (*,*) numbers, ' : ', '((',a,ops(i),b,')',ops(j),c,')',ops(k),d
              exit permutations
            else if ( abs(op(op(p,i,op(q,j,r)),k,s)-24.0) < eps ) then
              write (*,*) numbers, ' : ', '(',a,ops(i),'(',b,ops(j),c,'))',ops(k),d
              exit permutations
            else if ( abs(op(p,i,op(op(q,j,r),k,s))-24.0) < eps ) then
              write (*,*) numbers, ' : ', a,ops(i),'((',b,ops(j),c,')',ops(k),d,')'
              exit permutations
            else if ( abs(op(p,i,op(q,j,op(r,k,s)))-24.0) < eps ) then
              write (*,*) numbers, ' : ', a,ops(i),'(',b,ops(j),'(',c,ops(k),d,'))'
              exit permutations
            else if ( abs(op(op(p,i,q),j,op(r,k,s))-24.0) < eps ) then
              write (*,*) numbers, ' : ', '(',a,ops(i),b,')',ops(j),'(',c,ops(k),d,')'
              exit permutations
            end if
          end do
        end do
      end do
      call nextpermutation(numbers,last)
      if ( last ) then
        write (*,*) numbers, ' : no solution.'
        exit permutations
      end if
    end do permutations

  end do

contains

  pure real function op(x,c,y)
    integer, intent(in) :: c
    real, intent(in)    :: x,y
    select case ( ops(c) )
      case ('+')
        op = x+y
      case ('-')
        op = x-y
      case ('*')
        op = x*y
      case ('/')
        op = x/y
    end select
  end function op

end program solve_24


subroutine pgm(n,m)
integer:: n,m, i, j, c
integer :: a(n,m)

c = 0
do i = 1,m
do j = 1,n
  a(j,i) = c
  c = c  + 1
enddo
enddo

do i = 1,m
do j = 1,n
  print *, a(j,i)
enddo
enddo

end

program p

integer :: n = 5 , m = 5
call pgm(n,m)

end


      SUBROUTINE CDIVID(A,B,D,NCOL)
      DOUBLE PRECISION A(1),B(1),D(2),DTEMP,DENM
C
C     THIS ROUTINE DIVIDES THE VECTOR A BY D AND STORE RESULT IN B
C
      DENM = D(1)**2 + D(2)**2
      DO 10 I = 1,NCOL,2
      DTEMP = (A(I)*D(1) +A(I+1)*D(2))/DENM
      B(I+1) = (A(I+1)*D(1) -A(I) * D(2))/DENM
      B(I) = DTEMP
   10 CONTINUE
      RETURN
      END


c     DRDGAMMA
c>> 1996-07-12 DRDGAMMA Krogh  Minor changes for conversion to C.
c>> 1994-10-19 DRDGAMMA Krogh  Changes to use M77CON
c>> 1992-06-11 DRDGAMMA Krogh   Changed "duplication" identity.
c>> 1991-10-21 DRDGAMMA CLL
c>> 1987-12-09 DRDGAMMA Lawson  Initial Code.
c
c--D replaces "?": DR?GAMMA, ?GAMMA, ?LGAMA
      external DGAMMA, DLGAMA
      double precision DGAMMA, DLGAMA
      double precision LGAM, GAM, PI, X(12), Z
      integer I
c
      data X /-1.5d0, -0.5d0, 0.5d0,  1.0d0,  1.5d0,  2.0d0,
     *          3.0d0, 4.0d0, 5.0d0, 10.0d0, 20.0d0, 30.0d0 /
      data PI / 3.1415926535897932385d0 /
c
      print '(''   X'',9X,''DGAMMA'',10X,''DLGAMA'',10X,''Z''/1x)'
c
      do 10 I = 1, 12
        GAM = DGAMMA(X(I))
        Z = (2.d0 * SQRT(PI) * GAM) / ((2.0d0**X(I)) *
     1    DGAMMA(0.5d0*X(I)) * DGAMMA(0.5d0*X(I)+.5d0)) - 1.d0
        if(X(I) .lt. 0.0d0) then
          print '(1x,F4.1,3X,G15.8, 13x ,1X,E13.2)', X(I), GAM,  Z
        else
          LGAM = DLGAMA(X(I))
          print '(1x,F4.1,3X,G15.8,F13.5,1X,E13.2)', X(I), GAM, LGAM, Z
        endif
   10 continue
      end


MODULE SYSINFO

!**********************************************************************
!**************** SHARED VARAIBLES AND MATERICES **********************
!**********************************************************************

!**************************************************************
!                  GENERAL CONSTANTS
!**************************************************************
 REAL(4),PARAMETER :: PI=4.0d0*ATAN(1.0d0)
 REAL(4),PARAMETER :: KB=1.3807E-23
 REAL(4),PARAMETER :: Vc=2.9979E+8
 REAL(4),PARAMETER :: MU0=4.0E-7*PI
 REAL(4),PARAMETER :: EPSILON0=8.8542E-12
 REAL(4),PARAMETER :: N_Avogaros=6.023E23

!**************************************************************
!                    EARTH RADIUS
!**************************************************************
 REAL(4),PARAMETER :: Re=6378.1

!**************************************************************
!                    SYSTEM STATUS
!**************************************************************
 LOGICAL                :: SYSRESTART        =.FALSE.
!**************************************************************
!         SYSTEM GRID COORDINATES AND PARAMETERS
!**************************************************************
!********************** GRIDING SYSTEM ************************
 LOGICAL                 :: RECTGRID         =.TRUE.
 LOGICAL                 :: SPHRGRID         =.FALSE.
 LOGICAL                 :: GEOGRAPHICGRID   =.TRUE.
 LOGICAL                 :: GEOMAGNETICGRID  =.FALSE.
!**************** PRIMATRY GRIDING SYSTEM *********************
 LOGICAL                 :: pRECTGRID         =.FALSE.
 LOGICAL                 :: pSPHRGRID         =.FALSE.
 LOGICAL                 :: pGEOGRAPHICGRID   =.FALSE.
 LOGICAL                 :: pGEOMAGNETICGRID  =.FALSE.
!**************** SECONDARY GRIDING SYSTEM ********************
 LOGICAL                 :: sRECTGRID         =.FALSE.
 LOGICAL                 :: sSPHRGRID         =.FALSE.
 LOGICAL                 :: sGEOGRAPHICGRID   =.FALSE.
 LOGICAL                 :: sGEOMAGNETICGRID  =.FALSE.
!********************** GRID SPACINGS *************************
 LOGICAL                 :: EQUISPACED       =.TRUE.
 LOGICAL                 :: XEQUISPACED      =.FALSE.
 LOGICAL                 :: YEQUISPACED      =.FALSE.
 LOGICAL                 :: ZEQUISPACED      =.FALSE.
 LOGICAL                 :: CHEBYSHEVSPACED  =.FALSE.
 LOGICAL                 :: XCHEBYSHEVSPACED =.FALSE.
 LOGICAL                 :: YCHEBYSHEVSPACED =.FALSE.
 LOGICAL                 :: ZCHEBYSHEVSPACED =.FALSE.
 LOGICAL                 :: LEGENDERSPACED   =.FALSE.
 LOGICAL                 :: XLEGENDERSPACED  =.FALSE.
 LOGICAL                 :: YLEGENDERSPACED  =.FALSE.
 LOGICAL                 :: ZLEGENDERSPACED  =.FALSE.
!************ RECTANGLE NUMBER OF R-GRID POINTS ***************
 INTEGER(4)              :: XDIM=1
 INTEGER(4)              :: YDIM=1
 INTEGER(4)              :: ZDIM=1
!*************** R-SPACE RECTANGLE DIMENSIONS RANGES ******************
 REAL(8)                 :: Xsrt=   0.0
 REAL(8)                 :: Xend=   0.0
 REAL(8)                 :: Ysrt= -16.0*PI
 REAL(8)                 :: Yend=  16.0*PI
 REAL(8)                 :: Zsrt=   0.0*PI
 REAL(8)                 :: Zend=  32.0*PI
!*************** GEO DIMENSIONS RANGES ******************
 REAL(4)                 :: srtLAT= - 0.0
 REAL(4)                 :: endLAT=   0.0
 REAL(4)                 :: srtLON= -0.000050
 REAL(4)                 :: endLON=  0.000050
 REAL(4)                 :: srtALT=  105.000
 REAL(4)                 :: endALT=  105.100
!*************** RECTANGLE R-SPACE ARRAYS **********************
 REAL(8),    ALLOCATABLE :: X1D(:),X2D(:,:),X3D(:,:,:)
 REAL(8),    ALLOCATABLE :: Y1D(:),Y2D(:,:),Y3D(:,:,:)
 REAL(8),    ALLOCATABLE :: Z1D(:),Z2D(:,:),Z3D(:,:,:)
!*************** GEO R-SPACE ARRAYS ********************
 REAL(4),    ALLOCATABLE :: LAT1D(:)
 REAL(4),    ALLOCATABLE :: LON1D(:)
 REAL(4),    ALLOCATABLE :: ALT1D(:)

!**************************************************************
!************** LOCAL TIME AND DATE RANGE MATRICES ************
!**************************************************************
!INTEGER(4)              :: srtLT=120000,endLT=130000,stpLT=10000
!INTEGER(4)              :: srtDT=19870312,endDT=19870312
 INTEGER(4)              :: srtLT=10000,endLT=20000,stpLT=10000
 INTEGER(4)              :: srtDT=20080320,endDT=20080320
 INTEGER(4), ALLOCATABLE :: LTHURMAT(:),LTMINMAT(:),LTSECMAT(:)
 INTEGER(4), ALLOCATABLE :: DTYYYYMAT(:),DTMMMAT(:),DTDDMAT(:)
 INTEGER(4), ALLOCATABLE :: DTMMDDMAT(:)
 INTEGER(4), ALLOCATABLE :: LTMAT(:),DTMAT(:)

!**************************************************************
!                 MISCELLIOUS VARIABLES
!**************************************************************

 CONTAINS

 SUBROUTINE WHATISTIME(NOWTIME)
  IMPLICIT NONE
 !character(8)  :: date
 !character(10) :: time
 !character(5)  :: zone
  integer       :: values(8)
  INTEGER(4)    :: NOWTIME(*)
  !using keyword arguments
  call date_and_time(VALUES=values)
  NOWTIME(1:3)=values(1:3)
  NOWTIME(4:7)=values(5:8)
 !PRINT*, NOWTIME(1)
 !call date_and_time(date,time,zone,values)
 !call date_and_time(DATE=date,ZONE=zone)
 !call date_and_time(TIME=time)
 !call date_and_time(VALUES=values)
 !print '(a,2x,a,2x,a)', date, time, zone
 !print '(8i5)', values
  RETURN
 END SUBROUTINE WHATISTIME

!********************************************************
!  CHANGE THE CASE OF A STRING TO LOWER AND UPPER CASE
!********************************************************

 FUNCTION to_UpperCase (str)
 !==============================
 !Changes a string to upper case
 !==============================
  IMPLICIT NONE
  Character(*), Intent(In) :: str
  Character(LEN(str))      :: to_UpperCase
  Character(LEN(str))      :: string

  Integer :: ic, i

  Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

 !Capitalize each letter if it is lowecase
  string = str
  do i = 1, LEN_TRIM(str)
   ic = INDEX(low, str(i:i))
   if (ic > 0) string(i:i) = cap(ic:ic)
  end do

  to_UpperCase=trim(string)

  RETURN
 End Function to_UpperCase

 FUNCTION to_LowerCase (str)
 !==============================
 !Changes a string to lower case
 !==============================
  IMPLICIT NONE
  Character(*), Intent(In) :: str
  Character(LEN(str))      :: to_LowerCase
  Character(LEN(str))      :: string

  Integer :: ic, i

  Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

 !Capitalize each letter if it is lowecase
  string = str
  do i = 1, LEN_TRIM(str)
   ic = INDEX(cap, str(i:i))
   if (ic > 0) string(i:i) = low(ic:ic)
  end do

  to_LowerCase=TRIM(string)

  RETURN
 END FUNCTION to_LowerCase

END MODULE SYSINFO


! Bessel J_0(x),J_1(x),Y_0(x),Y_1(x),
!        I_0(x),I_1(x),K_0(x),K_1(x) functions
!        in multiple precision
!
! usage1
!     call bessel01(x,1,eps,j_0,j_1,y_0,y_1)
! usage2
!     call bessel01(x,-1,eps,i_0,i_1,k_0,k_1)
! input parameters
!     x   : argument (x > 0)
!     eps : error requested
!
      program test_bes
        integer, parameter :: dbl = selected_real_kind(p=17)
        real(kind=dbl) :: x, eps, i0, i1, k0, k1

        x = 720.0
        eps = 1d-1
        i0  = 0d0
        i1  = 0d0
        k0  = 0d0
        k1  = 0d0

        call bessel01 ( x, -1, eps, i0, i1, k0, k1 )

        write(*,*) x, eps, i0, i1, k0, k1, dbl

      end program test_bes

      subroutine bessel01(x, l, eps, s, t, u, v)
      implicit real*8 (a - h, o - z)
      pi = 4 * atan(1.0d0)
      euler = 0.577215664901532860606512090082402431042159335939
     &    9235988057672348848677267776646709369470632917467495d0
      prc = -log(eps)
      if (x .lt. prc * 0.6d0) then
          s = eps
          t = 0
          u = 0
          v = 0
          w = 2 / x
          y = 0
          z = euler - log(w)
          if (x .gt. eps) then
              k = int(prc / 15 + ((2 + l) / 6.0d0) * x +
     &            ((prc * prc / 7) * x) ** (1.0d0 / 3))
          else
              k = 1
          end if
          if (l .gt. 0) then
              do n = 2 * k, 2, -2
                  y = s + y
                  u = s / n - u
                  v = t * (n + 1) / (n * (n + 2)) - v
                  t = s * n * w - t
                  s = t * (n - 1) * w - s
              end do
              y = 1 / (2 * y + s)
              s = s * y
              t = t * y
              u = (4 * y * u + s * z) * (2 / pi)
              v = (4 * y * v + t * z - s * w / 2 - t) * (2 / pi)
          else
              do n = 2 * k, 2, -2
                  y = s + y
                  u = s / n + u
                  t = s * n * w + t
                  s = t * (n - 1) * w + s
              end do
              y = cosh(x) / (2 * y + s)
              s = s * y
              t = t * y
              if (x .lt. 1.5d0) then
                  u = 4 * y * u - s * z
              else
                  v = -x / 2
                  w = v
                  u = exp(-x) / 2
                  h = 9.0d0 / (prc + x)
                  y = exp(-h)
                  k = int(log(2 + 2 * prc / x) / h)
                  do n = 1, k
                      v = v / y
                      w = w * y
                      u = u + exp(v + w)
                  end do
                  u = u * h
              end if
              v = (1 / x - t * u) / s
          end if
      else
          w = 1 / (4 * x)
          k = int(prc * 0.12d0)
          do m = -1, 3, 4
              v = sqrt(8 / pi * w)
              y = v
              z = 0
              do n = 2, 8 * k + 6, 4
                  v = v * (w * (m * 1.0d0 / n - n + 2))
                  z = v - z * l
                  v = v * (w * (m * 1.0d0 / (n + 2) - n))
                  y = v - y * l
              end do
              if (m .eq. -1) then
                  t = y
                  u = z
              end if
          end do
          if (l .gt. 0) then
              v = sin(x - pi / 4)
              w = cos(x - pi / 4)
              s = v * u + w * t
              u = v * t - w * u
              t = v * y - w * z
              v = -v * z - w * y
          else
              v = exp(x) / 2
              w = pi / (4 * v)
              s = v * (t - u)
              u = w * (t + u)
              t = v * (y - z)
              v = w * (y + z)
          end if
      end if
      end
!


C     LAST UPDATE 07/05/93
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE TRED2(A,N,NP,D,E)
      IMPLICIT NONE
C
C Purpose: Householder reduction of a real, symmetric, N by N matrix A,
C          stored in an NP by NP physical array. On output, A is
C          replaced by the orthogonal matrix Q effecting the transformation
C          D returns the diagonal elements of the tridiagonal matrix and
C          E the off-diagonal elements, with E(1) = 0.
C
      INTEGER N,NP
      REAL*8 A(NP,NP),D(NP),E(NP)
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL*8 H,SCALE,F,G,HH
      INTEGER I,J,K,L
C
C---------------------------------------------------------------------
      DO 80 I=N,2,-1
         L = I - 1
         H = 0.0
         SCALE = 0.0
         IF(L.GT.1)THEN
            DO 10 K=1,L
               SCALE = SCALE + ABS(A(I,K))
 10         CONTINUE
            IF(SCALE.EQ.0.0)THEN
               E(I) = A(I,L)
            ELSE
               DO 20 K=1,L
                  A(I,K) = A(I,K)/SCALE
                  H = H + A(I,K)**2
 20            CONTINUE
               F = A(I,L)
               G = -SIGN(SQRT(H),F)
               E(I) = SCALE*G
               H = H - F*G
               A(I,L) = F - G
               F = 0.0
               DO 50 J=1,L
                  A(J,I) = A(I,J)/H
                  G = 0.0
                  DO 30 K=1,J
                     G = G + A(J,K)*A(I,K)
 30               CONTINUE
                  DO 40 K=J+1,L
                     G = G + A(K,J)*A(I,K)
 40               CONTINUE
                  E(J) = G/H
                  F = F + E(J)*A(I,J)
 50            CONTINUE
               HH = F/(H+H)
               DO 70 J=1,L
                  F = A(I,J)
                  G = E(J) - HH*F
                  E(J) = G
                  DO 60 K=1,J
                     A(J,K) = A(J,K) - F*E(K) - G*A(I,K)
 60               CONTINUE
 70            CONTINUE
            ENDIF
         ELSE
            E(I) = A(I,L)
         ENDIF
         D(I) = H
 80   CONTINUE
      D(1) = 0.0
      E(1) = 0.0
      DO 130 I=1,N
         L = I - 1
         IF(D(I).NE.0.0)THEN
            DO 110 J=1,L
               G = 0.0
               DO 90 K=1,L
                  G = G + A(I,K)*A(K,J)
 90            CONTINUE
               DO 100 K=1,L
                  A(K,J) = A(K,J) - G*A(K,I)
 100           CONTINUE
 110        CONTINUE
         ENDIF
         D(I) = A(I,I)
         A(I,I) = 1.0
         DO 120 J=1,L
            A(I,J) = 0.0
            A(J,I) = 0.0
 120     CONTINUE
 130  CONTINUE
      RETURN
C
      END


cx      SUBROUTINE  UNIMARF( ZS,N,LAG,ZMEAN,SUM,SD,AIC,DIC,M,AICM,SDM,A,
cx     *                     TMP,IER )
      SUBROUTINE  UNIMARF( ZS,N,LAG,ZMEAN,SUM,SD,AIC,DIC,M,AICM,SDM,A )
C
      INCLUDE 'timsac_f.h'
C
cc      PROGRAM  UNIMAR
C.......................................................................
C.....PLANNED BY H.AKAIKE...............................................
C.....DESIGNED BY H.AKAIKE AND G.KITAGAWA...............................
C.....PROGRAMMED BY G.KITAGAWA AND F.TADA...............................
C.....ADDRESS: THE INSTITUTE OF STATISTICAL MATHEMATICS, 4-6-7 MINAMI-AZ
C..............MINATO-KU, TOKYO 106, JAPAN..............................
C.....DATE OF THE LATEST REVISION:  MAR. 6,1979.........................
C.......................................................................
C.....THIS PROGRAM WAS ORIGINALLY PUBLISHED IN "TIMSAC-78", BY H.AKAIKE,
C.....G.KITAGAWA, E.ARAHATA AND F.TADA, COMPUTER SCIENCE MONOGRAPHS, NO.
C.....THE INSTITUTE OF STATISTICAL MATHEMATICS, TOKYO, 1979.............
C.......................................................................
C     TIMSAC 78.1.1.
C     ___                _                     __
C     UNIVARIATE CASE OF MINIMUM AIC METHOD OF AR MODEL FITTING.
C
C       THIS IS THE BASIC PROGRAM FOR THE FITTING OF AUTOREGRESSIVE MODE
C       OF SUCCESSIVELY HIGHER ORDERS BY THE METHOD OF LEAST SQUARES
C       REALIZED THROUGH HOUSEHOLDER TRANSFORMATION.  THE OUTPUTS ARE
C       THE ESTIMATES OF THE COEFFICIENTS, THE INNOVATION VARIANCES AND
C       CORRESPONDING AIC STATISTICS.  AIC IS DEFINED BY
C
C               AIC  =  N * LOG( SD )  +  2 * ( NUMBER OF PARAMETERS )
C       WHERE
C             N:    DATA LENGTH,
C             SD:   ESTIMATE OF THE INNOVATION VARIANCE.
C
C       ---------------------------------------------------------------
C       REFERENCE:
C          G.KITAGAWA AND H.AKAIKE(1978), "A PROCEDURE FOR THE MODELING
C          OF NON-STATIONARY TIME SERIES.",  ANN. INST. STATIST. MATH.,
C          30,B,351-363.
C       ---------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS PROGRAM:
C             REDATA
C             REDUCT
C             ARMFIT
C       ---------------------------------------------------------------
C       INPUTS REQUIRED:
C             MT:    INPUT DEVICE SPECIFICATION (MT=5 : CARD READER)
C             LAG:   UPPER LIMIT OF AR-ORDER, MUST BE LESS THAN 101
C
C       --  THE FOLLOWING INPUTS ARE REQUESTED BY SUBROUTINE REDATA  --
C
C             TITLE: TITLE OF DATA
C             N:     DATA LENGTH, MUST BE LESS THAN OR EQUAL TO 10000
C             DFORM: INPUT DATA FORMAT SPECIFICATION STATEMENT
C                    -- FOR EXAMPLE --     (8F10.5)
C             (Z(I),I=1,N):  ORIGINAL DATA
C       ---------------------------------------------------------------
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: UNIMARF
C
cxx      IMPLICIT  REAL * 8  ( A-H , O-Z )
CC      REAL * 4   Z(10000) , TITLE(20)
cc      REAL * 4   TITLE(20)
cc      DIMENSION  Z(10000)
cc      DIMENSION  X(200,101) , D(200) , A(100)
cxx      DIMENSION  ZS(N), Z(N)
cxx      DIMENSION  X(N+1,LAG+1), A(LAG)
cxx      DIMENSION  SD(LAG+1), AIC(LAG+1), DIC(LAG+1)
      INTEGER :: N, LAG, M
      REAL(8) :: ZS(N), ZMEAN, SUM, SD(LAG+1), AIC(LAG+1), DIC(LAG+1),
     1           AICM, SDM, A(LAG)
      REAL(8) :: Z(N), X(N+1,LAG+1)
cx      INTEGER*1  TMP(1)
cx      CHARACTER  CNAME*80
C
C        EXTERNAL SUBROUTINE DECLARATION:
C
      EXTERNAL  SETX1
C
cc      CHARACTER(100) IFLNAM,OFLNAM
cc      CALL FLNAM2( IFLNAM,OFLNAM,NFL )
cc      IF ( NFL.EQ.0 ) GO TO 999
cc      IF ( NFL.EQ.2 ) THEN
cc         OPEN( 6,FILE=OFLNAM,ERR=900,IOSTAT=IVAR )
cc      ELSE
cc         CALL SETWND
cc      END IF
cx      IER=0
cx      LU=3
cx      DO 100 I = 1,80
cx         CNAME(I:I) = ' '
cx  100 CONTINUE
cx      I = 1
cx      IFG = 1
cx      DO WHILE( (IFG.EQ.1) .AND. (I.LE.80) )
cx	   IF ( TMP(I).NE.ICHAR(' ') ) THEN
cx            CNAME(I:I) = CHAR(TMP(I))
cx            I = I+1
cx         ELSE
cx            IFG = 0
cx         END IF
cx      END DO
cx      IF ( I.GT.1 ) THEN
cx         IFG = 1
cx         OPEN (LU,FILE=CNAME,IOSTAT=IVAR)
cx         IF (IVAR .NE. 0) THEN
cxcx            WRITE(*,*) ' ***  unimar temp FILE OPEN ERROR :',CNAME,IVAR
cx            IER=IVAR
cx            IFG=0
cx         END IF
cx      END IF
C
C        PARAMETERS:
C             MJ1:  ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C             ISW:  =1   PARAMETERS OF MAICE MODEL ONLY ARE REQUESTED
C                   =2   PARAMETERS OF ALL MODELS ARE REQUESTED
C
cc      MJ1 = 200
      MJ1 = N+1
      ISW = 2
C
CC      READ( 5,1 )     MT
cc      MT = 5
cc      OPEN( MT,FILE=IFLNAM,ERR=910,IOSTAT=IVAR,STATUS='OLD' )
cc      READ( 5,1 )     LAG
cc      WRITE( 6,3 )
cc      WRITE( 6,2 )     LAG
cc      WRITE( 6,4 )     MT
C
C          +-----------------------------------------+                +-
C          ! ORIGINAL DATA LOADING AND MEAN DELETION !                !
C          +-----------------------------------------+                +-
C
cc      CALL  REDATA( Z,N,MT,TITLE )
cc	CLOSE( MT )
      CALL  REDATA( ZS,Z,N,ZMEAN,SUM )
      NMK = N - LAG
      K = LAG
C
C          +-----------------------+                                  +-
C          ! HOUSEHOLDER REDUCTION !                                  !
C          +-----------------------+                                  +-
C
cc      CALL  REDUCT( SETX1,Z,D,NMK,0,K,MJ1,LAG,X )
      CALL  REDUCT( SETX1,Z,NMK,0,K,MJ1,LAG,X )
C
C          +------------------+                                       +-
C          ! AR MODEL FITTING !                                       !
C          +------------------+                                       +-
C
cc      CALL  ARMFIT( X,K,LAG,NMK,ISW,TITLE,MJ1,A,SD,M )
cx      CALL  ARMFIT( X,K,LAG,NMK,ISW,MJ1,A,M,SD,AIC,DIC,SDM,AICM,
cx     *              IFG,LU )
      CALL  ARMFIT( X,K,LAG,NMK,ISW,MJ1,A,M,SD,AIC,DIC,SDM,AICM )
C
cc      GO TO 999
C                                                                      +
cc  900 CONTINUE
cc      WRITE(6,600) IVAR,OFLNAM
cc  600 FORMAT(/,' !!! Output_Data_File OPEN ERROR ',I8,//,5X,100A)
cc      GO TO 999
C                                                                      !
cc  910 CONTINUE
cc      IF ( NFL.EQ.2 ) CLOSE( 6 )
cc#ifdef __linux__
ccC      reopen #6 as stdout
cc      IF ( NFL.EQ.2 ) OPEN(6, FILE='/dev/fd/1')
cc#endif
ccC /* __linux__ */
cc      WRITE(6,610) IVAR,IFLNAM
cc  610 FORMAT(/,' !!! Input_Data_File OPEN ERROR ',I8,//,5X,100A)
C                                                                      +
cc  999 CONTINUE
cx      IF (IFG.NE.0) CLOSE(LU)
      RETURN
C
cxx    1 FORMAT( 16I5 )
cxx    2 FORMAT( 1H ,'FITTING UP TO THE ORDER  K =',I3,'  IS TRIED' )
cxx    3 FORMAT( ' PROGRAM TIMSAC 78.1.1',/'   AUTOREGRESSIVE MODEL FITTING
cxx     1  (SCALAR CASE)  ;   LEAST SQUARES METHOD BY HOUSEHOLDER TRANSFORM
cxx     2ATION',/,'   < AUTOREGRESSIVE MODEL >',/,1H ,10X,'Z(I) = A(1)*Z(I-
cxx     31) + A(2)*Z(I-2) +  ...  + A(M)*Z(I-M) + E(I)',/,'   WHERE',/,11X,
cxx     4'M:     ORDER OF THE MODEL',/,11X,'E(I):  GAUSSIAN WHITE NOISE WIT
cxx     5H MEAN 0  AND  VARIANCE SD(M).' )
cxx    4 FORMAT( 1H ,'ORIGINAL DATA INPUT DEVICE  MT =',I3 )
C
      E N D


      SUBROUTINE svdinv2 (amat, u, vt, w, m)
!
!     Computes PSEUDO-INVERSE of AMAT, Given SVD matrices u,v and
!     weight array w
!
!     MIMICS svdinv, but uses u, vt, w computed from Lapack
!     IT IS ASSUMED THAT THE ORDERED WEIGHT ARRAY w HAS BEEN SET
!     (EXTERNALLY) TO ZERO WHERE THE WEIGHTS ARE TO BE NEGLECTED
!
!
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!C-----------------------------------------------
      INTEGER, INTENT(in)     :: m
      REAL(rprec), DIMENSION(m,m), INTENT(out)   :: amat
      REAL(rprec), DIMENSION(m,m), INTENT(inout) :: u, vt
      REAL(rprec), DIMENSION(m)                  :: w
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(rprec) :: zero = 0
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: i, j
!-----------------------------------------------
      DO i = 1, m
         IF (w(i) .gt. zero) THEN
!divide ith row of Utr by w(i)
            u(:m,i) = u(:m,i)/w(i)
         ELSE
!zero the infinite 1/weights
            u(:m,i) = zero   !1.E-10_dp*u(:m,i)
         END IF
      END DO

!next multiply by V matrix (recall, vt = transpose of V) to get A inverse, store it in A
      DO i = 1, m                               !multiply ith row vector of V by
         DO j = 1, m                            !jth column vector of wU
                                                !vector multiply V and wU
            amat(i,j) = SUM(vt(:m,i)*u(j,:m))   !Put inverse back in A
         END DO
      END DO

      END SUBROUTINE svdinv2


      subroutine cubic (xk0, wp, alph, rad, qplus, qminus)

c     input:  xk0, wp, alph
c     output: rad, qplus, qminus

      implicit double precision (a-h, o-z)
      complex*16 s1,s13
      parameter (three = 3)
      parameter (third = 1/three)

c     this subroutine finds the roots of the equation
c     4xk0 * q^3  +  (alph-4xk0^2) * q^2  +  wp^2 = 0
c     see abramowitz and stegun pg 17 for formulae.

      a2 = (alph / (4*xk0**2)  -  1) * xk0
      a0 = wp**2 / (4*xk0)
      a1 = 0
      q = a1/3 - a2**2/9
      r = (a1*a2 - 3*a0)/6  -  a2**3/27
      rad = q**3 + r**2
      if (rad .gt. 0) then
         qplus = 0
         qminus = 0
         return
      endif

      s13 = dcmplx (r, sqrt(-rad))
      s1 = s13 ** third
      qz1 = 2*s1 - a2/3
c     qz2 = -(s1 + sqrt(three)*dimag(s1) + a2/3)
      qz3 = -(s1 - sqrt(three)*dimag(s1) + a2/3)
      qplus = qz1
      qminus = qz3

      return
      end


	SUBROUTINE enercalc(Nx,Ny,Nz,planfxyz,planbxyz,dt,Es,modescalereal,enkin,enstr,&
				enpot,en,kx,ky,kz,temp1,temp2,v,vold,u,uold)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine program calculates the energy for the nonlinear
	! Klein-Gordon equation in 2 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*|u|^2u
	!
	! The energy density is given by
	! 0.5u_t^2+0.5u_x^2+0.5u_y^2+0.5u_z^2+0.5u^2+Es*0.25u^4
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  planfxyz			= Forward 2d fft plan
	!  planbxyz			= Backward 2d fft plan
	!  dt				= timestep
	!  Es				= +1 for focusing, -1 for defocusing
	!  modescalereal	= Number to scale after backward FFT
	! .. Arrays ..
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  temp1			= array to hold temporary values
	!  temp2			= array to hold temporary values
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!
	! OUTPUT
	!
	! .. Scalars ..
	!  enkin			= Kinetic energy
	!  enstr			= Strain energy
	!  enpot			= Potential energy
	!  en				= Total energy
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  j				= loop counter in y direction
	!  z				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: Nx,Ny,Nz
	REAL(KIND=8), INTENT(IN)							:: dt,Es,modescalereal
	INTEGER(KIND=8), INTENT(IN)							:: planfxyz,planbxyz
	COMPLEX(KIND=8), DIMENSION(1:Nx),INTENT(IN)			:: kx
	COMPLEX(KIND=8), DIMENSION(1:Ny),INTENT(IN)			:: ky
	COMPLEX(KIND=8), DIMENSION(1:Nz),INTENT(IN)			:: kz
	COMPLEX(KIND=8), DIMENSION(1:Nx,1:Ny,1:Nz),INTENT(IN)	:: u,v,uold,vold
	COMPLEX(KIND=8), DIMENSION(1:Nx,1:Ny,1:Nz),INTENT(INOUT)	:: temp1,temp2
	REAL(KIND=8), INTENT(OUT)							:: enkin,enstr
	REAL(KIND=8), INTENT(OUT)							:: enpot,en
	INTEGER(KIND=4)										:: i,j,k

	!.. Strain energy ..
	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=0.5d0*kx(i)*(vold(i,j,k)+v(i,j,k))
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planbxyz,temp1,temp2)
	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=abs(temp2(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planfxyz,temp1,temp2)
	enstr=0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))

	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=0.5d0*ky(j)*(vold(i,j,k)+v(i,j,k))
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planbxyz,temp1,temp2)
	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=abs(temp2(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planfxyz,temp1,temp2)
	enstr=enstr+0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))

	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=0.5d0*kz(k)*(vold(i,j,k)+v(i,j,k))
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planbxyz,temp1,temp2)
	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			temp1(1:Nx,j,k)=abs(temp2(1:Nx,j,k)*modescalereal)**2
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planfxyz,temp1,temp2)
	enstr=enstr+0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))

	! .. Kinetic Energy ..
	!$OMP PARALLEL DO PRIVATE(j,k) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=( abs(u(i,j,k)-uold(i,j,k))/dt )**2
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planfxyz,temp1,temp2)
	enkin=0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))

	! .. Potential Energy ..
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO k=1,Nz
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=0.5d0*(abs((u(i,j,k)+uold(i,j,k))*0.50d0))**2&
					-0.125d0*Es*(abs(u(i,j,k))**4+abs(uold(i,j,k))**4)
			END DO
		END DO
	END DO
	!$OMP END PARALLEL DO
	CALL dfftw_execute_dft_(planfxyz,temp1,temp2)
	enpot=REAL(abs(temp2(1,1,1)),kind(0d0))
	en=enpot+enkin+enstr

	END SUBROUTINE enercalc


!==============================================================================!
  module Const_Mod
!------------------------------------------------------------------------------!
!   Constants definitions for all other modules.                               !
!------------------------------------------------------------------------------!
  implicit none
!==============================================================================!

  !----------------------------------------!
  !   A few handy mathematical constants   !
  !----------------------------------------!
  real,    parameter :: HUGE = 1.e+30
  real,    parameter :: TINY = 1.e-30
  integer, parameter :: HUGE_INT = 9223372036854775807

  ! Big and small numbers in metric system
  real, parameter :: TERA  = 1.e+12
  real, parameter :: GIGA  = 1.e+9
  real, parameter :: MEGA  = 1.e+6
  real, parameter :: MICRO = 1.e-6
  real, parameter :: NANO  = 1.e-9
  real, parameter :: PICO  = 1.e-12

  ! Archimedes’ constant
  real, parameter :: PI = 3.14159265359

  ! These are often used in turbulence models
  real, parameter :: ONE_THIRD  = 0.33333333333333333
  real, parameter :: TWO_THIRDS = 1.0 - ONE_THIRD

  end module


module mod_chkdt
  use mpi
  use mod_common_mpi, only:ierr
  use mod_types
  implicit none
  private
  public chkdt
  contains
  subroutine chkdt(n,dl,dzci,dzfi,visc,u,v,w,dtmax)
    !
    ! computes maximum allowed timestep
    !
    implicit none
    integer , intent(in), dimension(3) :: n
    real(rp), intent(in), dimension(3) :: dl
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), intent(in) :: visc
    real(rp), intent(in), dimension(0:,0:,0:) :: u,v,w
    real(rp), intent(out) :: dtmax
    real(rp) :: dxi,dyi,dzi
    real(rp) :: ux,uy,uz,vx,vy,vz,wx,wy,wz
    real(rp) :: dtix,dtiy,dtiz,dti,dlmin
    integer :: i,j,k,im,ip,jm,jp,km,kp
    !
    dti = 0.
    dxi = 1./dl(1)
    dyi = 1./dl(2)
    dzi = 1./dl(3)
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(n,u,v,w,dxi,dyi,dzi,dzci,dzfi) &
    !$OMP PRIVATE(i,j,k,im,jm,km,ip,jp,kp) &
    !$OMP PRIVATE(ux,uy,uz,vx,vy,vz,wx,wy,wz,dtix,dtiy,dtiz) &
    !$OMP REDUCTION(max:dti)
    do k=1,n(3)
      kp = k + 1
      km = k - 1
      do j=1,n(2)
        jp = j + 1
        jm = j - 1
        do i=1,n(1)
          ip = i + 1
          im = i - 1
          ux = abs(u(i,j,k))
          vx = 0.25*abs( v(i,j,k)+v(i,jm,k)+v(ip,j,k)+v(ip,jm,k) )
          wx = 0.25*abs( w(i,j,k)+w(i,j,km)+w(ip,j,k)+w(ip,j,km) )
          dtix = ux*dxi+vx*dyi+wx*dzfi(k)
          uy = 0.25*abs( u(i,j,k)+u(i,jp,k)+u(im,jp,k)+u(im,j,k) )
          vy = abs(v(i,j,k))
          wy = 0.25*abs( w(i,j,k)+w(i,jp,k)+w(i,jp,km)+w(i,j,km) )
          dtiy = uy*dxi+vy*dyi+wy*dzfi(k)
          uz = 0.25*abs( u(i,j,k)+u(im,j,k)+u(im,j,kp)+u(i,j,kp) )
          vz = 0.25*abs( v(i,j,k)+v(i,jm,k)+v(i,jm,kp)+v(i,j,kp) )
          wz = abs(w(i,j,k))
          dtiz = uz*dxi+vz*dyi+wz*dzci(k)
          dti = max(dti,dtix,dtiy,dtiz)
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
    call mpi_allreduce(MPI_IN_PLACE,dti,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
    if(dti.eq.0.) dti = 1.
    dlmin     = minval(dl)
    dlmin     = min(dlmin,minval(1./dzfi)) ! minimum of dzf is an estimate on the safe side
#ifdef IMPDIFF
    dtmax = sqrt(3.)/dti
#else
    dtmax = min(1.65/12./visc*dlmin**2,sqrt(3.)/dti)
#endif
    return
  end subroutine chkdt
end module mod_chkdt


    SUBROUTINE SGEES_F95( A, WR, WI, VS, SELECT, SDIM, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: GEES_F77 => LA_GEES
!  USE LA_EXTERNAL, ONLY: SELECT
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
   INTERFACE
      LOGICAL FUNCTION SELECT(WR, WI)
         USE LA_PRECISION, ONLY: WP => SP
         REAL(WP), INTENT(IN) :: WR, WI
      END FUNCTION SELECT
   END INTERFACE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO, SDIM
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:)
   REAL(WP), INTENT(OUT) :: WR(:), WI(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: VS(:,:)
!  .. EXTERNAL ARGUMENTS ..
   OPTIONAL :: SELECT
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!      LA_GEES computes for a real/complex square matrix A, the
! eigenvalues, the real-Schur/complex-Schur form T , and, optionally, the
! matrix of Schur vectors Z, where Z is orthogonal/unitary. This gives the
! Schur factorization
!                        A = Z*T*Z^H.
! Optionally, it also orders the eigenvalues on the diagonal of the Schur
! form so that selected eigenvalues are at the top left. The leading
! columns of Z then form an orthonormal basis for the invariant subspace
! corresponding to the selected eigenvalues.
!      A real matrix is in real-Schur form if it is block upper triangular
! with 1 by 1 and 2 by 2 blocks along the main diagonal. 2 by 2 blocks are
! standardized in the form
!                       [ a  b ]
! 		        [ c  a ]
! where b*c < 0. The eigenvalues of such a block are a +/- Sqrt(b*c).
! A complex matrix is in complex-Schur form if it is upper triangular.
!
! =========
!
!        SUBROUTINE LA_GEES( A, <w>, VS=vs, SELECT=select, &
!                                   SDIM=sdim, INFO=info )
!           <type>(<wp>), INTENT(INOUT) :: A(:,:)
!           <type>(<wp>), INTENT(OUT) :: <w(:)>
!           <type>(<wp>), INTENT(OUT), OPTIONAL :: VS(:,:)
!           INTERFACE
!               LOGICAL FUNCTION SELECT(<w(j)>)
!                  <type>(<wp>), INTENT(IN) :: <w(j)>
!               END FUNCTION SELECT
!           END INTERFACE
!           OPTIONAL :: SELECT
!           INTEGER, INTENT(OUT), OPTIONAL :: SDIM, INFO
!        where
!           <type> ::= REAL | COMPLEX
!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
!           <w>    ::= WR, WI | W
!           <w(:)> ::= WR(:), WI(:) | W(:)
!           <w(j)> ::= WR(j) , WI(j) |  W(j)
!
! Arguments
! =========
!
! A        (input/output) REAL or COMPLEX square array, shape (:,:).
!          On entry, the matrix A.
!          On exit, the Schur form T.
! <w>      (output) REAL or COMPLEX array, shape (:) with size(w) =
!          size(A,1).
!          The computed eigenvalues in the order in which they appear on
!          the diagonal of the Schur form T.
!          <w(:)> ::= WR(:), WI(:) | W(:),
!          where
!          WR(:), WI(:) are of REAL type (for the real and imaginary
! 	   parts) and W(:) is of COMPLEX type.
!          Note: If A is real, then a complex-conjugate pair appear
!          consecutively, with the eigenvalue having the positive
! 	   imaginary part appearing first.
! VS       Optional (output) REAL or COMPLEX square array, shape (:,:)
!          with size(VS,1) = size(A,1).
!          The matrix Z of Schur vectors.
! SELECT   Optional (input) LOGICAL FUNCTION.
!          LOGICAL FUNCTION SELECT( <w(j)> )
!            <type>(<wp>), INTENT(IN) :: <w(j)>
!          where
!            <type> ::= REAL | COMPLEX
!            <wp>   ::= KIND(1.0) | KIND(1.0D0)
!            <w(j)> ::= WR(j) , WI(j) | W(j)
!          1. SELECT must be declared as EXTERNAL or as an explicit
!             interface in the calling (sub)program.
!          2. SELECT is called by LA_GEES for every computed eigenvalue
! 	    w(j) (but only once for a complex conjugate pair when A is
! 	    real). It is used to select the eigenvalues that will be
!             ordered to the top left of the Schur form. The eigenvalue
! 	    w(j) is selected if SELECT(w(j)) has the value .TRUE.
!          3. A selected complex eigenvalue may no longer satisfy
! 	    SELECT(w(j)) = .TRUE. after ordering, since ordering may
! 	    change the value of complex eigenvalues (especially if the
! 	    eigenvalue is ill-conditioned). In this case INFO is set to
! 	    size(A,1) + 2 (see INFO below).
!          Note: Select must be present if SDIM is desired.
! SDIM     Optional (output) INTEGER.
!          The number of eigenvalues (after sorting) for which
! 	   SELECT=.TRUE. (If A is real, complex conjugate pairs for which
! 	   SELECT=.TRUE. for either eigenvalue count as 2).
! INFO     Optional (output) INTEGER.
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, and i is
!              <= n: the QR algorithm failed to compute all the
!                    eigenvalues; elements 1:ilo-1 and i+1:n of w contain
!                    those eigenvalues which have converged. VS contains
!                    the matrix which reduces A to its partially converged
!                    Schur form.
!              = n+1: the eigenvalues could not be reordered because some
!                    eigenvalues were not sufficiently separated (the
! 		   problem is very ill-conditioned).
!              = n+2: after reordering, some leading complex eigenvalues
! 	           in the Schur form no longer satisfy SELECT = .TRUE.
!                    This can be caused by ordinary roundoff or underflow
!                    due to scaling.
!              n is the order of A.
!          If INFO is not present and an error occurs, then the program is
!          terminated with an error message.
!-------------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GEES'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBVS, LSORT
   INTEGER, SAVE :: LWORK = 0
   INTEGER :: N, LINFO, LD, ISTAT, ISTAT1, S1VS, S2VS, LSDIM
!  .. LOCAL ARRAYS ..
   LOGICAL, TARGET :: LLBWORK(1)
   LOGICAL, POINTER :: BWORK(:)
   REAL(WP), TARGET :: LLVS(1,1)
   REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LSDIM = 0
   LINFO = 0; ISTAT = 0; N = SIZE(A,1); LD = MAX(1,N)
   IF( PRESENT(VS) )THEN; S1VS = SIZE(VS,1); S2VS = SIZE(VS,2); LJOBVS = 'V'
   ELSE; S1VS = 1; S2VS = 1; LJOBVS = 'N'; END IF
   IF( PRESENT(SDIM) .OR. PRESENT(SELECT) )THEN; LSORT = 'S'; ELSE; LSORT = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 .OR. SIZE(A,2) /= N )THEN; LINFO = -1
   ELSE IF( SIZE( WR ) /= N )THEN; LINFO = -2
   ELSE IF( SIZE( WI ) /= N )THEN; LINFO = -3
   ELSE IF( PRESENT(VS) .AND. ( S1VS /= N .OR. S2VS /= N ) )THEN; LINFO = -4
   ELSE IF( PRESENT(SDIM) .AND. .NOT.PRESENT(SELECT) )THEN; LINFO = -5
   ELSE IF( N > 0 )THEN
      IF( ISTAT == 0 ) THEN
         LWORK = MAX( 1, 3*N, LWORK); ALLOCATE(WORK(LWORK), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN; DEALLOCATE(WORK,STAT=ISTAT1)
            LWORK = MAX( 1, 3*N ); ALLOCATE(WORK(LWORK), STAT=ISTAT)
            IF( ISTAT == 0) CALL ERINFO( -200, SRNAME, LINFO )
         END IF
      END IF
      IF( ISTAT == 0 ) THEN
        IF( PRESENT(VS) )THEN
          IF( PRESENT(SDIM) )THEN
	     ALLOCATE(BWORK(N),STAT=ISTAT)
             CALL GEES_F77( LJOBVS, LSORT, SELECT, N, A, LD, LSDIM, WR, WI, &
                        VS, S1VS, WORK, LWORK, BWORK, LINFO )
	    ELSE
	     CALL GEES_F77( LJOBVS, LSORT, SELECT, N, A, LD, LSDIM, WR, WI, &
                        VS, S1VS, WORK, LWORK, LLBWORK, LINFO )
	    ENDIF
	  ELSE
	   IF( PRESENT(SDIM) )THEN
	      ALLOCATE(BWORK(N),STAT=ISTAT)
	      CALL GEES_F77( LJOBVS, LSORT, SELECT, N, A, LD, LSDIM, WR, WI, &
                        LLVS, S1VS, WORK, LWORK, BWORK, LINFO )
	   ELSE
	      CALL GEES_F77( LJOBVS, LSORT, SELECT, N, A, LD, LSDIM, WR, WI, &
                        LLVS, S1VS, WORK, LWORK, LLBWORK, LINFO )
	  ENDIF
	 ENDIF
         IF( LINFO == 0 ) LWORK = INT(WORK(1)+1)
      ELSE; LINFO = -100; ENDIF
!      IF( PRESENT(SDIM) ) SDIM = LSDIM
      IF( LSAME(LSORT,'S') ) DEALLOCATE(BWORK, STAT=ISTAT1)
      DEALLOCATE(WORK, STAT=ISTAT1)
   ENDIF
   IF( PRESENT(SDIM) ) SDIM = LSDIM
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SGEES_F95


SUBROUTINE PHOTSATRAT(nz, T, P, den, Jtrop, H2Osat, H2O)
  use photochem_data, only: relative_humidity, use_manabe

  implicit none

  ! local variables
  integer, intent(in) :: nz
  real(8), intent(in) :: T(nz), P(nz), den(nz)
  integer, intent(in) :: jtrop

  real(8), dimension(nz), intent(out) :: H2Osat
  real*8, dimension(nz) ,intent(out) :: H2O ! H2O mixing ratio!

  real*8 t0, pzero, amv, vapl, subl, r, a0, bk, ps
  integer j
  real*8 hl(nz) , a(nz)
  real*8 p1, p2, pv, rel

  !   THIS SUBROUTINE CALCULATES THE SATURATION VAPOR PRESSURE OF WATER
  !   FROM MAGNUS' EQUATION (SEE RUNAWAY GREENHOUSE PAPER IN ICARUS -
  !   APPENDIX A).  IT THEN FIXES TROPOSPHERIC H2O USING A MANABE/
  !   WETHERALD RELATIVE HUMIDITY DISTRIBUTION.

  rel = 0.d0
  t0 = 273.15
  pzero = 6.103E-3          !vapor pressure at T0 I assume
  amv = 18.
  vapl = 597.3
  subl = 677.
  r = 1.9872
  a0 = 0.553
  bk = 1.38E-16
  ps = 1.E-6*DEN(1)*bk*T(1)      !this is actually a good measure of pressure
  !
  DO j = 1 , nz
    hl(j) = subl
    a(j) = 0.
    IF ( T(j).GE.t0 ) THEN
      hl(j) = vapl + a0*t0
      a(j) = a0
    ENDIF
  ENDDO
  !
  !   FIND SATURATION VAPOR PRESSURE
  DO j = 1 , nz
    p1 = pzero*(t0/T(j))**(amv*a(j)/r)
    p2 = EXP(amv*hl(j)/r*(1./t0-1./T(j)))
    pv = p1*p2
    ! P(j) = 1.E-6*DEN(j)*bk*T(j)   ! bars !already defined
    H2OSAT(j) = pv/P(j)
  ENDDO
  !   CALCULATE TROPOSPHERIC H2O CONCENTRATIONS
  do j = 1 , Jtrop
    if (use_manabe) then
      rel = 0.77*(P(j)/ps-0.02)/0.98  !manabe formula
    else
      ! for mars, rel = 0.17
      rel = relative_humidity
    endif
    H2o(j) = rel*H2OSAT(j)
  enddo

end subroutine


      double complex function qlLi2omprod(v,w,z,iep)
      implicit none
      include 'qlconstants.f'
c     expression for dilog(1-(v-i*ep)/(w-i*ep)*(z+iep))
C     for real v,w and complex z
      double precision v,w,y,ddilog,rarg,omrarg,iep
      double complex qllnrat,lnarg,lnomarg,prod,arg,omarg,z,cln,
     . denspence
      if (abs(dimag(z)) .lt. 1d-15) then
C----case for real z
      y=dreal(z)
      rarg=v*y/w
      omrarg=1d0-rarg
      if (rarg .le. 1d0) then
         if (rarg .eq. 0d0 .or. rarg .eq. 1d0) then
            prod=0d0
         else
            lnarg=qllnrat(v,w)+cln(z,iep)
            lnomarg=dcmplx(log(omrarg))
            prod=lnarg*lnomarg
         endif
         qlLi2omprod=dcmplx(pisqo6-ddilog(rarg))-prod
      elseif (rarg .gt. 1d0) then
         rarg=w/(y*v)
         lnarg=-qllnrat(v,w)-cln(z,iep)
         lnomarg=dcmplx(log(1d0-rarg))
         qlLi2omprod=-dcmplx(pisqo6-ddilog(rarg))+lnarg*lnomarg
     .   -0.5d0*lnarg**2
      endif
      else
C----case for complex z
      arg=dcmplx(v/w)*z
      omarg=cone-arg
      if (abs(arg) .le. 1d0) then
         if (abs(arg) .eq. 0d0 .or. abs(arg) .eq. 1d0) then
            prod=0d0
         else
            lnarg=qllnrat(v,w)+cln(z,iep)
            lnomarg=log(omarg)
            prod=lnarg*lnomarg
         endif
         qlLi2omprod=dcmplx(pisqo6)-denspence(arg,1d0)-prod
      elseif (abs(arg) .gt. 1d0) then
         arg=w/(z*v)
         lnarg=-qllnrat(v,w)-cln(z,iep)
         lnomarg=log(cone-arg)
         qlLi2omprod=-dcmplx(pisqo6)+denspence(arg,1d0)+lnarg*lnomarg
     .   -0.5d0*lnarg**2
      endif

      endif
      return
      end


      program intrinsic77
c
c  Test Fortran 77 intrinsic functions (ANSI X3.9-1978 Section 15.10)
c
c  Test:
c  *  specific functions
c  *  generic functions with each argument type
c  *  specific functions by passing as subroutine argument
c     where permiited by Section 13.12 of Fortran 90 standard
c
      logical fail
      common /flags/ fail

      fail = .false.
      call type_conversion
      call truncation
      call nearest_whole_number
      call nearest_integer
      call absolute_value
      call remaindering
      call transfer_of_sign
      call positive_difference
      call double_precision_product
      call choosing_largest_value
      call choosing_smallest_value
      call length_of_character_array
      call index_of_substring
      call imaginary_part
      call complex_conjugate
      call square_root
      call exponential
      call natural_logarithm
      call common_logarithm
      call sine
      call cosine
      call tangent
      call arcsine
      call arccosine
      call arctangent
      call hyperbolic_sine
      call hyperbolic_cosine
      call hyperbolic_tangent
      call lexically_greater_than_or_equal
      call lexically_greater_than
      call lexically_less_than_or_equal
      call lexically_less_than

      if ( fail ) call abort()
      end

      subroutine failure(label)
c     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end

      subroutine c_i(i,j,label)
c     Check if INTEGER i equals j, and fail otherwise
      integer i,j
      character*(*) label
      if ( i .ne. j ) then
         call failure(label)
         write(6,*) 'Got ',i,' expected ', j
      end if
      end

      subroutine c_r(a,b,label)
c     Check if REAL a equals b, and fail otherwise
      real a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_d(a,b,label)
c     Check if DOUBLE PRECISION a equals b, and fail otherwise
      double precision a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0d-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_c(a,b,label)
c     Check if COMPLEX a equals b, and fail otherwise
      complex a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_l(a,b,label)
c     Check if LOGICAL a equals b, and fail otherwise
      logical a, b
      character*(*) label
      if ( a .neqv. b ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_ch(a,b,label)
c     Check if CHARACTER a equals b, and fail otherwise
      character*(*) a, b
      character*(*) label
      if ( a .ne. b ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine p_i_i(f,x,i,label)
c     Check if INTEGER f(x) equals i for INTEGER x
      integer f,x,i
      character*(*) label
      call c_i(f(x),i,label)
      end

      subroutine p_i_ii(f,x1,x2,i,label)
c     Check if INTEGER f(x1,x2) equals i for INTEGER x
      integer f,x1,x2,i
      character*(*) label
      call c_i(f(x1,x2),i,label)
      end

      subroutine p_i_r(f,x,i,label)
c     Check if INTEGER f(x) equals i for REAL x
      real x
      integer f,i
      character*(*) label
      call c_i(f(x),i,label)
      end

      subroutine p_i_d(f,x,i,label)
c     Check if INTEGER f(x) equals i for DOUBLE PRECISION x
      double precision x
      integer f,i
      character*(*) label
      call c_i(f(x),i,label)
      end

      subroutine p_i_ch(f,x,a,label)
c     Check if INTEGER f(x) equals a for CHARACTER x
      character*(*) x
      integer f, a
      character*(*) label
      call c_i(f(x),a,label)
      end

      subroutine p_i_chch(f,x1,x2,a,label)
c     Check if INTEGER f(x1,x2) equals a for CHARACTER x1 and x2
      character*(*) x1,x2
      integer f, a
      character*(*) label
      call c_i(f(x1,x2),a,label)
      end

      subroutine p_r_r(f,x,a,label)
c     Check if REAL f(x) equals a for REAL x
      real f,x,a
      character*(*) label
      call c_r(f(x),a,label)
      end

      subroutine p_r_rr(f,x1,x2,a,label)
c     Check if REAL f(x1,x2) equals a for REAL x1, x2
      real f,x1,x2,a
      character*(*) label
      call c_r(f(x1,x2),a,label)
      end

      subroutine p_d_d(f,x,a,label)
c     Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
      double precision f,x,a
      character*(*) label
      call c_d(f(x),a,label)
      end

      subroutine p_d_rr(f,x1,x2,a,label)
c     Check if DOUBLE PRECISION f(x1,x2) equals a for real x1,x2
      double precision f,a
      real x1,x2
      character*(*) label
      call c_d(f(x1,x2),a,label)
      end

      subroutine p_d_dd(f,x1,x2,a,label)
c     Check if DOUBLE PRECISION f(x1,x2) equals a for DOUBLE PRECISION x1,x2
      double precision f,x1,x2,a
      character*(*) label
      call c_d(f(x1,x2),a,label)
      end

      subroutine p_c_c(f,x,a,label)
c     Check if COMPLEX f(x) equals a for COMPLEX x
      complex f,x,a
      character*(*) label
      call c_c(f(x),a,label)
      end

      subroutine p_r_c(f,x,a,label)
c     Check if REAL f(x) equals a for COMPLEX x
      complex x
      real f, a
      character*(*) label
      call c_r(f(x),a,label)
      end

      subroutine type_conversion
      integer i
      character*1 c
c     conversion to integer
      call c_i(INT(5),5,'INT(integer)')
      call c_i(INT(5.01),5,'INT(real)')
      call c_i(INT(5.01d0),5,'INT(double)')
      call c_i(INT((5.01,-3.0)),5,'INT(complex)')
      call c_i(IFIX(5.01),5,'IFIX(real)')
      call c_i(IDINT(5.01d0),5,'IDINT(double)')
c     conversion to real
      call c_r(REAL(-2),-2.0,'REAL(integer)')
      call c_r(REAL(-2.0),-2.0,'REAL(real)')
      call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
      call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
      call c_r(FLOAT(-2),-2.0,'FLOAT(int)')
      call c_r(SNGL(-2.0d0),-2.0,'SNGL(double)')
c     conversion to double
      call c_d(DBLE(5),5.0d0,'DBLE(integer)')
      call c_d(DBLE(5.),5.0d0,'DBLE(real)')
      call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
      call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
c     conversion to complex
      call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
      call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
      call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
      call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(real,real)')
      call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
      call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
      call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
c     character conversion
      c = 'C'
      i = ichar(c)
      call c_i(ICHAR(c),i,'ICHAR')
      call c_ch(CHAR(i),c,'CHAR')
      end

      subroutine truncation
      intrinsic aint, dint
      call c_r(AINT(9.2),9.0,'AINT(real)')
      call c_d(AINT(9.2d0),9.0d0,'AINT(double)')
      call c_d(DINT(9.2d0),9.0d0,'DINT(double)')
      call p_r_r(AINT,9.2,9.0,'AINT')
      call p_d_d(DINT,9.2d0,9.0d0,'DINT')
      end

      subroutine nearest_whole_number
      intrinsic anint, dnint
      call c_r(ANINT(9.2),9.0,'ANINT(real)')
      call c_d(ANINT(9.2d0),9.0d0,'ANINT(double)')
      call c_d(DNINT(9.2d0),9.0d0,'DNINT(double)')
      call p_r_r(ANINT,9.2,9.0,'ANINT')
      call p_d_d(DNINT,9.2d0,9.0d0,'DNINT')
      end

      subroutine nearest_integer
      intrinsic nint, idnint
      call c_i(NINT(9.2),9,'NINT(real)')
      call c_i(NINT(9.2d0),9,'NINT(double)')
      call c_i(IDNINT(9.2d0),9,'IDNINT(double)')
      call p_i_r(NINT,9.2,9,'NINT')
      call p_i_d(IDNINT,9.2d0,9,'IDNINT')
      end

      subroutine absolute_value
      intrinsic iabs, abs, dabs, cabs
      call c_i(ABS(-7),7,'ABS(integer)')
      call c_r(ABS(-7.),7.,'ABS(real)')
      call c_d(ABS(-7.d0),7.d0,'ABS(double)')
      call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
      call c_i(IABS(-7),7,'IABS(integer)')
      call c_d( DABS(-7.d0),7.d0,'DABS(double)')
      call c_r( CABS((3.,-4.)),5.0,'CABS(complex)')
      call p_i_i(IABS,-7,7,'IABS')
      call p_r_r(ABS,-7.,7.,'ABS')
      call p_d_d(DABS,-7.0d0,7.0d0,'DABS')
      call p_r_c(CABS,(3.,-4.), 5.0,'CABS')
      end

      subroutine remaindering
      intrinsic mod, amod, dmod
      call c_i( MOD(8,3),2,'MOD(integer,integer)')
      call c_r( MOD(8.,3.),2.,'MOD(real,real)')
      call c_d( MOD(8.d0,3.d0),2.d0,'MOD(double,double)')
      call c_r( AMOD(8.,3.),2.,'AMOD(real,real)')
      call c_d( DMOD(8.d0,3.d0),2.d0,'DMOD(double,double)')
      call p_i_ii(MOD,8,3,2,'MOD')
      call p_r_rr(AMOD,8.,3.,2.,'AMOD')
      call p_d_dd(DMOD,8.d0,3.d0,2.d0,'DMOD')
      end

      subroutine transfer_of_sign
      intrinsic isign,sign,dsign
      call c_i(SIGN(8,-3),-8,'SIGN(integer)')
      call c_r(SIGN(8.,-3.),-8.,'SIGN(real,real)')
      call c_d(SIGN(8.d0,-3.d0),-8.d0,'SIGN(double,double)')
      call c_i(ISIGN(8,-3),-8,'ISIGN(integer)')
      call c_d(DSIGN(8.d0,-3.d0),-8.d0,'DSIGN(double,double)')
      call p_i_ii(ISIGN,8,-3,-8,'ISIGN')
      call p_r_rr(SIGN,8.,-3.,-8.,'SIGN')
      call p_d_dd(DSIGN,8.d0,-3.d0,-8.d0,'DSIGN')
      end

      subroutine positive_difference
      intrinsic idim, dim, ddim
      call c_i(DIM(-8,-3),0,'DIM(integer)')
      call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
      call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
      call c_i(IDIM(-8,-3),0,'IDIM(integer)')
      call c_d(DDIM(-8.d0,-3.d0),0.d0,'DDIM(double,double)')
      call p_i_ii(IDIM,-8,-3,0,'IDIM')
      call p_r_rr(DIM,-8.,-3.,0.,'DIM')
      call p_d_dd(DDIM,-8.d0,-3.d0,0.d0,'DDIM')
      end

      subroutine double_precision_product
      intrinsic dprod
      call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
      call p_d_rr(DPROD,-8.,-3.,24.d0,'DPROD')
      end

      subroutine choosing_largest_value
      call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
      call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
      call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
      call c_i(MAX0(1,2,3),3,'MAX0(integer,integer,integer)')
      call c_r(AMAX1(1.,2.,3.),3.,'MAX(real,real,real)')
      call c_d(DMAX1(1.d0,2.d0,3.d0),3.d0,'DMAX1(double,double,double)')
      call c_r(AMAX0(1,2,3),3.,'AMAX0(integer,integer,integer)')
      call c_i(MAX1(1.,2.,3.),3,'MAX1(real,real,real)')
      end

      subroutine choosing_smallest_value
      call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
      call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
      call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
      call c_i(MIN0(1,2,3),1,'MIN0(integer,integer,integer)')
      call c_r(AMIN1(1.,2.,3.),1.,'MIN(real,real,real)')
      call c_d(DMIN1(1.d0,2.d0,3.d0),1.d0,'DMIN1(double,double,double)')
      call c_r(AMIN0(1,2,3),1.,'AMIN0(integer,integer,integer)')
      call c_i(MIN1(1.,2.,3.),1,'MIN1(real,real,real)')
      end

      subroutine length_of_character_array
      intrinsic len
      call c_i(LEN('ABCDEF'),6,'LEN 1')
      call p_i_ch(LEN,'ABCDEF',6,'LEN 2')
      end

      subroutine index_of_substring
      intrinsic index
      call c_i(INDEX('ABCDEF','C'),3,'INDEX 1')
      call p_i_chch(INDEX,'ABCDEF','C',3,'INDEX 2')
      end

      subroutine imaginary_part
      intrinsic aimag
      call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
      call p_r_c(AIMAG,(2.,-7.),-7.,'AIMAG(complex)')
      end

      subroutine complex_conjugate
      intrinsic conjg
      call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
      call p_c_c(CONJG,(2.,-7.),(2.,7.),'CONJG')
      end

      subroutine square_root
      intrinsic sqrt, dsqrt, csqrt
      real x, a
      x = 4.0
      a = 2.0
      call c_r(SQRT(x),a,'SQRT(real)')
      call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
      call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
      call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
      call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
      call p_r_r(SQRT,x,a,'SQRT')
      call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
      call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
      end

      subroutine exponential
      intrinsic exp, dexp, cexp
      real x, a
      x = 0.0
      a = 1.0
      call c_r(EXP(x),a,'EXP(real)')
      call c_d(EXP(1.d0*x),1.d0*a,'EXP(double)')
      call c_c(EXP((1.,0.)*x),(1.,0.)*a,'EXP(complex)')
      call c_d(DEXP(1.d0*x),1.d0*a,'DEXP(double)')
      call c_c(CEXP((1.,0.)*x),(1.,0.)*a,'CEXP(complex)')
      call p_r_r(EXP,x,a,'EXP')
      call p_d_d(DEXP,1.d0*x,1.d0*a,'DEXP')
      call p_c_c(CEXP,(1.,0.)*x,(1.,0.)*a ,'CEXP')
      end

      subroutine natural_logarithm
      intrinsic alog, dlog, clog
      real x, a
      a = 1.234
      x = exp(a)
      call c_r(LOG(x),a,'LOG(real)')
      call c_d(LOG(1.d0*x),1.d0*a,'LOG(double)')
      call c_c(LOG((1.,0.)*x),(1.,0.)*a,'LOG(complex)')
      call c_r(ALOG(x),a,'ALOG(real)')
      call c_d(DLOG(1.d0*x),1.d0*a,'DLOG(double)')
      call c_c(CLOG((1.,0.)*x),(1.,0.)*a,'CLOG(complex)')
      call p_r_r(ALOG,x,a,'LOG')
      call p_d_d(DLOG,1.d0*x,1.d0*a,'DLOG')
      call p_c_c(CLOG,(1.,0.)*x,(1.,0.)*a,'CLOG')
      end

      subroutine common_logarithm
      intrinsic alog10, dlog10
      real x, a
      x = 100.0
      a = 2.0
      call c_r(LOG10(x),a,'LOG10(real)')
      call c_d(LOG10(1.d0*x),1.d0*a,'LOG10(double)')
      call c_r(ALOG10(x),a,'ALOG10(real)')
      call c_d(DLOG10(1.d0*x),1.d0*a,'DLOG10(double)')
      call p_r_r(ALOG10,x,a,'ALOG10')
      call p_d_d(DLOG10,1.d0*x,1.d0*a ,'DLOG10')
      end

      subroutine sine
      intrinsic sin, dsin, csin
      real x, a
      a = 1.0
      x = asin(a)
      call c_r(SIN(x),a,'SIN(real)')
      call c_d(SIN(1.d0*x),1.d0*a,'SIN(double)')
      call c_c(SIN((1.,0.)*x),(1.,0.)*a,'SIN(complex)')
      call c_d(DSIN(1.d0*x),1.d0*a,'DSIN(double)')
      call c_c(CSIN((1.,0.)*x),(1.,0.)*a,'CSIN(complex)')
      call p_r_r(SIN,x,a,'SIN')
      call p_d_d(DSIN,1.d0*x,1.d0*a,'DSIN')
      call p_c_c(CSIN,(1.,0.)*x,(1.,0.)*a ,'CSIN')
      end

      subroutine cosine
      intrinsic cos, dcos, ccos
      real x, a
      a = 0.123456
      x = acos(a)
      call c_r(COS(x),a,'COS(real)')
      call c_d(COS(1.d0*x),1.d0*a,'COS(double)')
      call c_c(COS((1.,0.)*x),(1.,0.)*a,'COS(complex)')
      call c_r(COS(x),a,'COS(real)')
      call c_d(DCOS(1.d0*x),1.d0*a,'DCOS(double)')
      call c_c(CCOS((1.,0.)*x),(1.,0.)*a,'CCOS(complex)')
      call p_r_r(COS,x,a,'COS')
      call p_d_d(DCOS,1.d0*x,1.d0*a ,'DCOS')
      call p_c_c(CCOS,(1.,0.)*x, (1.,0.)*a ,'CCOS')
      end

      subroutine tangent
      intrinsic tan, dtan
      real x, a
      a = 0.5
      x = atan(a)
      call c_r(TAN(x),a,'TAN(real)')
      call c_d(TAN(1.d0*x),1.d0*a,'TAN(double)')
      call c_d(DTAN(1.d0*x),1.d0*a,'DTAN(double)')
      call p_r_r(TAN,x,a,'TAN')
      call p_d_d(DTAN,1.d0*x,1.d0*a ,'DTAN')
      end

      subroutine arcsine
      intrinsic asin, dasin
      real x, a
      a = 0.5
      x = sin(a)
      call c_r(ASIN(x),a,'ASIN(real)')
      call c_d(ASIN(1.d0*x),1.d0*a,'ASIN(double)')
      call c_d(DASIN(1.d0*x),1.d0*a,'DASIN(double)')
      call p_r_r(ASIN,x,a,'ASIN')
      call p_d_d(DASIN,1.d0*x,1.d0*a ,'DASIN')
      end

      subroutine arccosine
      intrinsic acos, dacos
      real x, a
      x = 0.70710678
      a = 0.785398
      call c_r(ACOS(x),a,'ACOS(real)')
      call c_d(ACOS(1.d0*x),1.d0*a,'ACOS(double)')
      call c_d(DACOS(1.d0*x),1.d0*a,'DACOS(double)')
      call p_r_r(ACOS,x,a,'ACOS')
      call p_d_d(DACOS,1.d0*x,1.d0*a ,'DACOS')
      end

      subroutine arctangent
      intrinsic atan, atan2, datan, datan2
      real x1, x2, a
      a = 0.75
      x1 = tan(a)
      x2 = 1.0
      call c_r(ATAN(x1),a,'ATAN(real)')
      call c_d(ATAN(1.d0*x1),1.d0*a,'ATAN(double)')
      call c_d(DATAN(1.d0*x1),1.d0*a,'DATAN(double)')
      call c_r(ATAN2(x1,x2),a,'ATAN2(real)')
      call c_d(ATAN2(1.d0*x1,1.d0*x2),1.d0*a,'ATAN2(double)')
      call c_d(DATAN2(1.d0*x1,1.d0*x2),1.0d0*a,'DATAN2(double)')
      call p_r_r(ATAN,x1,a,'ATAN')
      call p_d_d(DATAN,1.d0*x1,1.d0*a,'DATAN')
      call p_r_rr(ATAN2,x1,x2,a,'ATAN2')
      call p_d_dd(DATAN2,1.d0*x1,1.d0*x2,1.d0*a,'DATAN2')
      end

      subroutine hyperbolic_sine
      intrinsic sinh, dsinh
      real x, a
      x = 1.0
      a = 1.1752012
      call c_r(SINH(x),a,'SINH(real)')
      call c_d(SINH(1.d0*x),1.d0*a,'SINH(double)')
      call c_d(DSINH(1.d0*x),1.d0*a,'DSINH(double)')
      call p_r_r(SINH,x,a,'SINH')
      call p_d_d(DSINH,1.d0*x,1.d0*a ,'DSINH')
      end

      subroutine hyperbolic_cosine
      intrinsic cosh, dcosh
      real x, a
      x = 1.0
      a = 1.5430806
      call c_r(COSH(x),a,'COSH(real)')
      call c_d(COSH(1.d0*x),1.d0*a,'COSH(double)')
      call c_d(DCOSH(1.d0*x),1.d0*a,'DCOSH(double)')
      call p_r_r(COSH,x,a,'COSH')
      call p_d_d(DCOSH,1.d0*x,1.d0*a ,'DCOSH')
      end

      subroutine hyperbolic_tangent
      intrinsic tanh, dtanh
      real x, a
      x = 1.0
      a = 0.76159416
      call c_r(TANH(x),a,'TANH(real)')
      call c_d(TANH(1.d0*x),1.d0*a,'TANH(double)')
      call c_d(DTANH(1.d0*x),1.d0*a,'DTANH(double)')
      call p_r_r(TANH,x,a,'TANH')
      call p_d_d(DTANH,1.d0*x,1.d0*a ,'DTANH')
      end

      subroutine lexically_greater_than_or_equal
      call c_l(LGE('A','B'),.FALSE.,'LGE(character,character) 1')
      call c_l(LGE('B','A'),.TRUE.,'LGE(character,character) 2')
      call c_l(LGE('A','A'),.TRUE.,'LGE(character,character) 3')
      end

      subroutine lexically_greater_than
      call c_l(LGT('A','B'),.FALSE.,'LGT(character,character) 1')
      call c_l(LGT('B','A'),.TRUE.,'LGT(character,character) 2')
      call c_l(LGT('A','A'),.FALSE.,'LGT(character,character) 3')
      end

      subroutine lexically_less_than_or_equal
      call c_l(LLE('A','B'),.TRUE.,'LLE(character,character) 1')
      call c_l(LLE('B','A'),.FALSE.,'LLE(character,character) 2')
      call c_l(LLE('A','A'),.TRUE.,'LLE(character,character) 3')
      end

      subroutine lexically_less_than
      call c_l(LLT('A','B'),.TRUE.,'LLT(character,character) 1')
      call c_l(LLT('B','A'),.FALSE.,'LLT(character,character) 2')
      call c_l(LLT('A','A'),.FALSE.,'LLT(character,character) 3')
      end


program test
  integer :: a(4, 3)
  integer :: i, j

  do i = 1, 4
  do j = 1, 3
      a(i, j) = i + j
  end do
  end do

  forall(i=1:4, j=1:3, a(i, j) /= 0) a(i, j) = -1

  print *, a

end program test


       subroutine appmth(runoff,remax,efflen,ealpha,m,effdrr,peakro)
c
c     + + + PURPOSE + + +
c
c     Called from IRS to compute approximate peak discharge based on the
c     kinematic wave model.
c
c     There are three cases considered for peak discharge:
c
c     1. partial equilibirum              for  tstar > 1
c
c          qpstar = 1/tstar**m
c
c     2. quasi equilibrium a              for  td < tstar < 1
c
c          qpstar = 1/tstar
c
c     3. quasi equlibirum b               for  0 < tstar < td
c
c          qpstar = 1/vstar - .6*(1-vstar)/vstar * tstar
c
c     where td = (1-sqrt(1-2.4*(1-vstar)*vstar))/(1.2*(1-vstar))
c
c     and where
c        qpstar = peakro/remax                             (nd)
c        vstar  = vave/remax                               (nd)
c        tstar  = te/effdrr                                (nd)
c        peakro = peak discharge                           (m/s)
c        vave   = average rainfall excess rate             (m/s)
c        remax  = maximum rainfall excess rate             (m/s)
c        effdrr = duration of rainfall excess              (s)
c        te     = time to kinematic equilibrium            (s)
c        m      = kinematic depth-discharge exponent       (nd)
c
c     Author: J.J. Stone
c     Reference in User Guide: Chapter 4.
c
c     Version: Created March 1994
c
c     + + + KEYWORDS + + +
c
c     kinematic wave model, approximation, time to kinematic equilibrium,
c     partial equilibrium
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real     runoff,efflen,ealpha,m,effdrr,remax,peakro
      real     tc
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     runoff  - rainfall excess or runoff volume
c     efflen  - ofe length
c     ealpha  - depth-discharge coefficient
c     m       - depth-discharge exponent
c     effdrr  - duration of rainfall excess
c     remax   - maximum rainfall excess rate
c     peakro  - approximat peak discharge
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real             te,vave,tstar,vstar,qpstar,a,b,c
c
c     + + + LOCAL DEFINITIONS + + +
c
c     te      - time to kinematic equilibrium using vave
c     vave    - average rainfall excess rate
c     vstar   - vave/remax
c     tstar   - te/effdrr
c     qpstar  - peakro/vave
c
c     compute dimensionless discharge parameters
c
      if (runoff.lt.0.00000001) then
         peakro = 0
         return
      endif
      vave  = runoff/effdrr
      te    = (efflen/(ealpha*vave**(m-1)))**(1./m)
      tstar = te/effdrr
      vstar = vave/remax
c
c     compute non dimensional peak flow
c
      if (tstar .ge. 1.) then
c
c       equation 1 - time to equilibrium is less than the duration
c                    of rainfall excess (partial equilibrium)
c
        qpstar = 1./tstar**m
c
      else
        if (vstar .lt. 1.) then
c
c         equation 2 or 3 - time to equilibrium is greater than the duration
c                           of rainfall excess
c
c         compute dividing time for eq.2 and 3
c
          a  = .6*(1.-vstar)
          b  = -1.
          c  = vstar
          tc = (-b-sqrt(b**2-4*a*c))/(2*a)
c
          if (tstar .gt. tc) then
c
c           equation 2
c
            qpstar = 1./tstar
c
          else
c
c           equation 3
c
            qpstar = 1./vstar - .6*(1.-vstar)/vstar * tstar
          end if
        else
c
c         trivial case - constant rainfall excess
c
          qpstar = 1.
        end if
c
      end if
c
c     dimensional peak runoff
c
      peakro = vave*qpstar
c
      return
      end


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

subroutine season(y,w,f,s,nlocal,seasonpar,amplitudecutoff,minimum)

!  Detrend the time-series by a running average                                 !
!                                                                               !
!  Fit sine and cosine functions to determine the number of annual seasons      !
!  The current version of the code only allows one or two annual seasons        !
!                                                                               !
!  Determine points that define the fitting intervals for local functions       !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated May 2006                                                             !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,nyear,nptperyear,npt,nseason,nenvi,printflag,debugflag,win(3),m1,m2
integer :: s(4*nyear+2),nlocal,yextpos(4),posmin1(1),posmin2(1),posmax1(1)
integer :: posmax2(1),yminpos,minimum
double precision :: y(npt),w(npt),ydt(npt),yav(npt),yfit(npt),f(npt,5),c(5)
double precision :: wfact,amp,yext(4), seasonpar, amplitudecutoff

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

!---- Use running average with large window to remove trend in time-series -----

do i = 1,npt

!---- Set window ---------------------------------------------------------------

  m1 = max(1,i - nptperyear/2)
  m2 = min(npt,i + nptperyear/2)

!---- Compute average in the window --------------------------------------------

  yav(i) = sum(w(m1:m2)*y(m1:m2))/sum(w(m1:m2))

end do

!---- Remove the trend ---------------------------------------------------------

ydt = y - yav

!---- Fit sine and cosine functions to detrended time-series -------------------

call linlsq(npt,5,f,ydt,w,c)

!---- Evaluate the fitted function ---------------------------------------------

yfit = c(1)*f(:,1)+c(2)*f(:,2)+c(3)*f(:,3)+c(4)*f(:,4)+c(5)*f(:,5)

!---- Check if the amplitude is larger than the criteria -----------------------

if ( (maxval(yfit) - minval(yfit)) <= amplitudecutoff ) then
  nlocal = 0
  s = 0
  return
end if

!---- Determine points that define the fitting intervals for local functions ---

j = 0
if ( (yfit(1)-yfit(nptperyear))*(yfit(2)-yfit(1)) < 0.d0 ) then
  j = j + 1
  yext(j) = yfit(1)
  yextpos(j) = 1
end if

do i = 2,nptperyear-1
  if ( (yfit(i)-yfit(i-1))*(yfit(i+1)-yfit(i)) < 0.d0 ) then
    j = j + 1
    yext(j) = yfit(i)
    yextpos(j) = i
  end if
end do

if ( (yfit(nptperyear)-yfit(nptperyear-1))*(yfit(1)-yfit(nptperyear)) < 0.d0 ) then
  j = j + 1
  yext(j) = yfit(nptperyear)
  yextpos(j) = nptperyear
end if

if (j == 2) then
  s(1:2*nyear) = (/ ((i-1)*nptperyear+yextpos(1:2), i = 1,nyear) /)
  s(1:2*nyear+2) = (/ 1,s(1:2*nyear),npt /)
  nlocal = 2*nyear
else
  posmax1(1:1) = maxloc(yext)
  posmax2(1:1) = maxloc(yext,mask=yext /= yext(posmax1(1)))
  posmin1(1:1) = minloc(yext)
  posmin2(1:1) = minloc(yext,mask=yext /= yext(posmin1(1)))

  if ( (yext(posmax2(1)) - yext(posmin2(1)))/(yext(posmax1(1)) - yext(posmin1(1))) > seasonpar ) then

!---- Two seasons ------------------------------------------------------------

    s(1:4*nyear) = (/ ((i-1)*nptperyear+yextpos(1:4), i = 1,nyear) /)
    s(1:4*nyear+2) = (/ 1,s(1:4*nyear),npt /)
    nlocal = 4*nyear

  else

!---- One season -------------------------------------------------------------

!---- Fit single sine and cosine functions to detrended time-series ----------

!   write(*,*) sum(ydt),sum(w)
    call linlsq(npt,3,f(:,1:3),ydt,w,c)

!---- Evaluate the fitted function -------------------------------------------

    yfit = c(1)*f(:,1)+c(2)*f(:,2)+c(3)*f(:,3)

    j = 0
    if ( (yfit(1)-yfit(nptperyear))*(yfit(2)-yfit(1)) < 0.d0 ) then
      j = j + 1
      yext(j) = yfit(1)
      yextpos(j) = 1
    end if

    do i = 2,nptperyear-1
      if ( (yfit(i)-yfit(i-1))*(yfit(i+1)-yfit(i)) < 0.d0 ) then
        j = j + 1
        yext(j) = yfit(i)
        yextpos(j) = i
      end if
    end do

    if ( (yfit(nptperyear)-yfit(nptperyear-1))*(yfit(1)-yfit(nptperyear)) < 0.d0 ) then
      j = j + 1
      yext(j) = yfit(nptperyear)
      yextpos(j) = nptperyear
    end if

	s(1:2*nyear) = (/ ((i-1)*nptperyear+yextpos(1:2), i = 1,nyear) /)
    s(1:2*nyear+2) = (/ 1,s(1:2*nyear),npt /)
    nlocal = 2*nyear

  end if
end if

!---- Find out if position corresponds to a minimum or a maximum. This information is ---
!     used in PHENOLOGY

if ( yfit(s(2)) < yfit(s(3)) ) then
  minimum = 1
else
  minimum = 0
end if

end subroutine season