*     DF01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 129 )
*     .. Local Scalars ..
      DOUBLE PRECISION DT
      INTEGER          I, INFO, N
      CHARACTER*1      SICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX), DWORK(NMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DF01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DT, SICO
      IF ( N.LE.1 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,N )
*        Compute the sine/cosine transform of the given real signal.
         CALL DF01MD( SICO, N, DT, A, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( SICO, 'S' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) I, A(I)
   20          CONTINUE
            ELSE
               WRITE ( NOUT, FMT = 99996 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) I, A(I)
   40          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' DF01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DF01MD = ',I2)
99997 FORMAT (' Components of sine transform are',//'   i',6X,'A(i)',/)
99996 FORMAT (' Components of cosine transform are',//'   i',6X,'A(i)',
     $       /)
99995 FORMAT (I4,3X,F8.4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
      END


c=======================================================================
c
c     subroutine calepsmedian
c
c     Calibrates Kato sensitivity parameter with median method
c
c-----------------------------------------------------------------------
      SUBROUTINE calepsmedian (n, cov, dwork, epskgr, info)
c-----------------------------------------------------------------------
c
c     INPUT
c        p : integer, number of variables (p>=1).
c        cov : double array of dimension p by p, covariance matrix.
c
c     WORKSPACE
c       dwork: double workspace of size  2*n*n + 9*n
c
c     OUTPUT
c       epskgr : double, Kato eps-group parameter.
c       info   :   = 0 successful exit                        integer
c                        -1 ncup != ncdown
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     I/O
      INTEGER n, info
      DOUBLE PRECISION cov(*), epskgr, dwork(*)
      CHARACTER JOBVL, JOBVR
c
c     local variables
      INTEGER ldvl, lwork, pdcov, pdeigval, pdwi, pdvl, pdeigvect,
     & pdwork, pdeigvalorder
c
c     external function
      EXTERNAL YM, AVOC, MEDIAN
c
c     initialisation
      info = 0

      pdcov = 1
c     needs n*n so n*n
      pdeigval = pdcov + n*n
c     needs n no n*n + n
      pdwi = pdeigval + n
c     needs n no n*n + 2*n
      pdvl =   pdwi +n
c     needs n so n*n +3*n
      pdeigvect = pdvl +n
c     needs n*n so 2*n*n +3*n
      pdeigvect = pdvl +n
c     needs n so 2*n*n +4*n
      pdwork = pdeigvect + n * n
c     needs 4*n so 2*n*n + 8*n
      pdeigvalorder = pdwork + 4*n
c     needs n, so 2*n*n + 9*n
c
      CALL YM(n, n, cov, dwork(pdcov))
c
      JOBVL = 'N'
      JOBVR = 'N'
      ldvl = 1
      lwork = 4*n
c
      CALL dgeev(jobvl, jobvr, n, dwork(pdcov), n, dwork(pdeigval),
     & dwork(pdwi), dwork(pdvl), ldvl, dwork(pdeigvect), n,
     & dwork(pdwork), lwork, info)
      CALL AVOC(n, dwork(pdeigval), dwork(pdeigvalorder))
      CALL MEDIAN(n, dwork(pdeigvalorder), epskgr, info)
      RETURN
      END


        subroutine curcal (rl0, rllow, rlc, rlup, aa1, aa2, aa3,
     &    aa4, aa5, bb1, bb2, bb3, bb4, bb5, cc1, cc2, cc3, cc4, cc5)
c
c       EMPIRICAL ACTIVE ELEMENT CURVE CALCULATION SUBR.
c
c============================================================================
c       INTERVAL  LLOW <= L <+(L0-LLOW)/2
c=================================================
        x1 = rllow
        y1 = .316
        x2 = rllow + (rl0 - rllow) / 4.0
        y2 = .676
        x3 = rllow + (rl0 - rllow) / 2.0
        y3 = .876
        call parabol(x1, x2, x3, y1, y2, y3, aa, bb, cc)
        aa1 = aa
        bb1 = bb
        cc1 = cc
c============================================================================
c       INTERVAL : LLOW+(L0-LLOW)/2 <= L < 3*(L0-LLOW)/4
c============================================================================
        x1 = rl0
        y1 = 1
        x2 = rllow + 3 * (rl0 - rllow) / 4.0
        y2 = .976
        x3 = rllow + (rl0 - rllow) / 2.0
        y3 = .876
        call parabol(x1, x2, x3, y1, y2, y3, aa, bb, cc)
        aa2 = aa
        bb2 = bb
        cc2 = cc
c============================================================================
c       INTERVAL : 3*(L0-LLOW)/4 <= L < LLOW
c============================================================================
        x1 = rl0
        y1 = 1
        x2 = rllow + 3 * (rl0 - rllow) / 4.0
        y2 = .976
        aa3 = (y2 - y1) / (x2 - x1) **2
        bb3 = -2 * aa3 * x1
        cc3 = y1 + x1 * x1 * aa3
        aa = aa3
        bb = bb3
        cc = cc3
c============================================================================
c       INTERVAL : L0 <= L < LC
c============================================================================
        x1 = rl0
        y1 = 1
        x2 = rl0 + (rlc - rl0) / 2.0
        y2 = .922
        x3 = rlc
        y3 = .707
        call parabol(x1, x2, x3, y1, y2, y3, aa, bb, cc)
        aa4 = aa
        bb4 = bb
        cc4 = cc
c============================================================================
c       INTERVAL : LC <= L < LUP
c============================================================================
        x1 = rlc + (rlup - rlc) / 2.0
        y1 = .501
        x2 = rlup
        y2 = .316
        x3 = rlc
        y3 = .707
        call parabol(x1, x2, x3, y1, y2, y3, aa, bb, cc)
        aa5 = aa
        bb5 = bb
        cc5 = cc
        return
        end
c---------------------------------------------------------------


C
C $Id: seradp.f,v 1.5 2008-07-27 00:17:12 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE SERADP (FB,FA2,FA4,FC1,FC3,LAM)
C
C     COMPUTES INTEGRAL FUNCTION OF TRANSFORMED LONG. FOR FOURIER
C     CONSTANTS A2, A4, B, C1, AND C3.
C     LAM IS INTEGRAL VALUE OF TRANSFORMED LONG.
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      COMMON /NORMDP/ Q,T,U,W,ES,P22,SA,CA,XJ
      DATA DG1 /0.01745329252D0/
      DATA ONE,TWO /1.0D0,2.0D0/
      LAM=LAM*DG1
      SD=SIN(LAM)
      SDSQ=SD*SD
      S=P22*SA*COS(LAM)*SQRT((ONE+T*SDSQ)/((ONE+W*SDSQ)
     .  *(ONE+Q*SDSQ)))
      H=SQRT((ONE+Q*SDSQ)/(ONE+W*SDSQ))*(((ONE+W*SDSQ)/
     .   ((ONE+Q*SDSQ)**TWO))-P22*CA)
      SQ=SQRT(XJ*XJ+S*S)
      FB=(H*XJ-S*S)/SQ
      FA2=FB*COS(TWO*LAM)
      FA4=FB*COS(4.0D0*LAM)
      FC=S*(H+XJ)/SQ
      FC1=FC*COS(LAM)
      FC3=FC*COS(3.0D0*LAM)
      RETURN
      END


module multiparameter_C3
  !> Propane multiparameter fundamental equation for Helmholtz
  !> energy. See Lemmon et al. (2009), doi:10.1021/je900217v.
  use multiparameter_base, only: meos
  implicit none
  save
  public :: meos_c3
  private

  ! Parameters for the ideal gas part alpha^0
  real, parameter, dimension(1:2) :: a = (/ -4.970583,  4.29352 /)
  real, parameter, dimension(3:6) :: b = (/ 1.062478, 3.344237, 5.363757, 11.762957 /)
  real, parameter, dimension(3:6) :: v = (/ 3.043, 5.874, 9.337, 7.922 /)

  ! upPol is the upper index for polynomial terms, upExp the same for
  ! single-expontential terms, upExpExp for double-exponential terms.
  integer, parameter :: upPol = 5
  integer, parameter :: upExp = 11
  integer, parameter :: upExpExp = 18

  real, parameter, dimension(1:upPol) :: N_pol = (/0.042910051, 1.7313671, -2.4516524,&
       0.34157466, -0.46047898 /)
  real, parameter, dimension(upPol+1:upExp) :: N_exp =(/ -0.66847295, 0.20889705, &
       0.19421381, -0.22917851, -0.60405866, 0.066680654 /)
  real, parameter, dimension(upExp+1:upExpExp) :: N_expexp = (/ 0.017534618, 0.33874242, &
       0.22228777, -0.23219062, -0.092206940, -0.47575718, -0.017486824 /)

  real, parameter, dimension(1:upPol) :: t_pol = (/1.00, 0.33, 0.80, 0.43, 0.90 /)
  real, parameter, dimension(upPol+1:upExp) :: t_exp = (/2.46, 2.09, 0.88, 1.09, 3.25, 4.62 /)
  real, parameter, dimension(upExp+1:upExpExp) :: t_expexp = (/0.76, 2.50, 2.75, 3.05, 2.55, 8.40, 6.75 /)

  integer, parameter, dimension(1:upPol) :: d_pol = (/ 4, 1, 1, 2, 2/)
  integer, parameter, dimension(upPol+1:upExp) :: d_exp = (/ 1, 3, 6, 6, 2, 3 /)
  integer, parameter, dimension(upExp+1:upExpExp) :: d_expexp = (/ 1, 1, 1, 2, 2, 4, 1 /)

  integer, parameter, dimension(upPol+1:upExp) :: l_exp = (/ 1, 1, 1, 1, 2, 2 /)
  real, parameter, dimension(upExp+1:upExpExp) :: eta_expexp = (/ 0.963, 1.977, 1.917, 2.307, 2.546, 3.28, 14.6 /)
  real, parameter, dimension(upExp+1:upExpExp) :: beta_expexp = (/ 2.33, 3.47, 3.15, 3.19, 0.92, 18.8, 547.8 /)
  real, parameter, dimension(upExp+1:upExpExp) :: gam_expexp = (/ 0.684, 0.829, 1.419, 0.817, 1.500, 1.426, 1.093 /)
  real, parameter, dimension(upExp+1:upExpExp) :: eps_expexp = (/ 1.283, 0.6936, 0.788, 0.473, 0.8577, 0.271, 0.948 /)

  ! Parameters for the ancillary equations to compute saturation densities
  real, parameter, dimension(4) :: N_liqsat = (/ 1.82205, 0.65802, 0.21109, 0.083973 /)
  real, parameter, dimension(4) :: expo_liqsat = (/ 0.345, 0.74, 2.6, 7.2 /)
  real, parameter, dimension(6) :: N_vapsat = (/ -2.4887, -5.1069, -12.174, -30.495, -52.192, -134.89 /)
  real, parameter, dimension(6) :: expo_vapsat = (/ 0.3785, 1.07, 2.7, 5.5, 10.0, 20.0/)

  !> C3 multiparameter equations of state (Lemmon, McLinden and Wagner 2009).
  type, extends(meos) :: meos_c3
     private
     ! Cache the expensive temperature-dependent quantities.
     real :: tau_cache
     real :: deltaSatLiq_cache
     real :: deltaSatVap_cache
     real :: prefactors_pol_cache(1:upPol)
     real :: prefactors_exp_cache(upPol+1:upExp)
     real :: prefactors_expexp_cache(upExp+1:upExpExp)

   contains

     procedure, public :: alpha0Derivs_taudelta => alpha0Derivs_C3
     procedure, public :: alphaResDerivs_taudelta => alphaResDerivs_C3
     procedure, public :: satDeltaEstimate => satDeltaEstimate_C3
     procedure, public :: init => init_C3

     procedure, private :: alphaResPrefactors => alphaResPrefactors_C3

     ! Assignment operator
     procedure, pass(This), public :: assign_meos => assign_meos_c3

  end type meos_c3

contains

  subroutine init_C3 (this, use_Rgas_fit)
    class(meos_c3) :: this
    logical, optional, intent(in) :: use_Rgas_fit

    this%tau_cache = 0.0

    this%compName = "C3"
    this%tc = 369.89  !< (K)
    this%rc = 5000    !< (mol/m^3)
    this%pc = 4251200 !< (Pa)

    this%t_triple = 85.525  !< (K)
    this%p_triple = 0.00017 !< (Pa)
    this%rhoLiq_triple = 16625  !< (mol/m^3)
    this%rhoVap_triple = 2.4e-7  !< (mol/m^3)

    this%molarMass = 44.09562e-3  !< (kg/mol)
    this%Rgas_fit = 8.314472 !< (J/(mol*K))

    this%maxT = 650.0 ! (T)
    this%maxP = 1000e6 ! (Pa)

    if (present(use_Rgas_fit)) then
       if (use_Rgas_fit) then
          this%Rgas_meos = this%Rgas_fit
       end if
    end if

  end subroutine init_C3

  ! The functional form of the ideal gas function varies among multiparameter EoS,
  ! which explains why this routine may seem a bit hard-coded.
  subroutine alpha0Derivs_C3(this, delta, tau, alp0)
    class(meos_c3) :: this
    real, intent(in) :: delta, tau
    real, intent(out) :: alp0(0:2,0:2) !< alp0(i,j) = [(d_delta)^i(d_tau)^j alpha0]*delta^i*tau^j
    ! Internals
    real, dimension(3:6) :: exps !, exps2
    ! Precalculate exponentials
    exps = exp(b*tau)
    !    exps2 = exps/(exps-1)
    !    exps2 = exps2*exps2

    alp0 = 0.0
    alp0(0,0) = log(delta) + 3*log(tau) + a(1) + a(2)*tau + dot_product(v, log(1-1/exps))
    alp0(1,0) = 1.0
    alp0(2,0) = -1.0
    alp0(0,1) = 3 + a(2)*tau + tau*dot_product(v*b, 1/(exps-1))
    alp0(0,2) = -3 - tau*tau*dot_product(v*b**2, exps/(exps-1)**2)
    !    alp0(0,2) = -3 - tau*tau*dot_product(v*bsq, exps2)

  end subroutine alpha0Derivs_C3

  ! Supplies all prefactors that do not depend on delta. Prefactors are cached.
  subroutine alphaResPrefactors_C3 (this, tau, prefactors_pol, prefactors_exp, prefactors_expexp)
    class(meos_c3) :: this
    real, intent(in) :: tau
    real, intent(out) :: prefactors_pol(1:upPol)
    real, intent(out) :: prefactors_exp(upPol+1:upExp)
    real, intent(out) :: prefactors_expexp(upExp+1:upExpExp)
    ! Internal

    if ( tau /= this%tau_cache ) then
       this%tau_cache = tau
       this%prefactors_pol_cache = N_pol * tau**t_pol
       this%prefactors_exp_cache = N_exp * tau**t_exp
       this%prefactors_expexp_cache = N_expexp * tau**t_expexp
    end if

    prefactors_pol = this%prefactors_pol_cache
    prefactors_exp = this%prefactors_exp_cache
    prefactors_expexp = this%prefactors_expexp_cache

  end subroutine alphaResPrefactors_C3

  subroutine alphaResDerivs_C3 (this, delta, tau, alpr)
    class(meos_c3) :: this
    real, intent(in) :: delta, tau
    real, intent(out) :: alpr(0:2,0:2) !< alpr(i,j) = (d_delta)^i(d_tau)^j alphaRes
    ! Internal
    real :: deltaL(upPol+1:upExp)
    real :: prefactors_pol(1:upPol)
    real :: prefactors_exp(upPol+1:upExp)
    real :: prefactors_expexp(upExp+1:upExpExp)
    real :: polTerms(1:upPol), expTerms(upPol+1:upExp), expExpTerms(upExp+1:upExpExp)
    call this%alphaResPrefactors(tau, prefactors_pol, prefactors_exp, prefactors_expexp)

    ! Precalculate polynomial terms
    polTerms(1:upPol) = prefactors_pol*delta**d_pol

    ! Precalculate single-exponential terms
    deltaL(upPol+1:upExp) = delta**l_exp
    expTerms(upPol+1:upExp) = prefactors_exp * delta**d_exp * exp(-deltaL)

    ! Precalculate double-exponential terms
    expExpTerms(upExp+1:upExpExp) = prefactors_expexp * delta**d_expexp &
         * exp(-eta_expexp*(delta-eps_expexp)**2 - beta_expexp*(tau-gam_expexp)**2)

    ! alpha
    alpr(0,0) = sum(polTerms) + sum(expTerms) + sum(expExpTerms)

    ! delta*alpha_delta
    alpr(1,0) = dot_product(polTerms, d_pol) + dot_product(expTerms, d_exp - l_exp*deltaL) &
         + dot_product(expExpTerms, d_expexp - 2*eta_expexp*delta*(delta-eps_expexp))

    ! delta**2 * alpha_deltadelta
    alpr(2,0) = dot_product(polTerms, d_pol*(d_pol-1)) + &
         dot_product(expTerms, (d_exp - l_exp*deltaL)*(d_exp-1-l_exp*deltaL) - l_exp*l_exp*deltaL ) + &
         dot_product(expExpTerms, (d_expexp - 2*eta_expexp*delta*(delta-eps_expexp))**2 - d_expexp - 2*eta_expexp*delta**2 )

    ! tau*alpha_tau
    alpr(0,1) = dot_product(polTerms, t_pol) + dot_product(expTerms, t_exp) &
         + dot_product(expExpTerms, t_expexp - 2*beta_expexp*tau*(tau-gam_expexp))

    ! tau**2 * alpha_tautau
    alpr(0,2) = dot_product(polTerms, t_pol*(t_pol-1)) + dot_product(expTerms, t_exp*(t_exp-1)) &
         + dot_product(expExpTerms, (t_expexp - 2*beta_expexp*tau*(tau-gam_expexp))**2 - t_expexp - 2*beta_expexp*tau**2 )

    ! delta*tau*alpha_deltatau
    alpr(1,1) = dot_product(polTerms, d_pol*t_pol) + dot_product(expTerms, (d_exp - l_exp*deltaL)*t_exp ) &
         + dot_product(expExpTerms, &
         (d_expexp - 2*eta_expexp*delta*(delta-eps_expexp))*(t_expexp - 2*beta_expexp*tau*(tau-gam_expexp)))

  end subroutine alphaResDerivs_C3

  function satDeltaEstimate_C3 (this,tau,phase) result(deltaSat)
    use thermopack_constants, only: LIQPH, VAPPH
    class(meos_c3) :: this
    real, intent(in) :: tau
    integer, intent(in) :: phase
    real :: deltaSat
    ! Internals
    real :: theta

    theta = 1-1/tau
    if ( phase == LIQPH ) then
       deltaSat = 1 + dot_product(N_liqsat,theta**expo_liqsat)
    else if ( phase == VAPPH ) then
       deltaSat = exp(dot_product(N_vapsat,theta**expo_vapsat))
    else
       call stoperror("satDeltaEstimate_C3: only LIQPH and VAPPH allowed!")
    end if

  end function satDeltaEstimate_C3

  subroutine assign_meos_c3(this,other)
    class(meos_c3), intent(inout) :: this
    class(*), intent(in) :: other
    !
    select type (other)
    class is (meos_c3)
      call this%assign_meos_base(other)

      this%tau_cache = other%tau_cache
      this%deltaSatLiq_cache = other%deltaSatLiq_cache
      this%deltaSatVap_cache = other%deltaSatVap_cache
      this%prefactors_pol_cache = other%prefactors_pol_cache
      this%prefactors_exp_cache = other%prefactors_exp_cache
      this%prefactors_expexp_cache = other%prefactors_expexp_cache

    class default
      call stoperror("assign_meos_c3: Should not be here....")
    end select
  end subroutine assign_meos_c3

end module multiparameter_C3


program main
    use plantFEM
    implicit none

    type(FEMDomain_) :: dam
    real(real64) :: x(7),altitude(7),top
    integer(int32) :: i

    ! plantFEM用メッシュ生成スクリプト
    ! https://github.com/kazulagi/plantFEM

    ! メッシュの元となったデータ：
    ! 牧　隆泰, 1958, 日本水利施設進展の研究, 土木雑誌社
    ! p. 209 長谷池（岡山県児島郡鉾立村)

    ! 以下、メッシュ分割プログラム
    ! 要素分割数
    call dam%create(meshtype="Cube",x_num=30,y_num=30,z_num=12)
    ! 堤体寸法(上下流方向長,堤長, 堤高)
    !15:6.1=x:30.1
    call dam%resize(x=85.00d0,y=137.0d0,z=3.0d0)
    call dam%move(x=-5.0d0,z=-2.0d0)
    ! 上流からx(n) m 進んだ地点の高さがaltitude(n) m
    x(1) = 0.00d0; altitude(1) = 1.00d0;
    x(2) = 7.37d0; altitude(2) = 9.22d0;
    x(3) = 9.59d0; altitude(3) = 9.22d0;
    x(4) =19.67d0; altitude(4) =18.69d0;
    x(5) =38.48d0; altitude(5) =18.69d0;
    x(6) =74.01d0; altitude(6) = 8.60d0;
    x(7) =75.73d0; altitude(7) = 1.00d0;

    call dam%edit(x=x, altitude=altitude)

    ! 保存
    call dam%msh("長谷下池")
    call dam%stl("長谷下池")

end program main


      subroutine arrow1(xaa,yaa,xbb,ybb,fullgth)
c
c --- draw arrow pointing from (xaa,yaa) to (xbb,ybb)
c --- if arrow is longer than 'fullgth' grid units, truncate it to that
c --- length and indicate original vector length by number of barbs
c --- (1 barb if orig.length lies in the range (1.5...2.5)*fullgth,
c --- 2 barbs if orig.length lies in the range (2.5...3.5)*fullgth, etc.)
c --- 'enlar' is an arbitrary overall enlargement factor
c
      data barb/.2/,enlar/1.2/
      headsz=.2*fullgth
      reduc=.5*fullgth/amax1(fullgth,sqrt((xbb-xaa)**2+(ybb-yaa)**2))
      xa=(.5+enlar*reduc)*xaa+(.5-enlar*reduc)*xbb
      xb=(.5+enlar*reduc)*xbb+(.5-enlar*reduc)*xaa
      ya=(.5+enlar*reduc)*yaa+(.5-enlar*reduc)*ybb
      yb=(.5+enlar*reduc)*ybb+(.5-enlar*reduc)*yaa
      n=min1(10.,.5/reduc-.5)
      d=0.
 1    n=n-1
      if (n.lt.0) go to 2
      call frstpt(xa+d*(xb-xa)             ,ya+d*(yb-ya)             )
      call vector(xa+d*(xb-xa)-barb*(yb-ya),ya+d*(yb-ya)+barb*(xb-xa))
      call vector(xa+d*(xb-xa)             ,ya+d*(yb-ya)             )
      d=d+barb*.5
      go to 1
 2    q=sqrt((xb-xa)**2+(yb-ya)**2)
      call frstpt(xa,ya)
      call vector(xb,yb)
      if (q.eq.0.) return
      q=enlar*headsz/q
      call vector(xb-(xb-xa-(yb-ya)*0.4)*q,yb-(yb-ya+(xb-xa)*0.4)*q)
      call vector(xb-(xb-xa+(yb-ya)*0.4)*q,yb-(yb-ya-(xb-xa)*0.4)*q)
      call vector(xb,yb)
      return
      end


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM          STNMA
C
C  STENMIN test driver for problems derived from SIF files.
C
C  Ph. Toint, January 1996, for CGT Productions.
C
      INTEGER          NMAX, N, NZ, LIRN, LICN, ILIM, METHOD
      INTEGER          GRDFLG, HSNFLG, NDIGIT, MSG, LWRK, LIWRK
      INTEGER          TERMCD, INFORM, I, IOUT, INPUT, INSPEC
      PARAMETER      ( INPUT =    55, IOUT =      6, INSPEC =   46 )
CTOY  PARAMETER      ( NMAX  =   100, LIRN =    500, LICN =    500 )
CMED  PARAMETER      ( NMAX  =  1000, LIRN =   5000, LICN =   5000 )
CBIG  PARAMETER      ( NMAX  = 20000, LIRN = 500000, LICN = 500000 )
CCUS  PARAMETER      ( NMAX  = 10000, LIRN =  10000, LICN =  10000 )
      PARAMETER      ( LIWRK = 2 * LIRN + 12 * NMAX + 2 )
      PARAMETER      ( LWRK = 7 * NMAX )
      INTEGER          IRN ( LIRN  ), ICN ( LICN ), IWRK( LIWRK )
CD    DOUBLE PRECISION FSCALE, GRADTL, STEPTL, FPLS, STEPMX
CS    REAL             FSCALE, GRADTL, STEPTL, FPLS, STEPMX
CS    REAL             GNORM, BIGINF, ZERO
CD    DOUBLE PRECISION GNORM, BIGINF, ZERO
CS    PARAMETER      ( BIGINF = 9.0E+19, ZERO = 0.0E0 )
CD    PARAMETER      ( BIGINF = 9.0D+19, ZERO = 0.0D0 )
CD    DOUBLE PRECISION X   ( NMAX ),  TYPX( NMAX ), XPLS( NMAX )
CD    DOUBLE PRECISION GPLS( NMAX ),  HESS( LICN ), WRK ( LWRK )
CS    REAL             X   ( NMAX ),  TYPX( NMAX ), XPLS( NMAX )
CS    REAL             GPLS( NMAX ),  HESS( LICN ), WRK ( LWRK )
CS    REAL             BU    ( NMAX ), BL  ( NMAX )
CD    DOUBLE PRECISION BU    ( NMAX ), BL  ( NMAX )
      REAL             CPU( 2 ), CALLS( 4 )
      LOGICAL          BOUNDS
      CHARACTER * 10   XNAMES( NMAX ), PNAME
C
      INTRINSIC        ABS   , MAX
      EXTERNAL         UFN, UGR, USH
C
C  Open the Spec file for the method.
C
      OPEN ( INSPEC, FILE = 'STNMIN.SPC', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INSPEC
C
C  Read input Spec data.
C
C     ILIM  :  the maximum number of iterations
C     GRADTL:  the relative gradient stopping tolerance
C     GRDFLG:  the gradient availability and checking flag
C     HSNFLG:  the Hessian availability and checking flag
C     FSCALE:  the typical value of the objective function
C     TYPX  :  the typical value of the problem's variables
C     METHOD:  the method used (0 = Newton, 1 = tensor )
C     NDIGIT:  the number of accurate digits in function values
C     MSG   :  the output specifier
C
      READ ( INSPEC, 1000 ) ILIM, GRADTL, GRDFLG, HSNFLG, FSCALE,
     *                      TYPX( 1 ), METHOD, NDIGIT, MSG
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up SIF data.
C
      CALL USETUP( INPUT, IOUT, N, X, BL, BU, NMAX )
C
C  Obtain variable names.
C
      CALL UNAMES( N, PNAME, XNAMES )
C
C  Set up algorithmic input data.
C
      BOUNDS  = .FALSE.
      DO 10 I = 1, N
         TYPX(I) = TYPX( 1 )
         IF ( BL( I ) .GT. - BIGINF .OR. BU( I ) .LT. BIGINF )
     *      BOUNDS = .TRUE.
   10 CONTINUE
      IF ( BOUNDS ) WRITE( IOUT, 2030 )
      INFORM = 0
      STEPTL = GRADTL * GRADTL
      STEPMX = ZERO
C
C  Call the optimizer.
C
CD    CALL STUMCD( N, X, NZ, IRN, LIRN, ICN, LICN, UFN, UGR,
CS    CALL STUMCS( N, X, NZ, IRN, LIRN, ICN, LICN, UFN, UGR,
     *             USH, TYPX, FSCALE, GRADTL, STEPTL, ILIM, STEPMX,
     *             IOUT, METHOD, GRDFLG, HSNFLG, NDIGIT, MSG, XPLS,
     *             FPLS, GPLS, HESS, WRK, LWRK, IWRK, LIWRK, TERMCD,
     *             BL, INFORM )
      CALL UREPRT( CALLS, CPU )
      GNORM    = ZERO
      DO 20 I  = 1, N
         GNORM = MAX( GNORM, ABS( GPLS( I ) ) )
   20 CONTINUE
      WRITE ( IOUT, 2040 ) GNORM
      WRITE ( IOUT, 2010 )
      DO 30 I = 1, N
         WRITE( IOUT, 2020 ) XNAMES(I), XPLS( I ), GPLS( I )
   30 CONTINUE
      WRITE ( IOUT, 2000 ) PNAME, N, CALLS(1), CALLS(2), CALLS(3),
     *                     TERMCD, FPLS, CPU(1), CPU(2)
      CLOSE( INPUT  )
      STOP
C
C  Non-executable statements.
C
 1000 FORMAT( I10, /, D10.3, 2(/,I10), 2(/,D10.3), 3(/,I10) )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  STENMIN',  /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # objective gradients   =        ', F8.2 /
     *    ,' # objective Hessians    =        ', F8.2 /
     *    ,' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *    ,' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 2010 FORMAT( /, '                 X         G ' )
 2020 FORMAT(  A10, 1P, 2D12.4 )
 2030 FORMAT(  /, ' ** Warning from STNMA. The problem as stated',
     *            ' includes simple bounds. ', /,
     *            '    These bounds will be ignored. ' )
 2040 FORMAT( ' Final gradient norm = ', D12.4 / )
      END


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my, &
     xlower,ylower,dx,dy,q,maux,aux)
  IMPLICIT NONE

  INTEGER meqn,mbc,mx,my,maux
  DOUBLE PRECISION xlower,ylower, dx,dy
  DOUBLE PRECISION q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

  INTEGER i,j
  DOUBLE PRECISION xi,yj,r, p0

  DO i=1-mbc,mx+mbc
     xi = xlower + (i-0.5d0)*dx
     DO j=1-mbc,my+mbc
        yj = ylower + (j-0.5d0)*dy
        r = dsqrt((xi-0.25d0)**2 + (yj-0.4d0)**2)
        q(1,i,j) = p0(r)
        q(2,i,j) = 0.d0
        q(3,i,j) = 0.d0
     ENDDO
  ENDDO
  RETURN
END SUBROUTINE clawpack5_qinit


! = = = = = = = = = = = = = = = = = = = = = = =
!
!  This SUBROUTINE calculates the PA relationship
!
! = = = = = = = = = = = = = = = = = = = = = = =

#include "AMYCAI.h"

SUBROUTINE PA_RELATION

! parameter AND array modules

    USE FloatPrecision
    USE TimeCatcher
    USE ArraySize
    USE Grids
    USE Hydro
    USE Topography
    USE Parameters

! Routine modules

    USE Longitudinal_1D_Model

    IMPLICIT NONE

! Define the Pointers to the surface AND
! discharge array for 1D Longitudinal model

    REAL(fp) , DIMENSION(:)   , POINTER :: QQ1 , QQ2
    REAL(fp) , DIMENSION(:)   , POINTER :: EE1 , EE2 , DEE1

    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: Rh1, Rh2
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: TD_Prism
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: MAX_Q
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: Steady_Area

    REAL(fp)                          :: h1 , h2
    REAL(fp)                          :: MAXH, aa1, CC
    REAL                              :: TT1, TT2, TTC
    INTEGER                           :: status , I , J , FID , FID0
    CHARACTER(len=100)                 :: FILENAME
    CHARACTER(len=100)                 :: DIRECTION
    CHARACTER(len=80)                 :: err_msg

    NULLIFY(QQ1,QQ2,EE1,EE2,DEE1)

! CPU Timer : begin

    CALL CPU_TIME(TT1)

! - - - - - - - - - - -
!
! Initialize parameters
!
! - - - - - - - - - - -
    BT = DBLE(NU-NL)*dx
    LU = DBLE(MU-ML)*dy
    T0 = 0.5D0*TDCYC   ! start from low tide
    IT0   = 0
    IHOUR = 0
    IDAY  = 0
    IYEAR = 0
    IDT   = INT(DT)
    CD    = 0
    CD2   = 0
    FID0 = 0

    Q_RESIDUAL1(:) = 0.D0
    Q_RESIDUAL2(:) = 0.D0

! ALLOCATE

    ALLOCATE(TD_Prism(ML:MU,1:File_Number),stat=status,errmsg=err_msg)
    ALLOCATE(Steady_Area(ML:MU,1:File_Number),stat=status,errmsg=err_msg)
    ALLOCATE(Max_Q(ML:MU,1:File_Number),stat=status,errmsg=err_msg)
    ALLOCATE(Rh1(ML:MU,1:File_Number),stat=status,errmsg=err_msg)
    ALLOCATE(Rh2(ML:MU,1:File_Number),stat=status,errmsg=err_msg)

! TARGET READY

    ETA1(:) = 0.D0
    ETA2(:) = 0.D0
    Q1(:) = 0.D0
    Q2(:) = 0.D0
    HETA(:) = 0.D0
    Q_RESIDUAL1(:) = 0.D0
    Q_RESIDUAL2(:) = 0.D0
    TDEP0 = 0.D0
    TD_Prism(:,:) = 0.D0
    MAX_Q(:,:) = 0.D0
    Steady_Area(:,:) = 0.D0

!POINTER READY

    QQ1=>Q1
    QQ2=>Q2
    EE1=>ETA1
    EE2=>ETA2
    DEE1=>DETA1
!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!       Calculate the PA relationship
!
!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =

! initialize the tidal amp

    TDAMP = TDAMP0

    !DIRECTION = 'c:\tidal_channel_q2d_model_xf\Q2D_Model_2_longitudinal\XUFAN_QUASI_2D_model\'
    WRITE(18,*) File_Number
    !pause
    LPF: DO FID = Start_File_ID , End_File_ID , File_ID_FRQ

        FID0 = FID0 + 1

        WRITE(*,*) 'FILE_ID = ' , FID , FID0
        WRITE(FILENAME,'(A4,I6.6,A4)') 'Dep_',FID,'.RES'
        OPEN(UNIT=10,FILE=FILENAME,FORM='UNFORMATTED',STATUS='OLD',IOSTAT=status,ACTION='READ')
        READ(10) DEP0
        CLOSE(0)

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Calculate the UPSILON
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

        DO I = ML , MU
            DO J = NL , NU
                IF(J==NU) THEN
                    DDEP(I,J) = 0.D0
                ELSE
                    DDEP(I,J) = (DEP0(I,J+1)-DEP0(I,J)) / dx
                END IF
                Upsilon(I,J) = SQRT(1+DDEP(I,J)**2)
            END DO
        END DO

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Calculate the Area
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

        DO I = ML , MU
            aa1 = 0.d0
            do J = NL , NU-1
                h1 = DEP0(I,J)
                h2 = DEP0(I,J+1)
                if(h1>0.d0.and.h2>0.d0) then
                    aa1 = aa1 + 0.5d0*dx*(h1+h2)
                    Rh2(I,FID0) = Rh2(I,FID0) + UPSILON(I,J)*dx
                    Rh1(I,FID0) = Rh1(I,FID0) + dx*(0.5D0*(h1+h2))**(7.D0/6.D0)
                elseif(h1>0.d0.and.h2<=0.d0) then
                    CC = h1 / (h1 - h2)
                    aa1 = aa1 + 0.5d0*dx*h1*CC
                    Rh2(I,FID0) = Rh2(I,FID0) + UPSILON(I,J)*dx*CC
                    Rh1(I,FID0) = Rh1(I,FID0) + dx*(h1)**(7.D0/6.D0)*CC
                elseif(h1<=0.d0.and.h2>0.d0) then
                    CC = h2 / (h2 - h1)
                    aa1 = aa1 + 0.5d0*dx*h2*CC
                    Rh2(I,FID0) = Rh2(I,FID0) + UPSILON(I,J)*dx*CC
                    Rh1(I,FID0) = Rh1(I,FID0) + dx*(h2)**(7.D0/6.D0)*CC
                end if
            end do
            Steady_Area(I,FID0) = aa1*2.D0
            Rh1(I,FID0) = Rh1(I,FID0)*2.D0
            Rh2(I,FID0) = Rh2(I,FID0)*2.D0
            Rh1(I,FID0) = (Rh1(I,FID0)/Steady_Area(I,FID0))**6
            Rh2(I,FID0) = Steady_Area(I,FID0)/Rh2(I,FID0)
        END DO

        LPT:DO

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Time variation
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

            T0 = T0 + DT

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Longitudinal 1D model, calculate discharge Q
!   , surface elevation eta AND cross-section area
!- - - - - - - - - - - - - - - - - - - - - - - - - - -
#ifdef TIDE_OSCILLATION
            CALL Water_Continuity_Model(EE1,DEE1,DEP0,T0,TDEP0,QQ1,BC,AC)
            QQ1(:) = QQ1(:)*2.D0
#else
            DO  I  = ML , MU
                QQ1(I) = DBLE(MU-I)/DBLE(MU-ML)*Q_CONST*2.D0
            END DO
#endif
!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Calculate the tidal prism
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

            DO I = ML , MU
                MAX_Q(I,FID0) = DMAX1(MAX_Q(I,FID0),QQ1(I))
                TD_Prism(I,FID0) = TD_Prism(I,FID0) + QQ1(I)*DT
            ENDDO

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
! reaching the high tide , exit
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

            IF(T0>=TDCYC) THEN
                T0 = 0.5D0*TDCYC
                EXIT LPT
            END IF

        END DO LPT
    END DO LPF

!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =

! OUTPUT

    OPEN(UNIT=10,FILE='Prism2.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) TD_Prism
    CLOSE(10)

    OPEN(UNIT=10,FILE='Area2.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) Steady_Area
    CLOSE(10)

    OPEN(UNIT=10,FILE='Rh1.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) Rh1
    CLOSE(10)

    OPEN(UNIT=10,FILE='Rh2.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) Rh2
    CLOSE(10)

    OPEN(UNIT=10,FILE='MaxQ.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) Max_Q
    CLOSE(10)

    DEALLOCATE(TD_Prism,stat=status,errmsg=err_msg)
    DEALLOCATE(Steady_Area,stat=status,errmsg=err_msg)
    DEALLOCATE(Rh1,stat=status,errmsg=err_msg)
    DEALLOCATE(Max_Q,stat=status,errmsg=err_msg)

! CPU Timer : END

    !CALL CPU_TIME(TT2)
    !WRITE(*,101) (TT2-TT1)/60.
    !PAUSE

101 FORMAT("The simulation costs ",f5.1," minuts")
102 FORMAT("DAY = ",I5)

END SUBROUTINE PA_RELATION


c
c
c     =====================================================
      subroutine clawpack46_rpt2(ixy,maxm,meqn,mwaves,mbc,mx,
     &      ql,qr,aux1,aux2,aux3, imp,asdq,bmasdq,bpasdq)
c     =====================================================
      implicit none
c
c     # Riemann solver in the transverse direction for the acoustics equations.
c
c     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.
c
      integer ixy, maxm, meqn, mwaves, mbc, mx, imp
      double precision     ql(1-mbc:maxm+mbc, meqn)
      double precision     qr(1-mbc:maxm+mbc, meqn)
      double precision   asdq(1-mbc:maxm+mbc, meqn)
      double precision bmasdq(1-mbc:maxm+mbc, meqn)
      double precision bpasdq(1-mbc:maxm+mbc, meqn)
      double precision aux1(1-mbc:maxm+mbc, *)
      double precision aux2(1-mbc:maxm+mbc, *)
      double precision aux3(1-mbc:maxm+mbc, *)

c
c     # density, bulk modulus, and sound speed, and impedence of medium:
c     # (should be set in setprob.f)
      double precision rho, bulk, cc, zz
      common /cparam/ rho,bulk,cc,zz

      integer mu, mv, i
      double precision a1, a2

c
      if (ixy.eq.1) then
          mu = 2
          mv = 3
        else
          mu = 3
          mv = 2
        endif
c
      do i = 2-mbc, mx+mbc
         a1 = (-asdq(i,1) + zz*asdq(i,mv)) / (2.d0*zz)
         a2 = ( asdq(i,1) + zz*asdq(i,mv)) / (2.d0*zz)
c
c        # The down-going flux difference bmasdq is the product  -c * wave
c
         bmasdq(i,1)  = cc * a1*zz
         bmasdq(i,mu) = 0.d0
         bmasdq(i,mv) = -cc * a1
c
c        # The up-going flux difference bpasdq is the product  c * wave
c
         bpasdq(i,1)  = cc * a2*zz
         bpasdq(i,mu) = 0.d0
         bpasdq(i,mv) = cc * a2
c
      end do
c
      return
      end


        subroutine nl_to_RGB(rad,glwref,contrast,cntref,iverbose,rc,gc,bc)

        include 'wa.inc'
        include 'wac.inc'

        real luminance ! candela / m**2
        real luma_of_counts
        integer init /0/
        save init,fasun

        parameter (day_int = day_int0)

!       Exponential clipping of gamma function
!       expgamma(x) = 1. - exp(-x**(1./gamma))
!       expgaminv(x) = (-(log(1.-x)))**gamma ! inverse of expgamma
!       radhi(glwref,cntref) = (10.**glwref) / (expgaminv(cntref/255.))
!       rad_to_counts2(rad1) = expgamma(rad1/radhi(glwref,cntref)) * 255.

!       Straight gamma function
        fgamma(x) = x**(1./gamma)
        fgaminv(x) = x**gamma ! inverse of expgamma
        radhi(glwref,cntref) = (10.**glwref) / (fgaminv(cntref/255.))
        rad_to_counts2(rad1) = fgamma(rad1/radhi(glwref,cntref)) * 255.

!       Convert nl to rintensity

!       Radiance units are watts/(m**2 sr nm)

!       Day_int0 is luminance of sunlight from 1AU distance uniformly
!       scattered throughout a 360 degree sphere. This will be defined as
!       the spectral radiance matching that of the solar spectrum.
!       Note solar constant is 1361.5 watts/m**2
        real rad(nc)
        real rel_solar(nc), cdm2(nc)
        real fasun(nct), rel_solar_extrap(nct), farad(nct)
        real nl_int

        if(init .eq. 0)then
            write(6,*)' initializing a call to get_fluxsun ',init
            call get_fluxsun(wa_tri,nct,1,fasun)
            init = 1
        endif

        if(maxval(rad(:)) .eq. 0.)then
            rc = 0.; gc = 0.; bc = 0.
            return
        endif

!       nl_int = rgb_to_y(rad(1),rad(2),rad(3))

        rel_solar(:) = rad(:) / day_int
        rel_solar_luminance = rgb_to_y(rel_solar(1),rel_solar(2) &
                                      ,rel_solar(3))
        if(iverbose .eq. 1)then
          write(6,*)'rel_solar_luminance = ',rel_solar_luminance
        endif

!       1 lambert = 3183.0988 candela/m**2        (luminance)
!       1 lux = 1 lumen/m**2                      (illuminance)
!       1 lux = 1 lumen/m**2                      (luminous exitance)
!       1 candela = 1/683.002 watts/sr (at 550nm) (luminous intensity)
!       1 watt = 683 lumens (555nm source)        (radiant flux)
!       1 watt =  93 lumens (solar spectrum)      (radiant flux)
!       1 watt/m**2                               (irradiance)
!       1 lumen = 1 cd*sr                         (luminous flux)
!       1 candela = 1 lumen per steradian         (luminous intensity)
        cdm2(:) = (rad(:)/1e9) * 3183.0988 ! nl to candela/m**2

!       Extrapolate color
        call extrap_color(rel_solar,rel_solar_extrap) ! dimensionless
        farad(:) = fasun(:) * rel_solar_extrap(:)     ! spect irradiance
        if(iverbose .eq. 1)write(6,*)' farad = ',farad

!       Convert sprad to xyz
        call get_tricolor(farad,iverbose,xx,yy,zz,x,y,z,luminance)
        if(iverbose .eq. 1)write(6,*)'xyzfarad = ',x,y,z
        if(iverbose .eq. 1)write(6,*)'luminance farad = ',luminance

!       Convert xyz to (linear) rgb
        ct = 5780.
        if(iverbose .eq. 1)write(6,*)'ct = ',ct
        call xyztosrgb(x,y,z,ct,r,g,b)

!       Convert rintensity to rgb (gamma correction)
        call linearrgb_to_counts(r,g,b,rc,gc,bc)

        if(iverbose .eq. 1)write(6,*)'glwref/contrast = ',glwref,contrast

!       if(iverbose .eq. 1)write(6,*)'desired rad = ',desired_rad

        luma_of_counts = RGB2luma(rc,gc,bc)
        if(iverbose .eq. 1)write(6,*)'luma_of_counts = ',luma_of_counts

!       solar_counts = 240.
        solar_counts = rad_to_counts2(day_int)
        if(iverbose .eq. 1)then
            write(6,*)'day_int = ',day_int
            write(6,*)'glwref = ',glwref
            write(6,*)'cntref = ',cntref
            write(6,*)'solar_counts = ',solar_counts
        endif

!       desired_luma = 240. * rel_solar_luminance**(1./gamma)
!       desired_luma = solar_counts + log10(rel_solar_luminance) * contrast
        desired_luma = rad_to_counts2(day_int*rel_solar_luminance)
        if(iverbose .eq. 1)write(6,*)'desired luma = ',desired_luma
        scale_luma = desired_luma / luma_of_counts
        if(iverbose .eq. 1)write(6,*)'scale_luma = ',scale_luma
        rc = rc * scale_luma
        gc = gc * scale_luma
        bc = bc * scale_luma

        return
        end

        subroutine extrap_color(a_nc,a_nct)

        include 'wa.inc'
        include 'wac.inc'

        real a_nc(nc), a_nct(nct)

!       Assuming nc = 3, find polynomial fit
        X1 = wa(1);   X2 = wa(2);   X3 = wa(3)
        Y1 = a_nc(1); Y2 = a_nc(2); Y3 = a_nc(3)

        a = ((Y2-Y1)*(X1-X3) + (Y3-Y1)*(X2-X1)) / &
            ((X1-X3)*(X2**2-X1**2) + (X2-X1)*(X3**2-X1**2))
        b = ((Y2 - Y1) - A*(X2**2 - X1**2)) / (X2-X1)
        c = Y1 - A*X1**2 - B*X1

        a_nct(:) = a*wa_tri(:)**2 + b*wa_tri(:) + c

        return
        end

        subroutine rad_to_xyz(rad_in,x,y,z)

        real rad_in(3),rad(3)

        rad(1) = rad_in(1) + 0.2 * rad_in(3)
        rad(2) = rad_in(2)
        rad(3) = rad_in(3)

        x = rad(1) / sum(rad)
        y = rad(2) / sum(rad)
        z = rad(3) / sum(rad)

        return
        end

        subroutine linearrgb_to_counts(r,g,b,rc,gc,bc)

        parameter (gamma = 2.2)

        rr = r ** (1./gamma)
        gg = g ** (1./gamma)
        bb = b ** (1./gamma)

        rc = rr*255.
        gc = gg*255.
        bc = bb*255.

        return
        end

        subroutine xyztorgb(x,y,z,r,g,b)

        xx = x; yy = y; zz = z

        R=  (0.41847   *XX)-(0.15866  *YY)-(0.082835*ZZ)
        G= -(0.091169  *XX)+(0.25243  *YY)+(0.015708*ZZ)
        B=  (0.00092090*XX)-(0.0025498*YY)+(0.17860 *ZZ)

        return
        end

        subroutine rgbtoxyz(r,g,b,x,y,z)

        x = (.49    * r + .31    * g + .20    * b) / 0.17697
        y = (.17697 * r + .81240 * g + .01063 * b) / 0.17697
        z = (             .01    * g + .99    * b) / 0.17697

        return
        end

        subroutine xyztosrgb(x,y,z,ct,r,g,b)

        colfrac = (ct - 5000.) / (6500. - 5000.)

        r65 =  3.2406*x -1.5372*y -0.4986*z
        g65 = -0.9689*x +1.8758*y +0.0415*z
        b65 =  0.0557*x -0.2040*y +1.0570*z

        r50 =  3.1339*x -1.6169*y -0.4906*z
        g50 = -0.9785*x +1.9160*y +0.0333*z
        b50 =  0.0720*x -0.2290*y +1.4057*z

        r = r65 * colfrac + r50 * (1.-colfrac)
        g = g65 * colfrac + g50 * (1.-colfrac)
        b = b65 * colfrac + b50 * (1.-colfrac)

!       Clip at 0. when outside the gamut
        r = max(r,0.)
        g = max(g,0.)
        b = max(b,0.)

        return
        end

        subroutine srgbtoxyz(r,g,b,ct,x,y,z)

        colfrac = (ct - 5000.) / (6500. - 5000.)

        x65 =  0.4124*r + 0.3576*g + 0.1805*b
        y65 =  0.2126*r + 0.7152*g + 0.0722*b
        z65 =  0.0193*r + 0.1192*g + 0.9505*b

        x50 =  0.4361*r + 0.3851*g + 0.1430*b
        y50 =  0.2225*r + 0.7169*g + 0.0606*b
        z50 =  0.0139*r + 0.0971*g + 0.7141*b

        x = x65 * colfrac + x50 * (1.-colfrac)
        y = y65 * colfrac + y50 * (1.-colfrac)
        z = z65 * colfrac + z50 * (1.-colfrac)

        return
        end

        subroutine get_fluxsun(wa,nc,iverbose,fa)

!       include 'wa.inc'
!       include 'wac.inc'

!       Returns solar spectral irradiance for selected wavelengths

        real fa(nc) ! watts/(m**2 nm)
        real wa(nc) ! wavelengths in microns

        if(iverbose .eq. 1)write(6,*)'  subroutine get_fluxsun',nc,wa

        TS = 5900. ! 5780.
        DS = 1.0 * 1.496e13 ! au to cm
        RS = 1.0 * 6.96e10  ! solar radii to cm
        xc = 0.; yc = 0.; zc = 0.

        do ic = 1,nc
          W = wa(ic) * 1e-4 ! microns to cm
          w_ang = wa(ic) * 10000.
          BB = (.0000374/(W**5.)) / (EXP(1.43/(W*TS))-1.)
          if(iverbose .eq. 1)write(6,*)'ic/w/bb',ic,w,bb
          FA(IC)=((RS/DS)**2)*BB*1E-8 ! erg/cm2/s/A
          FA(IC)=FA(IC) * .01         ! convert to W/m2/nm
        enddo ! ic

        if(iverbose .eq. 1)write(6,*)'fa sun is ',fa

        return
        end

        subroutine get_tricolor(fa,iverbose,xc,yc,zc,x,y,z,luminance)

        include 'wa.inc'
        include 'wac.inc'

!       Integrate spectral irradiance with the color matching functions

        real fa(nct)   ! spectral irradiance array vs wavelength (Input)
        real luminance ! candela / m**2                    (Output = yc)
        character*255 static_dir

!       3500 to 8000 Angstroms in 10 steps (color matching functions)
        real x1(nct)!/0, .014, .336, .005, .433, 1.062, .283, .011, 0, 0/
        real y1(nct)!/0, .0004, .038, .323, .995, .631, .107, .004, .0001, 0/
        real z1(nct)!/0, .068, 1.773, .272, .009, 0,0,0,0,0/
        integer init/0/
        save x1,y1,z1,init

        if(init .eq. 0)then
          call get_directory('static',static_dir,len_dir)
          open(11,file=trim(static_dir)//'/cie2.txt',status='old')
!         open(11,file='cie2.txt',status='old')
          do ict = 1,nct
            read(11,*)inm,x1(ict),y1(ict),z1(ict)
          enddo ! ict
          init = 1
        endif

        xc = 0.; yc = 0.; zc = 0.

!       Integrate with trapezoidal rule
        do ic = 2,nct
          icm = ic-1
          W = wa_tri(ic) * 1e-4 ! microns to cm
          w_ang = wa_tri(ic) * 10000.

          xs = 0.5 * (x1(icm)*fa(icm) + x1(ic)*fa(ic))
          ys = 0.5 * (y1(icm)*fa(icm) + y1(ic)*fa(ic))
          zs = 0.5 * (z1(icm)*fa(icm) + z1(ic)*fa(ic))

          xc = xc + xs
          yc = yc + ys
          zc = zc + zs

          if(iverbose .eq. 1)then
            write(6,1)ic,w_ang,fa(ic),xs,ys,zs,xc,yc,zc
1           format(' ic,wa,fa',i4,f8.0,f10.5,' xyzs',3f10.5,' xyzc',3f10.5)
          endif

        enddo ! ic

        x = xc / (xc+yc+zc)
        y = yc / (xc+yc+zc)
        z = zc / (xc+yc+zc)

        luminance = yc

        if(iverbose .eq. 1)write(6,11)x,y,z,luminance
11      format(' xyzl tricolor is ',3f10.6,f12.0)

        return
        end

      subroutine hsl_to_rgb(hue,sat,rintens,red,grn,blu)

      real luma

!     Hue is 0:R, 1:B, 2:G, 3:R

      red1 = max(1.0 - abs(hue - 0.0),0.0)
      red2 = max(1.0 - abs(hue - 3.0),0.0)
      red = max(red1,red2)
      grn = max(1.0 - abs(hue  - 2.0),0.0)
      blu = max(1.0 - abs(hue  - 1.0),0.0)

!     Normalize to the max intensity
      colmax = max(red,grn,blu)
      if(colmax .gt. 0.)then
          red = red/colmax
          grn = grn/colmax
          blu = blu/colmax
      endif

      red = (red*sat) + 1.0*(1.0-sat)
      grn = (grn*sat) + 1.0*(1.0-sat)
      blu = (blu*sat) + 1.0*(1.0-sat)

      red = red * rintens
      grn = grn * rintens
      blu = blu * rintens

!     Scale the RGB intensity according to the luma calculation

      luma = .30 * red + .59 * grn + .11 * blu

      if(luma .gt. 0.)then
          ratio_corr = rintens / luma
      else
          ratio_corr = 1.0
      endif

      red = red * ratio_corr
      grn = grn * ratio_corr
      blu = blu * ratio_corr

      return
      end


C    %W% %G%
        subroutine piequi (brnch,gk1,bk1,gk2,bk2,g12,b12,g21,b21)
C * * *
C * * * THIS SUBROUTINE FORMS A SINGLE EQUIVALENT PI FOR A GIVEN
C * * * ENTRY IN THE BRDATA TABLE.  IT IS CALLED BY INPUT2
C * * *
      include 'tspinc/params.inc'
        dimension brnch(18)
        complex y(2,2),cx
        equivalence (rk1,k1), (rk2,k2), (rltype,ltype), (rlist,list)
      include 'tspinc/namec.inc'
      include 'tspinc/pointr.inc'
C
C       THIS SUBROUTINE COMPUTES THE 2-PORT ADMITTANCE MATRIX Y
C       FOR BRNCH (1)
C
        rltype=brnch(1)
        rk1=brnch(2)
        rk2=brnch(12)
        rlist=brnch(17)
        go to (240,240,100,240,100,100,240,100)ltype
C
C       COMPUTE TRANSFER IMPEDANCE
C
  100   r=brnch(5)
        x=brnch(6)
        z=r**2 + x**2
  120   go to (240,280,130,280,150,180,280,140) ltype
C
C       " L " BRANCH
C
  130   y(1,2)=-cmplx (r/z, -x/z)
        y(2,1) = y(1,2)
        y(1,1)=cmplx (brnch(7),brnch(8))-y(1,2)
        y(2,2)=y(1,1)
         go to 260
C
C       " E " BRANCH
C
  140   y(1,2)= -cmplx (r/z, -x/z)
        y(2,1)=y(1,2)
        y(1,1)=cmplx(brnch(7),brnch(8))-y(1,2)
        y(2,2)=cmplx(brnch(9),brnch(10))-y(2,1)
        go to 260
C
C       " T " BRANCH
C
  150   i1=ixnamn(k1)
        i2=ixnamn(k2)
        tk=brnch(9)/basekv(i1)
        tm=brnch(10)/basekv(i2)
        tkm=1.0/(tk*tm)
        y(1,1)=cmplx(0.5*tkm*brnch(7),-0.5*tkm*abs(brnch(8)))
        y(2,2)=y(1,1)
        y(1,2)=-cmplx(r/(z*tk*tm),-x/(z*tk*tm))
        y(2,1)=y(1,2)
        y(1,1)=y(1,1)+cmplx (r/(z*tk*tk),-x/(z*tk*tk))
        y(2,2)=y(2,2)+cmplx (r/(z*tm*tm), -x/(z*tm*tm))
        go to 260
C
C       " TP " BRANCH
C
  180   tk=brnch(9)
        i1=ixnamn(k1)
        i2=ixnamn(k2)
        if(list.eq.0) tm=brnch(10)/basekv(i1)
        if(list.eq.1) tm=brnch(10)/basekv(i2)
        if(tm.eq.0.0)tm=1.0
        angle=0.0174532925*tk
        y(1,2)=cmplx(0.5*brnch(7),-0.5*abs(brnch(8)))
        y(1,1)=y(1,2)+cmplx(r/z,-x/z)
        y(2,2)=y(1,2)+cmplx(r/z,-x/z)/cmplx(tm**2,0.0)
        y(1,2)=-cmplx(cos(angle),sin(angle))*cmplx(r/(z*tm),-x/(z*tm))
        y(2,1)=-cmplx(cos(angle),-sin(angle))*cmplx(r/(z*tm),-x/(z*tm))
        if (list.eq.0) go to 230
        cx=y(2,2)
        y(2,2)=y(1,1)
        y(1,1)=cx
  230   continue
        go to 260
C
C       " L "  EQUIVALENT BRANCH
C
  240   gk1=brnch(4)+brnch(6)
        bk1=brnch(5)+brnch(7)
        g12=-brnch(6)
        b12=-brnch(7)
        g21=-brnch(8)
        b21=-brnch(9)
         gk2=brnch(10)+brnch(8)
        bk2=brnch(11)+brnch(9)
        go to 280
  260   continue
        gk1 = real (y(1,1)+y(1,2))
        bk1 = aimag (y(1,1)+y(1,2))
        gk2 = real (y(2,2)+y(2,1))
        bk2 = aimag (y(2,2)+y(2,1))
        g12 = -real (y(1,2))
        b12 = -aimag (y(1,2))
         g21 = -real (y(2,1))
        b21 = -aimag (y(2,1))
  280   return
        end


      DOUBLE PRECISION FUNCTION QUAPE3(F,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  QUANTILE FUNCTION OF THE PEARSON TYPE 3 DISTRIBUTION
C
C  OTHER ROUTINES USED: DERF,DLGAMA,GAMIND,QUAGAM,QUASTN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3),PAR(2)
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,FOUR/4D0/
C
C         SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
C
      DATA SMALL/1D-6/
C
      IF(PARA(2).LE.ZERO)GOTO 1000
      GAMMA=PARA(3)
      IF(F.LE.ZERO.OR.F.GE.ONE)GOTO 20
      IF(DABS(GAMMA).LT.SMALL)GOTO 10
      ALPHA=FOUR/(GAMMA*GAMMA)
      BETA=DABS(HALF*PARA(2)*GAMMA)
      PAR(1)=ALPHA
      PAR(2)=BETA
      IF(GAMMA.GT.ZERO)QUAPE3=PARA(1)-ALPHA*BETA+QUAGAM(F,PAR)
      IF(GAMMA.LT.ZERO)QUAPE3=PARA(1)+ALPHA*BETA-QUAGAM(ONE-F,PAR)
      RETURN
C
C         ZERO SKEWNESS
C
   10 QUAPE3=PARA(1)+PARA(2)*QUASTN(F)
      RETURN
C
   20 IF(F.EQ.ZERO.AND.GAMMA.GT.ZERO)GOTO 30
      IF(F.EQ.ONE .AND.GAMMA.LT.ZERO)GOTO 30
      WRITE(6,7000)
      QUAPE3=ZERO
      RETURN
   30 QUAPE3=PARA(1)-TWO*PARA(2)/GAMMA
      RETURN
C
 1000 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE QUAPE3 :',
     *  ' ARGUMENT OF FUNCTION INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE QUAPE3 : PARAMETERS INVALID')
      END