module arnoldi
  implicit none

contains

!     Description:

!     Arnoldi process. The matrix A is approximated by h on the subspace

!       h = v^T A v on Krylov subspace  {x, A*x, A^2*x, ... A^(m-1)*x}

!     Parameters:

!     A (in): a n-by-n square sparse matrix
!     x (in): a vector with n elements
!     h (out): m-by-m square Hessenburg matrix
!     v (out): n-by-m matrix of orthogonal vectors on Krylov subspace {x, A*x, A^2*x, ... A^(m-1)*x}

!     tol (in): tolerance error for happy breakdown
!     ite (in): the number of times of iteration for Arnoldi process to reduce roundoff errors
!               ite=1 is enough in most cases
!     rnorm (out): 2-norm of vector x (and is used for checking for happy breakdown)
!     info (out): the size of effective dimensions of h when a happy breakdown occurs

!     work: working area. The required size is n.

  subroutine arnoldi_dense(trans, n, A, lda, x, incx, m, H, ldh, V, ldv, &
    beta, rnorm, tol, ite, info)
    character, intent(in) :: trans
    integer, intent(in) :: n, lda, incx, m, ldh, ldv, ite
    double precision, intent(in) :: A(1:lda,1:n), x(1:incx,1:n), tol
    double precision, intent(out) :: H(1:ldh,1:m), V(1:ldv,1:m)
    double precision, intent(out) :: beta, rnorm
    integer, intent(out) :: info

    integer :: j, i, l
    double precision :: dnrm2, ddot
    double precision :: r, tmp(1:n)

    rnorm = sqrt(sum(A(1:n,1:n)**2))
    beta = dnrm2(n, x, incx)
    H(1:m,1:m) = 0.0d0
    V(1:n,1:m) = 0.0d0

    call daxpy(n, 1.0d0/beta, x, incx, V(1,1), 1)
    do j = 1, m
      call dgemv(trans, n, n, 1.0d0, A, lda, V(1,j), 1, 0.0d0, tmp, 1)
      do i = 1, j
        do l = 1, ite
          r = ddot(n, V(1,i), 1, tmp, 1)
          H(i,j) = H(i,j) + r
          call daxpy(n, -r, V(1,i), 1, tmp, 1)
        end do
      end do
      if (j /= m) then
        H(j+1,j) = dnrm2(n, tmp, 1)
        if (H(j+1,j) < rnorm * tol) then
          info = j
          return
        end if
        call daxpy(n, 1.0d0/H(j+1,j), tmp, 1, V(1,j+1), 1)
      end if
    end do
    info = m
  end subroutine arnoldi_dense

  subroutine arnoldi_csr(trans, n, A, rowptr, colind, nnz, &
    x, incx, m, H, ldh, V, ldv, beta, rnorm, tol, ite, info)
    use spblas
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, incx, m, ldh, ldv, ite
    double precision, intent(in) :: A(1:nnz), x(1:incx,1:n), tol
    integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
    double precision, intent(out) :: H(1:ldh,1:m), V(1:ldv,1:m)
    double precision, intent(out) :: beta, rnorm
    integer, intent(out) :: info

    integer :: j, i, l
    double precision :: dnrm2, ddot
    double precision :: r, tmp(1:n)

    rnorm = dnrm2(nnz, A, 1)
    beta = dnrm2(n, x, incx)
    H(1:m,1:m) = 0.0d0
    V(1:n,1:m) = 0.0d0

    call daxpy(n, 1.0d0/beta, x, incx, V(1,1), 1)
    do j = 1, m
      call dcsrmv(trans, n, n, 1.0d0, A, rowptr, colind, nnz, V(1,j), 1, 0.0d0, tmp, 1)
      do i = 1, j
        do l = 1, ite
          r = ddot(n, V(1,i), 1, tmp, 1)
          H(i,j) = H(i,j) + r
          call daxpy(n, -r, V(1,i), 1, tmp, 1)
        end do
      end do
      if (j /= m) then
        H(j+1,j) = dnrm2(n, tmp, 1)
        if (H(j+1,j) < rnorm * tol) then
          info = j
          return
        end if
        call daxpy(n, 1.0d0/H(j+1,j), tmp, 1, V(1,j+1), 1)
      end if
    end do
    info = m
  end subroutine arnoldi_csr

  subroutine arnoldi_csc(trans, n, A, colptr, rowind, nnz, &
    x, incx, m, H, ldh, V, ldv, beta, rnorm, tol, ite, info)
    use spblas
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, incx, m, ldh, ldv, ite
    double precision, intent(in) :: A(1:nnz), x(1:incx,1:n), tol
    integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
    double precision, intent(out) :: H(1:ldh,1:m), V(1:ldv,1:m)
    double precision, intent(out) :: beta, rnorm
    integer, intent(out) :: info

    integer :: j, i, l
    double precision :: dnrm2, ddot
    double precision :: r, tmp(1:n)

    rnorm = dnrm2(nnz, A, 1)
    beta = dnrm2(n, x, incx)
    H(1:m,1:m) = 0.0d0
    V(1:n,1:m) = 0.0d0

    call daxpy(n, 1.0d0/beta, x, incx, V(1,1), 1)
    do j = 1, m
      call dcscmv(trans, n, n, 1.0d0, A, colptr, rowind, nnz, V(1,j), 1, 0.0d0, tmp, 1)
      do i = 1, j
        do l = 1, ite
          r = ddot(n, V(1,i), 1, tmp, 1)
          H(i,j) = H(i,j) + r
          call daxpy(n, -r, V(1,i), 1, tmp, 1)
        end do
      end do
      if (j /= m) then
        H(j+1,j) = dnrm2(n, tmp, 1)
        if (H(j+1,j) < rnorm * tol) then
          info = j
          return
        end if
        call daxpy(n, 1.0d0/H(j+1,j), tmp, 1, V(1,j+1), 1)
      end if
    end do
    info = m
  end subroutine arnoldi_csc

  subroutine arnoldi_coo(trans, n, A, rowind, colind, nnz, &
    x, incx, m, H, ldh, V, ldv, beta, rnorm, tol, ite, info)
    use spblas
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, incx, m, ldh, ldv, ite
    double precision, intent(in) :: A(1:nnz), x(1:incx,1:n), tol
    integer, intent(in) :: rowind(1:nnz), colind(1:nnz)
    double precision, intent(out) :: H(1:ldh,1:m), V(1:ldv,1:m)
    double precision, intent(out) :: beta, rnorm
    integer, intent(out) :: info

    integer :: j, i, l
    double precision :: dnrm2, ddot
    double precision :: r, tmp(1:n)

    rnorm = dnrm2(nnz, A, 1)
    beta = dnrm2(n, x, incx)
    H(1:m,1:m) = 0.0d0
    V(1:n,1:m) = 0.0d0

    call daxpy(n, 1.0d0/beta, x, incx, V(1,1), 1)
    do j = 1, m
      call dcoomv(trans, n, n, 1.0d0, A, rowind, colind, nnz, V(1,j), 1, 0.0d0, tmp, 1)
      do i = 1, j
        do l = 1, ite
          r = ddot(n, V(1,i), 1, tmp, 1)
          H(i,j) = H(i,j) + r
          call daxpy(n, -r, V(1,i), 1, tmp, 1)
        end do
      end do
      if (j /= m) then
        H(j+1,j) = dnrm2(n, tmp, 1)
        if (H(j+1,j) < rnorm * tol) then
          info = j
          return
        end if
        call daxpy(n, 1.0d0/H(j+1,j), tmp, 1, V(1,j+1), 1)
      end if
    end do
    info = m
  end subroutine arnoldi_coo

end module arnoldi


      program lapackpractice1
        integer, parameter :: rp = selected_real_kind(15)
         integer, parameter :: nxn = 5
        real ( kind = rp ), dimension(nxn, nxn) :: x
        real ( kind = rp ), dimension(nxn, nxn) :: xinv
         ! double precision :: x
         ! double precision :: xinv

!           external DGETRF
!           external DGETRI
!           external inv

         open( file = "R:/DataSets/5x5Matrix.txt", unit = 34)

         read(34, *) x
         print *, x
         xinv = x

         xinv = inv(xinv)
         xinv =  matmul(x, xinv)
         print *, xinv

      end program lapackpractice1


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!This file is "Hartree.f90"
!This file contain one subroutine.
!SUBROUTINE Hartree
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine Hartree
  use Global_Variables
  use timer
  implicit none
  integer :: i,ix,iy,iz,n,nx,ny,nz
  real(8) :: G2

  call timer_begin(LOG_HARTREE)

!$omp parallel

!$omp do private(i)
  do i=1,NL
    rho_3D(Lx(i),Ly(i),Lz(i))=rho(i)
  end do
!$omp end do

!$omp do private(ix,iy,nz) collapse(3)
  do nz = -NLz/2,NLz/2-1
  do iy = 0,NLy-1
  do ix = 0,NLx-1
    f1(ix,iy,nz)=sum(eGzc(nz,:)*rho_3D(ix,iy,:))
  end do
  end do
  end do
!$omp end do

!$omp do private(ix,ny,nz) collapse(3)
  do nz = -NLz/2,NLz/2-1
  do ny = -NLy/2,NLy/2-1
  do ix = 0,NLx-1
    f2(ix,ny,nz)=sum(eGyc(ny,:)*f1(ix,:,nz))
  end do
  end do
  end do
!$omp end do

!$omp do private(nx,ny,nz) collapse(3)
  do nz = -NLz/2,NLz/2-1
  do ny = -NLy/2,NLy/2-1
  do nx = -NLx/2,NLx/2-1
    rhoe_G_3D(nx,ny,nz)=sum(eGxc(nx,:)*f2(:,ny,nz))/dble(NL)
  end do
  end do
  end do
!$omp end do

!$omp do private(nx,ny,nz,G2) collapse(3)
  do nz = -NLz/2,NLz/2-1
  do ny = -NLy/2,NLy/2-1
  do nx = -NLx/2,NLx/2-1
    rhoe_G_temp(nxyz(nx,ny,nz))=rhoe_G_3D(nx,ny,nz)
    G2=Gx(nxyz(nx,ny,nz))**2+Gy(nxyz(nx,ny,nz))**2+Gz(nxyz(nx,ny,nz))**2
    rhoe_G_3D(nx,ny,nz)=4*Pi/G2*rhoe_G_3D(nx,ny,nz)
  end do
  end do
  end do
!$omp end do

  rhoe_G_3D(0,0,0)=0.d0

!$omp do private(n)
  do n=NG_s,NG_e
    rhoe_G(n)=rhoe_G_temp(n)
  end do
!$omp end do

!$omp do private(nx,ny,iz) collapse(3)
  do iz = 0,NLz-1
  do ny = -NLy/2,NLy/2-1
  do nx = -NLx/2,NLx/2-1
    f3(nx,ny,iz)=sum(eGz(:,iz)*rhoe_G_3D(nx,ny,:))
  end do
  end do
  end do
!$omp end do

!$omp do private(nx,iy,iz) collapse(3)
  do iz = 0,NLz-1
  do iy = 0,NLy-1
  do nx = -NLx/2,NLx/2-1
    f4(nx,iy,iz)=sum(eGy(:,iy)*f3(nx,:,iz))
  end do
  end do
  end do
!$omp end do

!$omp do private(ix,iy,iz) collapse(3)
  do iz = 0,NLz-1
  do iy = 0,NLy-1
  do ix = 0,NLx-1
    Vh_3D(ix,iy,iz)=sum(eGx(:,ix)*f4(:,iy,iz))
  end do
  end do
  end do
!$omp end do

!$omp do private(i)
  do i=1,NL
    Vh(i)=Vh_3D(Lx(i),Ly(i),Lz(i))
  end do
!$omp end do

!$omp end parallel

  call timer_end(LOG_HARTREE)

  return
