!*==slanv2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLANV2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
!
!       .. Scalar Arguments ..
!       REAL               A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
!> matrix in standard form:
!>
!>      [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
!>      [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]
!>
!> where either
!> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
!> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
!> conjugate eigenvalues.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] A
!> \verbatim
!>          A is REAL
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is REAL
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is REAL
!>          On entry, the elements of the input matrix.
!>          On exit, they are overwritten by the elements of the
!>          standardised Schur form.
!> \endverbatim
!>
!> \param[out] RT1R
!> \verbatim
!>          RT1R is REAL
!> \endverbatim
!>
!> \param[out] RT1I
!> \verbatim
!>          RT1I is REAL
!> \endverbatim
!>
!> \param[out] RT2R
!> \verbatim
!>          RT2R is REAL
!> \endverbatim
!>
!> \param[out] RT2I
!> \verbatim
!>          RT2I is REAL
!>          The real and imaginary parts of the eigenvalues. If the
!>          eigenvalues are a complex conjugate pair, RT1I > 0.
!> \endverbatim
!>
!> \param[out] CS
!> \verbatim
!>          CS is REAL
!> \endverbatim
!>
!> \param[out] SN
!> \verbatim
!>          SN is REAL
!>          Parameters of the rotation matrix.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Modified by V. Sima, Research Institute for Informatics, Bucharest,
!>  Romania, to reduce the risk of cancellation errors,
!>  when computing real eigenvalues, and to ensure, if possible, that
!>  abs(RT1R) >= abs(RT2R).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SLANV2(A,B,C,D,Rt1r,Rt1i,Rt2r,Rt2i,Cs,Sn)
      IMPLICIT NONE
!*--SLANV2131
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      REAL A , B , C , Cs , D , Rt1i , Rt1r , Rt2i , Rt2r , Sn
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , HALF , ONE , TWO
      PARAMETER (ZERO=0.0E+0,HALF=0.5E+0,ONE=1.0E+0,TWO=2.0E+0)
      REAL MULTPL
      PARAMETER (MULTPL=4.0E+0)
!     ..
!     .. Local Scalars ..
      REAL aa , bb , bcmax , bcmis , cc , cs1 , dd , eps , p , sab ,    &
     &     sac , scale , sigma , sn1 , tau , temp , z , safmin ,        &
     &     safmn2 , safmx2
      INTEGER count
!     ..
!     .. External Functions ..
      REAL SLAMCH , SLAPY2
      EXTERNAL SLAMCH , SLAPY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN , SIGN , SQRT
!     ..
!     .. Executable Statements ..
!
      safmin = SLAMCH('S')
      eps = SLAMCH('P')
      safmn2 = SLAMCH('B')**INT(LOG(safmin/eps)/LOG(SLAMCH('B'))/TWO)
      safmx2 = ONE/safmn2
      IF ( C==ZERO ) THEN
         Cs = ONE
         Sn = ZERO
!
      ELSEIF ( B==ZERO ) THEN
!
!        Swap rows and columns
!
         Cs = ZERO
         Sn = ONE
         temp = D
         D = A
         A = temp
         B = -C
         C = ZERO
!
      ELSEIF ( (A-D)==ZERO .AND. SIGN(ONE,B)/=SIGN(ONE,C) ) THEN
         Cs = ONE
         Sn = ZERO
!
      ELSE
!
         temp = A - D
         p = HALF*temp
         bcmax = MAX(ABS(B),ABS(C))
         bcmis = MIN(ABS(B),ABS(C))*SIGN(ONE,B)*SIGN(ONE,C)
         scale = MAX(ABS(p),bcmax)
         z = (p/scale)*p + (bcmax/scale)*bcmis
!
!        If Z is of the order of the machine accuracy, postpone the
!        decision on the nature of eigenvalues
!
         IF ( z>=MULTPL*eps ) THEN
!
!           Real eigenvalues. Compute A and D.
!
            z = p + SIGN(SQRT(scale)*SQRT(z),p)
            A = D + z
            D = D - (bcmax/z)*bcmis
!
!           Compute B and the rotation matrix
!
            tau = SLAPY2(C,z)
            Cs = z/tau
            Sn = C/tau
            B = B - C
            C = ZERO
!
         ELSE
!
!           Complex eigenvalues, or real (almost) equal eigenvalues.
!           Make diagonal elements equal.
!
            count = 0
            sigma = B + C
 20         DO
               count = count + 1
               scale = MAX(ABS(temp),ABS(sigma))
               IF ( scale>=safmx2 ) THEN
                  sigma = sigma*safmn2
                  temp = temp*safmn2
                  IF ( count<=20 ) CYCLE
               ENDIF
               EXIT
            ENDDO
            IF ( scale<=safmn2 ) THEN
               sigma = sigma*safmx2
               temp = temp*safmx2
               IF ( count<=20 ) GOTO 20
            ENDIF
            p = HALF*temp
            tau = SLAPY2(sigma,temp)
            Cs = SQRT(HALF*(ONE+ABS(sigma)/tau))
            Sn = -(p/(tau*Cs))*SIGN(ONE,sigma)
!
!           Compute [ AA  BB ] = [ A  B ] [ CS -SN ]
!                   [ CC  DD ]   [ C  D ] [ SN  CS ]
!
            aa = A*Cs + B*Sn
            bb = -A*Sn + B*Cs
            cc = C*Cs + D*Sn
            dd = -C*Sn + D*Cs
!
!           Compute [ A  B ] = [ CS  SN ] [ AA  BB ]
!                   [ C  D ]   [-SN  CS ] [ CC  DD ]
!
            A = aa*Cs + cc*Sn
            B = bb*Cs + dd*Sn
            C = -aa*Sn + cc*Cs
            D = -bb*Sn + dd*Cs
!
            temp = HALF*(A+D)
            A = temp
            D = temp
!
            IF ( C/=ZERO ) THEN
               IF ( B==ZERO ) THEN
                  B = -C
                  C = ZERO
                  temp = Cs
                  Cs = -Sn
                  Sn = temp
               ELSEIF ( SIGN(ONE,B)==SIGN(ONE,C) ) THEN
!
!                    Real eigenvalues: reduce to upper triangular form
!
                  sab = SQRT(ABS(B))
                  sac = SQRT(ABS(C))
                  p = SIGN(sab*sac,C)
                  tau = ONE/SQRT(ABS(B+C))
                  A = temp + p
                  D = temp - p
                  B = B - C
                  C = ZERO
                  cs1 = sab*tau
                  sn1 = sac*tau
                  temp = Cs*cs1 - Sn*sn1
                  Sn = Cs*sn1 + Sn*cs1
                  Cs = temp
               ENDIF
            ENDIF
         ENDIF
!
      ENDIF
!
!     Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
!
      Rt1r = A
      Rt2r = D
      IF ( C==ZERO ) THEN
         Rt1i = ZERO
         Rt2i = ZERO
      ELSE
         Rt1i = SQRT(ABS(B))*SQRT(ABS(C))
         Rt2i = -Rt1i
      ENDIF
!
!     End of SLANV2
!
      END SUBROUTINE SLANV2


MODULE lattice_module

  use io_tools_module

  implicit none

  PRIVATE
  PUBLIC :: lattice
  PUBLIC :: init_lattice
  PUBLIC :: get_reciprocal_lattice
  PUBLIC :: construct_aa_lattice
  PUBLIC :: read_lattice
  PUBLIC :: get_inverse_lattice
  PUBLIC :: backup_aa_lattice
  PUBLIC :: get_aa_lattice

  type lattice
     real(8) :: LatticeConstant
     real(8) :: LatticeVector(3,3)
     real(8) :: Length(3)
     real(8) :: Volume
  end type lattice

  real(8) :: ax, av(3,3)

  type(lattice) :: aa_backup

CONTAINS

  SUBROUTINE read_lattice( aa, unit )
    implicit none
    type(lattice),intent(OUT) :: aa
    integer,optional,intent(IN) :: unit
    aa%LatticeConstant=0.0d0
    aa%LatticeVector(:,:)=0.0d0
    if ( present(unit) ) then
       call IOTools_readReal8Keyword( "AX", aa%LatticeConstant, unit )
       call IOTools_readReal8Keywords( "A1", aa%LatticeVector(:,1), unit )
       call IOTools_readReal8Keywords( "A2", aa%LatticeVector(:,2), unit )
       call IOTools_readReal8Keywords( "A3", aa%LatticeVector(:,3), unit )
    else
       call IOTools_readReal8Keyword( "AX", aa%LatticeConstant )
       call IOTools_readReal8Keywords( "A1", aa%LatticeVector(:,1) )
       call IOTools_readReal8Keywords( "A2", aa%LatticeVector(:,2) )
       call IOTools_readReal8Keywords( "A3", aa%LatticeVector(:,3) )
    end if
    call construct_aa_lattice( aa )
  END SUBROUTINE read_lattice

  SUBROUTINE init_lattice( ax_in, av_in )
    implicit none
    real(8),intent(IN) :: ax_in, av_in(3,3)
    ax = ax_in
    av = av_in
  END SUBROUTINE init_lattice

  SUBROUTINE construct_aa_lattice( aa )
    implicit none
    type(lattice),intent(INOUT) :: aa
    aa%LatticeVector(:,:) = aa%LatticeConstant * aa%LatticeVector(:,:)
    call calc_VectorLength( aa%LatticeVector, aa%Length )
    call calc_Volume( aa%LatticeVector, aa%Volume )
  END SUBROUTINE construct_aa_lattice

  SUBROUTINE calc_VectorLength( aa, aal )
    implicit none
    real(8),intent(IN)  :: aa(3,3)
    real(8),intent(OUT) :: aal(3)
    aal(1) = sqrt( sum(aa(1:3,1)**2) )
    aal(2) = sqrt( sum(aa(1:3,2)**2) )
    aal(3) = sqrt( sum(aa(1:3,3)**2) )
  END SUBROUTINE calc_VectorLength

  SUBROUTINE calc_Volume( aa, Va )
    implicit none
    real(8),intent(IN)  :: aa(3,3)
    real(8),intent(OUT) :: Va
    Va = aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1) &
        +aa(1,3)*aa(2,1)*aa(3,2)-aa(1,3)*aa(2,2)*aa(3,1) &
        -aa(1,2)*aa(2,1)*aa(3,3)-aa(1,1)*aa(2,3)*aa(3,2)
  END SUBROUTINE calc_Volume

  SUBROUTINE get_reciprocal_lattice( aa, bb )
    implicit none
    type(lattice),intent(IN)  :: aa
    type(lattice),intent(OUT) :: bb
    real(8) :: a(3,3), b(3,3), pi2
    pi2 = 2.0d0*acos(-1.0d0)
    a(:,:) = aa%LatticeVector(:,:)
    b(1,1) = a(2,2)*a(3,3) - a(3,2)*a(2,3)
    b(2,1) = a(3,2)*a(1,3) - a(1,2)*a(3,3)
    b(3,1) = a(1,2)*a(2,3) - a(2,2)*a(1,3)
    b(1,2) = a(2,3)*a(3,1) - a(3,3)*a(2,1)
    b(2,2) = a(3,3)*a(1,1) - a(1,3)*a(3,1)
    b(3,2) = a(1,3)*a(2,1) - a(2,3)*a(1,1)
    b(1,3) = a(2,1)*a(3,2) - a(3,1)*a(2,2)
    b(2,3) = a(3,1)*a(1,2) - a(1,1)*a(3,2)
    b(3,3) = a(1,1)*a(2,2) - a(2,1)*a(1,2)
    b(:,:) = b(:,:)*pi2/aa%Volume
    bb%LatticeVector(:,:) = b(:,:)
    call calc_VectorLength( bb%LatticeVector, bb%Length )
    call calc_Volume( bb%LatticeVector, bb%Volume )
    bb%LatticeConstant = pi2/aa%LatticeConstant
 END SUBROUTINE get_reciprocal_lattice

  SUBROUTINE get_inverse_lattice( a, ainv )
    implicit none
    real(8),intent(IN)  :: a(3,3)
    real(8),intent(OUT) :: ainv(3,3)
    real(8) :: b(3,3), v
    b(1,1) = a(2,2)*a(3,3) - a(3,2)*a(2,3)
    b(2,1) = a(3,2)*a(1,3) - a(1,2)*a(3,3)
    b(3,1) = a(1,2)*a(2,3) - a(2,2)*a(1,3)
    b(1,2) = a(2,3)*a(3,1) - a(3,3)*a(2,1)
    b(2,2) = a(3,3)*a(1,1) - a(1,3)*a(3,1)
    b(3,2) = a(1,3)*a(2,1) - a(2,3)*a(1,1)
    b(1,3) = a(2,1)*a(3,2) - a(3,1)*a(2,2)
    b(2,3) = a(3,1)*a(1,2) - a(1,1)*a(3,2)
    b(3,3) = a(1,1)*a(2,2) - a(2,1)*a(1,2)
    call calc_Volume( a, v )
    ainv(:,:) = transpose( b(:,:) )/v
  END SUBROUTINE get_inverse_lattice

  SUBROUTINE backup_aa_lattice( aa )
    implicit none
    type(lattice),intent(IN) :: aa
    aa_backup = aa
  END SUBROUTINE backup_aa_lattice

  SUBROUTINE get_aa_lattice( aa )
    implicit none
    type(lattice),intent(OUT) :: aa
    aa = aa_backup
  END SUBROUTINE get_aa_lattice

