*> \brief  DGTSVX computes the solution to system of linear equations A * X = B for GT matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGTSVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
*                          DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
*                          WORK, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          FACT, TRANS
*       INTEGER            INFO, LDB, LDX, N, NRHS
*       DOUBLE PRECISION   RCOND
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * ), IWORK( * )
*       DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
*      $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
*      $                   FERR( * ), WORK( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGTSVX uses the LU factorization to compute the solution to a real
*> system of linear equations A * X = B or A**T * X = B,
*> where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
*> matrices.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
*  =================
*>
*> \verbatim
*>
*> The following steps are performed:
*>
*> 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
*>    as A = L * U, where L is a product of permutation and unit lower
*>    bidiagonal matrices and U is upper triangular with nonzeros in
*>    only the main diagonal and first two superdiagonals.
*>
*> 2. If some U(i,i)=0, so that U is exactly singular, then the routine
*>    returns with INFO = i. Otherwise, the factored form of A is used
*>    to estimate the condition number of the matrix A.  If the
*>    reciprocal of the condition number is less than machine precision,
*>    INFO = N+1 is returned as a warning, but the routine still goes on
*>    to solve for X and compute error bounds as described below.
*>
*> 3. The system of equations is solved for X using the factored form
*>    of A.
*>
*> 4. Iterative refinement is applied to improve the computed solution
*>    matrix and calculate error bounds and backward error estimates
*>    for it.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] FACT
*> \verbatim
*>          FACT is CHARACTER*1
*>          Specifies whether or not the factored form of A has been
*>          supplied on entry.
*>          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored
*>                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
*>                  will not be modified.
*>          = 'N':  The matrix will be copied to DLF, DF, and DUF
*>                  and factored.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the form of the system of equations:
*>          = 'N':  A * X = B     (No transpose)
*>          = 'T':  A**T * X = B  (Transpose)
*>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*>          DL is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) subdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The n diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*>          DU is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) superdiagonal elements of A.
*> \endverbatim
*>
*> \param[in,out] DLF
*> \verbatim
*>          DLF is DOUBLE PRECISION array, dimension (N-1)
*>          If FACT = 'F', then DLF is an input argument and on entry
*>          contains the (n-1) multipliers that define the matrix L from
*>          the LU factorization of A as computed by DGTTRF.
*>
*>          If FACT = 'N', then DLF is an output argument and on exit
*>          contains the (n-1) multipliers that define the matrix L from
*>          the LU factorization of A.
*> \endverbatim
*>
*> \param[in,out] DF
*> \verbatim
*>          DF is DOUBLE PRECISION array, dimension (N)
*>          If FACT = 'F', then DF is an input argument and on entry
*>          contains the n diagonal elements of the upper triangular
*>          matrix U from the LU factorization of A.
*>
*>          If FACT = 'N', then DF is an output argument and on exit
*>          contains the n diagonal elements of the upper triangular
*>          matrix U from the LU factorization of A.
*> \endverbatim
*>
*> \param[in,out] DUF
*> \verbatim
*>          DUF is DOUBLE PRECISION array, dimension (N-1)
*>          If FACT = 'F', then DUF is an input argument and on entry
*>          contains the (n-1) elements of the first superdiagonal of U.
*>
*>          If FACT = 'N', then DUF is an output argument and on exit
*>          contains the (n-1) elements of the first superdiagonal of U.
*> \endverbatim
*>
*> \param[in,out] DU2
*> \verbatim
*>          DU2 is DOUBLE PRECISION array, dimension (N-2)
*>          If FACT = 'F', then DU2 is an input argument and on entry
*>          contains the (n-2) elements of the second superdiagonal of
*>          U.
*>
*>          If FACT = 'N', then DU2 is an output argument and on exit
*>          contains the (n-2) elements of the second superdiagonal of
*>          U.
*> \endverbatim
*>
*> \param[in,out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          If FACT = 'F', then IPIV is an input argument and on entry
*>          contains the pivot indices from the LU factorization of A as
*>          computed by DGTTRF.
*>
*>          If FACT = 'N', then IPIV is an output argument and on exit
*>          contains the pivot indices from the LU factorization of A;
*>          row i of the matrix was interchanged with row IPIV(i).
*>          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
*>          a row interchange was not required.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          The N-by-NRHS right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
*>          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*>          RCOND is DOUBLE PRECISION
*>          The estimate of the reciprocal condition number of the matrix
*>          A.  If RCOND is less than the machine precision (in
*>          particular, if RCOND = 0), the matrix is singular to working
*>          precision.  This condition is indicated by a return code of
*>          INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*>          FERR is DOUBLE PRECISION array, dimension (NRHS)
*>          The estimated forward error bound for each solution vector
*>          X(j) (the j-th column of the solution matrix X).
*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
*>          is an estimated upper bound for the magnitude of the largest
*>          element in (X(j) - XTRUE) divided by the magnitude of the
*>          largest element in X(j).  The estimate is as reliable as
*>          the estimate for RCOND, and is almost always a slight
*>          overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*>          BERR is DOUBLE PRECISION array, dimension (NRHS)
*>          The componentwise relative backward error of each solution
*>          vector X(j) (i.e., the smallest relative change in
*>          any element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, and i is
*>                <= N:  U(i,i) is exactly zero.  The factorization
*>                       has not been completed unless i = N, but the
*>                       factor U is exactly singular, so the solution
*>                       and error bounds could not be computed.
*>                       RCOND = 0 is returned.
*>                = N+1: U is nonsingular, but RCOND is less than machine
*>                       precision, meaning that the matrix is singular
*>                       to working precision.  Nevertheless, the
*>                       solution and error bounds are computed because
*>                       there are a number of situations where the
*>                       computed solution can be more accurate than the
*>                       value of RCOND would suggest.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup doubleGTsolve
*
*  =====================================================================
      SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
     $                   DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
     $                   WORK, IWORK, INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          FACT, TRANS
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
     $                   FERR( * ), WORK( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOFACT, NOTRAN
      CHARACTER          NORM
      DOUBLE PRECISION   ANORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGT
      EXTERNAL           LSAME, DLAMCH, DLANGT
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $         LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTSVX', -INFO )
         RETURN
      END IF
*
      IF( NOFACT ) THEN
*
*        Compute the LU factorization of A.
*
         CALL DCOPY( N, D, 1, DF, 1 )
         IF( N.GT.1 ) THEN
            CALL DCOPY( N-1, DL, 1, DLF, 1 )
            CALL DCOPY( N-1, DU, 1, DUF, 1 )
         END IF
         CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
*
*        Return if INFO is non-zero.
*
         IF( INFO.GT.0 )THEN
            RCOND = ZERO
            RETURN
         END IF
      END IF
*
*     Compute the norm of the matrix A.
*
      IF( NOTRAN ) THEN
         NORM = '1'
      ELSE
         NORM = 'I'
      END IF
      ANORM = DLANGT( NORM, N, DL, D, DU )
*
*     Compute the reciprocal of the condition number of A.
*
      CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
     $             IWORK, INFO )
*
*     Compute the solution vectors X.
*
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
     $             INFO )
*
*     Use iterative refinement to improve the computed solutions and
*     compute error bounds and backward error estimates for them.
*
      CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
     $             B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
*     Set INFO = N+1 if the matrix is singular to working precision.
*
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
     $   INFO = N + 1
*
      RETURN
*
*     End of DGTSVX
*
      END


      FUNCTION hmin(x)
!---------------------------------------------------
!***  calculates minimum height of a tetrahedron
!---------------------------------------------------

      IMPLICIT NONE
      REAL(kind=8):: hmin, x(3,4)

      REAL(kind=8):: vol

      REAL(kind=8) :: x1(3),x2(3),x3(3),xp(3),h(4),a

      x1(:) = x(:,2)-x(:,1)
      x2(:) = x(:,3)-x(:,1)
      x3(:) = x(:,4)-x(:,1)
      CALL vecpro(x1,x2,xp)
      vol = DOT_PRODUCT(x3,xp)
      vol = vol/6.d0
      a = SQRT(DOT_PRODUCT(xp,xp)) / 2d0
      h(1) = 3d0 * vol / a

      x1(:) = x(:,3)-x(:,2)
      x2(:) = x(:,4)-x(:,2)
      CALL vecpro(x1,x2,xp)
      a = SQRT(DOT_PRODUCT(xp,xp)) / 2d0
      h(2) = 3d0 * vol / a

      x1(:) = x(:,4)-x(:,1)
      x2(:) = x(:,2)-x(:,1)
      CALL vecpro(x1,x2,xp)
      a = SQRT(DOT_PRODUCT(xp,xp)) / 2d0
      h(3) = 3d0 * vol / a

      x1(:) = x(:,3)-x(:,1)
      x2(:) = x(:,4)-x(:,1)
      CALL vecpro(x1,x2,xp)
      a = SQRT(DOT_PRODUCT(xp,xp)) / 2d0
      h(4) = 3d0 * vol / a

      hmin = MIN (h(1), h(2), h(3), h(4))

      END FUNCTION hmin


subroutine INPUT
  use simsphere_mod
  implicit none

! ** Modified 8/14/90 >> Modified Hi (SKONST / S).

! **  Subroutine INPUT computes solar radiation as a function of the
! **  day, season, atmospheric attenuation, and albedo.

!  real(kind=8) :: EFFDEC, SOLSIN
  real :: EFFDEC=0.0, SOLSIN=0.0
  real :: SS(12)
  integer :: MD(12)

! Don't need to declare FTABS, FBSCAT, FTSCAT -- subroutine rewritten as function
!  real :: FTABS, FBSCAT, FTSCAT,  RM, S, N
  real :: RM=0.0, S=0.0, N=0.0, RLPATH=0.0, PATH=0.0
  real :: TABS=0.0, BSCAT=0.0, TSCAT=0.0, TABSD=0.0, BSCATD=0.0, TSCATD=0.0
  real :: DF=0.0, DE=0.0, SIG=0.0, EQT=0.0, HRANGL=0.0, SLB=0.0, SHEAT=0.0, HI=0.0, XSER=0.0, SOLEL=0.0
  real :: sinsolelslope=0.0, solelslope=0.0, GMT=0.0
  real, parameter :: skonst = 1.94*4.1868e4/60
  integer :: IMO1=0, JMO=0, I=0, K=0, DAD=0

!      INCLUDE 'modvars.h'

! **  The definition of the variables in the following DATA statements
! **  can be found in the manual.

  DATA MD / 31 , 29 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30, 31/
  DATA SS / 0.967 , 0.971 , 0.982 , 0.999 , 1.016 , 1.029 , 1.034,      &
          1.030 , 1.018 , 1.002 , 0.985 , 0.973 /

! **  Y ...Counter for determining celestial mechanics for long, lat and
! **  time of year.

  IF ( Y /= 1 ) GO TO 19
  Y = Y + 1

  IMO1 = IMO + 1
  IF (IMO1 == 13) IMO1 = 1

! **  Compute the solar distance factor.

  RM = FLOAT( IDAY - 1 ) / FLOAT( MD ( IMO ) )
  S = SS( IMO ) + RM * (SS( IMO1 ) - SS( IMO ) )

! **  Set up the number of the day in the year (DAD).

  K = IDAY
  JMO = IMO - 1
  IF ( JMO < 1 ) GO TO 12
  do I = 1 , JMO
    K = K + MD(I)
  end do
12  N = IYR / 4
  N = IYR - N * 4
  IF (N /= 0 .AND. K >= 60) K = K - 1
  DAD = K - 1

! **  Calculate the angular fraction of a year, convert to radians.

  DF = DAD * 360 / 365.242
  DE = real(DF / RADIAN,4)

! **  Correction to declination caused by elliptical orbit.

  SIG = SIGA + DF + 1.914827 * SIN( DE ) - 0.079525 * COS( DE )         &
        & + 0.019938 * SIN( DE * 2 ) - 0.00162 * COS( DE * 2 )
  SIG = real(SIG / RADIAN,4)

! **  Declination of the sun.

  EFFDEC = real(ASIN( SDEC * SIN( SIG ) ),4)

! **  True solar noon.

  EQT = 0.12357 * SIN( DE ) - 0.004289 * COS( DE )                      &
        & + 0.153809 * SIN( DE * 2 ) + 0.060783 * COS( DE * 2 )
  EQT = EQT + 12

19 CONTINUE

! **  Calc time in Greenwich Mean Time.

  GMT = PTIME + TZ

!  Calculate the solar hour angle in radians.

  HRANGL = 15 * ( GMT - EQT ) - XLONG
  HRANGL = real(HRANGL / RADIAN,4)

!  Now we can finally compute the solar elevation angle.

  SLB = real(XLAT / RADIAN,4)
  SOLSIN = SIN(EFFDEC)*SIN(SLB)+COS(EFFDEC)*COS(SLB)*COS(HRANGL)
  SOLEL = real(ASIN( SOLSIN ) * RADIAN,4)

  if (SLOPE > 0) then
    call sslope (sinsolelslope,solelslope,effdec,slb,hrangl)
  else
    call albedo (solsin)
    sinsolelslope = solsin
  end if

!  If the solar altitude is less that or equal to zero it's night so
!  return, otherwise compute absolute optical air mass (PATH).

  IF ( SOLEL <= 0 ) THEN
    SWAVE = 0
    RETURN
  END IF

  RLPATH = ( SOLSIN + 0.15 * ( SOLEL + 3.885 ) ** (-1.253) ) ** (-1)
!      if (rlpath < 1.0) rlpath = 1.0
  PATH = 0.001 * PS1 * RLPATH
  SOLEL = real(SOLEL / RADIAN,4)

!  write(*,*) 'SOLSIN: ',SOLSIN, ' SOLEL: ',SOLEL,' RLPATH: ',RLPATH,' PATH: ',PATH
!TJC  These lines moved to functions in module: ftabsT, ftscatT, fbscatT
!  CALL TRANSM (RLPATH,FTABS,FTSCAT,FBSCAT)

!  Store values for use.

!  TABS = FTABS
!  TSCAT = FTSCAT
!  BSCAT = FBSCAT

  if ( RLPATH == RLPATH ) then
    TABS = ftabsT(RLPATH)
    TSCAT = ftscatT(RLPATH)
    BSCAT = fbscatT(RLPATH)
  else
    write(*,*) 'RLPATH is NaN, input.f90:128'
    stop
  end if

!TJC End

!  Set the PATH length for diffuse radiation equal to 1.7.

  PATH = 1.7

!TJC  These lines moved to functions in module: ftabsT, ftscatT, fbscatT
!  CALL TRANSM (PATH,FTABS,FTSCAT,FBSCAT)
!
!!  Again store values for use.
!
!  TABSD  = FTABS
!  TSCATD = FTSCAT
!  BSCATD = FBSCAT

   TABSD = ftabsT(PATH)
   TSCATD = ftscatT(PATH)
   BSCATD = fbscatT(PATH)

!TJC End

! **  SHEAT >>> Sunlight amount on horizontal plane outside atmosphere
! **  XSER  >>> Diffuse Shortwave Radiation at the ground.
! **  HI    >>> Direct SW Radiation reaching the ground.
! **  SWAVE >>> Diffuse + Direct = 'Global'

  if (S /= 0) SHEAT = SKONST * sinsolelslope / S
  XSER  = BSCATD * ALBDOE * ( 1 - TSCATD ) * TABSD * SIN( SOLEL )
  if (S /= 0) HI = ( SHEAT * TABS * TSCAT ) + ( SKONST / S* TABS * ( 1 - TSCAT )    &
&       * ( 1 - BSCAT ) ) * SIN( SOLEL )
  if (XSER /= 1.0) then
    SWAVE = ( HI * ( 1 - ALBDOE ) ) / ( 1.0 - XSER )
  else
    write(*,*) 'Attempted divide by zero: input.f90:168'
    stop
  end if

  IF(CLOUD_FLAG) SWAVE = SWAVE*(1-(0.7*(0.1*CLD_FRACT)))
       ! impose cloud fraction; reduce swave according to cloud amount
       ! Note: forcing real arithmetic

  return
end


c     ============================================
      subroutine setaux(mbc,mx,my,xlower,ylower,dxc,dyc,
     &                  maux,aux)
c     ============================================
c
c     # set auxiliary arrays for advection on a curvilinear grid
c
c     # on input, (xc(i),yc(j)) gives uniformly spaced computational grid.
c     # on output,
c     #   aux(1,i,j) is edge velocity at "left" boundary of grid point (i,j)
c     #   aux(2,i,j) is edge velocity at "bottom" boundary of grid point (i,j)
c     #   aux(3,i,j) = kappa  is ratio of cell area to dxc*dyc
c
      implicit double precision (a-h,o-z)
      double precision, intent(inout),
     &              dimension(3, 1-mbc:mx+mbc,1-mbc:my+mbc) :: aux
      dimension xccorn(5),yccorn(5),xpcorn(5),ypcorn(5)
c
c
      do 20 j=1-mbc,my+mbc
         do 20 i=1-mbc,mx+mbc
c
c           # computational points (xc,yc) are mapped to physical
c           # coordinates (xp,yp) by mapc2p:
c
c           # lower left corner:
	    xccorn(1) = xlower + (i-1)*dxc
	    yccorn(1) = ylower + (j-1)*dyc
	    call mapc2p(xccorn(1),yccorn(1),xpcorn(1),ypcorn(1))

c           # upper left corner:
	    xccorn(2) = xccorn(1)
	    yccorn(2) = yccorn(1) + dyc
	    call mapc2p(xccorn(2),yccorn(2),xpcorn(2),ypcorn(2))
c
c           # upper right corner:
	    xccorn(3) = xccorn(1) + dxc
	    yccorn(3) = yccorn(1) + dyc
	    call mapc2p(xccorn(3),yccorn(3),xpcorn(3),ypcorn(3))
c
c           # lower right corner:
	    xccorn(4) = xccorn(1) + dxc
	    yccorn(4) = yccorn(1)
    	call mapc2p(xccorn(4),yccorn(4),xpcorn(4),ypcorn(4))
c
c
c           # compute edge velocities by differencing stream function:
c
	    aux(1,i,j) = (stream(xpcorn(2),ypcorn(2))
     &			  - stream(xpcorn(1),ypcorn(1)))/ dyc
c
	    aux(2,i,j) = -(stream(xpcorn(4),ypcorn(4))
     &			  - stream(xpcorn(1),ypcorn(1)))/ dxc

c
c
c           # compute area of physical cell from four corners:

	    xpcorn(5) = xpcorn(1)
	    ypcorn(5) = ypcorn(1)
	    area = 0.d0
	    do ic=1,4
	      area = area + 0.5d0 * (ypcorn(ic)+ypcorn(ic+1)) *
     &               (xpcorn(ic+1)-xpcorn(ic))
	    enddo

	    aux(3,i,j) = area / (dxc*dyc)
c
   20  continue
c
       return

       end


       implicit double precision (a-h,o-z)
       common /factl/ fact(0:100)
       common /herm/ h(0:100)
       dimension wf(0:100)
       pi=4.0d0*datan(1.0d0)
       read(*,*)nmax
       call factorial(nmax)
       nx=100
       xmin=-5.d0
       xmax=+5.d0
       xinc=(xmax-xmin)/nx
       x=xmin
       do i=1,nx+1
          call hermite(nmax,x)
          do n=0,nmax
            wf(n)=dsqrt(1.0d0/(2.0d0**n*dsqrt(pi)*fact(n)))*
     &         dexp(-x*x/2.0d0)*h(n)
          end do
          write(*,'(1x,f5.2,101f12.6)')x,(wf(n),n=0,nmax)
          x=x+xinc
       end do

       end

       subroutine factorial(n)
       implicit double precision (a-h,o-z)
       common /factl/ fact(0:100)
       fact(0)=1
       do i=1,n
         fact(i)=fact(i-1)*i
       end do
       end

      subroutine hermite(n,x)
      implicit real*8 (a-h,o-z)
      common /herm/ h(0:100)
      h(0)=1.0d0
      h(1)=2.0d0*x
      do i=2,n
        h(i)=2.0d0*x*h(i-1)-2.0d0*(i-1)*h(i-2)
      end do
      end


c--------------------------------------------------------
c  This program uses a semi-implicit representation of
c  the nonlinearities along with up- and down- winding
c  in regions where \psi_y=u is +ve or -ve respectively
c  The flow is periodic in x and also odd about x=pi
c  The latter condition is enforced in the finite-differences.
c  2nd order upwind and downwind formulas are used.
c--------------------------------------------------------
c
c   NOTE that the BC here psi_\eta = - sin(x)
c   Here the solution is computed on the full y range [-1,1]
c----------------------------------------------------------
c  Gursh-Edited the code to make memory consumption minimal via
c  introducing INX and INN
c
c  In this version of the code, the solution for Psi is calculated
c  by using Finite differences and upwind differencing in the
c  x-direction. Moreover, the x domain is [0,pi] and NOT [0,2pi]

      implicit double precision(a-h,o-y)
      implicit complex*16(z)
      integer INX, INN
      parameter(INX=265,INN=110)

      dimension a(INN),b(INN),c(INN),d(INN),e(INN)
      dimension r(INN),x(INN),y(INN),u(INN),v(INN),xx(INX)
      dimension psi(INX,0:INN),psi1(INX,0:INN),shp(INX)
     $,psix(INX,0:INN), zvhp(INX), zuhp(INX),
     $ uhm(INX),vhm(INX),uhp(INX),vhp(INX),uh0(INX),vh0(INX),
     $ psit(10), psitimes(5), periods(5)

      open(1,file='input',status='old')
c      open(2,file='en.m',status='unknown')
c      open(3,file='u1.m',status='unknown')
c      open(4,file='u2.m',status='unknown')
c      open(7,file='u3.m',status='unknown')
c      open(8,file='v1.m',status='unknown')
c      open(9,file='v2.m',status='unknown')
c      open(10,file='v3.m',status='unknown')
c      open(11,file='final',status='unknown')
c      open(13,file='vpi.m',status='unknown')
c      open(14,file='v0.m',status='unknown')
c      open(20,file='uhm.m',status='unknown')
c      open(21,file='vhm.m',status='unknown')
c      open(22,file='uhp.m',status='unknown')
c      open(23,file='vhp.m',status='unknown')
c      open(24,file='uh0.m',status='unknown')
c      open(25,file='vh0.m',status='unknown')
c      open(30,file='psi.m',status='unknown')
c      open(31,file='sum.m',status='unknown')
      open(32,file='psifin.m',status='unknown')

      read(1,*) n
      read(1,*) nx
      read(1,*) dt
      read(1,*) nmax
      read(1,*) rm
      read(1,*) tmax
      read(1,*) tstart
      read(1,*) papstart
      read(1,*) nstore
      read(1,*) nwrite
      read(1,*) icont
      read(1,*) iphase
      read(1,*) ipap

      write(6,*) 'Rey=',rm,'  Tmax=',tmax,'  dt=', dt,'  Nx=',nx,
     # '  Ny=', n
      write(6,*) 'Max Iter=', nmax

c-----computational parameters-------------------------------
c  h=step in the y-direction
c  dx=step in the x-direction
c  (n+1) points in the y-direction
c  (nx+1) points in the x-direction

      if((INN.lt.(n+5)).or.(inx.lt.(nx+5))) then
      write(6,*), 'INN or INX too small in code -increase them'
      end if

c     change value of h
      h=2.d0/float(n+1)
      h2=h**2
      h3=h**3
      h4=h**4
      api=4.d0*datan(1.d0)
      dx=api/float(nx)
      aa1=DBLE(dt/(rm*h*h))
      aa2=dt/(4.*h*dx)
      aw=-1.d0
      bw=-1.d0
      nx1=nx/8
      nx2=nx/4
      nx3=3*nx/8
      nm=1+(n+1)/4
      np=1+3*(n+1)/4
      n0=1+(n+1)/2
      ixp=10
      nspec=1/dt
      flush_time=5.0

      tol=1.d-8
      do 91 i=1,10
  91  psit(i)=-1

c------------------------------------------------------------
c1234 continue
      if(icont.eq.1) goto 88

c--- Set up initial conditions --------------------------------
      t=0.d0
 3    continue
      do 19 i=1,nx
      xx(i)=dx*(i-1)
      do 1 j=1,n+2
      y(j)=-1.d0+h*(j-1)
      psi(i+2,j)=0.
c1    psi(i,j)=sin(api*y(j))*sin(xx(i))/api
 1    psi(i,j)=.5d0*(y(j)-y(j)*y(j)*y(j))*sin(xx(i))
 19   continue
      do 44 i=1,nx
c     change value derivative
      psi(i,0)=psi(i,2)-2.d0*h*aw*sin(dx*(i-1))
      psi(i,n+3)=psi(i,n+1)+2.d0*h*bw*sin(dx*(i-1))
c      psi(i,n+3)=-psi(i,n+1)
      psi(i,1)=0.d0
      psi(i,n+2)=0.d0
 44   continue
      goto 89
c-------------------------------------------------------------

c-- the following are the read initial conditions for continuation
 88   read(11,*) t
      do 656 j=0,n+3
      read(40,1024) (psi(i,j),i=1,nx)
 656  continue
c---------------------------------------------------------------

  89  continue

c---Time loop ---------------------------------------------------

      do 4 iu=1,nmax

c--- set up psix(i,j) the derivative psi_x, pseudospectrally

      do 350 j=2,n+1
      do 354 i=2,(nx-1)
      psix(i,j)=0.5*(psi(i+1,j)-psi(i-1,j))/dx
c---- winding on the psi_x derivative
      if( (j.gt.2).and.(j.lt.n)) then
      if ((-0.5*psi(i,j-2)+psi(i,j-1)-psi(i,j+1)
     &+0.5*psi(i,j+2)).lt.0.0) then
      psix(i,j) = (psi(i+1,j)-psi(i,j))/dx
      elseif((-0.5*psi(i,j-2)+psi(i,j-1)-psi(i,j+1)
     &+0.5*psi(i,j+2)).gt.0.0) then
      psix(i,j) = (psi(i,j)-psi(i-1,j))/dx
      endif
      endif
 354  continue
c--- need these derivatives to be second order one-sided
c--- infact the value of psix(1,j) is always multiplied by zero
c--- therefore the accuracy of this term is unimportant
c--- Note psi(nx+1,j)=0 is imposed so that psix(nx,j) is 2nd order
      psix(1,j)=psi(2,j)/dx
      psix(nx,j)=0.5*(0.d0-psi(nx-1,j))/dx
 350  continue

      do 355 i=1,nx
      psix(i,1)=0.d0
 355  psix(i,n+2)=0.d0

c---  psix(i,j) is a real valued array equal to psi_x

      do 55 ix=1,nx

c---- loop in y-direction   ii=2,n+1  (y=-1+h, 1-h)

      do 2 ii=2,n+1

         i=ii-1

         a(i)=-.5d0*aa1
         b(i)=1.d0+2.d0*aa1
         c(i)=-2.d0-3.d0*aa1
         d(i)=1.d0+2.d0*aa1
         e(i)=-.5d0*aa1

c-----Here psi_yyx is upwinded according to sign of psi_y
      if( ((psi(ix,ii+1)-psi(ix,ii-1)).lt.0).or.(ix.eq.1)) then
      psiyyxwind=
     #       (psi(ix+1,ii+1)-psi(ix,ii+1))/dx
     # -2.d0*(psi(ix+1,ii)-psi(ix,ii))/dx
     #      +(psi(ix+1,ii-1)-psi(ix,ii-1))/dx
      else
      psiyyxwind=
     #       (psi(ix,ii+1)-psi(ix-1,ii+1))/dx
     # -2.d0*(psi(ix,ii)-psi(ix-1,ii))/dx
     #      +(psi(ix,ii-1)-psi(ix-1,ii-1))/dx
      endif

      r(i)=psi(ix,ii+1)-2.d0*psi(ix,ii)+
     #      psi(ix,ii-1)+.5d0*aa1*(psi(ix,ii+2)
     #     -4.d0*psi(ix,ii+1)+6.d0*psi(ix,ii)
     #     -4.d0*psi(ix,ii-1)+psi(ix,ii-2))
     #     +.5d0*(dt/h)*(
     #      psix(ix,ii)*(psi(ix,ii+2)-2.d0*psi(ix,ii+1)
     #      +2.d0*psi(ix,ii-1)-psi(ix,ii-2))
     #     -(psi(ix,ii+1)-psi(ix,ii-1))
     #     *psiyyxwind
     #     )

 2    continue
c     change LU matrix and RHS vector
      c(1)=c(1)+a(1)
      c(n)=c(n)+e(n)
      r(1)=r(1)+2.d0*h*aw*a(1)*sin((ix-1)*dx)
      r(n)=r(n)-2.d0*h*bw*e(n)*sin((ix-1)*dx)
c----------------------------------------------------------------
c     This is the inversion procedure for the matrix with
c     columns a b c d with RHS vector r

      D(1)=D(1)/C(1)
      E(1)=E(1)/C(1)
      r(1)=r(1)/C(1)
      C(2)=C(2)-B(2)*D(1)
      D(2)=(D(2)-B(2)*E(1))/C(2)
      r(2)=(r(2)-B(2)*r(1))/C(2)
      E(2)=E(2)/C(2)
      DO 7 I=3,N
      B(I)=B(I)-A(I)*D(I-2)
      C(I)=C(I)-A(I)*E(I-2)
      r(I)=r(I)-A(I)*r(I-2)
      C(I)=C(I)-B(I)*D(I-1)
      D(I)=(D(I)-B(I)*E(I-1))/C(I)
      E(I)=E(I)/C(I)
  7   r(I)=(r(I)-B(I)*r(I-1))/C(I)
      X(N)=r(N)
      X(N-1)=r(N-1)-D(N-1)*X(N)
      NM1=N-2
      DO 8 I=1,NM1
      K=N-I-1
      X(K)=r(K)-D(K)*X(K+1)-E(K)*X(K+2)
 8    CONTINUE

      do 444 i=2,n+1
 444  psi1(ix,i)=x(i-1)

c     change Solution update after inversion
      psi1(ix,0)=psi1(ix,2)-2.d0*h*aw*sin(dx*(ix-1))
c      psi1(ix,n+3)=-psi1(ix,n+1)
      psi1(ix,n+3)=psi1(ix,n+1)+2.d0*h*bw*sin(dx*(ix-1))
      psi1(ix,1)=0.d0
      psi1(ix,n+2)=0.d0

 55   continue
      t=t+dt
      do 555 i=1,nx
      do 556 j=0,n+3
 556  psi(i,j)=psi1(i,j)
 555  continue

      if((mod(iu,nstore).eq.0).and.(ipap.eq.1).and.(t.gt.papstart)) then
      sum=0.d0
      sum1=0.d0
      sum2=0.d0
      sum3=0.d0
      sum0=0.d0
      do 77 i=2,n+1
      v0=-psix(1,i)
      vpi=-psix(nx/2,i)
      u1=(psi(nx1,i+1)-psi(nx1,i-1))/2.d0/h
      v1=-psix(nx1+1,i)
      u2=(psi(nx2,i+1)-psi(nx2,i-1))/2.d0/h
      v2=-psix(nx2+1,i)
      u3=(psi(nx3,i+1)-psi(nx3,i-1))/2.d0/h
      v3=-psix(nx3+1,i)
      sum0=sum0+h*v0*v0
      sum=sum+h*vpi*vpi
      sum1=sum1+h*(u1*u1+v1*v1)
      sum2=sum2+h*(u2*u2+v2*v2)
      sum3=sum3+h*(u3*u3+v3*v3)
  77  continue
      sum1=sum1+h*sin((nx1-1)*dx)
      sum2=sum2+h*sin((nx2-1)*dx)
      sum3=sum3+h*sin((nx1-1)*dx)
      sumdif=sum1-sumold
      sumold=sum1
      sum0=sqrt(sum0)
      sum=sqrt(sum)
c      write(2,666) t,sum,sum1,sum2,sum3
c      write(31,667) t,sum0,sum
      write(6,666) t,sum1,sum2,sum3,sumdif
c     if(abs(sum).gt.500.d0) stop
      if(abs(sum1).gt.100.d0) then
      write(6,*) 'sum1 > 100 '
      goto 1234
      endif
      endif

c--- set up velocity profiles to save ------------------------------
      if(mod(iu,nwrite).eq.0) then

c      rewind(3)
c      rewind(4)
c      rewind(7)
c      rewind(8)
c      rewind(9)
c      rewind(10)
c      rewind(11)
c      rewind(13)
c      rewind(14)
c      rewind(20)
c      rewind(21)
c      rewind(22)
c      rewind(23)
c      rewind(24)
c      rewind(25)
      do 9 j=2,n+1
      v(j)=(psi(2,j)-psi(nx,j))/2.d0/dx
  9   u(j)=(psi(nx1,j+1)-psi(nx1,j-1))/2.d0/h
      v(1)=0.d0
      u(1)=aw*sin(dx*(nx1-1))
      u(n+2)=bw*sin(dx*(nx1-1))
      v(n+2)=0.d0
c      write(3,333) (y(i),u(i),i=1,n+2)
c      write(8,333) (y(i),v(i),i=1,n+2)
      do 10 j=2,n+1
      v(j)=(psi(nx1+1,j)-psi(nx1-1,j))/2.d0/dx
  10  u(j)=(psi(nx2,j+1)-psi(nx2,j-1))/2.d0/h
      u(1)=aw*sin(dx*(nx2-1))
      v(1)=0.d0
      u(n+2)=bw*sin(dx*(nx2-1))
      v(n+2)=0.d0
c      write(4,333) (y(i),u(i),i=1,n+2)
c      write(9,333) (y(i),v(i),i=1,n+2)
      do 11 j=2,n+1
      v(j)=(psi(nx2+1,j)-psi(nx2-1,j))/2.d0/dx
  11  u(j)=(psi(nx3,j+1)-psi(nx3,j-1))/2.d0/h
      u(1)=aw*sin(dx*(nx3-1))
      v(1)=0.d0
      u(n+2)=bw*sin(dx*(nx3-1))
      v(n+2)=0.d0
c      write(7,333) (y(i),u(i),i=1,n+2)
c      write(10,333) (y(i),v(i),i=1,n+2)
      do 12 j=2,n+1
  12  v(j)=-psi(nx,j)/dx
      v(1)=0.d0
      v(n+2)=0.d0
c      write(13,333) (y(i),v(i),i=1,n+2)
      do 79 j=2,n+1
  79  v(j)=-psi(2,j)/dx
      v(1)=0.d0
      v(n+2)=0.d0
c      write(14,333) (y(i),v(i),i=1,n+2)
      do 78 i=1,nx
c     change shear
c      shp(i)=(psi(i,n+3)-2.d0*psi(i,n+2)+psi(i,n+1))/h/h
      shp(i)=(psi(i,0)-2.d0*psi(i,1)+psi(i,2))/h/h
      uhm(i)=.5d0*(psi(i,nm+1)-psi(i,nm-1))/h
      vhm(i)=-psix(i,nm)
      uh0(i)=.5d0*(psi(i,n0+1)-psi(i,n0-1))/h
      vh0(i)=-psix(i,n0)
      uhp(i)=.5d0*(psi(i,np+1)-psi(i,np-1))/h
  78  vhp(i)=-psix(i,np)
c      write(20,333) (xx(i),uhm(i),i=1,nx)
c      write(21,333) (xx(i),vhm(i),i=1,nx)
c      write(22,333) (xx(i),uhp(i),i=1,nx)
c      write(23,333) (xx(i),vhp(i),i=1,nx)
c      write(24,333) (xx(i),uh0(i),i=1,nx)
c      write(25,333) (xx(i),vh0(i),i=1,nx)
c      write(28,333) (xx(i),shp(i),i=1,nx)

      if((mod(iu,nstore).eq.0).and.(ipap.eq.1).and.(t.gt.papstart)) then
      rewind(30)
c     write(30,*) t
      do 20 j=0,n+3
c 20  write(30,512) (psi(i,j),i=1,nx)
c  20  write(30,1024) (psi(i,j),i=1,nx)
  20  continue
      endif
c     write(11,*) t
      endif
      if(mod(iu,nspec).eq.0) then
      do 459 i=1,nx
      zvhp(i)=vhp(i)
  459 zuhp(i)=uhp(i)
c      write(26,333) (i,cdabs(zvhp(i))/nx,i=1,nx/2)
c      write(27,333) (i,cdabs(zuhp(i))/nx,i=1,nx/2)
      endif

      do 80 i=1,nx
  80  shp(i)=(psi(i,0)-2.d0*psi(i,1)+psi(i,2))/h/h
      shpmax=0.
      shpmin=0.
      do 778 i=1,nx
      if(shp(i).gt.shpmax) then
      shpmax=shp(i)
      imax=i
      endif
      if(shp(i).lt.shpmin) then
      shpmin=shp(i)
      imin=i
      endif
  778 continue
      if((shpmax.gt.9000000).or.(shpmin.lt.-9000000)) then
      write(6,*) 'Shear > 9000000'
      goto 1234
      endif

      nearxzero=15*nx/128
      nearxpeak=80*nx/128
      jval=80*(n+1)/100
      psit(4)=0.d0
      psit(5)=0.d0
      do 92 i=1,n
  92  psit(5)=psit(5)+abs(psi(nearxpeak,i))
      psit(5)=psit(5)*h*0.5
      do 93 i=1,nx
  93  psit(4)=psit(4)+abs(psi(i,jval))
      psit(4)=psit(4)*dx

      psit(2)=(psit(4)-psit(1))/dt
      if (psit(2)*psit(3).lt.0) then
      psitimes(2)=psitimes(1)
      psitimes(1)=t
      periods(1)= psitimes(1)-psitimes(2)
      endif
      psit(3)=psit(2)
      psit(1)=psit(4)

      psit(7)=(psit(5)-psit(6))/dt
      if (psit(7)*psit(8).lt.0) then
      psitimes(4)=psitimes(3)
      psitimes(3)=t
      periods(2)= psitimes(3)-psitimes(4)
      endif
      psit(8)=psit(7)
      psit(6)=psit(5)

      if(mod(iu,nstore).eq.0) then
      write(6,94) t, shpmin, shpmax, psit(4), psit(5)
  94  format('SHR',f11.4,f17.10,f16.10,2f13.8)
      endif

      if(flush_time.lt.t) then
      rewind(32)
c      write(32,*) '% Rey=',rm,'  Nx=',nx,'  Ny=',n,'   dt=',dt,
c     # ' timemarched for Tmax=',t, '  %Actual Tmax=',tmax
      do 221 j=0,n+3
 221  write(32,1024) (psi(i,j),i=1,nx)
      CALL FLUSH(32)
      flush_time=flush_time+5.0
      endif

      if(t.gt.tmax) goto 999

4     continue
 999  continue
 1234 continue
      write(6,*) 'FINAL t===', t,'Reynolds==',rm
c      write(11,*) t
      rewind(32)
c--      write(32,*) '% Rey=',rm,'  Nx=',nx,'  Ny=',n,'   dt=',dt,
c--     # ' timemarched for Tmax=',t, '  %Actual Tmax=',tmax
      do 220 j=0,n+3
c220  write(32,512) (psi(i,j),i=1,nx)
 220  write(32,1024) (psi(i,j),i=1,nx)
c      do 221 j=2,n+3
c 221  write(32,1024) (-psi(i,n+3-j),i=1,nx)

 222  format(2x,e13.6,4x,e13.6)
 64   format(3x,64f13.4)
 128  format(2x,128f13.4)
 256  format(2x,256f13.6)
 512  format(2x,512f13.6)
1024  format(2x,1024f17.10)

 666  format(2x,e13.6,3x,e13.6,3x,e13.6,3x,e13.6,3x,e13.6)
 333  format(2x,e13.6,3x,e13.6)
 334  format(2x,e13.6,3x,e13.6,3x,e13.6)
 667  format(1x,e13.6,4x,e13.6,4x,e13.6)
      stop
      end


MODULE QuadraticMap
IMPLICIT NONE

CONTAINS
PURE SUBROUTINE QUADRATIC_STEP(a, x, y)
IMPLICIT NONE
! Inputs:
! a -- 12 coefficients for quadratic map
! x, y -- current point
!
! Outputs:
! x, y -- the point after one iteration
    REAL, DIMENSION(12), INTENT(IN) :: a
    REAL, INTENT(INOUT) :: x, y
    REAL :: tmp, xy, x2, y2

    xy = x * y
    x2 = x ** 2
    y2 = y ** 2

    tmp = a(1) + a(2) * x + a(3) * y + a(4) * xy + a(5) * x2 + a(6) * y2
    y = a(7) + a(8) * x + a(9) * y + a(10) * xy + a(11) * x2 + a(12) * y2
    x = tmp

END SUBROUTINE QUADRATIC_STEP

PURE SUBROUTINE LINEAR_STEP(a, x, y, e1, e2, n1, n2)
IMPLICIT NONE
! Inputs:
! a -- 12 coefficients for quadratic map
! x, y -- current point
! e1, e2 -- current tangent space orthonormal basis
!
! Ouptuts:
! e1, e2 -- the result of orthonormalization of Jacobian applied to e1 and e2
! n1, n2 -- norms of (new) e1 and e2 before normalization
    REAL, DIMENSION(12), INTENT(IN) :: a
    REAL, INTENT(IN) :: x, y
    REAL, DIMENSION(2), INTENT(INOUT) :: e1, e2
    REAL, INTENT(OUT) :: n1, n2

    REAL, DIMENSION(2, 2) :: jacobian
    REAL, DIMENSION(2) :: e2_rotated

    jacobian = J(a, x, y)
    e1 = MATMUL(jacobian, e1)
    e2 = MATMUL(jacobian, e2)
    ! Reorthonormalize
    n1 = NORM2(e1)
    e1 = e1 / n1
    e2_rotated = e2 - DOT_PRODUCT(e2, e1) * e1
    n2 = NORM2(e2_rotated)
    e2 = e2_rotated / n2

    CONTAINS

    ! Jacobian
    PURE FUNCTION J(a, x, y)
        IMPLICIT NONE
        REAL, DIMENSION(2, 2) :: J
        REAL, DIMENSION(12), INTENT(IN) :: a
        REAL, INTENT(IN) :: x, y

        REAL :: dXx, dXy, dYx, dYy

        dXx = a(2) + a(4) * y + 2 * a(5) * x
        dXy = a(3) + a(4) * x + 2 * a(6) * y
        dYx = a(8) + a(10) * y + 2 * a(11) * x
        dYy = a(9) + a(10) * x + 2 * a(12) * y

        J(1,1) = dXx
        J(1,2) = dXy
        J(2,1) = dYx
        J(2,2) = dYy
    END FUNCTION J

END SUBROUTINE LINEAR_STEP

END MODULE QuadraticMap


MODULE non_linear_solvers
!
! It contains algorithms and numerical methods used for the inversion of the
! Span-Wagner EoS, necessary for the evaluation of properties in each node of the
! grid.
!
! It contains a 2D Newton-Raphson algorithm, a 1D Newton-Raphson algorithm, a
! Brent algorithm and the corresponding functions of which we seek the zeros.
!==============================================================================
!==============================================================================
!
USE def_constants
USE properties
!USE def_variables, ONLY: vL_psat_spline, vV_psat_spline,&
!                        &uL_psat_spline, uV_psat_spline,&
!                        &Tsat_psat_spline, saturP
!USE Interp_table
IMPLICIT NONE
!
PRIVATE
PUBLIC  New_Rap2D, New_Rap3D, New_Rap1D, BrentRoots
CONTAINS
!
!
!
!===============================================================================
      SUBROUTINE New_Rap2D(MODE, out1_NewRap, out2_NewRap, &
     &           resnorm, Niter, exitflag, in_1, in_2, guess_1, guess_2)
!===============================================================================
!-------------------------------------------------------------------
!         2D         TWO-PHASE or SINGLE-PHASE
!-------------------------------------------------------------------
!
!  Input :
!  -------
!     MODE              =  1 saturation, 2 to be added, etc.
!     in_1, in_2        =  Input values (optional, not always needed),
!                          For MODE=1: in_1 is the T_sat
!                          For MODE=2: in_1 is the pressure, in_2 is the internal energy
!     guess_1, guess_2  =  Initial guess
!                          For MODE=1: guess_1 is v_liquid, guess_2 is v_vapor
!                          For MODE=2: guess_1 is the Temperature, guess_2 is the specific volume
!
!  Output :
!  -------
!     resnorm           =  Norm of the "residual vector"
!     Niter             =  Number of iterations
!     exitflag          =  1 "normal exit", < 1 "a problem occurred"
!
!     out1_NewRap, out2_NewRap depend on the MODE used
!
!-----------------------------------------------------------------------
!                                         M. De Lorenzo      07/10/2016
!-----------------------------------------------------------------------
!
!
      IMPLICIT NONE
!
! Global variables
      INTEGER, INTENT(IN)  :: MODE
      INTEGER, INTENT(OUT) :: exitflag, Niter
      REAL(8),INTENT(IN)  :: guess_1, guess_2, in_1, in_2
      REAL(8),INTENT(OUT) :: out1_NewRap, out2_NewRap, resnorm
!
! Local variables
      INTEGER              :: n, nx, nf, INFO, MAX_ITER
      INTEGER,POINTER      :: IPIV(:)
      REAL(8) ::   x, TOL_X,  TOL_FUN, ALPHA,  MIN_LAMBDA, MAX_LAMBDA,&
     &          Dx_J, lambda, slope,   fffold, lambda_min, fff,        &
     &          fff2, A_l, lambda2, lambda_OLD, aa, bb, discriminant
      REAL(8), DIMENSION (2,1)  ::  XXX, F, delta, XXX_forw, XXX_back,&
     &       F_forw, F_back, dF, TYPX, dx_star, dx, XXX_old, C_l, aabb
      REAL(8), DIMENSION (1,2)  ::  g
      REAL(8), DIMENSION (2,2)  ::  J, J0, Jstar, AAA, B_l
      !
      ! ------------- INITIALIZATION ----------
      XXX(1,1) = guess_1
      XXX(2,1) = guess_2
      !
      !   Options
      !
      TOL_X      = 1.d-20           ! relative max step tolerance
      TOL_FUN    = 1.d-12           ! function tolerance
      MAX_ITER   = 500             ! max number of iterations
      ALPHA      = 1.d-4            ! criteria for decrease
      MIN_LAMBDA = 0.1d0            ! min lambda
      MAX_LAMBDA = 0.5d0
      TYPX       = abs(XXX)         ! x scaling value, remove zeros
      !
      !
      call F_New_Rap2D (MODE, F, XXX, in_1, in_2)
      !
      ! ---- Jacobian estimation
      !
      Dx_J = 1.d-6         ! finite difference delta
      nx   = 2             ! degrees of freedom
      nf   = 2             ! number of functions
      DO n = 1,nx
         delta(1,1) = 0.d0; delta(2,1)    = 0.d0
         delta(n,1) = delta(n,1) + Dx_J
         XXX_forw   = XXX + delta
         XXX_back   = XXX - delta
         call F_New_Rap2D (MODE, F_forw, XXX_forw, in_1, in_2)
         call F_New_Rap2D (MODE, F_back, XXX_back, in_1, in_2)
         dF      = F_forw - F_back   ! delta F
         J(1, n) = dF(1,1)/Dx_J/2.d0 ! derivatives dF/d_n
         J(2, n) = dF(2,1)/Dx_J/2.d0 ! derivatives dF/d_n
      ENDDO
      J0(1,1) = 1.d0 / TYPX(1,1)  ! Jacobian scaling matrix
      J0(1,2) = 1.d0 / TYPX(2,1)
      J0(2,1) = J0(1,1)
      J0(2,2) = J0(1,2)
      Jstar   = J/J0;             ! scale Jacobian
      !
      resnorm = sqrt(F(1,1)*F(1,1) + F(2,1)*F(2,1))
      exitflag = 1
      !
      !--- SOLVER -------------------
      !
      Niter  = 0     ! start counter
      lambda = 1.d0  ! backtracking
      lambda_OLD = lambda
!
      allocate(IPIV(nf))
!
 1    DO WHILE (((resnorm .GT. TOL_FUN) .OR. (lambda .LT. 1.d0)) &
     &        .AND.  (exitflag >= 0)   .AND. (Niter <= MAX_ITER))
               Niter = Niter + 1
              !
               IF (lambda==1.d0) THEN
              ! Newton-Raphson solver
              ! dx_star  = -Jstar\F      calculate Newton step
                 AAA     = -Jstar
                 dx_star = F
                !call PLU decomposition routine from LAPACK
                 call DGETRF( nf, nf,  AAA,nf, IPIV, INFO)
                 call DGETRS('N', nf,1,AAA,nf, IPIV, dx_star,nf,INFO)
      	         dx      = dx_star*TYPX
                 g       = MATMUL(TRANSPOSE(F),Jstar)
      	         slope   = g(1,1)*dx_star(1,1) + g(1,2)*dx_star(2,1)
      	         fffold  = SUM(F*F)
                 XXX_old = XXX
                 lambda_min = TOL_X/MAXVAL(ABS(dx)/ABS(XXX_old))
               ENDIF
!
!        print*, 'LAMBDA = ', lambda, 'resnorm',resnorm
               IF (lambda < lambda_min) THEN
                  exitflag = -2; ! XXX is too close to XXX_OLD
               !   print*,'XXX is too close to XXX_OLD'
               !ELSEIF any(isnan(dx)) || any(isinf(dx))
               !    exitflag = -1; ! matrix may be singular
               !    STOP
               ENDIF
!
! XXX at new step
!
      	 XXX = XXX_old + dx*lambda
!        print*, 'resnorm',resnorm
!        print*,'dx*lambda= ',dx*lambda
!        print*,'xxx', XXX
!        print*, 'lambda_min', lambda_min
         call F_New_Rap2D (MODE, F, XXX, in_1, in_2)
         !
         ! ---- Jacobian estimation
         !
         DO n = 1,nx
     	  delta(1,1)    = 0.d0; delta(2,1)    = 0.d0
     	  delta(n,1)    = delta(n,1) + Dx_J
     	  XXX_forw   = XXX + delta
     	  XXX_back   = XXX - delta
          call F_New_Rap2D (MODE, F_forw, XXX_forw, in_1, in_2)
          call F_New_Rap2D (MODE, F_back, XXX_back, in_1, in_2)
     	  dF      = F_forw - F_back    ! delta F
     	  J(1, n) = dF(1,1)/Dx_J/2.d0  ! derivatives dF/d_n
     	  J(2, n) = dF(2,1)/Dx_J/2.d0 ! derivatives dF/d_n
      	ENDDO
      	Jstar  = J/J0        ! scale Jacobian
      	fff    = SUM(F*F)    ! f to be minimized
!
! Optimization
!
          IF (fff > fffold + ALPHA*lambda*slope) THEN
              IF (lambda .eq. 1.d0) THEN
                  lambda = -slope/2.d0/(fff-fffold-slope) ! calculate lambda
              ELSE
                  A_l      =  1.d0/(lambda_OLD - lambda2)
                  B_l(1,1) =  1.d0/lambda_OLD**2.d0
                  B_l(1,2) = -1.d0/lambda2**2.d0
                  B_l(2,1) = -lambda2/lambda_OLD**2.d0
                  B_l(2,2) =  lambda_OLD/lambda2**2.d0
       	          C_l(1,1) =  fff-fffold-lambda_OLD*slope
                  C_l(2,1) =  fff2-fffold-lambda2*slope
                  !
      	          aabb = A_l* MATMUL(B_l,C_l)
                  aa   = aabb(1,1)
                  bb   = aabb(2,1)
                 IF (aa == 0.d0) THEN
                      lambda = -slope/2.d0/bb;
                 ELSE
                      discriminant = bb**2.d0 - 3.d0*aa*slope;
                      IF (discriminant < 0.d0) THEN
                          lambda = MAX_LAMBDA*lambda_OLD;
                      ELSEIF (bb <= 0.d0) THEN
                          lambda = (-bb + sqrt(discriminant))/3.d0/aa
                      ELSE
                          lambda = -slope/(bb + sqrt(discriminant))
                      ENDIF
      	   ENDIF
                 lambda = min(lambda,MAX_LAMBDA*lambda_OLD)! minimum step length
              ENDIF
          ELSE
              lambda = 1.d0; ! fraction of Newton step
          ENDIF
          IF (lambda < 1.d0) THEN
              lambda2 = lambda_OLD;
              fff2    = fff;                     ! save 2nd most previous value
              lambda  = max(lambda,MIN_LAMBDA*lambda_OLD) ! minimum step length
              GO TO 1
          ENDIF
      !
      !
          resnorm = sqrt(F(1,1)*F(1,1) + F(2,1)*F(2,1))
      !
      ENDDO
      !
      deallocate(IPIV)
      out1_NewRap = XXX(1,1)
      out2_NewRap = XXX(2,1)
      END SUBROUTINE New_Rap2D
!
!
!
      SUBROUTINE F_New_Rap2D (MODE, F, XXX, in_1, in_2)
      IMPLICIT NONE
      INTEGER,  INTENT(IN) :: MODE
      REAL(8), INTENT(IN) :: in_1, in_2
      REAL(8), DIMENSION (2,1), INTENT(IN)   :: XXX
      REAL(8), DIMENSION (2,1), INTENT(OUT)  :: F
!      REAL(8), DIMENSION (2,1)  :: F_out
      REAL(8) :: F1_MODE, F2_MODE, Helmholtz, T, v, p, e, cv, cp, s, c, &
     &            v_l, p_l, s_l, e_l, g_l, v_v, p_v, s_v, e_v, g_v,&
     &            helmho_v,helmho_l,deriv,dummy1,dummy2,x_out,a_out,entropy,enth
!
      IF     (MODE .EQ. 1) THEN
! Calculation of the saturation specific volumes of vapor
! and liquid phase.
! The saturation specific volume is obtained by imposing:
!  p_l = p_v         pressure equality
!  g_l = g_v         Gibbs free enthalpy equality
!
! That is the Maxwell criterion for saturation.
!
          v_l = XXX(1,1)
          v_v = XXX(2,1)
          T   = in_1
!
          CALL pressure(T,v_l,p_l)
          CALL pressure(T,v_v,p_v)
!
          CALL helmho(T,v_l,helmho_l)
          CALL helmho(T,v_v,helmho_v)
!          g_l    = Helmholtz(v_l,T) + p_l*v_l*1e-3_pr      ! kJ / kg
!          g_v    = Helmholtz(v_v,T) + p_v*v_v*1e-3_pr      ! kJ / kg
!
          g_l    = helmho_l + p_l*v_l      ! J / kg
          g_v    = helmho_v + p_v*v_v
          F(1,1) = (p_l - p_v)*1e-6_pr
          F(2,1) = (g_l - g_v)*1e-3_pr
!
      ELSEIF (MODE .EQ. 2) THEN
! Calculation of temperature and specific volume for imposed pressure p
! and specific internal energy, e.
!
! For this function:
!         in_1     = p
!         in_2     = e
!         XXX(1,1) = T
!         XXX(2,1) = v
!
!
          T   = XXX(1,1)
          v   = XXX(2,1)
          CALL pressure(T,v,p)
          CALL inter_energy(T,v,e)

!print*, 'T',T,'v',v,'p',p,'e',e
          F(1,1) = (in_1 - p)*1d-6         ! Pa
          F(2,1) = (in_2 - e)*1d-3         ! J/kg
!print*, F(1,1),F(2,1)
!print*, in_1,in_2, p,e
!
!
      ELSEIF (MODE .EQ. 3) THEN
! META liquid: dpdv_T  = 0 and e(t,v) = e_in
! For this function:
!         in_1     = e
!         in_2     =
!         XXX(1,1) = T
!         XXX(2,1) = v_l
!
!
          T   = XXX(1,1)
          v_l   = XXX(2,1)
!
        CALL inter_energy(T,v_l,e)
        CALL dpdv_T(T,v_l,deriv)
!
          F(1,1) = deriv * 1e-6_pr
          F(2,1) = (in_1 - e) *1e-3_pr
       ELSEIF (MODE .EQ. 4) THEN
! META liquid: p  = 0 and e(t,v) = e_in
! For this function:
!         in_1     = e
!         in_2     =
!         XXX(1,1) = T
!         XXX(2,1) = v_l
!
!
          T   = XXX(1,1)
          v_l   = XXX(2,1)
!
        CALL inter_energy(T,v_l,e)
        CALL pressure(T,v_l,p)
!
          F(1,1) = p * 1e-6_pr
          F(2,1) = (in_1 - e) *1e-3_pr

!
!
      ELSE
         print*,'MODE of New_Rap2D unknown'
         STOP
      ENDIF
!
      END SUBROUTINE F_New_Rap2D
!

!
!===============================================================================
      SUBROUTINE New_Rap3D(MODE, out1_NewRap, out2_NewRap, out3_NewRap, &
     &           resnorm, Niter, exitflag, in_1,in_2, guess_1, guess_2, guess_3)
!===============================================================================
!
      IMPLICIT NONE
!
! Global variables
      INTEGER, INTENT(IN)  :: MODE
      INTEGER, INTENT(OUT) :: exitflag, Niter
      REAL(pr),INTENT(IN)  :: guess_1, guess_2, guess_3, in_1, in_2!,in_3
      REAL(pr),INTENT(OUT) :: out1_NewRap, out2_NewRap, out3_NewRap, resnorm
!
! Local variables
      INTEGER              :: n, nx, nf, INFO, MAX_ITER
      INTEGER,POINTER      :: IPIV(:)
      REAL(8) ::   x, TOL_X,  TOL_FUN, ALPHA,  MIN_LAMBDA, MAX_LAMBDA,&
     &          Dx_J, lambda, slope,   fffold, lambda_min, fff,        &
     &          fff2, A_l, lambda2, lambda_OLD, aa, bb, discriminant
      REAL(8), DIMENSION (3,1)  ::  XXX, F, delta, XXX_forw, XXX_back,&
     &       F_forw, F_back, dF, TYPX, dx_star, dx, XXX_old, C_l, aabb
      REAL(8), DIMENSION (1,3)  ::  g
      REAL(8), DIMENSION (3,3)  ::  J, J0, Jstar, AAA, B_l
      !
      ! ------------- INITIALIZATION ----------
      XXX(1,1) = guess_1
      XXX(2,1) = guess_2
      XXX(3,1) = guess_3
      !
      !   Options
      !
      TOL_X      = 1.d-20           ! relative max step tolerance
      TOL_FUN    = 1.d-9           ! function tolerance
      MAX_ITER   = 500             ! max number of iterations
      ALPHA      = 1.d-4            ! criteria for decrease
      MIN_LAMBDA = 0.1d0            ! min lambda
      MAX_LAMBDA = 0.5d0
      TYPX       = abs(XXX)         ! x scaling value, remove zeros
      !
      !
      call F_New_Rap3D (MODE, F, XXX, in_1,in_2)
      !
      ! ---- Jacobian estimation
      !
      Dx_J = 1.d-6         ! finite difference delta
      nx   = 3             ! degrees of freedom
      nf   = 3             ! number of functions
      DO n = 1,nx
         delta(1,1) = 0.d0; delta(2,1) = 0.d0; delta(3,1) = 0.d0
         delta(n,1) = delta(n,1) + Dx_J
         XXX_forw   = XXX + delta
         XXX_back   = XXX - delta
         call F_New_Rap3D (MODE, F_forw, XXX_forw, in_1,in_2)
         call F_New_Rap3D (MODE, F_back, XXX_back, in_1,in_2)
         dF      = F_forw - F_back   ! delta F
         J(1, n) = dF(1,1)/Dx_J/2.d0 ! derivatives dF/d_n
         J(2, n) = dF(2,1)/Dx_J/2.d0 ! derivatives dF/d_n
         J(3, n) = dF(3,1)/Dx_J/2.d0 ! derivatives dF/d_n
      ENDDO
      J0(1,1) = 1.d0 / TYPX(1,1)  ! Jacobian scaling matrix
      J0(1,2) = 1.d0 / TYPX(2,1)
      J0(1,3) = 1.d0 / TYPX(3,1)
      J0(2,1) = J0(1,1)
      J0(2,2) = J0(1,2)
      J0(2,3) = J0(1,3)
      J0(3,1) = J0(1,1)
      J0(3,2) = J0(1,2)
      J0(3,3) = J0(1,3)
      Jstar   = J/J0;             ! scale Jacobian
      !
      resnorm = sqrt(F(1,1)*F(1,1) + F(2,1)*F(2,1)+ F(3,1)*F(3,1))
      exitflag = 1
      !
      !--- SOLVER -------------------
      !
      Niter  = 0     ! start counter
      lambda = 1.d0  ! backtracking
      lambda_OLD = lambda
!
      allocate(IPIV(nf))
!
 1    DO WHILE (((resnorm .GT. TOL_FUN) .OR. (lambda .LT. 1.d0)) &
     &        .AND.  (exitflag >= 0)   .AND. (Niter <= MAX_ITER))
               Niter = Niter + 1
              !
               IF (lambda==1.d0) THEN
              ! Newton-Raphson solver
              ! dx_star  = -Jstar\F      calculate Newton step
                 AAA     = -Jstar
                 dx_star = F
                !call PLU decomposition routine from LAPACK
                 call DGETRF( nf, nf,  AAA,nf, IPIV, INFO)
                 call DGETRS('N', nf,1,AAA,nf, IPIV, dx_star,nf,INFO)
      	         dx      = dx_star*TYPX
                 g       = MATMUL(TRANSPOSE(F),Jstar)
      	         slope   = g(1,1)*dx_star(1,1) + g(1,2)*dx_star(2,1) +&
                &          g(1,3)*dx_star(3,1)
      	         fffold  = SUM(F*F)
                 XXX_old = XXX
                 lambda_min = TOL_X/MAXVAL(ABS(dx)/ABS(XXX_old))
               ENDIF
!
!        print*, 'LAMBDA = ', lambda, 'resnorm',resnorm
               IF (lambda < lambda_min) THEN
                  exitflag = -2; ! XXX is too close to XXX_OLD
               !   print*,'XXX is too close to XXX_OLD'
               !ELSEIF any(isnan(dx)) || any(isinf(dx))
               !    exitflag = -1; ! matrix may be singular
               !    STOP
               ENDIF
!
! XXX at new step
!
      	 XXX = XXX_old + dx*lambda
!        print*, 'resnorm',resnorm
!        print*,'dx*lambda= ',dx*lambda
!        print*,'xxx', XXX
!        print*, 'lambda_min', lambda_min
         call F_New_Rap3D (MODE, F, XXX, in_1,in_2)
         !
         ! ---- Jacobian estimation
         !
         DO n = 1,nx
     	  delta(1,1)    = 0.d0; delta(2,1) = 0.d0; delta(3,1)=0.d0
     	  delta(n,1)    = delta(n,1) + Dx_J
     	  XXX_forw   = XXX + delta
     	  XXX_back   = XXX - delta
          call F_New_Rap3D (MODE, F_forw, XXX_forw, in_1,in_2)
          call F_New_Rap3D (MODE, F_back, XXX_back, in_1,in_2)
     	  dF      = F_forw - F_back    ! delta F
     	  J(1, n) = dF(1,1)/Dx_J/2.d0  ! derivatives dF/d_n
     	  J(2, n) = dF(2,1)/Dx_J/2.d0 ! derivatives dF/d_n
     	  J(3, n) = dF(3,1)/Dx_J/2.d0 ! derivatives dF/d_n
      	ENDDO
      	Jstar  = J/J0        ! scale Jacobian
      	fff    = SUM(F*F)    ! f to be minimized
!
! Optimization
!
          IF (fff > fffold + ALPHA*lambda*slope) THEN
              IF (lambda .eq. 1.d0) THEN
                  lambda = -slope/2.d0/(fff-fffold-slope) ! calculate lambda
              ELSE
                  A_l      =  1.d0/(lambda_OLD - lambda2)
                  B_l(1,1) =  1.d0/lambda_OLD**2.d0
                  B_l(1,2) = -1.d0/lambda2**2.d0
                  B_l(2,1) = -lambda2/lambda_OLD**2.d0
                  B_l(2,2) =  lambda_OLD/lambda2**2.d0
       	          C_l(1,1) =  fff-fffold-lambda_OLD*slope
                  C_l(2,1) =  fff2-fffold-lambda2*slope
                  !
      	          aabb = A_l* MATMUL(B_l,C_l)
                  aa   = aabb(1,1)
                  bb   = aabb(2,1)
                 IF (aa == 0.d0) THEN
                      lambda = -slope/2.d0/bb;
                 ELSE
                      discriminant = bb**2.d0 - 3.d0*aa*slope;
                      IF (discriminant < 0.d0) THEN
                          lambda = MAX_LAMBDA*lambda_OLD;
                      ELSEIF (bb <= 0.d0) THEN
                          lambda = (-bb + sqrt(discriminant))/3.d0/aa
                      ELSE
                          lambda = -slope/(bb + sqrt(discriminant))
                      ENDIF
      	   ENDIF
                 lambda = min(lambda,MAX_LAMBDA*lambda_OLD)! minimum step length
              ENDIF
          ELSE
              lambda = 1.d0; ! fraction of Newton step
          ENDIF
          IF (lambda < 1.d0) THEN
              lambda2 = lambda_OLD;
              fff2    = fff;                     ! save 2nd most previous value
              lambda  = max(lambda,MIN_LAMBDA*lambda_OLD) ! minimum step length
              GO TO 1
          ENDIF
      !
      !
          resnorm = sqrt(F(1,1)*F(1,1) + F(2,1)*F(2,1) + F(3,1)*F(3,1))
      !
      ENDDO
      !
      deallocate(IPIV)
      out1_NewRap = XXX(1,1)
      out2_NewRap = XXX(2,1)
      out3_NewRap = XXX(3,1)
      END SUBROUTINE New_Rap3D
!
!
!
      SUBROUTINE F_New_Rap3D (MODE, F, XXX, in_1,in_2)
      IMPLICIT NONE
      INTEGER,  INTENT(IN) :: MODE
      REAL(pr), INTENT(IN) :: in_1, in_2!, in_3
      REAL(pr), DIMENSION (3,1), INTENT(IN)   :: XXX
      REAL(pr), DIMENSION (3,1), INTENT(OUT)  :: F
      REAL(pr), DIMENSION (3,1)  :: F_out
      REAL(pr) :: F1_MODE, F2_MODE, Helmholtz, T, v, p, e, cv, cp, s, c, &
     &            v_l, p_l, s_l, e_l, g_l, v_v, p_v, s_v, e_v, g_v,&
     &            helmho_v,helmho_l,x,y,z,qual
!
      IF (MODE .EQ. 1) THEN
! FOR LL right boundary (liquid saturation line):
!  p_l = p_v         pressure equality
!  g_l = g_v         Gibbs free enthalpy equality
!  el = e            at one interal energy
! That is the Maxwell criterion for saturation.
!
          v_l = XXX(1,1)
          v_v = XXX(2,1)
          T   = XXX(3,1)
          e = in_1
!
          CALL pressure(T,v_l,p_l)
          CALL pressure(T,v_v,p_v)
!
          CALL helmho(T,v_l,helmho_l)
          CALL helmho(T,v_v,helmho_v)
!
          CALL inter_energy(T,v_l,e_l)
!
          g_l    = helmho_l + p_l*v_l      ! J / kg
          g_v    = helmho_v + p_v*v_v
          F(1,1) = (p_l - p_v)*1e-6_pr
          F(2,1) = (g_l - g_v)*1e-3_pr
          F(3,1) = (e_l - e)*1e-3_pr
!cas test for 3D solver
      ELSEIF (MODE .EQ. 2) THEN
          x=  XXX(1,1)
          y=  XXX(2,1)
          z=  XXX(3,1)
!
          F(1,1) = sin(x)
          F(2,1) = cos(y)
          F(3,1) = z*z*z - 6_pr*z*z + 11_pr*z -6
!
!
      ELSEIF (MODE .EQ. 3) THEN
!  FOR TP region
!  p=p_l         pressure equality
!  p =p_v        pressure equality
!  g_l = g_v     Gibbs free enthalpy equality
! That is the Maxwell criterion for saturation.
!
          v_l = XXX(1,1)
          v_v = XXX(2,1)
          T   = XXX(3,1)
          p = in_1
!
          CALL pressure(T,v_l,p_l)
          CALL pressure(T,v_v,p_v)
!
          CALL helmho(T,v_l,helmho_l)
          CALL helmho(T,v_v,helmho_v)
!
!
          g_l    = helmho_l + p_l*v_l      ! J / kg
          g_v    = helmho_v + p_v*v_v
!
          F(1,1) = (p_l - p_v)*1e-6_pr
          F(2,1) = (p_v - p)*1e-6_pr
          F(3,1) = (g_l - g_v)*1e-3_pr
      ELSEIF (MODE .EQ. 4) THEN
!  FOR LH right boundary (vapor saturation line)
!  p_l = p_v         pressure equality
!  g_l = g_v         Gibbs free enthalpy equality
!  ev = e            at one interal energy
! That is the Maxwell criterion for saturation.
!
          v_l = XXX(1,1)
          v_v = XXX(2,1)
          T   = XXX(3,1)
          e = in_1
!
          CALL pressure(T,v_l,p_l)
          CALL pressure(T,v_v,p_v)
!
          CALL helmho(T,v_l,helmho_l)
          CALL helmho(T,v_v,helmho_v)
!
          CALL inter_energy(T,v_v,e_v)
!
          g_l    = helmho_l + p_l*v_l      ! J / kg
          g_v    = helmho_v + p_v*v_v
          F(1,1) = (p_l - p_v)*1e-6_pr
          F(2,1) = (g_l - g_v)*1e-3_pr
          F(3,1) = (e_v - e)*1e-3_pr
!
     ELSEIF (MODE .EQ. 5) THEN
! for a given input couple of values of specific internal energy and
! specific volume, the temperature, vapor specific volume, liquid specific
! volume, are evalued at sauration and the corresponding quality is
! computed. (TP region)
!   (v,e)--> (Vv, Vl, T, x)
!   F1 = pv = pl
!   F2 = gv = gl
!   F3 = e - x*ev - (1-x)*el
!   x = (v-Vl)/(Vv - Vl)
!
          v_l = XXX(1,1)
          v_v = XXX(2,1)
          T   = XXX(3,1)
          e = in_1
          v = in_2
!
          CALL pressure(T,v_l,p_l)
          CALL pressure(T,v_v,p_v)
!
          CALL helmho(T,v_l,helmho_l)
          CALL helmho(T,v_v,helmho_v)
!
          CALL inter_energy(T,v_v,e_v)
          CALL inter_energy(T,v_l,e_l)
!
          qual = (v - v_l)/(v_v-v_l)
          g_l    = helmho_l + p_l*v_l      ! J / kg
          g_v    = helmho_v + p_v*v_v
!
          F(1,1) = (p_l - p_v)*1e-6_pr
          F(2,1) = (g_l - g_v)*1e-3_pr
          F(3,1) = (e - qual*e_v - (1_pr - qual)*e_l)*1e-3_pr
!
      ELSE
         print*,'MODE of New_Rap3D unknown'
         STOP
      ENDIF
    END SUBROUTINE F_New_Rap3D
!
!===============================================================================
          SUBROUTINE New_Rap1D(MODE, out_1, out_2, resnorm, Niter,&
     &                             exitflag, GGG, X0, in_1, out3)
!===============================================================================
!         1D         TWO-PHASE or SINGLE-PHASE
!-------------------------------------------------------------------
!
!  Input :
!  -------
!     MODE        =  it will depend on the used function
!     GGG         =  idem
!     in_1        =  idem
!     in_2        =  idem
!     X0          =  idem
!
!
!  Output :
!  -------
!
!     out_1       =  idem
!     out_2       =  idem
!
!-------------------------------------------------------------------
!                                         M. De Lorenzo      03/2016
!-------------------------------------------------------------------
!
!
      IMPLICIT NONE
!
      INTEGER             ::  MAX_ITER
      INTEGER, INTENT(IN) ::  MODE
      INTEGER, INTENT(OUT) :: exitflag, Niter
      REAL(8), INTENT(IN)   :: GGG, X0, in_1
      REAL(8), INTENT(OUT)  :: out_1, out_2, resnorm, out3
      REAL(8)  ::  TOL_X, TOL_FUN, ALPHA, MIN_LAMBDA, MAX_LAMBDA, Jstar,&
     &  lambda, slope, fffold, lambda_min, fff, fff2, A_l, aa, bb, Dx_J,&
     &  discriminant, lambda2, lambda_OLD, XXX, F, delta, XXX_forw, J0,&
     &  XXX_back, F_forw, F_back, dF, TYPX, dx_star, dx, XXX_old, g, J
      REAL(8), DIMENSION (2,2)  ::  B_l
      REAL(8), DIMENSION (2,1)  ::  C_l, aabb
!
!
      XXX = X0                        ! Initial value
!
!   Options
!
      TOL_X      = 1d-20            ! relative max step tolerance
      TOL_FUN    = 1d-12            ! function tolerance
      MAX_ITER   = 500              ! max number of iterations
      ALPHA      = 1d-4             ! criteria for decrease
      MIN_LAMBDA = 1d-1             ! min lambda
      MAX_LAMBDA = 5d-1
      TYPX       = abs(XXX)           ! x scaling value, remove zeros
!
! ---- Function F definition
!      F       = GGG_input - GGG
!
      call F_New_Rap1D(MODE, F, out_2, XXX, GGG, in_1, out3)
!
!
! --------- Jacobian estimation-----------------
!
      Dx_J       = 1d-6         ! finite difference delta
      delta      = Dx_J
      XXX_forw   = XXX + delta
      XXX_back   = XXX - delta
      call F_New_Rap1D(MODE, F_forw, out_2, XXX_forw, GGG, in_1, out3)
      call F_New_Rap1D(MODE, F_back, out_2, XXX_back, GGG, in_1, out3)
      dF       = F_forw - F_back    ! delta F
      J        = dF/Dx_J/2d0        ! derivatives dF/d_n
      J0       = 1d0 / TYPX         ! Jacobian scaling factor
      Jstar    = J/J0;              ! scale Jacobian
      resnorm  = abs(F)             ! Norm of residues
      exitflag = 1
!
!
!--- SOLVER -------------------
!
      Niter  = 0
      lambda = 1d0                ! backtracking
      lambda_OLD = lambda
!
!
!
1       DO WHILE ( ((resnorm>TOL_FUN) .OR. (lambda<1d0)) .AND. &
     &             (exitflag>=0) .AND. (Niter<=MAX_ITER))
             Niter = Niter + 1
!
!--------- Newton-Raphson solver
!
             IF (lambda .eq. 1.0d0) THEN
               dx_star = -F/Jstar        ! calculate Newton step
               dx      = dx_star*TYPX
               g       = F*Jstar
               slope   = g*dx_star
               fffold  = F*F
               XXX_old = XXX
               lambda_min = TOL_X/(ABS(dx)/ABS(XXX_old))
            ENDIF
!
!--------- Check about proximity of XXX and XXX_OLD
!
             IF (lambda < lambda_min) THEN
                exitflag = 2;
                !print*,'XXX is too close to XXX_OLD'
                !EXIT ! OUT NewRap
             ENDIF
!
!--------- Eventually, backtracking of New-Rap step
!
             XXX = XXX_old + dx*lambda
             call F_New_Rap1D(MODE, F, out_2, XXX, GGG, in_1, out3)
!
!--------- Jacobian estimation
!
             XXX_forw   = XXX + delta
             XXX_back   = XXX - delta
             call F_New_Rap1D(MODE, F_forw, out_2, XXX_forw, GGG, in_1,&
     & out3)
             call F_New_Rap1D(MODE, F_back, out_2, XXX_back, GGG, in_1,&
     & out3)
             dF     = F_forw - F_back    ! delta F
             J      = dF/Dx_J/2d0        ! derivatives dF/d_n
             Jstar  = J/J0               ! scale Jacobian
             fff    = F*F                ! f to be minimized
!
!--------- Optimization technique (minimizing fff = SUM(F*F) )
!
             IF (fff > fffold + ALPHA*lambda*slope) THEN
                 IF (lambda .eq. 1d0) THEN
                     lambda = -slope/2d0/(fff-fffold-slope) ! calculate lambda
                 ELSE
                     A_l      =  1d0/(lambda_OLD - lambda2)
                     B_l(1,1) =  1d0/lambda_OLD/lambda_OLD
                     B_l(1,2) = -1d0/lambda2/lambda2
                     B_l(2,1) = -lambda2/lambda_OLD/lambda_OLD
                     B_l(2,2) =  lambda_OLD/lambda2/lambda2
                     C_l(1,1) =  fff-fffold-lambda_OLD*slope
                     C_l(2,1) =  fff2-fffold-lambda2*slope
                     !
                     aabb = A_l* MATMUL(B_l,C_l)
                     aa   = aabb(1,1)
                     bb   = aabb(2,1)
                     IF (aa .EQ. 0.0d0) THEN
                         lambda = -slope/2d0/bb;
                     ELSE
                         discriminant = bb**2d0 - 3d0*aa*slope;
                         IF (discriminant < 0d0) THEN
                             lambda = MAX_LAMBDA*lambda_OLD;
                         ELSEIF (bb <= 0d0) THEN
                             lambda = (-bb + sqrt(discriminant))/3d0/aa
                         ELSE
                             lambda = -slope/(bb + sqrt(discriminant))
                         ENDIF
                     ENDIF
                 lambda = min(lambda,MAX_LAMBDA*lambda_OLD)     ! minimum step length
                 ENDIF
             ELSE
                 lambda = 1d0; ! fraction of Newton step
             ENDIF
             IF (lambda < 1d0) THEN
                 lambda2 = lambda_OLD;
                 fff2    = fff;       ! save 2nd most previous value
                 lambda  = max(lambda,MIN_LAMBDA*lambda_OLD) ! minimum step length
                 GO TO 1
             ENDIF
!
             resnorm = abs(F)
!
      END DO
!
      out_1 = XXX
!

      END SUBROUTINE New_Rap1D
!
!
!===============================================================================
      SUBROUTINE F_New_Rap1D(MODE, F, out_2, XXX, GGG, in_1, out_3)
!===============================================================================
          IMPLICIT NONE
          INTEGER, INTENT(IN)  :: MODE
          REAL(8), INTENT(IN)  :: in_1, XXX, GGG
          REAL(8), INTENT(OUT) :: F, out_2,out_3
!
!LOCAL
          INTEGER :: i,j
          REAL(8) :: temp, e, v
          REAL(8) :: delta_p,press,e_l,e_v,V_v,V_l,qual

          IF (MODE .EQ. 1) THEN
! (v,e) --> T: v=in_1, e=GGG, T=XXX
                v = in_1
                temp = XXX
!
                CALL inter_energy(temp, v, e)
!
                F = (e - GGG) * 1e-3_pr
                out_2 = 0.0_pr
                out_3 = 0.0_pr
!
!
        ELSEIF (MODE .EQ. 2) THEN
! In two-phase region, (e,v) --> (psat,x,Tsat)
!
        press = XXX
        v = in_1
        e = GGG
        CALL satprop(3, press, temp, v_v, v_l, e_v, e_l)

!        print*, 'iter process',v,v_l, v_v
        out_3 = temp
        qual = (v - v_l)/(v_v-v_l)
        out_2 = qual
        F = (e - qual*e_v - (1_pr - qual)*e_l) * 1e-3_pr
!
!
        ELSEIF (MODE .EQ. 3) THEN
        v     = XXX
        temp  = in_1
        CALL pressure(temp,v,press)
        F = (press - GGG) * 1e-6_pr

        ELSE
                print*,'MODE of New_Rap1D unknown'
                STOP
          ENDIF
!
      END SUBROUTINE F_New_Rap1D

!=======================================================================================
!
SUBROUTINE BrentRoots(MODE, out_1, out_2, residue, Niter, GGG, lower, upper, in_1, in_2)
!
!=======================================================================================
!
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: MODE
      INTEGER, INTENT(OUT) :: Niter
      REAL(8), INTENT(IN)  :: lower, upper, GGG, in_1, in_2
      REAL(8), INTENT(OUT) :: out_1, out_2, residue

      INTEGER              :: done
      REAL(8), PARAMETER   :: FPP      = 1d-16 ! floating-point precision
      REAL(8), PARAMETER   :: MAX_ITER = 2d2   ! maximum allowed number of iterations
      REAL(8), PARAMETER   :: nearzero = 1d-16
      REAL(8) :: TOL, AA, BB, CC, DD, EE, FA, FB, FC, xm, PP, SS, QQ, RR,&
&                Tol1, Root, Minimum

      TOL    = 1d-12
      done   = 0
      Niter  = 0
!
      AA = lower
      BB = upper
      CALL F_Brent(MODE, FA, out_2, AA, GGG, in_1, in_2)
      IF (abs(FA) .LT. TOL) THEN
       out_1 = AA
       RETURN
      ENDIF
!
      CALL F_Brent(MODE, FB, out_2, BB, GGG, in_1, in_2)
      IF (abs(FB) .LT. TOL) THEN
       out_1 = BB
       RETURN
      ENDIF
!
! Check if root is bracketed
      IF (((FA .GT. 0d0) .AND. (FB .GT. 0d0)) .OR. ((FA .LT. 0d0) .AND.&
     & (FB .LT. 0d0))) THEN
       print*, 'ERROR: Root is not bracketed in MODE', MODE
       STOP
      ELSE
       FC = FB
       DO WHILE ((done .EQ. 0) .AND. (Niter .LT. MAX_ITER))
                Niter =  Niter + 1
!
                 IF (((FC .GT. 0d0) .AND. (FB .GT. 0d0)) .OR.&
     &                        ((FC .LT. 0d0) .AND. (FB .LT. 0d0))) THEN
                 ! rename AA, BB, CC and adjust bounding interval DD
                    CC = AA
                    FC = FA
                    DD = BB - AA
                    EE = DD
                 ENDIF
                 IF (abs(FC) .LT. abs(FB)) THEN
                    AA = BB
                    BB = CC
                    CC = AA
                    FA = FB
                    FB = FC
                    FC = FA
                 ENDIF
                 Tol1 = 2d0 * FPP * abs(BB) + 0.5d0 * TOL  ! convergence check
                 xm   = 0.5d0 * (CC - BB)
                 IF((abs(xm) .LE.Tol1) .OR. (abs(FA) .LT.nearzero)) THEN
                 ! a root has been found
                     Root        = BB
                     done        = 1
                     CALL F_Brent(MODE, residue, out_2,BB,GGG,in_1,in_2)
                 ELSE
                     IF ((abs(EE) .GE. Tol1) .AND.&
     &                                 (abs(FA) .GT. abs(FB))) THEN
                         SS = FB / FA  ! attempt inverse quadratic function
                         IF (abs(AA - CC) .LT. nearzero) THEN
                             PP = 2d0 * xm * SS
                             QQ = 1d0 - SS
                         ELSE
                             QQ = FA / FC
                             RR = FB / FC
                             PP = SS * (2d0 * xm * QQ * (QQ - RR) -&
     &                                           (BB- AA) * (RR - 1d0))
                             QQ = (QQ - 1d0) * (RR - 1d0) * (SS - 1d0)
                         ENDIF
                         IF (PP .GT. nearzero) THEN
                             QQ = -QQ
                         ENDIF
                         PP = abs(PP)
                         ! Evaluation of the minimum
                         IF ((3d0 * xm * QQ - abs(Tol1 * QQ)) .LT.&
     &                                             (abs(EE * QQ))) THEN
                            Minimum = 3d0 * xm * QQ - abs(Tol1 * QQ)
                         ELSE
                            Minimum = abs(EE * QQ)
                         ENDIF
!
                         IF ((2d0 * PP) .LT. Minimum) THEN
                         ! accept interpolation
                             EE = DD
                             DD = PP / QQ
                         ELSE
                         ! interpolation failed, use bisection
                             DD = xm
                             EE = DD
                         ENDIF
                     ELSE
                     ! bounds decreasing too slowly, use bisection
                         DD = xm
                         EE = DD
                     ENDIF
                     AA = BB  ! move last best guess to AA
                     FA = FB
                     IF (abs(DD) .GT. Tol1) THEN
                     ! evaluate new trial root
                         BB = BB + DD
                     ELSE
                         IF (xm .GT. 0d0) THEN
                             BB = BB + abs(Tol1)
                         ELSE
                             BB = BB - abs(Tol1)
                         ENDIF
                     ENDIF
                     CALL F_Brent(MODE, FB, out_2, BB, GGG, in_1, in_2)
                     IF (Niter .GT. MAX_ITER) THEN
                        print*, 'Max N iteration exceeded in Brent'
                        STOP
                     ENDIF
                 ENDIF
       END DO
      ENDIF
!
      out_1 = Root
!
END SUBROUTINE BrentRoots
!
!
!===============================================================================
      SUBROUTINE F_Brent(MODE, F, out_2, XXX, GGG, in_1, in_2)
!===============================================================================
          IMPLICIT NONE
          INTEGER, INTENT(IN)  :: MODE
          REAL(8), INTENT(IN)  :: XXX, GGG, in_1, in_2
          REAL(8), INTENT(OUT) :: F, out_2
          REAL(8)              :: temp, v_v, v_l, e_v, e_l,e,press,v,qual

    IF (MODE .EQ. 1) THEN
!
! In two-phase region, (e,v) --> (psat,x,Tsat)
        press = XXX
        v = in_1
        e = GGG
        CALL satprop(3, press, temp, v_v, v_l, e_v, e_l)

!        print*, 'iter process',v,v_l, v_v
        out_2 = temp
        qual = (v - v_l)/(v_v-v_l)
        F = (e - qual*e_v - (1_pr - qual)*e_l) * 1e-3_pr
!
!

    ELSE
             STOP 'MODE of BrentRoots unknown'
    ENDIF
!
     END SUBROUTINE F_Brent
!
!
!
!
!
!
!
END MODULE non_linear_solvers


!***************************************************************************************************
!>
!  Main program for EZ test.

    program main

    use lsqr_kinds
    use lsqr_module,     only: lsqr_solver_ez
    use iso_fortran_env, only: output_unit

    implicit none

    ! define a 3x3 dense system to solve:
    integer,parameter :: m = 3 !! number of rows in `A` matrix
    integer,parameter :: n = 3 !! number of columns in `A` matrix
    real(wp),dimension(m),parameter :: b = real([1,2,3],wp)
    integer,dimension(m*n),parameter :: icol = [1,1,1,2,2,2,3,3,3]
    integer,dimension(m*n),parameter :: irow = [1,2,3,1,2,3,1,2,3]
    real(wp),dimension(m*n),parameter :: a = real([1,4,7,2,5,88,3,66,9],wp)
    real(wp),parameter :: damp = zero
    real(wp),dimension(m),parameter :: b_vec = b
    real(wp),dimension(m,n),parameter :: a_mat = reshape(a,[3,3])

    type(lsqr_solver_ez) :: solver
    real(wp),dimension(n) :: x
    real(wp),dimension(1) :: se !! not used
    real(wp),dimension(n,1) :: x_vec
    integer :: istop

    call solver%initialize(m,n,a,irow,icol,&
                            itnlim = 100,&
                            nout   = output_unit)
    call solver%solve(b,damp,x,istop)

    x_vec(1:3,1) = x

    write(*,*) ''
    write(*,*) 'istop = ', istop
    write(*,*) ''
    write(*,'(1P,A,*(E16.6))') 'x       = ', x
    write(*,'(1P,A,*(E16.6))') 'A*x     = ', matmul(a_mat, x_vec)
    write(*,'(1P,A,*(E16.6))') 'A*x - b = ', matmul(a_mat, x_vec) - reshape(b_vec,(/m,3/))

    end program main
!***************************************************************************************************