End Subroutine Hartree
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130


      subroutine basisp
c     implicit double precision (a-h,o-z)                                    dp
      common/bk30/numlp,numpc,h22(2,2),pl2(2,2),h33(3,2),pl3(3,2)
      dimension s(2)
      data s/-.5773502691895,.5773502691896/
      do 10 j=1,2
      h22(1,j)=.5*(1.0-s(j))
      h22(2,j)=.5*(1.0+s(j))
      h33(1,j)=.5*s(j)*(s(j)-1.0)
      h33(2,j)=.5*s(j)*(s(j)+1.0)
      h33(3,j)=1.0-s(j)*s(j)
      pl2(1,j)=-.50
      pl2(2,j)=.50
      pl3(1,j)=s(j)-.50
      pl3(2,j)=s(j)+.50
      pl3(3,j)=-2.*s(j)
   10 continue
      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of cpw in forward (tangent) mode:
!   variations   of useful results: cpw
!   with respect to varying inputs: p t
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity of water in (in J/kg/K)
!> @param[in] p pressure [MPa]
!> @param[in] t temporaryerature [degC]
!> @return cpf  [J/kg/K]
!> @details
!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
!> J/kg/K)\n of pure water, given temporaryerature (t, in C), and
!> pressure (p,in Pa)\n at node(i,j,k).\n \n
!>
!> method: c_p = d/dT E, E= fluid enthalpy.\n \n
!>
!>  Main source Zyvoloski1997: \n
!>
!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
!> of the models and methods for the FEHM application - a
!> finite-element heat- and mass-transfer code. United
!> States. doi:10.2172/565545. \n \n
!>
!> Alternative source (same text, more modern, without doi): \n
!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
!>
!> The table of coefficients from Zyvoloski1997 describes the physical
!> values found in Haar1984: \n
!>
!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
!> Thermodynamic and Transport Properties and Computer Programs for
!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
!> Corporation, Washington, 1984. \n \n
!>
!> range of validity:\n
!> pressures      0.001 - 110 MPa,\n
!> temporaryerature   15 - 350 degC\n
DOUBLE PRECISION FUNCTION g_CPW(p, g_p, t, g_t, cpw)
  IMPLICIT NONE
! Input Pressure (MPa)
  DOUBLE PRECISION, INTENT(IN) :: p
  DOUBLE PRECISION, INTENT(IN) :: g_p
! Input Temperature (degC)
  DOUBLE PRECISION, INTENT(IN) :: t
  DOUBLE PRECISION, INTENT(IN) :: g_t
! Enthalpy (J/kg)
  DOUBLE PRECISION :: enth
! Derivative of enthalpy wrt T (J/kg/K)
  DOUBLE PRECISION :: denthdt
  DOUBLE PRECISION :: g_denthdt
! Monomials of temporaryerature and pressure
  DOUBLE PRECISION :: t2, t3
  DOUBLE PRECISION :: g_t2, g_t3
  DOUBLE PRECISION :: p2, p3, p4
  DOUBLE PRECISION :: g_p2, g_p3
  DOUBLE PRECISION :: tp, t2p, tp2
  DOUBLE PRECISION :: g_tp, g_t2p, g_tp2
! Coefficients of numerator of rational function approximation
  DOUBLE PRECISION, PARAMETER :: y0=0.25623465d-3
  DOUBLE PRECISION, PARAMETER :: y1=0.10184405d-2
  DOUBLE PRECISION, PARAMETER :: y2=0.22554970d-4
  DOUBLE PRECISION, PARAMETER :: y3=0.34836663d-7
  DOUBLE PRECISION, PARAMETER :: y4=0.41769866d-2
  DOUBLE PRECISION, PARAMETER :: y5=-0.21244879d-4
  DOUBLE PRECISION, PARAMETER :: y6=0.25493516d-7
  DOUBLE PRECISION, PARAMETER :: y7=0.89557885d-4
  DOUBLE PRECISION, PARAMETER :: y8=0.10855046d-6
  DOUBLE PRECISION, PARAMETER :: y9=-0.21720560d-6
! Coefficients of denominator of rational function approximation
  DOUBLE PRECISION, PARAMETER :: z0=0.10000000d+1
  DOUBLE PRECISION, PARAMETER :: z1=0.23513278d-1
  DOUBLE PRECISION, PARAMETER :: z2=0.48716386d-4
  DOUBLE PRECISION, PARAMETER :: z3=-0.19935046d-8
  DOUBLE PRECISION, PARAMETER :: z4=-0.50770309d-2
  DOUBLE PRECISION, PARAMETER :: z5=0.57780287d-5
  DOUBLE PRECISION, PARAMETER :: z6=0.90972916d-9
  DOUBLE PRECISION, PARAMETER :: z7=-0.58981537d-4
  DOUBLE PRECISION, PARAMETER :: z8=-0.12990752d-7
  DOUBLE PRECISION, PARAMETER :: z9=0.45872518d-8
! Numerator and denominator of rational function approximation
  DOUBLE PRECISION :: ta, tb
  DOUBLE PRECISION :: g_ta, g_tb
! Derivative of numerator wrt T
  DOUBLE PRECISION :: da
  DOUBLE PRECISION :: g_da
! Derivative of denominator wrt T
  DOUBLE PRECISION :: db
  DOUBLE PRECISION :: g_db
! Denominator squared
  DOUBLE PRECISION :: b2
  DOUBLE PRECISION :: g_b2
  DOUBLE PRECISION :: temporary
  DOUBLE PRECISION :: cpw
! Temperature out of bounds
  IF (t .GT. 360.0d0) THEN
    WRITE(*, *) '[E1]: Error: Temperature (', t, &
&   ') out of bounds (> 360 degC).'
    STOP
  ELSE IF (t .LT. 0.0d0) THEN
! Relax table boundary of 15degC to error boundary 0degC
    WRITE(*, *) '[E2]: Error: Temperature (', t, &
&   ') out of bounds (< 0 degC).'
    STOP
  ELSE IF (p .GT. 110.0d0) THEN
! Pressure out of bounds
    WRITE(*, *) '[E3]: Error: Pressure (', p, &
&   ') out of bounds (> 110 MPa)'
    STOP
  ELSE IF (p .LT. 0.001d0) THEN
    WRITE(*, *) '[E4]: Error: Pressure (', p, &
&   ') out of bounds (< 0.001 MPa)'
    STOP
  ELSE
! Compute monomials in pressure and temporaryerature
    g_p2 = 2*p*g_p
    p2 = p*p
    g_p3 = p*g_p2 + p2*g_p
    p3 = p2*p
    p4 = p3*p
    g_t2 = 2*t*g_t
    t2 = t*t
    g_t3 = t*g_t2 + t2*g_t
    t3 = t2*t
    g_tp = t*g_p + p*g_t
    tp = p*t
    g_tp2 = p2*g_t + t*g_p2
    tp2 = t*p2
    g_t2p = p*g_t2 + t2*g_p
    t2p = t2*p
! Numerator of rational function approximation
    g_ta = y1*g_p + y2*g_p2 + y3*g_p3 + y4*g_t + y5*g_t2 + &
&     y6*g_t3 + y7*g_tp + y8*g_tp2 + y9*g_t2p
    ta = y0 + y1*p + y2*p2 + y3*p3 + y4*t + y5*t2 + y6*t3 + y7*tp + y8*&
&     tp2 + y9*t2p
! Denominator of rational function approximation
    g_tb = z1*g_p + z2*g_p2 + z3*g_p3 + z4*g_t + z5*g_t2 + &
&     z6*g_t3 + z7*g_tp + z8*g_tp2 + z9*g_t2p
    tb = z0 + z1*p + z2*p2 + z3*p3 + z4*t + z5*t2 + z6*t3 + z7*tp + z8*&
&     tp2 + z9*t2p
! Enthalpy
    enth = ta/tb
! Derivative of numerator
    g_da = y5*2.0d0*g_t + y6*3.0d0*g_t2 + y7*g_p + y8*g_p2 + &
&     y9*2.0d0*g_tp
    da = y4 + 2.0d0*y5*t + 3.0d0*y6*t2 + y7*p + y8*p2 + 2.0d0*y9*tp
! Derivative of denominator
    g_db = z5*2.0d0*g_t + z6*3.0d0*g_t2 + z7*g_p + z8*g_p2 + &
&     z9*2.0d0*g_tp
    db = z4 + 2.0d0*z5*t + 3.0d0*z6*t2 + z7*p + z8*p2 + 2.0d0*z9*tp
! Denominator squared
    g_b2 = 2*tb*g_tb
    b2 = tb*tb
! Derivative, quotient rule
    temporary = ta*db/b2
    g_denthdt = (g_da-da*g_tb/tb)/tb - (db*g_ta+ta*g_db-temporary*&
&     g_b2)/b2
    denthdt = da/tb - temporary
! Isobaric heat capacity (J/kg/K)
    g_cpw = 1.0d6*g_denthdt
    cpw = denthdt*1.0d6
    RETURN
  END IF
END FUNCTION g_CPW


      SUBROUTINE scalet( trace, nsamps, def, scalar, rnibs )
c     SCALET converts trace amplitudes into trace rasters for a raster plotter.
c  This routine finds the maximum amplitude (if scalar .LE. 0 ) and finds a
c  multiplier to converts it to be RNIBS*DEF.  If SCALAR is .GT. 0, it simply
c  multiplies the trace by SCALAR * RNIBS.
c
c  ARGUMENTS:
c  trace  - the seismic trace (a set of amplitudes).
c  nsamps - the number of samples in the trace.
c  def    - the deflection, in inches, between peak and trough.
c  scalar - the multiplier to use in converting to rasters.
c  rnibs  - the number of nibs or dots per inch.
c
c  Copyright (C) and written by:
c  Paul Henkart, Scripps Institution of Oceanography, January 1987
c  ALL RIGHTS RESERVED.
c
      DIMENSION trace(nsamps)
      COMMON /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap,
     *       idecimf
      SAVE scalr
      DATA scalr/-1/
c
      IF( scalar .GT. 0. ) scalr = scalar
      IF( scalar .EQ. 0. ) scalr = 0.
      IF( iuseap .EQ. 0 .OR. iasgnd .EQ. 0 ) THEN
          IF( scalr .LE. 0. ) THEN                                       ! do we need to pick a scalar?
              xmax = 0.                                                 ! set the min and max
              xmin = 0.
              DO 100 i = 1, nsamps
                 IF( trace(i) .GT. xmax ) xmax = trace(i)
                 IF( trace(i) .LT. xmin ) xmin = trace(i)
  100         CONTINUE
              IF( xmax .LT. -xmin ) xmax = -xmin                        ! use the absolute value
              IF( xmax .EQ. 0 ) THEN                                    ! is the trace all zeroes?
                  PRINT *,' ***  WARNING  ***  Trace is zero or NaN.'
                  RETURN
              ENDIF
              smult = def / xmax * 2                                    ! find the scalar
              IF( scalar .LT. 0. .AND. scalr .LT. 0 )
     &            PRINT *,' The computed PLOT SCALAR is ',smult
              scalr = smult
          ENDIF
          IF( scalr .LT. 1.0E-30) THEN
              PRINT *,' ***  ERROR  *** Plot scalar too small.',scalar
              STOP
          ENDIF
          IF( scalr .GT. 1.0E+30) THEN
              PRINT *,' ***  ERROR  *** Plot scalar too large.'
              STOP
          ENDIF
          x = scalr * rnibs
          DO 110 i = 1,nsamps
             trace(i) = trace(i) * x
  110     CONTINUE
      ELSE
          CALL APWAIT
          IF( scalr .LE. 0. ) THEN                                      ! pick a multiplier
              CALL MAXMGV( in, 1, nextad, nsamps )                      ! find the max magnitude value
              next = nextad + 2
              next1 = next + 1
              def2 = def * 2.
              CALL APPUT( def2, next, 1, 2 )
              CALL APWAIT
              CALL VDIV( nextad, 1, next, 1, nextad, 1, 1 )             ! def/max
              CALL APPUT( rnibs, next1, 1, 2 )                          ! put rnibs in the ap
              IF( scalar .LT. 0. ) THEN                                 ! do we print and save
                  CALL APWR
                  CALL APGET( scalar, nextad, 1, 2 )
                  CALL APWD
                  PRINT *,' the computed plot SCALAR is ',scalar
              ENDIF
              CALL APWD
              CALL VSMUL( nextad, 1, next1, nextad, 1, 1 )
          ELSE
              x = scalr * rnibs
              CALL APPUT( x, nextad, 1, 2 )
          ENDIF
          CALL VSMUL( in, 1, nextad, in, 1, nsamps )
          iout = 0                                                      ! signal that the data is out of the ap
          CALL APWR
          CALL APGET( trace, in, nsamps, 2 )                            ! ge the data out of the ap
          CALL APWD
      ENDIF
      RETURN
      END


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! maxloc in initialization with repeated elements.