END MODULE lattice_module


!*==spotf2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SPOTF2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDA, N
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SPOTF2 computes the Cholesky factorization of a real symmetric
!> positive definite matrix A.
!>
!> The factorization has the form
!>    A = U**T * U ,  if UPLO = 'U', or
!>    A = L  * L**T,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular.
!>
!> This is the unblocked version of the algorithm, calling Level 2 BLAS.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, if INFO = 0, the factor U or L from the Cholesky
!>          factorization A = U**T *U  or A = L*L**T.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, the leading minor of order k is not
!>               positive definite, and the factorization could not be
!>               completed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realPOcomputational
!
!  =====================================================================
      SUBROUTINE SPOTF2(Uplo,N,A,Lda,Info)
      IMPLICIT NONE
!*--SPOTF2113
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Lda , N
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL upper
      INTEGER j
      REAL ajj
!     ..
!     .. External Functions ..
      LOGICAL LSAME , SISNAN
      REAL SDOT
      EXTERNAL LSAME , SDOT , SISNAN
!     ..
!     .. External Subroutines ..
      EXTERNAL SGEMV , SSCAL , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SPOTF2',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
      IF ( upper ) THEN
!
!        Compute the Cholesky factorization A = U**T *U.
!
         DO j = 1 , N
!
!           Compute U(J,J) and test for non-positive-definiteness.
!
            ajj = A(j,j) - SDOT(j-1,A(1,j),1,A(1,j),1)
            IF ( ajj<=ZERO .OR. SISNAN(ajj) ) THEN
               A(j,j) = ajj
               GOTO 100
            ENDIF
            ajj = SQRT(ajj)
            A(j,j) = ajj
!
!           Compute elements J+1:N of row J.
!
            IF ( j<N ) THEN
               CALL SGEMV('Transpose',j-1,N-j,-ONE,A(1,j+1),Lda,A(1,j), &
     &                    1,ONE,A(j,j+1),Lda)
               CALL SSCAL(N-j,ONE/ajj,A(j,j+1),Lda)
            ENDIF
         ENDDO
      ELSE
!
!        Compute the Cholesky factorization A = L*L**T.
!
         DO j = 1 , N
!
!           Compute L(J,J) and test for non-positive-definiteness.
!
            ajj = A(j,j) - SDOT(j-1,A(j,1),Lda,A(j,1),Lda)
            IF ( ajj<=ZERO .OR. SISNAN(ajj) ) THEN
               A(j,j) = ajj
               GOTO 100
            ENDIF
            ajj = SQRT(ajj)
            A(j,j) = ajj
!
!           Compute elements J+1:N of column J.
!
            IF ( j<N ) THEN
               CALL SGEMV('No transpose',N-j,j-1,-ONE,A(j+1,1),Lda,     &
     &                    A(j,1),Lda,ONE,A(j+1,j),1)
               CALL SSCAL(N-j,ONE/ajj,A(j+1,j),1)
            ENDIF
         ENDDO
      ENDIF
      GOTO 99999
!
 100  Info = j
!
!
!     End of SPOTF2
!
99999 END SUBROUTINE SPOTF2


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C---------  BLOCH   U  T  I  L  I  T  I  E  S   B  L  O  C  K----------C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE BLOCH_SEM                                             C
C                                                                      C
C     Read the couple of nodes with bloch-periodicity constraints      C
C                                                                      C
C                                                                      C
C     NCOND       :NUMBER OF NODAL CONSTRAINTS                         C
C     IMNODES     :IMAGE NODES                                         C
C     IRNODES     :REFERENCES NODES                                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 05 DECEMBER 2011                                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE BLOCH_SEM(NDOF,SKG,SMG,NCOR,COORDS,NCOND_WO,NCOND,
     1           IRNODES_WO,IMNODES,IRNODES,NEVALS,AKXMIN,
     2           AKYMIN,AKXMAX,AKYMAX,NKX,NKY,EIGVALS)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (PI = 3.141592653589793)
C      N = NDOF - 2*NCOND
      N = NDOF - NCOND

      DIMENSION SKG(NDOF,NDOF),SMG(NDOF,NDOF),COORDS(2,NCOR),
     1          IRNODES_WO(NCOND_WO),
     2          IMNODES(NCOND),IRNODES(NCOND)

C     LOCAL VARIABLES

      COMPLEX*16 SKAUX,SKBLOCH, FI, FCI, FR, FCR,
     1           XJ, RFACT, SKBLOCH2
      DIMENSION SKAUX(NDOF,NDOF),
     1          SKBLOCH(NDOF-2*NCOND,NDOF-2*NCOND),IANODES(2*NCOND),
     2          EVALS(NDOF),
     3          EIGVALS(NKX*NKY,NEVALS+2),
     4          SKBLOCH2(NDOF-2*NCOND,NDOF-2*NCOND),
     5          RWORK(3*N-2), WORK(2*N-1)

      DO I=1,NDOF
          DO J=1,NDOF
              SKG(I,J) = SKG(I,J)/(SQRT(SMG(I,I))*SQRT(SMG(J,J)))
          END DO
      END DO

C      DEALLOCATE(SMG)

      XJ=(0.0,1.0)
      SKBLOCH = 0.0
      DO II=1,NCOND
        IANODES(2*II-1) = 2*IMNODES(II)-1
        IANODES(2*II) = 2*IMNODES(II)
      END DO

      DKX = (AKXMAX - AKXMIN)/(NKX-1)  ! X Wave Number step
      DKY = (AKYMAX - AKYMIN)/(NKY-1)  ! Y Wave Number step
      AKX = AKXMIN
      ICONT = 1
      DO IKX=1,NKX

       AKY = AKYMIN
        DO IKY=1,NKY
          SKAUX = DCMPLX(SKG)

C          WRITE(*,100) ICONT, NKX*NKY, AKX, AKY
C100       FORMAT(I5,'/',I5,' kx= ',F6.4,' ky= ',F6.4)

          CALL BLOCH_SEM_BC(SKAUX,NDOF,COORDS,NCOND,NCOND_WO,  ! Bloch BC Imposition
     1                  NCOR,AKX,AKY,IRNODES,IRNODES_WO,
     2                  IMNODES,IANODES,SKBLOCH)

C          CALL BLOCH_SEM_BC2(SKAUX,NDOF,COORDS,NCOND,NCOND_WO,  ! Bloch BC Imposition
C     1                  NCOR,AKX,AKY,IRNODES,IRNODES_WO,
C     2                  IMNODES,IANODES,SKBLOCH)

C          CALL BLOCH_SEM_BC3(SKAUX,NDOF,COORDS,NCOND,NCOR,AKX,AKY,  ! Bloch BC Imposition
C     1                     IRNODES,IMNODES,IANODES,SKBLOCH)

CCCC      SOLUTION  CCCCC

C           CALL DEVAHF(NDOF-2*NCOND,NEVALS,SKBLOCH,NDOF-2*NCOND,.TRUE.,
C     1                EVALS)

           CALL ZHEEV( 'N', 'U', N, SKBLOCH, N, EVALS, WORK, -1, RWORK,
     1                  INFO )

          EIGVALS(ICONT,1) = AKX
          EIGVALS(ICONT,2) = AKY
          EIGVALS(ICONT,3:NEVALS+2) = EVALS(1:NEVALS)

          ICONT = ICONT+1

          AKY = AKY + DKY
        END DO

        AKX = AKX + DKX
      END DO

      RETURN

      END SUBROUTINE BLOCH_SEM

C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE  BLOCH_SEM_BC()                                       C
C                                                                      C
C     Pending...                                                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 11 MARCH 2012                                          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE BLOCH_SEM_BC(SKAUX,NDOF,COORDS,NCOND,NCOND_WO,
     1                    NCOR,AKX,AKY,IRNODES,IRNODES_WO,
     2                    IMNODES,IANODES,SKBLOCH)

      IMPLICIT REAL*8(A-H,O-Z)

      COMPLEX*16 SKAUX,SKBLOCH,FI, FCI, FR,
     1           FCR, XJ, BLOCHAUX

      DIMENSION SKAUX(NDOF,NDOF),
     1          SKBLOCH(NDOF-2*NCOND,NDOF-2*NCOND),
     2          IANODES(2*NCOND),COORDS(2,NCOR),
     3          IRNODES_WO(NCOND_WO),
     4          IMNODES(NCOND),IRNODES(NCOND),
     5          BLOCHAUX(NDOF-2*NCOND,NDOF-2*NCOND)

      XJ=(0.0,1.0)

      DO II=1,NCOND_WO     ! Assigning the Phase shifts for Reference Nodes
        IR = IRNODES_WO(II)
        XR = COORDS(1,IR); YR = COORDS(2,IR)
        FR = EXP(XJ*AKX*XR)*EXP(XJ*AKY*YR)
        FCR= EXP(-XJ*AKX*XR)*EXP(-XJ*AKY*YR)
        CALL CROWMULT(SKAUX,NDOF,SKAUX,2*IR-1,FCR) ! Stiffness
        CALL CROWMULT(SKAUX,NDOF,SKAUX,2*IR,FCR)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,2*IR-1,FR)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,2*IR,FR)
      END DO

      DO II=1,NCOND     ! Assigning the Phase shifts for Image Nodes
        IM = IMNODES(II)
        XI = COORDS(1,IM); YI = COORDS(2,IM)
        FI = EXP(XJ*AKX*XI)*EXP(XJ*AKY*YI)
        FCI= EXP(-XJ*AKX*XI)*EXP(-XJ*AKY*YI)
        CALL CROWMULT(SKAUX,NDOF,SKAUX,2*IM-1,FCI) ! Stiffness
        CALL CROWMULT(SKAUX,NDOF,SKAUX,2*IM,FCI)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,2*IM-1,FI)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,2*IM,FI)
      END DO

      DO II=1,NCOND            ! Summing rows and columns
        IR = IRNODES(II); IM = IMNODES(II)
        CALL CROWADD(SKAUX,NDOF,SKAUX,2*IM-1,2*IR-1) ! Stiffness
        CALL CROWADD(SKAUX,NDOF,SKAUX,2*IM,2*IR)
        CALL CCOLADD(SKAUX,NDOF,SKAUX,2*IM-1,2*IR-1)
        CALL CCOLADD(SKAUX,NDOF,SKAUX,2*IM,2*IR)

      END DO

      CALL COLROWDEL(SKAUX,NDOF,2*NCOND,SKBLOCH,IANODES) ! Deleting redundant equations

