module ff_module

  implicit none

  public :: ff

contains

  subroutine ff () bind(c, name='ff')
    use multifab_module
    use multifab_c_module
    use bl_types

    integer :: ierr, nc, ng
    double precision :: norm
    type(multifab) :: mf

    if (parallel_IOProcessor()) then
       print *, ''
       print *, "In Fortran"
    end if

    ! Assuming there is a mf "data" in multifab_c_module,
    ! which has been shared by C++.
    call get_mf_c (mf, "data", ierr)
    if (ierr .eq. 0) then
       if (parallel_IOProcessor()) then
          print *, '    Successfully get data mf!'
       end if

       nc = multifab_ncomp(mf)
       ng = multifab_nghost(mf)

       if (parallel_IOProcessor()) then
          print *, '    ncomp  = ', nc
          print *, '    nghost = ', ng
       end if

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

       call multifab_setval(mf, 1.d0, all=.true.)

       norm = norm_l1(mf, nc, 1, all=.true.)

       if (parallel_IOProcessor()) then
          print *, "    1-norm of last component", norm
       end if

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

       call multifab_setval(mf, 3.d0, all=.false.)

       norm = norm_l1(mf, nc, 1, all=.true.)

       if (parallel_IOProcessor()) then
          print *, "    1-norm of last component", norm
       end if

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

       call multifab_fill_boundary(mf)

       norm = norm_l1(mf, nc, 1, all=.true.)

       if (parallel_IOProcessor()) then
          print *, "    1-norm of last component", norm
       end if

    end if

    call get_mf_c (mf, "foo", ierr)
    if (ierr .ne. 0) then
       if (parallel_IOProcessor()) then
          print *, '    Cannot get foo mf!'
       end if
    end if

    ! no need to destroy mf!
  end subroutine ff

end module ff_module


FUNCTION FUNC3(FUNC1, FUNC2, x, y)
  REAL, EXTERNAL :: FUNC1, FUNC2
  REAL :: FUNC3
  REAL :: x, y

  FUNC3 = FUNC1(x) * FUNC2(y)
END FUNCTION FUNC3


module KINDS
! Description:
!    Contains values for the kind parameters used in the program. To work in
!    quadruple precision, set dk = qk = 33. Remember that in this case only the
!    DLSODAR subroutines can be used.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

implicit none

integer,parameter  ::  ik = selected_int_kind(9)
integer,parameter  ::  dk = selected_real_kind(15)
integer,parameter  ::  qk = selected_real_kind(33)

end module KINDS


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.

program test_spectrum

use mod_precision,only:rk => realkind
use mod_spectrum
use mod_spectral_shapes
use mod_testing,only:assert,initialize_tests,report_tests

implicit none

type(spectrum_type) :: s
type(spectrum_type) :: s1,s2,s3

integer,parameter :: stdout = 6

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: ntests
integer :: n,norder

n = 1

ntests = 29

call initialize_tests(tests,ntests)

write(unit=stdout,fmt='(80("-"))')

s = spectrum_type(fmin = 0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1000._rk)

tests(n) = assert(size(s % getFrequency()) == 43,&
                  'expected number of frequencies')
n = n + 1

tests(n) = assert(.not. s % isMonochromatic(),&
                  'spectrum is not monochromatic')
n = n + 1

tests(n) = assert(s % isOmnidirectional(),&
                  'spectrum is omnidirectional')
n = n + 1

tests(n) = assert(all(s % getSpectrum() == 0),&
                  'initial spectrum instance has zero values')
n = n + 1

tests(n) = assert(s % significantWaveHeight() == 0,&
                  'sig. wave height == 0')
n = n + 1

tests(n) = assert(s % meanPeriod() == 0,&
                  'mean wave period == 0')
n = n + 1

tests(n) = assert(s % frequencyMoment(0) == 0,&
                  'frequency moment 0 == 0')
n = n + 1

tests(n) = assert(s % frequencyMoment(1) == 0,&
                  'frequency moment 1 == 0')
n = n + 1

tests(n) = assert(s % frequencyMoment(2) == 0,&
                  'frequency moment 2 == 0')
n = n + 1

tests(n) = assert(s % frequencyMoment(3) == 0,&
                  'frequency moment 3 == 0')
n = n + 1

tests(n) = assert(s % wavenumberMoment(0) == 0,&
                  'wavenumber moment 0 == 0')
n = n + 1

tests(n) = assert(s % wavenumberMoment(1) == 0,&
                  'wavenumber moment 1 == 0')
n = n + 1

tests(n) = assert(s % wavenumberMoment(2) == 0,&
                  'wavenumber moment 2 == 0')
n = n + 1

tests(n) = assert(s % wavenumberMoment(3) == 0,&
                  'wavenumber moment 3 == 0')
n = n + 1

call s % setDepth(2e3_rk)
tests(n) = assert(s % getDepth() == 2e3_rk,&
                  'setter/getter: depth')
n = n + 1

call s % setAirDensity(1.25_rk)
tests(n) = assert(s % getAirDensity() == 1.25_rk,&
                  'setter/getter: air density')
n = n + 1

call s % setWaterDensity(1.03e3_rk)
tests(n) = assert(s % getWaterDensity() == 1.03e3_rk,&
                  'setter/getter: water density')
n = n + 1

call s % setSurfaceTension(0.074_rk)
tests(n) = assert(s % getSurfaceTension() == 0.074_rk,&
                  'setter/getter: surface tension')
n = n + 1

call s % setGravity(9.806_rk)
tests(n) = assert(s % getGravity() == 9.806_rk,&
                  'setter/getter: gravitational acceleration')
n = n + 1

s1 = spectrum_type(fmin = 0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1000._rk)
s1 = jonswap(s1 % getFrequency(),10._rk,1e5_rk,9.8_rk)
s2 = s1 + 10._rk
tests(n) = assert(s2 == s1 + 10._rk,&
                  'overloaded operators: addition with reals')
n = n + 1

s2 = s1 - 10._rk
tests(n) = assert(s2 == s1 - 10._rk,&
                  'overloaded operators: subtraction with reals')
n = n + 1

s2 = 2._rk*s1
tests(n) = assert(s2 == 2._rk * s1,&
                  'overloaded operators: multiplication with reals')
n = n + 1

s2 = s1 / 2._rk
tests(n) = assert(s2 == s1 / 2._rk,&
                  'overloaded operators: division with reals')
n = n + 1

s2 = s1
tests(n) = assert(s2 == s1,'overloaded operators: equals')
n = n + 1

s2 = s1 + 10._rk
tests(n) = assert(s2 /= s1,'overloaded operators: not equals')
n = n + 1

tests(n) = assert(s2 > s1,'overloaded operators: greater than')
n = n + 1

tests(n) = assert(s2 >= s1,'overloaded operators: greater than or equal')
n = n + 1

tests(n) = assert(s1 < s2,'overloaded operators: less than')
n = n + 1

tests(n) = assert(s1 <= s2,'overloaded operators: less than or equal')
n = n + 1

write(unit=stdout,fmt='(80("-"))')

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_spectrum


! Calculate SUITS coefficients
subroutine SUITS(na,litab,lidf,tts,tto,cts,cto,psi,ctscto, &
        ks,ko,sob,sof,sdb,sdf,dob,dof,ddb,ddf)

    implicit none
    integer, intent(in) :: na
    REAL*8, INTENT(in) :: litab(na),lidf(na),tts,tto,cts,cto,psi,ctscto
    REAL*8, INTENT(out) :: ks,ko,sob,sof,sdb,sdf,dob,dof,ddb,ddf

    real*8 :: pi,rd
    common /angle/ pi,rd
    REAL*8 :: bf,ttl,ctl,chi_s,chi_o,frho,ftau,ksli,koli,sobli,sofli,bfli
    integer :: i

    !	Calculate geometric factors associated with extinction and scattering
    !	Initialise sums
    ks  = 0
    ko  = 0
    bf  = 0
    sob = 0
    sof = 0

    !	Weighted sums over LIDF
    DO i = 1,na
        ttl = litab(i)      ! leaf inclination discrete values
        ctl = COS(rd*ttl)
        !	SAIL volume scattering phase function gives interception and portions to be
        !	multiplied by rho and tau
        CALL volscatt(tts,tto,psi,ttl,chi_s,chi_o,frho,ftau)

        !********************************************************************************
        !*                   SUITS SYSTEM COEFFICIENTS
        !*
        !*	ks  : Extinction coefficient for direct solar flux
        !*	ko  : Extinction coefficient for direct observed flux
        !*	att : Attenuation coefficient for diffuse flux
        !*	sigb : Backscattering coefficient of the diffuse downward flux
        !*	sigf : Forwardscattering coefficient of the diffuse upward flux
        !*	sf  : Scattering coefficient of the direct solar flux for downward diffuse flux
        !*	sb  : Scattering coefficient of the direct solar flux for upward diffuse flux
        !*	vf   : Scattering coefficient of upward diffuse flux in the observed direction
        !*	vb   : Scattering coefficient of downward diffuse flux in the observed direction
        !*	w   : Bidirectional scattering coefficient
        !********************************************************************************

        !	Extinction coefficients
        ksli = chi_s/cts
        koli = chi_o/cto

        !	Area scattering coefficient fractions
        sobli = frho*pi/ctscto
        sofli = ftau*pi/ctscto
        bfli  = ctl*ctl
        ks    = ks+ksli*lidf(i)
        ko    = ko+koli*lidf(i)
        bf    = bf+bfli*lidf(i)
        sob   = sob+sobli*lidf(i)
        sof   = sof+sofli*lidf(i)

    ENDDO

    !	Geometric factors to be used later with rho and tau
    sdb = 0.5*(ks+bf)
    sdf = 0.5*(ks-bf)
    dob = 0.5*(ko+bf)
    dof = 0.5*(ko-bf)
    ddb = 0.5*(1.+bf)
    ddf = 0.5*(1.-bf)

    return
end subroutine SUITS

! *****************

!! Correct rho and tau using SUITS factors
subroutine RTgeom(rho,tau,ddb,ddf,sdb,sdf,dob,dof,sob,sof, &
        sigb,att,m,sb,sf,vb,vf,w)

    use mod_dataSpec_wavelength
    implicit none
    real*8,intent(in),dimension(nw) :: rho,tau
    real*8,intent(in) :: ddb,ddf,sdb,sdf,dob,dof,sob,sof
    real*8,intent(out),dimension(nw) :: sigb,att,m,sb,sf,vb,vf,w

    real*8,dimension(nw) :: m2,sigf

    sigb = ddb*rho+ddf*tau
    sigf = ddf*rho+ddb*tau
    att  = 1.-sigf
    m2   = (att+sigb)*(att-sigb)
    WHERE (m2 < 0)
        m2 = 0
    ENDWHERE
    m  = SQRT(m2)
    sb = sdb*rho+sdf*tau
    sf = sdf*rho+sdb*tau
    vb = dob*rho+dof*tau
    vf = dof*rho+dob*tau
    w  = sob*rho+sof*tau

    return
end subroutine RTgeom


      SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M,
     $                   P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a reduced order model (Ar,Br,Cr,Dr) for an original