program p
integer :: rslt = 1
integer, parameter, dimension(1) :: mx = maxloc((/6, 3, 6, 2/))
call check(mx, rslt, 1)
end


C     LAST UPDATE 20/03/98
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE BGWSRT(B,BB,IWID,JWID,ISEP,JSEP,SMOO,TENS,PC1,PC2)
      IMPLICIT NONE
C
C Purpose: Fits the background by the following method.
C          A window is then moved across the original image, the
C          pixel values in the window are sorted and those between
C          PC1 and PC2 are taken as background. A smoothing spline
C          is fitted to fill in the gaps between window centres.
C
C Calls   2: SORT , CURVS
C Called by: LSQINT
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      INTEGER MAXDIM,MAXDAT,MAXWIN
      PARAMETER(MAXDIM=512,MAXDAT=MAXDIM**2,MAXWIN=41*41)
C
C Scalar arguments:
C
      REAL SMOO,TENS,PC1,PC2
      INTEGER IWID,JWID,ISEP,JSEP
C
C Array arguments:
C
      REAL B(MAXDAT),BB(MAXDAT)
C
C Common Arrays:
C
      REAL AD(MAXDAT),PSIG(MAXDAT)
C
C Common scalars:
C
      REAL DELR,RMIN,DELZ,ZMIN
      INTEGER IFPIX,ILPIX,IFRAST,ILRAST,NPIX,NRAST,IBACK
      LOGICAL SIGMA,POLAR
C
C Local arrays:
C
      REAL XB(MAXDIM),YB(MAXDIM),YS(MAXDIM),YSP(MAXDIM),WRK(9*MAXDIM)
      REAL BW(MAXWIN)
      INTEGER INDEX(MAXWIN)
      LOGICAL KNOT(MAXDIM)
C
C Local Scalars:
C
      INTEGER I,J,IP,IBAD,IBCK,M,MM,ISTRT,IEND,NIWIND
      INTEGER NB,JW1,JW2,IW1,IW2,IW,IER,IN,JN
      REAL RS,ZS,BCK,S,EPS
      LOGICAL LINE
C
C Common blocks:
C
      COMMON /INSPEC/ DELR,RMIN,DELZ,ZMIN,POLAR
      COMMON /IMDATA/ NPIX,NRAST,IBACK,AD,PSIG,SIGMA
      COMMON /IMAGE / IFPIX,ILPIX,IFRAST,ILRAST
C
C External function:
C
      REAL CURV2
      EXTERNAL CURV2
C
C-----------------------------------------------------------------------
C
      WRITE(6,1000)
      WRITE(4,1000)
      IBAD = 0
C
C========Check window size for array bounds
C
      NB = (2*IWID+1)*(2*JWID+1)
      IF(NB.GT.MAXWIN)THEN
         WRITE(6,1010)
         WRITE(4,1010)
         STOP
      ENDIF
C
C========Initialize B to flag unknown background values
C
      DO 20 J=1,NRAST
         DO 10 I=1,NPIX
            M = (J-1)*NPIX + I
            B(M) = -1.0E+30
 10      CONTINUE
 20   CONTINUE
C
C========Set default window separation if necessary
C
      IF(JSEP.LE.0)JSEP = JWID
      IF(ISEP.LE.0)ISEP = IWID
C
C========Loop over rasters and determine window limits
C
      DO 120 J=IFRAST,ILRAST
         JW1 = J - JWID
         IF(JW1.LT.1)JW1 = 1
         JW2 = J + JWID
         IF(JW2.GT.NRAST)JW2 = NRAST
         ZS = FLOAT(J)*DELZ + ZMIN
C
C========Find first and last relevant pixels in this raster
C
         ISTRT = 0
         IEND = 0
         DO 30 I=IFPIX,ILPIX
            KNOT(I) = .FALSE.
            M = (J-1)*NPIX + I
            MM = J*NPIX - I + 1
            IF(AD(M).GT.-0.99E+30)THEN
               IF(ISTRT.EQ.0)ISTRT = I
            ENDIF
            IF(AD(MM).GT.-0.99E+30)THEN
               IF(IEND.EQ.0)IEND = NPIX - I + 1
            ENDIF
 30      CONTINUE
C
C========Determine whether this is a raster for interpolation, if so,
C========flag the appropriate pixels, if not, flag only those pixels
C========likely to be on the perimeter of the image or masked areas
C
         LINE = .FALSE.
         IF(MOD(J-IFRAST,JSEP).EQ.0.OR.J.EQ.ILRAST)THEN
            NIWIND = (IEND-ISTRT-1)/ISEP + 2
            DO 40 IN=1,NIWIND
               I = ISTRT + (IN-1)*ISEP
               IF(I.GT.IEND)I = IEND
               KNOT(I) = .TRUE.
 40         CONTINUE
            LINE = .TRUE.
         ELSE
            DO 50 I=ISTRT,IEND
               M = (J-1)*NPIX + I
               IF(AD(M-NPIX).LT.-0.99E+30.OR.
     &            AD(M+NPIX).LT.-0.99E+30)KNOT(I) = .TRUE.
 50         CONTINUE
         ENDIF
C
C=========Loop over pixels in this raster
C
         IBCK = 0
         DO 100 I=IFPIX,ILPIX
            IF(KNOT(I))THEN
               M = (J-1)*NPIX + I
               IF(AD(M).GT.-0.99E+30)THEN
                  IW1 = I - IWID
                  IF(IW1.LT.1)IW1 = 1
                  IW2 = I + IWID
                  IF(IW2.GT.NPIX)IW2 = NPIX
C
C========SPECIFIC WINDOW BACKGROUND METHOD
C
C========Collect pixel values in this window
C
                  NB = 0
                  DO 80 JN=JW1,JW2
                     DO 70 IN=IW1,IW2
                        MM = (JN-1)*NPIX + IN
                        IF(AD(MM).GT.-0.99E+30)THEN
                           NB = NB + 1
                           BW(NB) = AD(MM)
                        ENDIF
 70                  CONTINUE
 80               CONTINUE
C
C========Sort pixel values and sum over desired interval
C
                  IF(NB.GT.0)THEN
                     CALL SORT(BW,NB,INDEX)
                     IP = 0
                     BCK = 0.0
                     IW1 = MIN(INT(PC1*FLOAT(NB))+1,NB)
                     IW2 = MIN(INT(PC2*FLOAT(NB))+1,NB)
                     DO 90 IW=IW1,IW2
                        IP = IP + 1
                        BCK = BCK + BW(INDEX(IW))
 90                  CONTINUE
C
C========Form average
C
                     IBCK = IBCK + 1
                     YB(IBCK) = BCK/FLOAT(IP)
                     B(M) = YB(IBCK)
                     XB(IBCK) = FLOAT(I)*DELR + RMIN
                  ELSE
                     IBAD = IBAD + 1
                  ENDIF
C
C========END OF SPECIFIC WINDOW BACKGROUND METHOD
C
               ENDIF
            ENDIF
 100     CONTINUE
C
C========Fit splines to fill in gaps in this raster
C
         IF(LINE.AND.IBCK.GT.1)THEN
            EPS = SQRT(2.0/FLOAT(IBCK))
            S = SMOO*FLOAT(IBCK)
            CALL CURVS(IBCK,XB,YB,1.0,1,S,EPS,YS,YSP,TENS,WRK,IER)
            IF(IER.NE.0)THEN
               WRITE(6,2000)IER
               WRITE(4,2000)IER
               STOP 'Fatal error'
            ENDIF
C
C========Interpolate
C
            DO 110 I=ISTRT+1,IEND-1
               M = (J-1)*NPIX + I
               IF(AD(M).GT.-0.99E+30)THEN
                  RS = DELR*FLOAT(I) + RMIN
                  B(M) = CURV2(RS,IBCK,XB,YS,YSP,TENS)
               ENDIF
 110        CONTINUE
         ENDIF
 120  CONTINUE
C
C========Transpose the spline fitting
C
      DO 160 I=IFPIX,ILPIX
C
C========Set up arrays for interpolation
C
         IBCK = 0
         DO 140 J=IFRAST,ILRAST
            M = (J-1)*NPIX + I
            IF(B(M).GT.-0.99E+30)THEN
               IBCK = IBCK + 1
               XB(IBCK) = FLOAT(J)*DELZ + ZMIN
               YB(IBCK) = B(M)
            ENDIF
 140     CONTINUE
         IF(IBCK.GT.1)THEN
            EPS = SQRT(2.0/FLOAT(IBCK))
            S = SMOO*FLOAT(IBCK)
            CALL CURVS(IBCK,XB,YB,1.0,1,S,EPS,YS,YSP,TENS,WRK,IER)
            IF(IER.NE.0)THEN
               WRITE(6,2000)IER
               WRITE(4,2000)IER
               STOP 'Fatal error'
            ENDIF
C
C========Interpolate
C
            DO 150 J=IFRAST,ILRAST
               M = (J-1)*NPIX + I
               IF(AD(M).GT.-0.99E+30)THEN
                  ZS = DELZ*FLOAT(J) + ZMIN
                  B(M) = CURV2(ZS,IBCK,XB,YS,YSP,TENS)
               ENDIF
 150        CONTINUE
         ENDIF
 160  CONTINUE
C
C========Warn about omitted knot points
C
      WRITE(6,1020)IBAD
      WRITE(4,1020)IBAD
C
C========Subtract background from AD and accumulate background in BB
C
      DO 180 J=1,NRAST
         DO 170 I=1,NPIX
            M = (J-1)*NPIX + I
            IF(AD(M).GT.-0.99E+30)THEN
               AD(M) = AD(M) - B(M)
               BB(M) = BB(M) + B(M)
            ENDIF
 170     CONTINUE
 180  CONTINUE
      RETURN
C
 1000 FORMAT(/1X,'BGWSRT: Window background fitting...')
 1010 FORMAT(1X,'BGWSRT: Error - window size too large for array')
 1020 FORMAT(1X,'Number of bad background points:     ',I10)
 2000 FORMAT(1X,'***Error in spline fitting: FITPACK error ',I3)
      END


!
! SPDX-License-Identifier: MIT
!
module mod_cmpt_divth
  !
  ! note: these subroutines will be used for future extension to low Mach flows
  !
  use mod_param, only: gam_g
  use mod_types
  use mod_common_mpi
#if defined(_OPENACC)
  use cudafor