C      The matrices SMBLOCH and SKBLOCH are slightly non-Hermitian
C      so, they are averaged with their conjugated matrices.
      CALL MHERMIT(SKBLOCH,NDOF-2*NCOND,NDOF-2*NCOND,
     1             BLOCHAUX)
      SKBLOCH = 1.0/2.0*(SKBLOCH+BLOCHAUX)

      RETURN

      END SUBROUTINE BLOCH_SEM_BC
C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE  BLOCH_SEM_BC2()                                      C
C                                                                      C
C     Pending...                                                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 11 MARCH 2012                                          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE BLOCH_SEM_BC2(SKAUX,NDOF,COORDS,NCOND,NCOND_WO,
     1                    NCOR,AKX,AKY,IRNODES,IRNODES_WO,
     2                    IMNODES,IANODES,SKBLOCH)

      IMPLICIT REAL*8(A-H,O-Z)

      INTEGER CONT

      COMPLEX*16 SKAUX, SKBLOCH, FAC,
     1           FCR, XJ, BLOCHAUX,TMAT,THMAT, AMAUX

      DIMENSION SKAUX(NDOF,NDOF), SMAUX(NDOF,NDOF),
     1          SKBLOCH(NDOF-2*NCOND,NDOF-2*NCOND),
     2          IANODES(2*NCOND),COORDS(2,NCOR),
     3          IRNODES_WO(NCOND_WO),
     4          IMNODES(NCOND),IRNODES(NCOND),
     5          BLOCHAUX(NDOF-2*NCOND,NDOF-2*NCOND),
     6          TMAT(NDOF,NDOF-2*NCOND),
     7          THMAT(NDOF-2*NCOND,NDOF),
     8          INDEXVEC(NDOF),INDEXREF(NDOF),
     9          AMAUX(NDOF,NDOF-2*NCOND)

      XJ=(0.0,1.0)

      INDEXVEC = 0
      DO I=1,NCOND
        INDEXVEC(2*IMNODES(I)-1) = -(2*IRNODES(I)-1)
        INDEXVEC(2*IMNODES(I)) = -2*IRNODES(I)
      END DO
      INDEXREF = - INDEXVEC

      DO I=1,NDOF
        CONT = 0
        DO J=1,NCOND
          IF (INDEXVEC(I)<0)THEN
            IF( 2*IMNODES(J)<ABS(INDEXVEC(I)) )THEN
              CONT = CONT + 1
            END IF
          ELSEIF (2*IMNODES(J)<I)THEN
            CONT = CONT + 1
          END IF
        END DO
        IF(INDEXVEC(I)<0)THEN
          INDEXVEC(I) = INDEXVEC(I) + 2*CONT
        ELSE
          INDEXVEC(I) = I - 2*CONT
        END IF
      END DO

      TMAT = 0
      DO I=1,NDOF
        IF(INDEXVEC(I)>0)THEN
          J = INDEXVEC(I)
          TMAT(I,J) = 1
        ELSE
          J = ABS(INDEXVEC(I))
          IR = (INDEXREF(I)+1)/2; IM = (I+1)/2
          XI = COORDS(1,IM); YI = COORDS(2,IM)
          XR = COORDS(1,IR); YR = COORDS(2,IR)
          FAC = EXP(XJ*AKX*(XI-XR))*EXP(XJ*AKY*(YI-YR))
          TMAT(I,J) = FAC
        END IF
      END DO

      CALL MHERMIT(TMAT,NDOF,NDOF-2*NCOND,THMAT)
      CALL CMMULT(SKAUX,NDOF,NDOF,TMAT,NDOF,NDOF-2*NCOND,AMAUX)
      CALL CMMULT(THMAT,NDOF-2*NCOND,NDOF,AMAUX,NDOF,NDOF-2*NCOND,
     1            SKBLOCH)

C      The matrices SMBLOCH and SKBLOCH are slightly non-Hermitian
C      so, they are averaged with their conjugated matrices.
      CALL MHERMIT(SKBLOCH,NDOF-2*NCOND,NDOF-2*NCOND,
     1             BLOCHAUX)
      SKBLOCH = 1.0/2.0*(SKBLOCH+BLOCHAUX)

      RETURN

      END SUBROUTINE BLOCH_SEM_BC2
C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE  BLOCH_SEM_BC3()                                      C
C                                                                      C
C     Pending...                                                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 02 APRIL 2012                                          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE BLOCH_SEM_BC3(SKAUX,NDOF,COORDS,NCOND,NCOR,AKX,
     1                     AKY,IRNODES,IMNODES,IANODES,SKBLOCH)

      IMPLICIT REAL*8(A-H,O-Z)

      COMPLEX*16 SKAUX, SKBLOCH,FI, FCI, FR, XJ

      DIMENSION SKAUX(NDOF,NDOF),
     1          SKBLOCH(NDOF-2*NCOND,NDOF-2*NCOND),
     2          IANODES(2*NCOND),COORDS(2,NCOR),
     3          IMNODES(NCOND),IRNODES(NCOND)

      XJ=(0.0,1.0)

      DO II=1,NCOND     ! Assigning the Phase shifts
        IM = IMNODES(II)
        XI = COORDS(1,IM); YI = COORDS(2,IM)
        IR = IRNODES(II)
        XR = COORDS(1,IR); YR = COORDS(2,IR)
        FI = EXP(XJ*AKX*(XI-XR))*EXP(XJ*AKY*(YI-YR))
        FCI= EXP(-XJ*AKX*XI)*EXP(-XJ*AKY*YI)
        CALL CROWMULT(SKAUX,NDOF,SKAUX,2*IM-1,FCI) ! Stiffness
        CALL CROWMULT(SKAUX,NDOF,SKAUX,2*IM,FCI)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,2*IM-1,FI)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,2*IM,FI)

      END DO

      DO II=1,NCOND            ! Summing rows and columns
        IR = IRNODES(II); IM = IMNODES(II)
        CALL CROWADD(SKAUX,NDOF,SKAUX,2*IM-1,2*IR-1) ! Stiffness
        CALL CROWADD(SKAUX,NDOF,SKAUX,2*IM,2*IR)
        CALL CCOLADD(SKAUX,NDOF,SKAUX,2*IM-1,2*IR-1)
        CALL CCOLADD(SKAUX,NDOF,SKAUX,2*IM,2*IR)
      END DO

      CALL COLROWDEL(SKAUX,NDOF,2*NCOND,SKBLOCH,IANODES) ! Deleting redundant equations
      RETURN

      END SUBROUTINE BLOCH_SEM_BC3


      DOUBLE PRECISION FUNCTION DOT(X,Y,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(*), Y(*)
************************************************************************
*
*   DOT FORMS THE SCALAR PRODUCT OF TWO VECTORS.
*
*   ON INPUT     X   =    FIRST VECTOR, OF LENGTH N.
*                Y   =    SECOND VECTOR, OF LENGTH N.
*
*   ON RETURN    DOT =    DOT PRODUCT OF X AND Y.
*
************************************************************************
      DOT = 0.0D0
      DO 10 I=1,N
   10 DOT = DOT + X(I)*Y(I)
      RETURN
      END


!! This would generally be supplied by the user

SUBROUTINE  rpn2qad_flux(meqn,maux,idir,iface,q,auxvec,flux)

    IMPLICIT NONE

    INTEGER meqn,maux,idir, iface
    DOUBLE PRECISION q(meqn), flux(meqn)
    DOUBLE PRECISION auxvec(maux)

    DOUBLE PRECISION urot, g, nv(2), u(2)
    integer m

    g = auxvec(12+iface)  !! Edge length for iface = 0,1,2,3

    u(1) = auxvec(2)
    u(2) = auxvec(3)

    nv(1) = auxvec(4+4*idir)
    nv(2) = auxvec(5+4*idir)

    urot = g*(nv(1)*u(1) + nv(2)*u(2))

    DO m = 1,meqn
        !! # Scaling done here (unlike in ForestClaw)
        flux(m) = urot*q(m)
    ENDDO

END SUBROUTINE rpn2qad_flux


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! The Reaction Rates File
!
! Generated by KPP-2.1 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                 : redhc_made_soa_vbs_Rates.f90
! Time                 : Wed Oct 28 17:42:24 2020
! Working directory    : /mnt/lfs1/BMC/fim/Jordan/models/rapid-refresh/WRFV3.9_RAPCHEM_v7/chem/KPP/mechanisms/redhc_made_soa_vbs
! Equation file        : redhc_made_soa_vbs.kpp
! Output root filename : redhc_made_soa_vbs
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE redhc_made_soa_vbs_Rates

  USE redhc_made_soa_vbs_Parameters
  USE redhc_made_soa_vbs_Global
  IMPLICIT NONE

CONTAINS

! Begin Rate Law Functions from KPP_HOME/util/UserRateLaws

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  User-defined Rate Law functions
!  Note: the default argument type for rate laws, as read from the equations file, is single precision
!        but all the internal calculations are performed in double precision
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~>  Arrhenius
   REAL(kind=dp) FUNCTION ARR( A0,B0,C0 )
      REAL A0,B0,C0
      ARR =  DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0_dp)**DBLE(C0)
   END FUNCTION ARR

!~~~> Simplified Arrhenius, with two arguments
!~~~> Note: The argument B0 has a changed sign when compared to ARR
   REAL(kind=dp) FUNCTION ARR2( A0,B0 )
      REAL A0,B0
      ARR2 =  DBLE(A0) * EXP( DBLE(B0)/TEMP )
   END FUNCTION ARR2

   REAL(kind=dp) FUNCTION EP2(A0,C0,A2,C2,A3,C3)
      REAL A0,C0,A2,C2,A3,C3
      REAL(dp) K0,K2,K3
      K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP)
      K3 = K3*CFACTOR*1.0E6_dp
      EP2 = K0 + K3/(1.0_dp+K3/K2 )
   END FUNCTION EP2

   REAL(kind=dp) FUNCTION EP3(A1,C1,A2,C2)
      REAL A1, C1, A2, C2
      REAL(dp) K1, K2
      K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      EP3 = K1 + K2*(1.0E6_dp*CFACTOR)
   END FUNCTION EP3

   REAL(kind=dp) FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF)
      REAL A0,B0,C0,A1,B1,C1,CF
      REAL(dp) K0, K1
      K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0_dp)**DBLE(C0)
      K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0_dp)**DBLE(C1)
      K0 = K0*CFACTOR*1.0E6_dp
      K1 = K0/K1
      FALL = (K0/(1.0_dp+K1))*   &
           DBLE(CF)**(1.0_dp/(1.0_dp+(LOG10(K1))**2))
   END FUNCTION FALL

  !---------------------------------------------------------------------------

  ELEMENTAL REAL(dp) FUNCTION k_3rd(temp,cair,k0_300K,n,kinf_300K,m,fc)

    INTRINSIC LOG10

    REAL(dp), INTENT(IN) :: temp      ! temperature [K]
    REAL(dp), INTENT(IN) :: cair      ! air concentration [molecules/cm3]
    REAL,     INTENT(IN) :: k0_300K   ! low pressure limit at 300 K
    REAL,     INTENT(IN) :: n         ! exponent for low pressure limit
    REAL,     INTENT(IN) :: kinf_300K ! high pressure limit at 300 K
    REAL,     INTENT(IN) :: m         ! exponent for high pressure limit
    REAL,     INTENT(IN) :: fc        ! broadening factor (usually fc=0.6)
    REAL                 :: zt_help, k0_T, kinf_T, k_ratio

    zt_help = 300._dp/temp
    k0_T    = k0_300K   * zt_help**(n) * cair ! k_0   at current T
    kinf_T  = kinf_300K * zt_help**(m)        ! k_inf at current T
    k_ratio = k0_T/kinf_T
    k_3rd   = k0_T/(1._dp+k_ratio)*fc**(1._dp/(1._dp+LOG10(k_ratio)**2))

  END FUNCTION k_3rd

  !---------------------------------------------------------------------------

  ELEMENTAL REAL(dp) FUNCTION k_arr (k_298,tdep,temp)
    ! Arrhenius function

    REAL,     INTENT(IN) :: k_298 ! k at T = 298.15K
    REAL,     INTENT(IN) :: tdep  ! temperature dependence
    REAL(dp), INTENT(IN) :: temp  ! temperature

    INTRINSIC EXP

    k_arr = k_298 * EXP(tdep*(1._dp/temp-3.3540E-3_dp)) ! 1/298.15=3.3540e-3

  END FUNCTION k_arr

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  End of User-defined Rate Law functions
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! End Rate Law Functions from KPP_HOME/util/UserRateLaws