C     state-space representation (A,B,C,D) by using either the
C     square-root or the balancing-free square-root Singular
C     Perturbation Approximation (SPA) model reduction method in
C     conjunction with stable coprime factorization techniques.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBCF   CHARACTER*1
C             Specifies whether left or right coprime factorization is
C             to be used as follows:
C             = 'L':  use left coprime factorization;
C             = 'R':  use right coprime factorization.
C
C     FACT    CHARACTER*1
C             Specifies the type of coprime factorization to be computed
C             as follows:
C             = 'S':  compute a coprime factorization with prescribed
C                     stability degree ALPHA;
C             = 'I':  compute a coprime factorization with inner
C                     denominator.
C
C     JOBMR   CHARACTER*1
C             Specifies the model reduction approach to be used
C             as follows:
C             = 'B':  use the square-root Balance & Truncate method;
C             = 'N':  use the balancing-free square-root
C                     Balance & Truncate method.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily
C             equilibrate the triplet (A,B,C) as follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     ORDSEL  CHARACTER*1
C             Specifies the order selection method as follows:
C             = 'F':  the resulting order NR is fixed;
C             = 'A':  the resulting order NR is automatically determined
C                     on basis of the given tolerance TOL1.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation, i.e.
C             the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     NR      (input/output) INTEGER
C             On entry with ORDSEL = 'F', NR is the desired order of the
C             resulting reduced order system.  0 <= NR <= N.
C             On exit, if INFO = 0, NR is the order of the resulting
C             reduced order model. NR is set as follows:
C             if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR
C             is the desired order on entry, NQ is the order of the
C             computed coprime factorization of the given system, and
C             NMIN is the order of a minimal realization of the extended
C             system (see METHOD); NMIN is determined as the number of
C             Hankel singular values greater than NQ*EPS*HNORM(Ge),
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the
C             extended system (computed in HSV(1));
C             if ORDSEL = 'A', NR is equal to the number of Hankel
C             singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)).
C
C     ALPHA   (input) DOUBLE PRECISION
C             If FACT = 'S', the desired stability degree for the
C             factors of the coprime factorization (see SLICOT Library
C             routines SB08ED/SB08FD).
C             ALPHA < 0 for a continuous-time system (DICO = 'C'), and
C             0 <= ALPHA < 1 for a discrete-time system (DICO = 'D').
C             If FACT = 'I', ALPHA is not used.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, if INFO = 0, the leading NR-by-NR part of this
C             array contains the state dynamics matrix Ar of the reduced
C             order system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B.
C             On exit, if INFO = 0, the leading NR-by-M part of this
C             array contains the input/state matrix Br of the reduced
C             order system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C.
C             On exit, if INFO = 0, the leading P-by-NR part of this
C             array contains the state/output matrix Cr of the reduced
C             order system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the original input/output matrix D.
C             On exit, if INFO = 0, the leading P-by-M part of this
C             array contains the input/output matrix Dr of the reduced
C             order system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     NQ      (output) INTEGER
C             The order of the computed extended system Ge (see METHOD).
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, it contains the NQ Hankel singular values of
C             the extended system Ge ordered decreasingly (see METHOD).
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             If ORDSEL = 'A', TOL1 contains the tolerance for
C             determining the order of reduced extended system.
C             For model reduction, the recommended value is
C             TOL1 = c*HNORM(Ge), where c is a constant in the
C             interval [0.00001,0.001], and HNORM(Ge) is the
C             Hankel-norm of the extended system (computed in HSV(1)).
C             The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if
C             TOL1 <= 0 on entry, where EPS is the machine precision
C             (see LAPACK Library Routine DLAMCH).
C             If ORDSEL = 'F', the value of TOL1 is ignored.
C
C     TOL2    DOUBLE PRECISION
C             The tolerance for determining the order of a minimal
C             realization of the extended system Ge (see METHOD).
C             The recommended value is TOL2 = NQ*EPS*HNORM(Ge).
C             This value is used by default if TOL2 <= 0 on entry.
C             If TOL2 > 0, then TOL2 <= TOL1.
C
C     TOL3    DOUBLE PRECISION
C             The absolute tolerance level below which the elements of
C             B or C are considered zero (used for controllability or
C             observability tests by the coprime factorization method).
C             If the user sets TOL3 <= 0, then an implicitly computed,
C             default tolerance TOLDEF is used:
C             TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or
C             TOLDEF = N*EPS*NORM(B),  if JOBCF = 'R',
C             where EPS is the machine precision, and NORM(.) denotes
C             the 1-norm of a matrix.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(1,2*N,PM))
C             where  PM = P, if JOBCF = 'L',
C                    PM = M, if JOBCF = 'R'.
C             On exit with INFO = 0, IWORK(1) contains the order of the
C             minimal realization of the system.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S',
C             LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I',
C             LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S',
C             LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where
C             LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) +
C                   MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ),
C             LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) +
C                   MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ),
C             LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ),
C             LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and
C             LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2.
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 10*K+I:
C               I = 1:  with ORDSEL = 'F', the selected order NR is
C                       greater than the order of the computed coprime
C                       factorization of the given system. In this case,
C                       the resulting NR is set automatically to a value
C                       corresponding to the order of a minimal
C                       realization of the system;
C               K > 0:  K violations of the numerical stability
C                       condition occured when computing the coprime
C                       factorization using pole assignment (see SLICOT
C                       Library routines SB08CD/SB08ED, SB08DD/SB08FD).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction of A to a real Schur form failed;
C             = 2:  a failure was detected during the ordering of the
C                   real Schur form of A, or in the iterative process
C                   for reordering the eigenvalues of Z'*(A + H*C)*Z
C                   (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT
C                   Library routines SB08CD/SB08ED (or SB08DD/SB08FD);
C             = 3:  the matrix A has an observable or controllable
C                   eigenvalue on the imaginary axis if DICO = 'C' or
C                   on the unit circle if DICO = 'D';
C             = 4:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let be the linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t) + Du(t)                       (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system, and let G be the corresponding
C     transfer-function matrix. The subroutine AB09GD determines
C     the matrices of a reduced order system
C
C          d[z(t)] = Ar*z(t) + Br*u(t)
C          yr(t)   = Cr*z(t) + Dr*u(t)                   (2)
C
C     with the transfer-function matrix Gr, by using the
C     singular perturbation approximation (SPA) method in conjunction
C     with a left coprime factorization (LCF) or a right coprime
C     factorization (RCF) technique:
C
C     1. Compute the appropriate stable coprime factorization of G:
C                     -1                   -1
C                G = R  *Q (LCF) or G = Q*R   (RCF).
C
C     2. Perform the model reduction algorithm on the extended system
C                                           ( Q )
C                Ge = ( Q R ) (LCF) or Ge = ( R )  (RCF)
C
C        to obtain a reduced extended system with reduced factors
C                                               ( Qr )
C                Ger = ( Qr Rr ) (LCF) or Ger = ( Rr )  (RCF).
C
C     3. Recover the reduced system from the reduced factors as
C                       -1                       -1
C                Gr = Rr  *Qr (LCF) or Gr = Qr*Rr   (RCF).
C
C     The approximation error for the extended system satisfies
C
C        HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)],
C
C     where INFNORM(G) is the infinity-norm of G.
C
C     If JOBMR = 'B', the balancing-based square-root SPA method of [1]
C     is used for model reduction.
C     If JOBMR = 'N', the balancing-free square-root SPA method of [2]
C     is used for model reduction.
C     By setting TOL1 = TOL2, the routine can be used to compute
C     Balance & Truncate approximations.
C
C     If FACT = 'S', the stable coprime factorization with prescribed
C     stability degree ALPHA is computed by using the algorithm of [3].
C     If FACT = 'I', the stable coprime factorization with inner
C     denominator is computed by using the algorithm of [4].
C
C     REFERENCES
C
C     [1] Liu Y. and Anderson B.D.O.
C         Singular Perturbation Approximation of Balanced Systems.
C         Int. J. Control, Vol. 50, pp. 1379-1405, 1989.
C
C     [2] Varga A.
C         Balancing-free square-root algorithm for computing singular
C         perturbation approximations.
C         Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991, Vol. 2,
C         pp. 1062-1065.
C
C     [3] Varga A.
C         Coprime factors model reduction method based on square-root
C         balancing-free techniques.
C         System Analysis, Modelling and Simulation, Vol. 11,
C         pp. 303-311, 1993.
C
C     [4] Varga A.
C         A Schur method for computing coprime factorizations with
C         inner denominators and applications in model reduction.
C         Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
C
C     NUMERICAL ASPECTS
C
C     The implemented methods rely on accuracy enhancing square-root or
C     balancing-free square-root techniques.
C                                         3
C     The algorithms require less than 30N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     August 1998.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C
C     KEYWORDS
C
C     Balancing, coprime factorization, minimal realization,
C     model reduction, multivariable system, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, C100, ZERO
      PARAMETER         ( ONE = 1.0D0, C100 = 100.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL
      INTEGER           INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, N,
     $                  NQ, NR, P
      DOUBLE PRECISION  ALPHA, TOL1, TOL2, TOL3
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), HSV(*)
C     .. Local Scalars ..
      LOGICAL           DISCR, FIXORD, LEFT, STABD
      INTEGER           IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR,
     $                  KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR,
     $                  MAXMP, MP, NDR, NMINR, PM, WRKOPT
      DOUBLE PRECISION  MAXRED
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB09BX, DLACPY, SB08CD, SB08DD, SB08ED, SB08FD,
     $                  SB08GD, SB08HD, TB01ID, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO   = 0
      IWARN  = 0
      DISCR  = LSAME( DICO,   'D' )
      FIXORD = LSAME( ORDSEL, 'F' )
      LEFT   = LSAME( JOBCF,  'L' )
      STABD  = LSAME( FACT,   'S' )
      MAXMP  = MAX( M, P )
C
      LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2
      LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P )
      LW2 = LW1 +
     $      MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR )
      LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR )
      LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR )
      LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR.
     $                 LSAME( JOBMR, 'N' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR.
     $                 LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -5
      ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN
         INFO = -6
      ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR.
     $       ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) )
     $      THEN
         INFO = -7
      ELSE IF( N.LT.0 ) THEN
         INFO = -8
      ELSE IF( M.LT.0 ) THEN
         INFO = -9
      ELSE IF( P.LT.0 ) THEN
         INFO = -10
      ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN
         INFO = -11
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -17
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -19
      ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN
         INFO = -23
      ELSE IF( ( LDWORK.LT.1 ) .OR.
     $   (      STABD .AND.      LEFT .AND. LDWORK.LT.LW1 ) .OR.
     $   ( .NOT.STABD .AND.      LEFT .AND. LDWORK.LT.LW2 ) .OR.
     $   (      STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR.
     $   ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN
         INFO = -27
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09GD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         NR = 0
         NQ = 0
         IWORK(1) = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( LSAME( EQUIL, 'S' ) ) THEN
C
C        Scale simultaneously the matrices A, B and C:
C        A <- inv(D)*A*D,  B <- inv(D)*B and C <- C*D, where D is a
C        diagonal matrix.
C
         MAXRED = C100
         CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
      END IF
C
C     Perform the coprime factor model reduction procedure.
C
      KD = 1
      IF( LEFT ) THEN
C                           -1
C        Compute a LCF G = R  *Q.
C
         MP  = M + P
         KDR = KD  + MAXMP*MAXMP
         KC  = KDR + MAXMP*P
         KB  = KC  + MAXMP*N
         KBR = KB  + N*MAXMP
         KW  = KBR + N*P
         LWR = LDWORK - KW + 1
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N )
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP )
         CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), MAXMP )
C
         IF( STABD ) THEN
C
C           Compute a LCF with prescribed stability degree.
C
C           Workspace needed:      N*(2*MAX(M,P)+P) +
C                                  MAX(M,P)*(MAX(M,P)+P);
C           Additional workspace:  need   N*P+MAX(N*(N+5),5*P,4*M);
C                                  prefer larger.
C
            CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N,
     $                   DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR,
     $                   DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3,
     $                   DWORK(KW), LWR, IWARN, INFO )
         ELSE
C
C           Compute a LCF with inner denominator.
C
C           Workspace needed:      N*(2*MAX(M,P)+P) +
C                                  MAX(M,P)*(MAX(M,P)+P);
C           Additional workspace:  need   N*P +
C                                         MAX(N*(N+5),P*(P+2),4*P,4*M);
C                                  prefer larger.
C
            CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N,
     $                   DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR,
     $                   DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3,
     $                   DWORK(KW), LWR, IWARN, INFO )
         END IF
C
         IWARN = 10*IWARN
         IF( INFO.NE.0 )
     $      RETURN
C
         WRKOPT = INT( DWORK(KW) ) + KW - 1