#endif
  !
  implicit none
  !
  public  :: cmpt_divth,cmpt_density,cmpt_e_div
  private
  !
  contains
  !
  subroutine cmpt_divth(nx,ny,nz,dxi,dyi,dzi,nh_t,p0,dp0dt,vof,kappa,s,div_th)
    !
    implicit none
    !
    integer , intent(in )                                     :: nx,ny,nz
    real(rp), intent(in )                                     :: dxi,dyi,dzi
    integer , intent(in )                                     :: nh_t
    real(rp), intent(in )                                     :: p0,dp0dt
    real(rp), intent(in ), dimension(     0:,     0:,     0:) :: vof,kappa
    real(rp), intent(in ), dimension(1-nh_t:,1-nh_t:,1-nh_t:) :: s
    real(rp), intent(out), dimension(     0:,     0:,     0:) :: div_th
    !
    real(rp) :: dsdx,dsdy,dsdz,diff, &
                dsdxp,dsdxm,dsdyp,dsdym,dsdzp,dsdzm
    real(rp) :: kappaxp,kappaxm,kappayp,kappaym, &
                kappazp,kappazm
    integer  :: i,j,k,im,jm,km,ip,jp,kp
    !
#if defined(_OPENACC)
    attributes(managed) :: vof,kappa,div_th,s
    integer             :: istat
#endif
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(im,ip,jm,jp,km,kp) &
    !$OMP PRIVATE(dsdxm,dsdxp,dsdym,dsdyp,dsdzm,dsdzp) &
    !$OMP PRIVATE(kappaxm,kappaxp,kappaym,kappayp,kappazm,kappazp) &
    !$OMP PRIVATE(diff) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzi,gam_g,dp0dt,p0,vof,kappa,s)
#endif
    !
    do k=1,nz
      do j=1,ny
        do i=1,nx
#if defined(_OPENACC) && defined(_ACC_OPT)
          !$acc cache(s(i-1:i+1,j-1:j+1,k-1:k+1))
          !$acc cache(kappa(i-1:i+1,j-1:j+1,k-1:k+1))
#endif
          ip = i+1
          im = i-1
          jp = j+1
          jm = j-1
          kp = k+1
          km = k-1
          !
          dsdxm = (s(i ,j,k)-s(im,j,k))*dxi
          dsdxp = (s(ip,j,k)-s(i ,j,k))*dxi
          dsdym = (s(i,j ,k)-s(i,jm,k))*dyi
          dsdyp = (s(i,jp,k)-s(i,j ,k))*dyi
          dsdzm = (s(i,j,k )-s(i,j,km))*dzi
          dsdzp = (s(i,j,kp)-s(i,j ,k))*dzi
          !
          kappaxm = 0.5_rp*(kappa(i,j,k)+kappa(im,j,k))
          kappaxp = 0.5_rp*(kappa(i,j,k)+kappa(ip,j,k))
          kappaym = 0.5_rp*(kappa(i,j,k)+kappa(i,jm,k))
          kappayp = 0.5_rp*(kappa(i,j,k)+kappa(i,jp,k))
          kappazm = 0.5_rp*(kappa(i,j,k)+kappa(i,j,km))
          kappazp = 0.5_rp*(kappa(i,j,k)+kappa(i,j,kp))
          !
          diff = (dsdxp*kappaxp-dsdxm*kappaxm)*dxi + &
                 (dsdyp*kappayp-dsdym*kappaym)*dyi + &
                 (dsdzp*kappazp-dsdzm*kappazm)*dzi
          !
          div_th(i,j,k) = (((gam_g-1._rp)/gam_g*diff - &
                                   (dp0dt)/gam_g)/p0)*vof(i,j,k)
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    !
    return
  end subroutine cmpt_divth
  !
  subroutine cmpt_density(nx,ny,nz,dx,dy,dz,nh_t,p0,ri,rho2,psi,tmp,gas_mass,flag,rho0,rho)
    !
    implicit none
    !
    integer , intent(in )                                     :: nx,ny,nz
    real(rp), intent(in )                                     :: dx,dy,dz
    integer , intent(in )                                     :: nh_t
    real(rp), intent(in )                                     :: p0,ri,rho2
    real(rp), intent(in ), dimension(     0:,     0:,     0:) :: psi
    real(rp), intent(in ), dimension(1-nh_t:,1-nh_t:,1-nh_t:) :: tmp
    real(rp), intent(out)                                     :: gas_mass
    logical , intent(in)                                      :: flag
    real(rp), intent(out)                                     :: rho0
    real(rp), intent(out), dimension(     0:,     0:,     0:) :: rho
    !
    integer :: i,j,k
    real(rp):: rho_gas,rho_liq
#if defined(_OPENACC)
    attributes(managed) :: psi,tmp,rho
    integer             :: istat
#endif
    !
    if(flag) gas_mass = 0._rp
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(rho_gas,rho_liq) &
    !$OMP SHARED(flag,nx,ny,nz,dx,dy,dz,p0,ri,tmp,rho2,psi,rho)
