      SUBROUTINE MB03AB( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, W1,
     $                   W2, C1, S1, C2, S2 )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute two Givens rotations (C1,S1) and (C2,S2) such that the
C     orthogonal matrix
C
C               [ Q  0 ]        [  C1  S1  0 ]   [ 1  0   0  ]
C           Z = [      ],  Q := [ -S1  C1  0 ] * [ 0  C2  S2 ],
C               [ 0  I ]        [  0   0   1 ]   [ 0 -S2  C2 ]
C
C     makes the first column of the real Wilkinson double shift
C     polynomial of the product of matrices in periodic upper Hessenberg
C     form, stored in the array A, parallel to the first unit vector.
C     Only the rotation defined by C1 and S1 is needed for the real
C     Wilkinson single shift polynomial (see the SLICOT Library routines
C     MB03BE or MB03BF). The shifts are defined based on the eigenvalues
C     (computed externally by the SLICOT Library routine MB03BB) of the
C     trailing 2-by-2 submatrix of the matrix product. See the
C     definitions of the arguments W1 and W2.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SHFT    CHARACTER*1
C             Specifies the number and type of shifts employed by the
C             shift polynomial, as follows:
C             = 'C':  two complex conjugate shifts;
C             = 'D':  two real identical shifts;
C             = 'R':  two real shifts;
C             = 'S':  one real shift.
C             When the eigenvalues are complex conjugate, this argument
C             must be set to 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of the factors in the array A.
C             N >= 2, for a single shift polynomial;
C             N >= 3, for a double shift polynomial.
C
C     AMAP    (input) INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C             AMAP(1) is the pointer to the Hessenberg matrix, defined
C             by A(:,:,AMAP(1)).
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     SINV    (input) INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
C             The leading N-by-N-by-K part of this array must contain an
C             n-by-n product (implicitly represented by its K factors)
C             in periodic upper Hessenberg form.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= N.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= N.
C
C     W1      (input)  DOUBLE PRECISION
C             The real part of the first eigenvalue.
C             If SHFT = 'S', this argument is not used.
C
C     W2      (input)  DOUBLE PRECISION
C             The second eigenvalue, if both eigenvalues are real, else
C             the imaginary part of the complex conjugate pair.
C
C     C1      (output)  DOUBLE PRECISION
C     S1      (output)  DOUBLE PRECISION
C             On exit, C1 and S1 contain the parameters for the first
C             Givens rotation.
C
C     C2      (output)  DOUBLE PRECISION
C     S2      (output)  DOUBLE PRECISION
C             On exit, C2 and S2 contain the parameters for the second
C             Givens rotation. If SHFT = 'S', C2 = 1, S2 = 0.
C
C     METHOD
C
C     Givens rotations are properly computed and applied.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Nov. 2019.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SHFT
      INTEGER           K, LDA1, LDA2, N, SINV
      DOUBLE PRECISION  C1, C2, S1, S2, W1, W2
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*)
C     .. Local Scalars ..
      LOGICAL           ISR, SGLE
      INTEGER           AI, I
      DOUBLE PRECISION  ALPHA, BETA, C23, C3, CX, CY, DELTA, DUM, GAMMA,
     $                  P, S3, SX, SY, TEMP, TMP
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARTG
C
C     .. Executable Statements ..
C
      SGLE = LSAME( SHFT, 'S' )
      AI   = AMAP(1)
      CALL DLARTG( A(2,1,AI), ONE,  C1, S1, TEMP )
      CALL DLARTG( A(1,1,AI), TEMP, C2, S2, TMP  )
C
      DO 10  I = K, 2, -1
         AI = AMAP(I)
         IF ( S(AI).EQ.SINV ) THEN
            ALPHA = A(1,1,AI)*C2 + A(1,2,AI)*C1*S2
            BETA  = A(2,2,AI)*C1
            GAMMA = S1
            CALL DLARTG( BETA,  GAMMA,   C1, S1, TEMP )
            CALL DLARTG( ALPHA, TEMP*S2, C2, S2, DUM )
        ELSE
            ALPHA = S2*A(1,1,AI)
            BETA  = C1*C2*A(2,2,AI) - S2*A(1,2,AI)
            GAMMA = S1*A(2,2,AI)
            CX    = C1
            SX    = S1
            CALL DLARTG( CX, GAMMA, C1, S1, TEMP )
            TEMP = C1*BETA + SX*C2*S1
            CALL DLARTG( TEMP, ALPHA, C2, S2, DUM )
         END IF
   10 CONTINUE
C
      ISR = .NOT.LSAME( SHFT, 'C' )
      IF ( ISR ) THEN
         CALL DLARTG( C2 - W2*S1*S2, C1*S2, C2, S2, TEMP )
         IF ( SGLE ) THEN
            C1 = C2
            S1 = S2
            C2 = ONE
            S2 = ZERO
C
C           Return.
C
            GO TO 30
         ELSE
C
C           Save C2 and S2 for the final use.
C
            CX  = C2
            SX  = S2
            TMP = ONE
         END IF
      ELSE
         TEMP  = S1*S2
         ALPHA = C2 - W1*TEMP
         BETA  = C1*S2
         GAMMA = W2*TEMP
         CALL DLARTG( BETA, GAMMA, C1, S1, TEMP )
         CALL DLARTG( ALPHA, TEMP, C2, S2, DUM  )
         P  = S1*S2
         S2 = C1*S2
C
C        Save CX, SX, CY, and SY for the final use.
C
         CALL DLARTG( C2,   P,  CX, SX, TEMP )
         CALL DLARTG( TEMP, S2, CY, SY, TMP  )
      END IF
C
      I  = 1
      AI = AMAP(I)
C
      ALPHA = A(1,2,AI)*S2 + A(1,1,AI)*C2
      BETA  = A(2,2,AI)*S2 + A(2,1,AI)*C2
      GAMMA = A(3,2,AI)*S2
      CALL DLARTG( GAMMA, TMP,  C1, S1, TEMP )
      CALL DLARTG( BETA,  TEMP, C3, S3, DUM )
      CALL DLARTG( ALPHA, C3*BETA + S3*TEMP, C2, S2, DUM )
C
      DO 20  I = K, 2, -1
         AI = AMAP(I)
         IF ( S(AI).EQ.SINV ) THEN
            TEMP  = C1*S3
            ALPHA = ( A(1,3,AI)*TEMP + A(1,2,AI)*C3 )*S2 + A(1,1,AI)*C2
            BETA  = ( A(2,3,AI)*TEMP + A(2,2,AI)*C3 )*S2
            GAMMA =   A(3,3,AI)*C1
            DELTA =   S1
            CALL DLARTG( GAMMA, DELTA, C1, S1, TEMP )
            TEMP = TEMP*S2*S3
            CALL DLARTG( BETA,  TEMP, C3, S3, TMP )
            CALL DLARTG( ALPHA, TMP,  C2, S2, DUM )
         ELSE
            C23   = C2*C3
            TMP   = C2*S3
            ALPHA = C1*C3*A(3,3,AI)  - S3*A(2,3,AI)
            BETA  = S1*C3
            GAMMA = C1*TMP*A(3,3,AI) + C23*A(2,3,AI) - S2*A(1,3,AI)
            DELTA = S1*TMP
            TMP   = C1
            CALL DLARTG( TMP,  S1*A(3,3,AI), C1, S1, DUM )
            TEMP = ALPHA*C1 + BETA*S1
            CALL DLARTG( TEMP, S3*A(2,2,AI), C3, S3, TMP )
            TEMP = ( C23*A(2,2,AI) - S2*A(1,2,AI) )*C3 +
     $             ( GAMMA*C1 + DELTA*S1 )*S3
            CALL DLARTG( TEMP, S2*A(1,1,AI), C2, S2, DUM )
         END IF
   20 CONTINUE
C
C     Last step: let the rotations collap into the first factor.
C
      IF ( ISR ) THEN
         TEMP  = W1*S1*S3
         ALPHA =   C2 - CX*TEMP*S2
         BETA  = ( C3 - SX*TEMP )*S2
         GAMMA = C1*S2*S3
      ELSE
         P     = S1*S3
         ALPHA =   C2 + ( W2*SX - W1*CX )*CY*P*S2
         BETA  = ( C3 - W1*P*SY )
         P     = S2
         GAMMA = C1*S3
      END IF
      CALL DLARTG( BETA, GAMMA, C2, S2, TEMP )
      IF ( .NOT.ISR )
     $   TEMP = TEMP*P
      CALL DLARTG( ALPHA, TEMP, C1, S1, DUM )
C
   30 CONTINUE
      RETURN
C *** Last line of MB03AB ***
      END


      SUBROUTINE filters( nt, rvector, srate, f1, f2, idb, ifiltyp,
     &                    minphase, iii )
!     FILTERS produces a frequency domain filter which is multiplied
!  with the transformed time series.  The time series is then inverse
!  transformed back to the time domain.
!
!  ARGUMENTS:
!  nt      - The number of time points in rvector.
!  rvector - The time series to be filtered.  The filtered output is
!            returned in rvector.  10000 max
!  srate   - The sample rate in samples per second.
!  f1      - The low corner frequency.
!  f2      - The high corner frequency.
!  idb     - The INTEGER attenuation in dB at first octave (6dB for each
!            pole)
!  ifiltyp - filter type
!          =0, a combination of low and high pass
!          =1, low pass Butterworth, where f1 is the corner frequency
!          =2, high pass Butterworth, where f1 is the corner frequency
!          =3, notch filter, where f1 is the lower frequency and
!               f2 is the upper one.
!  minphase =1 means minimum phase filter, otherwise it is zero phase.
!  iii     =1, generate a new filter, otherwise no filter is generated
!
!  Author: John Shay, Oregon State Univbersity, April 8, 1988
!  mod 31 jan 92 - change array sizes to 5000 from 10000 so that it
!         compiles on the Apollo!
!                - Also commented out an unused factor = statement.
!                - Correct high pass (type 2)
!  mod 1 July 93 - zero from nt+1 to nfft rather with data!
!  mod 20 Jun 95 by mwh - check trace length and make array lengths a
!                  parameter and increase it to a power of 2!
! mod 16 July 95 by Gail Christeson
!       - reduce output amplitudes by nfft
!       - Fix notch filters
! mod 18 Nov 96 - Alistair - Redo minimum phase so that it works in all cases
!  mod 15 Apr. 97 - Make some of filters.f arrays COMMON.
!  mod 16 Oct 03 - Alistair - Add factor of 2 to minimum phase dropoff
!  ????  change MAXLEN to 16384
!  6 June 20 - Change MAXLEN to 32767
!
      INTEGER MAXLEN
!   IF you change MAXLEN, change contro also!
      PARAMETER( MAXLEN = 32767 * 2 )
      REAL maxabsval, rvector(1)
      LOGICAL firsttime
      COMMON /filtersc/ filt1(MAXLEN), refw(MAXLEN),
     &    filtl(MAXLEN), filth(MAXLEN)
      COMPLEX filt1, refw, filtl, filth
      COMPLEX filt(MAXLEN), filtt(1)
      EQUIVALENCE (filt,filtt)
      SAVE filt, firsttime, nfft, nw
      PARAMETER( pi = 3.14159265 )
      DATA nfftold/0/, f1old/0./, f2old/0./, idbold/0/
!
!  mod. June 95 - Change MAXLEN to 8192
!  mod. 23 Oct 95 - Change wording of error message

!      print *,' filters( ',nt, srate,f1,f2,idb,ifiltyp, minphase,iii
      nfft = 0
!     find the next power of 2 larger than nt
!     find the power of 2 of nfft
      npower2 = 1
      nfft = 2
   10 CONTINUE
      IF( nfft .LT. nt ) THEN
          nfft = nfft + nfft
          npower2 = npower2 + 1
          GOTO 10
      ENDIF
      rnfft = REAL(nfft)
!              force a new filter if this filter length is different from the last
      IF( nfft .NE. nfftold ) firsttime = .TRUE.
      nfftold = nfft

!     force a new filter if the corners are different from the last
      IF( f1 .NE. f1old .OR. f2 .NE. f2old ) firsttime = .TRUE.
      f1old = f1
      f2old = f2
      IF( idb .NE. idbold) firsttime = .TRUE.
      idbold = idb

