! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Linear Algebra Data and Routines File
!
! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : kpp_achem_gas_LinearAlgebra.f90
! Time                 : Thu Jun 11 11:33:46 2015
! Working directory    : /gpfsm/dnb32/adarmeno/models/geos-5/heracles-UNSTABLE-DEV_MICROPHYSICS/src/GEOSgcs_GridComp/GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphV
! Equation file        : kpp_achem_gas.kpp
! Output root filename : kpp_achem_gas
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE kpp_achem_gas_LinearAlgebra

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

  IMPLICIT NONE

CONTAINS

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! SPARSE_UTIL - SPARSE utility functions
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppDecomp( JVS, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse LU factorization
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER  :: IER
      REAL(kind=dp) :: JVS(LU_NONZERO), W(NVAR), a
      INTEGER  :: k, kk, j, jj

      a = 0. ! mz_rs_20050606
      IER = 0
      DO k=1,NVAR
        ! mz_rs_20050606: don't check if real value == 0
        ! IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN
        IF ( ABS(JVS(LU_DIAG(k))) < TINY(a) ) THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              W( LU_ICOL(kk) ) = JVS(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            a = -W(j) / JVS( LU_DIAG(j) )
            W(j) = -a
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVS(kk) = W( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KppDecomp

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppDecompCmplx( JVS, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse LU factorization, complex
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER        :: IER
      DOUBLE COMPLEX :: JVS(LU_NONZERO), W(NVAR), a
      REAL(kind=dp)  :: b = 0.0
      INTEGER        :: k, kk, j, jj

      IER = 0
      DO k=1,NVAR
        IF ( ABS(JVS(LU_DIAG(k))) < TINY(b) ) THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              W( LU_ICOL(kk) ) = JVS(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            a = -W(j) / JVS( LU_DIAG(j) )
            W(j) = -a
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVS(kk) = W( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KppDecompCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppDecompCmplxR( JVSR, JVSI, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Sparse LU factorization, complex
!   (Real and Imaginary parts are used instead of complex data type)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER       :: IER
      REAL(kind=dp) :: JVSR(LU_NONZERO), JVSI(LU_NONZERO)
      REAL(kind=dp) :: WR(NVAR), WI(NVAR), ar, ai, den
      INTEGER       :: k, kk, j, jj

      IER = 0
      ar  = 0.0
      DO k=1,NVAR
        IF (  ( ABS(JVSR(LU_DIAG(k))) < TINY(ar) ) .AND. &
              ( ABS(JVSI(LU_DIAG(k))) < TINY(ar) ) )  THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              WR( LU_ICOL(kk) ) = JVSR(kk)
              WI( LU_ICOL(kk) ) = JVSI(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            den = JVSR(LU_DIAG(j))**2 + JVSI(LU_DIAG(j))**2
            ar = -(WR(j)*JVSR(LU_DIAG(j)) + WI(j)*JVSI(LU_DIAG(j)))/den
            ai = -(WI(j)*JVSR(LU_DIAG(j)) - WR(j)*JVSI(LU_DIAG(j)))/den
            WR(j) = -ar
            WI(j) = -ai
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               WR( LU_ICOL(jj) ) = WR( LU_ICOL(jj) ) + ar*JVSR(jj) - ai*JVSI(jj)
               WI( LU_ICOL(jj) ) = WI( LU_ICOL(jj) ) + ar*JVSI(jj) + ai*JVSR(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVSR(kk) = WR( LU_ICOL(kk) )
            JVSI(kk) = WI( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KppDecompCmplxR

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveIndirect( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse solve subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER  :: i, j
      REAL(kind=dp) :: JVS(LU_NONZERO), X(NVAR), sum

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             X(i) = X(i) - JVS(j)*X(LU_ICOL(j));
         END DO
      END DO

      DO i=NVAR,1,-1
        sum = X(i);
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
          sum = sum - JVS(j)*X(LU_ICOL(j));
        END DO
        X(i) = sum/JVS(LU_DIAG(i));
      END DO

END SUBROUTINE KppSolveIndirect

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveTRIndirect( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve transpose subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER       :: i, j
      REAL(kind=dp) :: JVS(LU_NONZERO), X(NVAR)

      DO i=1,NVAR
        X(i) = X(i)/JVS(LU_DIAG(i))
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

      DO i=NVAR, 1, -1
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_CROW(i),LU_DIAG(i)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

END SUBROUTINE KppSolveTRIndirect

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveCmplx( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER        :: i, j
      DOUBLE COMPLEX :: JVS(LU_NONZERO), X(NVAR), sum

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             X(i) = X(i) - JVS(j)*X(LU_ICOL(j));
         END DO
      END DO

      DO i=NVAR,1,-1
        sum = X(i);
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
          sum = sum - JVS(j)*X(LU_ICOL(j));
        END DO
        X(i) = sum/JVS(LU_DIAG(i));
      END DO

END SUBROUTINE KppSolveCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveCmplxR( JVSR, JVSI, XR, XI )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Complex sparse solve subroutine using indirect addressing
!   (Real and Imaginary parts are used instead of complex data type)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER       ::  i, j
      REAL(kind=dp) ::  JVSR(LU_NONZERO), JVSI(LU_NONZERO), XR(NVAR), XI(NVAR), sumr, sumi, den

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             XR(i) = XR(i) - (JVSR(j)*XR(LU_ICOL(j)) - JVSI(j)*XI(LU_ICOL(j)))
             XI(i) = XI(i) - (JVSR(j)*XI(LU_ICOL(j)) + JVSI(j)*XR(LU_ICOL(j)))
         END DO
      END DO

      DO i=NVAR,1,-1
        sumr = XR(i); sumi = XI(i)
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
            sumr = sumr - (JVSR(j)*XR(LU_ICOL(j)) - JVSI(j)*XI(LU_ICOL(j)))
            sumi = sumi - (JVSR(j)*XI(LU_ICOL(j)) + JVSI(j)*XR(LU_ICOL(j)))
        END DO
        den   = JVSR(LU_DIAG(i))**2 + JVSI(LU_DIAG(i))**2
        XR(i) = (sumr*JVSR(LU_DIAG(i)) + sumi*JVSI(LU_DIAG(i)))/den
        XI(i) = (sumi*JVSR(LU_DIAG(i)) - sumr*JVSI(LU_DIAG(i)))/den
      END DO

END SUBROUTINE KppSolveCmplxR

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveTRCmplx( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve transpose subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER        :: i, j
      DOUBLE COMPLEX :: JVS(LU_NONZERO), X(NVAR)

      DO i=1,NVAR
        X(i) = X(i)/JVS(LU_DIAG(i))
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

      DO i=NVAR, 1, -1
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_CROW(i),LU_DIAG(i)-1
	  X(LU_ICOL(j)) = X(LU_ICOL(j))-JVS(j)*X(i)
	END DO
      END DO

END SUBROUTINE KppSolveTRCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KppSolveTRCmplxR( JVSR, JVSI, XR, XI )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Complex sparse solve transpose subroutine using indirect addressing
!   (Real and Imaginary parts are used instead of complex data type)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_JacobianSP

      INTEGER       ::  i, j
      REAL(kind=dp) ::  JVSR(LU_NONZERO), JVSI(LU_NONZERO), XR(NVAR), XI(NVAR), den

      DO i=1,NVAR
        den   = JVSR(LU_DIAG(i))**2 + JVSI(LU_DIAG(i))**2
        XR(i) = (XR(i)*JVSR(LU_DIAG(i)) + XI(i)*JVSI(LU_DIAG(i)))/den
        XI(i) = (XI(i)*JVSR(LU_DIAG(i)) - XR(i)*JVSI(LU_DIAG(i)))/den
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
	  XR(LU_ICOL(j)) = XR(LU_ICOL(j))-(JVSR(j)*XR(i) - JVSI(j)*XI(i))
	  XI(LU_ICOL(j)) = XI(LU_ICOL(j))-(JVSI(j)*XR(i) + JVSR(j)*XI(i))
	END DO
      END DO

      DO i=NVAR, 1, -1
	! subtract all nonzero elements in row i of JVS from X
        DO j=LU_CROW(i),LU_DIAG(i)-1
	  XR(LU_ICOL(j)) = XR(LU_ICOL(j))-(JVSR(j)*XR(i) - JVSI(j)*XI(i))
	  XI(LU_ICOL(j)) = XI(LU_ICOL(j))-(JVSI(j)*XR(i) + JVSR(j)*XI(i))
	END DO
      END DO

END SUBROUTINE KppSolveTRCmplxR

!
! Next few commented subroutines perform sparse big linear algebra
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE KppDecompBig( JVS, IP, IER )
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!        Sparse LU factorization
!!        for the Runge Kutta (3n)x(3n) linear system
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  USE kpp_achem_gas_Parameters
!  USE kpp_achem_gas_JacobianSP
!
!      INTEGER  :: IP3(3), IER, IP(3,NVAR)
!      REAL(kind=dp) :: JVS(3,3,LU_NONZERO), W(3,3,NVAR), a(3,3), E(3,3)
!      INTEGER  :: k, kk, j, jj
!
!      a = 0.0d0
!      IER = 0
!      DO k=1,NVAR
!        DO kk = LU_CROW(k), LU_CROW(k+1)-1
!              W( 1:3,1:3,LU_ICOL(kk) ) = JVS(1:3,1:3,kk)
!        END DO
!        DO kk = LU_CROW(k), LU_DIAG(k)-1
!            j = LU_ICOL(kk)
!            E(1:3,1:3) = JVS( 1:3,1:3,LU_DIAG(j) )
!            ! CALL DGETRF(3,3,E,3,IP3,IER)
!            CALL FAC3(E,IP3,IER)
!            IF ( IER /= 0 )  RETURN
!            ! a = W(j) / JVS( LU_DIAG(j) )
!            a(1:3,1:3) = W( 1:3,1:3,j )
!            ! CALL DGETRS ('N',3,3,E,3,IP3,a,3,IER)
!            CALL SOL3('N',E,IP3,a(1,1))
!            CALL SOL3('N',E,IP3,a(1,2))
!            CALL SOL3('N',E,IP3,a(1,3))
!            W(1:3,1:3,j) = a(1:3,1:3)
!            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
!               W( 1:3,1:3,LU_ICOL(jj) ) = W( 1:3,1:3,LU_ICOL(jj) ) &
!                        - MATMUL( a(1:3,1:3) , JVS(1:3,1:3,jj) )
!            END DO
!         END DO
!         DO kk = LU_CROW(k), LU_CROW(k+1)-1
!            JVS(1:3,1:3,kk) = W( 1:3,1:3,LU_ICOL(kk) )
!         END DO
!      END DO
!
!      DO k=1,NVAR
!         ! CALL WGEFA(JVS(1,1,LU_DIAG(k)),3,3,IP(1,k),IER)
!         ! CALL DGETRF(3,3,JVS(1,1,LU_DIAG(k)),3,IP(1,k),IER)
!         CALL FAC3(JVS(1,1,LU_DIAG(k)),IP(1,k),IER)
!         IF ( IER /= 0 )  RETURN
!      END DO
!
!END SUBROUTINE KppDecompBig
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE KppSolveBig( JVS, IP, X )
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!        Sparse solve subroutine using indirect addressing
!!        for the Runge Kutta (3n)x(3n) linear system
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  USE kpp_achem_gas_Parameters
!  USE kpp_achem_gas_JacobianSP
!
!      INTEGER  :: i, j, k, m, IP3(3), IP(3,NVAR), IER
!      REAL(kind=dp) :: JVS(3,3,LU_NONZERO), X(3,NVAR), sum(3)
!
!      DO i=1,NVAR
!        DO j = LU_CROW(i), LU_DIAG(i)-1
!          !X(1:3,i) = X(1:3,i) - MATMUL(JVS(1:3,1:3,j),X(1:3,LU_ICOL(j)));
!          DO k=1,3
!            DO m=1,3
!	       X(k,i) = X(k,i) - JVS(k,m,j)*X(m,LU_ICOL(j))
!            END DO
!          END DO
!        END DO
!      END DO
!
!      DO i=NVAR,1,-1
!        sum(1:3) = X(1:3,i);
!        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
!          !sum(1:3) = sum(1:3) - MATMUL(JVS(1:3,1:3,j),X(1:3,LU_ICOL(j)));
!          DO k=1,3
!            DO m=1,3
!	       sum(k) = sum(k) - JVS(k,m,j)*X(m,LU_ICOL(j))
!            END DO
!          END DO
!        END DO
!        ! X(i) = sum/JVS(LU_DIAG(i));
!        ! CALL DGETRS ('N',3,1,JVS(1:3,1:3,LU_DIAG(i)),3,IP(1,i),sum,3,0)
!        ! CALL WGESL('N',JVS(1,1,LU_DIAG(i)),3,3,IP(1,i),sum)
!        CALL SOL3('N',JVS(1,1,LU_DIAG(i)),IP(1,i),sum)
!        X(1:3,i) = sum(1:3)
!      END DO
!
!END SUBROUTINE KppSolveBig
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE KppSolveBigTR( JVS, IP, X )
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!        Big sparse transpose solve using indirect addressing
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  USE kpp_achem_gas_Parameters
!  USE kpp_achem_gas_JacobianSP
!
!      INTEGER       :: i, j, k, m, IP(3,NVAR)
!      REAL(kind=dp) :: JVS(3,3,LU_NONZERO), X(3,NVAR)
!
!      DO i=1,NVAR
!        ! X(i) = X(i)/JVS(LU_DIAG(i))
!        CALL SOL3('T',JVS(1,1,LU_DIAG(i)),IP(1,i),X(1,i))
!        DO j=LU_DIAG(i)+1,LU_CROW(i+1)-1
!	  !X(1:3,LU_ICOL(j)) = X(1:3,LU_ICOL(j)) &
!          !    - MATMUL( TRANSPOSE(JVS(1:3,1:3,j)), X(1:3,i) )
!          DO k=1,3
!            DO m=1,3
!	       X(k,LU_ICOL(j)) = X(k,LU_ICOL(j)) - JVS(m,k,j)*X(m,i)
!            END DO
!          END DO
!	END DO
!      END DO
!
!      DO i=NVAR, 1, -1
!        DO j=LU_CROW(i),LU_DIAG(i)-1
!	  !X(1:3,LU_ICOL(j)) = X(1:3,LU_ICOL(j)) &
!          !   - MATMUL( TRANSPOSE(JVS(1:3,1:3,j)), X(1:3,i) )
!          DO k=1,3
!            DO m=1,3
!	       X(k,LU_ICOL(j)) = X(k,LU_ICOL(j)) - JVS(m,k,j)*X(m,i)
!            END DO
!          END DO
!	END DO
!      END DO
!
!END SUBROUTINE KppSolveBigTR
!
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE FAC3(A,IPVT,INFO)
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!     FAC3 FACTORS THE MATRIX A (3,3) BY
!!           GAUSS ELIMINATION WITH PARTIAL PIVOTING
!!     LINPACK - LIKE
!!
!!     Remove comments to perform pivoting
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!
!      REAL(kind=dp) :: A(3,3)
!      INTEGER       :: IPVT(3),INFO
!!      INTEGER       :: L
!!      REAL(kind=dp) :: t, dmax, da, TMP(3)
!      REAL(kind=dp), PARAMETER :: ZERO = 0.0, ONE = 1.0
!
!      info = 0
!!      t = TINY(da)
!!
!!      da = ABS(A(1,1)); L = 1
!!      IF ( ABS(A(2,1))>da ) THEN
!!        da = ABS(A(2,1)); L = 2
!!        IF ( ABS(A(3,1))>da ) THEN
!!          L = 3
!!        END IF
!!      END IF
!!      IPVT(1)  = L
!!      IF (L /=1 ) THEN
!!         TMP(1:3) = A(L,1:3)
!!         A(L,1:3) = A(1,1:3)
!!         A(1,1:3) = TMP(1:3)
!!      END IF
!!      IF (ABS(A(1,1)) < t) THEN
!!         info = 1
!!         return
!!      END IF
!!
!      A(2,1) = A(2,1)/A(1,1)
!      A(2,2) = A(2,2) - A(2,1)*A(1,2)
!      A(2,3) = A(2,3) - A(2,1)*A(1,3)
!      A(3,1) = A(3,1)/A(1,1)
!      A(3,2) = A(3,2) - A(3,1)*A(1,2)
!      A(3,3) = A(3,3) - A(3,1)*A(1,3)
!
!!      IPVT(2)  = 2
!!      IF (ABS(A(3,2))>ABS(A(2,2))) THEN
!!         IPVT(2)  = 3
!!         TMP(2:3) = A(3,2:3)
!!         A(3,2:3) = A(2,2:3)
!!         A(2,2:3) = TMP(2:3)
!!      END IF
!!      IF (ABS(A(2,2)) < t) THEN
!!         info = 1
!!         return
!!      END IF
!!
!      A(3,2)   = A(3,2)/A(2,2)
!      A(3,3)   = A(3,3) - A(3,2)*A(2,3)
!      IPVT(3)  = 3
!
!END SUBROUTINE FAC3
!
!
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!SUBROUTINE SOL3(Trans,A,IPVT,b)
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!!     SOL3 solves the system 3x3
!!     A * x = b  or  trans(a) * x = b
!!     using the factors computed by WGEFA.
!!
!!     Trans      = 'N'   to solve  A*x = b ,
!!                = 'T'   to solve  transpose(A)*x = b
!!     LINPACK - LIKE
!!
!!     Remove comments to use pivoting
!! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!      CHARACTER     :: Trans
!      REAL(kind=dp) :: a(3,3),b(3)
!      INTEGER       :: IPVT(3)
!!      INTEGER       :: L
!!      REAL(kind=dp) :: TMP
!
!      SELECT CASE (Trans)
!
!      CASE ('n','N')  !  Solve  A * x = b
!
!!     Solve  L*y = b
!!         L = IPVT(1)
!!         IF (L /= 1) THEN
!!            TMP = B(1); B(1) = B(L); B(L) = TMP
!!         END IF
!         b(2) = b(2)-A(2,1)*b(1)
!         b(3) = b(3)-A(3,1)*b(1)
!
!!         L = IPVT(2)
!!         IF (L /= 2) THEN
!!            TMP = B(2); B(2) = B(L); B(L) = TMP
!!         END IF
!         b(3) = b(3)-A(3,2)*b(2)
!
!!     Solve  U*x = y
!         b(3) = b(3)/A(3,3)
!         b(2) = (b(2)-A(2,3)*b(3))/A(2,2)
!         b(1) = (b(1)-A(1,3)*b(3)-A(1,2)*b(2))/A(1,1)
!
!
!      CASE ('t','T')  !  Solve transpose(A) * x = b
!
!!      Solve transpose(U)*y = b
!         b(1) = b(1)/A(1,1)
!         b(2) = (b(2)-A(1,2)*b(1))/A(2,2)
!         b(3) = (b(3)-A(1,3)*b(1)-A(2,3)*b(2))/A(3,3)
!
!!      Solve transpose(L)*x = y
!         b(2) = b(2)-A(3,2)*b(3)
!!         L = ipvt(2)
!!         IF (L /= 2) THEN
!!            TMP = B(2); B(2) = B(L); B(L) = TMP
!!         END IF
!         b(1) = b(1)-A(3,1)*b(3)-A(2,1)*b(2)
!!         L = ipvt(1)
!!         IF (L /= 1) THEN
!!            TMP = B(1); B(1) = B(L); B(L) = TMP
!!         END IF
!
!      END SELECT
!
!END SUBROUTINE SOL3

! End of SPARSE_UTIL function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! KppSolve - sparse back substitution
!   Arguments :
!      JVS       - sparse Jacobian of variables
!      X         - Vector for variables
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE KppSolve ( JVS, X )

! JVS - sparse Jacobian of variables
  REAL(kind=dp) :: JVS(LU_NONZERO)
! X - Vector for variables
  REAL(kind=dp) :: X(NVAR)

  X(2) = X(2)-JVS(2)*X(1)
  X(4) = X(4)-JVS(5)*X(1)
  X(5) = X(5)-JVS(7)*X(2)
  X(5) = X(5)/JVS(8)
  X(4) = X(4)/JVS(6)
  X(3) = X(3)/JVS(4)
  X(2) = X(2)/JVS(3)
  X(1) = X(1)/JVS(1)

END SUBROUTINE KppSolve

! End of KppSolve function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! KppSolveTR - sparse, transposed back substitution
!   Arguments :
!      JVS       - sparse Jacobian of variables
!      X         - Vector for variables
!      XX        - Vector for output variables
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE KppSolveTR ( JVS, X, XX )

! JVS - sparse Jacobian of variables
  REAL(kind=dp) :: JVS(LU_NONZERO)
! X - Vector for variables
  REAL(kind=dp) :: X(NVAR)
! XX - Vector for output variables
  REAL(kind=dp) :: XX(NVAR)

  XX(1) = X(1)/JVS(1)
  XX(2) = X(2)/JVS(3)
  XX(3) = X(3)/JVS(4)
  XX(4) = X(4)/JVS(6)
  XX(5) = X(5)/JVS(8)
  XX(5) = XX(5)
  XX(4) = XX(4)
  XX(3) = XX(3)
  XX(2) = XX(2)-JVS(7)*XX(5)
  XX(1) = XX(1)-JVS(2)*XX(2)-JVS(5)*XX(4)

END SUBROUTINE KppSolveTR

! End of KppSolveTR function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! BLAS_UTIL - BLAS-LIKE utility functions
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!--------------------------------------------------------------
!
! BLAS/LAPACK-like subroutines used by the integration algorithms
! It is recommended to replace them by calls to the optimized
!      BLAS/LAPACK library for your machine
!
!  (C) Adrian Sandu, Aug. 2004
!      Virginia Polytechnic Institute and State University
!--------------------------------------------------------------

!--------------------------------------------------------------
      SUBROUTINE WCOPY(N,X,incX,Y,incY)
!--------------------------------------------------------------
!     copies a vector, x, to a vector, y:  y <- x
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL  SCOPY(N,X,1,Y,1)   or   CALL  DCOPY(N,X,1,Y,1)
!--------------------------------------------------------------
!     USE kpp_achem_gas_Precision

      INTEGER  :: i,incX,incY,M,MP1,N
      REAL(kind=dp) :: X(N),Y(N)

      IF (N.LE.0) RETURN

      M = MOD(N,8)
      IF( M .NE. 0 ) THEN
        DO i = 1,M
          Y(i) = X(i)
        END DO
        IF( N .LT. 8 ) RETURN
      END IF
      MP1 = M+1
      DO i = MP1,N,8
        Y(i) = X(i)
        Y(i + 1) = X(i + 1)
        Y(i + 2) = X(i + 2)
        Y(i + 3) = X(i + 3)
        Y(i + 4) = X(i + 4)
        Y(i + 5) = X(i + 5)
        Y(i + 6) = X(i + 6)
        Y(i + 7) = X(i + 7)
      END DO

      END SUBROUTINE WCOPY

!--------------------------------------------------------------
      SUBROUTINE WAXPY(N,Alpha,X,incX,Y,incY)
!--------------------------------------------------------------
!     constant times a vector plus a vector: y <- y + Alpha*x
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL SAXPY(N,Alpha,X,1,Y,1) or  CALL DAXPY(N,Alpha,X,1,Y,1)
!--------------------------------------------------------------

      INTEGER  :: i,incX,incY,M,MP1,N
      REAL(kind=dp) :: X(N),Y(N),Alpha
      REAL(kind=dp), PARAMETER :: ZERO = 0.0_dp

      IF (Alpha .EQ. ZERO) RETURN
      IF (N .LE. 0) RETURN

      M = MOD(N,4)
      IF( M .NE. 0 ) THEN
        DO i = 1,M
          Y(i) = Y(i) + Alpha*X(i)
        END DO
        IF( N .LT. 4 ) RETURN
      END IF
      MP1 = M + 1
      DO i = MP1,N,4
        Y(i) = Y(i) + Alpha*X(i)
        Y(i + 1) = Y(i + 1) + Alpha*X(i + 1)
        Y(i + 2) = Y(i + 2) + Alpha*X(i + 2)
        Y(i + 3) = Y(i + 3) + Alpha*X(i + 3)
      END DO

      END SUBROUTINE WAXPY

!--------------------------------------------------------------
      SUBROUTINE WSCAL(N,Alpha,X,incX)
!--------------------------------------------------------------
!     constant times a vector: x(1:N) <- Alpha*x(1:N)
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL SSCAL(N,Alpha,X,1) or  CALL DSCAL(N,Alpha,X,1)
!--------------------------------------------------------------

      INTEGER  :: i,incX,M,MP1,N
      REAL(kind=dp)  :: X(N),Alpha
      REAL(kind=dp), PARAMETER  :: ZERO=0.0_dp, ONE=1.0_dp

      IF (Alpha .EQ. ONE) RETURN
      IF (N .LE. 0) RETURN

      M = MOD(N,5)
      IF( M .NE. 0 ) THEN
        IF (Alpha .EQ. (-ONE)) THEN
          DO i = 1,M
            X(i) = -X(i)
          END DO
        ELSEIF (Alpha .EQ. ZERO) THEN
          DO i = 1,M
            X(i) = ZERO
          END DO
        ELSE
          DO i = 1,M
            X(i) = Alpha*X(i)
          END DO
        END IF
        IF( N .LT. 5 ) RETURN
      END IF
      MP1 = M + 1
      IF (Alpha .EQ. (-ONE)) THEN
        DO i = MP1,N,5
          X(i)     = -X(i)
          X(i + 1) = -X(i + 1)
          X(i + 2) = -X(i + 2)
          X(i + 3) = -X(i + 3)
          X(i + 4) = -X(i + 4)
        END DO
      ELSEIF (Alpha .EQ. ZERO) THEN
        DO i = MP1,N,5
          X(i)     = ZERO
          X(i + 1) = ZERO
          X(i + 2) = ZERO
          X(i + 3) = ZERO
          X(i + 4) = ZERO
        END DO
      ELSE
        DO i = MP1,N,5
          X(i)     = Alpha*X(i)
          X(i + 1) = Alpha*X(i + 1)
          X(i + 2) = Alpha*X(i + 2)
          X(i + 3) = Alpha*X(i + 3)
          X(i + 4) = Alpha*X(i + 4)
        END DO
      END IF

      END SUBROUTINE WSCAL

!--------------------------------------------------------------
      REAL(kind=dp) FUNCTION WLAMCH( C )
!--------------------------------------------------------------
!     returns epsilon machine
!     after LAPACK
!     replace this by the function from the optimized LAPACK implementation:
!          CALL SLAMCH('E') or CALL DLAMCH('E')
!--------------------------------------------------------------
!      USE kpp_achem_gas_Precision

      CHARACTER ::  C
      INTEGER    :: i
      REAL(kind=dp), SAVE  ::  Eps
      REAL(kind=dp)  ::  Suma
      REAL(kind=dp), PARAMETER  ::  ONE=1.0_dp, HALF=0.5_dp
      LOGICAL, SAVE   ::  First=.TRUE.

      IF (First) THEN
        First = .FALSE.
        Eps = HALF**(16)
        DO i = 17, 80
          Eps = Eps*HALF
          CALL WLAMCH_ADD(ONE,Eps,Suma)
          IF (Suma.LE.ONE) GOTO 10
        END DO
        PRINT*,'ERROR IN WLAMCH. EPS < ',Eps
        RETURN
10      Eps = Eps*2
        i = i-1
      END IF

      WLAMCH = Eps

      END FUNCTION WLAMCH

      SUBROUTINE WLAMCH_ADD( A, B, Suma )
!      USE kpp_achem_gas_Precision

      REAL(kind=dp) A, B, Suma
      Suma = A + B

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

!--------------------------------------------------------------
      SUBROUTINE SET2ZERO(N,Y)
!--------------------------------------------------------------
!     copies zeros into the vector y:  y <- 0
!     after BLAS
!--------------------------------------------------------------

      INTEGER ::  i,M,MP1,N
      REAL(kind=dp) ::  Y(N)
      REAL(kind=dp), PARAMETER :: ZERO = 0.0d0

      IF (N.LE.0) RETURN

      M = MOD(N,8)
      IF( M .NE. 0 ) THEN
        DO i = 1,M
          Y(i) = ZERO
        END DO
        IF( N .LT. 8 ) RETURN
      END IF
      MP1 = M+1
      DO i = MP1,N,8
        Y(i)     = ZERO
        Y(i + 1) = ZERO
        Y(i + 2) = ZERO
        Y(i + 3) = ZERO
        Y(i + 4) = ZERO
        Y(i + 5) = ZERO
        Y(i + 6) = ZERO
        Y(i + 7) = ZERO
      END DO

      END SUBROUTINE SET2ZERO

!--------------------------------------------------------------
      REAL(kind=dp) FUNCTION WDOT (N, DX, incX, DY, incY)
!--------------------------------------------------------------
!     dot produce: wdot = x(1:N)*y(1:N)
!     only for incX=incY=1
!     after BLAS
!     replace this by the function from the optimized BLAS implementation:
!         CALL SDOT(N,X,1,Y,1) or  CALL DDOT(N,X,1,Y,1)
!--------------------------------------------------------------
!      USE messy_mecca_kpp_Precision
!--------------------------------------------------------------
      IMPLICIT NONE
      INTEGER :: N, incX, incY
      REAL(kind=dp) :: DX(N), DY(N)

      INTEGER :: i, IX, IY, M, MP1, NS

      WDOT = 0.0D0
      IF (N .LE. 0) RETURN
      IF (incX .EQ. incY) IF (incX-1) 5,20,60
!
!     Code for unequal or nonpositive increments.
!
    5 IX = 1
      IY = 1
      IF (incX .LT. 0) IX = (-N+1)*incX + 1
      IF (incY .LT. 0) IY = (-N+1)*incY + 1
      DO i = 1,N
        WDOT = WDOT + DX(IX)*DY(IY)
        IX = IX + incX
        IY = IY + incY
      END DO
      RETURN
!
!     Code for both increments equal to 1.
!
!     Clean-up loop so remaining vector length is a multiple of 5.
!
   20 M = MOD(N,5)
      IF (M .EQ. 0) GO TO 40
      DO i = 1,M
         WDOT = WDOT + DX(i)*DY(i)
      END DO
      IF (N .LT. 5) RETURN
   40 MP1 = M + 1
      DO i = MP1,N,5
          WDOT = WDOT + DX(i)*DY(i) + DX(i+1)*DY(i+1) + DX(i+2)*DY(i+2) +  &
                   DX(i+3)*DY(i+3) + DX(i+4)*DY(i+4)
      END DO
      RETURN
!
!     Code for equal, positive, non-unit increments.
!
   60 NS = N*incX
      DO i = 1,NS,incX
        WDOT = WDOT + DX(i)*DY(i)
      END DO

      END FUNCTION WDOT

!--------------------------------------------------------------
      SUBROUTINE WADD(N,X,Y,Z)
!--------------------------------------------------------------
!     adds two vectors: z <- x + y
!     BLAS - like
!--------------------------------------------------------------
!     USE kpp_achem_gas_Precision

      INTEGER :: i, M, MP1, N
      REAL(kind=dp) :: X(N),Y(N),Z(N)

      IF (N.LE.0) RETURN

      M = MOD(N,5)
      IF( M /= 0 ) THEN
         DO i = 1,M
            Z(i) = X(i) + Y(i)
         END DO
         IF( N < 5 ) RETURN
      END IF
      MP1 = M+1
      DO i = MP1,N,5
         Z(i)     = X(i)     + Y(i)
         Z(i + 1) = X(i + 1) + Y(i + 1)
         Z(i + 2) = X(i + 2) + Y(i + 2)
         Z(i + 3) = X(i + 3) + Y(i + 3)
         Z(i + 4) = X(i + 4) + Y(i + 4)
      END DO

      END SUBROUTINE WADD

!--------------------------------------------------------------
      SUBROUTINE WGEFA(N,A,Ipvt,info)
!--------------------------------------------------------------
!     WGEFA FACTORS THE MATRIX A (N,N) BY
!           GAUSS ELIMINATION WITH PARTIAL PIVOTING
!     LINPACK - LIKE
!--------------------------------------------------------------
!
      INTEGER       :: N,Ipvt(N),info
      REAL(kind=dp) :: A(N,N)
      REAL(kind=dp) :: t, dmax, da
      INTEGER       :: j,k,l
      REAL(kind=dp), PARAMETER :: ZERO = 0.0, ONE = 1.0

      info = 0

size: IF (n > 1) THEN

col:  DO k = 1, n-1

!        find l = pivot index
!        l = idamax(n-k+1,A(k,k),1) + k - 1
         l = k; dmax = abs(A(k,k))
         DO j = k+1,n
            da = ABS(A(j,k))
            IF (da > dmax) THEN
              l = j; dmax = da
            END IF
         END DO
         Ipvt(k) = l

!        zero pivot implies this column already triangularized
         IF (ABS(A(l,k)) < TINY(ZERO)) THEN
            info = k
            return
         ELSE
            IF (l /= k) THEN
               t = A(l,k); A(l,k) = A(k,k); A(k,k) = t
            END IF
            t = -ONE/A(k,k)
            CALL WSCAL(n-k,t,A(k+1,k),1)
            DO j = k+1, n
               t = A(l,j)
               IF (l /= k) THEN
                  A(l,j) = A(k,j); A(k,j) = t
               END IF
               CALL WAXPY(n-k,t,A(k+1,k),1,A(k+1,j),1)
            END DO
         END IF

       END DO col

      END IF size

      Ipvt(N) = N
      IF (ABS(A(N,N)) == ZERO) info = N

      END SUBROUTINE WGEFA

!--------------------------------------------------------------
      SUBROUTINE WGESL(Trans,N,A,Ipvt,b)
!--------------------------------------------------------------
!     WGESL solves the system
!     a * x = b  or  trans(a) * x = b
!     using the factors computed by WGEFA.
!
!     Trans      = 'N'   to solve  A*x = b ,
!                = 'T'   to solve  transpose(A)*x = b
!     LINPACK - LIKE
!--------------------------------------------------------------

      INTEGER       :: N,Ipvt(N)
      CHARACTER     :: trans
      REAL(kind=dp) :: A(N,N),b(N)
      REAL(kind=dp) :: t
      INTEGER       :: k,kb,l

      SELECT CASE (Trans)

      CASE ('n','N')  !  Solve  A * x = b

!        first solve  L*y = b
         IF (n >= 2) THEN
          DO k = 1, n-1
            l = Ipvt(k)
            t = b(l)
            IF (l /= k) THEN
               b(l) = b(k)
               b(k) = t
            END IF
            CALL WAXPY(n-k,t,a(k+1,k),1,b(k+1),1)
          END DO
         END IF
!        now solve  U*x = y
         DO kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            CALL WAXPY(k-1,t,a(1,k),1,b(1),1)
         END DO

      CASE ('t','T')  !  Solve transpose(A) * x = b

!        first solve  trans(U)*y = b
         DO k = 1, n
            t = WDOT(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
         END DO
!        now solve trans(L)*x = y
         IF (n >= 2) THEN
         DO kb = 1, n-1
            k = n - kb
            b(k) = b(k) + WDOT(n-k,a(k+1,k),1,b(k+1),1)
            l = Ipvt(k)
            IF (l /= k) THEN
               t = b(l); b(l) = b(k); b(k) = t
            END IF
         END DO
         END IF

      END SELECT

      END SUBROUTINE WGESL
! End of BLAS_UTIL function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE kpp_achem_gas_LinearAlgebra


subroutine protke(j         ,nmmaxj    ,nmmax     ,icx       ,icy       , &
                & kfs       ,kfu       ,kfv       ,kcs       ,umnflc    , &
                & vmnflc    ,guu       ,gvv       ,wrk1      ,wrk2      , &
                & ptke      ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: protke.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute/protke.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Determines horizontal production term for
!              TKE according to document "first2d.doc"
!              (R.E. Uittenboogaard 24-12-99)
!              NOTE: boundary assumption: protke = 0.
!                    Latest change to allow HLES in DD
! Method used:
!     Comment:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
!
! Global variables
!
    integer, intent(in)                                       :: icx    !! Increment in the X-dir., if ICX= NMAX
                                                                        !! then computation proceeds in the X-
                                                                        !! dir. If icx=1 then computation pro-
                                                                        !! ceeds in the Y-dir.
    integer, intent(in)                                       :: icy
                                                                        !! Increment in the Y-dir. (see ICX)
    integer                                                   :: j      !! Begin pointer for arrays which have
                                                                        !! been transformed into 1D arrays.
                                                                        !! Due to the shift in the 2nd (M-)
                                                                        !! index, J = -2*NMAX + 1
    integer                                     , intent(in)  :: nmmax  ! Description and declaration in dimens.igs
    integer                                                   :: nmmaxj ! Description and declaration in dimens.igs
    integer  , dimension(gdp%d%nmlb:gdp%d%nmub)               :: kcs    ! Description and declaration in esm_alloc_int.f90
    integer  , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: kfs    ! Description and declaration in esm_alloc_int.f90
    integer  , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: kfu    ! Description and declaration in esm_alloc_int.f90
    integer  , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: kfv    ! Description and declaration in esm_alloc_int.f90
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: guu    ! Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: gvv    ! Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(out) :: ptke   !! TKE production due to velocity fluctuation
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: umnflc ! Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub) , intent(in)  :: vmnflc ! Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub)               :: wrk1
    real(fp) , dimension(gdp%d%nmlb:gdp%d%nmub)               :: wrk2
!
!
! Local variables
!
    integer                        :: kz
    integer                        :: ndm
    integer                        :: ndmd
    integer                        :: nm
    integer                        :: nmd
    integer                        :: nmu
    integer                        :: num
    real(fp)                       :: dx
    real(fp)                       :: dy
!
!
!! executable statements -------------------------------------------------------
!
    !
    ! Initialise the work arrays at 0
    !
    wrk1 = 0.0_fp
    wrk2 = 0.0_fp
    !
    !-----(du/dx)2 + (dv/dy)2 (at zeta points)
    !
    do nm = 1, nmmax
       if (kfs(nm)==1) then
          nmu = nm + icx
          num = nm + icy
          nmd = nm - icx
          ndm = nm - icy
          dx = 0.5*(gvv(nm) + gvv(ndm))
          dy = 0.5*(guu(nm) + guu(nmd))
          wrk1(nm) = ((umnflc(nm) - umnflc(nmd))/dx)                            &
                   & **2 + ((vmnflc(nm) - vmnflc(ndm))/dy)**2
       endif
    enddo
    !
    !-----(du/dy)2 + (dv/dx)2 + 2du/dydv/dx (at depth points)
    !
    do nm = 1, nmmax
       nmu = nm + icx
       num = nm + icy
       nmd = nm - icx
       ndm = nm - icy
       kz = kfv(nm)*kfv(nmu)*kfu(nm)*kfu(num)
       if (kz==1) then
          dx = 0.5*(gvv(nm) + gvv(nmu))
          dy = 0.5*(guu(nm) + guu(num))
          wrk2(nm) = ((umnflc(num) - umnflc(nm))/dy + (vmnflc(nmu) - vmnflc(nm))&
                   & /dx)**2
       endif
    enddo
    !
    !-----total S2 (at zeta points)
    !
    do nm = 1, nmmax
       if (kfs(nm)==1) then
          nmd = nm - icx
          ndm = nm - icy
          ndmd = nm - icx - icy
          ptke(nm) = 2*wrk1(nm) + (wrk2(nm) + wrk2(nmd) + wrk2(ndm) + wrk2(ndmd)&
                   & )/4.0
       else
          ptke(nm) = 0.
       endif
    enddo
end subroutine protke


! Copyright (c) Anand Patil, 2007

      SUBROUTINE euclidean(D,x,y,nx,ny,ndx,ndy,cmin,cmax,symm)

cf2py intent(inplace) D
cf2py integer intent(optional) :: cmin=0
cf2py integer intent(optional) :: cmax=-1
cf2py logical intent(optional) :: symm=0
cf2py intent(hide) nx, ny,ndx,ndy
cf2py threadsafe

      DOUBLE PRECISION D(nx,ny), x(nx,ndx), y(ny,ndy)
      INTEGER nx,ny,i,j,k,cmin,cmax,ndx,ndy
      LOGICAL symm
      DOUBLE PRECISION dist, dev

      if (cmax.EQ.-1) then
          cmax = ny
      end if
!       print *,nx,ny,ndx,ndy,cmin,cmax,symm

      if(symm) then

        do j=cmin+1,cmax
          D(j,j) = 0.0D0
          do i=1,j-1
            dist = 0.0D0
            do k=1,ndx
              dev=(x(i,k) - y(j,k))
              dist = dist + dev*dev
            enddo
            D(i,j) = dsqrt(dist)
          enddo
        enddo
      else
        do j=cmin+1,cmax
          do i=1,nx
            dist = 0.0D0
            do k=1,ndx
              dev=(x(i,k) - y(j,k))
              dist = dist + dev*dev
            enddo
            D(i,j) = dsqrt(dist)
          enddo
        enddo
      endif
      RETURN
      END

      SUBROUTINE geographic(D,x,y,nx,ny,cmin,cmax,symm)
! First coordinate is longitude, second is latitude.
! Assumes r=1.

cf2py logical intent(optional) :: symm=0
cf2py integer intent(optional) :: cmin=0
cf2py integer intent(optional) :: cmax=-1
cf2py intent(hide) nx, ny
cf2py intent(inplace) D
cf2py threadsafe

      DOUBLE PRECISION D(nx,ny), x(nx,2), y(ny,2)
      integer nx,ny,j,i,i_hi,cmin,cmax
      LOGICAL symm
      DOUBLE PRECISION clat1, clat2, dlat, dlon, a, sterm, cterm

      if (cmax.EQ.-1) then
          cmax = ny
      end if

      do j=cmin+1,cmax
        clat2 = dcos(y(j,2))
        if(symm) then
            D(j,j)=0.0D0
            i_hi = j-1
        else
            i_hi = nx
        endif

        do i=1,i_hi
            clat1 = dcos(x(i,2))
            dlat = (x(i,2)-y(j,2))*0.5D0
            dlon = (x(i,1)-y(j,1))*0.5D0
            a=dsin(dlat)**2 + clat1*clat2*dsin(dlon)**2
            sterm = dsqrt(a)
            cterm = dsqrt(1.0D0-a)
            D(i,j) = 2.0D0*DATAN2(sterm,cterm)
!             if(symm) then
!                 D(j,i) = D(i,j)
!             end if
        enddo
      enddo
      RETURN
      END

      SUBROUTINE paniso_geo_rad(D,x,y,nx,ny,cmin,cmax
     *,ctrs,scals,na,symm)

cf2py intent(inplace) D
cf2py logical intent(optional) :: symm=0
cf2py integer intent(optional) :: cmin=0
cf2py integer intent(optional) :: cmax=-1
cf2py intent(hide) na, nx, ny
cf2py threadsafe

      DOUBLE PRECISION D(nx,ny), x(nx,2), y(ny,2)
      DOUBLE PRECISION ctrs(na), scals(na), w
      integer nx,ny,i,j,na,i_hi,cmin,cmax
      LOGICAL symm
      DOUBLE PRECISION a,pi,da,dlon,dlat
      PARAMETER (pi=3.141592653589793238462643d0)

      if (cmax.EQ.-1) then
          cmax = ny
      end if

      CALL geographic(D,x,y,nx,ny,cmin,cmax,symm)
      w = 0.5D0/real(na)
      do k=1,na
          ctrs(k) = ctrs(k)/pi
      end do

      do j=cmin+1,cmax
        if(symm) then
            D(j,j)=0.0D0
            i_hi = j-1
        else
            i_hi = nx
        endif
        do i = 1,i_hi
            if (D(i,j).GT.0.0D0) then
                dlat = (x(i,2)-y(j,2))
                dlon = (x(i,1)-y(j,1))
                a=dsqrt(dlon*dlon+dlat*dlat)

                theta = DATAN2(dlat/a,dlon/a)/pi

                do k=1,na
                    da=theta-ctrs(k)
                    do while (da.LT.0.0D0)
                        da = da + 2.0D0
                    end do
                    if ((da.LE.w).OR.
     *              (da.GT.2.0D0-w).OR.
     *              ((da.GT.1.0D0).AND.(da.LE.1.0D0+w)).OR.
     *              ((da.GT.1.0D0-w).AND.(da.LE.1.0D0))) then
                        D(i,j)=D(i,j)/scals(k)
                        go to 1
                    end if
                enddo

  1         continue
            end if
!             if(symm) then
!                 D(j,i) = D(i,j)
!             end if
        enddo
      enddo

      RETURN
      END

c
      SUBROUTINE aniso_geo_rad(D,x,y,nx,ny,cmin,cmax,inc,ecc,symm)
! First coordinate is longitude, second is latitude.
! Assumes r=1.

cf2py intent(inplace) D
cf2py logical intent(optional) :: symm = 0
cf2py integer intent(optional) :: cmin=0
cf2py integer intent(optional) :: cmax=-1
cf2py intent(hide) nx
cf2py intent(hide) ny
cf2py threadsafe

      DOUBLE PRECISION D(nx,ny), x(nx,2), y(ny,2)
      integer nx,ny,i,j,cmin,cmax
      LOGICAL symm
      DOUBLE PRECISION clat1, clat2, dlat, dlon, a, sterm, cterm
      DOUBLE PRECISION slat1, slat2, inc, ecc, theta, dtheta

      if (cmax.EQ.-1) then
          cmax = ny
      end if

      if (symm) then

      do j=cmin+1,cmax
        clat2 = dcos(y(j,2))
        slat2 = dsin(y(j,2))
        D(j,j)=0.0D0

        do i=1,j-1
            clat1 = dcos(x(i,2))
            slat1 = dsin(x(i,2))
            dlat = (x(i,2)-y(j,2))
            dlon = (x(i,1)-y(j,1))
            a=dsin(dlat*0.5D0)**2 + clat1*clat2*dsin(dlon*0.5D0)**2
            sterm = dsqrt(a)
            cterm = dsqrt(1.0D0-a)
            D(i,j) = 2.0D0*DATAN2(sterm,cterm)

            if (D(i,j).GT.0.0D0) then

                a=dsqrt(dlon*dlon+dlat*dlat)
                theta = DATAN2(dlat/a,dlon/a)

                dtheta = theta-inc
                dtheta = dcos(dtheta)
                dtheta=ecc*ecc*dtheta*dtheta
                D(i,j)=D(i,j)*dsqrt(1.0D0 - dtheta)

            end if

!             D(j,i) = D(i,j)
        enddo
      enddo

      else

      do j=cmin+1,cmax

        clat2 = dcos(y(j,2))
        slat2 = dsin(y(j,2))

        do i=1,nx

            clat1 = dcos(x(i,2))
            slat1 = dsin(x(i,2))
            dlat = (x(i,2)-y(j,2))
            dlon = (x(i,1)-y(j,1))
            a=dsin(dlat*0.5D0)**2 + clat1*clat2*dsin(dlon*0.5D0)**2

            sterm = dsqrt(a)
            cterm = dsqrt(1.0D0-a)
            D(i,j) = 2.0D0*DATAN2(sterm,cterm)

            if (D(i,j).GT.0.0D0) then

                a=dsqrt(dlon*dlon+dlat*dlat)
                theta = DATAN2(dlat/a,dlon/a)

                dtheta = theta-inc
                dtheta = dcos(dtheta)
                dtheta=ecc*ecc*dtheta*dtheta
                D(i,j)=D(i,j)*dsqrt(1.0D0 - dtheta)

            end if

        enddo
      enddo

      endif

      RETURN
      END


!  *********************************************************************
!  *                                                                   *
!  *                       Dot Product Functions                       *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.0
!  Written by Gordon A. Fenton, TUNS, Aug. 2, 1993
!
!  PURPOSE  a set of specialized dot product functions designed for use by
!           LAS3G.
!
!  This file includes a set of functions which compute dot products for
!  LAS3G of the form
!
!             dot = {A^T}{Z} + {C^T}{U}
!
!  as well as some simple fixed length dot products.
!  In general arguments are as follows;
!
!    Z    real vector containing the parent cell values. Z(1) is assumed
!         to be the first element included in the dot product. (input)
!
!    A    real vector containing the BLUE coefficients. (input)
!
!    C    real vector containing the Covariance coefficients. (input)
!
!    U    real vector containing the random noise inputs. (input)
!
!    dotn external simple dot product function of fixed length. This is
!         used to compute {C^T}{U}.
!
!    j0-j8
!         pointers to cells in left edge of parent cell neighborhood.
!---------------------------------------------------------------------------
!-------------------------------------------------- 8 element corner -------
      real function dot8c( Z, A, C, U, dotn, j0, j1, j2, j3 )
      dimension Z(*), A(*), C(*), U(*)
      external dotn
!
      dot8c = A(1)*Z(j0) + A(2)*Z(1+j0)                                  &
           + A(3)*Z(j1) + A(4)*Z(1+j1)                                   &
           + A(5)*Z(j2) + A(6)*Z(1+j2)                                   &
           + A(7)*Z(j3) + A(8)*Z(1+j3)
!          + dotn( C, U )
      dot8c = dot8c + dotn( C, U )

      return
      end
!-------------------------------------- 12 element edge (horizontal) -------
      real function dot12h( Z, A, C, U, dotn, j0, j1, j2, j3 )
      dimension Z(*), A(*), C(*), U(*)
      external dotn

      dot12h = A( 1)*Z(j0) + A( 2)*Z(1+j0) + A( 3)*Z(2+j0)                &
            + A( 4)*Z(j1) + A( 5)*Z(1+j1) + A( 6)*Z(2+j1)                &
            + A( 7)*Z(j2) + A( 8)*Z(1+j2) + A( 9)*Z(2+j2)                &
            + A(10)*Z(j3) + A(11)*Z(1+j3) + A(12)*Z(2+j3)                &
            + dotn( C, U )

      return
      end
!-------------------------------------- 12 element edge (vertical) -------
      real function dot12v( Z, A, C, U, dotn, j0, j1, j2, j3, j4, j5 )
      dimension Z(*), A(*), C(*), U(*)
      external dotn

      dot12v = A( 1)*Z(j0) + A( 2)*Z(1+j0) + A( 3)*Z(j1) + A( 4)*Z(1+j1)  &
            + A( 5)*Z(j2) + A( 6)*Z(1+j2) + A( 7)*Z(j3) + A( 8)*Z(1+j3)  &
            + A( 9)*Z(j4) + A(10)*Z(1+j4) + A(11)*Z(j5) + A(12)*Z(1+j5)  &
            + dotn( C, U )

      return
      end
!-------------------------------------- 18 element side (front,back,top,bot) -
      real function dot18a( Z, A, C, U, dotn, j0,j1,j2,j3,j4,j5 )
      dimension Z(*), A(*), C(*), U(*)
      external dotn

      dot18a = A( 1)*Z(j0) + A( 2)*Z(1+j0) + A( 3)*Z(2+j0)                &
             + A( 4)*Z(j1) + A( 5)*Z(1+j1) + A( 6)*Z(2+j1)                &
             + A( 7)*Z(j2) + A( 8)*Z(1+j2) + A( 9)*Z(2+j2)                &
             + A(10)*Z(j3) + A(11)*Z(1+j3) + A(12)*Z(2+j3)                &
             + A(13)*Z(j4) + A(14)*Z(1+j4) + A(15)*Z(2+j4)                &
             + A(16)*Z(j5) + A(17)*Z(1+j5) + A(18)*Z(2+j5)                &
             + dotn( C, U )

      return
      end
!-------------------------------------- 18 element side (left and right) -
      real function dot18s( Z, A, C, U, dotn,j0,j1,j2,j3,j4,j5,j6,j7,j8)
      dimension Z(*), A(*), C(*), U(*)
      external dotn

      dot18s = A( 1)*Z(j0) + A( 2)*Z(1+j0)                                &
             + A( 3)*Z(j1) + A( 4)*Z(1+j1)                                &
             + A( 5)*Z(j2) + A( 6)*Z(1+j2)                                &
             + A( 7)*Z(j3) + A( 8)*Z(1+j3)                                &
             + A( 9)*Z(j4) + A(10)*Z(1+j4)                                &
             + A(11)*Z(j5) + A(12)*Z(1+j5)                                &
             + A(13)*Z(j6) + A(14)*Z(1+j6)                                &
             + A(15)*Z(j7) + A(16)*Z(1+j7)                                &
             + A(17)*Z(j8) + A(18)*Z(1+j8)                                &
             + dotn( C, U )

      return
      end
!-------------------------------------- 27 element interior --------------
      real function dot27i( Z, A, C, U, dotn,j0,j1,j2,j3,j4,j5,j6,j7,j8)
      dimension Z(*), A(*), C(*), U(*)
      external dotn

      dot27i = A( 1)*Z(j0) + A( 2)*Z(1+j0) + A( 3)*Z(2+j0)                &
             + A( 4)*Z(j1) + A( 5)*Z(1+j1) + A( 6)*Z(2+j1)                &
             + A( 7)*Z(j2) + A( 8)*Z(1+j2) + A( 9)*Z(2+j2)                &
             + A(10)*Z(j3) + A(11)*Z(1+j3) + A(12)*Z(2+j3)                &
             + A(13)*Z(j4) + A(14)*Z(1+j4) + A(15)*Z(2+j4)                &
             + A(16)*Z(j5) + A(17)*Z(1+j5) + A(18)*Z(2+j5)                &
             + A(19)*Z(j6) + A(20)*Z(1+j6) + A(21)*Z(2+j6)                &
             + A(22)*Z(j7) + A(23)*Z(1+j7) + A(24)*Z(2+j7)                &
             + A(25)*Z(j8) + A(26)*Z(1+j8) + A(27)*Z(2+j8)                &
             + dotn( C, U )

      return
      end
!===========================================================================
!  Here are some general purpose dot product functions (fixed length)
!---------------------------------------------------------------------------
!  DOT1: vectors X and Y are of length 1
!---------------------------------------------------------------------------
      real function dot1( X, Y )
      dimension X(*), Y(*)

      dot1 = X(1)*Y(1)

      return
      end
!---------------------------------------------------------------------------
!  DOT2: vectors X and Y are of length 2
!---------------------------------------------------------------------------
      real function dot2( X, Y )
      dimension X(*), Y(*)

      dot2 = X(1)*Y(1) + X(2)*Y(2)

      return
      end
!---------------------------------------------------------------------------
!  DOT3: vectors X and Y are of length 3
!---------------------------------------------------------------------------
      real function dot3( X, Y )
      dimension X(*), Y(*)

      dot3 = X(1)*Y(1) + X(2)*Y(2) + X(3)*Y(3)

      return
      end
!---------------------------------------------------------------------------
!  DOT4: vectors X and Y are of length 4
!---------------------------------------------------------------------------
      real function dot4( X, Y )
      dimension X(*), Y(*)

      dot4 = X(1)*Y(1) + X(2)*Y(2) + X(3)*Y(3) + X(4)*Y(4)

      return
      end
!---------------------------------------------------------------------------
!  DOT5: vectors X and Y are of length 5
!---------------------------------------------------------------------------
      real function dot5( X, Y )
      dimension X(*), Y(*)

      dot5 = X(1)*Y(1) + X(2)*Y(2) + X(3)*Y(3) + X(4)*Y(4) + X(5)*Y(5)

      return
      end
!---------------------------------------------------------------------------
!  DOT6: vectors X and Y are of length 6
!---------------------------------------------------------------------------
      real function dot6( X, Y )
      dimension X(*), Y(*)

      dot6 = X(1)*Y(1) + X(2)*Y(2) + X(3)*Y(3) + X(4)*Y(4) + X(5)*Y(5)    &
           + X(6)*Y(6)

      return
      end
!---------------------------------------------------------------------------
!  DOT7: vectors X and Y are of length 7
!---------------------------------------------------------------------------
      real function dot7( X, Y )
      dimension X(*), Y(*)

      dot7 = X(1)*Y(1) + X(2)*Y(2) + X(3)*Y(3) + X(4)*Y(4) + X(5)*Y(5)    &
           + X(6)*Y(6) + X(7)*Y(7)

      return
      end


! { dg-do run }
!
! PR fortran/33197
!
! Check implementation of PARITY
!
implicit none

integer :: i
logical :: Lt(1) = [ .true. ]
logical :: Lf(1) = [ .false.]
logical :: Ltf(2) = [ .true., .false. ]
logical :: Ltftf(4) = [.true., .false., .true.,.false.]

if (parity([logical ::]) .neqv. .false.) STOP 1
if (parity([.true., .false.]) .neqv. .true.) STOP 2
if (parity([.true.]) .neqv. .true.) STOP 3
if (parity([.false.]) .neqv. .false.) STOP 4
if (parity([.true., .false., .true.,.false.]) .neqv. .false.) STOP 5
if (parity(reshape([.true., .false., .true.,.false.],[2,2])) &
    .neqv. .false.) STOP 6
if (any (parity(reshape([.true., .false., .true.,.false.],[2,2]),dim=1) &
         .neqv. [.true., .true.])) STOP 7
if (any (parity(reshape([.true., .false., .true.,.false.],[2,2]),dim=2) &
         .neqv. [.false., .false.])) STOP 8

i = 0
if (parity(Lt(1:i)) .neqv. .false.) STOP 9
if (parity(Ltf) .neqv. .true.) STOP 10
if (parity(Lt) .neqv. .true.) STOP 11
if (parity(Lf) .neqv. .false.) STOP 12
if (parity(Ltftf) .neqv. .false.) STOP 13
if (parity(reshape(Ltftf,[2,2])) &
    .neqv. .false.) STOP 14
if (any (parity(reshape(Ltftf,[2,2]),dim=1) &
         .neqv. [.true., .true.])) STOP 15
if (any (parity(reshape(Ltftf,[2,2]),dim=2) &
         .neqv. [.false., .false.])) STOP 16

end


A(2:N - 1) = (A(1:N - 2) + A(2:N - 1) + A(3:N))/3


*DECK DERF
      DOUBLE PRECISION FUNCTION DERF (X)
C***BEGIN PROLOGUE  DERF
C***PURPOSE  Compute the error function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C8A, L5A1E
C***TYPE      DOUBLE PRECISION (ERF-S, DERF-D)
C***KEYWORDS  ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DERF(X) calculates the double precision error function for double
C precision argument X.
C
C Series for ERF        on the interval  0.          to  1.00000E+00
C                                        with weighted error   1.28E-32
C                                         log weighted error  31.89
C                               significant figures required  31.05
C                                    decimal places required  32.55
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, DERFC, INITDS
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900727  Added EXTERNAL statement.  (WRB)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  DERF
      DOUBLE PRECISION X, ERFCS(21), SQEPS, SQRTPI, XBIG, Y, D1MACH,
     1  DCSEVL, DERFC
      LOGICAL FIRST
      EXTERNAL DERFC
      SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST
      DATA ERFCS(  1) / -.4904612123 4691808039 9845440333 76 D-1     /
      DATA ERFCS(  2) / -.1422612051 0371364237 8247418996 31 D+0     /
      DATA ERFCS(  3) / +.1003558218 7599795575 7546767129 33 D-1     /
      DATA ERFCS(  4) / -.5768764699 7674847650 8270255091 67 D-3     /
      DATA ERFCS(  5) / +.2741993125 2196061034 4221607914 71 D-4     /
      DATA ERFCS(  6) / -.1104317550 7344507604 1353812959 05 D-5     /
      DATA ERFCS(  7) / +.3848875542 0345036949 9613114981 74 D-7     /
      DATA ERFCS(  8) / -.1180858253 3875466969 6317518015 81 D-8     /
      DATA ERFCS(  9) / +.3233421582 6050909646 4029309533 54 D-10    /
      DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12    /
      DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13    /
      DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15    /
      DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17    /
      DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18    /
      DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20    /
      DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22    /
      DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24    /
      DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26    /
      DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28    /
      DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29    /
      DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31    /
      DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DERF
      IF (FIRST) THEN
         NTERF = INITDS (ERFCS, 21, 0.1*REAL(D1MACH(3)))
         XBIG = SQRT(-LOG(SQRTPI*D1MACH(3)))
         SQEPS = SQRT(2.0D0*D1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.1.D0) GO TO 20
C
C ERF(X) = 1.0 - ERFC(X)  FOR  -1.0 .LE. X .LE. 1.0
C
      IF (Y.LE.SQEPS) DERF = 2.0D0*X/SQRTPI
      IF (Y.GT.SQEPS) DERF = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0,
     1  ERFCS, NTERF))
      RETURN
C
C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0
C
 20   IF (Y.LE.XBIG) DERF = SIGN (1.0D0-DERFC(Y), X)
      IF (Y.GT.XBIG) DERF = SIGN (1.0D0, X)
C
      RETURN
      END


subroutine rkpm_nodevolume(xna,nsd,nn,ien,ne,nen,ien_local,ne_local,&
	   dwjp_r,adist_r)
! calculate the node volume of fluid mesh for RKPM weight and support region radius
use fluid_variables, only : nquad,sq,wq
use mpi_variables
implicit none
include 'mpif.h'
real(8) xna(nsd,nn)
integer nsd
integer nn
integer ien(nen,ne)
integer nen
integer ne
integer ien_local(ne_local)
integer ne_local
!--------------------------------------------------
real(8) coef
integer ie_local
integer ie
integer inl
integer isd
real(8) xn(nsd,nen)
integer node
real(8) xmax(nsd)
integer iq
real(8) xr(nsd,nsd)
real(8) cf(nsd,nsd)
real(8) det
real(8) vol
integer nnum
!--------------------------------------------------
real(8) adist(nsd,nn)
real(8) dwjp(nn)
real(8) dwjp_r(nn)
real(8) adist_r(nsd,nn)

dwjp(:)=0.0d0
adist(:,:)=0.0d0
dwjp_r(:)=0.0d0
adist_r(:,:)=0.0d0

coef=0.8d0
if (myid == 0) write(*,*) '*** RKPM coefficient ***', coef
do ie_local=1,ne_local
	ie=ien_local(ie_local)
	do inl=1,nen
		do isd=1,nsd
			nnum=ien(inl,ie)
			xn(isd,inl)=xna(isd,nnum)
		end do
	end do

	do isd=1,nsd
		xmax(isd)=coef*(maxval(xn(isd,1:nen)) - minval(xn(isd,1:nen)))
        enddo

     do inl = 1,nen
        node = ien(inl,ie)
        adist(1:nsd,node) = max(adist(1:nsd,node),xmax(1:nsd))
     enddo

 !...Calculate volume
        if (nsd == 2) then
          if (nen == 3) then
                        include "vol2d3n.fi"
          elseif (nen == 4) then
                        include "vol2d4n.fi"
          endif
        elseif (nsd == 3) then
      if (nen == 4) then
                        include "vol3d4n.fi"
      elseif (nen == 8) then
                        include "vol3d8n.fi"
          endif
    endif

     do inl = 1,nen
        nnum = ien(inl,ie)
        dwjp(nnum) = dwjp(nnum) + vol/nen
     enddo
  enddo

call mpi_barrier(mpi_comm_world,ierror)
call mpi_allreduce(dwjp(1),dwjp_r(1),nn,mpi_double_precision,mpi_sum,mpi_comm_world,ierror)
call mpi_allreduce(adist(1,1),adist_r(1,1),nn*nsd,mpi_double_precision,mpi_max,mpi_comm_world,ierror)

!if (myid == 0) then
!open(unit=8406, file='dvolume_pa.txt', status='unknown')
!do isd=1,nn
!write(8406,*) 'dv',dwjp_r(isd),'radius',adist_r(1:nsd,isd)
!end do
!close(8406)
!end if

return

end


function NewtonN(f, x_old)

    use GaussSolveSystem

    implicit none
    external :: f

    interface
        function <caret>f(x)
            real(8), dimension (:), pointer :: f, x
        end function f
    end interface

    real(8), dimension (:, :), pointer :: pmatrix, temp_mat
    real(8), dimension (:), pointer :: x, x_old, temp, NewtonN, x_temp
    integer :: cnt, i, j, NN, smth
    real(8) :: eps, dx

    ! Инициализация метода
    allocate (x(1 : N))

    call read_options(NN, eps, dx)

    allocate (temp_mat(0 : N, 1 : N))

    ! Решение
    newt_c : do cnt = 1, NN
        ! Вычисление значений функций в точках
        temp => f(x_old)
        temp_mat(0, 1 : n) = temp(1 : n)
        deallocate (temp)

        allocate (x_temp(1 : n))
        do i = 1, N
            x_temp = x_old
            x_temp(i) = x_temp(i) + dx
            temp => f(x_temp)
            temp_mat(i, 1 : n) = temp
            deallocate (temp)
        enddo
        deallocate (x_temp)

        ! ОСЛУ
        allocate (pmatrix(1 : n + 1, 1 : n))

        line : do i = 1, N
            pmatrix(n + 1, i) = -temp_mat(0, i)

            col : do j = 1, N
                pmatrix(j, i) = (temp_mat(j, i) - temp_mat(0, i)) / dx
                pmatrix(n + 1, i) = pmatrix(n + 1, i) + pmatrix(j, i) * x_old(j)
            enddo col
        enddo line

        x => GaussSS(N, pmatrix, 3)

        call swap_v(x, x_old)

        ! Выход
        if (abs(sum((x - x_old)**2)) < eps) then
            write (*, *) "Solved."
            exit
        endif
    enddo newt_c

    temp => f(x)
    write(*, *) 'Mistake', sum(temp**2)

    !Завершение работы
    deallocate (temp)
    deallocate (temp_mat)
    deallocate (x)
    NewtonN => x_old

end function NewtonN


      FUNCTION APDF (F,IN,NS)
C
      REAL F(1)
C
C     IF (NS .EQ. 0) GO TO 10
C     APDF = FLOAT(IN-1)/FLOAT(NS)
C     RETURN
C  10 APDF = F(IN)
C     RETURN
C
      APDF = F(IN)
      IF (NS .NE. 0) APDF = FLOAT(IN-1)/FLOAT(NS)
      RETURN
      END


      REAL FUNCTION gennch(df,xnonc)
C**********************************************************************
C
C     REAL FUNCTION GENNCH( DF, XNONC )
C           Generate random value of Noncentral CHIsquare variable
C
C
C                              Function
C
C

C     Generates random deviate  from the  distribution  of a  noncentral
C     chisquare with DF degrees  of freedom and noncentrality  parameter
C     XNONC.
C
C
C                              Arguments
C
C
C     DF --> Degrees of freedom of the chisquare
C            (Must be > 1.0)
C                         REAL DF
C
C     XNONC --> Noncentrality parameter of the chisquare
C               (Must be >= 0.0)
C                         REAL XNONC
C
C
C                              Method
C
C
C     Uses fact that  noncentral chisquare  is  the  sum of a  chisquare
C     deviate with DF-1  degrees of freedom plus the  square of a normal
C     deviate with mean XNONC and standard deviation 1.
C
C**********************************************************************
C     .. Scalar Arguments ..
      REAL df,xnonc
C     ..
C     .. External Functions ..
      REAL genchi,gennor
      EXTERNAL genchi,gennor
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC sqrt
C     ..
C     .. Executable Statements ..
      IF (.NOT. (df.LE.1.0.OR.xnonc.LT.0.0)) GO TO 10
      WRITE (*,*) 'DF <= 1 or XNONC < 0 in GENNCH - ABORT'
      WRITE (*,*) 'Value of DF: ',df,' Value of XNONC',xnonc
      STOP 'DF <= 1 or XNONC < 0 in GENNCH - ABORT'

   10 gennch = genchi(df-1.0) + gennor(sqrt(xnonc),1.0)**2
      RETURN

      END


      subroutine rotate(xo,yo,zo,x1,y1,z1,x2,y2,z2,alp
     x     ,bet,gam)

c***********************************************************************
c
c     DL_POLY utility to rotate water molecule through the
c     Euler angles (alp,bet,gam) in lab fixed axes system.
c     The first data point is taken as the origin for the rotation
c
c     copyright daresbury laboratory 1993
c     author  - t. forester     july 1993
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      dimension x(2),y(2),z(2)
c
c     create hydrogen positions - bondlength 1.0d0

      x(1) = cos(109.5d0*3.1415926d0/360.d0)
      y(1) = sin(109.5d0*3.1415926d0/360.d0)
      z(1) = 0.d0

      x(2) = x(1)
      y(2) = -y(1)
      z(2) = z(1)
c
c     rotate about z by gam

      cs = cos(gam)
      sn = sin(gam)

      do i = 1,2

         xa = cs*x(i) - sn*y(i)
         ya = sn*x(i) + cs*y(i)
         x(i) = xa
         y(i) = ya

      enddo
c
c     rotate about x by bet

      cs = cos(bet)
      sn = sin(bet)

      do i = 1,2

         ya = cs*y(i) - sn*z(i)
         za = sn*y(i) + cs*z(i)
         y(i) = ya
         z(i) = za

      enddo
c
c     rotate about z by alp

      cs = cos(alp)
      sn = sin(alp)

      do i = 1,2

         xa = cs*x(i) - sn*y(i)
         ya = sn*x(i) + cs*y(i)
         x(i) = xa
         y(i) = ya

      enddo

      x1 = x(1) + xo
      x2 = x(2) + xo
      y1 = y(1) + yo
      y2 = y(2) + yo
      z1 = z(1) + zo
      z2 = z(2) + zo

      return
      end

      subroutine error(idnode,kode)
      implicit real*8(a-h,o-z)
      write(6,10) kode
   10 format(' error ',i5,' called by invert' )
      return
      end


*DECK POLCOF
      SUBROUTINE POLCOF (XX, N, X, C, D, WORK)
C***BEGIN PROLOGUE  POLCOF
C***PURPOSE  Compute the coefficients of the polynomial fit (including
C            Hermite polynomial fits) produced by a previous call to
C            POLINT.
C***LIBRARY   SLATEC
C***CATEGORY  E1B
C***TYPE      SINGLE PRECISION (POLCOF-S, DPOLCF-D)
C***KEYWORDS  COEFFICIENTS, POLYNOMIAL
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Written by Robert E. Huddleston, Sandia Laboratories, Livermore
C
C     Abstract
C        Subroutine POLCOF computes the coefficients of the polynomial
C     fit (including Hermite polynomial fits ) produced by a previous
C     call to POLINT. The coefficients of the polynomial, expanded about
C     XX, are stored in the array D. The expansion is of the form
C     P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... +
C                                                  D(N)*((Z-XX)**(N-1)).
C     Between the call to POLINT and the call to POLCOF the variable N
C     and the arrays X and C must not be altered.
C
C     *****  INPUT PARAMETERS
C
C     XX   - The point about which the Taylor expansion is to be made.
C
C     N    - ****
C            *     N, X, and C must remain unchanged between the
C     X    - *     call to POLINT or the call to POLCOF.
C     C    - ****
C
C     *****  OUTPUT PARAMETER
C
C     D    - The array of coefficients for the Taylor expansion as
C            explained in the abstract
C
C     *****  STORAGE PARAMETER
C
C     WORK - This is an array to provide internal working storage. It
C            must be dimensioned by at least 2*N in the calling program.
C
C
C     **** Note - There are two methods for evaluating the fit produced
C     by POLINT. You may call POLYVL to perform the task, or you may
C     call POLCOF to obtain the coefficients of the Taylor expansion and
C     then write your own evaluation scheme. Due to the inherent errors
C     in the computations of the Taylor expansion from the Newton
C     coefficients produced by POLINT, much more accuracy may be
C     expected by calling POLYVL as opposed to writing your own scheme.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   890213  DATE WRITTEN
C   891024  Corrected KEYWORD section.  (WRB)
C   891024  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  POLCOF
C
      DIMENSION X(*), C(*), D(*), WORK(*)
C***FIRST EXECUTABLE STATEMENT  POLCOF
      DO 10010 K=1,N
      D(K)=C(K)
10010 CONTINUE
      IF (N.EQ.1) RETURN
      WORK(1)=1.0
      PONE=C(1)
      NM1=N-1
      DO 10020 K=2,N
      KM1=K-1
      NPKM1=N+K-1
      WORK(NPKM1)=XX-X(KM1)
      WORK(K)=WORK(NPKM1)*WORK(KM1)
      PTWO=PONE+WORK(K)*C(K)
      PONE=PTWO
10020 CONTINUE
      D(1)=PTWO
      IF (N.EQ.2) RETURN
      DO 10030 K=2,NM1
      KM1=K-1
      KM2N=K-2+N
      NMKP1=N-K+1
      DO 10030 I=2,NMKP1
      KM2NPI=KM2N+I
      IM1=I-1
      KM1PI=KM1+I
      WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I)
      D(K)=D(K)+WORK(I)*D(KM1PI)
10030 CONTINUE
      RETURN
      END


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM VE09MA
C
C  --------------------------------------------------------------------
C
C  Solve the quadratic program
C
C     minimize     1/2 x(T) H x + c(T) x
C
C     subject to       A x = b,
C
C                   l <= x <= u
C
C  using the HSL code VE09.
C
C  Nick Gould.
C  December 1991.
C
C  --------------------------------------------------------------------
C
      INTEGER          NMAX, MMAX, NPMMAX, NPLUS, N, M, INSPEC
      INTEGER          INVE09, INPUT, IOUT, I, ITERN, NTOTAL
      INTEGER          ND, NS, NNZJ, NNZH, IND, IOP, MAXIT, LIP
      INTEGER          LV, LD, NDI, NT1, LWS, LIWS, II, IS, NFREE
      INTEGER          NBOTH, NNONEG, NLOWER, L, IR, IC, J, MM
      LOGICAL          CONVEX
      CHARACTER * 5    STATE
      CHARACTER * 10   PNAME
CS    REAL             ONE, ZERO, BIGINF, VL, VU, VX, VM
CD    DOUBLE PRECISION ONE, ZERO, BIGINF, VL, VU, VX, VM
      PARAMETER      ( IOUT  = 6 )
      PARAMETER      ( INPUT = 55, INSPEC = 56 )
CTOY  PARAMETER      ( NMAX = 100, MMAX = 100 )
CTOY  PARAMETER      ( LD = 10000, LWS = 10000, LIWS = 10000 )
CMED  PARAMETER      ( NMAX = 1000, MMAX = 1000 )
CMED  PARAMETER      ( LD = 100000, LWS = 100000, LIWS = 100000 )
CBIG  PARAMETER      ( NMAX = 5000, MMAX = 5000 )
CBIG  PARAMETER      ( LD = 350000, LWS = 200000, LIWS = 350000 )
CCUS  PARAMETER      ( NMAX = 3000, MMAX = 3000 )
CCUS  PARAMETER      ( LD = 200000, LWS = 150000, LIWS = 200000 )
      PARAMETER      ( NPMMAX = NMAX + MMAX, NPLUS = NPMMAX + 3 )
      INTEGER          ISTATE( NPMMAX ), IPERM( NMAX )
      INTEGER          IWS( LIWS ), IRND( LD ), IP( NPLUS )
CS    REAL             D( LD ), BND( 2, NMAX ), TUPPER, T1, T2
CS    REAL             X( NMAX ), X0( NMAX ), P( NMAX ), WS( LWS )
CS    REAL             BLOWER( NPMMAX ), BUPPER( NPMMAX )
CD    DOUBLE PRECISION D( LD ), BND( 2, NMAX ), TUPPER, T1, T2
CD    DOUBLE PRECISION X( NMAX ), X0( NMAX ), P( NMAX ), WS( LWS )
CD    DOUBLE PRECISION BLOWER( NPMMAX ), BUPPER( NPMMAX )
      LOGICAL          EQUATN( MMAX ), LINEAR( MMAX )
      CHARACTER * 10   VNAME( NMAX ), CNAME( MMAX )
CS    PARAMETER      ( ZERO  = 0.0E+0, ONE  = 1.0E+0 )
CD    PARAMETER      ( ZERO  = 0.0D+0, ONE  = 1.0D+0 )
CS    PARAMETER      ( BIGINF = 1.0E+19 )
CD    PARAMETER      ( BIGINF = 1.0D+19 )
      REAL             CPU( 2 ), CALLS( 7 )
      INTEGER          JOUT, JIN, NFRV, ITER, NR, NART
CS    REAL             F, U, GG, GMAX2, XJIN, RHO, SCALE, XART, TOLART
CS    REAL             TOLX, TOLAM, OBJF
CD    DOUBLE PRECISION F, U, GG, GMAX2, XJIN, RHO, SCALE, XART, TOLART
CD    DOUBLE PRECISION TOLX, TOLAM, OBJF
      LOGICAL          FEAS, FSEP, SOC
CS    COMMON /VE09C /  GG, U, F, RHO, GMAX2, XJIN, SCALE, XART, TOLART,
CD    COMMON /VE09CD/  GG, U, F, RHO, GMAX2, XJIN, SCALE, XART, TOLART,
     *                 TOLX, TOLAM, NART, JOUT, JIN, NFRV, ITER,
     *                 NR, FEAS, FSEP, SOC
C
C  Open the Spec file for the method.
C
      OPEN ( INSPEC, FILE = 'VE09.SPC', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INSPEC
C
C  Read input Spec data.
C
C     MAXIT : the maximum number of iterations
C     CONVEX: true if the objective function is convex
C
      READ ( INSPEC, 1000 ) MAXIT, CONVEX
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up the data structures necessary to hold the group partially
C  separable function.
C
      LV = MIN( LWS, MMAX )
      CALL CSETUP ( INPUT, IOUT, N, M, X0, BLOWER( 1 ),
     *              BUPPER( 1 ), NMAX, EQUATN, LINEAR,
     *              WS, BLOWER( NMAX + 1 ),
     *              BUPPER( NMAX + 1 ), LV, .FALSE., .FALSE., .FALSE. )
C
C  Determine the names of the problem, variables and constraints.
C
      MM = MAX( M, 1 )
      CALL CNAMES ( N, MM, PNAME, VNAME, CNAME )
C
C  Set up the initial estimate of the solution, SOL, and
C  right-hand-side, RHS, of the Kuhn-Tucker system.
C
C  The variables will be permuted, before being passed to
C  the optimizer, so that the first NBOTH variables are
C  bounded on both sides and the last NTOTAL - NFREE + 1 satisfy
C  nonnegativity restrictions (the remaining variables are
C  free).
C
C  On exit from the minimizer, the i-th original variable
C  will have the value X( IPERM( i ) ).
C
      NTOTAL = N
      ND     = 0
      NBOTH  = 0
      NFREE  = 0
C
C  Determine the status of each problem variable.
C
      DO 5 I = 1, N
         IF ( BUPPER( I ) .GT. BIGINF ) THEN
            IF ( BLOWER( I ) .LT. - BIGINF ) THEN
               NFREE = NFREE + 1
               IWS( I ) = 0
            ELSE IF ( BLOWER( I ) .EQ. ZERO ) THEN
               IWS( I ) = 1
            ELSE
               NBOTH = NBOTH + 1
               IWS( I ) = 2
            END IF
         ELSE
            NBOTH = NBOTH + 1
            IWS( I ) = 2
         END IF
    5 CONTINUE
C
C  Determine the status of each slack variable.
C
      DO 10 I = 1, M
         IF ( .NOT. EQUATN( I ) ) THEN
            NTOTAL = NTOTAL + 1
            IF ( ( BLOWER( NMAX + I ) .EQ. ZERO .AND.
     *             BUPPER( NMAX + I ) .GT. BIGINF ) .OR.
     *           ( BUPPER( NMAX + I ) .EQ. ZERO .AND.
     *             BLOWER( NMAX + I ) .LT. - BIGINF ) ) THEN
               IWS( NTOTAL ) = 1
            ELSE
               NBOTH = NBOTH + 1
               IWS( NTOTAL ) = 2
            END IF
         END IF
   10 CONTINUE
      NT1 = NTOTAL + 1
C
C  Permute the variables.
C
      NNONEG = NBOTH  + NFREE
      NLOWER = NNONEG + 1
      NFREE  = NBOTH
      NBOTH  = 0
      DO 15 I = 1, N
         IF ( IWS( I ) .EQ. 0 ) THEN
            NFREE = NFREE + 1
            IPERM( I ) = NFREE
         ELSE IF ( IWS( I ) .EQ. 1 ) THEN
            NNONEG = NNONEG + 1
            IPERM( I ) = NNONEG
         ELSE IF ( IWS( I ) .EQ. 2 ) THEN
            NBOTH = NBOTH + 1
            IPERM( I ) = NBOTH
            BND( 1, NBOTH ) = BLOWER( I )
            BND( 2, NBOTH ) = BUPPER( I )
         END IF
   15 CONTINUE
C
C  Introduce slack variables for inequality constraints.
C  Continue permuting the variables.
C
      IF ( NTOTAL .GT. N ) THEN
         NS = N
         DO 20 I = 1, M
            IF ( .NOT. EQUATN( I ) ) THEN
               ND = ND + 1
               NS = NS + 1
               IF ( IWS( NS ) .EQ. 1 ) THEN
                  NNONEG = NNONEG + 1
                  IPERM( NS ) = NNONEG
                  IF ( BLOWER( NMAX + I ) .EQ. ZERO ) THEN
                     D( ND ) = - ONE
                  ELSE
                     D( ND ) = ONE
                  END IF
               ELSE IF ( IWS( NS ) .EQ. 2 ) THEN
                  NBOTH = NBOTH + 1
                  IPERM( NS ) = NBOTH
                  BND( 1, NBOTH ) = BLOWER( NMAX + I )
                  BND( 2, NBOTH ) = BUPPER( NMAX + I )
                  D( ND ) = - ONE
               END IF
               IRND( ND ) = NTOTAL + I
               IWS( ND ) = IPERM( NS )
            END IF
   20    CONTINUE
      END IF
C
C  Set X to zero to determine the constant terms for
C  the problem functions.
C
      DO 30 I = 1, N
         X( I ) = ZERO
   30 CONTINUE
C
C  Evaluate the constant terms of the objective and constraint functions.
C
      CALL CFN( N , M , X, OBJF, MM, D( ND + 1 ) )
      NS = ND
      DO 40 I = 1, M
         IF ( D( NS + I ) .NE. ZERO ) THEN
            ND = ND + 1
            D( ND ) = - D( NS + I )
            IRND( ND ) = NTOTAL + I
            IWS( ND ) = NT1
         END IF
   40 CONTINUE
C
C  Evaluate the linear terms of the objective and constraint functions
C  in a sparse format.
C
      CALL CSGR ( N, M, .FALSE., LV, WS, X, NNZJ, LD - ND, D( ND + 1 ),
     *            IWS( ND + 1 ), IRND( ND + 1 ) )
      NS = ND
      DO 50 I = 1, NNZJ
         IF ( D( NS + I ) .NE. ZERO ) THEN
            ND = ND + 1
            D( ND ) = D( NS + I )
            IF ( IRND( NS + I ) .GT. 0 ) THEN
               IRND( ND ) = IRND( NS + I ) + NTOTAL
               IWS( ND ) = IPERM( IWS( NS + I ) )
            ELSE
               IRND( ND ) = IWS( NS + I )
               IWS( ND ) = NT1
            END IF
         END IF
   50 CONTINUE
C
C  Evaluate the Hessian of the Lagrangian function at the initial point.
C
      CALL CSH ( N, M, X0, LV, WS, NNZH, LD - ND, D( ND + 1 ),
     *           IRND( ND + 1 ), IWS( ND + 1 ) )
      NS = ND
      DO 60 I = 1, NNZH
         NDI = ND + I
         IF ( D( NDI ) .NE. ZERO ) THEN
            NS = NS + 1
            D( NS ) = D( NDI )
            IRND( NS ) = IPERM( IRND( NDI ) )
            IWS( NS ) = IPERM( IWS( NDI ) )
         END IF
   60 CONTINUE
      NNZH = NS - ND
      DO 70 I = 1, NNZH
         NDI = ND + I
         IF ( IRND( NDI ) .NE. IWS( NDI ) ) THEN
            NS = NS + 1
            D( NS ) = D( NDI )
            IRND( NS ) = IWS( NDI )
            IWS( NS ) = IRND( NDI )
         END IF
   70 CONTINUE
      ND = NS
C
C  Change from a co-ordinate storage scheme to a column-wise
C  scheme.
C
      IND = - 1
      LIP = NT1 + 1
CS    CALL MC49A ( IND, NT1, NTOTAL + M, ND, IRND, IWS, .TRUE., LD, D,
CD    CALL MC49AD( IND, NT1, NTOTAL + M, ND, IRND, IWS, .TRUE., LD, D,
     *             LIP, IP, LIWS - ND, IWS( ND + 1 ), IOP )
      IP( LIP + 1 ) = IP( LIP )
C
C  Prepare to call VE09.
C
      IOP    = 1
      TUPPER = ZERO
      INVE09 = 3
C
C  The major iteration.
C
      DO 300 ITERN = 1, MAXIT
CS       CALL VE09A ( D, LD, IRND, IP, M, NTOTAL, BND, NBOTH, NFREE + 1,
CD       CALL VE09AD( D, LD, IRND, IP, M, NTOTAL, BND, NBOTH, NFREE + 1,
     *                CONVEX, TUPPER, IOP, INVE09, X0, ISTATE,
     *                X, P, T1, T2, IWS, LIWS, WS, LWS )
         IF ( IOP .NE. 3 .AND. IOP .NE. 5 ) GO TO 500
  300 CONTINUE
C
C  End of main iteration loop.
C
  500 CONTINUE
      CALL CREPRT( CALLS, CPU )
C
C  Print details of the solution obtained.
C
      WRITE( 6, 2010 ) IOP
      IF ( IOP .GE. 0 ) THEN
         L = 4
         DO 520 J = 1, 2
            IF ( J .EQ. 1 ) THEN
               IR = 1
               IC = MIN( L, N )
            ELSE
               IF ( IC. LT. N - L ) WRITE( 6, 2000 )
               IR = MAX( IC + 1, N - IC + 1 )
               IC = N
            END IF
            DO 510 II = IR, IC
               I = IPERM( II )
               IS = ISTATE( I )
               IF ( IS .EQ. 0 ) THEN
                  VX = X( I + M )
                  VM = ZERO
                  STATE = ' FREE'
               ELSE
                  IF ( I .LE. NBOTH ) THEN
                     VX = BND( IS, I )
                  ELSE
                     VX = 0.0D+0
                  END IF
                  VM = - X( I + M )
                  IF ( IS .EQ. 1 ) THEN
                     STATE = 'LOWER'
                  ELSE
                     STATE = 'UPPER'
                  END IF
               END IF
               IF ( I .LE. NBOTH ) THEN
                  VL = BND( 1, I )
                  VU = BND( 2, I )
               ELSE
                  VU = BIGINF
                  IF ( I .GE. NLOWER ) THEN
                     VL = ZERO
                  ELSE
                     VL = - BIGINF
                  END IF
               END IF
               WRITE( 6, 2020 ) VNAME( II ), STATE, VX, VL, VU, VM
  510       CONTINUE
  520    CONTINUE
         IF ( M .GT. 0 ) THEN
            DO 610 I = 1, M
               WS( I ) = ZERO
  610       CONTINUE
            DO 620 I = IP( NTOTAL + 1 ), IP( NTOTAL + 2 ) - 1
               IF ( IRND( I ) .GT. NTOTAL ) THEN
                  WS( IRND( I ) - NTOTAL ) =
     *                WS( IRND( I ) - NTOTAL ) - D( I )
               END IF
  620       CONTINUE
            DO 640 II = 1, N
               J = IPERM( II )
               IS = ISTATE( J )
               IF ( IS .EQ. 0 ) THEN
                  VX = X( J + M )
               ELSE
                  IF ( I .LE. NBOTH ) THEN
                     VX = BND( IS, J )
                  ELSE
                     VX = 0.0D+0
                  END IF
               END IF
               DO 630 I = IP( J ), IP( J + 1 ) - 1
                  IF ( IRND( I ) .GT. NTOTAL ) THEN
                     WS( IRND( I ) - NTOTAL ) =
     *                  WS( IRND( I ) - NTOTAL ) + D( I ) * VX
                  END IF
  630          CONTINUE
  640       CONTINUE
            WRITE( 6, 2040 )
            L = 2
            DO 660 J = 1, 2
               IF ( J .EQ. 1 ) THEN
                  IR = 1
                  IC = MIN( L, M )
               ELSE
                  IF ( IC. LT. M - L ) WRITE( 6, 2000 )
                  IR = MAX( IC + 1, M - IC + 1 )
                  IC = M
               END IF
               DO 650 I = IR, IC
                  IF ( EQUATN( I ) ) THEN
                     STATE = 'FIXED'
                  ELSE
                     STATE = ' FREE'
                     IF ( ABS( WS( I ) - BLOWER( NMAX + I ) )
     *                    .LT. 1.0D-12 ) STATE = 'LOWER'
                     IF ( ABS( WS( I ) - BUPPER( NMAX + I ) )
     *                    .LT. 1.0D-12 ) STATE = 'UPPER'
                  END IF
                  WRITE( 6, 2020 ) CNAME( I ), STATE, WS( I ),
     *                       BLOWER( NMAX + I),
     *                       BUPPER( NMAX + I ), X( I )
  650          CONTINUE
  660       CONTINUE
         END IF
         WRITE( 6, 2030 ) F + OBJF, ITERN
      END IF
      WRITE ( 6, 2001 ) PNAME, N, M, (CALLS( I ), I = 1, 3 ),
     *                  (CALLS( I ), I = 5, 7 ),
     *                  IOP, F + OBJF, CPU( 1 ), CPU( 2 )
      CLOSE( INPUT  )
      STOP
C
C  Non-executable statements.
C
 1000 FORMAT( I10, /, L10 )
 2000 FORMAT( ' .          .....  ............',
     *        '  ............  ............  ............ ' )
 2001 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  VE09',     /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # constraints           =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # objective gradients   =        ', F8.2 /
     *    ,' # objective Hessians    =        ', F8.2 /
     *    ,' # constraints functions =        ', F8.2 /
     *    ,' # constraints gradients =        ', F8.2 /
     *    ,' # constraints Hessians  =        ', F8.2 /
     *     ' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 2010 FORMAT( ' Stopping with IOP = ',I3 /,
     *        ' Solution:', //,
     *        ' name       state     value   ',
     *        '   Lower bound   Upper bound  Dual variable ' )
 2020 FORMAT( 1X, A10, A6, 1P, 4D14.6 )
 2030 FORMAT( /, ' Final objective function value ', 1P, D22.14,
     *        /, ' Total number of iterations = ', I6 )
 2040 FORMAT( /, ' Constraints:', //,
     *        ' name       state     value   ',
     *        '   Lower bound   Upper bound    Multiplier ' )
C
C  End of VE09MA.
C
      END