C
         IF( NQ.EQ.0 ) THEN
            NR = 0
            IWORK(1) = 0
            DWORK(1) = WRKOPT
            RETURN
         END IF
C
         IF( MAXMP.GT.M ) THEN
C
C           Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive
C           columns (see SLICOT Library routines SB08CD/SB08ED).
C
            KBT = KBR
            KBR = KB + N*M
            KDT = KDR
            KDR = KD + MAXMP*M
            CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N )
            CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR),
     $                   MAXMP )
         END IF
C
C        Perform model reduction on ( Q, R ) to determine ( Qr, Rr ).
C
C        Workspace needed:      N*(2*MAX(M,P)+P) +
C                               MAX(M,P)*(MAX(M,P)+P) + 2*N*N;
C        Additional workspace:  need   N*(MAX(N,M+P)+5) + N*(N+1)/2;
C                               prefer larger.
C
         KT  = KW
         KTI = KT  + NQ*NQ
         KW  = KTI + NQ*NQ
         CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA,
     $                DWORK(KB), N, DWORK(KC), MAXMP, DWORK(KD), MAXMP,
     $                HSV, DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2,
     $                IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, IERR )
C
         IWARN = IWARN + IWARNK
         IF( IERR.NE.0 ) THEN
            INFO = 4
            RETURN
         END IF
C
         NMINR  = IWORK(1)
         WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C                                                -1
C        Compute the reduced order system Gr = Rr  *Qr.
C
C        Workspace needed:      N*(2*MAX(M,P)+P) +
C                               MAX(M,P)*(MAX(M,P)+P);
C        Additional workspace:  need   4*P.
C
         KW = KT
         CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP,
     $                DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR),
     $                MAXMP, IWORK, DWORK(KW), INFO )
C
C        Copy the reduced system matrices Br, Cr, and Dr to B, C, and D,
C        respectively.
C
         CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB )
         CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC )
         CALL DLACPY( 'Full', P, M,  DWORK(KD), MAXMP, D, LDD )
      ELSE
C                             -1
C        Compute a RCF G = Q*R  .
C
         PM  = P  + M
         KDR = KD + P
         KC  = KD + PM*M
         KCR = KC + P
         KW  = KC + PM*N
         LWR = LDWORK - KW + 1
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM )
         CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), PM )
C
         IF( STABD ) THEN
C
C           Compute a RCF with prescribed stability degree.
C
C           Workspace needed:      (N+M)*(M+P);
C           Additional workspace:  need  MAX( N*(N+5), 5*M, 4*P );
C                                  prefer larger.
C
            CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB,
     $                   DWORK(KC), PM, DWORK(KD), PM, NQ, NDR,
     $                   DWORK(KCR), PM, DWORK(KDR), PM, TOL3,
     $                   DWORK(KW), LWR, IWARN, INFO)
         ELSE
C
C           Compute a RCF with inner denominator.
C
C           Workspace needed:      (N+M)*(M+P);
C           Additional workspace:  need  MAX(N*(N+5),M*(M+2),4*M,4*P);
C                                  prefer larger.
C
            CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB,
     $                   DWORK(KC), PM, DWORK(KD), PM, NQ, NDR,
     $                   DWORK(KCR), PM, DWORK(KDR), PM, TOL3,
     $                   DWORK(KW), LWR, IWARN, INFO)
         END IF
C
         IWARN = 10*IWARN
         IF( INFO.NE.0 )
     $      RETURN
C
         WRKOPT = INT( DWORK(KW) ) + KW - 1
C
         IF( NQ.EQ.0 ) THEN
            NR = 0
            IWORK(1) = 0
            DWORK(1) = WRKOPT
            RETURN
         END IF
C                                   ( Q )              ( Qr )
C        Perform model reduction on ( R ) to determine ( Rr ).
C
C        Workspace needed:      (N+M)*(M+P) + 2*N*N;
C        Additional workspace:  need   N*(MAX(N,M+P)+5) + N*(N+1)/2;
C                               prefer larger.
C
         KT  = KW
         KTI = KT  + NQ*NQ
         KW  = KTI + NQ*NQ
         CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA,
     $                B, LDB, DWORK(KC), PM, DWORK(KD), PM, HSV,
     $                DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK,
     $                DWORK(KW), LDWORK-KW+1, IWARNK, IERR )
C
         IWARN = IWARN + IWARNK
         IF( IERR.NE.0 ) THEN
            INFO = 4
            RETURN
         END IF
C
         NMINR  = IWORK(1)
         WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C                                                   -1
C        Compute the reduced order system Gr = Qr*Rr  .
C
C        Workspace needed:      (N+M)*(M+P);
C        Additional workspace:  need 4*M.
C
         KW = KT
         CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM,
     $                DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM,
     $                IWORK, DWORK(KW), INFO )
C
C        Copy the reduced system matrices Cr and Dr to C and D.
C
         CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC )
         CALL DLACPY( 'Full', P, M,  DWORK(KD), PM, D, LDD )
      END IF
C
      IWORK(1) = NMINR
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of AB09GD ***
      END


c  Part of R package KernSmooth
c  Copyright (C) 1995  M. P. Wand
c
c  Unlimited use and distribution (see LICENCE).

cccccccccc FORTRAN subroutine sdiag.f cccccccccc

c For computing the diagonal entries of the "binned"
c smoother matrix.

c Last changed: 01/02/95

      subroutine sdiag(xcnts,delta,hdisc,Lvec,indic,
     +                 midpts,M,iQ,fkap,ipp,ippp,ss,Smat,
     +                 work,det,ipvt,Sdg)
      integer i,j,k,Lvec(*),M,iQ,mid,indic(*),midpts(*),
     +        ipvt(*),info,ii,ipp,ippp,indss
      double precision xcnts(*),fkap(*),hdisc(*),
     +                 delta,ss(M,ippp),Smat(ipp,ipp),Sdg(*),
     +                 fac,work(*),det(2)

c Obtain kernel weights

      mid = Lvec(1) + 1
      do 10 i=1,(iQ-1)
         midpts(i) = mid
         fkap(mid) = 1.0d0
         do 20 j=1,Lvec(i)
            fkap(mid+j) = exp(-(delta*j/hdisc(i))**2/2)
            fkap(mid-j) = fkap(mid+j)
20       continue
         mid = mid + Lvec(i) + Lvec(i+1) + 1
10       continue
      midpts(iQ) = mid
      fkap(mid) = 1.0d0
      do 30 j=1,Lvec(iQ)
         fkap(mid+j) = exp(-(delta*j/hdisc(iQ))**2/2)
         fkap(mid-j) = fkap(mid+j)
30    continue

c Combine kernel weights and grid counts

      do 40 k = 1,M
         if (xcnts(k).ne.0) then
            do 50 i = 1,iQ
               do 60 j = max(1,k-Lvec(i)),min(M,k+Lvec(i))
                  if (indic(j).eq.i) then
                     fac = 1.0d0
                     ss(j,1) = ss(j,1) + xcnts(k)*fkap(k-j+midpts(i))
                     do 70 ii = 2,ippp
                        fac = fac*delta*(k-j)
                        ss(j,ii) = ss(j,ii)
     +                  + xcnts(k)*fkap(k-j+midpts(i))*fac
70                   continue
                  endif
60             continue
50          continue
         endif
40    continue

      do 80 k = 1,M
         do 90 i = 1,ipp
            do 100 j = 1,ipp
               indss = i + j - 1
               Smat(i,j) = ss(k,indss)
100         continue
90       continue

         call dgefa(Smat,ipp,ipp,ipvt,info)
         call dgedi(Smat,ipp,ipp,ipvt,det,work,01)

         Sdg(k) = Smat(1,1)

80    continue

      return
      end

cccccccccc End of sdiag.f cccccccccc


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     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 2);
!
!
!     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, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     diagonal preconditioning of a matrix
!
      subroutine inviscidpre(nk,inomat,ntmat_,shcon,nshcon,physcon,
     &     xmach2,nactdoh,b,vold,v,mi)
!
      implicit none
!
      integer i,nk,imat,inomat(*),ntmat_,nshcon(*),nactdoh(0:4,*),
     &     idof,mi(*)
!
      real*8 temp,shcon(0:3,ntmat_,*),cp,physcon(*),r,xkappa,vel2,
     &     xmach,xmach2(*),constant,b(*),vold(0:mi(2),*),
     &     v(0:mi(2),*)
!
      do i=1,nk
        imat=inomat(i)
        if(imat.eq.0) cycle
!
        idof=nactdoh(0,i)
        temp=vold(0,i)
!
!     material properties r, cp and kappa
!
        call materialdata_cp_sec(imat,ntmat_,temp,shcon,
     &       nshcon,cp,physcon)
        r=shcon(3,1,imat)
        xkappa=cp/(cp-r)
!
!     size of the velocity
!
        vel2=vold(1,i)**2+vold(2,i)**2+vold(3,i)**2
!
        xmach=dsqrt(vel2)/(xkappa*r*(temp-physcon(1)))
!
!     determine the relevant Mach number
!
        if(xmach.lt.1.d-5) then
          xmach2(idof)=1.d-10
        elseif(xmach.lt.1.d0) then
          xmach2(idof)=xmach**2
        else
          xmach2(idof)=1.d0
        endif
!
        constant=1.d0-1.d0/xmach2(idof)
!
!     modifying the right hand side
!
        b(idof)=b(idof)+vel2*constant/3.d0*v(0,i)-constant*
     &       -(vold(1,i)*v(1,i)+vold(2,i)*v(2,i)+vold(3,i)*v(3,i))
!
      enddo
!
      return
      end


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C     Projet MICO - Riks & N.R.      (ver. FORTRAN 31.03.95)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

C ----Declarations--------
      integer i, boucle, t, ii, type
      double precision h, a, b, Vh, Vv, E, Lh, Lv, pas
      double precision TOL, u, Force(1000), Du1(2), TgSwap
      double precision lambda, Beta, ETA, Du(2), Du2(2)
      double precision x(1000), y(1000), R(2), uu(2)
      double precision norm, F(2), Kt(2,2), MAT(2)
      double precision invKt(2,2), dtmKt, uut(2), lambdat, Fint(2)
      double precision rac1, rac2, a1, a2, a3, test1, test2
      double precision ps, ru(2), ru2(2)

C ----Donnees-------------
      h      = 40.
      a      = 24.
      b      = 40.
      Vh     = 160.
      Vv     = 200.
      E      = 70000.
      Lh     = 2*a
      Lv     = dsqrt(h**2+(b+a)**2)
      TOL    = 1e-3
      i      = 0
      uu(1)  = 0.
      uu(2)  = 0.
      R(1)   = 20000.
      R(2)   = 0.
      Beta   = 0.005
      pas    = 0.01
      TgSwap = 900.

C ----Paramètres----------

      write(*,*)'TOL?'
      read(*,*)TOL
      write(*,*)'Beta?'
      read(*,*)Beta
      write(*,*)'ETA max?'
      read(*,*)ETAMAX
      write(*,*)'pas N.R.?'
      read(*,*)pas

C-------------------type=1 -> NR
C                   type=2 -> RC
      type=1

C ----Initialisation------------------------------

      t=1
      x(1)=0.
      y(1)=0.
      Force(1)=0.

C  --------------------Newton Raphson----
30    if (type.EQ.1) then
         lambdat=lambda
         uut(1)=uu(1)
         uut(2)=uu(2)
C        ----Calcul de l'incrément de Force----
         if (t.GT.1) then
            if ((Force(t-1)-Force(t)).LT.0) then
               lambda=lambda+pas
            else
               lambda=lambda-pas
            endif
         else
            lambda=lambda+pas
         endif
         boucle=0
         ii=0