!      IF( iii .EQ. 1 ) firsttime = .TRUE.

      IF( firsttime ) THEN
          deltafreq = 0.
          tsec = nfft / srate
          nw = nfft / 2

          IF( nfft .GT. MAXLEN .OR. nt .GT. MAXLEN ) THEN
              PRINT *,' ***  ERROR  ***  Too much data for freq filt.'
              PRINT *,' Use fewer samples per trace or change filters.f'
              PRINT *,' nt = ',nt,' nw = ',nw,' nfft=',nfft
              STOP
          ENDIF

          DO 500 i = 1, nw+1
             filt(i)  = CMPLX(1.0, 0.0)
             filtl(i) = CMPLX(1.0, 0.0)
             filth(i) = CMPLX(1.0, 0.0)
  500     CONTINUE

          IF( minphase .EQ. 1 ) deltafreq = 2. * pi / tsec

          IF( ifiltyp .EQ. 0 ) THEN
              poles = FLOAT(idb) / 6. + 1.
              tr = 1. / ((f2-deltafreq) * tsec)

              DO j = 1, nw + 1
  501            filtl(j) = filtl(j) / SQRT(1.+(REAL(j-1)*tr)**poles)
              ENDDO

              tr = 1. / ((f1 + deltafreq) * tsec)

              DO 502 j = 1, nw+1
                 factor = (REAL(j-1) * tr) ** poles
                 filth(j) = filth(j) * SQRT(factor / (1. + factor))
  502         CONTINUE

              DO j = 1, nw+1
  503            filt(j) = filtl(j) * filth(j)
              ENDDO

          ELSEIF (ifiltyp .EQ. 1 ) THEN
              poles = FLOAT(idb) / 6. + 1.
              tr = 1. / ((f1-deltafreq) * tsec)
              DO j = 1, nw + 1
  504            filt(j) = filt(j) / SQRT(1.+(REAL(j-1)*tr)**poles)
              ENDDO

          ELSEIF (ifiltyp .EQ. 2 ) THEN
              poles = FLOAT(idb) / 6. + 1.
              tr = 1. / ((f1+deltafreq) * tsec)
              DO j = 1, nw + 1
                 factor = (REAL(j-1) * tr) ** poles
  505            filt(j) = filt(j) * SQRT(factor / (1. + factor))
              ENDDO

          ELSEIF (ifiltyp .EQ. 3 ) THEN
              index1 = IFIX((f1-deltafreq) * tsec) + 1
              index2 = IFIX((f2-deltafreq) * tsec) + 2
              IF( index2 - index1 .LT. 16 ) THEN
                  PRINT *, ' ***  ERROR  ***  Notch too narrow'
                  STOP
              ENDIF
              tr = 1. - 10. ** (-FLOAT(idb) / 20.)
              DO j = index1, index2
  506            filt(j) = filt(j) *
     &       (1.+tr*(COS(2.*pi*REAL((j-index1)/(index2-index1)))-1.)/2.)
              ENDDO
          ENDIF

          IF( minphase .EQ. 1 ) THEN
!   This is the "efficient" version that reduces the number
! of operations - I have checked it on a simple test case, and believe if it
! doesn't work then the original will not work. However if you want to play
! safe the only real change need is for the rnfft scaling
!  Alistair

              DO 507 i = 1, nw+1
                 IF( REAL(filt(i)) .EQ. 0. ) THEN
                     filt(i) = CMPLX(-30.0,0.0)
                 ELSE
                     filt(i) = CMPLX(ALOG(REAL(filt(i))),0.0)
                 ENDIF
  507         CONTINUE

              DO i = nw+2, nw*2
  508            filt(i) = CONJG(filt(nw*2-i+2))
              ENDDO

              CALL fftinv( filt, npower2 )

              DO 509 i = 2, nw+1
                 r = (1. + COS(pi * REAL(i-1) / nw)) / 2.
                 filt(i) = r * filt(i)
  509         continue
!  509            filt(nw*2+2-i) = r * filt(nw*2+2-i)

!              DO 510 i = 1, nw
!  510            filt1(i) = filt(i)

!              DO 511 i = nw+1, nw*2
!  511            filt1(i) = -CONJG(filt(i))
              DO 511 i = nw+1, nfft
                  filt(i) = cmplx(0., 0.)
  511         continue

              CALL fftfwd( filt, npower2 )
!              CALL fftfwd( filt1 , npower2 )

              maxabsval = 0.

!   straight implementation of the analytic Kramers-Kronig
!   relationship - ajh
              DO 512 i = 1, nw+1
!                 filt(i) = CEXP((filt(i) + filt1(i))/2./rnfft)
!                 filt(i) = CEXP(filt(i)/rnfft)
!..                                     Add factor of 2 here ajh.
                 filt(i) = CEXP(2.*filt(i)/rnfft)
                 maxabsval = AMAX1(CABS(filt(i)),maxabsval)
  512         CONTINUE

              IF( maxabsval .EQ. 0. ) THEN
                  PRINT *,' Filter is zero, data not filtered.'
                  RETURN
              ENDIF

              DO i = 1, nw+1
  513            filt(i) = filt(i) / maxabsval
              ENDDO
         ENDIF
         firsttime = .FALSE.
      ENDIF

!     the actual filtering follows
      DO i = 1, nt
  519    refw(i) = CMPLX( rvector(i),0. )
      ENDDO
!     zero fill the backend of the data!
      IF( nt+1 .LT. nfft ) THEN
          DO i = nt+1, nfft
!  520    refw(i) = CMPLX( rvector(i),0. )
  520        refw(i) = CMPLX( 0.,0. )
          ENDDO
      ENDIF
      CALL fftfwd( refw, npower2 )

      DO i = 1, nw+1
!       if( filt(i) .ne. 0. ) print *,' i=',i,' filt=',filt(i)
  521    refw(i) = refw(i) * filt(i)
      ENDDO
      DO i = nw+2, nw*2
  522    refw(i) = CONJG(refw(nw*2-i+2))
      ENDDO

      CALL fftinv( refw, npower2 )

      DO i = 1, nt
  523    rvector(i) = REAL(refw(i)) / nfft
      ENDDO

      RETURN
      END


  SUBROUTINE ice2vapor(ice,sh,t,p,thresh,ice_m,sh_m,rh_m)

  ! Subroutine to convert cloud ice to vapor up to a saturation
  ! threshold (wrt ice)

    IMPLICIT NONE

    ! Inputs:

    REAL, INTENT(IN)    :: ice    ! Cloud ice mixing ratio (kg/kg)
    REAL, INTENT(IN)    :: sh     ! Specific humidity (kg/kg)
    REAL, INTENT(IN)    :: t      ! Temperature (K)
    REAL, INTENT(IN)    :: p      ! Pressure (Pa)
    REAL, INTENT(IN)    :: thresh ! Saturation factor
              ! Set thresh to 1.0 to convert cloud ice up to
              ! ice saturation

    ! Outputs:

    REAL, INTENT(OUT)   :: ice_m  ! Adjusted lwc
    REAL, INTENT(OUT)   :: sh_m   ! Adjusted specific humidity
    REAL, INTENT(OUT)   :: rh_m   ! Adjusted RH (%)

    ! Locals

    REAL :: shsat,mr,mrsat,mr_m,mrmax,tc
    REAL, EXTERNAL :: ssh2,make_rh

    ! Set saturation specific humidity for ice for this point
    tc = t-273.15
    shsat = ssh2(p,tc,tc,0.)*0.001

    ! Convert specific humidity to mixing ratio
    mrsat = shsat/(1.-shsat)
    mr = sh/(1.-sh)
    mrmax = mrsat*thresh

    ! Create modified mr (mr_m) by adding cloud ice

    mr_m = mr + ice

    ! Zero out the modified cloud ice

    ice_m = 0.

    ! If mr_m exceeds mrmax, convert the excess amount
    ! back to cloud ice

    IF (mr_m .GT. mrmax) THEN
      ice_m = mr_m - mrmax
      mr_m = mrmax
    ENDIF

    rh_m = (mr_m/mrsat)*100.

    ! Convert mr_m to sh_m
    sh_m = mr_m/(1.+mr_m)
    RETURN
  END SUBROUTINE ice2vapor


module NumberKindsModule
!------------------------------------------------------------------------------
! Lagrangian Particle / Panel Method - Spherical Model
!------------------------------------------------------------------------------
!
!> @author
!> Peter Bosler, Sandia National Laboratories Center for Computing Research
!
!> @defgroup NumberKinds Number kinds module
!> Defines global numerical constants for use by all LPPM modules and executables.
!>
!
!
! DESCRIPTION:
!> @file
!> Defines global numerical constants for use by all LPPM modules and executables.
!
!------------------------------------------------------------------------------
	implicit none
	public

	!> @defgroup TypeConstants Type Constants
	!> @brief sets compiler-dependent kind variables for primitive data types
	integer, parameter :: KREAL = kind(0.d0)   !<< compiler generated kind for double precision reals @ingroup TypeConstants
	integer, parameter :: KINT = kind(1)	   !<< compiler generated kind for default integer @ingroup TypeConstants
	integer, parameter :: KLOG = kind(.TRUE.)  !<< compiler generated kind logical @ingroup TypeConstants

	real(KREAL), parameter :: ZERO_TOL = 1.0d-10 !<< zero tolerance for real numbers @ingroup TypeConstants

	!> @defgroup PhysicalConstants Physical Constants
	!> @brief Physical constants referenced from @cite CAM3.0
	real(KREAL), parameter :: PI = 3.1415926535897932384626433832795027975_KREAL !<< Pi @ingroup PhysicalConstants
	real(KREAL), parameter :: RAD_2_DEG = 180.0_kreal/PI !<<  convert radians to degrees @ingroup PhysicalConstants
	real(KREAL), parameter :: DEG_2_RAD = PI / 180.0_kreal !<< convert degress to radians @ingroup PhysicalConstants
	real(KREAL), parameter :: GRAV = 9.80616 !<< acceleration due to gravity {m s^(-2)} @ingroup PhysicalConstants
	real(KREAL), parameter :: ONE_DAY = 86140.0_kreal !<< Earth's sidereal day {s} @ingroup PhysicalConstants
	real(KREAL), parameter :: EARTH_RADIUS = 6371220_kreal !<< mean radius of the Earth { m } @ingroup PhysicalConstants
!    real(KREAL), save ::	  OMEGA = 2.0_kreal*PI / ONE_DAY  !<< rotation rate of sphere {s^(-1)} @ingroup PhysicalConstants
    real(KREAL), parameter :: EARTH_SURFACE_AREA = 4.0_kreal * PI * EARTH_RADIUS * EARTH_RADIUS

	!> @defgroup IOConstants I/O Constants
	!> @brief constants for file input and output
	integer(KINT), parameter :: STD_ERR = 0
	integer(KINT), parameter :: STD_IN  = 5
	integer(KINT), parameter :: STD_OUT = 6
	integer(KINT), parameter :: READ_UNIT = 11
	integer(KINT), parameter :: WRITE_UNIT_1 = 12
	integer(KINT), parameter :: WRITE_UNIT_2 = 13
	integer(KINT), parameter :: WRITE_UNIT_3 = 14
	integer(KINT), parameter :: MAX_STRING_LENGTH = 256

	!> @defgroup MeshConstants Mesh and application constants
	!> @brief constants for mesh and problem definition
	integer(KINT), parameter ::	QUAD_PANEL = 4 !<< panelKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter ::	TRI_PANEL = 3 !<< panelKind parameter for triangular panels @ingroup MeshConstants
	integer(KINT), parameter :: PLANAR_GEOM = 81
	integer(KINT), parameter :: SPHERE_GEOM = 82
	integer(KINT), parameter :: EUCLIDEAN_3D = 83
	integer(KINT), parameter ::	MAX_VERTEX_DEGREE = 10 !<< panelKind parameter for triangular panels @ingroup MeshConstants
	integer(KINT), parameter ::	ADVECTION_SOLVER = 90 !<< problemKind parameter for spherical advection @ingroup MeshConstants
	integer(KINT), parameter ::	BVE_SOLVER = 91 !<< problemKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter ::	SWE_SOLVER = 92	!<< problemKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter :: PLANE_SOLVER = 99 !<< problemKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter ::	MAX_POLYGON_SIDES = 20 !<< defines maximum allowable polygon size in a Voronoi mesh @ingroup MeshConstants
	integer(KINT), parameter ::	FREE_BOUNDARIES = 101 !<< boundary condition parameter for planar meshes @ingroup MeshConstants
	integer(KINT), parameter ::	PERIODIC_BOUNDARIES = 102 !<< boundary condition parameter for planar meshes @ingroup MeshConstants
	integer(KINT), parameter :: TRI_HEX_SEED = 201
	integer(KINT), parameter :: QUAD_RECT_SEED = 202
	integer(KINT), parameter :: POLAR_DISC_SEED = 203
	integer(KINT), parameter :: QUAD_RECT_PERIODIC_SEED = 204
	integer(KINT), parameter :: ICOS_TRI_SPHERE_SEED = 205
	integer(KINT), parameter :: CUBED_SPHERE_SEED = 206
	real(KREAL), save :: SphereRadius = 1.0_kreal

	!> @defgroup MPIVariables MPI Variables
	!> @brief variables to define MPI computing environment
	integer(KINT), save :: numProcs = 1 !<< number of processess @ingroup MPIVariables
	integer(KINT), save :: procRank = 0 !<< process rank @ingroup MPIVariables

	interface
		real(8) function scalarFnOf2DSpace( x, y)
			real(8), intent(in) :: x, y
		end function
	end interface

	interface
		real(8) function scalarFnOf3DSpace( x, y, z)
			real(8), intent(in) :: x, y, z
		end function
	end interface

	interface
		function vectorFnOf2DSpace( x, y )
			real(8), dimension(2) :: vectorFnOf2DSpace
			real(8), intent(in) :: x, y
		end function
	end interface

	interface
		function vectorFnOf3DSpace( x, y, z)
			real(8), dimension(3) :: vectorFnOf3DSpace
			real(8), intent(in) :: x, y, z
		end function
	end interface

end module NumberKindsModule


!	Multinomial mean.
!	density is vector of probabilities
!	quadpoint is array of weights.
function mmeanth(density,quadpoint)
implicit none
real(kind=8),intent(in)::density(:),quadpoint(:,:)
real(kind=8)::mmeanth(size(quadpoint,1))
mmeanth=matmul(quadpoint,density)
return

end function mmeanth


      SUBROUTINE SROTMGF (SD1,SD2,SX1,SY1,SPARAM)
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
C     SY2)**T.
C     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
C
C       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
C     H=(          )    (          )    (          )    (          )
C       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
C     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
C     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
C     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
C
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      DIMENSION SPARAM(5)
C
      DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/
      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
      IF(.NOT. SD1 .LT. ZERO) GO TO 10
C       GO ZERO-H-D-AND-SX1..
          GO TO 60
   10 CONTINUE
C     CASE-SD1-NONNEGATIVE
      SP2=SD2*SY1
      IF(.NOT. SP2 .EQ. ZERO) GO TO 20
          SFLAG=-TWO
          GO TO 260