#endif
    do k=1,nz
      do j=1,ny
        do i=1,nx
          !
          rho_gas    = p0/(ri*tmp(i,j,k))
          rho_liq    = rho2
          rho(i,j,k) = psi(i,j,k)*rho_gas+(1._rp-psi(i,j,k))*rho_liq
          if(flag) gas_mass   = gas_mass + psi(i,j,k)*rho_gas*dx*dy*dz
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    !
    rho0 = minval(rho(1:nx,1:ny,1:nz))
    call mpi_allreduce(MPI_IN_PLACE,rho0,1,MPI_REAL_RP,MPI_MIN,MPI_COMM_WORLD,ierr)
    if(flag) call mpi_allreduce(MPI_IN_PLACE,gas_mass,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    !
    return
  end subroutine cmpt_density
  !
  subroutine cmpt_e_div(nx,ny,nz,dx,dy,dz,lx,ly,lz,nh_u,div_th,u,v,w,e_div,e_div_mean)
    !
    implicit none
    !
    integer,  intent(in )                                     :: nx,ny,nz
    real(rp), intent(in )                                     :: dx,dy,dz
    real(rp), intent(in )                                     :: lx,ly,lz
    integer , intent(in )                                     :: nh_u
    real(rp), intent(in ), dimension(      0:,    0:,     0:) :: div_th
    real(rp), intent(in ), dimension(1-nh_u:,1-nh_u:,1-nh_u:) :: u,v,w
    real(rp), intent(out)                                     :: e_div,e_div_mean
    !
    integer :: i,j,k
    real(rp):: lxi,lyi,lzi,dxi,dyi,dzi
    real(rp):: div_s,e_div_v
    !
#if defined(_OPENACC)
    attributes(managed) :: div_th
    attributes(managed) :: u,v,w
    integer             :: istat
#endif
    !
    lxi = 1._rp/lx
    lyi = 1._rp/ly
    lzi = 1._rp/lz
    dxi = 1._rp/dx
    dyi = 1._rp/dy
    dzi = 1._rp/dz
    !
    e_div = 0._rp
    e_div_mean = 0._rp
    !
#if defined(_OPENACC)
    !$acc parallel loop reduction(+:e_div_mean)
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(div_s,e_div_v) &
    !$OMP SHARED(nx,ny,nz,lx,ly,lz,dxi,dyi,xzi,div_th,e_div,e_div_mean)&
    !$OMP REDUCTION(+:e_div_mean)
#endif
    do k=1,nz
      do j=1,ny
        do i=1,nx
          !
#if defined(_OPENACC) && defined(_ACC_OPT)
          !$acc cache(u(i-1:i,j:j,k:k))
          !$acc cache(v(i:i,j-1:j,k:k))
          !$acc cache(v(i:i,j:j,k:k-1))
#endif
          div_s = (u(i,j,k)-u(i-1,j,k))*dxi + &
                  (v(i,j,k)-v(i,j-1,k))*dyi + &
                  (w(i,j,k)-w(i,j,k-1))*dzi
          !
          e_div_v    = abs(div_th(i,j,k)-div_s)
          e_div      = max(e_div_v,e_div)
          e_div_mean = e_div_mean + e_div_v*dx*dy*dz/lx/ly/lz
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end parallel loop
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    call mpi_allreduce(MPI_IN_PLACE,e_div     ,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
    call mpi_allreduce(MPI_IN_PLACE,e_div_mean,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    !
    return
  end subroutine cmpt_e_div
  !
end module mod_cmpt_divth


 implicit none

 integer :: a,b
 common/block_1/a,b

 integer c,n

 print*,'Give integers a and b'; read*,a,b
 print*,'How many strange operations should be performed?'; read*,n

 call strangeoperation(n,c)
 print*,'The strange operations have resulted in the value ',c

 end

 subroutine strangeoperation(n,strange)

 implicit none

 integer :: a,b
 common/block_1/a,b

 integer i,n,strange

 strange=0
 do i=1,n
   strange=strange+(strange-a)**2+a*b*strange
   if (abs(strange) > 100000) strange=strange/1000+10*i
 enddo

 end subroutine strangeoperation


! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

module mod_PGA3Dsupport
  !! author: MDG
  !! version: 1.0
  !! date: 07/21/21
  !!
  !! support routines for Projective Geometric Algebra in 3D; this module is based on
  !! https://bivector.net/3DPGA.pdf
  !!
  !! as of 7/23/2021 the following operations are available
  !!
  !! returning a multivector:
  !! function rotor(angle, line) result(rtr)
  !! function translator(dist, line) result(trs)
  !! function plane(a, b, c, d) result(pl)
  !! function point(x, y, z, ideal) result(pt)
  !! function line(a, b, c, ideal) result(l)
  !! function circle(t, radius, line) result(cr)
  !! function torus(s, t, r1, l1, r2, l2) result(to)
  !! function pointoncircle(t, radius, line) result(poc)
  !! function join(mv1, mv2, mv3, mv4) result(j)
  !! function meet(mv1, mv2, mv3, mv4) result(j)
  !! function normalthru(mv1, mv2) result(p)
  !! function normalto(mv1) result(n)
  !! function projectonto(mv1, mv2) result(p)
  !!
  !! returnig a scalar result:
  !! function distpoints(mv1, mv2) result(d)
  !! function distplanes(mv1, mv2) result(d)
  !! function distplaneline(mv1, mv2) result(d)
  !! function ordisttoplane(mv1, mv2) result(d)
  !! function ordisttoline(mv1, mv2) result(d)
  !! function angleplanes(mv1, mv2) result(d)
  !! function angleplaneline(mv1, mv2) result(d)
  !!
  !! miscellaneous:
  !! subroutine getplane(pl, a, b, c, d)
  !! subroutine getpoint(pt, x, y, z)

use mod_kinds
use mod_global
use mod_PGA3D

IMPLICIT NONE

! define the basis components of the algebra
type(PGA3D_T)             :: ONE, E0, E1, E2, E3, E01, E02, E03, E12, E23, E31, E123, E032, E021, E013, E0123, &
                             E023, E012, E031

contains

!--------------------------------------------------------------------------
subroutine PGA3D_initialize(verbose)
!DEC$ ATTRIBUTES DLLEXPORT :: PGA3D_initialize
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! define the basis elements of the projective geometric algebra in 3D

IMPLICIT NONE

logical, INTENT(IN), OPTIONAL     :: verbose

ONE = PGA3D_T(val=1.D0, ind=0)

E0 = PGA3D_T(val=1.D0, ind=1)           ! ideal plane
E1 = PGA3D_T(val=1.D0, ind=2)           ! x=0 plane
E2 = PGA3D_T(val=1.D0, ind=3)           ! y=0 plane
E3 = PGA3D_T(val=1.D0, ind=4)           ! z=0 plane

E01 = E0 .wedge. E1
E02 = E0 .wedge. E2
E03 = E0 .wedge. E3
E12 = E1 .wedge. E2
E31 = E3 .wedge. E1
E23 = E2 .wedge. E3

E123 = E1 .wedge. E2 .wedge. E3
E032 = E0 .wedge. E3 .wedge. E2
E013 = E0 .wedge. E1 .wedge. E3
E021 = E0 .wedge. E2 .wedge. E1
E023 = E032 .muls. (-1.D0)
E031 = E013 .muls. (-1.D0)
E012 = E021 .muls. (-1.D0)

E0123 = E0 .wedge. E1 .wedge. E2 .wedge. E3

if (present(verbose)) then
  if (verbose.eqv..TRUE.) then
    call ONE%log( pre = 'ONE')
    call E0%log( pre = 'E0')
    call E1%log( pre = 'E1')
    call E2%log( pre = 'E2')
    call E3%log( pre = 'E3')
    call E01%log( pre = 'E01')
    call E02%log( pre = 'E02')
    call E03%log( pre = 'E03')
    call E12%log( pre = 'E12')
    call E23%log( pre = 'E23')
    call E31%log( pre = 'E31')
    call E123%log( pre = 'E123')
    call E032%log( pre = 'E032')
    call E013%log( pre = 'E013')
    call E021%log( pre = 'E021')
    call E0123%log( pre = 'E0123')
  end if
end if

end subroutine PGA3D_initialize

!--------------------------------------------------------------------------
recursive function rotor(angle, line) result(rtr)
!DEC$ ATTRIBUTES DLLEXPORT :: rotor
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! create a rotor multivector

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: angle
type(PGA3D_T), INTENT(IN)           :: line
type(PGA3D_T)                       :: rtr

type(PGA3D_T)                       :: b

b = line%normalized()
b = b.muls.sin(angle*0.5D0)
rtr = b.adds.cos(angle*0.5D0)

end function rotor

!--------------------------------------------------------------------------
recursive function translator(dist, line) result(trs)
!DEC$ ATTRIBUTES DLLEXPORT :: translator
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! create a translator multivector

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: dist
type(PGA3D_T), INTENT(IN)           :: line
type(PGA3D_T)                       :: trs

type(PGA3D_T)                       :: b

b = line
b = b.muls.(dist*0.5D0)
trs = b.adds.(1.D0)

end function translator

!--------------------------------------------------------------------------
recursive function plane(a, b, c, d) result(pl)
!DEC$ ATTRIBUTES DLLEXPORT :: plane
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! create a plane

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: a, b, c, d
type(PGA3D_T)                       :: pl

pl = (E1.muls.a) + (E2.muls.b) + (E3.muls.c) + (E0.muls.d)

end function plane

!--------------------------------------------------------------------------
recursive subroutine getplane(pl, a, b, c, d)
!DEC$ ATTRIBUTES DLLEXPORT :: getplane
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! get the components of a plane

IMPLICIT NONE

type(PGA3D_T), INTENT(INOUT)         :: pl
real(kind=dbl), INTENT(OUT)          :: a, b, c, d

a = pl%getcomp(2)
b = pl%getcomp(3)
c = pl%getcomp(4)
d = pl%getcomp(1)

end subroutine getplane

!--------------------------------------------------------------------------
recursive function point(x, y, z, ideal) result(pt)
!DEC$ ATTRIBUTES DLLEXPORT :: point
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! create a regular or an ideal point

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: x, y, z
logical, INTENT(IN), OPTIONAL       :: ideal
type(PGA3D_T)                       :: pt

pt = (E032.muls.x) + (E013.muls.y) + (E021.muls.z)
if (.not.present(ideal)) pt = pt + E123

end function point

!--------------------------------------------------------------------------
recursive subroutine getpoint(pt, x, y, z)
!DEC$ ATTRIBUTES DLLEXPORT :: getpoint
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! get the coordinates of a point

IMPLICIT NONE

type(PGA3D_T), INTENT(INOUT)         :: pt
real(kind=dbl), INTENT(OUT)          :: x, y, z

x = pt%getcomp(13)
y = pt%getcomp(12)
z = pt%getcomp(11)

end subroutine getpoint

!--------------------------------------------------------------------------
recursive function line(a, b, c, ideal) result(l)
!DEC$ ATTRIBUTES DLLEXPORT :: line
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! create a regular or an ideal line

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: a, b, c
logical, INTENT(IN), OPTIONAL       :: ideal
type(PGA3D_T)                       :: l

if (present(ideal)) then
  l = (E01.muls.a) + (E02.muls.b) + (E03.muls.c)
else
  l = (E12.muls.c) + (E31.muls.b) + (E23.muls.a)
end if

end function line

!--------------------------------------------------------------------------
recursive function circle(t, radius, line) result(cr)
!DEC$ ATTRIBUTES DLLEXPORT :: circle
!! author: MDG
!! version: 1.0
!! date: 07/22/21
!!
!! create a circle

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: t
real(kind=dbl), INTENT(IN)          :: radius
type(PGA3D_T), INTENT(IN)           :: line
type(PGA3D_T)                       :: cr

cr = rotor(t * cPi * 2.D0, line) * translator( radius, E1*E0 )

end function circle

!--------------------------------------------------------------------------
recursive function torus(s, t, r1, l1, r2, l2) result(to)
!DEC$ ATTRIBUTES DLLEXPORT :: torus
!! author: MDG
!! version: 1.0
!! date: 07/22/21
!!
!! create a circle

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: s, t, r1, r2
type(PGA3D_T), INTENT(IN)           :: l1, l2
type(PGA3D_T)                       :: to

to = circle(s, r2, l2) * circle(t, r1, l1)

end function torus

!--------------------------------------------------------------------------
recursive function pointoncircle(t, radius, line) result(poc)
!DEC$ ATTRIBUTES DLLEXPORT :: pointoncircle
!! author: MDG
!! version: 1.0
!! date: 07/22/21
!!
!! temporary routine

IMPLICIT NONE

real(kind=dbl), INTENT(IN)          :: t
real(kind=dbl), INTENT(IN)          :: radius
type(PGA3D_T), INTENT(IN)           :: line
type(PGA3D_T)                       :: poc

type(PGA3D_T)                       :: cr

cr = circle(t, radius, line)
poc = cr .sandwich. E123

end function pointoncircle

!--------------------------------------------------------------------------
recursive function join(mv1, mv2, mv3, mv4) result(j)
!DEC$ ATTRIBUTES DLLEXPORT :: join
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! join two, three, or four multivectors

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
type(PGA3D_T), INTENT(IN),OPTIONAL  :: mv3, mv4
type(PGA3D_T)                       :: j

j = mv1.vee.mv2

if (present(mv3)) j = j.vee.mv3
if (present(mv4)) j = j.vee.mv4

end function join

!--------------------------------------------------------------------------
recursive function meet(mv1, mv2, mv3, mv4) result(j)
!DEC$ ATTRIBUTES DLLEXPORT :: meet
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! meet two, three, or four multivectors

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
type(PGA3D_T), INTENT(IN),OPTIONAL  :: mv3, mv4
type(PGA3D_T)                       :: j

j = mv1.wedge.mv2

if (present(mv3)) j = j.wedge.mv3
if (present(mv4)) j = j.wedge.mv4

end function meet

!--------------------------------------------------------------------------
recursive function normalthru(mv1, mv2) result(p)
!DEC$ ATTRIBUTES DLLEXPORT :: normalthru
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! find multivector normal to mv1 through mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
type(PGA3D_T)                       :: p

p = mv1.inner.mv2

end function normalthru

!--------------------------------------------------------------------------
recursive function normalto(mv1) result(n)
!DEC$ ATTRIBUTES DLLEXPORT :: normalto
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! find multivector normal to mv1

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1
type(PGA3D_T)                       :: n

n = mv1 * E0123

end function normalto

!--------------------------------------------------------------------------
recursive function projectonto(mv1, mv2) result(p)
!DEC$ ATTRIBUTES DLLEXPORT :: projectonto
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! project mv1 onto mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
type(PGA3D_T)                       :: p

p = (mv2.inner.mv1) * mv2

end function projectonto

!--------------------------------------------------------------------------
recursive function distpoints(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: distpoints
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! distance bwtween to points mv1 and mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p

p = (mv1%normalized()).vee.(mv2%normalized())
d = p%norm()

end function distpoints

!--------------------------------------------------------------------------
recursive function distplanes(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: distplanes
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! distance between parallel planes mv1 and mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p

p = (mv1%normalized()).wedge.(mv2%normalized())
d = p%inorm()

end function distplanes

!--------------------------------------------------------------------------
recursive function distplaneline(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: distplaneline
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! distance between parallel plane mv1 and line mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p
real(kind=dbl), allocatable         :: v(:)
integer(kind=irg)                   :: i

p = mv1%normalized() * mv2%normalized()
v = p%getgrade(3)

d = norm2(v(1:3))

end function distplaneline

!--------------------------------------------------------------------------
recursive function ordisttoplane(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: ordisttoplane
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! oriented distance between point mv1 and plane mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p

p = (mv1%normalized()) .wedge. (mv2%normalized())

d = p%getcomp(15)

end function ordisttoplane

!--------------------------------------------------------------------------
recursive function ordisttoline(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: ordisttoline
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! oriented distance between point mv1 and line mv2

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p

p = (mv1%normalized()) .vee. (mv2%normalized())

d = p%norm()

end function ordisttoline

!--------------------------------------------------------------------------
recursive function angleplanes(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: angleplanes
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! angle between intersecting planes

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p

p = (mv1%normalized()).inner.(mv2%normalized())
d = acos(p%getcomp(0))

end function angleplanes

!--------------------------------------------------------------------------
recursive function angleplaneline(mv1, mv2) result(d)
!DEC$ ATTRIBUTES DLLEXPORT :: angleplaneline
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! angle between plane and non-parallel line

IMPLICIT NONE

type(PGA3D_T), INTENT(IN)           :: mv1, mv2
real(kind=dbl)                      :: d

type(PGA3D_T)                       :: p
real(kind=dbl), allocatable         :: v(:)

p = mv1%normalized() * mv2%normalized()
v = p%getgrade(3)

d = asin( norm2(v(2:4)) )

end function angleplaneline

end module mod_PGA3Dsupport


      subroutine tran

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes tributary channel transmission losses

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_k(1,j)   |mm/hr         |effective hydraulic conductivity of tributary
!!                               |channel alluvium
!!    ch_w(1,j)   |(m)           |average main channel width
!!    ch_l1(j)    |(km)          |main channel length
!!    hru_km(:)   |km**2         |area of HRU in square kilometers
!!    ihru        |none          |HRU number
!!    peakr       |m^3/s         |peak runoff rate
!!    qday        |mm H2O        |surface runoff loading to main channel
!!                               |from HRU on current day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    peakr       |m^3/s         |peak runoff rate
!!    qday        |mm H2O        |amount of surface runoff loading to main
!!                               |channel from HRU on current day
!!    shallst(:)  |mm H2O        |depth of water in shallow aquifer in HRU
!!    tloss       |mm H2O        |amount of water removed from surface runoff
!!                               |via transmission losses on day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    a           |m^3           |regression intercept for unit channel
!!    axw         |m^3           |regression intercept for unit channel with
!!                               |a flow of duration DUR
!!    b           |none          |regression slope for unit channel
!!    bxw         |none          |regression slope for a channel of length L
!!                               |and width W
!!    dur         |hr            |length of time runoff occurs if traveling
!!                               |at peak runoff rate
!!    j           |none          |HRU number
!!    k           |1/(m-km)      |decay factor for unit channel with a flow
!!                               |duration DUR and volume VOL
!!    pr1         |m^3/s         |peak runoff rate prior to accounting for
!!                               |transmission losses
!!    pxw         |m^3           |threshold volume for a channel reach of
!!                               |length L and width W
!!    qinit       |mm H2O        |amount of water in surface runoff loading
!!                               |prior to accounting for transmission losses
!!    vo          |m**3 H2O      |volume of water in surface runoff loading
!!                               |to main channel on day
!!    xx          |none          |variable to hold intermediate calculation
!!    zz          |none          |variable to hold intermediate calculation

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Log, Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: qinit, vo, dur, k, b, zz, bxw, pr1, a, xx, axw, pxw

      !! initialize variables
      j = 0
      j = ihru

      if (ch_k(1,hru_sub(j)) <= 0.) return

!! save runoff amount prior to transmission losses
      qinit = 0.
      pr1 = 0.
      qinit = qday
      pr1 = peakr

!! calculate incoming volume of water
      vo = 0.
      vo = qday * hru_km(j) * 1000.   !!volume incoming: m^3

!! calculate flow duration
      dur = 0.
      dur = vo / (peakr * 3600.)      !!duration: hr
      if (dur > 24.) dur = 24.

!! flagged by pdw, should be after xx condition
!!!! zero surface runoff/peak rate
!!      qday = 0.
!!      peakr = 0.

      xx = 0.
      xx = 2.6466 * ch_k(1,hru_sub(j)) * dur / vo
      if (xx < 1.) then

        !moved by pdw
        !! zero surface runoff/peak rate
        qday = 0.
        peakr = 0.
        ! end move pdw

        k = 0.
        k = -2.22 * Log(1. - xx)
        b = 0.
        b = Exp(-0.4905 * k)

        ! bug fix by pdw
        ! old code: if ((1. - b) > 1.e-20) then
				! new code:
        if ((1. - b) .GE. 0.) then
        ! end fix pdw

          zz = 0.
          zz = - k * ch_w(1,hru_sub(j)) * ch_l1(j)
          if (zz >= -30.) then
            bxw = 0.
            bxw = Exp(zz)
            a = 0.
            a = -.2258 * ch_k(1,hru_sub(j)) * dur
            if (1. - b > 0.01) then
              axw = (a / (1. - b)) * (1. - bxw)
            else
              axw = 0.
            end if
            pxw = -axw / bxw
            if (vo > pxw) then
                qday = axw + bxw * vo              !!surface runoff: m^3
                qday = qday / (1000. * hru_km(j))  !!surface runoff: mm
                if (qday < 0.) qday = 0.
                if (qday > 0.) then
                  peakr = (1. / (dur * 3600.)) * (axw - (1. - bxw) * vo)   &
     &                  + bxw * pr1              !!peak rate: m^3/s
                  if (peakr < 0.) peakr = 0.
                end if
             end if
          end if
        end if
      end if

      tloss = qinit - qday
      if (tloss < 0.) then
        qday = qinit
        tloss = 0.
      end if

      !! add transmission losses to shallow aquifer storage
      !! This will be done in gwmod.
!      shallst(j) = shallst(j) + tloss

      return
      end


MODULE Phyllochron_mod
    IMPLICIT NONE
CONTAINS
    SUBROUTINE phyllochron_(fixPhyll, &
        leafNumber, &
        lincr, &
        ldecr, &
        pdecr, &
        pincr, &
        ptq, &
        gai, &
        pastMaxAI, &
        kl, &
        aPTQ, &
        phylPTQ1, &
        p, &
        choosePhyllUse, &
        phyllochron)
        REAL, INTENT(OUT) :: phyllochron
        REAL:: gai_
        REAL, INTENT(IN) :: fixPhyll
        REAL, INTENT(IN) :: leafNumber
        REAL, INTENT(IN) :: lincr
        REAL, INTENT(IN) :: ldecr
        REAL, INTENT(IN) :: pdecr
        REAL, INTENT(IN) :: pincr
        REAL, INTENT(IN) :: ptq
        REAL, INTENT(IN) :: gai
        REAL, INTENT(INOUT) :: pastMaxAI
        REAL, INTENT(IN) :: kl
        REAL, INTENT(IN) :: aPTQ
        REAL, INTENT(IN) :: phylPTQ1
        REAL, INTENT(IN) :: p
        CHARACTER(65), INTENT(IN) :: choosePhyllUse
        !- Description:
    !            - Model Name: Phyllochron Model
    !            - Author: Pierre Martre
    !            - Reference: Modeling development phase in the
    !                Wheat Simulation Model SiriusQuality.
    !                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    !            - Institution: INRA Montpellier
    !            - Abstract: Calculate different types of phyllochron
        !- inputs:
    !            - name: fixPhyll
    !                          - description : Sowing date corrected Phyllochron
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - default : 5
    !                          - unit : °C d leaf-1
    !                          - uri : some url
    !                          - inputtype : variable
    !            - name: leafNumber
    !                          - description : Actual number of phytomers
    !                          - variablecategory : state
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 25
    !                          - default : 0
    !                          - unit : leaf
    !                          - uri : some url
    !                          - inputtype : variable
    !            - name: lincr
    !                          - description : Leaf number above which the phyllochron is increased by Pincr
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 30
    !                          - default : 8
    !                          - unit : leaf
    !                          - uri : some url
    !                          - inputtype : parameter
    !            - name: ldecr
    !                          - description : Leaf number up to which the phyllochron is decreased by Pdecr
    !                          - parametercategory : species
    !                          - inputtype : parameter
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 30
    !                          - default : 10
    !                          - unit : leaf
    !                          - uri : some url
    !            - name: pdecr
    !                          - description : Factor decreasing the phyllochron for leaf number less than Ldecr
    !                          - parametercategory : species
    !                          - inputtype : parameter
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10
    !                          - default : 0.4
    !                          - unit :
    !                          - uri : some url
    !            - name: pincr
    !                          - description : Factor increasing the phyllochron for leaf number higher than Lincr
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - default : 1.5
    !                          - min : 0
    !                          - max : 10
    !                          - unit :
    !                          - uri : some url
    !                          - inputtype : parameter
    !            - name: ptq
    !                          - description : Photothermal quotient
    !                          - parametercategory : species
    !                          - inputtype : variable
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - default : 0
    !                          - unit : MJ °C-1 d-1 m-2)
    !                          - uri : some url
    !            - name: gai
    !                          - description : Green Area Index
    !                          - variablecategory : species
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - default : 0
    !                          - unit : m2 m-2
    !                          - uri : some url
    !                          - inputtype : variable
    !            - name: pastMaxAI
    !                          - description : Past Maximum GAI
    !                          - variablecategory : state
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - default : 0
    !                          - unit : m2 m-2
    !                          - uri : some url
    !                          - inputtype : variable
    !            - name: kl
    !                          - description : Exctinction Coefficient
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 50
    !                          - default : 0.45
    !                          - unit :
    !                          - uri : some url
    !                          - inputtype : parameter
    !            - name: aPTQ
    !                          - description : Slope to intercept ratio for Phyllochron  parametrization with PhotoThermal Quotient
    !                          - parametercategory : species
    !                          - inputtype : variable
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 1000
    !                          - default : 0.842934
    !                          - unit :
    !                          - uri : some url
    !            - name: phylPTQ1
    !                          - description : Phyllochron at PTQ equal 1
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - default : 20
    !                          - min : 0
    !                          - max : 1000
    !                          - unit : °C d leaf-1
    !                          - uri : some url
    !                          - inputtype : parameter
    !            - name: p
    !                          - description : Phyllochron (Varietal parameter)
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - default : 120
    !                          - min : 0
    !                          - max : 1000
    !                          - unit : °C d leaf-1
    !                          - uri : some url
    !                          - inputtype : parameter
    !            - name: choosePhyllUse
    !                          - description : Switch to choose the type of phyllochron calculation to be used
    !                          - parametercategory : species
    !                          - datatype : STRING
    !                          - default : Default
    !                          - unit :
    !                          - uri : some url
    !                          - inputtype : parameter
        !- outputs:
    !            - name: phyllochron
    !                          - description :  the rate of leaf appearance
    !                          - variablecategory : state
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 1000
    !                          - unit :  °C d leaf-1
    !            - name: pastMaxAI
    !                          - description : Past maximum GAI
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - unit : m2 m-2
        IF(choosePhyllUse .EQ. 'Default')) THEN
            IF(leafNumber .LT. ldecr)) THEN
                phyllochron = fixPhyll * pdecr)
            ELSE IF ( leafNumber .GE. ldecr) .AND. leafNumber .LT. lincr))) THEN
                phyllochron = fixPhyll
            ELSE
                phyllochron = fixPhyll * pincr)
            END IF
        END IF
        IF(choosePhyllUse .EQ. 'PTQ')) THEN
            gai_ = MAX(pastMaxAI, gai)
            pastMaxAI = gai_
            IF(gai_ .GT. 0.0)) THEN
                phyllochron = phylPTQ1 * (gai_ * kl) / ((1 - EXP(-kl * gai_)))))) /  &
                        ((ptq + aPTQ)))
            ELSE
                phyllochron = phylPTQ1
            END IF
        END IF
        IF(choosePhyllUse .EQ. 'Test')) THEN
            IF(leafNumber .LT. ldecr)) THEN
                phyllochron = p * pdecr)
            ELSE IF ( leafNumber .GE. ldecr) .AND. leafNumber .LT. lincr))) THEN
                phyllochron = p
            ELSE
                phyllochron = p * pincr)
            END IF
        END IF
    END SUBROUTINE phyllochron_