20       u=uu(1)
         v=uu(2)
         ii=ii+1
         F(1)=(E*Vv/Lv**4)*(v*v+u*u-2*h*v+2*u*(a+b))*(v-h)
         F(2)=(E*Vv/Lv**4)*(v**2+u**2-2*h*v+2*u*(a+b))*(u+a+b)
         F(2)=F(2)+(8*E*Vh/Lh**4)*(u**2+2*a*u)*(u+a)
         if (lambda.NE.0) then
            norm=dsqrt((lambda*R(1)-F(1))**2+(lambda*R(2)-F(2))**2)
     *           /abs(lambda)/dsqrt(R(1)**2+R(2)**2)
         else
            norm=0
         endif
         if ((norm.GT.TOL).OR.(ii.EQ.1)) then
            Kt(1,1)=E*Vv/(Lv**4)*(2*u+2*(a+b))*(v-h)
            Kt(1,2)=E*Vv/(Lv**4)*((v**2+u**2-2*v*h+2*u*(a+b))
     *              +(v-h)*(2*v-2*h))
            Kt(2,1)=E*Vv/(Lv**4)*((v**2+u**2-2*h*v+2*u*(a+b))
     *              +(u+a+b)*(2*u+2*(a+b)))+8*E*Vh/(Lh**4)*((2*u+2*a)
     *              *(u+a)+(u**2+2*a*u))
            Kt(2,2)=E*Vv/(Lv**4)*(u+a+b)*(2*v-2*h)
            MAT(1)=lambda*R(1)-F(1)
            MAT(2)=lambda*R(2)-F(2)
            dtmKt=Kt(1,1)*Kt(2,2)-Kt(1,2)*Kt(2,1)
            invKt(1,1)=Kt(2,2)/dtmKt
            invKt(2,2)=Kt(1,1)/dtmKt
            invKt(1,2)=-1*Kt(1,2)/dtmKt
            invKt(2,1)=-1*Kt(2,1)/dtmKt
            Du(1)=invKt(1,1)*MAT(1)+invKt(1,2)*MAT(2)
            Du(2)=invKt(2,1)*MAT(1)+invKt(2,2)*MAT(2)
            if (ii.EQ.1) then
               Du1(1)=Du(1)
               Du1(2)=Du(2)
            endif
            uu(1)=uu(1)+Du(1)
            uu(2)=uu(2)+Du(2)
         else
            boucle=1
         endif
         if (boucle.EQ.0) goto 20
         t=t+1
         Force(t)=lambda*R(1)
         x(t)=uu(2)
         y(t)=uu(1)
         ETA=dsqrt(Du1(1)**2+Du1(2)**2)/
     *       dsqrt((uu(1)-uut(1))**2+(uu(2)-uut(2))**2)
      else
C  --------------------------Ricks Criesfield----
         i=0
         lambdat=lambda
         uut(1)=uu(1)
         uut(2)=uu(2)
         lambda=(Force(t))/R(1)
         boucle=0
40       u=uu(1)
         v=uu(2)
         Fint(1)=(E*Vv/Lv**4)*(v*v+u*u-2*h*v+2*u*(a+b))*(v-h)
         Fint(2)=(E*Vv/Lv**4)*(v**2+u**2-2*h*v+2*u*(a+b))*(u+a+b)
         Fint(2)=Fint(2)+(8*E*Vh/Lh**4)*(u**2+2*a*u)*(u+a)
         norm=dsqrt((lambda*R(1)-Fint(1))**2+(lambda*R(2)-Fint(2))
     *           **2)/abs(lambda)/dsqrt(R(1)**2+R(2)**2)
         if ((norm.GT.TOL).OR.(i.EQ.0)) then
            i=i+1
            Kt(1,1)=E*Vv/(Lv**4)*(2*u+2*(a+b))*(v-h)
            Kt(1,2)=E*Vv/(Lv**4)*((v**2+u**2-2*v*h+2*u*(a+b))
     *              +(v-h)*(2*v-2*h))
            Kt(2,1)=E*Vv/(Lv**4)*((v**2+u**2-2*h*v+2*u*(a+b))
     *              +(u+a+b)*(2*u+2*(a+b)))+8*E*Vh/(Lh**4)*((2*u+2*a)
     *              *(u+a)+(u**2+2*a*u))
            Kt(2,2)=E*Vv/(Lv**4)*(u+a+b)*(2*v-2*h)
C           ----Calcul de Du1-----------
            MAT(1)=lambda*R(1)-Fint(1)
            MAT(2)=lambda*R(2)-Fint(2)
            dtmKt=Kt(1,1)*Kt(2,2)-Kt(1,2)*Kt(2,1)
            invKt(1,1)=Kt(2,2)/dtmKt
            invKt(2,2)=Kt(1,1)/dtmKt
            invKt(1,2)=-1*Kt(1,2)/dtmKt
            invKt(2,1)=-1*Kt(2,1)/dtmKt
            Du1(1)=invKt(1,1)*MAT(1)+invKt(1,2)*MAT(2)
            Du1(2)=invKt(2,1)*MAT(1)+invKt(2,2)*MAT(2)
C           ----Calcul de Du2-----------
            Du2(1)=invKt(1,1)*R(1)+invKt(1,2)*R(2)
            Du2(2)=invKt(2,1)*R(1)+invKt(2,2)*R(2)
C           ----Calcul de a1, a2, a3----
            ru(1)=uu(1)-uut(1)
            ru(2)=uu(2)-uut(2)
            ru2(1)=ru(1)+Du1(1)
            ru2(2)=ru(2)+Du1(2)
            a1=(Beta**2)*ps(R,R)+ps(Du2,Du2)
            a2=2*((lambda-lambdat)*(Beta**2)*ps(R,R)+ps(ru2,Du2))
            a3=2*ps(ru,Du1)+ps(Du1,Du1)+(ps(ru,ru)+
     *         ((lambda-lambdat)**2)*(Beta**2)*ps(R,R)-ETA**2)
            rac1=(-a2+dsqrt(a2**2-4*a1*a3))/2/a1
            rac2=(-a2-dsqrt(a2**2-4*a1*a3))/2/a1
            test1=uu(2)+Du1(2)+rac1*Du2(2)
            test2=uu(2)+Du1(2)+rac2*Du2(2)
            if ((test2-test1).GT.0) then
               uu(1)=uu(1)+Du1(1)+rac2*Du2(1)
               uu(2)=uu(2)+Du1(2)+rac2*Du2(2)
               lambda=lambda+rac2
            else
               uu(1)=uu(1)+Du1(1)+rac1*Du2(1)
               uu(2)=uu(2)+Du1(2)+rac1*Du2(2)
               lambda=lambda+rac1
            endif
         else
            boucle=1
         endif
         if (boucle.EQ.0) goto 40

         ETA=ETA*dsqrt(4./i)
         if (ETA.GT.ETAMAX) then
            ETA=ETAMAX
         endif
         t=t+1
         Force(t)=lambda*R(1)
         x(t)=uu(2)
         y(t)=uu(1)
      endif
C     ----Teste la tangente à la courbe:
C                     TG > 900 --> N.R.
C                     TG < 900---> R.C.
      if (abs((Force(t-1)-Force(t))/(uut(2)-uu(2))).LT.TgSwap) then
         type=2
      else
         type=1
      endif
      if (lambda.LT.1) goto 30

C ----Resultats-----------

      open (UNIT = 1, FILE = 'rcnr_1.m', STATUS='unknown')
      do 31 i=1,t
         write(1,*)'x(',i,')=',x(i),';'
         write(1,*)'y(',i,')=',y(i),';'
         write(1,*)'P(',i,')=',Force(i),';'
31    continue
      write(1,*)'figure(1), plot(x,y), grid'
      write(1,*)'figure(2), plot(x,P), grid'
      close (UNIT=1)
      write(*,*)'t =',t
      end

      double precision function ps(a,b)
         double precision a(2),b(2)
         ps=a(1)*b(1)+a(2)*b(2)
      return
      end