C     REGULAR-CASE..
   20 CONTINUE
      SP1=SD1*SX1
      SQ2=SP2*SY1
      SQ1=SP1*SX1
C
      IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40
          SH21=-SY1/SX1
          SH12=SP2/SP1
C
          SU=ONE-SH12*SH21
C
          IF(.NOT. SU .LE. ZERO) GO TO 30
C         GO ZERO-H-D-AND-SX1..
               GO TO 60
   30     CONTINUE
               SFLAG=ZERO
               SD1=SD1/SU
               SD2=SD2/SU
               SX1=SX1*SU
C         GO SCALE-CHECK..
               GO TO 100
   40 CONTINUE
          IF(.NOT. SQ2 .LT. ZERO) GO TO 50
C         GO ZERO-H-D-AND-SX1..
               GO TO 60
   50     CONTINUE
               SFLAG=ONE
               SH11=SP1/SP2
               SH22=SX1/SY1
               SU=ONE+SH11*SH22
               STEMP=SD2/SU
               SD2=SD1/SU
               SD1=STEMP
               SX1=SY1*SU
C         GO SCALE-CHECK
               GO TO 100
C     PROCEDURE..ZERO-H-D-AND-SX1..
   60 CONTINUE
          SFLAG=-ONE
          SH11=ZERO
          SH12=ZERO
          SH21=ZERO
          SH22=ZERO
C
          SD1=ZERO
          SD2=ZERO
          SX1=ZERO
C         RETURN..
          GO TO 220
C     PROCEDURE..FIX-H..
   70 CONTINUE
      IF(.NOT. SFLAG .GE. ZERO) GO TO 90
C
          IF(.NOT. SFLAG .EQ. ZERO) GO TO 80
          SH11=ONE
          SH22=ONE
          SFLAG=-ONE
          GO TO 90
   80     CONTINUE
          SH21=-ONE
          SH12=ONE
          SFLAG=-ONE
   90 CONTINUE
      GO TO IGO,(120,150,180,210)
C     PROCEDURE..SCALE-CHECK
  100 CONTINUE
  110     CONTINUE
          IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130
               IF(SD1 .EQ. ZERO) GO TO 160
               ASSIGN 120 TO IGO
C              FIX-H..
               GO TO 70
  120          CONTINUE
               SD1=SD1*GAM**2
               SX1=SX1/GAM
               SH11=SH11/GAM
               SH12=SH12/GAM
          GO TO 110
  130 CONTINUE
  140     CONTINUE
          IF(.NOT. SD1 .GE. GAMSQ) GO TO 160
               ASSIGN 150 TO IGO
C              FIX-H..
               GO TO 70
  150          CONTINUE
               SD1=SD1/GAM**2
               SX1=SX1*GAM
               SH11=SH11*GAM
               SH12=SH12*GAM
          GO TO 140
  160 CONTINUE
  170     CONTINUE
          IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190
               IF(SD2 .EQ. ZERO) GO TO 220
               ASSIGN 180 TO IGO
C              FIX-H..
               GO TO 70
  180          CONTINUE
               SD2=SD2*GAM**2
               SH21=SH21/GAM
               SH22=SH22/GAM
          GO TO 170
  190 CONTINUE
  200     CONTINUE
          IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220
               ASSIGN 210 TO IGO
C              FIX-H..
               GO TO 70
  210          CONTINUE
               SD2=SD2/GAM**2
               SH21=SH21*GAM
               SH22=SH22*GAM
          GO TO 200
  220 CONTINUE
          IF(SFLAG)250,230,240
  230     CONTINUE
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               GO TO 260
  240     CONTINUE
               SPARAM(2)=SH11
               SPARAM(5)=SH22
               GO TO 260
  250     CONTINUE
               SPARAM(2)=SH11
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               SPARAM(5)=SH22
  260 CONTINUE
          SPARAM(1)=SFLAG
          RETURN
      END


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for VMF1
C     ----------------------------------------------
      DOUBLE PRECISION VMF1H, VMF1W

      CALL VMF1(0.00127683D0, 0.00060955D0, 55055D0, 0.6708665767D0,
     .  1.278564131D0, VMF1H, VMF1W)

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> VMF1 Results:'
      PRINT *, '----------------------------------------'
      WRITE(*, FMT1) DABS(VMF1H-3.424342122738070593D0)
      WRITE(*, FMT1) DABS(VMF1W-3.448299714692572238D0)

C     ALL DONE
      END


      subroutine ch_watqual3

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine performs in-stream nutrient transformations and water
!!    quality calculations

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name         |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ai0          |ug chla/mg alg|ratio of chlorophyll-a to algal biomass
!!    ai1          |mg N/mg alg   |fraction of algal biomass that is nitrogen
!!    ai2          |mg P/mg alg   |fraction of algal biomass that is phosphorus
!!    ai3          |mg O2/mg alg  |the rate of oxygen production per unit of
!!                                |algal photosynthesis
!!    ai4          |mg O2/mg alg  |the rate of oxygen uptake per unit of algae
!!                                |respiration
!!    ai5          |mg O2/mg N    |the rate of oxygen uptake per unit of NH3
!!                                |nitrogen oxidation
!!    ai6          |mg O2/mg N    |the rate of oxygen uptake per unit of NO2
!!                                |nitrogen oxidation
!!    algae(:)     |mg alg/L      |algal biomass concentration in reach
!!    ammonian(:)  |mg N/L        |ammonia concentration in reach
!!    bc1(:)       |1/day         |rate constant for biological oxidation of NH3
!!                                |to NO2 in reach at 20 deg C
!!    bc2(:)       |1/day         |rate constant for biological oxidation of NO2
!!                                |to NO3 in reach at 20 deg C
!!    bc3(:)       |1/day         |rate constant for hydrolysis of organic N to
!!                                |ammonia in reach at 20 deg C
!!    bc4(:)       |1/day         |rate constant for the decay of organic P to
!!                                |dissolved P in reach at 20 deg C
!!    chlora(:)    |mg chl-a/L    |chlorophyll-a concentration in reach
!!    dayl(:)      |hours         |day length for current day
!!    disolvp(:)   |mg P/L        |dissolved phosphorus concentration in reach
!!    hru_ra(:)    |MJ/m^2        |solar radiation for the day in HRU
!!    inum1        |none          |reach number
!!    inum2        |none          |inflow hydrograph storage location number
!!    k_l          |MJ/(m2*hr)    |half saturation coefficient for light
!!    k_n          |mg N/L        |michaelis-menton half-saturation constant
!!                                |for nitrogen
!!    k_p          |mg P/L        |michaelis-menton half saturation constant
!!                                |for phosphorus
!!    lambda0      |1/m           |non-algal portion of the light extinction
!!                                |coefficient
!!    lambda1      |1/(m*ug chla/L)|linear algal self-shading coefficient
!!    lambda2      |(1/m)(ug chla/L)**(-2/3)
!!                                |nonlinear algal self-shading coefficient
!!    mumax        |1/day         |maximum specific algal growth rate at 20 deg
!!                                |C
!!    nitraten(:)  |mg N/L        |nitrate concentration in reach
!!    nitriten(:)  |mg N/L        |nitrite concentration in reach
!!    organicn(:)  |mg N/L        |organic nitrogen concentration in reach
!!    organicp(:)  |mg P/L        |organic phosphorus concentration in reach
!!    rch_cbod(:)  |mg O2/L       |carbonaceous biochemical oxygen demand in
!!                                |reach
!!    rch_dox(:)   |mg O2/L       |dissolved oxygen concentration in reach
!!    rchdep       |m             |depth of flow on day
!!    rchwtr       |m^3 H2O       |water stored in reach at beginning of day
!!    rhoq         |1/day         |algal respiration rate at 20 deg C
!!    rttime       |hr            |reach travel time
!!    rtwtr        |m^3 H2O       |flow out of reach
!!    tfact        |none          |fraction of solar radiation computed in the
!!                                |temperature heat balance that is
!!                                |photosynthetically active
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    algae(:)    |mg alg/L      |algal biomass concentration in reach
!!    ammonian(:) |mg N/L        |ammonia concentration in reach
!!    chlora(:)   |mg chl-a/L    |chlorophyll-a concentration in reach
!!    disolvp(:)  |mg P/L        |dissolved phosphorus concentration in reach
!!    nitraten(:) |mg N/L        |nitrate concentration in reach
!!    nitriten(:) |mg N/L        |nitrite concentration in reach
!!    organicn(:) |mg N/L        |organic nitrogen concentration in reach
!!    organicp(:) |mg P/L        |organic phosphorus concentration in reach
!!    rch_cbod(:) |mg O2/L       |carbonaceous biochemical oxygen demand in
!!                               |reach
!!    rch_dox(:)  |mg O2/L       |dissolved oxygen concentration in reach
!!    soxy        |mg O2/L       |saturation concetration of dissolved oxygen
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    algcon      |mg alg/L      |initial algal biomass concentration in reach
!!    algi        |MJ/(m2*hr)    |daylight average, photosynthetically active,
!!                               |light intensity
!!    algin       |mg alg/L      |algal biomass concentration in inflow
!!    ammoin      |mg N/L        |ammonium N concentration in inflow
!!    bc1mod      |1/day         |rate constant for biological oxidation of NH3
!!                               |to NO2 modified to reflect impact of low
!!                               |oxygen concentration
!!    bc2mod      |1/day         |rate constant for biological oxidation of NO2
!!                               |to NO3 modified to reflect impact of low
!!                               |oxygen concentration
!!    cbodcon     |mg/L          |initial carbonaceous biological oxygen demand
!!                               |concentration in reach
!!    cbodin      |mg/L          |carbonaceous biological oxygen demand
!!                               |concentration in inflow
!!    chlin       |mg chl-a/L    |chlorophyll-a concentration in inflow
!!    cinn        |mg N/L        |effective available nitrogen concentration
!!    cordo       |none          |nitrification rate correction factor
!!    disoxin     |mg O2/L       |dissolved oxygen concentration in inflow
!!    dispin      |mg P/L        |soluble P concentration in inflow
!!    f1          |none          |fraction of algal nitrogen uptake from
!!                               |ammonia pool
!!    fl_1        |none          |growth attenuation factor for light, based on
!!                               |daylight-average light intensity
!!    fll         |none          |growth attenuation factor for light averaged
!!                               |over the diurnal cycle
!!    fnn         |none          |algal growth limitation factor for nitrogen
!!    fpp         |none          |algal growth limitation factor for phosphorus
!!    gra         |1/day         |local algal growth rate at 20 deg C
!!    jrch        |none          |reach number
!!    lambda      |1/m           |light extinction coefficient
!!    nh3con      |mg N/L        |initial ammonia concentration in reach
!!    nitratin    |mg N/L        |nitrate concentration in inflow
!!    nitritin    |mg N/L        |nitrite concentration in inflow
!!    no2con      |mg N/L        |initial nitrite concentration in reach
!!    no3con      |mg N/L        |initial nitrate concentration in reach
!!    o2con       |mg O2/L       |initial dissolved oxygen concentration in
!!                               |reach
!!    orgncon     |mg N/L        |initial organic N concentration in reach
!!    orgnin      |mg N/L        |organic N concentration in inflow
!!    orgpcon     |mg P/L        |initial organic P concentration in reach
!!    orgpin      |mg P/L        |organic P concentration in inflow
!!    solpcon     |mg P/L        |initial soluble P concentration in reach
!!    tday        |none          |flow duration (fraction of 24 hr)
!!    thbc1       |none          |temperature adjustment factor for local
!!                               |biological oxidation of NH3 to NO2
!!    thbc2       |none          |temperature adjustment factor for local
!!                               |biological oxidation of NO2 to NO3
!!    thbc3       |none          |temperature adjustment factor for local
!!                               |hydrolysis of organic N to ammonia N
!!    thbc4       |none          |temperature adjustment factor for local
!!                               |decay of organic P to dissolved P
!!    thgra       |none          |temperature adjustment factor for local algal
!!                               |growth rate
!!    thrho       |none          |temperature adjustment factor for local algal
!!                               |respiration rate
!!    thrk1       |none          |temperature adjustment factor for local CBOD
!!                               |deoxygenation
!!    thrk2       |none          |temperature adjustment factor for local oxygen
!!                               |reaeration rate
!!    thrk3       |none          |temperature adjustment factor for loss of
!!                               |CBOD due to settling
!!    thrk4       |none          |temperature adjustment factor for local
!!                               |sediment oxygen demand
!!    thrs1       |none          |temperature adjustment factor for local algal
!!                               |settling rate
!!    thrs2       |none          |temperature adjustment factor for local
!!                               |benthos source rate for dissolved phosphorus
!!    thrs3       |none          |temperature adjustment factor for local
!!                               |benthos source rate for ammonia nitrogen
!!    thrs4       |none          |temperature adjustment factor for local
!!                               |organic N settling rate
!!    thrs5       |none          |temperature adjustment factor for local
!!                               |organic P settling rate
!!    wtmp        |deg C         |temperature of water in reach
!!    wtrin       |m^3 H2O       |water flowing into reach on day
!!    uu          |varies        |variable to hold intermediate calculation
!!                               |result
!!    vv          |varies        |variable to hold intermediate calculation
!!                               |result
!!    wtrtot      |m^3 H2O       |inflow + storage water
!!    ww          |varies        |variable to hold intermediate calculation
!!                               |result
!!    xx          |varies        |variable to hold intermediate calculation
!!                               |result
!!    yy          |varies        |variable to hold intermediate calculation
!!                               |result
!!    zz          |varies        |variable to hold intermediate calculation
!!                               |result
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Log, Exp, Min
!!    SWAT: Theta

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~
      !use jrw_datalib_module
      use channel_module
      use hydrograph_module
      use climate_module
      use channel_data_module

      real :: tday, wtmp, fll, gra
      real :: lambda, fnn, fpp, algi, fl_1, xx, yy, zz, ww
      real :: uu, vv, cordo, f1, algcon, orgncon, nh3con, no2con, no3con
      real :: orgpcon, solpcon, cbodcon, o2con, wtrtot, bc1mod, bc2mod
      real :: thgra = 1.047, thrho = 1.047, thrs1 = 1.024
      real :: thrs2 = 1.074, thrs3 = 1.074, thrs4 = 1.024, thrs5 = 1.024
      real :: thbc1 = 1.083, thbc2 = 1.047, thbc3 = 1.047, thbc4 = 1.047
      real :: thrk1 = 1.047, thrk2 = 1.024, thrk3 = 1.024, thrk4 = 1.060
      real :: nitritin         !mg N/L        |nitrite concentration in inflow
      real :: nitratin         !mg N/L        |nitrate concentration in inflow
      real :: soxy             !mg O2/L       |saturation concetration of dissolved oxygen