END MODULE


PURE LOGICAL FUNCTION LDOROT(F, G, H, TOL, HYP)
  IMPLICIT NONE

  DOUBLE PRECISION, INTENT(IN) :: F, G, H, TOL
  LOGICAL, INTENT(IN) :: HYP

  DOUBLE PRECISION :: GA

  GA = ABS(G)
  LDOROT = (F .NE. (F + GA)) .OR. (H .NE. (H + GA))
END FUNCTION LDOROT

SUBROUTINE JKSTEP(UPPER, I, J, M, N, G, LDG, U, LDU, V, LDV, JVEC, NPLUS, TOL, SWEEP, SWHALF, STEP, HYP, INFO)
  IMPLICIT NONE

  LOGICAL, INTENT(IN) :: UPPER
  INTEGER, INTENT(IN) :: I, J, M, N, LDG, LDU, LDV, JVEC(N), NPLUS, SWEEP, SWHALF
  DOUBLE PRECISION, INTENT(IN) :: TOL
  DOUBLE PRECISION, INTENT(INOUT) :: G(LDG,N), U(LDU,M), V(LDV,N)
  INTEGER, INTENT(INOUT) :: STEP
  LOGICAL, INTENT(OUT) :: HYP
  INTEGER, INTENT(OUT) :: INFO(2)

  DOUBLE PRECISION :: F0, G0, H0, CU, SU, CV, SV, F1, H1, PARAMU(5), PARAMV(5)
  LOGICAL :: RHSIDE

  EXTERNAL :: DROTM

  INFO = 0
  STEP = STEP + 1
  HYP = (JVEC(I) .NE. JVEC(J))

  F0 = G(I,I)
  H0 = G(J,J)

  IF (UPPER) THEN
     G0 = G(I,J)
  ELSE
     G0 = G(J,I)
  END IF

  IF (G0 .EQ. ZERO) RETURN

  IF (LDOROT(F0, G0, H0, TOL, HYP)) THEN
     INFO(2) = 1
     PARAMU(1) = MONE
     PARAMV(1) = MONE

     IF (HYP) THEN
        CALL DKOGH2(UPPER, F0, G0, H0, TOL, RHSIDE, CU, SU, CV, SV, F1, H1, INFO(1))
     ELSE
        CALL DKOGT2(UPPER, F0, G0, H0, TOL, RHSIDE, CU, SU, CV, SV, F1, H1, INFO(1))
     END IF

     PARAMU(2) =  CU
     PARAMU(3) = -SU
     PARAMU(4) =  SU
     PARAMU(5) =  CU

     IF (HYP) THEN
        PARAMV(2) =  CV
        PARAMV(3) = -SV
        PARAMV(4) = -SV
        PARAMV(5) =  CV
     ELSE
        PARAMV(2) =  CV
        PARAMV(3) = -SV
        PARAMV(4) =  SV
        PARAMV(5) =  CV
     END IF

     IF (RHSIDE) THEN
        CALL DROTM(M, G(1,I), 1,   G(1,J), 1,   PARAMV)
        CALL DROTM(N, G(I,1), LDG, G(J,1), LDG, PARAMU)
     ELSE
        CALL DROTM(N, G(I,1), LDG, G(J,1), LDG, PARAMU)
        CALL DROTM(M, G(1,I), 1,   G(1,J), 1,   PARAMV)
     END IF

     CALL DROTM(M, U(I,1), LDU, U(J,1), LDU, PARAMU)
     CALL DROTM(N, V(1,I), 1,   V(1,J), 1,   PARAMV)

     G(I,I) = F1
     G(J,J) = H1
  ELSE
     INFO(2) = -1
  END IF
  G(I,J) = ZERO
  G(J,I) = ZERO
