C
C     file hstcyl.f
C
      SUBROUTINE HSTCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE STANDARD FIVE-POINT FINITE
C                        DIFFERENCE APPROXIMATION ON A STAGGERED
C                        GRID TO THE MODIFIED HELMHOLTZ EQUATION
C                        IN CYLINDRICAL COORDINATES. THIS EQUATION
C
C                          (1/R)(D/DR)(R(DU/DR)) + (D/DZ)(DU/DZ)
C
C                          + LAMBDA*(1/R**2)*U = F(R,Z)
C
C                        IS A TWO-DIMENSIONAL MODIFIED HELMHOLTZ
C                        EQUATION RESULTING FROM THE FOURIER TRANSFORM
C                        OF A THREE-DIMENSIONAL POISSON EQUATION.
C
C USAGE                  CALL HSTCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,IDIMF,
C                                     PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               A,B
C
C                          THE RANGE OF R, I.E. A .LE. R .LE. B.
C                          A MUST BE LESS THAN B AND A MUST BE
C                          BE NON-NEGATIVE.
C
C                        M
C                          THE NUMBER OF GRID POINTS IN THE INTERVAL
C                          (A,B).  THE GRID POINTS IN THE R-DIRECTION
C                          R-DIRECTION ARE GIVEN BY
C                          R(I) = A + (I-0.5)DR FOR I=1,2,...,M
C                          WHERE DR =(B-A)/M.
C                          M MUST BE GREATER THAN 2.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT R = A AND R = B.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT R = A
C                               (SEE NOTE BELOW) AND R = B.
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT R = A
C                               (SEE NOTE BELOW) AND THE DERIVATIVE
C                               OF THE SOLUTION WITH RESPECT TO R IS
C                               SPECIFIED AT R = B.
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE BELOW) AND R = B.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE BELOW) AND THE
C                               SOLUTION IS SPECIFIED AT R = B.
C
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE SOLUTION IS
C                               SPECIFIED AT R = B.
C
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO R IS SPECIFIED
C                               AT R = B.
C
C                          NOTE:
C                          IF A = 0, DO NOT USE MBDCND = 1,2,3, OR 4,
C                          BUT INSTEAD USE MBDCND = 5 OR 6.
C                          THE RESULTING APPROXIMATION GIVES THE ONLY
C                          MEANINGFUL BOUNDARY CONDITION,
C                          I.E. DU/DR = 0.
C                          (SEE D. GREENSPAN, 'INTRODUCTORY NUMERICAL
C                          ANALYSIS OF ELLIPTIC BOUNDARY VALUE
C                          PROBLEMS,' HARPER AND ROW, 1965, CHAPTER 5.)
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES (IF ANY)
C                          OF THE SOLUTION AT R = A.
C
C                          WHEN MBDCND = 1 OR 2,
C                            BDA(J) = U(A,Z(J)) ,       J=1,2,...,N.
C
C                          WHEN MBDCND = 3 OR 4,
C                            BDA(J) = (D/DR)U(A,Z(J)) ,   J=1,2,...,N.
C
C                          WHEN MBDCND = 5 OR 6, BDA IS A DUMMY
C                          VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT R = B.
C
C                          WHEN MBDCND = 1,4,OR 5,
C                            BDB(J) = U(B,Z(J)) ,        J=1,2,...,N.
C
C                          WHEN MBDCND = 2,3, OR 6,
C                            BDB(J) = (D/DR)U(B,Z(J)) ,   J=1,2,...,N.
C
C                        C,D
C                          THE RANGE OF Z, I.E. C .LE. Z .LE. D.
C                          C MUST BE LESS THAN D.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE INTERVAL
C                          (C,D).  THE UNKNOWNS IN THE Z-DIRECTION
C                          ARE GIVEN BY Z(J) = C + (J-0.5)DZ,
C                          J=1,2,...,N, WHERE DZ = (D-C)/N.
C                          N MUST BE GREATER THAN 2.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT Z = C  AND Z = D.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN Z, I.E.
C                               U(I,J) = U(I,N+J).
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT Z = C
C                               AND Z = D.
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT Z = C
C                               AND THE DERIVATIVE OF THE SOLUTION WITH
C                               RESPECT TO Z IS SPECIFIED AT Z = D.
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION WITH
C                               RESPECT TO Z IS SPECIFIED AT Z = C
C                               AND Z = D.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION WITH
C                               RESPECT TO Z IS SPECIFIED AT Z = C AND
C                               THE SOLUTION IS SPECIFIED AT Z = D.
C
C                        BDC
C                          A ONE DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT Z = C.
C
C                          WHEN NBDCND = 1 OR 2,
C                            BDC(I) = U(R(I),C) ,        I=1,2,...,M.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDC(I) = (D/DZ)U(R(I),C),    I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT Z = D.
C
C                          WHEN NBDCND = 1 OR 4,
C                            BDD(I) = U(R(I),D) ,       I=1,2,...,M.
C
C                          WHEN NBDCND = 2 OR 3,
C                            BDD(I) = (D/DZ)U(R(I),D) ,   I=1,2,...,M.
C
C                          WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE MODIFIED
C                          HELMHOLTZ EQUATION.  IF LAMBDA IS GREATER
C                          THAN 0, A SOLUTION MAY NOT EXIST.
C                          HOWEVER, HSTCYL WILL ATTEMPT TO FIND A
C                          SOLUTION.  LAMBDA MUST BE ZERO WHEN
C                          MBDCND = 5 OR 6.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE RIGHT SIDE OF THE
C                          MODIFIED HELMHOLTZ EQUATION.
C                          FOR I=1,2,...,M   AND J=1,2,...,N
C                            F(I,J) = F(R(I),Z(J)) .
C                          F MUST BE DIMENSIONED AT LEAST M X N.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HSTCYL.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.  IDIMF MUST
C                          BE AT LEAST M.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE. W MAY
C                          REQUIRE UP TO 13M + 4N + M*INT(LOG2(N))
C                          LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS
C                          USED IS COMPUTED BY HSTCYL AND IS RETURNED
C                          IN THE LOCATION W(1).
C
C ON OUTPUT
C
C                        F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (R(I),Z(J)) FOR  I=1,2,...,M, J=1,2,...,N.
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC, DERIVATIVE,
C                          OR UNSPECIFIED BOUNDARY CONDITIONS IS
C                          SPECIFIED FOR A POISSON EQUATION
C                          (LAMBDA = 0), A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT, CALCULATED AND
C                          SUBTRACTED FROM F, WHICH ENSURES THAT A
C                          SOLUTION EXISTS.  HSTCYL THEN COMPUTES
C                          THIS SOLUTION, WHICH IS A LEAST SQUARES
C                          SOLUTION TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C                          A SOLUTION; HENCE, THE SOLUTION IS NOT
C                          UNIQUE.  THE VALUE OF PERTRB SHOULD BE
C                          SMALL COMPARED TO THE RIGHT SIDE F.
C                          OTHERWISE, A SOLUTION IS OBTAINED TO AN
C                          ESSENTIALLY DIFFERENT PROBLEM.
C                          THIS COMPARISON SHOULD ALWAYS BE MADE TO
C                          INSURE THAT A MEANINGFUL SOLUTION HAS BEEN
C                          OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS. EXCEPT TO NUMBERS 0 AND 11,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR
C
C                          =  1  A .LT. 0
C
C                          =  2  A .GE. B
C
C                          =  3  MBDCND .LT. 1 OR MBDCND .GT. 6
C
C                          =  4  C .GE. D
C
C                          =  5  N .LE. 2
C
C                          =  6  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C                          =  7  A = 0 AND MBDCND = 1,2,3, OR 4
C
C                          =  8  A .GT. 0 AND MBDCND .GE. 5
C
C                          =  9  M .LE. 2
C
C                          = 10  IDIMF .LT. M
C
C                          = 11  LAMBDA .GT. 0
C
C                          = 12  A=0, MBDCND .GE. 5, ELMBDA .NE. 0
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HSTCYL, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF, GENBUN, GNBNAUX, AND POISTG
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN 1977.
C                        RELEASED ON NCAR'S PUBLIC SOFTWARE LIBRARIES
C                        IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS
C                        THE RIGHT SIDE WHEN THE SYSTEM IS SINGULAR AND
C                        CALLS EITHER POISTG OR GENBUN WHICH SOLVES THE
C                        LINEAR SYSTEM OF EQUATIONS.
C
C TIMING                 FOR LARGE M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO M*N*LOG2(N).
C
C ACCURACY               THE SOLUTION PROCESS RESULTS IN A LOSS
C                        OF NO MORE THAN FOUR SIGNIFICANT DIGITS
C                        FOR N AND M AS LARGE AS 64.
C                        MORE DETAILED INFORMATION ABOUT ACCURACY
C                        CAN BE FOUND IN THE DOCUMENTATION FOR
C                        SUBROUTINE POISTG WHICH IS THE ROUTINE THAT
C                        ACTUALLY SOLVES THE FINITE DIFFERENCE
C                        EQUATIONS.
C
C REFERENCES             U. SCHUMANN AND R. SWEET, "A DIRECT METHOD FOR
C                        THE SOLUTION OF POISSON'S EQUATION WITH NEUMANN
C                        BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                        ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                        PP. 171-182.
C***********************************************************************
      DIMENSION       F(IDIMF,1) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (IDIMF .LT. M) IERROR = 10
      IF (M .LE. 2) IERROR = 9
      IF (A.EQ.0. .AND. MBDCND.GE.5 .AND. ELMBDA.NE.0.) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/FLOAT(M)
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      DO 101 I=1,M
         J = IWR+I
         W(J) = A+(FLOAT(I)-0.5)*DELTAR
         W(I) = (A+FLOAT(I-1)*DELTAR)/(DLRSQ*W(J))
         K = IWC+I
         W(K) = (A+FLOAT(I)*DELTAR)/(DLRSQ*W(J))
         K = IWB+I
         W(K) = ELMBDA/W(J)**2-2./DLRSQ
  101 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (102,102,104,104,106,106),MBDCND
  102 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 103 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  103 CONTINUE
      GO TO 106
  104 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 105 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  105 CONTINUE
  106 CONTINUE
      GO TO (107,109,109,107,107,109),MBDCND
  107 W(IWC) = W(IWC)-W(IWR)
      A1 = 2.*W(IWR)
      DO 108 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  108 CONTINUE
      GO TO 111
  109 W(IWC) = W(IWC)+W(IWR)
      A1 = DELTAR*W(IWR)
      DO 110 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  110 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  111 A1 = 2./DLTHSQ
      GO TO (121,112,112,114,114),NP
  112 DO 113 I=1,M
         F(I,1) = F(I,1)-A1*BDC(I)
  113 CONTINUE
      GO TO 116
  114 A1 = 1./DELTHT
      DO 115 I=1,M
         F(I,1) = F(I,1)+A1*BDC(I)
  115 CONTINUE
  116 A1 = 2./DLTHSQ
      GO TO (121,117,119,119,117),NP
  117 DO 118 I=1,M
         F(I,N) = F(I,N)-A1*BDD(I)
  118 CONTINUE
      GO TO 121
  119 A1 = 1./DELTHT
      DO 120 I=1,M
         F(I,N) = F(I,N)-A1*BDD(I)
  120 CONTINUE
  121 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 130,123,122
  122 IERROR = 11
      GO TO 130
  123 GO TO (130,130,124,130,130,124),MBDCND
  124 GO TO (125,130,130,125,130),NP
  125 CONTINUE
      DO 127 I=1,M
         A1 = 0.
         DO 126 J=1,N
            A1 = A1+F(I,J)
  126    CONTINUE
         J = IWR+I
         PERTRB = PERTRB+A1*W(J)
  127 CONTINUE
      PERTRB = PERTRB/(FLOAT(M*N)*0.5*(A+B))
      DO 129 I=1,M
         DO 128 J=1,N
            F(I,J) = F(I,J)-PERTRB
  128    CONTINUE
  129 CONTINUE
  130 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  DELTHT**2
C
      DO 132 I=1,M
         W(I) = W(I)*DLTHSQ
         J = IWC+I
         W(J) = W(J)*DLTHSQ
         J = IWB+I
         W(J) = W(J)*DLTHSQ
         DO 131 J=1,N
            F(I,J) = F(I,J)*DLTHSQ
  131    CONTINUE
  132 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (NBDCND .EQ. 0) GO TO 133
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 134
  133 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  134 CONTINUE
      W(1) = W(IWR+1)+3.*FLOAT(M)
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


FUNCTION ran_gamma(s, first) RESULT(fn_val)
USE random
IMPLICIT NONE

! Uses the algorithm in
! Marsaglia, G. and Tsang, W.W. (2000) `A simple method for generating
! gamma variables', Trans. om Math. Software (TOMS).

! Generates a random gamma deviate for shape parameter s >= 1.

REAL, INTENT(IN)    :: s
LOGICAL, INTENT(IN) :: first
REAL                :: fn_val

! Local variables
REAL, SAVE  :: c, d
REAL        :: u, v, x

IF (s < 1.0) THEN
   WRITE(*, *) 'Shape parameter must be >= 1'
   STOP
END IF

IF (first) THEN
  d = s - 1./3.
  c = 1.0/SQRT(9.0*d)
END IF

! Start of main loop
DO

! Generate v = (1+cx)^3 where x is random normal; repeat if v <= 0.

  DO
    x = random_normal()
    v = (1.0 + c*x)**3
    IF (v > 0.0) EXIT
  END DO

! Generate uniform variable U

  CALL RANDOM_NUMBER(u)
  IF (u < 1.0 - 0.0331*x**4) THEN
    fn_val = d*v
    EXIT
  ELSE IF (LOG(u) < 0.5*x**2 + d*(1.0 - v + LOG(v))) THEN
    fn_val = d*v
    EXIT
  END IF
END DO

RETURN
END FUNCTION ran_gamma

PROGRAM test_rgamma
USE random
IMPLICIT NONE

INTERFACE
  FUNCTION ran_gamma(s, first) RESULT(fn_val)
    USE random
    IMPLICIT NONE
    REAL, INTENT(IN)    :: s
    LOGICAL, INTENT(IN) :: first
    REAL                :: fn_val
  END FUNCTION ran_gamma
END INTERFACE

REAL, PARAMETER  :: shape(8) = (/ 1.0, 2.0, 3.0, 4.0, 5.0, 10.0, 20.0, 50.0 /)
INTEGER          :: i, j
REAL             :: aver, dev, sumsq, start, finish, x

DO i = 1, 8
  WRITE(*, *)
  WRITE(*, '(a, f7.1)') ' Shape parameter = ', shape(i)

! First time the new algorithm

  CALL CPU_TIME(start)
  x = ran_gamma(shape(i), .TRUE.)
  aver = x
  sumsq = 0.0
  DO j = 2, 1000000
    x = ran_gamma(shape(i), .FALSE.)
    dev = x - aver
    aver = aver + dev/j
    sumsq = sumsq + dev*(x-aver)
  END DO
  CALL CPU_TIME(finish)
  sumsq = SQRT(sumsq/999999.)
  WRITE(*, *) 'Using Marsaglia & Tsang algorithm'
  WRITE(*, '(a, f7.2, a, 2f7.3)')  &
        ' Time = ', finish - start, 'sec.   Mean & st.devn. = ', aver, sumsq

! Repeat using algorithm in module random

  CALL CPU_TIME(start)
  x = random_gamma(shape(i), .TRUE.)
  aver = x
  sumsq = 0.0
  DO j = 2, 1000000
    x = random_gamma(shape(i), .FALSE.)
    dev = x - aver
    aver = aver + dev/j
    sumsq = sumsq + dev*(x-aver)
  END DO
  CALL CPU_TIME(finish)
  sumsq = SQRT(sumsq/999999.)
  WRITE(*, *) 'Using algorithm in module random'
  WRITE(*, '(a, f7.2, a, 2f7.3)')  &
        ' Time = ', finish - start, 'sec.   Mean & st.devn. = ', aver, sumsq
END DO

STOP
END PROGRAM test_rgamma


!!!!!
! This subroutine calculates the gamma coefficients for the Meador &
! Weaver two-stream plane-parallel atmosphere radiative transfer code.
! The calculations are taken directly from Pinty et al. (2006) Table
! 4.
!
! Pinty, B., Lavergne, T., Dickinson, R.E., Widlowski, J.-L., Gobron,
! N., Verstraete, M.M., 2006. Simplifying the interaction of land
! surfaces with radiation for relating remote sensing products to
! climate models. J. Geophys. Res. 111, D02116.
! doi:10.1029/2005JD005952
!!!!!

subroutine pinty(rl, tl, mu0, gammas)
    use mod_dataspec_wavelength
    implicit none

    real*8, intent(in) :: mu0
    real*8, intent(in), dimension(nw) :: rl, tl
    real*8, intent(out), dimension(nw, 4) :: gammas

    real*8, dimension(nw) :: w0, wd, w02, wd6

    w0 = rl + tl
    wd = rl - tl

    w02 = w0 / 2.0d0
    wd6 = wd / 6.0d0

    gammas(:,1) = 2.0d0 * (1 - w02 + wd6)
    gammas(:,2) = 2.0d0 * (w02 + wd6)
    gammas(:,3) = 2.0d0 * (w02 / 2.0d0 + mu0 * wd6) / w0
    gammas(:,4) = 1.0d0 - gammas(:,3)

end subroutine pinty


! =============================================================================
!                       Test FFT module
!
!       This unit test checks the FFT module with reference solutions.
! =============================================================================
program test_fft_3d
    use unit_test
    use constants, only : pi, twopi, f12, zero, four, two
    use inversion_utils, only : init_fft, fftxyp2s, fftxys2p
    use parameters, only : update_parameters, dx, nx, ny, nz, lower, extent
    implicit none

    double precision              :: error = zero
    double precision, allocatable :: fp1(:, :, :), &
                                     fp2(:, :, :), &
                                     fp(:, :, :),  &
                                     fs(:, :, :)
    integer                       :: i, j, k
    double precision              :: x, y, z

    nx = 32
    ny = 64
    nz = 128
    lower = (/-pi, f12 * pi, zero/)
    extent = (/twopi, two * twopi, four * twopi/)

    call update_parameters

    allocate(fp1(0:nz, 0:ny-1, 0:nx-1))
    allocate(fp2(0:nz, 0:ny-1, 0:nx-1))
    allocate(fs(0:nz, 0:nx-1, 0:ny-1))

    call init_fft

    ! setup test field
    do i = 0, nx-1
        x = lower(1) + dble(i) * dx(1)
        do j = 0, ny-1
            y = lower(2) + dble(j) * dx(2)
            do k = 0, nz
                z = lower(3) + dble(k) * dx(3)
                fp1(k, j, i) = dcos(four * x) + dsin(y) + dcos(z)
                fp2(k, j, i) = fp1(k, j, i)
            enddo
        enddo
    enddo

    fs = zero

    ! we need to copy since fftxyp2s overwrites *fp*.
    fp = fp1

    ! forward FFT
    call fftxyp2s(fp, fs)

    ! inverse FFT
    call fftxys2p(fs, fp2)

    ! final check
    error = maxval(dabs(fp1 - fp2))

    call print_result_dp('Test FFT 2D transform', error, atol=dble(1.0e-14))

end program test_fft_3d


    Program dtgsna_example

!     DTGSNA Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_dpyth
      Use lapack_interfaces, Only: dlange, dtgevc, dtgsna
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, snorm, stnrm, tnorm
      Integer :: i, info, lda, ldb, ldvl, ldvr, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), dif(:), s(:), vl(:, :), &
        vr(:, :), work(:)
      Integer, Allocatable :: iwork(:)
      Logical :: select(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DTGSNA Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvl = n
      ldvr = n
      lwork = 2*n*(n+2) + 16
      Allocate (a(lda,n), b(ldb,n), dif(n), s(n), vl(ldvl,n), vr(ldvr,n), &
        work(lwork), iwork(n+6))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Calculate the left and right generalized eigenvectors of the
!     pair (A,B). Note that DTGEVC requires WORK to be of dimension
!     at least 6*n.

      Call dtgevc('Both', 'All', select, n, a, lda, b, ldb, vl, ldvl, vr, &
        ldvr, n, m, work, info)

      If (info>0) Then
        Write (nout, 100) info, info + 1
      Else

!       Estimate condition numbers for all the generalized eigenvalues
!       and right eigenvectors of the pair (A,B)

        Call dtgsna('Both', 'All', select, n, a, lda, b, ldb, vl, ldvl, vr, &
          ldvr, s, dif, n, m, work, lwork, iwork, info)

!       Print condition numbers of eigenvalues and right eigenvectors

        Write (nout, *) 'S'
        Write (nout, 110) s(1:m)
        Write (nout, *)
        Write (nout, *) 'DIF'
        Write (nout, 110) dif(1:m)

!       Calculate approximate error estimates

!       Compute the 1-norms of A and B and then compute
!       SQRT(snorm**2 + tnorm**2)

        eps = epsilon(1.0E0_dp)
        snorm = dlange('1-norm', n, n, a, lda, work)
        tnorm = dlange('1-norm', n, n, b, ldb, work)
        stnrm = nagf_blas_dpyth(snorm, tnorm)
        Write (nout, *)
        Write (nout, *) 'Approximate error estimates for eigenvalues of (A,B)'
        Write (nout, 110)(eps*stnrm/s(i), i=1, m)
        Write (nout, *)
        Write (nout, *) 'Approximate error estimates for right ', &
          'eigenvectors of (A,B)'
        Write (nout, 110)(eps*stnrm/dif(i), i=1, m)
      End If

100   Format (' The 2-by-2 block (', I5, ':', I5, ') does not have a co', &
        'mplex eigenvalue')
110   Format ((3X,1P,7E11.1))
    End Program


! Programming name : Possuile2DFlow.f90
! Programming purpose : Compute possuile flow using LBM
! Programming author: Yang Yang :-)

!-----------------------------------------------------------------------------------------------------------
! Simulation Parameter Bolock
MODULE ParametersBlock
implicit none
! Module name: ParametersBlock
! Modul purpose: Specify and compute basic parameters

! Parallel parameter
integer, parameter:: CPUS = 6

! Discrete parameters
! Mesh parameters:
integer, parameter:: Nx = 512, Ny = 512    ! Mesh size
integer, parameter:: t_max = 1000000       ! Max time step
! Lattice model parameters:
integer, parameter:: D = 2        ! 2 Dimension model
integer, parameter:: Q = 9        ! D2Q9 velocity model
integer, parameter:: Qm = 5       ! D2Q5 velocity model

real*8, parameter:: c = 1.d0      ! lattice speed
real*8, parameter:: delta_x = 1.d0            ! mesh step length
real*8, parameter:: delta_y = delta_x         ! mesh step length
real*8, parameter:: delta_t = delta_x / c     ! time step length

real*8, parameter:: omega_alpha(1:Q) = (/ 4.d0/9.d0, 1.d0/9.d0, 1.d0/9.d0, 1.d0/9.d0, 1.d0/9.d0,&
& 1.d0/36.d0, 1.d0/36.d0, 1.d0/36.d0, 1.d0/36.d0 /)    ! Weight of distrbution function
integer, parameter:: e_alpha(1:2,1:Q) = (/0,0, 1,0, 0,1, -1,0, 0,-1, 1,1, -1,1, -1,-1, 1,-1 /)  ! Discrete velocity model

real*8, parameter:: CQ = 1.d0/2.d0                     ! CQ parameter in Mass LBE
real*8, parameter:: J0 = 0.9995d0                      ! J0 parameter in Mass LBE
real*8, parameter:: J_alpha(1:Qm) = (/J0, (1.d0-J0)/4.d0, (1.d0-J0)/4.d0, (1.d0-J0)/4.d0, (1.d0-J0)/4.d0/) ! J_alpha in Mass LBE

! Physics parameters
! Flow parameters
real*8, parameter:: rho_0 = 1.d0    ! Reference Density
real*8, parameter:: Ma = 0.001d0    ! Mach number (Inlet Velocity)
real*8, parameter:: Re = 200        ! Renoyld number (Viscosity)
! Mass Transfer parameters
real*8, parameter:: C0 = 1.d0       ! Inlet concentration
real*8, parameter:: Sc = 2000       ! Schmit number (Diffusion coefficient)
real*8, parameter:: Pe = Re*Sc      ! Peclect number (Diffusion coefficient)

! Computing parameters
! Fluid Flow
real*8, parameter:: Ly = Ny*delta_y                   ! Characteristic length
real*8, parameter:: U0 = 1.d0/sqrt(3.d0)*c*Ma         ! Characteristic Velocity
real*8, parameter:: nu = U0*Ly / Re                   ! Viscosity of fluid
real*8, parameter:: tau_f = (3.d0*nu) / (delta_t*c**2) + 1.d0/2.d0     ! dimensionless relaxion time of flow
! Mass Transfer
real*8, parameter:: Dm = nu / Sc                   ! Diffusion coefficient
real*8, parameter:: tau_m = Dm / (delta_t*c**2*CQ*(1-J0)) + 1.d0/2.d0  ! dimensionless relaxion time of Mass transfer

! Central parameters:  Nx,Ny,t_max;D,Q,Qm;c,delta_x,delta_y,delta_t,omega_alpha,e_alpha,CQ,J0,J_alpha
! U0,C0,nu,Dm,tau_f,tau_m
END MODULE ParametersBlock
!------------------------------------------------

!------------------------------------------------
! main program
PROGRAM main
use ParametersBlock
implicit none
integer, parameter:: Output_Interval = 10000, Report_Interval = 1000
real*8, parameter:: BreakCriticalCondition = 1.d-5

integer::t=0
real*8 f(Nx+1,Ny+1,Q), f_eq(Nx+1,Ny+1,Q), f_Temp(Nx+1,Ny+1,Q)
real*8 rho(Nx+1,Ny+1), u(Nx+1,Ny+1,D), u_temp(Nx+1,Ny+1,D)
real*8 epsilon

!%% Output Simulation parameters
call OutputParameters()
Write(*,*) 'Programing Paused, Continue?...'
pause

!%% Initial field
call InitialField(f,f_eq,rho,u)
!%% Evolution field main loop
do t = 1,t_max
    call ComputeF(f,f_eq,f_Temp)
    call MacroVars(f,f_Temp,rho,u,u_temp)
    call ComputeF_eq(rho,u,f_eq)
    Call BCs(f,f_eq,rho,u)
    if(mod(t,Output_Interval).EQ.0) then
       Call Outputs(rho,u,t)
    end if
    if(mod(t,Report_Interval).EQ.0 ) then
       Call Erro(u,u_temp,epsilon)
       print 300, t,epsilon
       if(epsilon<BreakCriticalCondition .AND. t>5000) then
          Print*, 'epsilon < BreakCriticalCondition','Step = ',t
          Exit
       end if
    end if

end do

300 format(1x,'Current Time Step = ',I10,', Current Residuls = ',ES25.15,/)
!%% Report and output computing result
call SimulationReport(t,epsilon,u)

!%% Output Velocity field and time step as meso file
call MesoField(u,t)

END PROGRAM main
!--------------------------------------------------------------

!--------------------------------------------------------------
!subroutine OutputParameters
SUBROUTINE OutputParameters()
use ParametersBlock
implicit none
integer i
character(len=20), parameter:: FileName1='SimulationParameters.txt'
!FileName2='MesoParameters.dat'

! Print
Write(*,100) Nx,Ny,t_max
100 format(1x,'Nx = 'I10,', Ny = ',I10,', t_max = ',I10,/)
Write(*,101) D,Q,Qm
101 format(1x,'D = ',I3,', Q = ',I3,', Qm = ',I3,/)
Write(*,102) c,delta_x,delta_y,delta_t
102 format(1x,'c = ',ES15.5,', delta_x = ',ES15.5,', delta_y = ',ES15.5,', delta_t = ',ES15.5,/)
Write(*,103) omega_alpha
103 format(1x,'Omega_alpha = ',9F10.5,/)
Write(*,*) 'e_alpha = '
do i = 1,D
  Write(*,104) e_alpha(i,:)
  104 format(1x,9I3)
end do

Write(*,105) CQ,J0
105 format(1x,'CQ = ',F10.5,', J0 = 'F10.5,/)
Write(*,106) J_alpha
106 format(1x,'J_alpha ='5F10.5)

Write(*,107) U0,Rho_0,C0
107 format(1x,'U0 = ',F10.5,', Rho_0 = ',F10.5,', C0 = 'F10.5,/)
Write(*,108) nu,Dm
108 format(1x,'nu = ',ES15.6,', Dm = ',ES15.6,/)
Write(*,109) tau_f,tau_m
109 format(1x,'tau_f = ',ES15.6,', tau_m = ',ES15.6,/)

Write(*,110) Re,Sc,Pe
110 format(1x,'Re = ',F12.4,', Sc = ',F12.4,', Pe = ',F12.4,/)

! Output to ReportFile
Open(unit=20,file=Trim(FileName1))
Write(20,100) Nx,Ny,t_max
Write(20,101) D,Q,Qm
Write(20,102) c,delta_x,delta_y,delta_t
Write(20,103) omega_alpha
Write(20,*) 'e_alpha = '
do i = 1,D
  Write(20,104) e_alpha(i,:)
end do

Write(20,105) CQ,J0
Write(20,106) J_alpha

Write(20,107) U0,Rho_0,C0
Write(20,108) nu,Dm
Write(20,109) tau_f,tau_m
Write(20,110) Re,Sc,Pe
Close(20)

! Output Meso parameter file
!Open(unit=30,file=Trim(FileName2))
!Write(30,*) Nx,Ny,t_max,D,Qm,c,delta_x,delta_y,delta_t,e_alpha,CQ,J_alpha,C0,tau_m
!Close(30)

END SUBROUTINE OutputParameters
!---------------------------------------------------------

!---------------------------------------------------------
SUBROUTINE InitialField(f,f_eq,rho,u)
use ParametersBlock
use omp_lib
implicit none
real*8, INTENT(INOUT):: f(Nx+1,Ny+1,Q), f_eq(Nx+1,Ny+1,Q)
real*8, INTENT(INOUT):: rho(Nx+1,Ny+1), u(Nx+1,Ny+1,D)
integer i,j,k
real*8 u_square,e_temp,x

!$OMP PARALLEL DO PRIVATE(i,j) SHARED(u,rho) NUM_THREADS(CPUS)
! Macro Varibles
do i=1,Nx+1
   do j = 1,Ny+1
     u(i,j,:) = 0
     rho(i,j) = Rho_0
   end do
end do
!$OMP END PARALLEL DO

j = Ny+1
!$OMP PARALLEL DO PRIVATE(i,x) FIRSTPRIVATE(j) SHARED(u) NUM_THREADS(CPUS)
do i = 1,Nx+1
    x = (i-1.d0)/Nx
    u(i,j,1) = U0*16.d0*(x**2)*(1.d0-x)**2
end do
!$OMP END PARALLEL DO

!$OMP PARALLEL DO PRIVATE(i,j,u_square,e_temp) SHARED(f,f_eq,u,rho) NUM_THREADS(CPUS)
! Micro Variles
do i=1,Nx+1
   do j = 1,Ny+1
     u_square = u(i,j,1)**2 + u(i,j,2)**2
     do k = 1,Q
        e_temp = u(i,j,1)*dble(e_alpha(1,k)) + u(i,j,2)*dble(e_alpha(2,k))
        f_eq(i,j,k) = rho(i,j)*Omega_alpha(k)*( 1.d0 + e_temp*3.d0/c**2 + e_temp**2*9.d0/2.d0/c**4 - u_square*3.d0/2.d0/c**2 )
        f(i,j,k) =  f_eq(i,j,k)
     end do
   end do
end do
!$OMP END PARALLEL DO

END SUBROUTINE InitialField
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE ComputeF(f,f_eq,f_Temp)
use ParametersBlock
use omp_lib
implicit none

real*8, INTENT(INOUT):: f_Temp(Nx+1,Ny+1,Q)
real*8, INTENT(IN):: f(Nx+1,Ny+1,Q), f_eq(Nx+1,Ny+1,Q)

integer i,j,k
integer i_temp,j_temp

!$OMP PARALLEL DO PRIVATE(i,j,k,i_temp,j_temp) SHARED(f,f_eq,F_Temp) NUM_THREADS(CPUS)
do i = 2,Nx
   do j = 2,Ny
     do k = 1,Q
         i_temp = i - e_alpha(1,k)
         j_temp = j - e_alpha(2,k)
         F_Temp(i,j,k) = f(i_temp,j_temp,k) + (f_eq(i_temp,j_temp,k) - f(i_temp,j_temp,k))/tau_f
     end do
   end do
end do
!$OMP END PARALLEL DO

END SUBROUTINE ComputeF
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE MacroVars(f,f_Temp,rho,u,u_temp)
use ParametersBlock
use omp_lib
implicit none

real*8, INTENT(IN):: f_Temp(Nx+1,Ny+1,Q)
REAL*8, INTENT(OUT):: f(Nx+1,Ny+1,Q), rho(Nx+1,Ny+1),u(Nx+1,Ny+1,D),u_temp(Nx+1,Ny+1,D)
integer i,j,k

!$OMP PARALLEL DO PRIVATE(i,j,k) SHARED(u_temp,rho,u,f,f_Temp) NUM_THREADS(CPUS)
! Initial and sum all direction
do i = 2,Nx
   do j = 2,Ny
     u_temp(i,j,:) = u(i,j,:)
     rho(i,j) = 0.d0
     u(i,j,:) = 0.d0
     do k = 1,Q
       f(i,j,k) = f_Temp(i,j,k)
       rho(i,j) = rho(i,j) + f(i,j,k)
       u(i,j,1) = u(i,j,1) + e_alpha(1,k)*f(i,j,k)
       u(i,j,2) = u(i,j,2) + e_alpha(2,k)*f(i,j,k)
     end do
     u(i,j,:) = u(i,j,:) / Rho(i,j)
   end do
end do
!$OMP END PARALLEL DO

END SUBROUTINE
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE ComputeF_eq(rho,u,f_eq)
use ParametersBlock
use omp_lib
implicit none

real*8, INTENT(IN):: rho(Nx+1,Ny+1),u(Nx+1,Ny+1,D)
real*8, INTENT(OUT):: f_eq(Nx+1,Ny+1,Q)
integer i,j,k
real*8 u_square,e_temp

!$OMP PARALLEL DO PRIVATE(i,j,k,u_square,e_temp) SHARED(u,rho,f_eq) NUM_THREADS(CPUS)
do i = 2,Nx
   do j = 2,Ny
     u_square = u(i,j,1)**2 + u(i,j,2)**2
     do k = 1,Q
        e_temp = u(i,j,1)*dble(e_alpha(1,k)) + u(i,j,2)*dble(e_alpha(2,k))
        f_eq(i,j,k) = rho(i,j)*Omega_alpha(k)*( 1.d0 + e_temp*3.d0/c**2 + e_temp**2*9.d0/2.d0/c**4 - u_square*3.d0/2.d0/c**2 )
     end do
    end do
end do
!$OMP END PARALLEL DO

END SUBROUTINE ComputeF_eq
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE BCs(f,f_eq,rho,u)
use ParametersBlock
use omp_lib
implicit none

real*8, INTENT(INOUT):: f(Nx+1,Ny+1,Q),f_eq(Nx+1,Ny+1,Q),rho(Nx+1,Ny+1),u(Nx+1,Ny+1,D)
integer i,j,k
real*8 u_square,e_temp,x

!%% Inlet non-equilibrium scheme
i = 1
!$OMP PARALLEL DO PRIVATE(j,k,u_square,e_temp) FIRSTPRIVATE(i) SHARED(rho,u,f_eq,f) NUM_THREADS(CPUS)
do j = 2,Ny
   rho(i,j) = rho(i+1,j)
   u(i,j,1) = 0
   u(i,j,2) = 0
   u_square = u(i,j,1)**2 + u(i,j,2)**2
   do k = 1,Q
     e_temp = u(i,j,1)*dble(e_alpha(1,k)) + u(i,j,2)*dble(e_alpha(2,k))
     f_eq(i,j,k) = rho(i,j)*Omega_alpha(k)*( 1.d0 + e_temp*3.d0/c**2 + e_temp**2*9.d0/2.d0/c**4 - u_square*3.d0/2.d0/c**2 )
     f(i,j,k) = f_eq(i,j,k) + (f(i+1,j,k) - f_eq(i+1,j,k) )
   end do
end do
!$OMP END PARALLEL DO

!%% Outlet fully developed
i = Nx+1
!$OMP PARALLEL DO PRIVATE(j,k,u_square,e_temp) FIRSTPRIVATE(i) SHARED(rho,u,f_eq,f) NUM_THREADS(CPUS)
do j = 2,Ny
    u(i,j,1) = 0
    u(i,j,2) = 0
    rho(i,j) = rho(i-1,j)
    do k = 1,Q
       e_temp = u(i,j,1)*dble(e_alpha(1,k)) + u(i,j,2)*dble(e_alpha(2,k))
       f_eq(i,j,k) = rho(i,j)*Omega_alpha(k)*( 1.d0 + e_temp*3.d0/c**2 + e_temp**2*9.d0/2.d0/c**4 - u_square*3.d0/2.d0/c**2 )
       f(i,j,k) = f_eq(i,j,k) + (f(i-1,j,k) - f_eq(i-1,j,k) )
    end do
end do
!$OMP END PARALLEL DO

!%% Walls non-equilibrium scheme
! %% Bottom
j = 1
!$OMP PARALLEL DO PRIVATE(i,k,u_square,e_temp) FIRSTPRIVATE(j) SHARED(rho,u,f,f_eq) NUM_THREADS(CPUS)
do i = 1,Nx + 1
   rho(i,j) = rho(i,j+1)
   u(i,j,1) = 0
   u(i,j,2) = 0
   u_square = u(i,j,1)**2 + u(i,j,2)**2
   do k = 1,Q
     e_temp = u(i,j,1)*dble(e_alpha(1,k)) + u(i,j,2)*dble(e_alpha(2,k))
     f_eq(i,j,k) = rho(i,j)*Omega_alpha(k)*( 1.d0 + e_temp*3.d0/c**2 + e_temp**2*9.d0/2.d0/c**4 - u_square*3.d0/2.d0/c**2 )
     f(i,j,k) = f_eq(i,j,k) + (f(i,j+1,k) - f_eq(i,j+1,k) )
   end do
end do
!$OMP END PARALLEL DO

!%% TOP
j = Ny+1
!$OMP PARALLEL DO PRIVATE(i,k,u_square,e_temp,x) FIRSTPRIVATE(j) SHARED(rho,u,f,f_eq) NUM_THREADS(CPUS)
do i = 1,Nx + 1
   x = (i-1.d0)/Nx
   rho(i,j) = rho(i,j-1)
   u(i,j,1) = U0*16.d0*(x**2)*(1.d0-x)**2
   u(i,j,2) = 0
   u_square = u(i,j,1)**2 + u(i,j,2)**2
   do k = 1,Q
     e_temp = u(i,j,1)*dble(e_alpha(1,k)) + u(i,j,2)*dble(e_alpha(2,k))
     f_eq(i,j,k) = rho(i,j)*Omega_alpha(k)*( 1.d0 + e_temp*3.d0/c**2 + e_temp**2*9.d0/2.d0/c**4 - u_square*3.d0/2.d0/c**2 )
     f(i,j,k) = f_eq(i,j,k) + (f(i,j-1,k) - f_eq(i,j-1,k) )
   end do
end do
!$OMP END PARALLEL DO

END SUBROUTINE BCs
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE Outputs(rho,u,t)
use ParametersBlock
implicit none

integer, INTENT(IN):: t
real*8, INTENT(IN):: rho(Nx+1,Ny+1),u(Nx+1,Ny+1,D)

real*8 rho_out(Nx+1,Ny+1),u_out(Nx+1,Ny+1,D)
character(len=100) Char_Temp,Nx_Temp,Ny_Temp
integer i,j

Write(Char_Temp,*) t
Write(Nx_Temp,*) Nx+1
Write(Ny_Temp,*) Ny+1
open(20,file='FlowDataAtStep'//Trim(Char_Temp)//'.dat')

Write(20,*) 'VARIABLES = X, Y, U, V, Rho'
Write(20,*) 'Zone T="", I ='//Trim(Nx_Temp)//', J ='//Trim(Ny_Temp)//', F = Point'

! Dimensionless
do i = 1,Nx+1
   do j = 1,Ny+1
      u_out(i,j,:) = u(i,j,:) / U0
      rho_out(i,j) = rho(i,j) / Rho_0
   end do
end do

! Output
do j = 1,Ny+1
   do i = 1,Nx+1
     Write(20,200) dble(i-1)/dble(Ly),dble(j-1)/dble(Ly),u_out(i,j,1),u_out(i,j,2),rho_out(i,j)
   end do
end do
200 format(1x,5ES24.15)

close(20)

END SUBROUTINE Outputs
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE Erro(u,u_temp,epsilon)
use ParametersBlock
use omp_lib
implicit none

real*8, INTENT(IN):: u(Nx+1,Ny+1,D),u_temp(Nx+1,Ny+1,D)
real*8, INTENT(INOUT):: epsilon
integer i,j
real*8:: num = 0.d0, den = 0.d0

!$OMP PARALLEL DO PRIVATE(i,j) SHARED(u,u_temp) REDUCTION(+:num,den) NUM_THREADS(CPUS)
do i = 2,Nx
   do j = 2,Ny
    num = num + (u(i,j,1)-u_temp(i,j,1))**2 + (u(i,j,2)-u_temp(i,j,2))**2
    den = den + u_temp(i,j,1)**2 + u_temp(i,j,2)**2
   end do
end do
!$OMP END PARALLEL DO

epsilon = sqrt(num) / sqrt(den)

END SUBROUTINE Erro
!--------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE SimulationReport(t,epsilon,u)
use ParametersBlock
implicit none

real*8, INTENT(IN):: t,epsilon,u(Nx+1,Ny+1,D)
integer j,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10

! %% Compute Log File
open(20,file='Report.log')
Write(20,200) t,epsilon
200 format(1x,'Final Time Step:',I10,', Final Residual:',ES25.15)
close(20)

! %% Velocity Profile
i1 = NINT(0.d0*Nx) +1
i2 = NINT(1.d0/20.d0*Nx) +1
i3 = NINT(1.d0/10.d0*Nx) +1
i4 = NINT(3.d0/20.d0*Nx) +1
i5 = NINT(1.d0/5.d0*Nx) +1
i6 = NINT(3.d0/10.d0*Nx) +1
i7 = NINT(2.d0/5.d0*Nx) +1
i8 = NINT(3.d0/5.d0*Nx) +1
i9 = NINT(4.d0/5.d0*Nx) +1
i10 = Nx+1
open(30,file = 'VelocityProfile.txt')
Write(30,*) 'Variables = Y,U(X1:X10)'
do j = 1,Ny+1
    Write(30,300) dble(j-1)/dble(Ly) ,u(i1,j,1)/U0,u(i2,j,1)/U0,u(i3,j,1)/U0,u(i4,j,1)/U0,u(i5,j,1)/U0&
              &,u(i6,j,1)/U0,u(i7,j,1)/U0,u(i8,j,1)/U0,u(i9,j,1)/U0, u(i10,j,1)/U0
end do
300 format(1x,11ES18.10)
close(30)

END SUBROUTINE SimulationReport
!--------------------------------------------------------

!--------------------------------------------------------
!: This Subroutine is really important, play a role of bridge
SUBROUTINE Mesofield(u,t)
use ParametersBlock
implicit none

real*8, INTENT(IN):: u(Nx+1,Ny+1,D)
integer, INTENT(IN):: t
open(100,file = 'MesoField.dat')
Write(100,*) u,t

close(100)
END SUBROUTINE Mesofield
!--------------------------------------------------------


module snding_mod
  implicit none
  private
  public :: splint, spline

  contains

    real pure function splint(XA,YA,Y2A,n,x)
      integer, intent(in) :: n, x
      real, intent(in) :: XA(50), YA(50), Y2A(n)

      real :: h, a, b
      integer :: klo, khi, k

      klo=1
      khi=n

      do
        if (khi-klo <= 1) exit
        if (khi-klo > 1) then
          k=(khi+klo)/2
          if (XA(k) > x) then
            khi=k
          else
            klo=k
          end if
        end if
      end do

      H=XA(KHI)-XA(KLO)
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      splint=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.

    end function

    pure function spline(X,Y,N,YP1,YPN)
      integer, parameter :: NMAX=100
      real :: U(NMAX)
      real :: UN,QN,P,SIG
      integer, intent(in) :: N
      integer :: i, k
      real, intent(in) :: X(N), Y(N), YP1, YPN
      real :: spline(N)

      IF (YP1>.99E30) THEN
        spline(1)=0.
        U(1)=0.
      ELSE
        spline(1)=-0.5
        U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
      end if
      do I=2,N-1
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        P=SIG*spline(I-1)+2.
        spline(I)=(SIG-1.)/P
        U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))                 &
             /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
      end do
      IF (YPN>.99E30) THEN
        QN=0.
        UN=0.
      ELSE
        QN=0.5
        UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
      end if
      spline(N)=(UN-QN*U(N-1))/(QN*spline(N-1)+1.)
      do K=N-1,1,-1
        spline(K)=spline(K)*spline(K+1)+U(K)
      end do
      return
    end function

end module snding_mod


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     11/96
!
!     a program for testing all vector analysis and synthesis subroutines
!
!     (1) first a scalar stream function and a scalar velocity potential function
!         are set in st, sv by restricting polys in x, y, z to the sphere surface
!
!     (2) the vector vield (v, w) is set by analytically differenting the scalar fields in (1)
!         using the standard formula relating a vector field and the stream and velocity
!         potential scalar fields in colatitude X longitude spherical coordinates
!
!          v = -1/sin(theta)*d(st)/dphi + d(sv)/dtheta
!
!          w =  1/sin(theta)*d(sv)/dphi + d(st)/dtheta
!
!     (3) a vector analysis is performed on (v, w)
!
!     (4) a vector synthesis is performed using coeffs from (3)
!
!     (5) the synthesized vector field from (4) is compared with the vector field from (2)
!
!     note:  vhaec, vhaes, vhagc, vhags, vhsec, vhses, vhsgc, vhsgs are all tested!
!
program tvha

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        Sphere, &
        Regularsphere, &
        GaussianSphere

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), allocatable :: solver

    ! Test gaussian grid
    allocate (GaussianSphere :: solver)
    call test_vector_analysis_and_synthesis_routines(solver)
    deallocate (solver)

    ! Test regular grid
    allocate (RegularSphere :: solver)
    call test_vector_analysis_and_synthesis_routines(solver)
    deallocate (solver)

contains

    subroutine test_vector_analysis_and_synthesis_routines(sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLONS = 19
        integer(ip), parameter        :: NLATS = 25
        integer(ip), parameter        :: NSYNTHS = 2
        integer(ip)                   :: i, j, k ! Counters
        real(wp)                      :: polar_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: azimuthal_component(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: synthesized_polar(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: synthesized_azimuthal(NLATS, NLONS, NSYNTHS)
        character(len=:), allocatable :: previous_polar_error, previous_azimuthal_error

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            !  Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_polar_error, source='     polar error     = 5.107026e-15')
            allocate (previous_azimuthal_error, source='     azimuthal error = 9.325873e-15')

            type is (RegularSphere)

            ! Initialize regular sphere
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_polar_error, source='     polar error     = 5.329071e-15')
            allocate (previous_azimuthal_error, source='     azimuthal error = 7.771561e-15')
        end select

        !
        !  Set scalar stream and velocity potential fields as polys in x, y, z
        !    and then set v, w from st, sv scalar fields
        !
        associate (&
            ve => polar_component, &
            we => azimuthal_component, &
            radial => sphere_type%unit_vectors%radial, &
            theta => sphere_type%unit_vectors%polar, &
            phi => sphere_type%unit_vectors%azimuthal &
           )
            do k=1, NSYNTHS
                do j=1, NLONS
                    do i=1, NLATS
                        associate (&
                            x => radial(i, j)%x, & !sint*cosp
                            y => radial(i, j)%y, & !sint*sinp
                            z => radial(i, j)%z, & !cost
                            dxdt => theta(i, j)%x, &! cost*cosp
                            dxdp => -radial(i, j)%y, & !-sint*sinp
                            dydt => theta(i, j)%y, &! cost*sinp
                            dydp => radial(i, j)%x, & ! sint*cosp
                            dzdt => theta(i, j)%z, & ! -sint
                            dzdp => phi(i, j)%z, & ! 0.0
                            cosp => phi(i, j)%y, &
                            sinp => -phi(i, j)%x &
                           )
                            select case (k)
                                case (1)
                                    associate (&
                                        dstdt => x*dydt+y*dxdt, &
                                        dsvdt => y*dzdt+z*dydt &
                                       )
                                        ve(i, j, k) = -(cosp*dydp+sinp*dxdp) + dsvdt
                                        we(i, j, k) = sinp*dzdp + dxdt + dstdt
                                    end associate
                                case (2)
                                    associate (&
                                        dstdt => x*dzdt+z*dxdt, &
                                        dsvdt => x*dydt+y*dxdt &
                                       )
                                        !
                                        !          v = -1/sin(theta)*d(st)/dphi + d(sv)/dtheta
                                        !
                                        !          w =  1/sin(theta)*d(sv)/dphi + d(st)/dtheta
                                        !
                                        ve(i, j, k) = z*sinp + dsvdt
                                        we(i, j, k) = cosp*dydp+ sinp*dxdp + dstdt
                                    end associate
                            end select
                        end associate
                    end do
                end do
            end do
        end associate

        !
        !  Perform analysis then synthesis
        !
        do k = 1, NSYNTHS
            associate (&
                ve => polar_component(:, :, k), &
                we => azimuthal_component(:, :, k), &
                v => synthesized_polar(:, :, k), &
                w => synthesized_azimuthal(:, :, k) &
               )

                ! Analyse function into (real) coefficients
                call sphere_type%vector_analysis_from_spherical_components(ve, we)

                ! Synthesize function from (real) coefficients
                call sphere_type%perform_vector_synthesis(v, w)
            end associate
        end do

        !
        !  Compute discretization error
        !
        associate (&
            ve => polar_component, &
            we => azimuthal_component, &
            v => synthesized_polar, &
            w => synthesized_azimuthal &
           )
            associate (&
                err2v => maxval(abs(v - ve)), &
                err2w => maxval(abs(w - we)) &
               )
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     test vector analysis and synthesis *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing vector analysis and synthesis'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_polar_error
                write (stdout, '(a)') previous_azimuthal_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     polar error     = ', err2v
                write (stdout, '(a, 1pe15.6)') '     azimuthal error = ', err2w
                write (stdout, '(a)') ''
            end associate
        end associate
        !
        !  Release memory
        !
        call sphere_type%destroy()
        deallocate (previous_polar_error)
        deallocate (previous_azimuthal_error)

    end subroutine test_vector_analysis_and_synthesis_routines

end program tvha


C FILE: vvh_routines.f

        SUBROUTINE Tensor_Inner_Product_3X3(a,b,T)

            implicit none
            real(8), dimension(3,3), intent(in) :: a, b
            real(8), intent(out) :: T!, TX

            !TX = sum(sum(a*b,2))

            T = a(1,1)*b(1,1) + a(1,2)*b(1,2) + a(1,3)*b(1,3)
            T = T + a(2,1)*b(2,1) + a(2,2)*b(2,2) + a(2,3)*b(2,3)
            T = T + a(3,1)*b(3,1) + a(3,2)*b(3,2) + a(3,3)*b(3,3)

        END SUBROUTINE

        SUBROUTINE HENCKY_1D(mu, etr, Ei, dWtr, d2Wtr, energye)

            implicit none
            real(8), intent(in) :: mu, etr(3,1), Ei(3,3,3)
            real(8) :: G, eps(3), vdWtr(3)
            real(8), intent(out) :: dWtr(3,3), d2Wtr(3,3), energye

            eps(:) = 0.d0

            G = mu

            eps=[etr(1,1), etr(2,1), etr(3,1)]

            vdWtr(:) = 2*G*eps(:)

            dWtr(1, 1:3) = [vdWtr(1),    0.0d0,    0.0d0]
            dWtr(2, 1:3) = [   0.0d0, vdWtr(2),    0.0d0]
            dWtr(3, 1:3) = [   0.0d0,    0.0d0, vdWtr(3)]

            d2Wtr(1, 1:3) = [2*G,    0.0d0,    0.0d0]
            d2Wtr(2, 1:3) = [   0.0d0, 2*G,    0.0d0]
            d2Wtr(3, 1:3) = [   0.0d0,    0.0d0, 2*G]

            energye = G*(eps(1)**2 + eps(2)**2 + eps(3)**2)

        END SUBROUTINE

        SUBROUTINE Hencky_3D(mu, etr, Ei, dWtr, d2Wtr, energye)

            implicit none
            real(8), intent(in) :: mu, etr(3,3), Ei(3,3,3)
            real(8) :: G, eps(3), vdWtr(3)
            real(8), intent(out) :: dWtr(3,3), d2Wtr(3,3), energye

            eps(:) = 0.d0

            G = mu

            call Tensor_Inner_Product_3X3(etr, Ei(:,:,1), eps(1))
            call Tensor_Inner_Product_3X3(etr, Ei(:,:,2), eps(2))
            call Tensor_Inner_Product_3X3(etr, Ei(:,:,3), eps(3))

            vdWtr(:) = 2*G*eps(:)

            dWtr(1, 1:3) = [vdWtr(1),    0.0d0,    0.0d0]
            dWtr(2, 1:3) = [   0.0d0, vdWtr(2),    0.0d0]
            dWtr(3, 1:3) = [   0.0d0,    0.0d0, vdWtr(3)]

            d2Wtr(1, 1:3) = [2*G,    0.0d0,    0.0d0]
            d2Wtr(2, 1:3) = [   0.0d0, 2*G,    0.0d0]
            d2Wtr(3, 1:3) = [   0.0d0,    0.0d0, 2*G]

            energye = G*(eps(1)**2 + eps(2)**2 + eps(3)**2)

        END SUBROUTINE

C END FILE


      program main
c
c ... array declarations.
c
      implicit double precision (a-h, o-z)
      dimension coef(120,5), rhs(100), u(100), wksp(600), ubar(1),
     a     rparm(30)
      integer jcoef(120,5), iwksp(300), iparm(30), p(100), ip(100)
      external cg, rs6
c
      ndim = 120
      mdim = 5
      nw = 600
      inw = 300
c
c ... generate coef, jcoef, and rhs.
c
      nx = 10
      ny = 10
      n = nx*ny
      h = 1.0d0/dble(nx + 1)
      maxnz = 5
      do i = 1,n
         coef(i,1) = 6.0d0
         coef(i,2) = -1.0d0
         coef(i,3) = -2.0d0
         coef(i,4) = -1.0d0
         coef(i,5) = -2.0d0
         jcoef(i,1) = i
         jcoef(i,2) = i + 1
         jcoef(i,3) = i + nx
         jcoef(i,4) = i - 1
         jcoef(i,5) = i - nx
         rhs(i) = 0.0d0
      enddo
      k = 0
      do j = 1,ny
         y = dble(j)*h
         do i = 1,nx
            x = dble(i)*h
            k = k + 1
            if (j .eq. 1) then
               rhs(k) = rhs(k) + 2.0d0
               coef(k,5) = 0.0d0
               jcoef(k,5) = 0
            endif
            if (j .eq. ny) then
               rhs(k) = rhs(k) + 2.0d0*(1.0d0 + x)
               coef(k,3) = 0.0d0
               jcoef(k,3) = 0
            endif
            if (i .eq. 1) then
               rhs(k) = rhs(k) + 1.0d0
               coef(k,4) = 0.0d0
               jcoef(k,4) = 0
            endif
            if (i .eq. nx) then
               rhs(k) = rhs(k) + 1.0d0 + y
               coef(k,2) = 0.0d0
               jcoef(k,2) = 0
            endif
         enddo
      enddo
      call dfault (iparm,rparm)
c
c ... now, reset some default values.
c
      iparm(3) = 3
      iparm(12) = 1
      iparm(14) = 1
      iparm(23) = 0
c
c ... generate an initial guess for u and call nspcg.
c
      call vfill (n,u,0.0d0)
c
      call redblk (ndim,n,maxnz,coef,jcoef,p,ip,1,iwksp,ier)
      call nspcg (rs6,cg,ndim,mdim,n,maxnz,coef,jcoef,p,ip,
     a            u,ubar,rhs,wksp,iwksp,nw,inw,iparm,rparm,ier)
      stop
      end


program ch0708
    ! Table of Liquid Conversion Measurements
    implicit none

    integer :: litre
    real :: gallon, usgallon

    do litre = 1, 10
        gallon = litre/4.545
        usgallon = litre/3.7854118
        print *, litre, ' ', gallon, ' ', usgallon
    end do
end program


      SUBROUTINE INIFFT

C     Initialize FFTs

      include "atparam.h"

      COMMON /FFTCOM/ WSAVE(2*IX+15)

      CALL RFFTI (IX,WSAVE)
C      CALL DFFTI (IX,WSAVE)

      RETURN
      END

*********************************************************************

      SUBROUTINE GRIDX(VARM,VORG,KCOS)

C     From Fourier coefficients to grid-point data

      include "atparam.h"

      include "com_spectral.h"

      COMMON /FFTCOM/ WSAVE(2*IX+15)

      REAL VORG(IX,IL), VARM(MX2,IL)
      REAL FVAR(IX)

C     Copy Fourier coefficients into working array

      DO J=1,IL

        FVAR(1)=VARM(1,J)

        DO M=3,MX2
          FVAR(M-1)=VARM(M,J)
        ENDDO
        DO M=MX2,IX
          FVAR(M)=0.0
        ENDDO

C     Inverse FFT

      CALL RFFTB (IX,FVAR,WSAVE)
C      CALL DFFTB (IX,FVAR,WSAVE)

C     Copy output into grid-point field, scaling by cos(lat) if needed

        IF (KCOS.EQ.1) THEN

          DO I=1,IX
            VORG(I,J)=FVAR(I)
          ENDDO

        ELSE

          DO I=1,IX
            VORG(I,J)=FVAR(I)*COSGR(J)
          ENDDO

        ENDIF

      ENDDO

      RETURN
      END

******************************************************************

      SUBROUTINE SPECX(VORG,VARM)

C     From grid-point data to Fourier coefficients

      include "atparam.h"

      COMMON /FFTCOM/ WSAVE(2*IX+15)

      REAL VORG(IX,IL), VARM(MX2,IL)
      REAL FVAR(IX)

C     Copy grid-point data into working array

      DO J=1,IL

        DO I=1,IX
          FVAR(I)=VORG(I,J)
        ENDDO

C     Direct FFT

      CALL RFFTF (IX,FVAR,WSAVE)
C      CALL DFFTF (IX,FVAR,WSAVE)

C     Copy output into spectral field, dividing by no. of long.

      SCALE=1./FLOAT(IX)

C     Mean value (a(0))

      VARM(1,J)=FVAR(1)*SCALE
      VARM(2,J)=0.0

      DO M=3,MX2
        VARM(M,J)=FVAR(M-1)*SCALE
      ENDDO

      ENDDO

      RETURN
      END

      include "spe_subfft_fftpack2.f"


!
MODULE shape_2_mod
  !
  ! Shape function library - 2d.
  !
  USE IntrinsicTypesModule, RK=>REAL_KIND
  !
  IMPLICIT NONE
  !
CONTAINS
  !
  !
  !***********************************************************************
  !
  SUBROUTINE sf2d(itype, npts, pts, vals, MV1, istat)
    !
    !     Evaluate shape functions at a list of points.
    !
    !----------------------------------------------------------------------
    !
    IMPLICIT NONE
    !
    !     Arguments:
    !
    INTEGER :: itype, npts, MV1, istat
    REAL(RK) :: pts(2,*), vals(MV1, *)
    !
    !----------------------------------------------------------------------
    !
    istat = 0
    !
    IF (itype .eq. 3) THEN
       !
       call sf2d03(npts, pts, vals, MV1)
       !
    ELSEIF (itype .eq. 4) THEN
       !
       call sf2d04(npts, pts, vals, MV1)
       !
    ELSEIF (itype .eq. 6) THEN
       !
       call sf2d06(npts, pts, vals, MV1)
       !
    ELSEIF (itype .eq. 8) THEN
       !
       call sf2d08(npts, pts, vals, MV1)
       !
    ELSEIF (itype .eq. 9) THEN
       !
       call sf2d09(npts, pts, vals, MV1)
       !
    ELSE
       !
       !     Unrecognized element type.
       !
       istat = 1
       !
    ENDIF
    !
    RETURN
  END SUBROUTINE sf2d
  !
  !***********************************************************************
  !
  SUBROUTINE sf2dg(itype, npts, pts, grads, MG1, istat)
    !
    !     Evaluate shape function gradients at a list of points.
    !
    !----------------------------------------------------------------------
    !
    IMPLICIT NONE
    !
    !     Arguments:
    !
    INTEGER :: itype, npts, MG1, istat
    REAL(RK) :: pts(2,*), grads(2,MG1, *)
    !
    !----------------------------------------------------------------------
    !
    istat = 0
    !
    IF (itype .eq. 3) THEN
       !
       call sf2dg03(npts, pts, grads, MG1)
       !
    ELSEIF (itype .eq. 4) THEN
       !
       call sf2dg04(npts, pts, grads, MG1)
       !
    ELSEIF (itype .eq. 6) THEN
       !
       call sf2dg06(npts, pts, grads, MG1)
       !
    ELSEIF (itype .eq. 8) THEN
       !
       call sf2dg08(npts, pts, grads, MG1)
       !
    ELSEIF (itype .eq. 9) THEN
       !
       call sf2dg09(npts, pts, grads, MG1)
       !
    ELSE
       !
       !     Unrecognized element type.
       !
       istat = 1
       !
    ENDIF
    !
    RETURN
  END SUBROUTINE sf2dg
  !
  !***********************************************************************
  !
  !     ***** t3 ******
  !
  SUBROUTINE sf2d03(npts, pnts, value, MV1)
    !
    !     three node triangular element (values)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MV1
    REAL(RK) :: value(MV1,*), pnts(2, *)
    !
    INTEGER  :: i
    REAL(RK) ::xi, eta, zeta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       zeta = 1.d0 - xi - eta
       !
       ! nodal locations:
       !
       ! 2
       ! 31
       !
       value(1,i) = xi
       value(2,i) = eta
       value(3,i) = zeta
    enddo
    !
    RETURN
  END SUBROUTINE sf2d03
  !
  !***********************************************************************
  !
  SUBROUTINE sf2dg03(npts, pnts, grad, MG1)
    !
    !     three node tirangle element (gradients)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MG1
    REAL(RK) :: grad(2,MG1,*), pnts(2,*)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta, zeta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       zeta = 1.0d0 - xi - eta
       !
       grad(1,1,i) = 1.0d0
       grad(1,2,i) = 0.0d0
       grad(1,3,i) = -1.0d0
       !
       grad(2,1,i) = 0.d0
       grad(2,2,i) = 1.d0
       grad(2,3,i) = -1.d0
    enddo
    !
    RETURN
  END SUBROUTINE sf2dg03
  !
  !***********************************************************************
  !
  !     ***** q4 ******
  !
  SUBROUTINE sf2d04(npts, pnts, value, MV1)
    !
    !     four node quadrilateral element (values)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MV1
    REAL(RK) :: value(MV1,*), pnts(2, *)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       !
       value(1,i) = (1.0d0-xi)*(1.0d0-eta)
       value(2,i) = xi*(1.0d0-eta)
       value(3,i) = xi*eta
       value(4,i) = (1.0d0-xi)*eta
    enddo
    !
    RETURN
  END SUBROUTINE sf2d04
  !
  !***********************************************************************
  !
  SUBROUTINE sf2dg04(npts, pnts, grad, MG1)
    !
    !     four node quadrilateral element (gradients)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MG1
    REAL(RK) :: grad(2,MG1,*), pnts(2,*)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       !
       grad(1,1,i) = eta-1.0d0
       grad(1,2,i) = 1.0d0-eta
       grad(1,3,i) = eta
       grad(1,4,i) = -eta
       !
       grad(2,1,i) =xi-1.0d0
       grad(2,2,i) =-xi
       grad(2,3,i) =xi
       grad(2,4,i) =1.0d0-xi
    enddo
    !
    RETURN
  END SUBROUTINE sf2dg04
  !
  !***********************************************************************
  !
  !     ****** t6 ******
  !
  SUBROUTINE sf2d06(npts, pnts, value, MV1)
    !
    !     six node triangular element (values)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MV1
    REAL(RK) :: value(MV1,*), pnts(2, *)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta, zeta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       zeta = 1.0d0 - xi - eta
       ! nodal locations:
       !
       ! 3
       ! 42
       ! 561
       !
       !
       value(1,i) = (2.0d0*xi-1.0d0)*xi
       value(2,i) = 4.0d0*eta*xi
       value(3,i) = (2.0d0*eta-1.0d0)*eta
       value(4,i) = 4.0d0*eta*zeta
       value(5,i) = (2.0d0*zeta-1.0d0)*zeta
       value(6,i) = 4.0d0*xi*zeta
    enddo
    !
    RETURN
  END SUBROUTINE sf2d06
  !
  !***********************************************************************
  !
  SUBROUTINE sf2dg06(npts, pnts, grad, MG1)
    !
    !     six node triangular element (gradients)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MG1
    REAL(RK) :: grad(2,MG1,*), pnts(2,*)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta, zeta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       zeta = 1.0d0 - xi - eta
       !
       grad(1,1,i) = 4.0d0*xi-1.0d0
       grad(1,2,i) = 4.0d0*eta
       grad(1,3,i) = 0.0d0
       grad(1,4,i) = -4.0d0*eta
       grad(1,5,i) = -4.0d0*zeta+1.0d0
       grad(1,6,i) = 4.0d0*zeta-4.0d0*xi
       !
       grad(2,1,i) = 0.0d0
       grad(2,2,i) = 4.0d0*xi
       grad(2,3,i) = 4.0d0*eta-1.0d0
       grad(2,4,i) = 4.0d0*zeta-4.0d0*eta
       grad(2,5,i) = -4.0d0*zeta+1.0d0
       grad(2,6,i) = -4.0d0*xi
    enddo
    !
    RETURN
  END SUBROUTINE sf2dg06
  !
  !***********************************************************************
  !
  !     ***** q8 *****
  !
  SUBROUTINE sf2d08(npts, pnts, value, MV1)
    !
    !     eight-node quadilateral ( serendipity ) element (values)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MV1
    REAL(RK) :: value(MV1,*), pnts(2, *)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       !
       value(1,i) = (1.0-xi)*(1.0-eta)*(-2.0*xi-2.0*eta+1.0)
       value(2,i) = 4.0*xi*(1.0-xi)*(1.0-eta)
       value(3,i) = xi*(1.0-eta)*(2.0*xi-2.0*eta-1.0)
       value(4,i) = 4.0*xi*eta*(1.0-eta)
       value(5,i) = xi*eta*(2.0*xi+2.0*eta-3.0)
       value(6,i) = 4.0*xi*eta*(1.0-xi)
       value(7,i) = eta*(1.0-xi)*(-2.0*xi+2.0*eta-1.0)
       value(8,i) = 4.0*eta*(1.0-xi)*(1.0-eta)
    enddo
    !
    RETURN
  END SUBROUTINE sf2d08
  !
  !***********************************************************************
  !
  SUBROUTINE sf2dg08(npts, pnts, grad, MG1)
    !
    !     eight-node quadilateral ( serendipity ) element (gradients)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MG1
    REAL(RK) :: grad(2,MG1,*), pnts(2,*)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       !
       grad(1,1,i) = -1.0*(1.0-eta)*(3.0-4.0*xi-2.0*eta)
       grad(1,2,i) = 4.0*(1.0-eta)*(1.0-2.0*xi)
       grad(1,3,i) = (1.0-eta)*(4.0*xi-2.0*eta-1.0)
       grad(1,4,i) = 4.0*eta*(1.0-eta)
       grad(1,5,i) = eta*(4.0*xi+2.0*eta-3.0)
       grad(1,6,i) = 4.0*eta*(1.0-2.0*xi)
       grad(1,7,i) = -eta*(-4.0*xi+2.0*eta+1.0)
       grad(1,8,i) = -4.0*eta*(1.0-eta)
       !
       grad(2,1,i) = -1.0*(1.0-xi)*(3.0-4.0*eta-2.0*xi)
       grad(2,2,i) = -4.0*xi*(1.0-xi)
       grad(2,3,i) = -xi*(2.0*xi-4.0*eta+1.0)
       grad(2,4,i) = 4.0*xi*(1.0-2.0*eta)
       grad(2,5,i) = xi*(2.0*xi+4.0*eta-3.0)
       grad(2,6,i) = 4.0*xi*(1.0-xi)
       grad(2,7,i) = (1.0-xi)*(-2.0*xi+4.0*eta-1.0)
       grad(2,8,i) = 4.0*(1.0-xi)*(1.0-2.0*eta)
    enddo
    !
    RETURN
  END SUBROUTINE sf2dg08
  !
  !***********************************************************************
  !
  !     ***** q9 *****
  !
  SUBROUTINE sf2d09(npts, pnts, value, MV1)
    !
    !     nine-node quadilateral element ( lagrangian ) (values)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MV1
    REAL(RK) :: value(MV1,*), pnts(2, *)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       !
       value(1,i) =  (2.0*xi-1.0)*(2.0*eta-1.0)*(xi-1.0)*(eta-1.0)
       value(2,i) =  4.0*xi*(1.0-xi)*(eta-1.0)*(2.0*eta-1.0)
       value(3,i) =  xi*(2.0*xi-1.0)*(2.0*eta-1.0)*(eta-1.0)
       value(4,i) =  4.0*xi*eta*(2.0*xi-1.0)*(1.0-eta)
       value(5,i) =  xi*eta*(2.0*xi-1.0)*(2.0*eta-1.0)
       value(6,i) =  4.0*xi*eta*(1.0-xi)*(2.0*eta-1.0)
       value(7,i) =  (xi-1.0)*(2.0*xi-1.0)*(2.0*eta-1.0)*eta
       value(8,i) =  4.0*(2.0*xi-1.0)*(xi-1.0)*(1.0-eta)*eta
       value(9,i) =  16.0*xi*eta*(1.0-xi)*(1.0-eta)
    enddo
    !
    RETURN
  END SUBROUTINE sf2d09
  !
  !***********************************************************************
  !
  SUBROUTINE sf2dg09(npts, pnts, grad, MG1)
    !
    !     nine-node quadilateral element ( lagrangian ) (gradients)
    !
    IMPLICIT NONE
    !
    INTEGER  :: npts, MG1
    REAL(RK) :: grad(2,MG1,*), pnts(2,*)
    !
    INTEGER  :: i
    REAL(RK) :: xi, eta
    !
    do i=1, npts
       xi  = pnts(1,i)
       eta = pnts(2,i)
       !
       grad(1,1,i) =  (4.0*xi-3.0)*(2.0*eta-1.0)*(eta-1.0)
       grad(1,2,i) =  4.0*(1.0-2.0*xi)*(eta-1.0)*(2.0*eta-1.0)
       grad(1,3,i) =  (4.0*xi-1.0)*(2.0*eta-1.0)*(eta-1.0)
       grad(1,4,i) =  4.0*eta*(4.0*xi-1.0)*(1.0-eta)
       grad(1,5,i) =  eta*(4.0*xi-1.0)*(2.0*eta-1.0)
       grad(1,6,i) =  4.0*eta*(1.0-2.0*xi)*(2.0*eta-1.0)
       grad(1,7,i) =  (4.0*xi-3.0)*(2.0*eta-1.0)*eta
       grad(1,8,i) =  4.0*eta*(4.0*xi-3.0)*(1.0-eta)
       grad(1,9,i) =  16.0*(1.0-2.0*xi)*(1.0-eta)*eta
       !
       grad(2,1,i) =  (2.0*xi-1.0)*(4.0*eta-3.0)*(xi-1.0)
       grad(2,2,i) =  4.0*xi*(1.0-xi)*(4.0*eta-3.0)
       grad(2,3,i) =  xi*(2.0*xi-1.0)*(4.0*eta-3.0)
       grad(2,4,i) =  4.0*xi*(2.0*xi-1.0)*(1.0-2.0*eta)
       grad(2,5,i) =  xi*(2.0*xi-1.0)*(4.0*eta-1.0)
       grad(2,6,i) =  4.0*xi*(1.0-xi)*(4.0*eta-1.0)
       grad(2,7,i) =  (xi-1.0)*(2.0*xi-1.0)*(4.0*eta-1.0)
       grad(2,8,i) =  4.0*(2.0*xi-1.0)*(xi-1.0)*(1.0-2.0*eta)
       grad(2,9,i) =  16.0*xi*(1.0-xi)*(1.0-2.0*eta)
    enddo
    !
    RETURN
  END SUBROUTINE sf2dg09
  !
  !
END MODULE shape_2_mod


!***********************************************************************
! Routes water between segments in the system using Muskingum routing
!
!   The Muskingum equation is described in 'Hydrology for Engineers', 3rd ed.
!   by Linsley, R.K, Kohler, M.A., and Paulhus, J.L.H., 1982 p. 275 and in
!   'Water in Environmental Planning' by Dunne, T., and Leopold, L.B. 1978
!   p. 357.
!
!   Note that the Muskingum equation assumes a linear relation of storage
!   to the inflow/outflow relation and therefore the relation is the same
!   throughout the range of the hydrograph.  The route_time parameter in
!   the fixroute module is replaced by two new parameters, K_coef and
!   x_coef, which are described below:
!
!   The Muskingum method is based on the equation: S = K[xI + (1 - x)O]
!     where S is storage, K is the storage coefficient, x is a coefficient
!     between 0 and .5, I is inflow, and O is outflow.
!
!   Solving for the outflow at day 2,O2; and knowing the inflow at day 1,
!   I1; the inflow at day 2,I2; and the outflow at day 1, O1; the storage
!   equation can be written as follows:
!
!        O2 = czero*I2 + cone*I1 + ctwo*O1
!
!     where czero = -((Kx - 12)    / (K - Kx + 12))
!           cone  =  (Kx + 12)     / (K - Kx + 12)
!           ctwo  =  (K - Kx - 12) / (K - Kx + 12)
!
!     assuming a time step of one day and K is in units of hours
!
!   This module is based on the "musroute.f" module. It differs in three
!   basic ways:
!
!   1. This module uses an internal routing time step of one hour.
!      The old muskingum module ran on the same daily time step as
!      the rest of PRMS. The problem with this is that there is no
!      ability to distinguish where the flood wave (front of the flow
!      change) within the segment. For example, if there is a series
!      of 4 1-day long segments, a flood wave will make it to the bottom
!      of these in 1 day. If the same system is modeled as 1 4-day long
!      segment, it will take 4 days.
!
!   2. The X parameter has been removed as a specified input and is now computed. To
!      my knowledge, no modeler had ever set this to anything other than the default
!      value (0.2) anyway. Always using the default value can lead to problems
!      with the C coffecients which can result in mass balance problems or negative
!      flow values.
!
!      To solve this problem, I assume that the C coefficients must
!      always be between 0 and 1. By setting the C coefficients equal to 0 and 1,
!      various limits on the time step (ts), X, and K can be determined. There are
!      two of these limits which are of interest:
!
!      When C0 = 0:
!             ts
!        K = -----
!             2X
!
!      When C2 = 0:
!            ts
!       K = -----
!           2(1-X)
!
!      Determining a value of K half way between these two limits (by averaging)
!      and solving for X using the quadratic formula results in:
!
!            1-sqrt(1-(ts/K))
!       X = ------------------
!                  2
!
!       So when ts is fixed at one hour and K is fixed as the average (or expected)
!       travel time corresponding to the segment (for each segment in the stream
!       network), a value of X can be computed (for each segment in the stream
!       network) which will result in both conservation of mass and non-negative
!       flows. Another benefit is that only one input parameter (K) needs to be
!       input to the module.
!
!   3. If the travel time of a segment is less than or equal to the routing
!      time step (one hour), then the outflow of the segment is set to the
!      value of the inflow.
!
!***********************************************************************
      MODULE PRMS_MUSKINGUM
      IMPLICIT NONE
!   Local Variables
      DOUBLE PRECISION, PARAMETER :: ONE_24TH = 1.0D0 / 24.0D0
      INTEGER, SAVE, ALLOCATABLE :: Ts_i(:)
      REAL, SAVE, ALLOCATABLE :: Ts(:), C0(:), C1(:), C2(:)
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Currinsum(:), Pastin(:), Pastout(:)
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Outflow_ts(:), Inflow_ts(:)
      CHARACTER(LEN=9), SAVE :: MODNAME
!   Declared Variables
      DOUBLE PRECISION, SAVE :: Basin_segment_storage
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Segment_delta_flow(:)
!   Declared Parameters
      REAL, SAVE, ALLOCATABLE :: K_coef(:), X_coef(:), Segment_flow_init(:)
      END MODULE PRMS_MUSKINGUM

!***********************************************************************
!     Main muskingum routine
!***********************************************************************
      INTEGER FUNCTION muskingum()
      USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: muskingum_decl, muskingum_init, muskingum_run
      EXTERNAL :: muskingum_restart
!***********************************************************************
      muskingum = 0

      IF ( Process(:3)=='run' ) THEN
        muskingum  = muskingum_run()
      ELSEIF ( Process(:4)=='decl' ) THEN
        muskingum  = muskingum_decl()
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( Init_vars_from_file==1 ) CALL muskingum_restart(1)
        muskingum = muskingum_init()
      ELSEIF ( Process(:5)=='clean' ) THEN
        IF ( Save_vars_to_file==1 ) CALL muskingum_restart(0)
      ENDIF

      END FUNCTION muskingum

!***********************************************************************
!     muskingum_decl - Declare parameters and variables and allocate arrays
!   Declared Parameters
!     tosegment, hru_segment, obsin_segment, K_coef, x_coef
!***********************************************************************
      INTEGER FUNCTION muskingum_decl()
      USE PRMS_MUSKINGUM
      USE PRMS_MODULE, ONLY: Nsegment, Init_vars_from_file
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: declparam, declvar
      EXTERNAL read_error, print_module
! Local Variables
      CHARACTER(LEN=80), SAVE :: Version_muskingum
!***********************************************************************
      muskingum_decl = 0

      Version_muskingum = 'muskingum.f90 2016-07-25 12:06:00Z'
      CALL print_module(Version_muskingum, 'Streamflow Routing          ', 90)
      MODNAME = 'muskingum'

      ALLOCATE ( C1(Nsegment), C2(Nsegment), C0(Nsegment), Ts(Nsegment) )
      ALLOCATE ( Currinsum(Nsegment), Ts_i(Nsegment) )
      ALLOCATE ( Pastin(Nsegment), Pastout(Nsegment) )
      ALLOCATE ( Outflow_ts(Nsegment), Inflow_ts(Nsegment) )

      IF ( declvar(MODNAME, 'basin_segment_storage', 'one', 1, 'double', &
     &     'Basin area-weighted average storage in the stream network', &
     &     'inches', Basin_segment_storage)/=0 ) CALL read_error(3, 'basin_segment_storage')

      ALLOCATE ( Segment_delta_flow(Nsegment) )
      IF ( declvar(MODNAME, 'segment_delta_flow', 'nsegment', Nsegment, 'double', &
     &     'Cummulative flow in minus flow out for each stream segment', &
     &     'cfs', Segment_delta_flow)/=0 ) CALL read_error(3, 'segment_delta_flow')

      ALLOCATE ( K_coef(Nsegment) )
      IF ( declparam(MODNAME, 'K_coef', 'nsegment', 'real', &
     &     '1.0', '0.01', '24.0', &
     &     'Muskingum storage coefficient', &
     &     'Travel time of flood wave from one segment to the next downstream segment,'// &
     &     ' called the Muskingum storage coefficient; enter 1.0 for reservoirs,'// &
     &     ' diversions, and segment(s) flowing out of the basin', &
     &     'hours')/=0 ) CALL read_error(1, 'K_coef')

      ALLOCATE ( X_coef(Nsegment) )
      IF ( declparam(MODNAME, 'x_coef', 'nsegment', 'real', &
     &     '0.2', '0.0', '0.5', &
     &     'Routing weighting factor', &
     &     'The amount of attenuation of the flow wave, called the'// &
     &     ' Muskingum routing weighting factor; enter 0.0 for'// &
     &     ' reservoirs, diversions, and segment(s) flowing out of the basin', &
     &     'decimal fraction')/=0 ) CALL read_error(1, 'x_coef')

      IF ( Init_vars_from_file==0 ) THEN
        ALLOCATE ( Segment_flow_init(Nsegment) )
        IF ( declparam(MODNAME, 'segment_flow_init', 'nsegment', 'real', &
     &       '0.0', '0.0', '1.0E7', &
     &       'Initial flow in each stream segment', &
     &       'Initial flow in each stream segment', &
     &       'cfs')/=0 ) CALL read_error(1, 'segment_flow_init')
      ENDIF

      END FUNCTION muskingum_decl

!***********************************************************************
!    muskingum_init - Get and check parameter values and initialize variables
!***********************************************************************
      INTEGER FUNCTION muskingum_init()
      USE PRMS_MUSKINGUM
      USE PRMS_MODULE, ONLY: Nsegment, Inputerror_flag, Parameter_check_flag, &
     &    Init_vars_from_file
      USE PRMS_BASIN, ONLY: NEARZERO, Basin_area_inv
      USE PRMS_FLOWVARS, ONLY: Seg_inflow, Seg_outflow
      USE PRMS_SET_TIME, ONLY: Cfs_conv
      IMPLICIT NONE
      EXTERNAL :: read_error
      INTEGER, EXTERNAL :: getparam
! Local Variables
      INTEGER :: i, ierr
      REAL :: k, x, d, x_max
!***********************************************************************
      muskingum_init = 0

      IF ( getparam(MODNAME, 'K_coef', Nsegment, 'real', K_coef)/=0 ) CALL read_error(2, 'K_coef')
      IF ( getparam(MODNAME, 'x_coef', Nsegment, 'real', X_coef)/=0 ) CALL read_error(2, 'x_coef')
      IF ( Init_vars_from_file==0 ) THEN
        IF ( getparam(MODNAME, 'segment_flow_init',  Nsegment, 'real', Segment_flow_init)/=0 ) &
     &       CALL read_error(2,'segment_flow_init')
        Seg_inflow = 0.0D0
        DO i = 1, Nsegment
          Seg_outflow(i) = Segment_flow_init(i)
        ENDDO
        DEALLOCATE ( Segment_flow_init )
        Segment_delta_flow = 0.0D0
        Outflow_ts = 0.0D0
      ENDIF
!
!     Compute the three constants in the Muskingum routing equation based
!     on the values of K_coef and a routing period of 1 hour. See the notes
!     at the top of this file.

!
      C0 = 0.0
      C1 = 0.0
      C2 = 0.0
!make sure K>0
      Ts = 1.0
      ierr = 0
      Basin_segment_storage = 0.0D0
      DO i = 1, Nsegment
        Basin_segment_storage = Basin_segment_storage + Seg_outflow(i)
        k = K_coef(i)
        x = X_coef(i)

! check the values of k and x to make sure that Muskingum routing is stable

        IF ( k<1.0 ) THEN
!          IF ( Parameter_check_flag>0 ) THEN
!            PRINT '(/,A,I6,A,F6.2,/,9X,A,/)', 'WARNING, segment ', i, ' has K_coef < 1.0,', k, &
!     &            'this may produce unstable results'
!            ierr = 1
!          ENDIF
          Ts(i) = 0.0
          Ts_i(i) = -1

        ELSEIF ( k<2.0 ) THEN
          Ts(i) = 1.0
          Ts_i(i) = 1

        ELSEIF ( k<3.0 ) THEN
          Ts(i) = 2.0
          Ts_i(i) = 2

        ELSEIF ( k<4.0 ) THEN
          Ts(i) = 3.0
          Ts_i(i) = 3

        ELSEIF ( k<6.0 ) THEN
          Ts(i) = 4.0
          Ts_i(i) = 4

        ELSEIF ( k<8.0 ) THEN
          Ts(i) = 6.0
          Ts_i(i) = 6

        ELSEIF ( k<12.0 ) THEN
          Ts(i) = 8.0
          Ts_i(i) = 8

        ELSEIF ( k<24.0 ) THEN
          Ts(i) = 12.0
          Ts_i(i) = 12

        ELSE
          Ts(i) = 24.0
          Ts_i(i) = 24

        ENDIF

!  x must be <= t/(2K) the C coefficents will be negative. Check for this for all segments
!  with Ts >= minimum Ts (1 hour).
        IF ( Ts(i)>0.1 ) THEN
          x_max = Ts(i) / (2.0 * k)
          IF ( x>x_max ) THEN
            PRINT *, 'ERROR, x_coef value is too large for stable routing for segment:', i, ' x_coef:', x
            PRINT *, '       a maximum value of:', x_max, ' is suggested'
            Inputerror_flag = 1
            CYCLE
          ENDIF
        ENDIF

        d = k - (k * x) + (0.5 * Ts(i))
        IF ( d==0.0 ) THEN
          PRINT *, 'ERROR, segment ', i, ' computed value d = 0.0, change values of K_coef and x_coef'
          Inputerror_flag = 1
        ENDIF
        C0(i) = (-(k * x) + (0.5 * Ts(i))) / d
        C1(i) = ((k * x) + (0.5 * Ts(i))) / d
        C2(i) = (k - (k * x) - (0.5 * Ts(i))) / d

        ! the following code was in the original musroute, but, not in Linsley and others
        ! rsr, 3/1/2016 - having < 0 coefficient can cause negative flows as found by Jacob in GCPO headwater
!  if c2 is <= 0.0 then  short travel time though reach (less daily
!  flows), thus outflow is mainly = inflow w/ small influence of previous
!  inflow. Therefore, keep c0 as is, and lower c1 by c2, set c2=0

!  if c0 is <= 0.0 then long travel time through reach (greater than daily
!  flows), thus mainly dependent on yesterdays flows.  Therefore, keep
!  c2 as is, reduce c1 by c0 and set c0=0
! SHORT travel time
        IF ( C2(i)<0.0 ) THEN
          IF ( Parameter_check_flag>0 ) THEN
            PRINT '(/,A)', 'WARNING, c2 < 0, set to 0, c1 set to c1 + c2'
            PRINT *, '        old c2:', C2(i), '; old c1:', C1(i), '; new c1:', C1(i) + C2(i)
            PRINT *, '        K_coef:', K_coef(i), '; x_coef:', x_coef(i)
          ENDIF
          C1(i) = C1(i) + C2(i)
          C2(i) = 0.0
        ENDIF

! LONG travel time
        IF ( C0(i)<0.0 ) THEN
          IF ( Parameter_check_flag>0 ) THEN
            PRINT '(/,A)', 'WARNING, c0 < 0, set to 0, c0 set to c1 + c0'
            PRINT *, '      old c0:', C0(i), 'old c1:', C1(i), 'new c1:', C1(i) + C0(i)
            PRINT *, '        K_coef:', K_coef(i), '; x_coef:', x_coef(i)
          ENDIF
          C1(i) = C1(i) + C0(i)
          C0(i) = 0.0
        ENDIF

      ENDDO
      IF ( ierr==1 ) PRINT '(/,A,/)', '***Recommend that the Muskingum parameters be adjusted in the Parameter File'
      DEALLOCATE ( K_coef, X_coef)

      Basin_segment_storage = Basin_segment_storage*Basin_area_inv/Cfs_conv

      END FUNCTION muskingum_init

!***********************************************************************
!     muskingum_run - Compute routing summary values
!***********************************************************************
      INTEGER FUNCTION muskingum_run()
      USE PRMS_MUSKINGUM
      USE PRMS_MODULE, ONLY: Nsegment
      USE PRMS_BASIN, ONLY: CFS2CMS_CONV, Basin_area_inv, Obsin_segment, Segment_order, Tosegment
      USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_cms, Basin_gwflow_cfs, Basin_ssflow_cfs, &
     &    Basin_stflow_out, Basin_cfs, Basin_stflow_in, Basin_sroff_cfs, Seg_inflow, Seg_outflow, Seg_upstream_inflow, &
     &    Seg_lateral_inflow, Flow_out
      USE PRMS_OBS, ONLY: Streamflow_cfs
      USE PRMS_SET_TIME, ONLY: Cfs_conv
      USE PRMS_SRUNOFF, ONLY: Basin_sroff
      USE PRMS_GWFLOW, ONLY: Basin_gwflow
      IMPLICIT NONE
! Functions
      INTRINSIC MOD
! Local Variables
      INTEGER :: i, j, iorder, toseg, imod, tspd
      DOUBLE PRECISION :: area_fac, currin
!***********************************************************************
      muskingum_run = 0

!     SET yesterdays inflows and outflows into temp (past arrays)
!     values may be 0.0 as intial, > 0.0 for runtime and dynamic
!     initial condtions. Then set outlfow and inflow for this time
!     step to 0.0
!
!     upstream_inflow and outflow will vary by hour
!     lateral_inflow and everything else will vary by day
!
!     Compute surface runoff, ssflow, and gwflow going to each segment
!     This is todays "seg_inflow" before additional water is routed to
!     a new (if any is routed)
!
!     For each HRU if the lateral flow for this HRU goes to the
!     segment being evaluated (segment i) then sum flows
!
!     Do these calculations once for the current day, before the hourly
!     routing starts.
!
!       Out2   =      In2*C0    +        In1*C1    +          Out1*C2
!     Seg_outflow = Seg_inflow*Czero + Pastinflow*Cone + Pastoutflow*Ctwo
!       C0, C1, and C2: initialized in the "init" part of this module
!
      Pastin = Seg_inflow
      Pastout = Seg_outflow
      Seg_inflow = 0.0D0
      Seg_outflow = 0.0D0
      Inflow_ts = 0.0D0
      Currinsum = 0.0D0

! 24 hourly timesteps per day
      DO j = 1, 24

        Seg_upstream_inflow = 0.0D0
        DO i = 1, Nsegment
          iorder = Segment_order(i)

! current inflow to the segment is the time weighted average of the outflow
! of the upstream segments plus the lateral HRU inflow plus any gains.
          currin = Seg_lateral_inflow(iorder)
          IF ( Obsin_segment(iorder)>0 ) Seg_upstream_inflow(iorder) = Streamflow_cfs(Obsin_segment(iorder))
          currin = currin + Seg_upstream_inflow(iorder)
          Seg_inflow(iorder) = Seg_inflow(iorder) + currin
          Inflow_ts(iorder) = Inflow_ts(iorder) + currin
          Currinsum(iorder) = Currinsum(iorder) + Seg_upstream_inflow(iorder)

          ! Check to see if this segment is to be routed on this time step
          tspd = Ts_i(iorder)
          imod = MOD( j, tspd )
          IF ( imod==0 ) THEN
            Inflow_ts(iorder) = (Inflow_ts(iorder) / Ts(iorder))
! Compute routed streamflow
            IF ( Ts_i(iorder)>0 ) THEN
! Muskingum routing equation
              Outflow_ts(iorder) = Inflow_ts(iorder)*C0(iorder) + Pastin(iorder)*C1(iorder) + Outflow_ts(iorder)*C2(iorder)
            ELSE
! If travel time (K_coef paremter) is less than or equal to
! time step (one hour), then the outflow is equal to the inflow
! Outflow_ts is the value from last hour
              Outflow_ts(iorder) = Inflow_ts(iorder)
            ENDIF

            ! pastin is equal to the Inflow_ts on the previous routed timestep
            Pastin(iorder) = Inflow_ts(iorder)

! because the upstream inflow from streams is used, reset it to zero so new average
! can be computed next routing timestep.
            Inflow_ts(iorder) = 0.0D0
          ENDIF

          ! Seg_outflow (the mean daily flow rate for each segment) will be the average of the hourly values.
          Seg_outflow(iorder) = Seg_outflow(iorder) + Outflow_ts(iorder)
          ! pastout is equal to the Inflow_ts on the previous routed timestep
          Pastout(iorder) = Outflow_ts(iorder)

! Add current timestep's flow rate to sum the upstream flow rates.
! This can be thought of as a volume because it is a volumetric rate
! (cubic feet per second) over a time step of an hour. Down below when
! this value is used, it will be divided by the number of hours in the
! segment's simulation time step, giving the mean flow rate over that
! period of time.
          toseg = Tosegment(iorder)
          IF ( toseg>0 ) Seg_upstream_inflow(toseg) = Seg_upstream_inflow(toseg) + Outflow_ts(iorder)

        ENDDO ! segment

      ENDDO  ! timestep

      Basin_segment_storage = 0.0D0
      Flow_out = 0.0D0
      DO i = 1, Nsegment
        Seg_outflow(i) = Seg_outflow(i) * ONE_24TH
        Seg_inflow(i) = Seg_inflow(i) * ONE_24TH
        Seg_upstream_inflow(i) = Currinsum(i) * ONE_24TH
! Flow_out is the total flow out of the basin, which allows for multiple outlets
! includes closed basins (tosegment=0)
        IF ( Tosegment(i)==0 ) Flow_out = Flow_out + Seg_outflow(i)
        Segment_delta_flow(i) = Segment_delta_flow(i) + Seg_inflow(i) - Seg_outflow(i)
        Basin_segment_storage = Basin_segment_storage + Segment_delta_flow(i)
      ENDDO

      area_fac = Cfs_conv/Basin_area_inv
      Basin_stflow_in = Basin_sroff + Basin_gwflow + Basin_ssflow ! not equal to stflow_out if replacement flows
      Basin_cfs = Flow_out
      Basin_stflow_out = Basin_cfs / area_fac
      Basin_cms = Basin_cfs*CFS2CMS_CONV
      Basin_sroff_cfs = Basin_sroff*area_fac
      Basin_ssflow_cfs = Basin_ssflow*area_fac
      Basin_gwflow_cfs = Basin_gwflow*area_fac
      Basin_segment_storage = Basin_segment_storage/area_fac

      END FUNCTION muskingum_run

!***********************************************************************
!     muskingum_restart - write or read restart file
!***********************************************************************
      SUBROUTINE muskingum_restart(In_out)
      USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit
      USE PRMS_MUSKINGUM
      IMPLICIT NONE
      ! Argument
      INTEGER, INTENT(IN) :: In_out
      ! Function
      EXTERNAL check_restart
      ! Local Variable
      CHARACTER(LEN=9) :: module_name
!***********************************************************************
      IF ( In_out==0 ) THEN
        WRITE ( Restart_outunit ) MODNAME
        WRITE ( Restart_outunit ) Basin_segment_storage
        WRITE ( Restart_outunit ) Segment_delta_flow
        WRITE ( Restart_outunit ) Outflow_ts
        WRITE ( Restart_outunit ) Pastin
        WRITE ( Restart_outunit ) Pastout
      ELSE
        READ ( Restart_inunit ) module_name
        CALL check_restart(MODNAME, module_name)
        READ ( Restart_inunit ) Basin_segment_storage
        READ ( Restart_inunit ) Segment_delta_flow
        READ ( Restart_inunit ) Outflow_ts
        READ ( Restart_inunit ) Pastin
        READ ( Restart_inunit ) Pastout
      ENDIF
      END SUBROUTINE muskingum_restart


      subroutine  intrinsic01

      intrinsic abs,exp,sqrt

      read *, x

      print *, abs(sqrt(x))

      end