!!    rnum1        |none          |fraction of overland flow

         !! calculate flow duration
         tday = rttime / 24.0

!        benthic sources/losses in mg

         rs2_s =  Theta(ch_nut(jnut)%rs2,thrs2,wtmp)*ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt
         rs3_s =  Theta(ch_nut(jnut)%rs3,thrs3,wtmp)*ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt
         rk4_s =  Theta(ch_nut(jnut)%rk4,thrk4,wtmp)*ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt

            !! initialize concentration of nutrient in reach
         wtrtot = 0.
         algcon = 0.
         orgncon = 0.
         nh3con = 0.
         no2con = 0.
         no3con = 0.
         orgpcon = 0.
         solpcon = 0.
         cbodcon = 0.
         o2con = 0.
         ch(jrch)%rch_cbod = amax1(1.e-6, ch(jrch)%rch_cbod)

         algcon =ch(jrch)%algae
         orgncon = ch(jrch)%organicn
         nh3con = ch(jrch)%ammonian
         no2con =  ch(jrch)%nitriten
         no3con = ch(jrch)%nitraten
         orgpcon =ch(jrch)%organicp
         solpcon = ch(jrch)%disolvp
         cbodcon= ch(jrch)%rch_cbod
         o2con = ch(jrch)%rch_dox
         if (orgncon < 1.e-6) orgncon = 0.0
	   if (nh3con < 1.e-6) nh3con = 0.0
	   if (no2con < 1.e-6) no2con = 0.0
	   if (no3con < 1.e-6) no3con = 0.0
	   if (orgpcon < 1.e-6) orgpcon = 0.0
	   if (solpcon < 1.e-6) solpcon = 0.0
	   if (cbodcon < 1.e-6) cbodcon = 0.0
	   if (o2con < 1.e-6) o2con = 0.0

         if (wtrin> 0.) then
         disoxin = disoxin - rk4_s /wtrin
         disoxin = max(0., disoxin)
         dispin = dispin + rs2_s / wtrin
         ammoin = ammoin + rs3_s / wtrin

         !! calculate temperature in stream Stefan and Preudhomme. 1993.  Stream temperature estimation
         !! from air temperature.  Water Res. Bull. p. 27-45 SWAT manual equation 2.3.13
         wtmp = 5.0 + 0.75 * wst(iwst)%weat%tave
         if (wtmp <= 0.) wtmp = 0.1

         !! calculate effective concentration of available nitrogen QUAL2E equation III-15
         cinn = nh3con + no3con

         !! calculate saturation concentration for dissolved oxygen
         !! QUAL2E section 3.6.1 equation III-29
         ww = -139.34410 + (1.575701e05 / (wtmp + 273.15))
         xx = 6.642308e07 / ((wtmp + 273.15)**2)
         yy = 1.243800e10 / ((wtmp + 273.15)**3)
         zz = 8.621949e11 / ((wtmp + 273.15)**4)
         soxy = Exp(ww - xx + yy - zz)
         if (soxy < 1.e-6) soxy = 0.
         !! end initialize concentrations

         !! O2 impact calculations

        !! calculate nitrification rate correction factor for low
        !! oxygen QUAL2E equation III-21
	if (o2con.le.0.001) o2con=0.001
	if (o2con.gt.30.) o2con=30.
        cordo = 1.0 - Exp(-0.6 * o2con)
        !! modify ammonia and nitrite oxidation rates to account for low oxygen
        bc1mod = ch_nut(jnut)%bc1 * cordo
        bc2mod = ch_nut(jnut)%bc2 * cordo
!! end O2 impact calculations

!! algal growth
         !! calculate light extinction coefficient
         !! (algal self shading) QUAL2E equation III-12
         if (ch_nut(jnut)%ai0 * algcon > 1.e-6) then
           lambda = ch_nut(jnut)%lambda0 + (ch_nut(jnut)%lambda1 *      &
              ch_nut(jnut)%ai0 * algcon)                                &
              + ch_nut(jnut)%lambda2 * (ch_nut(jnut)%ai0 *              &
              algcon) ** (.66667)
         else
           lambda = ch_nut(jnut)%lambda0
         endif

	   if (lambda > ch_nut(jnut)%lambda0) lambda = ch_nut(jnut)%lambda0
         !! calculate algal growth limitation factors for nitrogen
         !! and phosphorus QUAL2E equations III-13 & III-14
         fnn = cinn / (cinn + ch_nut(jnut)%k_n)
         fpp = solpcon / (solpcon + ch_nut(jnut)%k_p)

         !! calculate daylight average, photosynthetically active,
         !! light intensity QUAL2E equation III-8
         !! Light Averaging Option # 2
         iwgn = wst(iwst)%wco%wgn
         if (wgn_pms(iwgn)%daylth > 0.) then
           algi = wst(iwst)%weat%solrad * ch_nut(jnut)%tfact /  wgn_pms(iwgn)%daylth
         else
           algi = 0.00001
         end if

         !! calculate growth attenuation factor for light, based on
         !! daylight average light intensity QUAL2E equation III-7b
         fl_1 = (1. / (lambda * rchdep)) *                               &
             Log((ch_nut(jnut)%k_l + algi) / (ch_nut(jnut)%k_l + algi *  &
             (Exp(-lambda * rchdep))))
         fll = 0.92 * (wgn_pms(iwgn)%daylth / 24.) * fl_1

         !! calculcate local algal growth rate
         if (algcon < 5000.) then
         select case (ch_nut(jnut)%igropt)
           case (1)
             !! multiplicative QUAL2E equation III-3a
             gra = ch_nut(jnut)%mumax * fll * fnn * fpp
           case (2)
             !! limiting nutrient QUAL2E equation III-3b
             gra = ch_nut(jnut)%mumax * fll * Min(fnn, fpp)
           case (3)
             !! harmonic mean QUAL2E equation III-3c
             if (fnn > 1.e-6 .and. fpp > 1.e-6) then
               gra = ch_nut(jnut)%mumax * fll * 2. / ((1. / fnn) + (1. / fpp))
             else
               gra = 0.
             endif
           end select
        end if

         !! calculate algal biomass concentration at end of day (phytoplanktonic algae)
         !! QUAL2E equation III-2
         ch(jrch)%algae = 0.
         factm = 0.

         alg_m1 = wq_semianalyt (tday, rt_delt, 0., factk, algcon, algin)

         factk = Theta(gra,thgra,wtmp) - Theta(ch_nut(jnut)%rhoq, thrho, wtmp)
         alg_m = wq_semianalyt(tday, rt_delt, 0., factk, algcon, algin)
         alg_m2 = alg_m-alg_m1
         alg_no3_m = -alg_m * (1. - f1) * ch_nut(jnut)%ai1
         alg_nh4_m = -alg_m * f1 * ch_nut(jnut)%ai1
         alg_P_m = -alg_m * ch_nut(jnut)%ai2
         alg_set = 0.
         if (rchdep > 0.001) alg_set = Theta (ch_nut(jnut)%rs1, thrs1, wtmp) / rchdep

         algcon_out = wq_semianalyt (tday, rt_delt, alg_m, -alg_set, algcon, algin)

         ch(jrch)%algae = algcon_out
         if (ch(jrch)%algae < 1.e-6) ch(jrch)%algae = 0.
	     if (ch(jrch)%algae > 5000.) ch(jrch)%algae = 5000.

         !! calculate chlorophyll-a concentration at end of day QUAL2E equation III-1
         ch(jrch)%chlora = ch(jrch)%algae * ch_nut(jnut)%ai0 / 1000.
         !! end algal growth

!! oxygen calculations
         !! calculate carbonaceous biological oxygen demand at end of day QUAL2E section 3.5 equation III-26
         !! adjust rk1 to m-term and BOD & O2 mass availability

         cbodo = min (cbodcon,o2con)
         cbodoin = min (cbodin,disoxin)
         rk1_k = -Theta (ch_nut(jnut)%rk1, thrk1,wtmp)
         rk1_m = wq_k2m (tday, rt_delt, rk1_k, cbodocon, cbodoin)
         ! calculate corresponding m-term
         rk3_k=0.
         if (rchdep > 0.001)  rk3_k = -Theta (ch_nut(jnut)%rk3, thrk3, wtmp) / rchdep
         factm = rk1_m
         factk = rk3_k
         ch(jrch)%rch_cbod = 0.
         ch(jrch)%rch_cbod = wq_semianalyt (tday, rt_delt, factm, factk, cbodcon, cbodin)

!! nitrogen calculations
         !! calculate organic N concentration at end of day
         !! QUAL2E section 3.3.1 equation III-16
         bc1_k = Theta(ch_nut(jnut)%bc1,thbc1,wtmp)
         bc3_k = Theta(ch_nut(jnut)%bc3,thbc3,wtmp)
         rs4_k=0.
         if (rchdep > 0.001)  rs4_k = Theta (ch_nut(jnut)%rs4, thrs4, wtmp) / rchdep

         bc3_m = wq_k2m (tday, rt_delt, -bc3_k, orgncon, orgnin)
         factk =-rs4_k
         factm = bc3_m
         ch(jrch)%organicn = wq_semianalyt (tday, rt_delt, factm, factk, orgncon, orgnin)

          if (ch(jrch)%organicn < 1.e-6) ch(jrch)%organicn = 0.

         !! calculate dissolved oxygen concentration if reach at
         !! end of day QUAL2E section 3.6 equation III-28

         rk2_m = Theta (ch_nut(jnut)%rk2, thrk2, wtmp) * soxy
         rk2_k = Theta (ch_nut(jnut)%rk2, thrk2, wtmp)

         alg_m_o2 = ch_nut(jnut)%ai4 * alg_m2 + ch_nut(jnut)%ai3 * alg_m1

         factk = - rk2_k
         factm = rk1_m + rk2_m - rk4_m + bc1_m * ch_nut(jnut)%ai5 + bc2_m * ch_nut(jnut)%ai6
         ch(jrch)%rch_dox = wq_semianalyt (tday, rt_delt, factm, factk, o2con, disoxin)
         if (ch(jrch)%rch_dox <0.) ch(jrch)%rch_dox = 0.
!! end oxygen calculations

        !! calculate fraction of algal nitrogen uptake from ammonia pool QUAL2E equation III-18
        f1 = ch_nut(jnut)%p_n * nh3con / (ch_nut(jnut)%p_n * nh3con +     &
            (1. - ch_nut(jnut)%p_n) * no3con + 1.e-6)

        !! calculate ammonia nitrogen concentration at end of day QUAL2E section 3.3.2 equation III-17
         factk=-bc1_k
         bc1_m=wq_k2m(tday,rt_delt,factk,nh3con,ammoin)
         factm=bc1_m-bc3_m
         ch(jrch)%ammonian= wq_semianalyt(tday,rt_delt,factm,0.,nh3con,ammoin)
         if (ch(jrch)%ammonian < 1.e-6) ch(jrch)%ammonian = 0.

        !! calculate concentration of nitrite at end of day QUAL2E section 3.3.3 equation III-19
         bc2_k = -Theta(ch_nut(jnut)%bc2,thbc2,wtmp)

        bc2_m= wq_k2m(tday,rt_delt,bc2_k,no2con,nitritin)

        factm=-bc1_m+bc2_m
        ch(jrch)%nitriten = wq_semianalyt(tday,rt_delt,factm,0.,no2con,nitritin)
        if (ch(jrch)%nitriten < 1.e-6) ch(jrch)%nitriten = 0.

        !! calculate nitrate concentration at end of day QUAL2E section 3.3.4 equation III-20
        factk = 0.
        factm = -bc2_m+alg_m_no3

        ch(jrch)%nitraten = wq_semianalyt (tday, rt_delt, factm,0., no3con, nitratin)
        if (ch(jrch)%nitraten < 1.e-6) ch(jrch)%nitraten = 0.
!! end nitrogen calculations

!! phosphorus calculations
        !! calculate organic phosphorus concentration at end of day QUAL2E section 3.3.6 equation III-24
         bc4_k = Theta(ch_nut(jnut)%bc4,thbc4,wtmp)
         ch(jrch)%nitriten = 0.
         bc4_m = wq_k2m(tday,rt_delt,-bc4_k,orgpcon,orgpin)
         rs5_k=0.
         if (rchdep > 0.001) rs5_k = Theta(ch_nut(jnut)%rs5,thrs5,wtmp) / rchdep

        factk=-rs5_k
        factm =bc4_m

        ch(jrch)%organicp = wq_semianalyt (tday, rt_delt, factm, factk, orgpcon, orgpin)
        if (ch(jrch)%organicp < 1.e-6) ch(jrch)%organicp = 0.

        !! calculate dissolved phosphorus concentration at end of day QUAL2E section 3.4.2 equation III-25
        factk = 0.
        factm = -bc4_m+ch_nut(jnut)%ai2 *alg
        ch(jrch)%disolvp = wq_semianalyt (tday, rt_delt, factm, 0., solpcon, dispin)
        if (ch(jrch)%disolvp < 1.e-6) ch(jrch)%disolvp = 0.