! Begin INLINED Rate Law Functions

REAL(KIND=dp) FUNCTION usro3j2oh(temp,c_m,c_h2o)

   REAL(KIND=dp), INTENT(IN) :: temp, c_m, c_h2o
   REAL(KIND=dp) :: kh2o,kn2,ko2

   kh2o = 2.2e-10_dp
   kn2  = 0.79_dp * ARR2(1.8e-11_dp,-110.0_dp, temp)
   ko2  = 0.21_dp * ARR2(3.2e-11_dp, -70.0_dp, temp)

   usro3j2oh = (kh2o*c_h2o) / (kh2o*c_h2o + kn2*c_m + ko2*c_m)

END FUNCTION usro3j2oh

REAL(KIND=dp) FUNCTION TROEMS(k0_300K,n,kinf_300K,m,TEMP,C_M)

    INTRINSIC LOG10

    REAL(KIND=dp), INTENT(IN) :: TEMP      ! TEMPerature [K]
    REAL(KIND=dp), INTENT(IN) :: C_M      ! air concentration [molecules/cm3]
    REAL(KIND=dp), INTENT(IN) :: k0_300K   ! low pressure limit at 300 K
    REAL(KIND=dp), INTENT(IN) :: n         ! exponent for low pressure limit
    REAL(KIND=dp), INTENT(IN) :: kinf_300K ! high pressure limit at 300 K
    REAL(KIND=dp), INTENT(IN) :: m         ! exponent for high pressure limit
    REAL(KIND=dp)             :: zt_help, k0_T, kinf_T, k_ratio

    zt_help = TEMP/300._dp
    k0_T    = k0_300K   * zt_help**(n) * C_M ! k_0   at current T
    kinf_T  = kinf_300K * zt_help**(m)        ! k_inf at current T
    k_ratio = k0_T/kinf_T
    TROEMS   = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2))

END FUNCTION TROEMS

REAL(KIND=dp) FUNCTION usr5( temp, c_m )

    REAL(KIND=dp), INTENT(IN) :: temp
    REAL(KIND=dp), INTENT(IN) :: c_m

    REAL(KIND=dp) :: k0, k2

   k0 = c_m * 6.5e-34_dp * exp( 1335._dp/temp )
   k2 = exp( 2199._dp/temp )
   k0 = k0 /(1.0_dp + k0/(2.7e-11_dp*k2))
   k2 = exp( 460._dp/temp )

   usr5 = k0 + 2.4e-14_dp * k2

END FUNCTION usr5

REAL(KIND=dp) FUNCTION usr8( temp, c_m )

    REAL(KIND=dp), INTENT(IN) :: temp
    REAL(KIND=dp), INTENT(IN) :: c_m

    REAL(KIND=dp), parameter :: boltz = 1.38044e-16_dp

    usr8 = 1.5e-13_dp * (1._dp + 6.e-7_dp*boltz*c_m*temp)

END FUNCTION usr8

REAL(KIND=dp) FUNCTION usr9( temp, c_m, c_h2o )

    REAL(KIND=dp), INTENT(IN) :: temp
    REAL(KIND=dp), INTENT(IN) :: c_m
    REAL(KIND=dp), INTENT(IN) :: c_h2o

    REAL(KIND=dp) :: ko, kinf, fc

    if( c_h2o > 0._dp ) then
       ko   = 2.3e-13_dp * exp( 600._dp/temp )
       kinf = 1.7e-33_dp * c_m * exp( 1000._dp/temp )
       fc   = 1._dp/c_h2o + 1.4e-21_dp * exp( 2200._dp/temp )
       usr9 = (ko + kinf) * fc
    else
       usr9 = 0._dp
    end if

END FUNCTION usr9

REAL(KIND=dp) FUNCTION usr16( rh, temp )

    REAL(KIND=dp), INTENT(IN) :: rh                       ! relative humidity
    REAL(KIND=dp), INTENT(IN) :: temp                     ! temperature (K)

    usr16 = 0._dp

END FUNCTION usr16

REAL(KIND=dp) FUNCTION usr17( rh, temp )

    REAL(KIND=dp), INTENT(IN) :: rh                       ! relative humidity
    REAL(KIND=dp), INTENT(IN) :: temp                     ! temperature (K)

    usr17 = 0._dp

END FUNCTION usr17

REAL(KIND=dp) FUNCTION usr17a( rh, temp )

    REAL(KIND=dp), INTENT(IN) :: rh                       ! relative humidity
    REAL(KIND=dp), INTENT(IN) :: temp                     ! temperature (K)

    usr17a = 0._dp

END FUNCTION usr17a

REAL(KIND=dp) FUNCTION usr23( temp, c_m )

    REAL(KIND=dp), INTENT(IN) :: temp
    REAL(KIND=dp), INTENT(IN) :: c_m

    REAL(KIND=dp) :: fc, k0
    REAL(KIND=dp) :: wrk

    fc    = 3.e-11_dp * (300._dp/temp) ** 3.3_dp
    wrk   = fc * c_m
    k0    = wrk / (1._dp + wrk/1.5e-12_dp)
    usr23 = k0 * .6_dp ** (1._dp/(1._dp + (log10( wrk/1.5e-12_dp ))**2._dp))

END FUNCTION usr23

REAL(KIND=dp) FUNCTION usr24( temp, c_m )

    REAL(KIND=dp), INTENT(IN) :: temp
    REAL(KIND=dp), INTENT(IN) :: c_m

    REAL(KIND=dp) :: ko, wrk

    wrk   = .21_dp*c_m
    ko    = 1._dp + 5.5e-31_dp*exp( 7460._dp/temp )*wrk
    usr24 = 1.7e-42_dp*exp( 7810._dp/temp )*wrk/ko

END FUNCTION usr24

REAL(KIND=dp) FUNCTION usr_c2o3_no2( c_m )

    REAL(KIND=dp), INTENT(IN) :: c_m

    REAL(KIND=dp) :: ko, kinf, wrk

    ko    = 2.6e-28_dp * c_m
    kinf  = 1.2e-11_dp
    wrk   = ko/kinf
    usr_c2o3_no2 = (ko/(1._dp+wrk))*.6_dp**(1._dp/(1._dp+(log10(wrk))**2))

END FUNCTION usr_c2o3_no2

REAL(KIND=dp) FUNCTION usr_xo2n_ho2( temp )

    REAL(KIND=dp), INTENT(IN) :: temp

    REAL(KIND=dp) :: rxn_xo2_no, rxn_xo2n_no, rxn_xo2_ho2

    rxn_xo2_no  = ARR2( 4.2e-12_dp, -180._dp, temp )
    rxn_xo2n_no = 6.8e-13_dp
    rxn_xo2_ho2 = ARR2( 3.5e-13_dp, -1000._dp, temp )
    usr_xo2n_ho2 = rxn_xo2n_no * rxn_xo2_ho2 / (rxn_xo2_no + 1.e-36_dp)

END FUNCTION usr_xo2n_ho2

REAL(KIND=dp) FUNCTION usr26( rh, temp )

    REAL(KIND=dp), INTENT(IN) :: rh                       ! relative humidity
    REAL(KIND=dp), INTENT(IN) :: temp                     ! temperature (K)

    usr26 = 0._dp

END FUNCTION usr26

! End INLINED Rate Law Functions

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_SUN - update SUN light using TIME
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  SUBROUTINE Update_SUN()
      !USE redhc_made_soa_vbs_Parameters
      !USE redhc_made_soa_vbs_Global

    IMPLICIT NONE

    REAL(kind=dp) SunRise, SunSet
    REAL(kind=dp) Thour, Tlocal, Ttmp

    SunRise = 4.5_dp
    SunSet  = 19.5_dp
    Thour = TIME/3600.0_dp
    Tlocal = Thour - (INT(Thour)/24)*24

    IF ((Tlocal>=SunRise).AND.(Tlocal<=SunSet)) THEN
       Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise)
       IF (Ttmp.GT.0) THEN
          Ttmp =  Ttmp*Ttmp
       ELSE
          Ttmp = -Ttmp*Ttmp
       END IF
       SUN = ( 1.0_dp + COS(PI*Ttmp) )/2.0_dp
    ELSE
       SUN = 0.0_dp
    END IF

 END SUBROUTINE Update_SUN

! End of Update_SUN function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_RCONST - function to update rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_RCONST ( )

! Begin INLINED RCONST