subroutine stoktb(hrmsnm, tpu, h, ustokes, 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: stoktb.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/stoktb.f90 $
!!--description-----------------------------------------------------------------
!
! NONE
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use mathconsts
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    real(fp), pointer :: ag
    real(fp), pointer :: gammax
!
! Global variables
!
    real(fp)              :: h
    real(fp), intent(in)  :: hrmsnm
    real(fp)              :: tpu
    real(fp), intent(out) :: ustokes
!
! Local variables
!
    real(fp) :: a
    real(fp) :: fact
    real(fp) :: kwav
    real(fp) :: omega
    real(fp) :: p1
!
!! executable statements -------------------------------------------------------
!
    ag         => gdp%gdphysco%ag
    gammax     => gdp%gdnumeco%gammax
    !
    ! Calculates Stokes velocities at the bed
    !
    a = 0.5_fp * (min(hrmsnm, gammax*h))
    if (tpu > 0.1_fp) then
       omega = 2.0_fp * pi / tpu
       !
       ! Determine Wave number
       !
       call wavenr(h, tpu, kwav, ag)
       !
       ! Determine Second order Stokes drift at the bed (z=0)
       !
       p1      = max(-25.0_fp,  -2.0_fp*kwav*h)
       fact    = exp(p1)
       ustokes = omega * kwav * a**2 * (fact*2.0_fp / (1.0_fp-fact)**2)
    else
       ustokes = 0.0_fp
    endif
end subroutine stoktb


      SUBROUTINE XTRNL0
*
*
*       External force initialization.
*       ------------------------------
*
      INCLUDE 'common6.h'
      COMMON/GALAXY/ GMG,RG(3),VG(3),FG(3),FGD(3),TG,
     &               OMEGA,DISK,A,B,V02,RL2,GMB,AR,GAM,ZDUM(7)
*
*
*       Check option for cluster in circular galactic orbit.
      IF (KZ(14).NE.1) GO TO 20
*
*       Specify Oort's constants (units of km/sec/kpc).
      A = 14.4
      B = -12.0
*       Adopt local density from Gilmore & Kuijken (solar mass/pc**3).
      RHO = 0.11
*       Convert rotation constants to units of cm/sec/pc.
      A = 100.0*A
      B = 100.0*B
*
*       Specify the tidal term in star cluster units (solar mass & pc).
      TIDAL(1) = 4.0*A*(A - B)*(PC/GM)
*
*       Initialize the Y-component to zero.
      TIDAL(2) = 0.0
*
*       Specify the vertical force gradient.
      TIDAL(3) = -(2.0*TWOPI*RHO + 2.0*(A - B)*(A + B)*(PC/GM))
*
      FAC = 1.0E-10/(PC/GM)
      WRITE (6,5)  ZMBAR*ZMASS, FAC*TIDAL(1), FAC*TIDAL(3), PC/GM
    5 FORMAT (/,12X,'TOTAL MASS =',F8.1,'  TIDAL(1&3) =',1P,2E10.2,
     &              '  PC/GM =',E10.2)
*
*       Adopt twice the angular velocity for Coriolis terms.
      TIDAL(4) = 2.0*(A - B)*SQRT(PC/GM)
*
*       Define time scale in seconds and velocity scale in km/sec.
      TSCALE = SQRT(PC/GM)*PC
*
*       Convert time scale from units of seconds to million years.
      TSCALE = TSCALE/(3.15D+07*1.0D+06)
*
*       Scale to working units of RBAR in pc & ZMBAR in solar masses.
      DO 10 K = 1,3
          TIDAL(K) = TIDAL(K)*RBAR**3/ZMBAR
   10 CONTINUE
      TIDAL(4) = TIDAL(4)*SQRT(RBAR**3/ZMBAR)
      TSCALE = TSCALE*SQRT(RBAR**3/(ZMASS*ZMBAR))
*
*       Perform an energy scaling iteration to include ETIDE (once is OK).
      E0 = -0.25
      CALL XTRNLV(1,N)
*       Form total energy based on current values and ETIDE (cf. SCALE).
      ETOT = ZKIN - POT + ETIDE
      SX = E0/ETOT
*       Exclude re-scaling for positive energy or binary Plummer cluster.
      IF (ETOT.GE.0.0) SX = 1.0
      IF (KZ(5).EQ.2) SX = 1.0
*
*       Scale coordinates & velocities to yield ETOT = -0.25.
      DO 15 I = 1,N
          DO 12 K = 1,3
              X(K,I) = X(K,I)/SX
              XDOT(K,I) = XDOT(K,I)*SQRT(SX)
   12     CONTINUE
   15 CONTINUE
*
*       Consider alternatives: circular point-mass orbit or 3D galaxy model.
   20 ZMTOT = ZMASS*ZMBAR
      IF (KZ(14).EQ.2) THEN
*
*       Read galaxy mass and central distance (solar units and kpc).
          READ (5,*)  GMG, RG0
*
*       Set circular velocity in km/sec and angular velocity in cgs units.
          VG0 = 1.0D-05*SQRT(GMG/(1000.0*RG0))*SQRT(GM/PC)
          OMEGA = 100.0*VG0/RG0
*
*       Obtain King tidal radius in pc (eq. (9) of Fukushige & Heggie, 1995).
          RT = (ZMTOT/(3.0*GMG))**0.3333*(1000.0*RG0)
*
          IF (RTIDE.GT.0.0) THEN
*       Determine RBAR (N-body units) from RT (pc) and King model (see SCALE).
              IF(KZ(22).EQ.2) RBAR = RT/RTIDE
          ELSE
              RTIDE = RT/RBAR
          END IF
*
*       Convert from cgs to N-body units.
          OMEGA = OMEGA*SQRT(PC/GM)*SQRT(RBAR**3/ZMBAR)
*
*       Specify the galactic parameters for equations of motion.
          TIDAL(1) = 3.0*OMEGA**2
          TIDAL(2) = 0.0D0
          TIDAL(3) = -OMEGA**2
          TIDAL(4) = 2.0*OMEGA
          GMG = GMG/ZMTOT
*
*       Check re-scaling units to current RBAR (i.e. TSTAR & VSTAR).
          IF (KZ(22).EQ.2) THEN
              CALL UNITS
          END IF
*
          WRITE (6,35)  GMG, RG0, OMEGA, RTIDE, RBAR
*
*       Perform an energy scaling iteration to include ETIDE (once is OK).
      E0 = -0.25
      CALL XTRNLV(1,N)
*       Form total energy based on current values and ETIDE (cf. SCALE).
      ETOT = ZKIN - POT + ETIDE
      SX = E0/ETOT
      IF (ETOT.GE.0.0) SX = 1.0
*
*       Scale coordinates & velocities to yield ETOT = -0.25.
      DO 24 I = 1,N
          DO 22 K = 1,3
              X(K,I) = X(K,I)/SX
              XDOT(K,I) = XDOT(K,I)*SQRT(SX)
   22     CONTINUE
   24 CONTINUE
*
*       Treat the case of 3D orbit for point-mass, bulge, disk and/or halo.
      ELSE IF (KZ(14).EQ.3) THEN
*
*       Read all parameters (NB! Do not confuse with Oort's constants A, B).
          READ (5,*)  GMG, DISK, A, B, VCIRC, RCIRC, GMB, AR, GAM
*       Gamma/eta model: GMB = mass, AR = scale radius, GAM = exponent.
          READ (5,*)  (RG(K),K=1,3), (VG(K),K=1,3)
*
*       Specify planar motion from SEMI & ECC for no disk & halo if VZ = 0.
          IF (DISK + VCIRC + GMB.EQ.0.0.AND.VG(3).EQ.0.0D0) THEN
              RAP = RG(1)
              ECC = RG(2)
              SEMI = RAP/(1.0 + ECC)
              VG2 = GMG/(1000.0*SEMI)*(1.0 - ECC)/(1.0 + ECC)
              DO 25 K = 1,3
                  RG(K) = 0.0
                  VG(K) = 0.0
   25         CONTINUE
*       Initialize 2D orbit with given eccentricity at apocentre.
              RG(1) = RAP
              VG(2) = 1.0D-05*SQRT(VG2)*SQRT(GM/PC)
          END IF
*
*       Convert from kpc and km/sec to N-body units.
          DO 30 K = 1,3
              RG(K) = 1000.0*RG(K)/RBAR
              VG(K) = VG(K)/VSTAR
   30     CONTINUE
*
*       Define the angular velocity (z-component) and mass in N-body units.
          R02 = RG(1)**2 + RG(2)**2
          OMEGA = (RG(1)*VG(2) - RG(2)*VG(1))/R02
          TIDAL(4) = 2.0*OMEGA
          GMG = GMG/ZMTOT
          GMB = GMB/ZMTOT
          AR = 1000.0*AR/RBAR
*
          IF (GMG.GT.0.0) THEN
              WRITE (6,35)  GMG, SQRT(R02), OMEGA, RTIDE, RBAR
   35         FORMAT (/,12X,'POINT-MASS MODEL:    GMG =',1P,E9.1,
     &                      '  RG =',E9.1,'  OMEGA =',E9.1,
     &                      '  RT =',0P,F6.2,'  RBAR =',F6.2)
          END IF
          IF (GMB.GT.0.0D0) THEN
              WRITE (6,36)  GMB, AR, GAM
   36         FORMAT (/,12X,'GAMMA/ETA MODEL:    GMB =',1P,E9.1,
     &                      '  AR =',E9.1,'  GAM =',E9.1)
          END IF
*
*       Define disk and/or logarithmic halo parameters in N-body units.
          IF (DISK.GT.0.0D0) THEN
              DISK = DISK/ZMTOT
              A = 1000.0*A/RBAR
              B = 1000.0*B/RBAR
              WRITE (6,40)  DISK, A, B
   40         FORMAT (/,12X,'DISK MODEL:    MD =',1P,E9.1,
     &                                   '  A =',E9.1,'  B =',E9.1)
          END IF
*
*       Determine local halo velocity from total circular velocity.
          IF (VCIRC.GT.0.0D0) THEN
              VCIRC = VCIRC/VSTAR
              RCIRC = 1000.0*RCIRC/RBAR
              A2 = RCIRC**2 + (A + B)**2
              V02 = VCIRC**2 - (GMG/RCIRC + DISK*RCIRC**2/A2**1.5)
*       Include any contribution from bulge potential (V2 = R*F).
              IF (GMB.GT.0.0D0) THEN
                  VB2 = GMB/RCIRC*(1.0 + AR/RCIRC)**(GAM-3.0)
                  V02 = V02 - VB2
              END IF
              IF (V02.LT.0.0D0) THEN
                  WRITE (6,45)  V02, 0.001*RCIRC*RBAR
   45             FORMAT (' ',' NEGATIVE HALO VELOCITY!    V02 RCIRC ',
     &                                                     1P,2E10.2)
                  STOP
              END IF
*       Specify the corresponding scale length of logarithmic halo.
              RL2 = RCIRC**2*(VCIRC**2 - V02)/V02
*       Define the asymptotic circular velocity due to halo.
              V02 = VCIRC**2
*
*       Include table of circular velocity on unit #51 (km/sec & kpc).
              RI = 1000.0/RBAR
              DR = 1000.0/RBAR
              DO 60 K = 1,30
                  RI2 = RI**2
                  A2 = RI2 + (A + B)**2
                  VB2 = GMB/RI*(1.0 + AR/RI)**(GAM-3.0)
                  VCIRC2 = GMG/SQRT(RI2) + DISK*RI2/A2**1.5 +
     &                     V02*RI2/(RL2 + RI2) + VB2
                  WRITE (52,50)  SQRT(VCIRC2)*VSTAR, RI*RBAR/1000.0
   50             FORMAT (' CIRCULAR VELOCITY:    VC R ',F7.1,F7.2)
                  RI = RI + DR
   60         CONTINUE
              CALL FLUSH(52)
*
              A2 = R02 + (A + B)**2
              VB2 = GMB/SQRT(R02)*(1.0 + AR/SQRT(R02))**(GAM-3.0)
              VCIRC2 = GMG/SQRT(R02) + DISK*R02/A2**1.5 +
     &                 V02*R02/(RL2 + R02) + VB2
              VCIRC = SQRT(VCIRC2)*VSTAR
              WRITE (6,62)  VCIRC, SQRT(R02)/1000.0, SQRT(RL2)/1000.0
   62         FORMAT (/,12X,'CIRCULAR VELOCITY:    VC RG RL',F7.1,2F7.2)
          ELSE
              V02 = 0.0
          END IF
*
*       Initialize F & FDOT of reference frame (point-mass galaxy is OK).
          CALL GCINIT
*
*       Form tidal radius from circular angular velocity (assumes apocentre).
          IF (RTIDE.EQ.0.0D0) RTIDE = (0.5/OMEGA**2)**0.3333
*
          WRITE (6,65)  (RG(K),K=1,3), (VG(K),K=1,3), SQRT(V02)
   65     FORMAT (/,12X,'SCALED ORBIT:    RG = ',3F7.2,
     &                                 '  VG = ',3F7.1,'  V0 =',F6.1)
      END IF
*
*       Include Plummer potential for 2D and 3D (use MP = 0 if not needed).
      IF (KZ(14).EQ.3.OR.KZ(14).EQ.4) THEN
*       Check input for Plummer potential.
          READ (5,*)  MP, AP2, MPDOT, TDELAY
          WRITE (6,70)  MP, AP2, MPDOT, TDELAY
   70     FORMAT (/,12X,'PLUMMER POTENTIAL:    MP =',F7.3,'  AP =',F6.2,
     &                        '  MPDOT =',F7.3,'  TDELAY =',F5.1)
          MP0 = MP
          AP2 = AP2**2
*       Rescale velocities by including the Plummer & galactic virial energy.
          IF (ZKIN.GT.0.0D0) THEN
*       Note that QVIR = Q is saved in routine SCALE and VIR < 0 with GPU.
              CALL ENERGY
              VIR = POT - VIR
              QV = SQRT(QVIR*VIR/ZKIN)
              DO 80 I = 1,N
                  DO 78 K = 1,3
                      XDOT(K,I) = XDOT(K,I)*QV
   78             CONTINUE
   80         CONTINUE
          END IF
          IF (RTIDE.EQ.0.0D0) RTIDE = 10.0*RSCALE
      ELSE
          MP = 0.0
          MPDOT = 0.0
      END IF
      RTIDE0 = RTIDE
      TSCALE = TSTAR
*
*       Define tidal radius in scaled units for linearized field.
      IF (KZ(14).LE.2) THEN
          RTIDE = (ZMASS/TIDAL(1))**0.3333
          WRITE (6,90)  (TIDAL(K),K=1,4), TSCALE, RTIDE
   90     FORMAT (/,12X,'TIDAL PARAMETERS:  ',1P,4E10.2,
     &                  '  TSCALE =',E9.2,'  RTIDE =',0P,F6.2,/)
      END IF
*
      RETURN
*
      END


module accuracy
  implicit none
  private
  public sik, ik, hik, rk, ark, out, inp, safe_max,safe_min,max_exp, pi, twopi, cl, wl, c2
  public accuracyInitialize
  public planck,avogno,vellgt,boltz,bohr,todebye
  public epsil,small_,sqrt2,sqrt3,rad,fititermax,aston,hartree,ev,my_fmt
  !
  integer, parameter :: sik         = selected_int_kind(4)       ! Small integers
  integer, parameter :: ik          = selected_int_kind(8)       ! "Normal" integers. This must map on
                                                                 ! C "int" type, or the DX interface won't
                                                                 ! work correctly.
  integer, parameter :: hik         = selected_int_kind(8)       ! "Pointer" integers - sufficient to store
                                                                 ! memory address
  integer, parameter :: drk         = selected_real_kind(12,25)  ! "Double" reals and complex (complexi? :-)
  integer, parameter :: rk          = selected_real_kind(12,25)  ! "Normal" reals and complex (complexi? :-)
  integer, parameter :: ark         = selected_real_kind(12,25)  ! "Accurate" reals and complex (complexi? :-)
  integer, parameter :: inp         = 5                          ! Output I/O channel
  integer, parameter :: out         = 6                          ! Output I/O channel
  integer, parameter :: nfilelegendre = 101                      ! Damp-output channel for eigenfunction

  real(rk), parameter  :: safe_max   = exp(log(huge(1.0_rk))*0.25_rk)   ! Largest number we want to work with
  real(rk), parameter  :: safe_min   = exp(log(tiny(1.0_rk))*0.25_rk)   ! Smallest number we want to work with
                                                                        ! (The somewhat convoluted syntax is used to standard F95
                                                                        !  which prohibits non-integer exponents in this context)
  real(rk), parameter  :: max_exp    =log(safe_max)                     ! Largest number OK for exponentiating
  real(rk), parameter  :: small_     =epsilon(1.0_rk)                   ! a positive model number that is almost
                                                                        ! negligible compared to unity in the current model
                                                                 ! epsil - antisymmetric tensor (Levi-Civita symbol)
  real(rk), parameter :: epsil(3,3,3)=reshape( (/0,0,0,0,0,-1,0,1,0,0,0,1,0,0,0,&
                                                -1,0,0,0,-1,0,1,0,0,0,0,0/), (/3,3,3/) )
  real(rk), parameter :: pi    = 4.0_rk * atan2(1.0_rk,1.0_rk)   ! PI=3.14...
  real(rk), parameter :: twopi = 2.0_rk * pi                     ! 2*PI=6.28...
  real(rk), parameter :: sqrt2 = sqrt(2._rk)                     ! \sqrt{2}
  real(rk), parameter :: sqrt3 = sqrt(3._rk)                     ! \sqrt{3}
  real(rk), parameter :: rad   = 180._rk/pi                      ! radian = 180/pi
  integer, parameter  :: cl          = 80                        ! Max character string length
  integer, parameter  :: wl          = 500                       ! Very large max character string length
  character(len=cl)   :: my_fmt                                  !text variable containing formats for reads/writes
  integer, parameter  :: fititermax  = 200                       ! Max number of iterations in different fittings

  ! physical constants -- All constants updated 21 March 2012 from the NIST
  ! website http://physics.nist.gov/cuu/Constants/index.html
  real(drk), parameter :: planck     =  6.62606957e-27_rk         ! Planck constant in (non-SI) erg*second
  real(drk), parameter :: avogno     =  6.02214129e+23_rk         ! Avogadro constant
  real(drk), parameter :: vellgt     =  2.99792458e+10_rk         ! Speed of light constant in (non-SI) cm/second
  real(drk), parameter :: boltz      =  1.3806488e-16_rk          ! Boltzmann constant in (non-SI) erg/Kelvin
  real(drk), parameter :: bohr       =  0.52917720859_rk          ! bohr constant in Angstroms
  real(drk), parameter :: hartree    =  219474.6313705_rk         ! hartree in cm-1
  real(drk), parameter :: ev         =  8065.54465_rk             ! ev in cm-1
  real(drk), parameter :: uma        =  1.660538921e-24_rk        ! unified atomic mass unit [=mass(C-12)/12 ] in grams
  real(drk), parameter :: aston      =  planck/(8._rk*PI**2*vellgt*uma*1e-16_rk)  !rotational factor in cm-1 amu Ang^2
  real(drk), parameter :: todebye    =  2.541765_rk               ! a.u. in debye
  real(drk), parameter :: c2         =  1.43877736d0              ! second radiative constant NIST http://physics.nist.gov/cgi-bin/cuu/Value?c22ndrc

  contains

    subroutine accuracyInitialize  ! This initialization routine is now superfluous but kept for compatibility
     !
    end subroutine accuracyInitialize

end module accuracy


      subroutine solt

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine estimates daily average temperature at the bottom
!!    of each soil layer

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    albday      |none          |albedo of ground for day
!!    hru_ra(:)   |MJ/m^2        |solar radiation for the day in HRU
!!    hru_sub(:)  |none          |subbasin in which HRU is located
!!    ihru        |none          |HRU number
!!    sno_hru(:)  |mm H2O        |amount of water in snow in HRU on current day
!!    sol_avbd(:) |Mg/m^3        |average bulk density of soil profile
!!    sol_cov(:)  |kg/ha         |amount of residue on soil surface
!!    sol_nly(:)  |none          |number of soil layers in profile
!!    sol_sw(:)   |mm H2O        |amount of water stored in soil profile on
!!                               |any given day
!!    sol_tmp(:,:)|deg C         |average temperature of soil layer on previous
!!                               |day
!!    sol_z(:,:)  |mm            |depth to bottom of soil layer
!!    tmn(:)      |deg C         |minimum temperature for the day in HRU
!!    tmp_an(:)   |deg C         |average annual air temperature
!!    tmpav(:)    |deg C         |average temperature for the day in HRU
!!    tmx(:)      |deg C         |maximum temperature for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    sol_tmp(:,:)|deg C         |daily average temperature of soil layer
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    b           |none          |variable to hold intermediate calculation
!!    bcv         |none          |lagging factor for cover
!!    dd          |mm            |damping depth for day
!!    df          |none          |depth factor
!!    dp          |mm            |maximum damping depth
!!    f           |none          |variable to hold intermediate calculation
!!                               |result
!!    j           |none          |HRU number
!!    k           |none          |counter
!!    st0         |MJ/m^2        |radiation hitting soil surface on day
!!    tbare       |deg C         |temperature of bare soil surface
!!    tcov        |deg C         |temperature of soil surface corrected for
!!                               |cover
!!    tlag        |none          |lag coefficient for soil temperature
!!    tmp_srf     |deg C         |temperature of soil surface
!!    wc          |none          |scaling factor for soil water impact on daily
!!                               |damping depth
!!    ww          |none          |variable to hold intermediate calculation
!!    xx          |none          |variable to hold intermediate calculation
!!    zd          |none          |ratio of depth at center of layer to
!!                               |damping depth
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

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

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

      use parm

      integer :: j, k
      real :: f, dp, ww, b, wc, dd, xx, st0
      real :: tlag, df, zd, bcv, tbare, tcov, tmp_srf

      j = 0
      j = ihru

      tlag = 0.8

!! calculate damping depth

      !! calculate maximum damping depth
      !! SWAT manual equation 2.3.6
      f = 0.
      dp = 0.
      f = sol_avbd(j) / (sol_avbd(j) + 686. * Exp(-5.63 * sol_avbd(j)))
      dp = 1000. + 2500. * f

      !! calculate scaling factor for soil water
      !! SWAT manual equation 2.3.7
      ww = 0.
      wc = 0.
      ww = .356 - .144 * sol_avbd(j)
      wc = sol_sw(j) / (ww * sol_z(sol_nly(j),j))

      !! calculate daily value for damping depth
      !! SWAT manual equation 2.3.8
      b = 0.
      f = 0.
      dd = 0.
      b = Log(500. / dp)
      f = Exp(b * ((1. - wc) / (1. + wc))**2)
      dd = f * dp

!! calculate lagging factor for soil cover impact on soil surface temp
!! SWAT manual equation 2.3.11
      bcv = 0.
      bcv = sol_cov(j) /
     &                 (sol_cov(j) + Exp(7.563 - 1.297e-4 * sol_cov(j)))
      if (sno_hru(j) /= 0.) then
        if (sno_hru(j) <= 120.) then
          xx = 0.
          xx = sno_hru(j) /
     &                    (sno_hru(j) + Exp(6.055 - .3002 * sno_hru(j)))
        else
          xx = 1.
        end if
        bcv = Max(xx,bcv)
      end if

!! calculate temperature at soil surface
      st0 = 0.
      tbare = 0.
      tcov = 0.
      tmp_srf = 0.
      !! SWAT manual equation 2.3.10
      st0 = (hru_ra(j) * (1. - albday) - 14.) / 20.
      !! SWAT manual equation 2.3.9
      tbare = tmpav(j) + 0.5 * (tmx(j) - tmn(j)) * st0
      !! SWAT manual equation 2.3.12
      tcov = bcv * sol_tmp(2,j) + (1. - bcv) * tbare

!!    taking average of bare soil and covered soil as in APEX
!!    previously using minumum causing soil temp to decrease
!!    in summer due to high biomass

      tmp_srf = 0.5 * (tbare + tcov)  ! following Jimmy's code

!! calculate temperature for each layer on current day
      xx = 0.
      do k = 1, sol_nly(j)
        zd = 0.
        df = 0.
        zd = (xx + sol_z(k,j)) / 2.  ! calculate depth at center of layer
        zd = zd / dd                 ! SWAT manual equation 2.3.5
        !! SWAT manual equation 2.3.4
        df = zd / (zd + Exp(-.8669 - 2.0775 * zd))
        !! SWAT manual equation 2.3.3
        sol_tmp(k,j) = tlag * sol_tmp(k,j) + (1. - tlag) *
     &                   (df * (tmp_an(hru_sub(j)) - tmp_srf) + tmp_srf)
        xx = sol_z(k,j)

        ! Temperature correction for Onsite Septic systems
        if (isep_opt(j)/=0.and.iyr>=isep_iyr(j).and.k>=i_sep(j)) then
	   if (sol_tmp(k,j) < 10.) then
	      sol_tmp(k,j) = 10. - (10. - sol_tmp(k,j)) * 0.1
	   end if
	  endif

      end do

      return
      end


      Subroutine BCS(Np,Gp,x0,y0,E,Epc,delta)
*****************Newtons method for******************
*******solving a pair of non-linear equations********
*****************************************************
      Dimension E(364),vk2(364)
      Real Jac, lambda
      x=x0
      y=y0
5     Do 10 i=1,100
        iFlag=0
        Call Funcs(Np,Gp,x,y,F,dFx,dFy,G,dGx,dGy,E,iFlag)
        If(iFlag.EQ.0) Goto 15
        Dx=F*dGy-dFy*G
        Dy=dFx*G-F*dGx
        Jac=dFx*dGy-dFy*dGx
        x1=x-Dx/Jac
        y1=y-Dy/Jac
        If((Abs(Dx/Jac).LT.0.00001).AND.(Abs(Dy/Jac).LT.0.001))Then
          delta=Abs(x1)
          lambda=y1
          Goto 20
        Endif
        x=x1
        y=y1
10    Continue
15    Write(*,*)'BCS equations are not converging, Epc set to 0.0'
      Epc=0.0
      Return
20    Continue
      Sekvk2=0.0
      Sek=0.0
      Svk4=0.0
      S1=0.0
      Do 30 i = 1,Np
        Dr =((E(i)-lambda)**2+delta**2)**0.5
        vk2(i)=0.5*(1.0 - ((E(i)-lambda)/Dr))
        Sekvk2=Sekvk2+ E(i)*vk2(i)
        Svk4=Svk4+(vk2(i))**2
        If (i.GT.(Np/2)) Goto 30
          Sek=Sek+ E(i)
          S1=S1+ 1.0
30    Continue
      write(*,*)Sekvk2,Svk4,Sek,S1
      Epc = 2.0*(Sekvk2-Sek) - delta**2/Gp - Gp*(Svk4-S1)
      Write(*,'(3(5X,A,F10.5))')
     &      'Delta =',delta,'Lambda=',lambda,'Epc =',Epc

      End

      Subroutine Funcs(Np,Gp,x,y,F,dFx,dFy,G,dGx,dGy,E,iFlag)
      Dimension E(728)
      iFlag=0
*Note:  While compiling in DOS platform overflow checking commands
*   may need to be changed
      F=(-1.0)*Float(Np)
      G=(-1.0)*2.0/Gp
      dFx=0.0
      dFy=0.0
      dGx=0.0
      dGy=0.0
      Do 10 I=1,Np
        Dr =((E(I)-y)**2+x**2)**0.5
        dDr=Dr*((E(I)-y)**2+x**2)
        F=F+(1.0 - (E(I)-y)/Dr)
        dFx=dFx + x*(E(I)-y)/dDr
        dFy=dFy + x**2/dDr
        G=G+1.0/Dr
        dGx=dGx - x/dDr
        dGy=dFy + (E(I)-y)/dDr
10    Continue
      iFlag=1
      End


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     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 2);
!
!
!     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, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine defplas(elconloc,elas,emec,ithermal,icmd,
     &  beta,stre,ckl,vj)
!
!     calculates stiffness and stresses for the deformation plasticity
!     material law
!
!     icmd=3: calcutates stress at mechanical strain
!     else: calcutates stress and stiffness matrix at mechanical strain
!
      implicit none
!
      integer cauchy
!
      integer ithermal,icmd,i,j,k,l,m,n,ii,istart,iend,nt,kk(84)
!
      real*8 elconloc(*),elas(*),emec(*),beta(*),s(6),al,
     &  ee,un,s0,xn,stre(*),eq,c0,c1,c2,c3,dkl(3,3),ekl(3,3),
     &  q,dq,pp,el(6),ckl(3,3),vj
!
      kk=(/1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3,
     &  1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3,
     &  1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3,
     &  2,3,2,3/)
!
      cauchy=1
!
      istart=1
      iend=1
!
!     determining linear elastic material constants
!
      ee=elconloc(1)
      un=elconloc(2)
      s0=elconloc(3)
      xn=elconloc(4)
      al=elconloc(5)
!
      do i=1,6
         el(i)=emec(i)
      enddo
!
!     major loop
!
      do ii=istart,iend
!
         c0=(el(1)+el(2)+el(3))/3.d0
!
         el(1)=el(1)-c0
         el(2)=el(2)-c0
         el(3)=el(3)-c0
!
!        equivalent deviatoric strain
!
         eq=dsqrt(2.d0/3.d0*(el(1)*el(1)+el(2)*el(2)+
     &                       el(3)*el(3)+2.d0*(el(4)*el(4)+
     &                       el(5)*el(5)+el(6)*el(6))))
!
!        initial value of the Mises equivalent stress (q)
!
         c1=3.d0*ee*eq/(2.d0*(1.d0+un))
!
         if(c1.le.s0) then
            q=c1
         else
            q=(s0**(xn-1)*ee*eq/al)**(1.d0/xn)
         endif
!
!        determining the Mises equivalent stress q
!
         c1=2.d0*(1.d0+un)/3.d0
         do
            c2=al*(q/s0)**(xn-1.d0)
            dq=(ee*eq-(c1+c2)*q)/(c1+xn*c2)
            if((dabs(dq).lt.q*1.d-4).or.(dabs(dq).lt.1.d-10)) exit
            q=q+dq
         enddo
!
         if(icmd.ne.3) then
!
!           calculating the tangent stiffness matrix
!
!           initialization of the Delta Dirac function
!
            do i=1,3
               do j=1,3
                  dkl(i,j)=0.d0
               enddo
            enddo
            do i=1,3
               dkl(i,i)=1.d0
            enddo
!
            ekl(1,1)=el(1)
            ekl(2,2)=el(2)
            ekl(3,3)=el(3)
            ekl(1,2)=el(4)
            ekl(1,3)=el(5)
            ekl(2,3)=el(6)
            ekl(2,1)=ekl(1,2)
            ekl(3,1)=ekl(1,3)
            ekl(3,2)=ekl(2,3)
!
            if(eq.lt.1.d-10) then
               c1=ee/(1.d0+un)
               c2=0.d0
            else
               c1=2.d0/(3.d0*eq)
               c2=c1*(1.d0/eq-1.d0/(eq+(xn-1.d0)*c2*q/ee))
               c1=c1*q
            endif
            c3=(ee/(1.d0-2.d0*un)-c1)/3.d0
!
            nt=0
            do i=1,21
               k=kk(nt+1)
               l=kk(nt+2)
               m=kk(nt+3)
               n=kk(nt+4)
               nt=nt+4
               elas(i)=c1*((dkl(k,m)*dkl(l,n)+dkl(k,n)*dkl(l,m))/2.d0
     &                     -c2*ekl(k,l)*ekl(m,n))
     &                 +c3*dkl(k,l)*dkl(m,n)
            enddo
!
!           conversion of the stiffness matrix from spatial coordinates
!           coordinates into material coordinates
!
            call stiff2mat(elas,ckl,vj,cauchy)
!
         endif
!
!        calculating the stress
!
         pp=-ee*c0/(1.d0-2.d0*un)
!
         if(eq.lt.1.d-10) then
            c1=0.d0
         else
            c1=2.d0*q/(3.d0*eq)
         endif
!
         do i=1,6
            s(i)=el(i)*c1
         enddo
         do i=1,3
            s(i)=s(i)-pp
         enddo
!
         do i=1,6
            stre(i)=s(i)
         enddo
!
!        converting the stress into the material frame of
!        reference
!
         call str2mat(stre,ckl,vj,cauchy)
!
      enddo
!
      return
      end


      subroutine long_force(q, vlong, dvl)

      implicit real*8(a-h,o-z)

      include 'sizes.h'

      include 'qsats.h'

      common /bincom/ bin, binvrs, r2min

      real*8, intent(in)  :: q(NATOM3)
      real*8, intent(out) :: vlong, dvl(NATOM3)

      h2k = 3.157746d5

      vlong = 0d0
      do i=1,NATOMS
        x = q(3*i-2)
        y = q(3*i-1)
        z = q(3*i)

        vlong = vlong  - 0.147941E+01           -
     +           0.278253E-02*q(3*i-2)          +
     +           0.112328E-03*q(3*i-1)          +
     +           0.382942E-04*q(3*i)            -
     +           0.290524E-01*q(3*i-2)**2       -
     +           0.288602E-01*q(3*i-1)**2       -
     +           0.237969E-01*q(3*i)**2         +
     +           0.239032E-03*q(3*i-2)*q(3*i-1) -
     +           0.780090E-05*q(3*i-1)*q(3*i)   +
     +           0.103676E-05*q(3*i-2)*q(3*i)

        dvl(3*i-2) = -0.278253e-2-0.581048e-1*x  + 0.239032e-3*y +
     +                0.103676e-5*z
        dvl(3*i-1) =  0.112328e-3-0.577204e-1*y  + 0.239032e-3*x -
     +                0.780090e-5*z
        dvl(3*i)    =  0.382942e-4-0.475938e-1*z - 0.780090e-5*y +
     +                0.103676e-5*x
      enddo

c --- energy units conversion K ---> Hartree

      vlong = vlong/h2k
      dvl = dvl/h2k

      return
      end subroutine


      double complex function I3me(k1sq,k2sq,k3sq)
      implicit none
      include 'constants.f'
c     Triangle function with one internal mass and two spacelike
c     offshell lines and one timelike of mass k1sq
c
c                         | k2
c                         |
c                         /\
c                        /__\____
c               k3  *****-------- k1,(k1sq=msq)
c
c   Mass of the one massive internal line is equal to k1sq
c
c   Adapted from
c   %\cite{Denner:kt}
c   \bibitem{Denner:kt}
c   A.~Denner,
c   %``Techniques For Calculation Of Electroweak Radiative
c   Corrections At The One Loop Level And Results For W Physics At Lep-200,''
c   Fortsch.\ Phys.\  {\bf 41}, 307 (1993).
c   %%CITATION = FPYKA,41,307;%%

      integer i,j,k
      double precision lambda,alpha,y0(0:2),xp(0:2),xm(0:2),
     . yip(0:2),yim(0:2),alphai(0:2),x,y,z,k1sq,k2sq,k3sq
      double precision psq(0:2,0:2),msq(0:2),I3mer,I3mei

      double precision ddilog,polylog
      double precision aa,bb

      integer,parameter::jj(0:2)=(/1,2,0/)
      integer,parameter::kk(0:2)=(/2,0,1/)

      polylog(y,z)=ddilog((y-1d0)/z)-ddilog(y/z)
      lambda(x,y,z)=sqrt(x**2+y**2+z**2-2d0*(x*y+y*z+z*x))

      psq(0,1)=k1sq
      psq(1,2)=k2sq
      psq(2,0)=k3sq
      msq(0)=k1sq
      msq(1)=0d0
      msq(2)=0d0
      alpha=psq(0,1)**2+psq(1,2)**2+psq(2,0)**2
     . -2d0*(psq(0,1)*psq(1,2)+psq(1,2)*psq(2,0)+psq(2,0)*psq(0,1))
      if (alpha .lt. 0d0) then
      write(6,*) 'I3me:Formula not implemented for alpha imaginary'
      stop
      endif
      alpha=sqrt(alpha)
      I3mer=0d0
      I3mei=0d0
      do i=0,2
      j=jj(i)
      k=kk(i)
      alphai(i)=lambda(psq(j,k),msq(j),msq(k))
      y0(i)=0.5d0/alpha/psq(j,k)
     . *(psq(j,k)*(psq(j,k)-psq(k,i)-psq(i,j)
     . +2d0*msq(i)-msq(j)-msq(k))
     . -(psq(k,i)-psq(i,j))*(msq(j)-msq(k))
     . +alpha*(psq(j,k)-msq(j)+msq(k)))
      xp(i)=0.5d0/psq(j,k)*(psq(j,k)-msq(j)+msq(k)+alphai(i))
      xm(i)=0.5d0/psq(j,k)*(psq(j,k)-msq(j)+msq(k)-alphai(i))
      yip(i)=y0(i)-xp(i)
      yim(i)=y0(i)-xm(i)
      I3mer=I3mer+polylog(y0(i),yip(i))+polylog(y0(i),yim(i))

      enddo

      aa=(y0(1)-1d0)/yim(1)
      bb=y0(0)/yip(0)
      I3mei=pi*dlog(aa/bb)

C---- Minus sign for (-1)^n
      I3me=-Dcmplx(I3mer,I3mei)/alpha

      return
      end


      subroutine  rhs_face(vnx, vny, sar, dtv2, rmuem,
     #                     rl, pl, ul, vl,
     #                     rr, pr, ur, vr,
     #                     a1, a2, a3, a4,
     #                     rhs_f1, rhs_f2, rhs_f3, rhs_f4,
     #                     xx)
c
c******  computation of right-hand-side face-coefficients for sgs********
c
c
c     ******************************************************************
c
      use flo_param
c
c     ******************************************************************
c
      use solv_param
c
c     ******************************************************************
c
      implicit none
      real, dimension(4,4)      :: xx

      real     :: gm1,dlim
      real     :: vnx,vny,sar,dtv2,rmuem
      real     :: rl,pl,ul,vl,rr,pr,ur,vr,a1,a2,a3,a4
      real     :: rhoa,us,vs,ps,qs,ccs,cs
      real     :: e1,e2,e3,a,q1,q2,q3,r1,r2,aqsa
      real     :: amu,amupr,vq1,vr1
      real     :: a11,a12,a13,a14,a22,a23,a33,a41,a44
      real     :: rhs_f1,rhs_f2,rhs_f3,rhs_f4
c
      gm1     = gamma - 1.
      dlim    = .10
      if (kvis.eq.0) dlim = .25
      if (ncyc.lt.5) dlim = .5
c
c---- arithmetic averaging
c
      rhoa  = 0.5*(rl  +rr)
      us    = 0.5*(ul  +ur)
      vs    = 0.5*(vl  +vr)
      ps    = 0.5*(pl  +pr)
      qs    = vnx*us  +vny*vs
      ccs   = gamma*ps/rhoa
      cs    = sqrt(ccs)
c
c---- viscous coefficients
c
      amu   = dtv2*rmuem
      amupr = amu/(prn  +prt)
c
c---- eigenvalues
c
      e1    = abs(qs)
      e2    = abs(qs  +cs)
      e3    = abs(qs  -cs)
      a     = dlim*cs
      if (e1.lt.a) e1 = .5*(a  +e1*e1/a)
      if (e2.lt.a) e2 = .5*(a  +e2*e2/a)
      if (e3.lt.a) e3 = .5*(a  +e3*e3/a)
      a     = sar*dtv2
      aqsa  = a*diag*abs(qs)
c
c---- form the right hand side with the negative jacobian
c
      q1    = a*(qs  -e1)
      q2    = a*(qs  +cs  -e2)
      q3    = a*(qs  -cs  -e3)
      r1    = .5*(q2  +q3)  -q1
      r2    = .5*(q2  -q3)

      vq1   = q1  -amu
      vr1   = r1  -amu/3.

      a11   = r1  +q1  -gm1*amupr  -aqsa
      a12   = vnx*r2
      a13   = vny*r2
      a14   = -amupr
      a22   = vnx*vnx*vr1  +vq1  -aqsa
      a23   = vnx*vny*vr1
      a33   = vny*vny*vr1  +vq1  -aqsa
      a41   = -gm1*amupr
      a44   = q1  -amupr  -aqsa

      rhs_f1   = a11*a1  +a12*a2  +a13*a3  +a14*a4
      rhs_f2   = a12*a1  +a22*a2  +a23*a3
      rhs_f3   = a13*a1  +a23*a2  +a33*a3
      rhs_f4   = a41*a1  +a44*a4
c
c---- form the preconditioning matrix wtth the positive jacobian
c
      q1    = a*(qs  +e1)
      q2    = a*(qs  +cs  +e2)
      q3    = a*(qs  -cs  +e3)
      r1    = .5*(q2  +q3)  -q1
      r2    = .5*(q2  -q3)

      vq1   = q1  +amu
      vr1   = r1  +amu/3.

      xx(1,1)   =  r1  +q1  +gm1*amupr  +aqsa  + xx(1,1)
      xx(1,2)   =  vnx*r2                      + xx(1,2)
      xx(1,3)   =  vny*r2                      + xx(1,3)
      xx(1,4)   =  amupr                       + xx(1,4)

      xx(2,1)   =  vnx*r2                      + xx(2,1)
      xx(2,2)   =  vnx*vnx*vr1  +vq1  +aqsa    + xx(2,2)
      xx(2,3)   =  vnx*vny*vr1                 + xx(2,3)

      xx(3,1)   =  vny*r2                      + xx(3,1)
      xx(3,2)   =  vnx*vny*vr1                 + xx(3,2)
      xx(3,3)   =  vny*vny*vr1  +vq1  +aqsa    + xx(3,3)

      xx(4,1)   =  gm1*amupr                   + xx(4,1)
      xx(4,4)   =  q1  +amupr  +aqsa           + xx(4,4)

      return

      end


!***********************************/
!	Name:Venkatakrishnanリミッターを求めるプログラム
!	Alias:Venkatakrishnan
!	Description:既に求めてあるΔmax,Δmin,Δ_を元に各格子における流束制限関数を求める
!	Type:CellCenter
!	Input:Geometory,CC%VariationOfVariable,CC%GradientOfVariable,CE%NormalGradient
!	Output:CC%LimiterFunction
!	Note:法線ベクトルについての考慮は式自体に内包してあるのでいらない
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2018.01.11
!	Other:
!***********************************/
subroutine Venkatakrishnan(Geom,CC,CE)
    use StructVar_Mod
    use LoopVar_Mod
    use UVenkatakrishnanVar_Mod4OMP
    use ConstantVar_Mod, VPK => VenkatakrishnanParameterK
    implicit none
    type(Geometry), intent(in) :: Geom
    type(CellCenter), intent(inout) :: CC
    type(CellEdge), intent(inout) :: CE

    type(UVenkatakrishnanWithOMP) :: UV

        UV%VE2 = (VPK * 2.0d0*min(Geom%Width(1,1,1) , Geom%Width(1,1,2)))**3
        nullify(iCX,iCY,iCZ,iFX,iFY,iFZ,iVar)
        iVar => iVariable
        iFX => iFaceX
        iCX => iFaceX
        iFY => iFaceY
        iCY => iFaceY
        iFZ => iFaceZ
        iCZ => iFaceZ
    if(Geom%Dimension == 1) then
!端のセルではセル周囲変動量(Variation)を定義できないため計算不可であるため1.0(制限関数の最大値)を与える
!なんなら端だけ処理を分けてもいいけれど，セル中心の制限関数を計算するときのmin関数で影響が消えるはずなので問題ない...？ !問題出てたみたいです(01/09)
        CE%TmpLimiterFunction(:,0,1,1,1) = 1.0d0

        do iFaceX = 1, Geom%CellNumber(1)
            do iSide=1,2
            do iVariable=1,3
            if(CE%NormalGradient(iVar,iFX,1,1,iSide) > 0.0d0) then
                UV%iMaxMin => iOne
            else if(CE%NormalGradient(iVar,iFX,1,1,iSide) <= 0.0d0) then
                UV%iMaxMin => iTwo
            end if

            CE%TmpLimiterFunction(iVar,iFX,1,1,iSide) = &
                &   (CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,1,1)**2 + UV%VE2 &
                    &   + 2.0d0 * CE%NormalGradient(iVar,iFX,1,1,iSide)*CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,1,1)) &
                & / (CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,1,1)**2  + 2.0d0*CE%NormalGradient(iVar,iFX,1,1,iSide)**2&
                    &   + CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,1,1)*CE%NormalGradient(iVar,iFX,1,1,iSide) + UV%VE2)
            end do
            end do
        end do

        iCX => iCenterX
        iFX => iCenterX

        do iCenterX = 1, Geom%CellNumber(1)-1
            CC%LimiterFunction(:,iCX,1,1) = min(CE%TmpLimiterFunction(:,iFX-1,1,1,2),CE%TmpLimiterFunction(:,iFX,1,1,1),&
                &   CE%TmpLimiterFunction(:,iFX,1,1,2),CE%TmpLimiterFunction(:,iFX+1,1,1,1))
        end do
            CC%LimiterFunction(:,iCX,1,1) = min(CE%TmpLimiterFunction(:,iFX-1,1,1,1), &
                &   CE%TmpLimiterFunction(:,iFX-1,1,1,2),CE%TmpLimiterFunction(:,iFX,1,1,1))

    else if(Geom%Dimension == 2) then
        CE%TmpLimiterFunction = 1.0d0