!! end phosphorus calculations

      else
        !! all water quality variables set to zero when no flow
        algin = 0.0
        chlin = 0.0
        orgnin = 0.0
        ammoin = 0.0
        nitritin = 0.0
        nitratin = 0.0
        orgpin = 0.0
        dispin = 0.0
        cbodin = 0.0
        disoxin = 0.0
        ch(jrch)%algae = 0.0
        ch(jrch)%chlora = 0.0
        ch(jrch)%organicn = 0.0
        ch(jrch)%ammonian = 0.0
        ch(jrch)%nitriten = 0.0
        ch(jrch)%nitraten = 0.0
        ch(jrch)%organicp = 0.0
        ch(jrch)%disolvp = 0.0
        ch(jrch)%rch_cbod = 0.0
        ch(jrch)%rch_dox = 0.0
        soxy = 0.0
      endif
      return
      end subroutine ch_watqual3


module atsymb
implicit none
save
!
integer, parameter :: natom=105
real,dimension(natom)::ams=(/                                             &
  1.00790D0,  4.00260D0,  6.94000D0,  9.01218D0,                        &
10.81000D0, 12.01100D0, 14.00670D0, 15.99940D0, 18.99840D0,            &
20.17900D0, 22.98977D0, 24.30500D0, 26.98154D0, 28.08550D0,            &
30.97376D0, 32.06000D0, 35.45300D0, 39.94800D0, 39.09830D0,            &
40.08000D0, 44.95590D0, 47.90000D0, 50.94150D0, 51.99600D0,            &
54.93800D0, 55.84700D0, 58.93320D0, 58.71000D0, 63.54600D0,            &
65.38000D0, 69.73500D0, 72.59000D0, 74.92160D0, 78.96000D0,            &
79.90400D0, 83.80000D0, 85.46780D0, 87.62000D0, 88.90590D0,            &
91.22000D0, 92.90640D0, 95.94000D0, 98.90620D0, 101.0700D0,            &
102.9055D0, 106.4000D0, 107.8680D0, 112.4100D0, 114.8200D0,            &
118.6900D0, 121.7500D0, 127.6000D0, 126.9045D0, 131.3000D0,            &
132.9054D0, 137.3300D0,                                                &
138.9063d+00,139.9054d+00,                                             &
140.9076d+00,141.9077d+00,144.9127d+00,151.9197d+00,                &
152.9212d+00,157.9241d+00,158.9253d+00,163.9292d+00,                &
164.9303d+00,165.9303d+00,168.9342d+00,173.9389d+00,                &
174.9408d+00,179.9465d+00,180.9480d+00,183.9509d+00,                &
186.9557d+00,191.9615d+00,192.9629d+00,194.9648d+00,                &
196.9665d+00,201.9706d+00,                &
204.9744d+00,207.9766d+00,208.9804d+00,208.9824d+00,                &
209.9871d+00,222.0176d+00,                &
223.0197d+00,226.0254d+00,                &
227.0278d+00,232.0381d+00,231.0359d+00,238.0508d+00,                &
237.0482d+00,244.0642d+00,243.0614d+00,247.0703d+00,                &
247.0703d+00,251.0796d+00,0.000000d+00,252.0829d+00,                &
257.0751d+00,                &
258.0986d+00,259.1009d+00,260.1053d+00,                &
12.0d+00/)
character*2,dimension(natom)::asymb=(/'H ','He',           &
'Li','Be','B ','C ','N ','O ','F ','Ne',                &
'Na','Mg','Al','Si','P ','S ','Cl','Ar',                &
'K ','Ca','Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu',         &
'Zn','Ga','Ge','As','Se','Br','Kr',                &
'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag',         &
'Cd','In','Sn','Sb','Te','I ','Xe',                &
'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb',         &
'Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re',         &
'Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn',            &
'Fr','Ra','Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk',          &
'Cf','Xx','Es','Fm','Md','No','Lr','Cx'/)
end module atsymb


!! @file mathf.f90
!! @brief This module contains mathematical procedures used in the program.

! Mathematical Procedures
module mathf
    use,intrinsic :: iso_c_binding
    use constants
    !$ use omp_lib
    include 'fftw3.f03'

    ! Integration
    !> 任意の関数に対して積分を計算する
    interface integrate
        module procedure integrate_real, integrate_complex
    end interface
    ! Get Phase Distribution
    !> 任意の値、または配列に対して位相を計算する
    interface phase
        module procedure phase_coordinates, phase_complex
    end interface

    ! FDM
    !> FDM(有限差分法)の精度を指定する
    !! @details 係数は\f$ (2 \times N_d + 1) \f$個分使う
    integer,parameter,private               :: Nd = 3
    !> FDM(有限差分法)の係数を格納する変数
    double precision,allocatable,private    :: C1(:), C2(:)
    ! FTTW
    !> FFTWで用いる内部変数
    type(C_PTR),private                     :: plan_f, plan_b
    !> FFTWで用いる\f$ f(x) \f$に対するポインタ
    type(C_PTR)                             :: pfx
    !> FFTWで用いる\f$ F(k) \f$に対するポインタ
    type(C_PTR)                             :: pFk
    !> FFTWで用いる\f$ g(x) \f$に対するポインタ
    type(C_PTR)                             :: pgx
    !> FFTWで用いる\f$ G(k) \f$に対するポインタ
    type(C_PTR)                             :: pGk
    !> FFTWで用いる波数ベクトル
    double precision,allocatable,private    :: K(:, :), K2(:)
    !> FFTWで用いる配列
    !! @details FFTWによって\f$ f(x) \to F(k) \f$と変換される
    complex(kind(0d0)),pointer,private      :: fx(:), Fk(:)
    !> FFTWで用いる配列
    !! @details FFTWによって\f$ g(x) \to G(k) \f$と変換される
    !! @note プログラム内で用いていないかもしれない。コードから除外？
    complex(kind(0d0)),pointer,private      :: gx(:), Gk(:)
    ! MPI
    !> MPIが使用するプロセッサー数
    integer                                 :: mpi_num_procs = -1
    !> プロセスが対応するMPIのRankが格納される変数
    integer                                 :: mpi_rank = 0
    !> MPIが吐いたエラーが格納される変数
    integer                                 :: mpi_ierr = -1
    ! MISC
    !> 全体のインデックス\f$ i \f$からx軸のインデックス\f$ ix \f$に射影する配列
    integer,allocatable                     :: i2ix(:)
    !> 全体のインデックス\f$ i \f$からy軸のインデックス\f$ iy \f$に射影する配列
    integer,allocatable                     :: i2iy(:)
    !> 全体のインデックス\f$ i \f$からz軸のインデックス\f$ iz \f$に射影する配列
    integer,allocatable                     :: i2iz(:)
    !> それぞれの軸のインデックス\f$ (ix,iy,iz) \f$から全体のインデックス\f$ i \f$に射影する配列
    integer,allocatable                     :: ixyz2i(:, :, :)
    !> ひとつ前の時刻における波動関数
    complex(kind(0d0)),allocatable          :: old_phi(:)
    !> 一時的なデータを格納するための配列
    complex(kind(0d0)),allocatable          :: ztemp(:)
    !> 一時的なデータを格納するための配列
    complex(kind(0d0)),allocatable          :: ztemp2(:)
    !> ハミルトニアンを作用させた配列を格納するための配列
    !! @note 便宜上変数名にPhiを用いているが、必ずしも格納される値は \f$ \hat{H}|\Phi \rangle \f$ではないことに注意。係数や複数のハミルトニアンが既に作用している可能性がある。
    complex(kind(0d0)),allocatable          :: HPhi(:)
    !> 密度を格納する配列
    !! @details Predictor-Corrector法を用いる場合は必ずしも密度と波動関数の時刻は一致しないために宣言される
    double precision,allocatable            :: density(:)
    !> 勾配を計算した結果を格納するための配列
    complex(kind(0d0)),allocatable          :: zgrad(:,:)
    !> 高速フーリエ逆変換を行ったあとの結果を格納するための配列
    complex(kind(0d0)),allocatable          :: drevert(:)
    !> 高速フーリエ変換を行ったあとの結果を格納するための配列
    complex(kind(0d0)),allocatable          :: ztrans(:)
    !> ラプラシアンを計算した結果を格納するための配列
    complex(kind(0d0)),allocatable          :: zlap(:)
    !> \f$ |\nabla F|^2 \f$を計算した結果を格納するための配列
    complex(kind(0d0)),allocatable          :: zAbs2Gradient(:)
    !> 角運動量演算子を作用させた波動関数のx成分を格納する配列
    complex(kind(0d0)),allocatable          :: zLxPhi(:)
    !> 角運動量演算子を作用させた波動関数のy成分を格納する配列
    complex(kind(0d0)),allocatable          :: zLyPhi(:)
    !> 角運動量演算子を作用させた波動関数のz成分を格納する配列
    complex(kind(0d0)),allocatable          :: zLzPhi(:)
    !> 空間の次元が格納される変数であり、setting.f90内のinitialize()を呼ぶことで設定される
    !! @details 1次元のときはDIM=1, 2次元のときはDIM=2, 3次元のときはDIM=3となる
    integer                                 :: DIM         = 0
    !> 空間の微小体積を格納する変数であり、setting.f90内のinitialize()を呼ぶことで設定される
    !! @details 1次元のときはdV=dh, 2次元のときはdV=dh^2, 3次元のときはdV=dh^3となる
    double precision                        :: dV          = 0d0
    !> 微分演算時の境界条件のモードを指定するためのenum
    integer,parameter,private               :: DEFMODE_FDM_ZERO=0,DEFMODE_FDM_PERIODIC=1,DEFMODE_FFT=2
    !> 微分演算時の境界条件のモード
    integer,parameter,private               :: defmode     = DEFMODE_FFT