! End INLINED RCONST

  RCONST(1) = (j(Pj_o31d)*usro3j2oh(temp,c_m,c_h2o))
  RCONST(2) = (j(Pj_no2))
  RCONST(3) = (j(Pj_n2o5))
  RCONST(4) = (j(Pj_hno3))
  RCONST(5) = (j(Pj_no3o))
  RCONST(6) = (j(Pj_hno4))
  RCONST(7) = (j(Pj_ch2or))
  RCONST(8) = (j(Pj_ch2om))
  RCONST(9) = (j(Pj_h2o2))
  RCONST(10) = (j(Pj_ch3cho))
  RCONST(11) = (j(Pj_ch3cocho))
  RCONST(12) = (j(Pj_pan))
  RCONST(13) = (j(Pj_ch3o2h))
  RCONST(14) = (j(Pj_ch3o2h))
  RCONST(15) = (ARR2(1.7e-12_dp,940.0_dp,TEMP))
  RCONST(16) = (ARR2(1.0e-14_dp,490.0_dp,TEMP))
  RCONST(17) = (usr9(temp,c_m,c_h2o))
  RCONST(18) = (ARR2(2.9e-12_dp,160.0_dp,TEMP))
  RCONST(19) = (ARR2(4.8e-11_dp,-250.0_dp,TEMP))
  RCONST(20) = (ARR2(4.2e-12_dp,240.0_dp,TEMP))
  RCONST(21) = (TROE(6.90e-31_dp,1.0_dp,2.60e-11_dp,0.0_dp,TEMP,C_M))
  RCONST(22) = (ARR2(3.5e-12_dp,-250.0_dp,TEMP))
  RCONST(23) = (ARR2(3.0e-12_dp,1500.0_dp,TEMP))
  RCONST(24) = (ARR2(1.2e-13_dp,2450.0_dp,TEMP))
  RCONST(25) = (ARR2(4.0e-12_dp,-170.0_dp,TEMP))
  RCONST(26) = (TROE(2.e-30_dp,4.4_dp,1.4e-12_dp,.7_dp,TEMP,C_M))
  RCONST(27) = (TROEE(3.333e26_dp,10900._dp,2.2e-30_dp,4.4_dp,1.4e-12_dp,.7_dp,TEMP,C_M))
  RCONST(28) = (TROE(2.e-30_dp,3._dp,2.5e-11_dp,0._dp,TEMP,C_M))
  RCONST(29) = (usr5(TEMP,C_M))
  RCONST(30) = (ARR2(1.5e-11_dp,-170._dp,TEMP))
  RCONST(31) = (TROE(1.8e-31_dp,3.2_dp,4.7e-12_dp,1.4_dp,TEMP,C_M))
  RCONST(32) = (ARR2(1.3e-12_dp,-380._dp,TEMP))
  RCONST(33) = (TROEE(4.76e26_dp,10900._dp,1.8e-31_dp,3.2_dp,4.7e-12_dp,1.4_dp,TEMP,C_M))
  RCONST(34) = (ARR2(6.e-13_dp,2058._dp,TEMP))
  RCONST(35) = (9.e-12_dp)
  RCONST(36) = (usr8(temp,c_m))
  RCONST(37) = (ARR2(1.1D+2,1710.0_dp,TEMP))
  RCONST(38) = (ARR2(7.e-12_dp,-250._dp,TEMP))
  RCONST(39) = (2.5e-15_dp)
  RCONST(40) = (ARR2(8.1e-12_dp,-270._dp,TEMP))
  RCONST(41) = (usr_c2o3_no2(c_m))
  RCONST(42) = (ARR2(2.e16_dp,13500._dp,TEMP))
  RCONST(43) = (2.e-12_dp)
  RCONST(44) = (6.5e-12_dp)
  RCONST(45) = (8.1e-13_dp)
  RCONST(46) = (ARR2(1.1e-15_dp,8000._dp,TEMP))
  RCONST(47) = (1.6e3_dp)
  RCONST(48) = (ARR2(5.2e-12_dp,-504._dp,TEMP))
  RCONST(49) = (ARR2(4.33e-15_dp,1800._dp,TEMP))
  RCONST(50) = (7.7e-15_dp)
  RCONST(51) = (ARR2(9.1e-15_dp,2850._dp,TEMP))
  RCONST(52) = (TROEMS(1.0D-28,-0.8_dp,8.8D-12,0.0_dp,TEMP,C_M))
  RCONST(53) = (1.5e-11_dp)
  RCONST(54) = (ARR2(2.54e-11_dp,-410._dp,TEMP))
  RCONST(55) = (ARR2(1.23e-14_dp,2013._dp,TEMP))
  RCONST(56) = (ARR2(3.03e-12_dp,446.0_dp,TEMP))
  RCONST(57) = (3.2e-12_dp)
  RCONST(58) = (ARR2(5.9e-13_dp,360._dp,TEMP))
  RCONST(59) = (ARR2(2.6e-12_dp,-365._dp,TEMP))
  RCONST(60) = (ARR2(1.7e-14_dp,-1300._dp,TEMP))
  RCONST(61) = (6.8e-13_dp)
  RCONST(62) = (ARR2(3.5e-13_dp,-1000._dp,TEMP))
  RCONST(63) = (usr_xo2n_ho2(TEMP))
  RCONST(64) = (8.e-11_dp)
  RCONST(65) = (usr23(TEMP,C_M))
  RCONST(66) = (ARR2(1.7e-12_dp,710._dp,TEMP))
  RCONST(67) = (5.5e-11_dp)
  RCONST(68) = (ARR2(1.2D-15,821.0_dp,TEMP))
  RCONST(69) = (ARR2(1.5D-11,-449.0_dp,TEMP))
  RCONST(70) = (ARR2(3.7D-12,-175.0_dp,TEMP))
  RCONST(71) = (5.60D-16)
  RCONST(72) = (2.52D-10)
  RCONST(73) = (2.20D-11)
  RCONST(74) = (ARR2(4.40D-15,845.0_dp,TEMP))
  RCONST(75) = (ARR2(1.33D-11,-500.0_dp,TEMP))
  RCONST(76) = (RATE_CVPOA)
  RCONST(77) = (RATE_CVPOA)
  RCONST(78) = (RATE_CVPOA)
  RCONST(79) = (RATE_CVPOA)
  RCONST(80) = (RATE_CVASOA)
  RCONST(81) = (RATE_CVASOA)
  RCONST(82) = (RATE_CVASOA)
  RCONST(83) = (RATE_CVASOA0)
  RCONST(84) = (RATE_CVBSOA)
  RCONST(85) = (RATE_CVBSOA)
  RCONST(86) = (RATE_CVBSOA)
  RCONST(87) = (2.3D-11)
  RCONST(88) = (ARR2(1.64D-11,125.0_dp,TEMP))
  RCONST(89) = (ARR2(8.64D-13,-450.0_dp,TEMP))

END SUBROUTINE Update_RCONST

! End of Update_RCONST function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_PHOTO - function to update photolytical rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_PHOTO ( )

   USE redhc_made_soa_vbs_Global

  RCONST(1) = (j(Pj_o31d)*usro3j2oh(temp,c_m,c_h2o))
  RCONST(2) = (j(Pj_no2))
  RCONST(3) = (j(Pj_n2o5))
  RCONST(4) = (j(Pj_hno3))
  RCONST(5) = (j(Pj_no3o))
  RCONST(6) = (j(Pj_hno4))
  RCONST(7) = (j(Pj_ch2or))
  RCONST(8) = (j(Pj_ch2om))
  RCONST(9) = (j(Pj_h2o2))
  RCONST(10) = (j(Pj_ch3cho))
  RCONST(11) = (j(Pj_ch3cocho))
  RCONST(12) = (j(Pj_pan))
  RCONST(13) = (j(Pj_ch3o2h))
  RCONST(14) = (j(Pj_ch3o2h))

END SUBROUTINE Update_PHOTO

! End of Update_PHOTO function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE redhc_made_soa_vbs_Rates


module sfldy
  use ode

  type SFluidQty
    real(dp), allocatable :: w(:) ! Cell width and height and depth.
    real(dp), allocatable :: o(:) ! Offset from top-left of the grid, or top-left-front in 3D.
    real(dp) :: cs                ! Cell size.
  end type SFluidQty

  interface interpolate
    module procedure :: lint
  end interface interpolate
contains

  subroutine sfldyEuler(u, x, h)
    ! Forward Euler for the integration of the velocities.
    implicit none
    class(SFluidQty), intent(in) :: u(:)
    real(dp), intent(in)         :: h ! Fluid vectors (u, v, w), time step
    real(dp), intent(inout)      :: x(:)
    real(dp)                     :: lint
    real(dp)                     :: du(size(u))
    integer                      :: i

    ! Obtain terivatives.
    do i = 1, size(u)
      du(i) = interp(u(i), x) / u(i) % cs
    end do

    ! Integrate x.
    x = x + du * h

  end subroutine sfldyEuler

  function interp(u, x) result(interpolation)
    implicit none
    class(SFluidQty), intent(in)     :: u
    real(dp), intent(in)             :: x(:)
    real(dp)                         :: interpolation
    real(dp), dimension(size(x))     :: xt
    integer,  dimension(size(x))     :: ix
    real(dp), dimension(2**size(x))  :: grid
    real(dp), parameter              :: offset = 1+1d-30

    ! Clamping vertex coordinates.
    xt = min(max(x - u % o, 0._dp), u % w - offset)
    ! Making vertices integers.
    ix = nint(x)
    ! Setting up origin to the top-left or top-left-front corner.
    xt = xt - ix

    ! Find grid positions.
    grid = FindCoord(u, x)

    ! This is for 2D only.
    interpolation = lint( [ lint(grid(1:2), x(1)), lint(grid(3:4), x(1)) ], x(2) )
  end function interp

  function lint(c, x)
    implicit none
    real(dp), intent(in) :: c(:), x ! Coeffcients and x
    real(dp)             :: lint

    lint = ( c(1) - c(2) ) * x - c(1)
  end function lint

  function FindCoord(u, x) result(grid)
    ! Scales the offset to the cell width.
    implicit none
    real(dp), intent(in)         :: x(:)
    class(SFluidQty), intent(in) :: u
    real(dp)                     :: grid(2**size(x)), tmp
    integer                      :: i, j, k, sx, sg
    integer, parameter :: disp(24) = [0,1,0,1,0,1,0,1,0,0,1,1,&
                                      0,0,1,1,0,0,0,0,1,1,1,1]

    sx  = size(x)
    sg  = size(grid)

    ! Loop over Grid Displacements.
    gd: do i = 1, sg
      ! Sum Only Relevant Quantities.
      sorq1: do j = 1, sx
        ! Save the value of x(i) in tmp.
        tmp = x(j) + disp(i + 8*(j-1))
        sorq2: do k = 1, sx
          ! If j = i we need to skip to the next value of j.
          if (j == k) cycle sorq2
          ! Check whether this is correct, do not be an idiot!
          tmp = tmp + ( x(k) + disp(i + 8*(k-1)) ) * u % w(j)
          ! Check whether this is correct, do not be an idiot!
        end do sorq2
        ! Assign tmp to the coordinate i.
        grid(i + 8*(j-1)) = tmp
      end do sorq1
    end do gd
  end function FindCoord

end module sfldy


module vegetables_random_m
    use iso_varying_string, only: varying_string, assignment(=)

    implicit none
    private
    public :: &
            get_random_ascii_character, &
            get_random_ascii_string, &
            get_random_ascii_string_with_max_length, &
            get_random_double_precision_with_magnitude, &
            get_random_double_precision_with_range, &
            get_random_integer, &
            get_random_integer_with_range, &
            get_random_logical
contains
    function get_random_ascii_character() result(random_character)
        character(len=1) :: random_character

        character(len=*), parameter :: ASCII_CHARACTERS = &
        '  !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~'
        integer :: which_character

        which_character = get_random_integer_with_range(1, len(ASCII_CHARACTERS))
        random_character = ASCII_CHARACTERS(which_character:which_character)
    end function

    function get_random_ascii_string() result(random_string)
        type(varying_string) :: random_string

        random_string = get_random_ascii_string_with_max_length(1024)
    end function

    function get_random_ascii_string_with_max_length(max_length) result(random_string)
        integer, intent(in) :: max_length
        type(varying_string) :: random_string

        character(len=max_length) :: characters
        integer :: i
        integer :: num_characters

        num_characters = get_random_integer_with_range(0, max_length)
        do i = 1, num_characters
            characters(i:i) = get_random_ascii_character()
        end do
        random_string = characters(1:num_characters)
    end function

    function get_random_double_precision_with_magnitude(magnitude) result(random_double)
        double precision, intent(in) :: magnitude
        double precision :: random_double

        call random_number(random_double)
        random_double = random_double * magnitude
        if (get_random_logical()) random_double = -random_double
    end function

    function get_random_double_precision_with_range(start, end_) result(random_double)
        double precision, intent(in) :: start
        double precision, intent(in) :: end_
        double precision :: random_double

        call random_number(random_double)
        random_double = start + (end_ - start) * random_double
    end function

    function get_random_integer() result(random_integer)
        integer :: random_integer

        integer, parameter :: MAX_INT = HUGE(1)
        double precision :: random_real

        call random_number(random_real)
        random_integer = floor(random_real*MAX_INT)
        if (get_random_logical()) random_integer = -random_integer
    end function

    function get_random_integer_with_range(start, end_) result(random_integer)
        integer, intent(in) :: start
        integer, intent(in) :: end_
        integer :: random_integer

        double precision :: random_real

        call random_number(random_real)
        random_integer = start + floor((end_ + 1 - start) * random_real)
    end function

    function get_random_logical() result(random_logical)
        logical :: random_logical

        if (get_random_integer_with_range(0, 1) == 0) then
            random_logical = .TRUE.
        else
            random_logical = .FALSE.
        end if
    end function
end module


      REAL*8 FUNCTION PREMSF(M,T,RR)
      REAL*8 RZAMS,M,T,RR
      REAL*8 RZAMSF
      EXTERNAL RZAMSF
*
      RZAMS = RZAMSF(M)