!!$omp parallel num_threads(CoreNumberOfCPU),shared(Geom,CE,CC),firstprivate(iFaceX,iFaceY,iCenterX,iCenterY,iVariable,iLoop,UV)
!!$omp do
        do iFaceY = 1, Geom%CellNumber(2) !セル中心についてのループ
            do iFaceX = 1, Geom%CellNumber(1)
                do iVariable=1, Geom%Dimension+2 !変数についてのループ
                    do iLoop=1, 4 !界面についてのループ

                        if(CE%NormalGradient(iVariable,iFaceX,iFaceY,1,iLoop) == 0.0d0) then
                            CE%TmpLimiterFunction(iVariable,iFaceX,iFaceY,1,iLoop) = 1.0d0

                        else ! NormalGradient /= 0.0d0

                            if(CE%NormalGradient(iVariable,iFaceX,iFaceY,1,iLoop) > 0.0d0) then
                                UV%iMaxMin => iOne !Δmax
                            else !if(CE%NormalGradient(iVar,iFX,iFY,1,iLoop) < 0.0d0) then
                                UV%iMaxMin => iTwo !Δmin
                            end if

                            CE%TmpLimiterFunction(iVariable,iFaceX,iFaceY,1,iLoop) = &
                                &   (CC%VariationOfVariable(UV%iMaxMin,iVariable,iFaceX,iFaceY,1)**2 + UV%VE2 &
                                    &   + 2.0d0 * CE%NormalGradient(iVariable,iFaceX,iFaceY,1,iLoop)*CC%VariationOfVariable(UV%iMaxMin,iVariable,iFaceX,iFaceY,1)) &
                                & / (CC%VariationOfVariable(UV%iMaxMin,iVariable,iFaceX,iFaceY,1)**2  + 2.0d0*CE%NormalGradient(iVariable,iFaceX,iFaceY,1,iLoop)**2&
                                    &   + CC%VariationOfVariable(UV%iMaxMin,iVariable,iFaceX,iFaceY,1)*CE%NormalGradient(iVariable,iFaceX,iFaceY,1,iLoop) + UV%VE2)

                        end if
                    end do
                end do
            end do
        end do