contains
    ! POSITION ------------------------------------------------------
    !> インデックスからx座標を取得する
    !! @param[in] i インデックス
    !! @return x 座標
    double precision function xpos(i) result(x)
        integer,intent(in) :: i
        !x = dh * i
        x = -xmax + dh * ( i - 1 )
    end function
    !> インデックスからy座標を取得する
    !! @param[in] j インデックス
    !! @return y 座標
    double precision function ypos(j) result(y)
        integer,intent(in) :: j
        !y = dh * j
        y = -ymax + dh * ( j - 1 )
    end function
    !> インデックスからz座標を取得する
    !! @param[in] k_ インデックス
    !! @return z 座標
    double precision function zpos(k_) result(z)
        integer,intent(in) :: k_
        !z = dh * k
        z = -zmax + dh * ( k_ - 1 )
    end function
    ! ---------------------------------------------------------------

    ! INTEGRATION----------------------------------------------------
    !> 実数が格納された配列を台形公式で積分する
    !! @param[in] f 実数配列
    !! @return result 結果
    function integrate_real(f) result(result)
        double precision,intent(in)  :: f(1:NL)
        double precision             :: result
        result = sum(f) * dV
    end function
    !> 実数が格納された配列を指定された円形範囲で積分する
    !! @param[in] f 実数配列
    !! @param[in] r 積分範囲の半径
    !! @return result 結果
    function integrate_real_radius(f, r) result(result)
        double precision,intent(in)  :: f(1:NL)
        double precision,intent(in)  :: r
        double precision             :: result
        integer                      :: ix, iy, iz, i
        double precision             :: x, y, z
        result = 0d0
        do iz = 1, Nz
            z = zpos(iz)
            do iy = 1, Ny
                y = ypos(iy)
                do ix = 1, Nx
                    x = xpos(ix)
                    i = ixyz2i(ix, iy, iz)

                    if (x * x + y * y + z * z  < r * r) then
                        result = result + f(i) * dV
                    end if
                end do
            end do
        end do
    end function
    ! Integration of complex function
    ! Note that f must be function of real (even if it's treated as complex in code)
    ! and of course, the returned value should be also real.
    !> 複素数が格納された配列を台形公式で積分する
    !! @param[in] f 複素数配列
    !! @return result 結果
    function integrate_complex(f) result(result)
        complex(kind(0d0)),intent(in)  :: f(1:NL)
        double precision               :: result
        result = sum( dble(f) ) * dV
    end function
    ! ---------------------------------------------------------------

    ! Normalize a function to 1 ----------------------------------
    !> 配列を規格化する
    !! @param[in,out] F 複素数配列
    subroutine normalize(F)
        complex(kind(0d0)),intent(inout) :: F(1:NL)
        F = F / sqrt( integrate( abs(F)**2 ) )
        F = F * sqrt( dble( ParticleN ) )
    end subroutine normalize
    ! ---------------------------------------------------------------

    ! Time evolution with Taylor expansion --------------------------
    !> 波動関数を(虚)時間発展させる
    !! @param[in,out] Phi 波動関数
    !! @param[in] Pot 外場ポテンシャル
    !! @param[in] Omega_z 容器の回転角速度
    !! @param[in] isimag 虚時間発展で計算するか否か
    subroutine evolve(Phi, Pot, OMEGA_z, isimag)
        complex(kind(0d0)),intent(inout)     :: Phi(1:NL)
        double precision,intent(in)          :: Pot(1:NL)
        double precision,intent(in)          :: OMEGA_z(1:Nz)
        logical,intent(in)                   :: isimag
        integer                              :: iter
        double precision                     :: mu
        integer,parameter                    :: Nexp = 15

        ! Save old wave function temporarily
        old_phi = Phi

        if (isimag) then
            ! IMAGINARY TIME EVOLUTION ------------------------------------------------------
            ! First term of Taylor expansion
            ztemp = old_phi
            Phi   = old_phi
            ! Other terms of Taylor expansion
            do iter = 1, 1
                call H(ztemp, density, Pot, OMEGA_z)
                ztemp = - HPhi * dt_imag / iter
                Phi   = Phi + ztemp
            end do
            call normalize(Phi)
        else
            ! REAL TIME EVOLUTION -----------------------------------------------------------
            mu = calc_mu(old_phi, Pot, OMEGA_z)

            ! PC = Predictor-Corrector
            if ( is_PC_enabled ) then
                ! First term of Taylor expansion
                ztemp = old_phi
                Phi = old_phi
                ! Other terms of Taylor expansion
                do iter = 1, Nexp
                    call H(ztemp, abs(old_phi)**2, Pot, OMEGA_z)
                    ztemp2 = HPhi - mu * ztemp
                    ztemp  = ( 1d0 / ( iu - gamma ) ) * ztemp2 * dt_real * 0.5 / iter
                    Phi    = Phi + ztemp
                end do
                density = abs(Phi)**2
            else
                density = abs(old_phi)**2
            end if

            ! First term of Taylor expansion
            ztemp = old_phi
            Phi   = old_phi
            ! Other terms of Taylor expansion
            do iter = 1, Nexp
                call H(ztemp, density, Pot, OMEGA_z)
                ztemp2 = HPhi - mu * ztemp
                ztemp  = ( 1d0 / ( iu - gamma ) ) * ztemp2 * dt_real / iter
                Phi    = Phi + ztemp
            end do
        end if
    end subroutine evolve

    !> 化学ポテンシャルを計算する
    !! @param[in,out] Phi 波動関数
    !! @param[in] Pot 外場ポテンシャル
    !! @param[in] Omega_z 容器の回転角速度
    double precision function calc_mu(Phi, Pot, OMEGA_z)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        double precision,intent(in)    :: Pot(1:NL)
        double precision,intent(in)    :: OMEGA_z(1:Nz)

        ! <Phi|H|Phi> = <H>
        ! Chemical potential and Total energy per particle are different.
        call H(Phi, abs(Phi)**2, Pot, OMEGA_z)
        calc_mu = integrate( conjg(Phi) * HPhi ) / integrate( abs(Phi)**2 )
    end function

    ! H(ρ,V,Ω)|Phi>
    !> ハミルトニアンを作用させた\f$ \hat{H}|\Phi\rangle \f$を計算する
    !! @param[in,out] Phi 波動関数
    !! @param[in] density GP方程式内の非線形項における密度配列
    !! @param[in] Pot 外場ポテンシャル
    !! @param[in] Omega_z 容器の回転角速度
    subroutine H(Phi, density_, Pot, OMEGA_z)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        double precision,intent(in)    :: Pot(1:NL)
        double precision,intent(in)    :: density_(1:NL)
        double precision,intent(in)    :: OMEGA_z(1:Nz)
        complex(kind(0d0))             :: temp(1:NL)
        integer                        :: i
        HPhi = 0d0
        temp = transform_fftw(Phi)

        call laplacian_fftw(temp)
        HPhi = HPhi - 0.5d0 * zlap

        HPhi = HPhi + Pot * Phi

        call gradient_fftw(temp)
        call LzPhi(Phi, zgrad)
        i = 1
        do iz = 1, Nz
            do iy = 1, Ny
                do ix = 1, Nx
                    HPhi(i) = HPhi(i) - OMEGA_z(iz) * zLzPhi(i)
                    i = i + 1
                end do
            end do
        end do

        HPhi = HPhi + density_ * Phi
    end subroutine
    ! ---------------------------------------------------------------

    !> FDM(有限差分法)とFFT(高速フーリエ変換)を行うための前準備を行う
    !! @details この関数は微分操作を行う前に必ず呼ばれなければいけない
    subroutine prepare_derivative()
        call prepare_FDM
        if ( defmode == DEFMODE_FFT ) then
            call new_fftw
        end if
    end subroutine

    ! Must be called in the first place
    !> OpenMP と OpenMPI による並列化の前準備を行う
    !! @details この関数は全ての算術操作を行う前に必ず呼ばれなければいけない
    subroutine prepare_mpi()
        integer iret, nthreads_omp, nthreads_fftw

        ! FFTW THREADS ###############
        nthreads_fftw = 3
        call dfftw_init_threads(iret)
        call dfftw_plan_with_nthreads(nthreads_fftw)
        ! OpenMP ####################
        nthreads_omp  = nthreads_fftw
        if ( nthreads_omp > 1 ) then
            !$ call omp_set_num_threads(nthreads_omp)
            !$ write (*, *) "OpenMP is successfully initiated."
        else
            !$ call omp_set_num_threads(1)
        end if
        ! ############################
        if ( mpi_rank == 0 ) then
            write (*, '(1X,3(A, I0))') "FFTW_THREADS = ", nthreads_fftw, ", OMP_THREADS = ", nthreads_omp, ", FFTW_CODE = ", iret
        end if
        ! MPI ########################
        !call MPI_Init(mpi_ierr)
        !call fftw_mpi_init
        !call MPI_Comm_size(MPI_COMM_WORLD, mpi_num_procs, mpi_ierr)
        !call MPI_Comm_rank(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
        ! ############################
    end subroutine

    ! Prepare Finite Difference Method  -----------------------------
    !> FDM(有限差分法)の係数を計算する
    subroutine prepare_FDM()
        integer :: i
        allocate( C1(-Nd:Nd), C2(-Nd:Nd) )
        C1 = 0d0
        C2 = 0d0
        ! 1st derivative
        do i = 1, Nd
            if ( i == 1 ) then
                C1(1) = Nd / ( Nd + 1d0 )
            else
                C1(i) = -C1(i-1) * ( i - 1 ) * ( Nd - i + 1d0 ) / ( i * ( Nd + i ) )
            end if
            C1(-i) = -C1(i)
        end do
        C1 = C1 / dh

        ! 2nd derivative
        do i = 1, Nd
          if ( i == 1 ) then
            C2(1) = 2d0 * Nd / ( Nd + 1d0 )
          else
            C2(i) = -C2(i-1) * ( i - 1d0 )**2 * ( Nd - i + 1d0 ) / ( i**2 * ( Nd + i ) )
          end if
          C2(-i) = C2(i)
          C2(0) = C2(0) + C2(i)
        end do
        C2(0) = -2d0 * C2(0)
        C2 = C2 / ( dh * dh )
    end subroutine
    ! ---------------------------------------------------------------

    ! Calculate Laplacian of a function -----------------------------
    !> FDM(有限差分法)を用いてラプラシアンを固定境界条件で計算する
    !! @details 波動関数が境界でゼロになることを仮定しているため、円柱トラップでは使えない
    !! @details 計算結果は\f$ zlap \f$ に格納される
    !! @param[in] F 複素数配列
    subroutine Laplacian_Zero(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        integer                       :: ix, iy, iz, i, id, ip
        zlap = (0d0, 0d0)

        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i); iz = i2iz(i);
            do id = -Nd, Nd
                if ( 1 <= ix + id .and. ix + id <= Nx ) then
                    ip = ixyz2i(ix + id, iy, iz)
                    zlap(i) = zlap(i) + F(ip) * C2(id)
                end if
            end do

            if ( Ny > 1 ) then
                ix = i2ix(i); iy = i2iy(i); iz = i2iz(i);
                do id = -Nd, Nd
                    if ( 1 <= iy + id .and. iy + id <= Ny ) then
                        ip = ixyz2i(ix, iy + id, iz)
                        zlap(i) = zlap(i) + F(ip) * C2(id)
                    end if
                end do
            end if

            if ( Nz > 1 ) then
                ix = i2ix(i); iy = i2iy(i); iz = i2iz(i);
                do id = -Nd, Nd
                    if ( 1 <= iz + id .and. iz + id <= Nz ) then
                        ip = ixyz2i(ix, iy, iz + id)
                        zlap(i) = zlap(i) + F(ip) * C2(id)
                    end if
                end do
            end if
        end do
    end subroutine
    !> FDM(有限差分法)を用いてラプラシアンを周期境界条件で計算する
    !! @details 計算結果は配列\f$ zlap \f$ に格納される
    !! @param[in] F 複素数配列
    subroutine Laplacian_Periodic(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        integer                       :: ix, iy, iz, i, id, ip
        zlap = (0d0, 0d0)

        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i); iz = i2iz(i);
            do id = -Nd, Nd
                if ( 1 <= ix + id .and. ix + id <= Nx ) then
                    ip = ixyz2i(ix + id, iy, iz)
                    zlap(i) = zlap(i) + F(ip) * C2(id)
                else
                    if ( 1 > ix + id ) then
                        ip = ixyz2i(Nx + (ix + id), iy, iz)
                        zlap(i) = zlap(i) + F(ip) * C2(id)
                    else
                        ip = ixyz2i(ix + id - Nx, iy, iz)
                        zlap(i) = zlap(i) + F(ip) * C2(id)
                    end if
                end if
            end do
        end do

        if ( Ny > 1 ) then
            do i = 1, NL
                ix = i2ix(i); iy = i2iy(i); iz = i2iz(i);
                do id = -Nd, Nd
                    if ( 1 <= iy + id .and. iy + id <= Ny ) then
                        ip = ixyz2i(ix, iy + id, iz)
                        zlap(i) = zlap(i) + F(ip) * C2(id)
                    else
                        if ( 1 > iy + id ) then
                            ip = ixyz2i(ix, Ny + (iy + id), iz)
                            zlap(i) = zlap(i) + F(ip) * C2(id)
                        else
                            ip = ixyz2i(ix, iy + id - Ny, iz)
                            zlap(i) = zlap(i) + F(ip) * C2(id)
                        end if
                    end if
                end do
            end do
        end if

        if ( Nz > 1 ) then
            do i = 1, NL
                ix = i2ix(i); iy = i2iy(i); iz = i2iz(i);
                do id = -Nd, Nd
                    if ( 1 <= iz + id .and. iz + id <= Nz ) then
                        ip = ixyz2i(ix, iy, iz + id)
                        zlap(i) = zlap(i) + F(ip) * C2(id)
                    else
                        if ( 1 > iz + id ) then
                            ip = ixyz2i(ix, iy, Nz + (iz + id))
                            zlap(i) = zlap(i) + F(ip) * C2(id)
                        else
                            ip = ixyz2i(ix, iy, iz + id - Nz)
                            zlap(i) = zlap(i) + F(ip) * C2(id)
                        end if
                    end if
                end do
            end do
        end if
    end subroutine
    !> 複素数配列に対してラプラシアンを計算する
    !! @details 境界条件ではグローバル変数の\f( defmode \f)によって指定される
    !! @details 演算結果はグローバル変数の\f( zlap \f)に格納される
    !! @param[in] F 実数配列
    subroutine Laplacian(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        double precision              :: t2, t1
        complex(kind(0d0))            :: temp(1:NL)

        select case ( defmode )
        case ( DEFMODE_FDM_PERIODIC )
            call Laplacian_Periodic(F)
        case ( DEFMODE_FDM_ZERO )
            call Laplacian_Zero(F)
        case ( DEFMODE_FFT )
            temp = transform_fftw(F)
            call laplacian_fftw( temp )
        end select
    end subroutine
    ! ---------------------------------------------------------------

    ! A partial derivative of a function F with respect to X --------
    !> 実数配列に対して \f$ d/dx \f$ を計算する
    !! @details 計算結果は\f$ zgrad(:,1) \f$に格納される
    !! @param[in] F 実数配列
    subroutine dF_dX_REAL(F)
        double precision,intent(in) :: F(1:NL)
        integer                     :: ix, iy, iz, i, id, ip
        zgrad(:, 1) = (0d0, 0d0)

        do i = 1, NL
            ix = i2ix(i)
            iy = i2iy(i)
            iz = i2iz(i)
            do id = -Nd, Nd
                if ( id == 0 ) cycle
                if ( 1 <= ix + id .and. ix + id <= Nx ) then
                    ip = ixyz2i(ix + id, iy, iz)
                    zgrad(i, 1) = zgrad(i, 1) + F(ip) * C1(id)
                else
                    if ( defmode == DEFMODE_FDM_ZERO ) cycle
                    if ( 1 > ix + id ) then
                        ip = ixyz2i(Nx + (ix + id), iy, iz)
                        zgrad(i, 1) = zgrad(i, 1) + F(ip) * C1(id)
                    else
                        ip = ixyz2i(ix + id - Nx, iy, iz)
                        zgrad(i, 1) = zgrad(i, 1) + F(ip) * C1(id)
                    end if
                end if
            end do
        end do
    end subroutine
    !> 複素数配列に対して \f$ d/dx \f$ を計算する
    !! @details 計算結果は\f$ zgrad(:,1) \f$に格納される
    !! @param[in] F 複素数配列
    subroutine dF_dX_COMPLEX(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        integer                       :: ix, iy, iz, i, id, ip
        zgrad(:, 1) = (0d0, 0d0)

        do i = 1, NL
            ix = i2ix(i)
            iy = i2iy(i)
            iz = i2iz(i)
            do id = -Nd, Nd
                if ( id == 0 ) cycle
                if ( 1 <= ix + id .and. ix + id <= Nx ) then
                    ip = ixyz2i(ix + id, iy, iz)
                    zgrad(i, 1) = zgrad(i, 1) + F(ip) * C1(id)
                else
                    if ( defmode == DEFMODE_FDM_ZERO ) cycle
                    if ( 1 > ix + id ) then
                        ip = ixyz2i(Nx + (ix + id), iy, iz)
                        zgrad(i, 1) = zgrad(i, 1) + F(ip) * C1(id)
                    else
                        ip = ixyz2i(ix + id - Nx, iy, iz)
                        zgrad(i, 1) = zgrad(i, 1) + F(ip) * C1(id)
                    end if
                end if
            end do
        end do
    end subroutine
    ! ---------------------------------------------------------------

    ! A partial derivative of a function F with respect to Y --------
    !> 実数配列に対して \f$ d/dy \f$ を計算する
    !! @details 計算結果は\f$ zgrad(:,2) \f$に格納される
    !! @param[in] F 実数配列
    subroutine dF_dY_REAL(F)
        double precision,intent(in) :: F(1:NL)
        integer                       :: ix, iy, iz, i, id, ip
        zgrad(:, 2) = (0d0, 0d0)

        if ( Ny > 1 ) then
            do i = 1, NL
                ix = i2ix(i)
                iy = i2iy(i)
                iz = i2iz(i)
                do id = -Nd, Nd
                    if ( id == 0 ) cycle
                    if ( 1 <= iy + id .and. iy + id <= Ny ) then
                        ip = ixyz2i(ix, iy + id, iz)
                        zgrad(i, 2) = zgrad(i, 2) + F(ip) * C1(id)
                    else
                        if ( defmode == DEFMODE_FDM_ZERO ) cycle
                        if ( 1 > iy + id ) then
                            ip = ixyz2i(ix, Ny + (iy + id), iz)
                            zgrad(i, 2) = zgrad(i, 2) + F(ip) * C1(id)
                        else
                            ip = ixyz2i(ix, iy + id - Ny, iz)
                            zgrad(i, 2) = zgrad(i, 2) + F(ip) * C1(id)
                        end if
                    end if
                end do
            end do
        end if
    end subroutine
    !> 複素数配列に対して \f$ d/dy \f$ を計算する
    !! @details 計算結果は\f$ zgrad(:,2) \f$に格納される
    !! @param[in] F 複素数配列
    subroutine dF_dY_COMPLEX(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        integer                       :: ix, iy, iz, i, id, ip
        zgrad(:, 2) = (0d0, 0d0)

        if ( Ny > 1 ) then
            do i = 1, NL
                ix = i2ix(i)
                iy = i2iy(i)
                iz = i2iz(i)
                do id = -Nd, Nd
                    if ( id == 0 ) cycle
                    if ( 1 <= iy + id .and. iy + id <= Ny ) then
                        ip = ixyz2i(ix, iy + id, iz)
                        zgrad(i, 2) = zgrad(i, 2) + F(ip) * C1(id)
                    else
                        if ( defmode == DEFMODE_FDM_ZERO ) cycle
                        if ( 1 > iy + id ) then
                            ip = ixyz2i(ix, Ny + (iy + id), iz)
                            zgrad(i, 2) = zgrad(i, 2) + F(ip) * C1(id)
                        else
                            ip = ixyz2i(ix, iy + id - Ny, iz)
                            zgrad(i, 2) = zgrad(i, 2) + F(ip) * C1(id)
                        end if
                    end if
                end do
            end do
        end if
    end subroutine
    ! ---------------------------------------------------------------

    ! A partial derivative of a function F with respect to Z --------
    !> 実数配列に対して \f$ d/dz \f$ を計算する
    !! @details 計算結果は\f$ zgrad(:,3) \f$に格納される
    !! @param[in] F 実数配列
    subroutine dF_dZ_REAL(F)
        double precision,intent(in) :: F(1:NL)
        integer                     :: ix, iy, iz, i, id, ip
        zgrad(:, 3) = (0d0, 0d0)

        if ( Nz > 1 ) then
            do i = 1, NL
                ix = i2ix(i)
                iy = i2iy(i)
                iz = i2iz(i)
                do id = -Nd, Nd
                    if ( id == 0 ) cycle
                    if ( 1 <= iz + id .and. iz + id <= Nz ) then
                        ip = ixyz2i(ix, iy, iz + id)
                        zgrad(i, 3) = zgrad(i, 3) + F(ip) * C1(id)
                    else
                        if ( defmode == DEFMODE_FDM_ZERO ) cycle
                        if ( 1 > iz + id ) then
                            ip = ixyz2i(ix, iy, Nz + (iz + id))
                            zgrad(i, 3) = zgrad(i, 3) + F(ip) * C1(id)
                        else
                            ip = ixyz2i(ix, iy, iz + id - Nz)
                            zgrad(i, 3) = zgrad(i, 3) + F(ip) * C1(id)
                        end if
                    end if
                end do
            end do
        end if
    end subroutine
    !> 複素数配列に対して \f$ d/dz \f$ を計算する
    !! @details 計算結果は\f$ zgrad(:,3) \f$に格納される
    !! @param[in] F 複素数配列
    subroutine dF_dZ_COMPLEX(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        integer                       :: ix, iy, iz, i, id, ip
        zgrad(:,3) = (0d0, 0d0)

        if ( Nz > 1 ) then
            do i = 1, NL
                ix = i2ix(i)
                iy = i2iy(i)
                iz = i2iz(i)
                do id = -Nd, Nd
                    if ( id == 0 ) cycle
                    if ( 1 <= iz + id .and. iz + id <= Nz ) then
                        ip = ixyz2i(ix, iy, iz + id)
                        zgrad(i, 3) = zgrad(i, 3) + F(ip) * C1(id)
                    else
                        if ( defmode == DEFMODE_FDM_ZERO ) cycle
                        if ( 1 > iz + id ) then
                            ip = ixyz2i(ix, iy, Nz + (iz + id))
                            zgrad(i, 3) = zgrad(i, 3) + F(ip) * C1(id)
                        else
                            ip = ixyz2i(ix, iy, iz + id - Ny)
                            zgrad(i, 3) = zgrad(i, 3) + F(ip) * C1(id)
                        end if
                    end if
                end do
            end do
        end if
    end subroutine
    ! ---------------------------------------------------------------

    ! Calculate Gradient of a function -----------------------------
    !> 複素数配列に対して勾配\f$ \nabla F  \f$を計算する
    !! @details 計算結果は\f$ zgrad \f$に格納され、配列の次元はそれぞれインデックス、空間軸を指す
    !! @param[in] F 複素数配列
    subroutine Gradient(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        complex(kind(0d0))            :: temp(1:NL)
        if ( defmode == DEFMODE_FFT ) then
            temp = transform_fftw( F )
            call gradient_fftw( temp )
        else
            call dF_dX_COMPLEX(F)
            call dF_dY_COMPLEX(F)
            call dF_dZ_COMPLEX(F)
        end if
    end subroutine Gradient
    ! ---------------------------------------------------------------

    ! Calculate |∇F|^2 ----------------------------------------------
    !> 複素数配列に対して \f$ |\nabla F|^2 \f$ を計算する
    !! @details 計算結果は\f$ zAbs2Gradient \f$に格納される
    !! @param[in] F 複素数配列
    subroutine Abs2Gradient(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        call Gradient(F)
        zAbs2Gradient = abs( zgrad(:, 1) )**2
        if ( Ny > 1 ) then
            zAbs2Gradient = zAbs2Gradient + abs( zgrad(:, 2) )**2
        end if
        if ( Nz > 1 ) then
            zAbs2Gradient = zAbs2Gradient + abs( zgrad(:, 3) )**2
        end if
    end subroutine Abs2Gradient
    ! ---------------------------------------------------------------

    !> 波動関数に対して各エネルギーを計算する
    !! @param[in] Phi 波動関数
    !! @param[in] Pot 外場ポテンシャル
    !! @param[in] Omega_z 回転角速度
    !! @return energies 各エネルギーを格納する配列 (順番に運動エネルギー、ポテンシャルエネルギー、回転エネルギー、相互作用エネルギー)
    function calc_energies(Phi, Pot, OMEGA_z) result(energies)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        double precision,intent(in)    :: Pot(1:NL)
        double precision,intent(in)    :: OMEGA_z(1:Nz)
        double precision               :: energies(1:4)
        double precision               :: t1, t2
        complex(kind(0d0))             :: temp(1:NL)

        call Laplacian(Phi)
        energies(1) = 0.5d0 * integrate( -conjg(Phi) * zlap )
        energies(2) = integrate( Pot * abs(Phi)**2 )
        call Gradient(Phi)
        call LzPhi(Phi, zgrad)
        i = 1
        do iz = 1, Nz
            do iy = 1, Ny
                do ix = 1, Nx
                    temp(i) = conjg(Phi(i)) * OMEGA_z(iz) * zLzPhi(i)
                    i = i + 1
                end do
            end do
        end do
        energies(4) = integrate( temp )
        energies(3) = 0.5d0*integrate( abs(Phi)**4 )
    end function

    ! Calculate Total Energy
    !> 波動関数に対して全エネルギーを計算する
    !! @param[in] Phi 波動関数
    !! @param[in] Pot 外場ポテンシャル
    !! @param[in] OMEGA_z 回転角速度
    !! @return total_energy 全エネルギー
    function calc_total_energy(Phi, Pot, OMEGA_z) result(total_energy)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        double precision,intent(in)    :: Pot(1:NL)
        double precision,intent(in)    :: OMEGA_z(1:Nz)
        double precision               :: total_energy
        double precision               :: energies(0:3)
        energies = calc_energies(Phi, Pot, OMEGA_z)
        total_energy = sum( energies )
    end function

    ! Make Quantized Vortex Manually
    !> 量子渦を動的に挿入する
    !! @details 波動関数に対して手動で位相を回転させ、動的に量子渦を挿入する
    !! @param[in,out] Phi 波動関数
    !! @param[in] m 巻数(winding number)
    !! @param[in] x0,y0 量子渦の中心座標
    subroutine make_vortex(Phi, m, x0, y0)
        complex(kind(0d0)),intent(inout)       :: Phi(1:NL)
        integer,           intent(in)          :: m
        integer                                :: i, ix, iy
        double precision                       :: x, y
        double precision,intent(in)            :: x0, y0

        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i)
            x = xpos(ix); y = ypos(iy)
            if ( NL / dble(Nx) > 1 ) then
                Phi(i) = Phi(i) * exp(iu * m * phase(y-y0, x-x0))
            else
                if ( x < 0 ) then
                    Phi(i) = Phi(i)
                else
                    Phi(i) = Phi(i) * exp(iu * pi)
                end if
            end if
        end do
    end subroutine

    ! Phase (Complex Number)
    !> 任意の複素数に対して位相(Argument)を計算する
    !! @details 引数はスカラー、ベクトルのどちらでも受け付ける
    !! @details 戻り値は引数と同じrankを取る
    !! @param[in] Z 複素数(配列)
    !! @return 引数で受け取った値に対応する位相
    pure elemental double precision function phase_complex(Z)
        complex(kind(0d0)),intent(in) :: Z
        phase_complex = atan2(aimag(Z), real(Z))
    end function

    ! Phase (Space Coordinates)
    !> 任意の実数に対して位相 \f$ \theta = \arctan(Y/X) \f$ を計算する
    !! @params[in] Y,X 実数
    double precision function phase_coordinates(Y, X)
        double precision,intent(in) :: X, Y
        phase_coordinates = atan2(Y, X)
    end function

    ! Angular momentum
    !> 角運動量演算子を作用させた \f$ L_z | \Phi \rangle \f$ を計算する
    !! @param[in] Phi 波動関数
    !! @param[in] Grad 波動関数の勾配を格納した配列
    !! @note 引数の波動関数は必要無いのでコードから除外して良い
    subroutine LzPhi(Phi, Grad)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        complex(kind(0d0)),intent(in)  :: Grad(1:NL,1:3)
        integer                        :: i, ix, iy
        double precision               :: x, y
        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i)
            x = xpos(ix); y = ypos(iy)
            zLzPhi(i) = -iu * ( x * Grad(i, 2) - y * Grad(i, 1) )
        end do
    end subroutine LzPhi

    !> 角運動量演算子を作用させた \f$ L_i | \Phi \rangle \f$ を計算する
    !! @details ここで \f$ i=(x,y,z) \f$ である
    !! @param[in] Phi 波動関数
    !! @param[in] Grad 波動関数の勾配を格納した配列
    !! @note 引数の波動関数は必要無いのでコードから除外して良い
    subroutine LallPhi(Phi, Grad)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        complex(kind(0d0)),intent(in)  :: Grad(1:NL,1:3)
        integer                        :: i, ix, iy, iz
        double precision               :: x, y, z
        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i); iz = i2iz(i)
            x = xpos(ix); y = ypos(iy); z = zpos(iz)
            zLxPhi(i) = -iu * ( y * Grad(i, 3) - z * Grad(i, 2) )
            zLyPhi(i) = -iu * ( z * Grad(i, 1) - x * Grad(i, 3) )
            zLzPhi(i) = -iu * ( x * Grad(i, 2) - y * Grad(i, 1) )
        end do
    end subroutine LallPhi

    ! Calculate Expected Angular Momentum Value (Excluding Plank constant)
    !> 1粒子あたりの角運動量の期待値 \f$ \langle \Phi | L_z | \Phi \rangle \f / \langle \Phi | \Phi \rangle$ を計算する
    !! @param[in] Phi 波動関数
    double precision function calc_Lz(Phi)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        call Gradient(Phi)
        call LzPhi(Phi, zgrad)
        calc_Lz = dble( integrate(conjg(Phi)*zLzPhi) )
        calc_Lz = calc_Lz / ParticleN
    end function
    !> 1粒子あたりの角運動量の期待値 \f$ \langle \Phi | L_i | \Phi \rangle / \langle \Phi | \Phi \rangle \f$ を計算する
    !! @details ここで \f$ i=(x,y,z) \f$ である
    !! @param[in] Phi 波動関数
    function calc_Lall(Phi) result(L)
        complex(kind(0d0)),intent(in)  :: Phi(1:NL)
        double precision               :: L(1:3)
        call Gradient(Phi)
        call LallPhi(Phi, zgrad)
        L(1) = dble( integrate(conjg(Phi)*zLxPhi) )
        L(2) = dble( integrate(conjg(Phi)*zLyPhi) )
        L(3) = dble( integrate(conjg(Phi)*zLzPhi) )
        L = L / ParticleN
    end function

    ! Probability Current
    !> 確率流密度を計算する
    !! @param[in] 波動関数
    !! @return 確率流密度を格納した配列。次元はそれぞれインデックス、空間軸を指す。
    function calc_flux(Phi) result(Flux)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        double precision              :: Flux(1:NL, 1:3)
        integer                       :: i, id
        double precision              :: t2, t1
        call Gradient(Phi)
        do id = 1, 3
            Flux(:,id) = aimag( conjg(Phi(:))*zgrad(:,id) )
        end do
    end function
    !> z軸向きの循環を計算する
    !! @details 確率流密度から循環を計算する
    !! @note 数値計算の仕様上、位相が不連続的に変化すると計算できなくなる
    !! @param[in] Phi 波動関数
    !! @param[in] Flux 確率流密度
    double precision function circulation_flux(Phi, Flux)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        double precision,  intent(in) :: Flux(1:NL, 1:3)
        integer                       :: ix, iy
        double precision              :: sum
        integer                       :: lx, ux, ly, uy
        lx = floor(0.25d0 * Nx)
        ux = ceiling(0.75d0 * Nx)
        ly = floor(0.25d0 * Ny)
        uy = ceiling(0.75d0 * Ny)

        sum = 0d0
        ! C1
        do ix = lx, ux
            sum = sum + v_dr_(Phi, Flux, ix, ly, +1, 0)
        end do
        ! C2
        do iy = ly, uy
            sum = sum + v_dr_(Phi, Flux, ux, iy, 0, +1)
        end do
        ! C3
        do ix = ux, lx, -1
            sum = sum + v_dr_(Phi, Flux, ix, uy, -1, 0)
        end do
        ! C4
        do iy = uy, ly, -1
            sum = sum + v_dr_(Phi, Flux, lx, iy, 0, -1)
        end do
        circulation_flux = sum
    end function

    ! (VELOCITY) * dh
    !> circulation_fluxを計算するために実装した内部関数
    !! @details 確率流密度\f$ \textbf{j} \f$を用いて\f( \left[ \text{coe_dx} \times j_x + \text{coe_dy} \times j_y \right] / |\Phi|^2 \f)を計算する
    !! @param[in] Phi 波動関数
    !! @param[in] Flux 確率流密度
    !! @param[in] ix,iy 計算する場所のインデックス
    !! @param[in] coe_dx,coe_dy 係数
    double precision function v_dr_(Phi, Flux, ix, iy, coe_dx, coe_dy)
        complex(kind(0d0)), intent(in) :: Phi(1:NL)
        double precision,   intent(in) :: Flux(1:NL, 1:3)
        integer,            intent(in) :: ix, iy, coe_dx, coe_dy
        integer                        :: i

        i = ixyz2i(ix, iy, 1)
        v_dr_ = coe_dx * Flux(i, 1) / abs(Phi(i))**2 + coe_dy * Flux(i, 2) / abs(Phi(i))**2
        v_dr_ = v_dr_ * dh
    end function

    ! circulation derived from phase
    !> z軸向きの循環を計算する
    !! @details 位相情報から循環を計算する
    !! @note 数値計算の仕様上、位相が不連続的に変化すると計算できなくなる
    !! @param[in] Phi 波動関数
    double precision function circulation_phase(Phi)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        integer                       :: ix, iy, istart, iend
        double precision              :: sum
        integer                       :: lx, ux, ly, uy
        lx = floor(0.25d0 * Nx)
        ux = ceiling(0.75d0 * Nx)
        ly = floor(0.25d0 * Ny)
        uy = ceiling(0.75d0 * Ny)

        sum = 0d0
        ! C1
        do ix = lx, ux
            istart = ixyz2i(ix-1, ly, 1)
            iend = ixyz2i(ix+1, ly, 1)

            if(phase( Phi(iend) ) - phase( Phi(istart) ) < 0) then
                sum = sum + 0.5d0 * ( ( phase( Phi(iend) ) + 2d0 * pi ) - phase( Phi(istart) ) )
            else
                sum = sum + v_dr(Phi, ix, ly, +1, 0)
            end if
        end do
        ! C2
        do iy = ly, uy
            istart = ixyz2i(ux, iy-1, 1)
            iend = ixyz2i(ux, iy+1, 1)

            if(phase( Phi(iend) ) - phase( Phi(istart) ) < 0) then
                sum = sum + 0.5d0 * ( ( phase( Phi(iend) ) + 2d0 * pi ) - phase( Phi(istart) ) )
            else
                sum = sum + v_dr(Phi, ux, iy, 0, +1)
            end if
        end do
        ! C3
        do ix = ux, lx, -1
            istart = ixyz2i(ix+1, uy, 1)
            iend = ixyz2i(ix-1, uy, 1)

            if( phase( Phi(iend) ) - phase( Phi(istart) ) < 0) then
                sum = sum - 0.5d0*( ( phase( Phi(iend) ) ) - ( phase( Phi(istart) ) + 2d0 * pi ) )
            else
                sum = sum + v_dr(Phi, ix, uy, -1, 0)
            end if
        end do
        ! C4
        do iy = ux, lx, -1
            istart = ixyz2i(lx, iy+1, 1)
            iend = ixyz2i(lx, iy-1, 1)

            if (phase(Phi(iend)) - phase(Phi(istart)) < 0) then
                sum = sum - 0.5d0 * ( ( phase( Phi(iend) ) ) - ( phase( Phi(istart) ) + 2d0 * pi ) )
            else
                sum = sum + v_dr(Phi, lx, iy, 0, -1)
            end if
        end do
        circulation_phase = sum
    end function

    ! (VELOCITY) * dh
    !> \f( \text{circulation_phase} \f)を計算するために実装した内部関数
    !! @details 位相\f$ \theta \f$を用いて\f( 0.5 \times \left[ \text{coe_dx} \times d\theta_x + \text{coe_dy} \times d\theta_y \right] / |\Phi|^2 \f)を計算する
    !! @param[in] Phi 波動関数
    !! @param[in] Flux 確率流密度
    !! @param[in] ix,iy 計算する場所のインデックス
    !! @param[in] coe_dx,coe_dy 係数
    double precision function v_dr(Phi, ix, iy, coe_dx, coe_dy)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        integer,           intent(in) :: ix, iy, coe_dx, coe_dy
        integer                       :: istart, iend

        istart = ixyz2i(ix-1, iy, 1)
        iend   = ixyz2i(ix+1, iy, 1)
        v_dr = coe_dx*(phase(Phi(iend))-phase(Phi(istart)))

        istart = ixyz2i(ix, iy-1, 1)
        iend   = ixyz2i(ix, iy+1, 1)
        v_dr = v_dr + coe_dy*(phase(Phi(iend))-phase(Phi(istart)))
        v_dr = 0.5d0 * v_dr
    end function

    ! FFTW Gradient
    !> 複素数配列に対して勾配 \f$ \nabla G \f$ を計算する
    !! @details 高速フーリエ変換を用いた微分演算で勾配を計算する
    !! @details GP方程式に対して有限差分法よりも良い微分精度を持つ
    !! @param[in] G 複素数配列
    subroutine gradient_fftw(G)
        complex(kind(0d0)),intent(in) :: G(1:NL)
        complex(kind(0d0))            :: temp1(1:NL), temp2(1:NL), temp3(1:NL)
        integer                       :: i, j

        if (Nx > 1) then
            temp1(:) = G(:) * K(:, 1)
            zgrad(:, 1) = iu * revert_fftw( temp1 )
        else
            zgrad(:, 1) = (0d0, 0d0)
        end if

        if (Ny > 1) then
            temp2(:) = G(:) * K(:, 2)
            zgrad(:, 2) = iu * revert_fftw( temp2 )
        else
            zgrad(:, 2) = (0d0, 0d0)
        end if

        if (Nz > 1) then
            temp3(:) = G(:) * K(:, 3)
            zgrad(:, 3) = iu * revert_fftw( temp3 )
        else
            zgrad(:, 3) = (0d0, 0d0)
        end if
    end subroutine

    ! FFTW Laplacian
    !> 複素数配列に対してラプラシアン \f$ \Delta F \f$ を計算する
    !! @details 高速フーリエ変換を用いた微分演算でラプラシアンを計算する
    !! @details GP方程式に対して有限差分法よりも良い微分精度を持つ
    !! @param[in] F 複素数配列
    subroutine laplacian_fftw(F)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        complex(kind(0d0))            :: temp(1:NL)
        temp = F * K2
        zlap = -1d0 * revert_fftw( temp )
    end subroutine

    ! FFTW Transform
    !> 複素数配列に対して(順)高速フーリエ変換を行う
    !! @param[in] in 複素数配列
    !! @return 変換結果
    function transform_fftw(in) result(out)
        complex(kind(0d0)),intent(in) :: in(1:NL)
        complex(kind(0d0))            :: out(1:NL)
        call dfftw_execute_dft( plan_f, in, out )
    end function

    ! FFTW Backward Transform
    !> 複素数配列に対して(逆)高速フーリエ変換を行う
    !! @param[in] in 複素数配列
    !! @return 変換結果
    function revert_fftw(in) result(out)
        complex(kind(0d0)),intent(in) :: in(1:NL)
        complex(kind(0d0))            :: out(1:NL)
        call dfftw_execute_dft( plan_b, in, out )
        out = out / NL
    end function

    ! FFTW Instantiate
    !> 高速フーリエ変換を行うための前準備を行う
    subroutine new_fftw()
        double precision    :: Kx(1:Nx), Ky(1:Ny), Kz(1:Nz)
        integer             :: ix, iy, iz, i
        ! This way saves calculation time 1.43x times faster
        pfx = fftw_alloc_complex(int(NL, C_SIZE_T))
        pFk = fftw_alloc_complex(int(NL, C_SIZE_T))
        pgx = fftw_alloc_complex(int(NL, C_SIZE_T))
        pGk = fftw_alloc_complex(int(NL, C_SIZE_T))
        call c_f_pointer( pfx, fx, [NL] )
        call c_f_pointer( pFk, Fk, [NL] )
        call c_f_pointer( pgx, gx, [NL] )
        call c_f_pointer( pGk, Gk, [NL] )
        select case ( DIM )
        case (1)
            call dfftw_plan_dft_1d(plan_f, Nx, fx, Fk, FFTW_FORWARD, FFTW_MEASURE)
            call dfftw_plan_dft_1d(plan_b, Nx, Fk, fx, FFTW_BACKWARD, FFTW_MEASURE)
        case (2)
            call dfftw_plan_dft_2d(plan_f, Nx, Ny, fx, Fk, FFTW_FORWARD, FFTW_MEASURE)
            call dfftw_plan_dft_2d(plan_b, Nx, Ny, Fk, fx, FFTW_BACKWARD, FFTW_MEASURE)
        case (3)
            call dfftw_plan_dft_3d(plan_f, Nx, Ny, Nz, fx, Fk, FFTW_FORWARD, FFTW_MEASURE)
            call dfftw_plan_dft_3d(plan_b, Nx, Ny, Nz, Fk, fx, FFTW_BACKWARD, FFTW_MEASURE)
        case default
            stop "DIM is not specified"
        end select
        allocate( K(1:NL, 3), K2(1:NL) )
        Kx = create_wavenumber(Nx)
        Ky = create_wavenumber(Ny)
        Kz = create_wavenumber(Nz)
        i = 1
        do iz = 1, Nz
            do iy = 1, Ny
                do ix = 1, Nx
                    K(i, 1) = Kx(ix)
                    K(i, 2) = Ky(iy)
                    K(i, 3) = Kz(iz)
                    K2(i)   = Kx(ix)**2 + Ky(iy)**2 + Kz(iz)**2
                    i = i + 1
                end do
            end do
        end do
    end subroutine

    ! FFTW Wavenumbers
    !> 高速フーリエ変換を行うための前準備を行う
    !! @details フーリエ変換で用いるための波数を周期境界条件を仮定して計算する
    !! @param[in] N 次元
    !! @return K_ 波数ベクトル
    function create_wavenumber(N) result(K_)
        integer,intent(in)  :: N
        double precision    :: K_(1:N)
        double precision    :: coe
        integer             :: i
        coe = 2d0 * PI / ( N * dh )
        if ( N > 1 ) then
            do i = 1, N
                if (i <= N / 2) then
                    K_(i) = i - 1
                else
                    K_(i) = i - N - 1
                end if
            end do
            K_ = K_ * coe
        else
            K_ = 0d0
        end if
    end function

    ! Destroy FFTW Instances
    !> 高速フーリエ変換関連のメモリを開放する
    subroutine destroy_fftw()
        call dfftw_destroy_plan( plan_f )
        call dfftw_destroy_plan( plan_b )
        call fftw_free( pfx )
        call fftw_free( pFk )
    end subroutine
end module mathf


      subroutine runP_0000(Gr,S0000,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,m,n,np
      parameter(np=3)
      double precision Gr(np,np)
      double complex S0000(-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(dzzii(z2(n,m))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dd0000+N0,ep-1)

c--- note: we have simplified the recursion relation by using DD (5.9)
c--- so that S0000 = 2C00(0)+2*m0sq*D00
      Dv(dd0000+N0,ep)=
     . (pole
     . +S0000(ep)
     . -bit)/12d0
      enddo

      return
      end