*       Coefficients in PREMSR
      IF(M.LE.1.d0)THEN
         PRE1 = 0d0
         PRE2 = 0d0
         PRE3 = 7.432d-2 - 9.43d-2*M + 7.439d-2*M**2
      ENDIF
      IF(M.GT.1d0.AND.M.LT.2d0)THEN
         PRE1 = -4.00772d0 + 4.00772d0*M
         PRE2 = 8.5656d0 - 8.5656d0*M
         PRE3 = -4.50678d0 + 4.56118d0*M
      ENDIF
      IF(M.GE.2d0)THEN
         PRE1 = 1.60324d0 + 2.20401d0*M - 0.60433d0*M**2
     &        + 5.172d-2*M**3
         PRE2 = -4.56878d0 - 4.05305d0*M + 1.24575*M**2
     &        - 0.10922d0*M**3
         PRE3 = 3.01153 + 1.85745*M - 0.64290d0*M**2
     &        + 5.759d-2*M**3
      END IF
      PREMSF = RZAMS*10**((PRE1*T**3 + PRE2*T**4
     &       + PRE3*T**5)/(1.05 - T)) - RR
      RETURN
      END


subroutine tester
use fdeclarations

implicit none
open (unit=79, file='testdata.txt', status='old', action='read')
read (79,*) ee

allocate(s(ee,zz))
allocate(cer(ee,zz))
allocate(testmat(ee,w-1))

do i=1,ee
read(79,*) (testmat(i,j), j=1,w-1)
end do

write(*,*) 'MODELLING TEST DATA'
write(*,*) '--------------------'
call sleep(2)

ii=n
dmatrix=matrix
!do i=1,n
!write(*,10) (dmatrix(i,j), j=1,w)
!end do
write(*,*) 'Developing rules database ...'
call classifier

open(49, file='log.txt', action='write', status='replace')
write(49,*) ' TEST DATA PARAMETERS'
write(49,*) ' '
write(49,*) ' Classification matrix'
write(49,*) ' V      D      S      T      HS'
do i=1,ii
write(49,10) (cmatrix(i,j), j=1,w)
end do

!write(49,*) ' '
!write(49,*) 'rmatrix'
!do i=1,e
!write(49,10) (rmatrix(i,j), j=1,w-1)
!end do

call combinations

open (unit=59, file='amatrix.txt', status='old', action='read')
read (59,*) nn

allocate(amatrix(nn,w-1))

do i=1,nn
read(59,*) (amatrix(i,j), j=1,w-1)
end do
if (proc==2) then
call ruler

!write(49,*) ' '
!write(49,*) 'p1matrix'
!do i=1,nn
!write(49,10) (p1matrix(i,j), j=1,w+1)
!end do

write(49,*) ' '
write(49,*) ' Bayesian joint probabilities matrix'
write(49,*) ' H      G      M      P      B'
do i=1,nn
write(49,10) (p2matrix(i,j), j=1,w)
end do

write(*,*) 'Development of rules successful!'
write(*,*) ' '
call sleep(2)

write(*,*) 'Fuzzifying inputs ...'

ematrix=testmat
z=ee
call fuzzifier
write(*,*) 'Fuzzification successful!'
write(*,*) ' '

write(*,*) 'Applying the fuzzy rule-based Bayesian algorithm ...'
write(*,*) ' '
call sleep(2)
do i=1,ee
allocate(c1matrix(e**(w-1),w-1))
allocate(tbayh(nn))
allocate(tbayg(nn))
allocate(tbaym(nn))
allocate(tbayp(nn))
allocate(tbayb(nn))
allocate(c2matrix(nn,w-1))

open(29, file='dmatrix.txt', action='write', status='replace')
write(29,*) nn
call permutator
close(29, status='keep')

open (unit=39, file='dmatrix.txt', status='old', action='read')
read (39,*) nn
do jj=1,nn
read(39,*) (c2matrix(jj,j), j=1,w-1)
end do
close(39, status='keep')

do j=1,nn
tbayh(j)=product(c2matrix(j,:))*p2matrix(j,1)
tbayg(j)=product(c2matrix(j,:))*p2matrix(j,2)
tbaym(j)=product(c2matrix(j,:))*p2matrix(j,3)
tbayp(j)=product(c2matrix(j,:))*p2matrix(j,4)
tbayb(j)=product(c2matrix(j,:))*p2matrix(j,5)
end do
!write(49,*) ' '
!write(49,*) 'fmatrix'
!do i=1,nn
!write(49,10) (fmatrix(i,j,jj), j=1,w-1)
!end do
write(*,*) 'Output calculation for observation', i, 'successful'
bayg1(i)=sum(tbayg(1:nn))
baym1(i)=sum(tbaym(1:nn))
bayh1(i)=sum(tbayh(1:nn))
bayp1(i)=sum(tbayp(1:nn))
bayb1(i)=sum(tbayb(1:nn))
deallocate(c1matrix)
deallocate(c2matrix)
deallocate(tbayh)
deallocate(tbayg)
deallocate(tbaym)
deallocate(tbayp)
deallocate(tbayb)
end do
z=ee
call rules2
!write(49,*) ' '
!write(49,*) 'bayH1'
!do i=1,n
!write(49,10) (bayh1(i))
!end do

!write(49,*) ' '
!write(49,*) 'bayb'
!do i=1,nn
!write(49,10) (bayb(i,j), j=1,n)
!end do