END SUBROUTINE JKSTEP


       PROGRAM  geomz
C#######################################################################
C  NAME OF ROUTINE
C      geomz ( GEOM Z-values )
C
C  PURPOSE
C      THIS IS THE STANDARD MAIN PROGRAM USED FOR TAE/VICAR PROGRAMS.
C      THIS MODULE CALLS SUBROUTINE MAIN44 TO ENTER INTO THE BODY OF THE
C      PROGRAM.
C      Program "geomz" is a VICAR applications program which is used to
C      perform rubber sheet vertical correction of images by a set of
C      points specified as parameters or in a parameter data set.
C  PREPARED FOR USE ON MIPL SYSTEM BY
C      STEVE POHORSKY   STERLING SOFTWARE/INFORMATICS     APRIL 1986
C  FOR
C      MIPL SOFTWARE DEVELOPMENT
C
C  ORIGINAL "geomz" PROGRAM BY
C      H. WILCZYNSKI
C
C  ENVIRONMENT
C      VAX 11       VMS  with TAE/VICAR2 EXECUTIVE       FORTRAN-77
C
C  REVISION HISTORY
C     14 FEB 80   ...ALZ...   REPLACE CALL END BY RETURN
C     24 AUG 78    ...ALZ...   INITIAL RELEASE
C     4-86  SP   CONVERTED FROM IBM VICAR VERSION.
C     4-86  SP   REWROTE ENTIRE COMPUTATIONAL SECTION BECAUSE OF ERRORS AND
C                BECAUSE REQUESTOR WANTED CALL TO DGELG SUBROUTINE REMOVED.
C                THE IBM VERSION ALWAYS USED THE VALUE FROM THE INPUT
C                PARAMETERS AS THE INITIAL VAL FOR A CELL OF THE IMAGE.
C                BILINEAR INTERPOLATION SHOULD BE USED INSTEAD SINCE THE
C                FIRST PIXEL IN THE CELL MIGHT NOT BE AT THE TIEPOINT.
C                THIS IS THE CASE WHEN THE FOUR CORNERS OF THE IMAGE ARE NOT
C                TIEPOINTS.  THE IBM CODE COULD NOT HANDLE THE CASE WHERE
C                THE STARTING LINE AND SAMPLE DID NOT BELONG TO THE UPPER-LEFT
C                CELL, WHICH SHOULD BE THEORETICALLY ALLOWABLE. THE NEW
C                COMPUTATIONAL SECTION DOES NOT REQUIRE THAT THE SPACING
C                OF TIEPOINTS BE UNIFORM.  THE CHECK FOR UNIFORMITY WAS LEFT
C                IN TO LEAVE THE PROGRAM FUNCTIONALLY THE SAME.
C     5-86  SP   CHANGED ROUNDING TO USE NINT(VAL(IAH)) INSTEAD OF VAL(IAH)
C                IN THE FINAL ADD TO WORK(J).
C     5-95  VRU  ... CRI ... MSTP S/W CONVERSION (VICAR PORTING)
C  USER PARAMETERS:
C       IN,       INPUT IMAGE FILE
C       OUT,      OUTPUT IMAGE (Z CORRECTION APPLIED)
C       NAH=N     THE INTEGER N DENOTES THE NUMBER OF AREAS HORIZONTALLY IN THE
C                 TIEPOINT GRID.
C       NAV=M     THE INTEGER M DENOTES THE NUMBER OF AREAS VERTICALLY IN THE
C                 TIEPOINT GRID.
C       TIEPOINT, INPUT GRID
C                 X1,Y1,DZ1,...,XN,YN,DZN
C                 THE NUMBERS XI,YI,DZI SPECIFY THE POINTS OF
C                 A UNIFORM RECTANGULAR GRID. THE NUMBERS MAY BE REAL OR
C                 INTEGER.  THE XI AND YI SPECIFY THE PIXEL LOCATION OF
C                 THE TIEPOINT AND THE DZI SPECIFY THE DN SHIFT.
C      FIXVAL=V   THE INTEGER V INDICATES THAT ALL PIXELS OF VALUE V ARE TO
C                 BE UNCHANGED.
C  PROGRAM LIMITATIONS
C      SEE HLP FILE.
C  SUBROUTINES CALLED
C      MAIN44
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C#######################################################################
C  NAME OF ROUTINE
C     MAIN44 (name for top level subroutine by VICAR convention)
C
C  PURPOSE
C      MAIN44 performs rubber sheet vertical correction of images by a set
C      points specified as parameters or in a parameter data set.
C  CONVERTED FOR USE ON MIPL SYSTEM BY
C      STEVE POHORSKY   STERLING SOFTWARE/INFORMATICS     APRIL 1986
C  FOR
C      MIPL SOFTWARE DEVELOPMENT
C  ENVIRONMENT
C      VAX 11       VMS  with TAE/VICAR EXECUTIVE       FORTRAN-77
C  CALLING SEQUENCE
C      Standard subroutine call and return.
C  CALLED BY
C      "geomz"
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT INTEGER(A-Z)

      PARAMETER (DIM_PAR = 120000)         ! MAX OF 120,000/3 TIEPOINTS

      COMMON /COM/COEFF(200),PAR(DIM_PAR),WORK(60000)
     +,VAL(200),INCL(200),INCS(200),LVAL(200)
      REAL*4 LINES(3001), SAMPS(201)
      REAL VAL,INCL,INCS,LVAL
      REAL EPSX,EPSY, VALA, VALB, F1, F2, F3, F4
      INTEGER*2 WORK
      REAL  COEFF,RPAR(DIM_PAR),DXX,DX,DYY,DY
      CHARACTER*8 FORMAT
      DATA HALF/0/,IMAX/255/

C
C======================START OF EXECUTABLE CODE======================

      CALL IFMESSAGE('GEOMZ version 2-JAN-95')
      CALL XVEACTION('SA',' ')
C..OPEN INPUT FILE

      CALL XVUNIT(IUNIT,'INP',1,ISTAT, ' ')
      IRETURN = 1
      CALL XVSIGNAL(IUNIT, ISTAT, IRETURN)
      CALL XVOPEN(IUNIT,ISTAT, 'OP', 'READ', 'U_FORMAT','HALF', ' ')

      CALL XVSIZE( STLINE, STSAMP, NLINE, NSAMP, NLI, NSI)
      CALL XVGET(IUNIT,ISTAT,'FORMAT',FORMAT, ' ')
      IF(FORMAT.NE.'BYTE')   HALF = 1
      IF (HALF.EQ.1)         IMAX = 32767

C..GET PARAMETERS

      CALL XVP('NAH',NAH,COUNT)
      CALL XVP('NAV',NAV,COUNT)
      IF ( NAH .EQ. 0  .OR.  NAV .EQ. 0)   GOTO 999
      NAH1 = NAH+1
      NAV1 = NAV+1
      IF (NAH1*NAV1 .GT. DIM_PAR/3)
     &   CALL MABEND('ERROR: NAH*NAV TOO BIG.')

      CALL XVPARM('TIEPOINT',RPAR,COUNT,IDEF, DIM_PAR)
      IF (COUNT.NE.NAH1*NAV1*3)
     &   CALL MABEND('NUMBER OF TIEPOINTS DOES NOT MATCH NAH/NAV')
      PTR = 1

      CALL XVPARM( 'FIXVAL', FIXVAL, ICOUNT, IDEF, 1 )
      IF (ICOUNT .EQ. 0)  FIXVAL = 99999

C..OPEN THE OUTPUT FILE.

      CALL XVUNIT(OUNIT,'OUT',1,ISTAT, ' ')
      IRETURN = 1
      CALL XVSIGNAL(OUNIT, ISTAT, IRETURN)
      CALL XVOPEN(OUNIT, ISTAT, 'OP', 'WRITE', 'U_NL',NLINE,
     .        'U_NS',NSAMP, 'U_FORMAT','HALF', ' ' )

      DYY = RPAR(NAH1*3+PTR)-RPAR(PTR)
      DXX = RPAR(PTR+4)-RPAR(PTR+1)
      EPSX = DXX/1000.
      EPSY = DYY/1000.

C..MAKE SURE THE SPACING IS UNIFORM.

      DO 10 I=1,NAV1
      DO 20 J=1,NAH1
      IF(I.EQ.NAV1)GOTO 15
      IF(ABS(RPAR(NAH1*3+PTR)-RPAR(PTR)-DYY).GE.EPSY)GOTO 998
   15 IF(J.EQ.NAH1)GOTO 16
      IF(ABS(RPAR(PTR+4)-RPAR(PTR+1)-DXX).GE.EPSX) GOTO 998
   16 PTR = PTR+3
   20 CONTINUE
   10 CONTINUE

      ELINE = STLINE + NLINE - 1
      ESAMP = STSAMP + NSAMP - 1

C..STORE THE LINE AND SAMPLE NUMBERS FOR THE ROWS AND COLUMNS OF THE TIEPOINT
C..GRID.

      DO IAV = 1, NAV1
         LINES(IAV) = RPAR(1 + 3*NAH1* (IAV-1) )
      END DO

      DO IAH = 1, NAH1
         SAMPS(IAH) = RPAR(2 + 3* (IAH-1) )
      END DO

C..FIND THE GRID CELLS THAT CONTAIN (STLINE,STSAMP) AND (ELINE,ESAMP).
C..USUALLY THIS WILL BE THE FIRST AND THE LAST, AND WE WILL END UP WITH
C..   IAVBEG=IAHBEG=1  AND IAVEND=NAV AND IAHEND=NAH.

      IAVBEG = 2
      DO WHILE( LINES(IAVBEG) .LE. STLINE .AND. IAVBEG .LT. NAV1 )
         IAVBEG = IAVBEG+1
      END DO
      IAVBEG = IAVBEG-1

      IAVEND = NAV
      DO WHILE( LINES(IAVEND) .GE. ELINE .AND. IAVEND .GT. 1)
         IAVEND = IAVEND-1
      END DO

      IAHBEG = 2
      DO WHILE( SAMPS(IAHBEG) .LE. STSAMP .AND. IAHBEG .LT. NAH1 )
         IAHBEG = IAHBEG+1
      END DO
      IAHBEG = IAHBEG-1

      IAHEND = NAH
      DO WHILE( SAMPS(IAHEND) .GE. ESAMP .AND. IAHEND .GT. 1)
         IAHEND = IAHEND-1
      END DO