!!$omp end do
!!$omp end parallel
!!$omp barrier

!Make Imaginary Cell's Limiter

!!$omp parallel num_threads(CoreNumberOfCPU),shared(Geom,CE,CC),private(iFaceX,iFaceY,iCenterX,iCenterY)
!!$omp do
        do iCenterY =1 ,Geom%CellNumber(2)
            do iCenterX = 1, Geom%CellNumber(1)
               CC%LimiterFunction(:,iCenterX,iCenterY,1) = &
                    &   min(CE%TmpLimiterFunction(:,iCenterX,iCenterY,1,1), CE%TmpLimiterFunction(:,iCenterX-1,iCenterY,1,2) &
                    &       ,CE%TmpLimiterFunction(:,iCenterX,iCenterY,1,2), CE%TmpLimiterFunction(:,iCenterX+1,iCenterY,1,1) &
                    &       ,CE%TmpLimiterFunction(:,iCenterX,iCenterY,1,3), CE%TmpLimiterFunction(:,iCenterX,iCenterY-1,1,4) &
                    &       ,CE%TmpLimiterFunction(:,iCenterX,iCenterY,1,4), CE%TmpLimiterFunction(:,iCenterX,iCenterY+1,1,3))
            end do
        end do

!!$omp end do
!!$omp end parallel
        nullify(iCX,iCY,iFX,iFY)

    else if(Geom%Dimension == 3) then
        CE%TmpLimiterFunction(:,0,:,:,1) = 1.0d0
        CE%TmpLimiterFunction(:,:,0,:,2) = 1.0d0
        CE%TmpLimiterFunction(:,:,:,0,3) = 1.0d0

        do iFaceZ =1, Geom%CellNumber(3)
            do iFaceY = 1, Geom%CellNumber(2)
                do iFaceX = 1, Geom%CellNumber(1)
                    do iVariable = 1, Geom%Dimension+2
                        do iLoop = 1, Geom%Dimension

            if(CE%NormalGradient(iVar,iFX,iFY,iFZ,iLoop) > 0.0d0) then
                UV%iMaxMin => iOne
            else if(CE%NormalGradient(iVar,iFX,iFY,iFZ,iLoop) <= 0.0d0) then
                UV%iMaxMin => iTwo
            end if

            CE%TmpLimiterFunction(iVar,iFX,iFY,iFZ,iLoop) = &
                &   (CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,iCY,iCZ)**2 + UV%VE2 &
                    &   + 2.0d0 * CE%NormalGradient(iVar,iFX,iFY,iFZ,iLoop)*CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,iCY,iCZ)) &
                & / (CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,iCY,iCZ)**2  + 2.0d0*CE%NormalGradient(iVar,iFX,iFY,iFZ,iLoop)**2&
                    &   + CC%VariationOfVariable(UV%iMaxMin,iVar,iCX,iCY,iCZ)*CE%NormalGradient(iVar,iFX,iFY,iFZ,iLoop) + UV%VE2)

                        end do
                    end do
                end do
            end do
        end do

        iCX => iCenterX
        iCY => iCenterY
        iFX => iCenterX
        iFY => iCenterY
        iCZ => iCenterZ
        iFZ => iCenterZ
        do iCenterZ = 1, Geom%CellNumber(3)
            do iCenterY = 1 ,Geom%CellNumber(2)
                do iCenterX = 1, Geom%CellNumber(1)
                CC%LimiterFunction(:,iCX,iCY,iCZ) = &
                    &   min(CE%TmpLimiterFunction(:,iFX-1,iFY,iFZ,1),CE%TmpLimiterFunction(:,iFX,iFY,iFZ,1),&
                    &       CE%TmpLimiterFunction(:,iFX,iFY-1,iFZ,2),CE%TmpLimiterFunction(:,iFX,iFY,iFZ,2),&
                    &       CE%TmpLimiterFunction(:,iFX,iFY,iFZ-1,3),CE%TmpLimiterFunction(:,iFX,iFY,iFZ,3))
                    end do
            end do
        end do

    end if
    return
end subroutine Venkatakrishnan