write (49,*) ' '
write (49,*) ' Joint probability of High suitability class'
do i=1,ee
write(49,10) (bayh2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Good suitability class'
do i=1,ee
write(49,10) (bayg2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Moderate suitability class'
do i=1,ee
write(49,10) (baym2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Poor suitability class'
do i=1,ee
write(49,10) (bayp2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Bad suitability class'
do i=1,ee
write(49,10) (bayb2(i))
end do

s(:,:)=0.01
s(0,:)=0.01
ik=1
do i=1,ee
hs(i)=bhigh(i)+bgood(i)+bmoderate(i)+bpoor(i)+bbad(i)
if (testmat(i,2)>0) then
if (bayg1(i)<=0 .and. bayh1(i)<=0 .and. baym1(i)<=0 .and. bayp1(i)<=0 .and. bayb1(i)<=0) then
!Loop to find the previous non-zero value
134 if (s(i-ik,zz)<=0) then ! and add it to the current array cell
ik=ik+1
goto 134
else
s(i,zz)=s(i-ik,zz)
cer(i,zz)=0
end if
else
s(i,zz)=hs(i)
cer(i,zz)=1
end if
else
s(i,zz)=0
cer(i,zz)=1
end if
end do

open(19, file='output.txt', action='write', status='replace')
do i=1,ee
write(19,10) (s(i,zz))
end do

else if (proc==1) then
l=2
call ftester
end if
10 format (8f7.3)

if (proc==2) then
open (unit=39, file='dmatrix.txt', status='old', action='read')
close (39, status='delete')
else
goto 699
end if
699 end subroutine tester


*DECK QZVAL
      SUBROUTINE QZVAL (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z)
C***BEGIN PROLOGUE  QZVAL
C***PURPOSE  The third step of the QZ algorithm for generalized
C            eigenproblems.  Accepts a pair of real matrices, one in
C            quasi-triangular form and the other in upper triangular
C            form and computes the eigenvalues of the associated
C            eigenproblem.  Usually preceded by QZHES, QZIT, and
C            followed by QZVEC.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2C
C***TYPE      SINGLE PRECISION (QZVAL-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is the third step of the QZ algorithm
C     for solving generalized matrix eigenvalue problems,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART.
C
C     This subroutine accepts a pair of REAL matrices, one of them
C     in quasi-triangular form and the other in upper triangular form.
C     It reduces the quasi-triangular matrix further, so that any
C     remaining 2-by-2 blocks correspond to pairs of complex
C     eigenvalues, and returns quantities whose ratios give the
C     generalized eigenvalues.  It is usually preceded by  QZHES
C     and  QZIT  and may be followed by  QZVEC.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real upper quasi-triangular matrix.  A is a two-
C          dimensional REAL array, dimensioned A(NM,N).
C
C        B contains a real upper triangular matrix.  In addition,
C          location B(N,1) contains the tolerance quantity (EPSB)
C          computed and saved in  QZIT.  B is a two-dimensional REAL
C          array, dimensioned B(NM,N).
C
C        MATZ should be set to .TRUE. if the right hand transformations
C          are to be accumulated for later use in computing
C          eigenvectors, and to .FALSE. otherwise.  MATZ is a LOGICAL
C          variable.
C
C        Z contains, if MATZ has been set to .TRUE., the transformation
C          matrix produced in the reductions by  QZHES  and  QZIT,  if
C          performed, or else the identity matrix.  If MATZ has been set
C          to .FALSE., Z is not referenced.  Z is a two-dimensional REAL
C          array, dimensioned Z(NM,N).
C
C     On Output
C
C        A has been reduced further to a quasi-triangular matrix in
C          which all nonzero subdiagonal elements correspond to pairs
C          of complex eigenvalues.
C
C        B is still in upper triangular form, although its elements
C          have been altered.  B(N,1) is unaltered.
C
C        ALFR and ALFI contain the real and imaginary parts of the
C          diagonal elements of the triangular matrix that would be
C          obtained if A were reduced completely to triangular form
C          by unitary transformations.  Non-zero values of ALFI occur
C          in pairs, the first member positive and the second negative.
C          ALFR and ALFI are one-dimensional REAL arrays, dimensioned
C          ALFR(N) and ALFI(N).
C
C        BETA contains the diagonal elements of the corresponding B,
C          normalized to be real and non-negative.  The generalized
C          eigenvalues are then the ratios ((ALFR+I*ALFI)/BETA).
C          BETA is a one-dimensional REAL array, dimensioned BETA(N).
C
C        Z contains the product of the right hand transformations
C          (for all three steps) if MATZ has been set to .TRUE.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  QZVAL
C
      INTEGER I,J,N,EN,NA,NM,NN,ISW
      REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*)
      REAL C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR
      REAL U1,U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22
      REAL SQI,SQR,SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R
      REAL A22I,A22R,EPSB
      LOGICAL MATZ
C
C***FIRST EXECUTABLE STATEMENT  QZVAL
      EPSB = B(N,1)
      ISW = 1
C     .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES.
C                FOR EN=N STEP -1 UNTIL 1 DO -- ..........
      DO 510 NN = 1, N
         EN = N + 1 - NN
         NA = EN - 1
         IF (ISW .EQ. 2) GO TO 505
         IF (EN .EQ. 1) GO TO 410
         IF (A(EN,NA) .NE. 0.0E0) GO TO 420
C     .......... 1-BY-1 BLOCK, ONE REAL ROOT ..........
  410    ALFR(EN) = A(EN,EN)
         IF (B(EN,EN) .LT. 0.0E0) ALFR(EN) = -ALFR(EN)
         BETA(EN) = ABS(B(EN,EN))
         ALFI(EN) = 0.0E0
         GO TO 510
C     .......... 2-BY-2 BLOCK ..........
  420    IF (ABS(B(NA,NA)) .LE. EPSB) GO TO 455
         IF (ABS(B(EN,EN)) .GT. EPSB) GO TO 430
         A1 = A(EN,EN)
         A2 = A(EN,NA)
         BN = 0.0E0
         GO TO 435
  430    AN = ABS(A(NA,NA)) + ABS(A(NA,EN)) + ABS(A(EN,NA))
     1      + ABS(A(EN,EN))
         BN = ABS(B(NA,NA)) + ABS(B(NA,EN)) + ABS(B(EN,EN))
         A11 = A(NA,NA) / AN
         A12 = A(NA,EN) / AN
         A21 = A(EN,NA) / AN
         A22 = A(EN,EN) / AN
         B11 = B(NA,NA) / BN
         B12 = B(NA,EN) / BN
         B22 = B(EN,EN) / BN
         E = A11 / B11
         EI = A22 / B22
         S = A21 / (B11 * B22)
         T = (A22 - E * B22) / B22
         IF (ABS(E) .LE. ABS(EI)) GO TO 431
         E = EI
         T = (A11 - E * B11) / B11
  431    C = 0.5E0 * (T - S * B12)
         D = C * C + S * (A12 - E * B12)
         IF (D .LT. 0.0E0) GO TO 480
C     .......... TWO REAL ROOTS.
C                ZERO BOTH A(EN,NA) AND B(EN,NA) ..........
         E = E + (C + SIGN(SQRT(D),C))
         A11 = A11 - E * B11
         A12 = A12 - E * B12
         A22 = A22 - E * B22
         IF (ABS(A11) + ABS(A12) .LT.
     1       ABS(A21) + ABS(A22)) GO TO 432
         A1 = A12
         A2 = A11
         GO TO 435
  432    A1 = A22
         A2 = A21
C     .......... CHOOSE AND APPLY REAL Z ..........
  435    S = ABS(A1) + ABS(A2)
         U1 = A1 / S
         U2 = A2 / S
         R = SIGN(SQRT(U1*U1+U2*U2),U1)
         V1 = -(U1 + R) / R
         V2 = -U2 / R
         U2 = V2 / V1
C
         DO 440 I = 1, EN
            T = A(I,EN) + U2 * A(I,NA)
            A(I,EN) = A(I,EN) + T * V1
            A(I,NA) = A(I,NA) + T * V2
            T = B(I,EN) + U2 * B(I,NA)
            B(I,EN) = B(I,EN) + T * V1
            B(I,NA) = B(I,NA) + T * V2
  440    CONTINUE
C
         IF (.NOT. MATZ) GO TO 450
C
         DO 445 I = 1, N
            T = Z(I,EN) + U2 * Z(I,NA)
            Z(I,EN) = Z(I,EN) + T * V1
            Z(I,NA) = Z(I,NA) + T * V2
  445    CONTINUE
C
  450    IF (BN .EQ. 0.0E0) GO TO 475
         IF (AN .LT. ABS(E) * BN) GO TO 455
         A1 = B(NA,NA)
         A2 = B(EN,NA)
         GO TO 460
  455    A1 = A(NA,NA)
         A2 = A(EN,NA)
C     .......... CHOOSE AND APPLY REAL Q ..........
  460    S = ABS(A1) + ABS(A2)
         IF (S .EQ. 0.0E0) GO TO 475
         U1 = A1 / S
         U2 = A2 / S
         R = SIGN(SQRT(U1*U1+U2*U2),U1)
         V1 = -(U1 + R) / R
         V2 = -U2 / R
         U2 = V2 / V1
C
         DO 470 J = NA, N
            T = A(NA,J) + U2 * A(EN,J)
            A(NA,J) = A(NA,J) + T * V1
            A(EN,J) = A(EN,J) + T * V2
            T = B(NA,J) + U2 * B(EN,J)
            B(NA,J) = B(NA,J) + T * V1
            B(EN,J) = B(EN,J) + T * V2
  470    CONTINUE
C
  475    A(EN,NA) = 0.0E0
         B(EN,NA) = 0.0E0
         ALFR(NA) = A(NA,NA)
         ALFR(EN) = A(EN,EN)
         IF (B(NA,NA) .LT. 0.0E0) ALFR(NA) = -ALFR(NA)
         IF (B(EN,EN) .LT. 0.0E0) ALFR(EN) = -ALFR(EN)
         BETA(NA) = ABS(B(NA,NA))
         BETA(EN) = ABS(B(EN,EN))
         ALFI(EN) = 0.0E0
         ALFI(NA) = 0.0E0
         GO TO 505
C     .......... TWO COMPLEX ROOTS ..........
  480    E = E + C
         EI = SQRT(-D)
         A11R = A11 - E * B11
         A11I = EI * B11
         A12R = A12 - E * B12
         A12I = EI * B12
         A22R = A22 - E * B22
         A22I = EI * B22
         IF (ABS(A11R) + ABS(A11I) + ABS(A12R) + ABS(A12I) .LT.
     1       ABS(A21) + ABS(A22R) + ABS(A22I)) GO TO 482
         A1 = A12R
         A1I = A12I
         A2 = -A11R
         A2I = -A11I
         GO TO 485
  482    A1 = A22R
         A1I = A22I
         A2 = -A21
         A2I = 0.0E0
C     .......... CHOOSE COMPLEX Z ..........
  485    CZ = SQRT(A1*A1+A1I*A1I)
         IF (CZ .EQ. 0.0E0) GO TO 487
         SZR = (A1 * A2 + A1I * A2I) / CZ
         SZI = (A1 * A2I - A1I * A2) / CZ
         R = SQRT(CZ*CZ+SZR*SZR+SZI*SZI)
         CZ = CZ / R
         SZR = SZR / R
         SZI = SZI / R
         GO TO 490
  487    SZR = 1.0E0
         SZI = 0.0E0
  490    IF (AN .LT. (ABS(E) + EI) * BN) GO TO 492
         A1 = CZ * B11 + SZR * B12
         A1I = SZI * B12
         A2 = SZR * B22
         A2I = SZI * B22
         GO TO 495
  492    A1 = CZ * A11 + SZR * A12
         A1I = SZI * A12
         A2 = CZ * A21 + SZR * A22
         A2I = SZI * A22
C     .......... CHOOSE COMPLEX Q ..........
  495    CQ = SQRT(A1*A1+A1I*A1I)
         IF (CQ .EQ. 0.0E0) GO TO 497
         SQR = (A1 * A2 + A1I * A2I) / CQ
         SQI = (A1 * A2I - A1I * A2) / CQ
         R = SQRT(CQ*CQ+SQR*SQR+SQI*SQI)
         CQ = CQ / R
         SQR = SQR / R
         SQI = SQI / R
         GO TO 500
  497    SQR = 1.0E0
         SQI = 0.0E0
C     .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT
C                IF TRANSFORMATIONS WERE APPLIED ..........
  500    SSR = SQR * SZR + SQI * SZI
         SSI = SQR * SZI - SQI * SZR
         I = 1
         TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21
     1      + SSR * A22
         TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22
         DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22
         DI = CQ * SZI * B12 + SSI * B22
         GO TO 503
  502    I = 2
         TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21
     1      + CQ * CZ * A22
         TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21
         DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22
         DI = -SSI * B11 - SQI * CZ * B12
  503    T = TI * DR - TR * DI
         J = NA
         IF (T .LT. 0.0E0) J = EN
         R = SQRT(DR*DR+DI*DI)
         BETA(J) = BN * R
         ALFR(J) = AN * (TR * DR + TI * DI) / R
         ALFI(J) = AN * T / R
         IF (I .EQ. 1) GO TO 502
  505    ISW = 3 - ISW
  510 CONTINUE
C
      RETURN
      END


subroutine evr(cash,nrow,ncol,v,nro,nco,fy,grid,secondd,ev_out)
INTEGER, INTENT(IN) :: nrow, ncol, nro, nco
REAL, INTENT(IN) :: cash(nrow,ncol), v(nro,nco), fy, grid(nco,1), secondd(nco,1)
REAL, INTENT(OUT) :: ev_out(nrow,ncol)
REAL, allocatable :: ones(:,:), inc(:,:), aux(:,:)
ALLOCATE (ones(nrow,ncol),inc(nrow,ncol),aux(nrow,ncol))
ev_out = 0.0
ones= 1.0
inc=fy*ones+cash
inc=MIN(inc,grid(nco,1))
inc=MAX(inc,grid(1,1))
!prob_li = 0.005
prob_li = 0.0
call splint(grid,v(1,:),secondd,nco,inc,nrow,ncol,aux)
ev_out=aux
!inc=2.0  !drop to 10%
inc=5.0  !drop to 25%
call splint(grid,v(1,:),secondd,nco,inc,nrow,ncol,aux)
ev_out=(1-prob_li)*ev_out + prob_li*aux
DEALLOCATE (ones,inc,aux)
end subroutine


SUBROUTINE q_erf(x, erf, erfc)

!   Calculate the error function & its complement in quadruple precision.
!   0 <= x <= 1 uses series 7.1.5 from Abramowitz & Stegun
!   1 < x < 4 uses Chebyshev series
!   4 <= x uses a continued fraction
!
!   If x < 0 then erfc(x) = 1 + erf(|x|) and erf(x) = - erf(|x|)
!
!   WARNING: x must NOT occupy the same locations as any of
!            the other arguments if x < 0.
!
!   Programmer: Alan Miller    Alan.Miller @ vic.cmis.csiro.au
!               www.ozemail.com.au/~milleraj   FAX: (+61) 3-9545-8080
!   Latest revision - (Fortran 77 version) 11 May 1988
!   Latest revision - 4 February 1998

USE quadruple_precision
IMPLICIT NONE
TYPE (quad), INTENT(IN)            :: x
TYPE (quad), INTENT(OUT), OPTIONAL :: erf, erfc

!     Chebyshev coefficients
TYPE (quad), PARAMETER :: coeff(40) = (/ quad(0.4888515056984716D+00, -.1253349490474187D-15),  &
         quad(-.1358986289159460D+00, 0.1828677302762691D-16),  &
         quad(0.3563511414853497D-01, -.1026978994630672D-17),  &
         quad(-.8884098618222492D-02, 0.1869288268188562D-17),  &
         quad(0.2118423997553177D-02, 0.1709987556862464D-18),  &
         quad(-.4853987640800370D-03, -.6960364726525852D-19),  &
         quad(0.1072737545377177D-03, 0.1534550435363124D-19),  &
         quad(-.2293663448190487D-04, 0.6928883131080608D-20),  &
         quad(0.4756874691575556D-05, -.1627977086918653D-20),  &
         quad(-.9589944832662770D-06, -.2249363452839194D-22),  &
         quad(0.1882900688295897D-06, -.1968876883111176D-22),  &
         quad(-.3606320662143092D-07, 0.7483138202418590D-23),  &
         quad(0.6747602051937456D-08, -.1005646109123554D-23),  &
         quad(-.1234907042333986D-08, -.8553919151789978D-25),  &
         quad(0.2213150119337267D-09, -.8378636504284192D-27),  &
         quad(-.3887955444797815D-10, 0.4599438293044550D-27),  &
         quad(0.6701388253274512D-11, -.4533239266031100D-27),  &
         quad(-.1134237426103359D-11, -.2592968654684961D-27),  &
         quad(0.1886555920176928D-12, -.9535048043067878D-29),  &
         quad(-.3085780489354876D-13, 0.7801557018723816D-29),  &
         quad(0.4966710292058390D-14, -.1626370800837245D-29),  &
         quad(-.7871154824211008D-15, 0.8389350837750800D-31),  &
         quad(0.1228887884514987D-15, -.5265492467954702D-31),  &
         quad(-.1891087633190591D-16, -.2388153131040173D-32),  &
         quad(0.2869742042877464D-17, 0.7703719777548944D-34),  &
         quad(-.4296338289538412D-18, 0.9629649721936182D-35),  &
         quad(0.6348319360536490D-19, -.7222237291452136D-35),  &
         quad(-.9261746469308854D-20, -.1805559322863034D-35),  &
         quad(0.1334626827242897D-20, 0.2633107345841924D-36),  &
         quad(-.1900244302571750D-21, 0.3761581922631320D-37),  &
         quad(0.2674133030089899D-22, -.4701977403289150D-38),  &
         quad(-.3720610299437181D-23, -.2938735877055719D-39),  &
         quad(0.5119522849758822D-24, -.1578156674465586D-56),  &
         quad(-.6968654298053806D-25, -.2295887403949780D-41),  &
         quad(0.9386117844916958D-26, -.2008901478456058D-41),  &
         quad(-.1251273661158375D-26, 0.5022253696140144D-42),  &
         quad(0.1651286941713772D-27, -.3587324068671532D-43),  &
         quad(-.2157623168556909D-28, -.5605193857299268D-45),  &
         quad(0.2771990968956549D-29, -.3503246160812043D-45),  &
         quad(-.3468792422835851D-30, 0.7006492321624086D-46) /)

!       Local variables

TYPE (quad) :: d, dd, term, arg, y2, sv, xx, y, temp, erff, erfcc
REAL (dp)   :: a
INTEGER     :: m, j
LOGICAL     :: small
TYPE (quad), PARAMETER :: qone = quad(1._dp, 0._dp), qzero = quad(0._dp, 0._dp)

IF (x%hi < 0.d0) THEN
  arg = -x
ELSE
  arg = x
END IF

IF (arg%hi > 1._dp) GO TO 20
!----------------------------------------------------------------------
!
!                  2x          x^2   x^4    x^6
!       erf(x) = --------.(1 - --- + ---- - ---- + .. )
!                sqrt(pi)      1.3   2!.5   3!.7
!
!
small = .false.
term = two_on_rtpi * arg
erff = term
xx = arg * arg
m = 1
DO
  IF (small) THEN
    term%hi = - term%hi * xx%hi / m
    temp%hi = term%hi / (2*m + 1)
    temp%lo = 0._dp
  ELSE
    term = - term * xx
    SELECT CASE (m)
      CASE (1)
        term = term
      CASE (2)
        term = SCALE(term, -1)
      CASE (4)
        term = SCALE(term, -2)
      CASE (8)
        term = SCALE(term, -3)
      CASE DEFAULT
        term = term / DBLE(m)
    END SELECT
    temp = term / DBLE(2*m+1)
  END IF
  erff = erff + temp
  m = m + 1
  IF (.NOT. small .AND. ABS(temp%hi) < erff%hi * 1.d-16) small = .true.
  IF (ABS(temp%hi) < erff%hi * 1.d-30) EXIT
END DO

erfcc = qone - erff

GO TO 60
!
!----------------------------------------------------------------------
!
!    Use Chebyshev series for 1 < x < 4.
!    Adapted from the routine CHEBEV from 'Numerical Recipes' by Press,
!    Flannery, Teukolsky & Vetterling, Cambridge Uni Press, 1986.
!
20 IF (arg%hi >= 4._dp) GO TO 40
d = qzero
dd = qzero
y = (arg - 2.5_dp) / 1.5_dp
y2 = SCALE(y, 1)
DO j = 40, 2, -1
  sv = d
  d = y2 * d - dd + coeff(j)
  dd = sv
END DO
term = y * d - dd + SCALE(coeff(1), -1)

!     Finally multiply by exp(-x^2)

erfcc = term * EXP(-x*x)
erff = qone - erfcc

GO TO 60

!----------------------------------------------------------------------
!
!       Use a continued fraction for x >= 4.0

40 a = 0.5D0 * INT(230._dp/arg%hi) + 2._dp
erfcc = qzero
DO
  erfcc = erfcc + arg
  erfcc = quad(a, 0._dp) / erfcc
  a = a - 0.5D0
  IF (a < 0.1D0) EXIT
END DO
erfcc = erfcc + arg
erfcc = qone / erfcc

!       Multiply result by exp(-x**2) / sqrt(pi)

erfcc = erfcc * EXP(-x*x) / sqrtpi
erff = qone - erfcc

!       Replace erf & erfc if argument was negative.

60 IF (x%hi < 0._dp) THEN
  erfcc = qone + erff
  erff = -erff
END IF

IF (PRESENT(erf)) erf = erff
IF (PRESENT(erfc)) erfc = erfcc

RETURN
END SUBROUTINE q_erf

PROGRAM test_q_erf
! Test quadruple-precision erf function by approximating its first derivative
! using divided differences.
! f'(x) = [f(x-2h) - 8.f(x-h) + 8.f(x+h) - f(x-2h)] / (12.h)  approx.

USE quadruple_precision
IMPLICIT NONE

TYPE (quad) :: x, h, arg, erf_2, erf_1, erf1, erf2, erfc, av_erfc,  &
               d_est, deriv, error
TYPE (quad), PARAMETER :: qone = quad(1._dp, 0._dp)

INTERFACE
  SUBROUTINE q_erf(x, erf, erfc)
    USE quadruple_precision
    IMPLICIT NONE
    TYPE (quad), INTENT(IN)            :: x
    TYPE (quad), INTENT(OUT), OPTIONAL :: erf, erfc
  END SUBROUTINE q_erf
END INTERFACE

DO
  WRITE(*, '(a)', ADVANCE='NO') ' Enter x: '
  READ(*, *) x%hi
  x%lo = 0._dp
  h = SCALE(qone, -24)
  IF (ABS(x%hi) < 0.477_dp) THEN       ! Use erf if erf(x) > 0.5
    arg = x - 2._dp * h
    CALL q_erf(arg, erf_2, av_erfc)
    arg = x - h
    CALL q_erf(arg, erf_1, erfc)
    av_erfc = av_erfc + erfc
    arg = x + h
    CALL q_erf(arg, erf1, erfc)
    av_erfc = av_erfc + erfc
    arg = x + 2._dp * h
    CALL q_erf(arg, erf2, erfc)
    av_erfc = (av_erfc + erfc) / 4._dp
    d_est = (erf_2 - erf2 + SCALE( erf1 - erf_1, 3)) / (12._dp * h)

  ELSE                                 ! Else use erfc(x)
    arg = x - 2._dp * h
    CALL q_erf(arg, erfc=av_erfc)
    erf_2 = av_erfc
    arg = x - h
    CALL q_erf(arg, erfc=erf_1)
    av_erfc = av_erfc + erf_1
    arg = x + h
    CALL q_erf(arg, erfc=erf1)
    av_erfc = av_erfc + erf1
    arg = x + 2._dp * h
    CALL q_erf(arg, erfc=erf2)
    av_erfc = (av_erfc + erf2) / 4._dp
    d_est = (erf2 - erf_2 + SCALE( erf_1 - erf1, 3)) / (12._dp * h)
  END IF

  deriv = two_on_rtpi * EXP(-x*x)
  error = d_est - deriv
  WRITE(*, '(a)') '      Estimate        Derivative         Error          erfc'
  WRITE(*, '(2f20.16, g12.4, f20.16)') d_est%hi, deriv%hi, error%hi, av_erfc%hi
END DO

STOP
END PROGRAM test_q_erf


      SUBROUTINE FAILUR (FTHR,ULTSTN,STRESL,FINDEX)
C
C      THIS ROUTINE COMPUTES THE FAILURE INDEX OF A LAYER
C      IN A LAMINATED COMPOSITE ELEMENT USING ONE OF THE
C      FOLLOWING FIVE FAILURE THEORIES CURRENTLY AVAILABLE
C
C        1.   HILL
C        2.   HOFFMAN
C        3.   TSAI-WU
C        4.   MAX STRESS
C        5.   MAX STRAIN
C
C        DEFINITIONS
C        -----------
C        XT = ULTIMATE UNIAXIAL TENSILE STRENGTH IN THE FIBER
C             DIRECTION
C        XC = ULTIMATE UNIAXIAL COMPRESSIVE STRENGTH IN THE
C             FIBER DIRECTION
C        YT = ULTIMATE UNIAXIAL TENSILE STRENGTH PERPENDICULAR TO
C             THE FIBER DIRECTION
C        YC = ULTIMATE UNIAXIAL COMPRESSIVE STRENGTH PERPENDICULAR
C             TO THE FIBER DIRECTION
C        S  = ULTIMATE PLANAR SHEAR STRENGTH UNDER PURE SHEAR
C             LOADING
C        SIMILARILY FOR THE ULTIMATE STRAINS
C
      DIMENSION       ULTSTN(6),STRESL(3)
      INTEGER         FTHR
      COMMON /SYSTEM/ IBUF,NOUT
C
C**** CHECK FOR ZERO STRENGTH VALUES
C
      DO 10 I = 1,5
   10 IF (ULTSTN(I) .EQ. 0.0) GO TO 90
C
C**** ULTIMATE STRENGTH VALUES
C
      XT      = ULTSTN(1)
      XC      = ULTSTN(2)
      YT      = ULTSTN(3)
      YC      = ULTSTN(4)
      S       = ULTSTN(5)
      F12     = ULTSTN(6)
C
C**** LAYER STRESSES
C
      SIG1    = STRESL(1)
      SIG2    = STRESL(2)
      TAU12   = STRESL(3)
C
C**** LAYER STRAINS
C
      EPS1    = STRESL(1)
      EPS2    = STRESL(2)
      GAMA    = STRESL(3)
C
C
      GO TO (20,30,40,60,70), FTHR
C
C     H I L L   F A I L U R E  T H E O R Y
C     ====================================
C
   20 X = XT
      IF (SIG1 .LT. 0.0) X = XC
C
      Y = YT
      IF (SIG2 .LT. 0.0) Y = YC
C
      XX = XT
      IF ((SIG1*SIG2) .LT. 0.0) XX = XC
C
      FINDEX = ( SIG1*SIG1 )/( X*X )
      FINDEX = FINDEX + ( SIG2*SIG2 )/( Y*Y )
      FINDEX = FINDEX - ( SIG1*SIG2 )/( XX*XX )
      FINDEX = FINDEX + ( TAU12*TAU12 )/( S*S )
      GO TO 80
C
C
C     H O F F M A N  F A I L U R E  T H E O R Y
C     =========================================
C
   30 FINDEX = ( 1.0/XT - 1.0/XC )*SIG1
      FINDEX = FINDEX + ( 1.0/YT - 1.0/YC )*SIG2
      FINDEX = FINDEX + ( SIG1*SIG1 )/( XT*XC )
      FINDEX = FINDEX + ( SIG2*SIG2 )/( YT*YC )
      FINDEX = FINDEX + ( TAU12*TAU12 )/( S*S )
      FINDEX = FINDEX - ( SIG1*SIG2 )/( XT*XC )
      GO TO 80
C
C
C     T S A I-W U  F A I L U R E  T H E O R Y
C     =======================================
C
C**** CHECK STABILITY CRITERIA FOR THE INTERACTION TERM F12
   40 IF (F12 .EQ. 0.0) GO TO 50
C
      CRIT = ( 1.0/(XT*XC) )*( 1.0/(YT*YC) ) - ( F12*F12 )
      IF (CRIT .GT. 0.0) GO TO 50
C
C**** IF STABILITY CRITERIA IS VIOLATED THEN SET THE
C     F12 THE INTERACTION TERM TO ZERO
C
      F12 = 0.0
C
C
   50 FINDEX = ( 1.0/XT - 1.0/XC )*SIG1
      FINDEX = FINDEX + ( 1.0/YT - 1.0/YC )*SIG2
      FINDEX = FINDEX + ( SIG1*SIG1 )/( XT*XC )
      FINDEX = FINDEX + ( SIG2*SIG2 )/( YT*YC )
      FINDEX = FINDEX + ( TAU12*TAU12 )/( S*S )
      IF (F12 .EQ. 0.0) GO TO 80
      FINDEX = FINDEX + ( 2.0*F12*SIG1*SIG2 )
      GO TO 80
C
C
C     M A X  S T R E S S  F A I L U R E  T H E O R Y
C     ==============================================
C
   60 FI1 = SIG1/XT
      IF (SIG1 .LT. 0.0) FI1 = SIG1/XC
C
      FI2 = SIG2/YT
      IF (SIG2 .LT. 0.0) FI2 = SIG2/YC
C
      FI12 = ABS(TAU12)/S
C
      FINDEX = FI1
      IF (FI2  .GT. FINDEX) FINDEX = FI2
      IF (FI12 .GT. FINDEX) FINDEX = FI12
      GO TO 80
C
C
C     M A X  S T R A I N  F A I L U R E  T H E O R Y
C     ==============================================
C
   70 FI1 = EPS1/XT
      IF (EPS1 .LT. 0.0) FI1 = EPS1/XC
C
      FI2 = EPS2/YT
      IF (EPS2 .LT. 0.0) FI2 = EPS2/YC
C
      FI12 = ABS(GAMA)/S
C
      FINDEX = FI1
      IF (FI2  .GT. FINDEX) FINDEX = FI2
      IF (FI12 .GT. FINDEX) FINDEX = FI12
C
   80 CONTINUE
C
      RETURN
C
C
C     NON-FATAL ERROR
C
C
   90 FINDEX = 0.0
      RETURN
      END