C..THIS IS NOT QUITE AN OUTER LINE LOOP WITH AN INNER SAMPLE LOOP.
C..WE LOOP OVER THE ROWS OF GRID CELLS. FOR EACH ROW WE COMPUTE THE
C..TRANSFORMATIONS TO BE APPLIED AND THEN TRANSFORM THE LINES OF THE CELLS.
C..THIS PROCESSES THE LINES OF THE IMAGE IN CONSECUTIVE ORDER.

      DO IAV = IAVBEG, IAVEND
         IF (IAV .EQ. IAVBEG)  THEN
            LBEG = STLINE           ! BEGINNING AND ENDING LINES FOR THIS ROW.
         ELSE
            LBEG = LEND+1
         END IF

         IF (IAV .EQ. IAVEND)  THEN
            LEND = ELINE
         ELSE
            LEND = LINES(IAV+1)
         END IF

         DO IAH = IAHBEG, IAHEND
           IF (IAH .EQ. IAHBEG)  THEN
              SBEG = STSAMP        ! BEGINNING AND ENDING SAMPS FOR THIS COLUMN.
           ELSE
              SBEG = SEND+1
           END IF

           IF (IAH .EQ. IAHEND)  THEN
              SEND = ESAMP
           ELSE
              SEND = SAMPS(IAH+1)
           END IF

           DX = SAMPS(IAH+1) - SAMPS(IAH)
           DY = LINES(IAV+1) - LINES(IAV)

           PTR1 = 3 + 3*(IAH-1) + 3*NAH1* (IAV-1)

C..COMPUTE VAL(IAH), THE FIRST DZ VALUE FOR THIS CELL, BY USING BILINEAR
C..INTERPOLATION FROM THE VALUES (F1,F2,F3,F4) FOR THE FOUR TIEPOINTS FOR
C..THE CELL.

           F1 = RPAR( PTR1 )
           F2 = RPAR( PTR1 +3)
           F3 = RPAR( PTR1 +3*NAH1)
           F4 = RPAR( PTR1 +3*NAH1+3)

           VALA = F1 + (F2-F1) * (SBEG-SAMPS(IAH) ) / DX
           VALB = F3 + (F4-F3) * (SBEG-SAMPS(IAH) ) / DX

           VAL(IAH) = VALA + (VALB-VALA)* (LBEG-LINES(IAV))/DY

C..THE DZ VALUES FOR THE REST OF THE CELL WILL BE COMPUTED BY ADJUSTING
C..THE INITIAL VALUE BY A LINE INCREMENT (INCL) AT THE START OF EACH LINE
C..OF THE CELL AND ADJUSTING THE VALUE BY A SAMPLE INCREMENT (INCS) WITHIN
C..EACH LINE OF THE CELL.

           LVAL(IAH) = VAL(IAH)
           INCL(IAH) = (VALB-VALA) / DY
           COEFF(IAH) = ( F4-F2+F1-F3 ) / (DY*DX)
           INCS(IAH) = (F2-F1)/DX  +  COEFF(IAH) * ( LBEG-LINES(IAV) )

         END DO

C..NOW THE LINE LOOP FOR THIS ROW.

         DO LINE = LBEG,LEND

           IF ( LINE .EQ. STLINE )   THEN
             CALL XVREAD( IUNIT, WORK, ISTAT, 'LINE', STLINE, ' ' )
           ELSE
             CALL XVREAD( IUNIT, WORK, ISTAT, ' ' )
           END IF

C..LOOP THROUGH THE CELLS FOR THIS LINE.

           DO IAH = IAHBEG, IAHEND
             IF (IAH .EQ. IAHBEG)  THEN
                SBEG = STSAMP      ! BEGINNING AND ENDING SAMPS FOR THIS COLUMN.
             ELSE
                SBEG = SEND+1
             END IF

             IF (IAH .EQ. IAHEND)  THEN
                SEND = ESAMP
             ELSE
                SEND = SAMPS(IAH+1)
             END IF

C..LOOP THROUGH THE SAMPLES FOR EACH CELL.

             DO J = SBEG, SEND
                IF (WORK(J) .NE. FIXVAL)  THEN
                   DZ = NINT( VAL(IAH) )
                   IMVAL = WORK(J)+DZ
                   IF(IMVAL .LT. 0)IMVAL = 0
                   IF(IMVAL .GT. IMAX)IMVAL = IMAX
                   WORK(J) = IMVAL
                END IF
                VAL(IAH) = VAL(IAH) + INCS(IAH)
             END DO

C..SET UP FOR NEXT LINE OF THIS CELL.

             INCS(IAH) = INCS(IAH) + COEFF(IAH)
             VAL(IAH)  = LVAL(IAH) + INCL(IAH)
             LVAL(IAH) = VAL(IAH)

           END DO

           CALL XVWRIT(OUNIT, WORK(STSAMP), ISTAT, ' ')

        END DO
      END DO

      CALL XVCLOSE( IUNIT, ISTAT, ' ' )
      CALL XVCLOSE( OUNIT, ISTAT, ' ' )
      RETURN

  998 CALL XVMESSAGE('TIEPOINTS NOT EVENLY SPACED', ' ')
      CALL ABEND
  999 CALL XVMESSAGE('PARM ERROR', ' ')
      CALL ABEND
      RETURN
      END


subroutine set_implicit_boundary_data(t, lower_values, upper_values)

    implicit none

    integer :: mx, mbc, meqn
    double precision :: x_lower, dx
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    character(len=2), dimension(2, 10) :: bc_options
    common /bc_config/ bc_options

    double precision, intent(in) :: t
    double precision, dimension(2), intent(out) :: lower_values, upper_values

    double precision, external :: true_solution, gen_derivative
    double precision, dimension(-1:2) :: cell_values
    integer :: i, orders(2)
    double precision :: test

    if (bc_options(1, 1) == 'p') return

    call get_true_solution_by_index_range(-1, 2, t, cell_values)
    read(bc_options(1, 1), '(2I1)') orders
    do i = 1, 2
        lower_values(i) = gen_derivative(orders(i), cell_values, dx)
    end do

    call get_true_solution_by_index_range(mx-1, mx+2, t, cell_values)
    read(bc_options(2, 1), '(2I1)') orders
    do i = 1, 2
        upper_values(i) = gen_derivative(orders(i), cell_values, dx)
    end do

end subroutine set_implicit_boundary_data


C
C
*$ 2) Routines Producing New Images
*  --------------------------------
C
C
*+ image_convolve

       subroutine image_convolve(nix,niy,in_data,ncx,ncy,icx,icy,array,
     *                           null,out_data,status                 )
C      ----------------------------------------------------------------
C
C Convolve the input image with the specified array
C
C Given:
C   size of input image
       integer    nix, niy
C   input image
       real*4     in_data(nix,niy)
C   size of convolving array
       integer    ncx, ncy
C   centre of convolving array
       integer    icx, icy
C   convolving array data
       real*4     array(ncx,ncy)
C   null data value on input image
       real*4     null
C
C Returned:
C   output image
       real*4     out_data(nix,niy)
C   error status word
       integer    status
C
C The input image is convolved with the supplied function.  The output
C image is of the same size as the input image.
C
C Values beyond the edge of the input image are assumed to be zero.
*-
C Local variables
       integer    i, j, i1, i2, j1, j2, ii, jj

C check status on entry
       if (status.ne.0) return

C initialise output data
       do j=1,niy
         do i=1,nix
           out_data(i,j) = 0.0
         end do
       end do

C move through input image and convolve to output image
       do j=1,niy
         j1 = max(1,j+icy-ncy)
         j2 = min(niy,j+icy-1)
         do i=1,nix
           i1 = max(1,i-icx+1)
           i2 = min(nix,i+ncx-icx)
           if (in_data(i,j).ne.null) then
             do jj=j1,j2
               do ii=i1,i2
                 out_data(ii,jj) = out_data(ii,jj) +
     *               in_data(i,j)*array(ii-i+icx,jj-j+ncy-icy+1)
               end do
             end do
           end if
         end do
       end do

C report any error
       call cmd_err(status,'image_convolve',' ')
       end


!>   subroutine to established a pair linked list by sorting grid cell.
!>   it is suitable for a homogeneous particle distribution with the
!>   same smoothing length in an instant. a fixed number of particles
!>   lie in each cell.
!>
!>     ntotal   : number of particles                                [in]
!>     hsml     : smoothing length                                   [in]
!>     grid     : array of grid cells                               [out]
!>     ngridx   : number of sorting grid cells in x, y, z-direction [out]
!>     ghsmlx   : smoothing length measured in cells of the grid    [out]
!>     maxgridx : maximum x-, y- and z-coordinate of grid range     [out]
!>     mingridx : minimum x-, y- and z-coordinate of grid range     [out]
!>     dgeomx   : x-, y- and z-expansion of grid range              [out]

subroutine init_grid(ntotal, hsml, grid, ngridx, ghsmlx, maxgridx, mingridx, dgeomx)

    use sph_kind, only: rk
    use parameter
    implicit none

    !     parameter used for sorting grid cells in the link list algorithm
    !     maxngx  : maximum number of sorting grid cells in x-direction
    !     maxngy  : maximum number of sorting grid cells in y-direction
    !     maxngz  : maximum number of sorting grid cells in z-direction
    !     determining maximum number of sorting grid cells:
    !     (for an homogeneous particle distribution:)
    !     1-dim. problem: maxngx = maxn ,  maxngy = maxngz = 1
    !     2-dim. problem: maxngx = maxngy ~ sqrt(maxn) ,  maxngz = 1
    !     3-dim. problem: maxngx = maxngy = maxngz ~ maxn^(1/3)
    integer :: maxngx, maxngy, maxngz
    parameter(maxngx=100, maxngy=100, maxngz=1)
    !> 在模拟中所使用的粒子总数
    !> number of particles in simulation
    integer, intent(in) :: ntotal
    integer :: grid(maxngx, maxngy, maxngz), ngridx(dim), ghsmlx(dim)
    real(rk) :: hsml, maxgridx(dim), mingridx(dim), dgeomx(dim)
    integer :: i, j, k, d, maxng(dim), ngrid(3)
    !> averaged number of particles per grid cell
    real(rk), parameter :: nppg = 3.0_rk

    !     initialize parameters: maximum number of grid cells

    maxng(1) = maxngx
    if (dim >= 2) then
        maxng(2) = maxngy
        if (dim == 3) then
            maxng(3) = maxngz
        end if
    end if

    do d = 1, 3
        ngrid(d) = 1
    end do

    !     range of sorting grid

    maxgridx(1) = x_maxgeom
    mingridx(1) = x_mingeom
    if (dim >= 2) then
        maxgridx(2) = y_maxgeom
        mingridx(2) = y_mingeom
        if (dim == 3) then
            maxgridx(3) = z_maxgeom
            mingridx(3) = z_mingeom
        end if
    end if

    do d = 1, dim
        dgeomx(d) = maxgridx(d) - mingridx(d)
    end do

    !     number of grid cells in x-, y- and z-direction:

    if (dim == 1) then
        ngridx(1) = min(int(ntotal/nppg) + 1, maxng(1))
    else if (dim == 2) then
        ngridx(1) = min(int(sqrt(ntotal*dgeomx(1)/(dgeomx(2)*nppg))) + 1, maxng(1))
        ngridx(2) = min(int(ngridx(1)*dgeomx(2)/dgeomx(1)) + 1, maxng(2))
    else if (dim == 3) then
        ngridx(1) = min(int((ntotal*dgeomx(1)*dgeomx(1)/(dgeomx(2)*dgeomx(3)*nppg))**(1._rk/3._rk)) + 1, maxng(1))
        ngridx(2) = min(int(ngridx(1)*dgeomx(2)/dgeomx(1)) + 1, maxng(2))
        ngridx(3) = min(int(ngridx(1)*dgeomx(3)/dgeomx(1)) + 1, maxng(3))
    end if

    !     smoothing length measured in grid cells:

    do d = 1, dim
        ghsmlx(d) = int(real(ngridx(d))*hsml/dgeomx(d)) + 1
    end do

    do d = 1, dim
        ngrid(d) = ngridx(d)
    end do

    !     initialize grid

    do i = 1, ngrid(1)
        do j = 1, ngrid(2)
            do k = 1, ngrid(3)
                grid(i, j, k) = 0
            end do
        end do
    end do

end subroutine init_grid