      DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A,
     $                                  LDA, B, LDB, C, LDC, NS, HSV,
     $                                  DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Hankel-norm of the ALPHA-stable projection of the
C     transfer-function matrix G of the state-space system (A,B,C).
C
C     FUNCTION VALUE
C
C     AB13AD  DOUBLE PRECISION
C             The Hankel-norm of the ALPHA-stable projection of G
C             (if INFO = 0).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
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     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e. the
C             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     ALPHA   (input) DOUBLE PRECISION
C             Specifies the ALPHA-stability boundary for the eigenvalues
C             of the state dynamics matrix A. For a continuous-time
C             system (DICO = 'C'), ALPHA <= 0 is the boundary value for
C             the real parts of eigenvalues, while for a discrete-time
C             system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
C             boundary value for the moduli of eigenvalues.
C             The ALPHA-stability domain does not include the boundary
C             (see the Note below).
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 state dynamics matrix A.
C             On exit, if INFO = 0, the leading N-by-N part of this
C             array contains the state dynamics matrix A in a block
C             diagonal real Schur form with its eigenvalues reordered
C             and separated. The resulting A has two diagonal blocks.
C             The leading NS-by-NS part of A has eigenvalues in the
C             ALPHA-stability domain and the trailing (N-NS) x (N-NS)
C             part has eigenvalues outside the ALPHA-stability domain.
C             Note: The ALPHA-stability domain is defined either
C                   as the open half complex plane left to ALPHA,
C                   for a continous-time system (DICO = 'C'), or the
C                   interior of the ALPHA-radius circle centered in the
C                   origin, for a discrete-time system (DICO = 'D').
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 N-by-M part of this
C             array contains the input/state matrix B of the transformed
C             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-N part of this
C             array contains the state/output matrix C of the
C             transformed system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     NS      (output) INTEGER
C             The dimension of the ALPHA-stable subsystem.
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, the leading NS elements of HSV contain the
C             Hankel singular values of the ALPHA-stable part of the
C             original system ordered decreasingly.
C             HSV(1) is the Hankel norm of the ALPHA-stable subsystem.
C
C     Workspace
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,N*(MAX(N,M,P)+5)+N*(N+1)/2).
C             For optimum performance LDWORK should be larger.
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 computation of the ordered real Schur form of A
C                   failed;
C             = 2:  the separation of the ALPHA-stable/unstable diagonal
C                   blocks failed because of very close eigenvalues;
C             = 3:  the computed ALPHA-stable part is just stable,
C                   having stable eigenvalues very near to the imaginary
C                   axis (if DICO = 'C') or to the unit circle
C                   (if DICO = 'D');
C             = 4:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let be the following linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(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 following procedure is used to
C     compute the Hankel-norm of the ALPHA-stable projection of G:
C
C     1) Decompose additively G as
C
C          G = G1 + G2
C
C        such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and
C        G2 = (Au,Bu,Cu) has only ALPHA-unstable poles.
C        For the computation of the additive decomposition, the
C        algorithm presented in [1] is used.
C
C     2) Compute the Hankel-norm of ALPHA-stable projection G1 as the
C        the maximum Hankel singular value of the system (As,Bs,Cs).
C        The computation of the Hankel singular values is performed
C        by using the square-root method of [2].
C
C     REFERENCES
C
C     [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J.
C         Synthesis of positive real multivariable feedback systems,
C         Int. J. Control, Vol. 45, pp. 817-842, 1987.
C
C     [2] Tombs, M.S. and Postlethwaite, I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     NUMERICAL ASPECTS
C
C     The implemented method relies on a square-root technique.
C                                     3
C     The algorithms require about 17N  floating point operations.
C
C     CONTRIBUTOR
C
C     C. Oara and A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine SHANRM.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Additive spectral decomposition, model reduction,
C     multivariable system, state-space model, system norms.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  C100, ONE, ZERO
      PARAMETER         ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, EQUIL
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           IERR, KT, KW, KW1, KW2
      DOUBLE PRECISION  ALPWRK, MAXRED, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  AB13AX, DLAMCH
      EXTERNAL          AB13AX, DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          TB01ID, TB01KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO  = 0
      DISCR = LSAME( DICO, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR.
     $                 LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR.
     $    ( .NOT.DISCR .AND.   ALPHA.GT.ZERO ) ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) +
     $                         ( N*( N + 1 ) )/2 ) ) THEN
         INFO = -16
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         NS = 0
         AB13AD = ZERO
         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        Workspace: N.
C
         MAXRED = C100
         CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
      END IF
C
C     Correct the value of ALPHA to ensure stability.
C
      ALPWRK = ALPHA
      IF( DISCR ) THEN
         IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) )
      ELSE
         IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) )
      END IF
C
C     Allocate working storage.
C
      KT  = 1
      KW1 = N*N + 1
      KW2 = KW1 + N
      KW  = KW2 + N
C
C     Reduce A to a block diagonal real Schur form, with the
C     ALPHA-stable part in the leading diagonal position, using a
C     non-orthogonal similarity transformation A <- inv(T)*A*T and
C     apply the transformation to B and C: B <- inv(T)*B and C <- C*T.
C
C     Workspace needed:      N*(N+2);
C     Additional workspace:  need   3*N;
C                            prefer larger.
C
      CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA,
     $             B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1),
     $             DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.NE.3 ) THEN
            INFO = 1
         ELSE
            INFO = 2
         END IF
         RETURN
      END IF
C
      WRKOPT = DWORK(KW) + DBLE( KW-1 )
C
      IF( NS.EQ.0 ) THEN
         AB13AD = ZERO
      ELSE
C
C        Workspace:  need   N*(MAX(N,M,P)+5)+N*(N+1)/2;
C                    prefer larger.
C
         AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV,
     $                    DWORK, LDWORK, IERR )
C
         IF( IERR.NE.0 ) THEN
            INFO = IERR + 2
            RETURN
         END IF
C
         DWORK(1) = MAX( WRKOPT, DWORK(1) )
      END IF
C
      RETURN
C *** Last line of AB13AD ***
      END


! chk_ieee_f2018.f90
!     Check: does the compiler support the Fortran 2018 extended IEEE features?
!
program chk_ieee_f2018
    use ieee_arithmetic
    use ieee_exceptions
    implicit none

    real                   :: single
    real(kind=kind(1.0d0)) :: double

    type(ieee_modes_type)  :: mode
    type(ieee_round_type)  :: round

    integer                :: radix

    write( *, '(a)' )        'IEEE arithmetic support (Fortran 2018):'
    write( *, '(a20,3a10)' ) 'Type of support', ' All kinds', '    Single', '    Double'
    write( *, '(a20,3l10)' ) 'Subnormal   ',ieee_support_subnormal(), ieee_support_subnormal(single), ieee_support_subnormal(double)

    !
    ! Simply call some of the new subroutines - the linker makes the check
    !
    call ieee_get_modes( modes )

    call ieee_get_rounding_mode( round, radix )

    single = ieee_real( 1.1d0 )
    single = ieee_fma( 1.1d0, 2.3d0, 4.2d0 )

end program chk_ieee_f2018


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE PTFUNC (KIND,IVAR,S,T,VAR,V)
C
C     ******************************************************************
C
C     SUBROUTINE TO EVALUATE A DEPENDENT VARIABLE AT A GIVEN POINT (S,T)
C     WITHIN AN ELEMENT
C
C     ******************************************************************
C
      DIMENSION VAR(9)
C
C     ******************************************************************
C
      GO TO (10, 10, 20, 20, 30, 30), KIND
C
C     TRIANGULAR ELEMENTS (TRI6/3,TRI6/6)
C
   10 CONTINUE
      IF (IVAR.EQ.3) THEN
      V=S*VAR(1)+T*VAR(2)+(1.-S-T)*VAR(3)
       ELSE
      V=(2.*S*S-S)*VAR(1)+(2.*T*T-T)*VAR(2)+(2.*(S+T)**2-3.*(S+T)+1.)*
     1VAR(3)+(4.*S*T)*VAR(4)+(-4.*T*T-4.*S*T+4.*T)*VAR(5)+(-4.*S*S-4.*S*
     2T+4.*S)*VAR(6)
      END IF
      RETURN
C
C     QUADRILATERAL ELEMENTS (QUAD8/4,QUAD8/8)
C
   20 CONTINUE
      IF (IVAR.EQ.3) THEN
      V=.25*(1.-S)*(1.-T)*VAR(1)+.25*(1.+S)*(1.-T)*VAR(2)+.25*(1.+S)*
     1(1.+T)*VAR(3)+.25*(1.-S)*(1.+T)*VAR(4)
       ELSE
      V=.25*(1.-S)*(1.-T)*(-S-T-1.)*VAR(1)+.25*(1.+S)*(1.-T)*(S-T-1.)*
     1VAR(2)+.25*(1.+S)*(1.+T)*(S+T-1.)*VAR(3)+.25*(1.-S)*(1.+T)*
     2(-S+T-1.)*VAR(4)+.50*(1.-S*S)*(1.-T)*VAR(5)+.50*(1.+S)*(1.-T*T)*
     3VAR(6)+.50*(1.-S*S)*(1.+T)*VAR(7)+.50*(1.-S)*(1.-T*T)*VAR(8)
      END IF
      RETURN
C
C     QUADRILATERAL ELEMENTS (QUAD9/4,QUAD9/9)
C
   30 CONTINUE
      IF (IVAR.EQ.3) THEN
      V=.25*(1.-S)*(1.-T)*VAR(1)+.25*(1.+S)*(1.-T)*VAR(2)+.25*(1.+S)*
     1(1.+T)*VAR(3)+.25*(1.-S)*(1.+T)*VAR(4)
       ELSE
      V=.25*(1.-S)*(1.-T)*(S*T)*VAR(1)+.25*(1.+S)*(1.-T)*(-S*T)*VAR(2)+
     1.25*(1.+S)*(1.+T)*(S*T)*VAR(3)+.25*(1.-S)*(1.+T)*(-S*T)*VAR(4)+
     2.50*(1.-S*S)*(1.-T)*(-T)*VAR(5)+.50*(1.+S)*(1.-T*T)*(S)*VAR(6)+
     3.50*(1.-S*S)*(1.+T)*(T)*VAR(7)+.50*(1.-S)*(1.-T*T)*(-S)*VAR(8)+
     4(1.-S*S)*(1.-T*T)*VAR(9)
      END IF
C
      RETURN
      END


module PlanetsConstants
!-------------------------------------------------------------------------------
!
!   Constants related to the planets that are useful for gravity and topography
!   analyses.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    implicit none

    real*8, parameter :: &
        Grav_constant = 6.67408d-11, & ! CODATA 2014, Mohr et al. (2016)
        pi_constant =  3.14159265358979
    real*8, parameter :: &
        mu0_constant = pi_constant * 4.0d-7 ! magnetic constant

    ! The Moon
    real*8, parameter :: &
        R_Moon = 1737151.0d0, & ! Wieczorek (2015)
        GM_Moon = 4902.80007d9, & ! DE430, Williams et al. (2014)
        Mass_Moon = GM_Moon / Grav_constant, & ! Wieczorek et al. (2005)
        a_orbit_Moon = 384399.014d3 , & ! DE430, Williams et al. (2013)
        Omega_Moon = 2.0d0 * pi_constant / 27.3215820d0 / 24.0d0 / 60.0d0 / 60.0d0, & ! Yoder (1995)
        I_Solid_Moon = 0.3931120d0, & ! Williams et al. (2016)
        gamma_Moon = 227.7317d-6, & ! (B-A)/C, Williams et al. (2014)
        beta_Moon = 631.0213d-6 ! (C-A)/B, Williams et al. (2014)
    real*8, parameter ::  &
        density_Moon = Mass_Moon * 3.0d0 / 4.0d0 / pi_constant / R_Moon**3, &
        g0_Moon = GM_Moon / R_Moon**2 ! gravitational acceleration at R_Moon, not including rotation.

    ! Mars
    real*8, parameter :: &
        R_Mars = 3389500.12207057, & ! MarsTopo2600, Wieczorek (2015)
        GM_Mars = 0.4282837581575610d+14, & ! jgmro_120d, Konopliv et al. (2016)
        Mass_Mars = GM_Mars / Grav_constant, & ! GM / Grav_constant
        Omega_Mars = 350.891985307d0 * pi_constant / 180.0d0 / 24.0d0 / 60.0d0 / 60.0d0, & ! Konopliv et al. (2016)
        f_Mars = 0.0052276178, & ! Ardalan et al. (2010)
        a_Mars = 3395.42800d3, & ! Ardalan et al. (2010)
        b_Mars = 3377.6780d3, & ! Ardalan et al. (2010)
        U0_mars = 12654875.0d0 ! Ardalan et al. (2010)
    real*8, parameter :: &
        g0_Mars = GM_Mars / R_Mars**2, & ! gravitational acceleration at R_Mars, not including rotation.&
        density_Mars = Mass_Mars * 3.0d0 / 4.0d0 / pi_constant / R_Mars**3

    ! Venus
    real*8, parameter :: &
        R_Venus = 6051.877d3, & ! VenusTopo719, Wieczorek (2015)
        GM_Venus = 324858.592079d9, & ! MGNP180U, Konopliv et al. (1999)
        Mass_Venus = GM_Venus / Grav_constant, & ! GM / Grav_constant
        Omega_Venus = -2.0d0 * pi_constant / 243.020d0 / 24.0d0 / 60.0d0 / 60.0d0 ! Konopliv et al. (1999)
    real*8, parameter :: &
        density_Venus = Mass_Venus * 3.0d0 / 4.0d0 / pi_constant / R_Venus**3, &
        g0_Venus = GM_Venus / R_Venus**2

    ! Earth
    real*8, parameter :: &
        GM_egm2008 = 3986004.415d8, & ! EGM2008, Pavlis et al. (2012)
        Mass_egm2008 = GM_egm2008 / Grav_constant, &
        a_WGS84 = 6378137.0d0, & ! WGS84 ellipsoid semi-major axis
        f_WGS84 = 1.0d0 / 298.2572235630d0, & ! WGS84 ellipsoid flattening
        gm_WGS84 = 3986004.418d8, & ! WGS84 gm, including the atmosphere
        Mass_WGS84 = GM_WGS84 / Grav_constant, &
        omega_WGS84 = 7292115.0d-11, & ! WGS84 angular velocity
        gma_WGS84 = 3.50d8, & ! WGS84 GM of the atmosphere
        b_WGS84 = 6356752.31420d0, & ! WGS84 semi-minor axis
        U0_WGS84 = 62636851.7146d0, & ! WGS84 Theoretical normal potential
        r3_WGS84 = 6371000.7900d0 ! WGS84 Radius of sphere of equal volume

    ! Mercury
    real*8, parameter :: &
        GM_Mercury = 2.2031815411154894d+13, & ! ggmes_100v07, Mazarico et al. (2014)
        Mass_Mercury = GM_Mercury / Grav_constant, &
        R_Mercury = 2439.40197456433d3, & ! gtmes_150v05, Smith et al. (2012)
        Omega_orbit_Mercury = 2.0d0 * pi_constant / 87.969216879d0 / 24.0d0 / 60.0d0 / 60.0d0, & ! ggmes_100v07, Mazarico et al. (2014)
        Omega_Mercury = 6.1385108d0 * 2.0d0 * pi_constant / 360.0d0 / (24.0d0 * 60.0d0 * 60.0d0) ! ggmes_100v07, Mazarico et al. (2014)
    real*8, parameter :: &
        density_Mercury = Mass_Mercury * 3.0d0 / 4.0d0 / pi_constant / R_Mercury**3, &
        g0_Mercury = GM_Mercury / R_Mercury**2

end module PlanetsConstants


!*==ctgsy2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CTGSY2 solves the generalized Sylvester equation (unblocked algorithm).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CTGSY2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
!                          LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
!                          INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
!       REAL               RDSCAL, RDSUM, SCALE
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * ),
!      $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CTGSY2 solves the generalized Sylvester equation
!>
!>             A * R - L * B = scale *  C               (1)
!>             D * R - L * E = scale * F
!>
!> using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,
!> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
!> N-by-N and M-by-N, respectively. A, B, D and E are upper triangular
!> (i.e., (A,D) and (B,E) in generalized Schur form).
!>
!> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
!> scaling factor chosen to avoid overflow.
!>
!> In matrix notation solving equation (1) corresponds to solve
!> Zx = scale * b, where Z is defined as
!>
!>        Z = [ kron(In, A)  -kron(B**H, Im) ]             (2)
!>            [ kron(In, D)  -kron(E**H, Im) ],
!>
!> Ik is the identity matrix of size k and X**H is the transpose of X.
!> kron(X, Y) is the Kronecker product between the matrices X and Y.
!>
!> If TRANS = 'C', y in the conjugate transposed system Z**H*y = scale*b
!> is solved for, which is equivalent to solve for R and L in
!>
!>             A**H * R  + D**H * L   = scale * C           (3)
!>             R  * B**H + L  * E**H  = scale * -F
!>
!> This case is used to compute an estimate of Dif[(A, D), (B, E)] =
!> = sigma_min(Z) using reverse communication with CLACON.
!>
!> CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL
!> of an upper bound on the separation between to matrix pairs. Then
!> the input (A, D), (B, E) are sub-pencils of two matrix pairs in
!> CTGSYL.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          = 'N': solve the generalized Sylvester equation (1).
!>          = 'T': solve the 'transposed' system (3).
!> \endverbatim
!>
!> \param[in] IJOB
!> \verbatim
!>          IJOB is INTEGER
!>          Specifies what kind of functionality to be performed.
!>          = 0: solve (1) only.
!>          = 1: A contribution from this subsystem to a Frobenius
!>               norm-based estimate of the separation between two matrix
!>               pairs is computed. (look ahead strategy is used).
!>          = 2: A contribution from this subsystem to a Frobenius
!>               norm-based estimate of the separation between two matrix
!>               pairs is computed. (SGECON on sub-systems is used.)
!>          Not referenced if TRANS = 'T'.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          On entry, M specifies the order of A and D, and the row
!>          dimension of C, F, R and L.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          On entry, N specifies the order of B and E, and the column
!>          dimension of C, F, R and L.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA, M)
!>          On entry, A contains an upper triangular matrix.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the matrix A. LDA >= max(1, M).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB, N)
!>          On entry, B contains an upper triangular matrix.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the matrix B. LDB >= max(1, N).
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX array, dimension (LDC, N)
!>          On entry, C contains the right-hand-side of the first matrix
!>          equation in (1).
!>          On exit, if IJOB = 0, C has been overwritten by the solution
!>          R.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the matrix C. LDC >= max(1, M).
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is COMPLEX array, dimension (LDD, M)
!>          On entry, D contains an upper triangular matrix.
!> \endverbatim
!>
!> \param[in] LDD
!> \verbatim
!>          LDD is INTEGER
!>          The leading dimension of the matrix D. LDD >= max(1, M).
!> \endverbatim
!>
!> \param[in] E
!> \verbatim
!>          E is COMPLEX array, dimension (LDE, N)
!>          On entry, E contains an upper triangular matrix.
!> \endverbatim
!>
!> \param[in] LDE
!> \verbatim
!>          LDE is INTEGER
!>          The leading dimension of the matrix E. LDE >= max(1, N).
!> \endverbatim
!>
!> \param[in,out] F
!> \verbatim
!>          F is COMPLEX array, dimension (LDF, N)
!>          On entry, F contains the right-hand-side of the second matrix
!>          equation in (1).
!>          On exit, if IJOB = 0, F has been overwritten by the solution
!>          L.
!> \endverbatim
!>
!> \param[in] LDF
!> \verbatim
!>          LDF is INTEGER
!>          The leading dimension of the matrix F. LDF >= max(1, M).
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is REAL
!>          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
!>          R and L (C and F on entry) will hold the solutions to a
!>          slightly perturbed system but the input matrices A, B, D and
!>          E have not been changed. If SCALE = 0, R and L will hold the
!>          solutions to the homogeneous system with C = F = 0.
!>          Normally, SCALE = 1.
!> \endverbatim
!>
!> \param[in,out] RDSUM
!> \verbatim
!>          RDSUM is REAL
!>          On entry, the sum of squares of computed contributions to
!>          the Dif-estimate under computation by CTGSYL, where the
!>          scaling factor RDSCAL (see below) has been factored out.
!>          On exit, the corresponding sum of squares updated with the
!>          contributions from the current sub-system.
!>          If TRANS = 'T' RDSUM is not touched.
!>          NOTE: RDSUM only makes sense when CTGSY2 is called by
!>          CTGSYL.
!> \endverbatim
!>
!> \param[in,out] RDSCAL
!> \verbatim
!>          RDSCAL is REAL
!>          On entry, scaling factor used to prevent overflow in RDSUM.
!>          On exit, RDSCAL is updated w.r.t. the current contributions
!>          in RDSUM.
!>          If TRANS = 'T', RDSCAL is not touched.
!>          NOTE: RDSCAL only makes sense when CTGSY2 is called by
!>          CTGSYL.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          On exit, if INFO is set to
!>            =0: Successful exit
!>            <0: If INFO = -i, input argument number i is illegal.
!>            >0: The matrix pairs (A, D) and (B, E) have common or very
!>                close eigenvalues.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexSYauxiliary
!
!> \par Contributors:
!  ==================
!>
!>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!>     Umea University, S-901 87 Umea, Sweden.
!
!  =====================================================================
      SUBROUTINE CTGSY2(Trans,Ijob,M,N,A,Lda,B,Ldb,C,Ldc,D,Ldd,E,Lde,F, &
     &                  Ldf,Scale,Rdsum,Rdscal,Info)
      IMPLICIT NONE
!*--CTGSY2262
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER Ijob , Info , Lda , Ldb , Ldc , Ldd , Lde , Ldf , M , N
      REAL Rdscal , Rdsum , Scale
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , B(Ldb,*) , C(Ldc,*) , D(Ldd,*) , E(Lde,*) ,    &
     &        F(Ldf,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      INTEGER LDZ
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0,LDZ=2)
!     ..
!     .. Local Scalars ..
      LOGICAL notran
      INTEGER i , ierr , j , k
      REAL scaloc
      COMPLEX alpha
!     ..
!     .. Local Arrays ..
      INTEGER ipiv(LDZ) , jpiv(LDZ)
      COMPLEX rhs(LDZ) , z(LDZ,LDZ)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL CAXPY , CGESC2 , CGETC2 , CSCAL , CLATDF , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CMPLX , CONJG , MAX
!     ..
!     .. Executable Statements ..
!
!     Decode and test input parameters
!
      Info = 0
      ierr = 0
      notran = LSAME(Trans,'N')
      IF ( .NOT.notran .AND. .NOT.LSAME(Trans,'C') ) THEN
         Info = -1
      ELSEIF ( notran ) THEN
         IF ( (Ijob<0) .OR. (Ijob>2) ) Info = -2
      ENDIF
      IF ( Info==0 ) THEN
         IF ( M<=0 ) THEN
            Info = -3
         ELSEIF ( N<=0 ) THEN
            Info = -4
         ELSEIF ( Lda<MAX(1,M) ) THEN
            Info = -6
         ELSEIF ( Ldb<MAX(1,N) ) THEN
            Info = -8
         ELSEIF ( Ldc<MAX(1,M) ) THEN
            Info = -10
         ELSEIF ( Ldd<MAX(1,M) ) THEN
            Info = -12
         ELSEIF ( Lde<MAX(1,N) ) THEN
            Info = -14
         ELSEIF ( Ldf<MAX(1,M) ) THEN
            Info = -16
         ENDIF
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CTGSY2',-Info)
         RETURN
      ENDIF
!
      IF ( notran ) THEN
!
!        Solve (I, J) - system
!           A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
!           D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
!        for I = M, M - 1, ..., 1; J = 1, 2, ..., N
!
         Scale = ONE
         scaloc = ONE
         DO j = 1 , N
            DO i = M , 1 , -1
!
!              Build 2 by 2 system
!
               z(1,1) = A(i,i)
               z(2,1) = D(i,i)
               z(1,2) = -B(j,j)
               z(2,2) = -E(j,j)
!
!              Set up right hand side(s)
!
               rhs(1) = C(i,j)
               rhs(2) = F(i,j)
!
!              Solve Z * x = RHS
!
               CALL CGETC2(LDZ,z,LDZ,ipiv,jpiv,ierr)
               IF ( ierr>0 ) Info = ierr
               IF ( Ijob==0 ) THEN
                  CALL CGESC2(LDZ,z,LDZ,rhs,ipiv,jpiv,scaloc)
                  IF ( scaloc/=ONE ) THEN
                     DO k = 1 , N
                        CALL CSCAL(M,CMPLX(scaloc,ZERO),C(1,k),1)
                        CALL CSCAL(M,CMPLX(scaloc,ZERO),F(1,k),1)
                     ENDDO
                     Scale = Scale*scaloc
                  ENDIF
               ELSE
                  CALL CLATDF(Ijob,LDZ,z,LDZ,rhs,Rdsum,Rdscal,ipiv,jpiv)
               ENDIF
!
!              Unpack solution vector(s)
!
               C(i,j) = rhs(1)
               F(i,j) = rhs(2)
!
!              Substitute R(I, J) and L(I, J) into remaining equation.
!
               IF ( i>1 ) THEN
                  alpha = -rhs(1)
                  CALL CAXPY(i-1,alpha,A(1,i),1,C(1,j),1)
                  CALL CAXPY(i-1,alpha,D(1,i),1,F(1,j),1)
               ENDIF
               IF ( j<N ) THEN
                  CALL CAXPY(N-j,rhs(2),B(j,j+1),Ldb,C(i,j+1),Ldc)
                  CALL CAXPY(N-j,rhs(2),E(j,j+1),Lde,F(i,j+1),Ldf)
               ENDIF
!
            ENDDO
         ENDDO
      ELSE
!
!        Solve transposed (I, J) - system:
!           A(I, I)**H * R(I, J) + D(I, I)**H * L(J, J) = C(I, J)
!           R(I, I) * B(J, J) + L(I, J) * E(J, J)   = -F(I, J)
!        for I = 1, 2, ..., M, J = N, N - 1, ..., 1
!
         Scale = ONE
         scaloc = ONE
         DO i = 1 , M
            DO j = N , 1 , -1
!
!              Build 2 by 2 system Z**H
!
               z(1,1) = CONJG(A(i,i))
               z(2,1) = -CONJG(B(j,j))
               z(1,2) = CONJG(D(i,i))
               z(2,2) = -CONJG(E(j,j))
!
!
!              Set up right hand side(s)
!
               rhs(1) = C(i,j)
               rhs(2) = F(i,j)
!
!              Solve Z**H * x = RHS
!
               CALL CGETC2(LDZ,z,LDZ,ipiv,jpiv,ierr)
               IF ( ierr>0 ) Info = ierr
               CALL CGESC2(LDZ,z,LDZ,rhs,ipiv,jpiv,scaloc)
               IF ( scaloc/=ONE ) THEN
                  DO k = 1 , N
                     CALL CSCAL(M,CMPLX(scaloc,ZERO),C(1,k),1)
                     CALL CSCAL(M,CMPLX(scaloc,ZERO),F(1,k),1)
                  ENDDO
                  Scale = Scale*scaloc
               ENDIF
!
!              Unpack solution vector(s)
!
               C(i,j) = rhs(1)
               F(i,j) = rhs(2)
!
!              Substitute R(I, J) and L(I, J) into remaining equation.
!
               DO k = 1 , j - 1
                  F(i,k) = F(i,k) + rhs(1)*CONJG(B(k,j)) + rhs(2)       &
     &                     *CONJG(E(k,j))
               ENDDO
               DO k = i + 1 , M
                  C(k,j) = C(k,j) - CONJG(A(i,k))*rhs(1) - CONJG(D(i,k))&
     &                     *rhs(2)
               ENDDO
!
            ENDDO
         ENDDO
      ENDIF
!
!     End of CTGSY2
!
      END SUBROUTINE CTGSY2


      REAL FUNCTION slRVGA (R2000, D2000)
*+
*     - - - - - - -
*      R V G A
*     - - - - - - -
*
*  Velocity component in a given direction due to the rotation
*  of the Galaxy (single precision)
*
*  Given:
*     R2000,D2000   real    J2000.0 mean RA,Dec (radians)
*
*  Result:
*     Component of dynamical LSR motion in direction R2000,D2000 (km/s)
*
*  Sign convention:
*     The result is +ve when the dynamical LSR is receding from the
*     given point on the sky.
*
*  Note:  The Local Standard of Rest used here is a point in the
*         vicinity of the Sun which is in a circular orbit around
*         the Galactic centre.  Sometimes called the "dynamical" LSR,
*         it is not to be confused with a "kinematical" LSR, which
*         is the mean standard of rest of star catalogues or stellar
*         populations.
*
*  Reference:  The orbital speed of 220 km/s used here comes from
*              Kerr & Lynden-Bell (1986), MNRAS, 221, p1023.
*
*  Called:
*     slCS2C, slVDV
*
*  P.T.Wallace   Starlink   23 March 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL R2000,D2000

      REAL VA(3), VB(3)

      REAL slVDV

*
*  LSR velocity due to Galactic rotation
*
*  Speed = 220 km/s
*  Apex  = L2,B2  90deg, 0deg
*        = RA,Dec  21 12 01.1  +48 19 47  J2000.0
*
*  This is expressed in the form of a J2000.0 x,y,z vector:
*
*      VA(1) = X = -SPEED*COS(RA)*COS(DEC)
*      VA(2) = Y = -SPEED*SIN(RA)*COS(DEC)
*      VA(3) = Z = -SPEED*SIN(DEC)

      DATA VA / -108.70408, +97.86251, -164.33610 /

*  Convert given J2000 RA,Dec to x,y,z
      CALL slCS2C(R2000,D2000,VB)

*  Compute dot product with LSR motion vector
      slRVGA=slVDV(VA,VB)

      END


C
C      **********************************************************************
C      ********************* SUBROUTINE COXREG  *****************************
C      **********************************************************************
C
       SUBROUTINE COXREG(IND,X,Y,NVAR,NTOT,ICENS,CHI,PROB,
     +                      RINFO,SCORE,FINFO,IL,IM)
C
C      *      THIS PROGRAM COMPUTES A CORRELATION PROBABILITY ACCORDING     *
C      *      TO COX'S (1972) PROPORTIONAL HAZARDS MODEL.                   *
C      *      ONLY ONE TYPE OF CENSORING (I.E. LOWER OR UPPER)              *
C      *      IS ALLOWED IN Y, BUT UP TO NVAR INDEPENDENT VARIABLES CAN     *
C      *      BE USED. THE HYPOTHESIS TESTED IS THE ABSENCE OF CORRELATION  *
C      *      BETWEEN THE DEPENDENT VARIABLE AND INDEPENDENT VARIABLES.     *
C      *      THEREFORE, THE  REGRESSION COEFFICIENT IN COX MODEL BETA      *
C      *      IS SET TO ZERO.                                               *
C
C      * NOTE NOTE NOTE:   THE PROBABILITY CALCULATED MAY NOT BE ACCURATE   *
C      *      WHEN THERE ARE A LARGE NUMBER OF TIED OBSERVATIONS (CF.       *
C      *      R. G. MILLER, SURVIVAL ANALYSIS, 1981, PP. 136-7).            *
C
C      *                                                                    *
C      *      INPUT    IND(I)  :  INDICATOR OF CENSORING                    *
C      *                           0 : UNCENSORED DATA POINT                *
C      *                           1 : Y(I) IS LOWER LIMIT                  *
C      *                          -1 : Y(I) IS UPPER LIMIT                  *
C      *              X(J,I)   :  INDEPENDENT VARIABLES (J=1,..NVAR)        *
C      *              Y(I)     :  DEPENDENT VARIABLE                        *
C      *               NVAR    :  NO. OF INDEPENDENT VARIABLES              *
C      *               NTOT    :  TOTAL NO. OF OBSERVATIONS                 *
C      *                                                                    *
C      *       WORK      DF    :  DEGREE OF FREEDOM                         *
C      *                IL(I)  :  INDICATOR OF TIES (#  OF TIES)            *
C      *                IM(I)  :  INDICATOR OF TIES (POSITION)              *
C      *               RINFO(I):  INFORMATION MATRIX AND ITS INVERSE        *
C      *                          MATRIX AFTER CALLING SUBROUTINE           *
C      *                          MATINV.                                   *
C      *               SCORE(I):  SCORE VECTOR                              *
C      *                                                                    *
C      *     OUTPUT       CHI  :  GLOBAL CHI-SQUARE                         *
C      *                 PROB  :  PROBABILITY OF CORRELATION                *
C      *                                                                    *
C      *     SUBROUTINES                                                    *
C      *                          CXSORT, TIE, MATINV, PCHISQ               *
C      *                                                                    *
C      *     REFERENCE:    RUPERT G. MILLER JR., "SURVIVAL ANALYSIS", 1981, *
C      *                         JOHN WILEY & SONS (NY:NY)                  *
C      *                                                                    *
C
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)

       DIMENSION IND(NTOT),Y(NTOT),X(NVAR,NTOT),IL(NTOT),IM(NTOT)
       DIMENSION RINFO(NVAR,NVAR),SCORE(NVAR),FINFO(NVAR)
C
       DF=NVAR
C
       DO 20 I=1,NTOT
          IF(ICENS.EQ.-1) Y(I)=-Y(I)
C
C      *  IF THE OBSERVATION IS CENSORED, ADD A SMALL NUMBER TO AVOID TIES  *
C      *  WITH DETECTED VALUE.                                              *
C
          IF(IND(I).NE.0) Y(I)=Y(I)*(1.0+FLOAT(ICENS)*0.0000001)
C
          DO 10 J=1,NVAR
             IF(ICENS.EQ.-1) X(J,I)=-X(J,I)
   10     CONTINUE
   20  CONTINUE
C
C      *           SORT Y IN ASCENDING ORDER                                *
C
       CALL CXSORT(IND,X,Y,NVAR,NTOT)
C
C      *          CHECK TIED DATA POINTS AND GIVE THEM A SPECIAL FLAG.      *
C
       CALL TIE(IND,X,Y,NVAR,NTOT,IL,IM)
C
C      *         COMPUTE SCORE VECTOR. DIMENSION IS NVAR                    *
C
       DO 600 I=1,NVAR
          SCORE(I)=0.0
C
          DO 500 J=1,NTOT
             IF(IND(J).EQ.0) THEN
                IF(IL(J).EQ.1) THEN
                   SUM=0.0
C
                   DO 400 K=J,NTOT
                      SUM=SUM+X(I,K)
  400              CONTINUE
C
                   JJ=J+IM(J)-1
                   XSUM=0.0
                   DO 450 KL=J,JJ
                      XSUM=XSUM+X(I,KL)
  450              CONTINUE
C
                   DEN=REAL(NTOT+1-J)
                   SCORE(I)=SCORE(I)+XSUM-IM(J)*SUM/DEN
                ENDIF
             ENDIF
  500     CONTINUE
  600  CONTINUE
C
C      *    COMPUTE THE INFORMATION MATRIX. DIMENSION IS NVAR BY NVAR       *
C
       DO 1000 I=1,NVAR
          DO  900 J=I,NVAR
             RINFO(I,J)=0.0
C
             DO 800 K=1,NTOT
                IF(IND(K).EQ.0) THEN
                   IF(IL(K).EQ.1) THEN
                      SUM1=0.0
                      SUM2=0.0
                      SUM3=0.0
C
                      DO 700 L=K,NTOT
                         SUM1=SUM1+X(I,L)
                         SUM2=SUM2+X(J,L)
                         SUM3=SUM3+X(I,L)*X(J,L)
  700                 CONTINUE
                      DEN=NTOT+1-K
                      RINFO(I,J)=RINFO(I,J)-REAL(IM(K))
     +                     *(SUM1*SUM2/DEN**2-SUM3/DEN)
                   ENDIF
                ENDIF
  800        CONTINUE
             RINFO(J,I)=RINFO(I,J)
  900     CONTINUE
 1000  CONTINUE
C
C      *     INVERT INFORMATION MATRX RINFO(I,J). THE INVERTED MATRIX       *
C      *     IS STORED IN RINFO(I,J).                                       *
C
       CALL MATINV(RINFO,NVAR,DET)
C
C      *      COMPUTE GLOBAL CHI-SQUARE:                                    *
C      *                                                                    *
C      *       CHI = [SCORE(I)**T] X [RINFO(I,J)**-1] X [SCORE(J)]          *
C      *         WHERE T IS TRANSVERSE.                                     *
C
       DO 1200 I=1,NVAR
          FINFO(I)=0.0
          DO 1100 K=1,NVAR
             FINFO(I)=FINFO(I)+RINFO(I,K)*SCORE(K)
 1100     CONTINUE
 1200  CONTINUE
       CHI=0.0
C
       DO 1300 L=1,NVAR
          CHI=CHI+FINFO(L)*SCORE(L)
 1300  CONTINUE

C
C      *              GET THE REDUCED CHI-SQUARE                            *
C
       RCHI=CHI/DF
C
C      *           COMPUTE CHI-SQUARE PROBABILITY                           *
C
       PROB=PCHISQ(RCHI,NVAR)
C
       RETURN
       END


      subroutine fill_xyz_sg( )
!
      use comgrid
      use comgrid_sg
      use comparttr
      use comparttr_sg
!
      implicit none
!
!
      integer icount, ii, i, j, k, itemp
      real*8  xtmp, ytmp, ztmp
      real*8  eps_x, eps_y, eps_z
      real*8  x_dx, y_dy, z_dz
      integer local_debug
      data    local_debug / 0 /
!
!     loop over all cells, refined or not
!
      icount = 1
      do ii = 1, n_grid_points
       if(ip_touched_cells(ii) .ne. 0)then
        k=1
        do while (k .le. nxyz(ip_touched_cells(ii),3))
        eps_z = dxyz(ii,3)*1.e-8
        z_dz  = corn(ii,3)+dxyz(ii,3)
        ztmp = corn(ii,3) +
     1         (2*k-1)*(dxyz(ii,3)/nxyz(ip_touched_cells(ii),3)/2.0d0)
C       Begin Check for outside face, edge or corner
        if(abs(z(ii)- corn(ii,3)).lt. eps_z) then
           if(k.eq.1) then
              ztmp = corn(ii,3)
           endif
        endif
        if(k.eq.nxyz(ip_touched_cells(ii),3)) then
           if(abs(z(ii)- z_dz) .lt. eps_z) then
              ztmp = z_dz
           endif
        endif
C       End Check for outside face, edge or corner
        j=1
        do while (j .le. nxyz(ip_touched_cells(ii),2))
        eps_y = dxyz(ii,2)*1.e-8
        y_dy  = corn(ii,2)+dxyz(ii,2)
        ytmp = corn(ii,2) +
     1         (2*j-1)*(dxyz(ii,2)/nxyz(ip_touched_cells(ii),2)/2.0d0)
C       End Check for outside face, edge or corner
        if(abs(y(ii)- corn(ii,2)).lt. eps_y) then
           if(j.eq.1) then
              ytmp = corn(ii,2)
           endif
        endif
        if(j.eq.nxyz(ip_touched_cells(ii),2)) then
           if(abs(y(ii)- y_dy) .lt. eps_y) then
              ytmp = y_dy
           endif
        endif
C
        i=1
        do while (i .le. nxyz(ip_touched_cells(ii),1))
        eps_x = dxyz(ii,1)*1.e-8
        x_dx  = corn(ii,1)+dxyz(ii,1)
        xtmp = corn(ii,1) +
     1         (2*i-1)*(dxyz(ii,1)/nxyz(ip_touched_cells(ii),1)/2.0d0)
C       Begin Check for outside face, edge or corner
        if(abs(x(ii)- corn(ii,1)).lt. eps_x) then
           if(i.eq.1) then
              xtmp = corn(ii,1)
           else
              xtmp= corn(ii,1) +
     1         (i-1)*(dxyz(ii,1)/nxyz(ip_touched_cells(ii),1))
           endif
        endif
        if(abs(x(ii)- x_dx) .lt. eps_x) then
           if(i.eq.nxyz(ip_touched_cells(ii),1)) then
              xtmp = x_dx
           else
              xtmp=corn(ii,1) +
     1         (i)*(dxyz(ii,1)/nxyz(ip_touched_cells(ii),1))
           endif
        endif
C       End Check for outside face, edge or corner
        x_sg(icount) = xtmp
        y_sg(icount) = ytmp
        z_sg(icount) = ztmp
        icount = icount + 1
        i = i + 1
       if(local_debug .eq. 1)then
          itemp=icount-1
          write(6,100)ii,x(ii),y(ii),z(ii),corn(ii,1),corn(ii,2)
     1         ,corn(ii,3)
          write(6,100)itemp,x_sg(itemp),y_sg(itemp),z_sg(itemp)
 100      format(i8,6e14.6)
       endif
        enddo
        j = j + 1
        enddo
        k = k + 1
        enddo
       else
        x_sg(icount) = x(ii)
        y_sg(icount) = y(ii)
        z_sg(icount) = z(ii)
        icount = icount + 1
       endif
      enddo
!
      return
      end subroutine fill_xyz_sg


c******************************************************************
c                            LYAP_RENORM.F
c*****************************************************************
c   Computes the distance and adds to the cum. sum for computing
c   Lyap exponent for a tp and its shadow. Moves the shadow back to
c   its original distance in phase space along the separation vector.
c             Input:
c              xt,yt,zt      ==>  current position of a TP in Helio coord
c                                    (real scalars)
c              vxt,vyt,vzt   ==>  current position of TP in Helio coord
c                                    (real scalars)
c              xs,ys,zs      ==>  current position of shawdow part in Helio coord
c                                    (real scalars)
c              vxs,vys,vzs   ==>  current position of SP in Helio coord
c                                    (real scalars)
c                  distorig  ==>  original distance between TP and SP
c                  logsum    ==>  current values of the log of gamma
c                                    (real scalar)
c
c             Output:
c              xs,ys,zs      ==>  renormalized position of SP in Helio coord
c                                    (real scalars)
c              vxs,vys,vzs   ==>  renormalized position of SP in Helio coord
c                                    (real scalars)
c               logsum       ==>  renormalized values of the log of gamma
c                                    (real scalar)
c
c Remarks:
c Authors:  Martin Duncan
c Date:    5/5/93
c Last revision:  5/11/93  HFL

	subroutine lyap_renorm(xt,yt,zt,vxt,vyt,vzt,xs,ys,zs,
     &                    vxs,vys,vzs,distorig,logsum)

	include '../swift.inc'

c...    Input Only
        real*8 xt,yt,zt,vxt,vyt,vzt
	real*8 distorig

c....   Input and Output
	real*8 xs,ys,zs,vxs,vys,vzs
	real*8 logsum

c...    Internal
	real*8 dx,dy,dz,dvx,dvy,dvz,dist,fac

c-----
c...  Executable code

	dx = xt - xs
	dy = yt - ys
	dz = zt - zs
	dvx = vxt - vxs
	dvy = vyt - vys
	dvz = vzt - vzs

	dist = sqrt(dx**2 + dy**2 + dz**2 + dvx**2 + dvy**2 + dvz**2)
	fac = distorig/dist

	xs = xt + fac*dx
	ys = yt + fac*dy
	zs = zt + fac*dz
	vxs = vxt + fac*dvx
	vys = vyt + fac*dvy
	vzs = vzt + fac*dvz

	logsum = logsum + log(1.d0/fac)
	return
	end ! lyap_renorm
c---------------------------------------------------------------------------


!original version
! http://www.unamur.be/sciences/physique/administration/tetpack/dostet.f
!*==DOSTET.spg  processed by SPAG 6.72Dc at 03:33 on 26 Sep 2016
SUBROUTINE DOSTET(Ener,Idime,Nband,Idef,Ntet,Xe,Ne,Y,Z)
  !     COMPUTE A DENSITY OF STATES USING THE TETRAHEDRONS METHOD.
  !     XE CONTAINS THE ENERGIES, Y AND Z RETURN THE RELATED DENSITY OF
  !     STATES AND THE INTEGRATED DENSITY OF STATES, RESPECTIVELY.
  IMPLICIT NONE
  !*--DOSTET7
  !*** Start of declarations inserted by SPAG
  integer, intent(in)   :: Idime, Nband, Ntet, Ne
  real(8), intent(in)    :: Ener(Idime,*), Xe(Ne)
  integer, intent(in)   :: Idef(5, Ntet)
  real(8), intent(out)   :: Y(Ne) , Z(Ne)

! local variables
  REAL(8) c(4), cc , e , e1 , e12 , e13 , e14 , e2 , e23 , e24 , e3 ,  &
       & e34 , e4 , ee1 , ee2 , ee3 , ee4 ,  eps , facy
  INTEGER i , ia , ib , ic , id , itet , ivol , ix , j , nb
  REAL(8) surfac , unite , volume
  !*** End of declarations inserted by SPAG
  REAL(4) avol
  !DIMENSION Ener(Idime,1) , Xe(1) , Y(1) , Z(1) , Idef(5,1) , c(4)
  EQUIVALENCE (ivol,avol)
  EQUIVALENCE (c(1),e1)
  EQUIVALENCE (c(2),e2)
  EQUIVALENCE (c(3),e3)
  EQUIVALENCE (c(4),e4)
  DATA eps/1.0D-05/
  Y = 0.D0
  Z = 0.D0
  !
  !     LOOP OVER THE TETRAHEDRONS
  DO itet = 1 , Ntet
     ia = Idef(1,itet)
     ib = Idef(2,itet)
     ic = Idef(3,itet)
     id = Idef(4,itet)
     ivol = Idef(5,itet)
     !
     !     LOOP OVER THE BANDS
     DO nb = 1 , Nband
        !
        ! *** DEFINE E1, E2, E3, E4, AS THE CORNER ENERGIES ORDERED BY
        ! *** DECREASING SIZE
        c(1) = Ener(nb,ia)
        c(2) = Ener(nb,ib)
        c(3) = Ener(nb,ic)
        c(4) = Ener(nb,id)
        DO i = 1 , 4
           cc = c(i)
           do j = i + 1, 4
              IF ( cc.LT.c(j) ) THEN
                 c(i) = c(j)
                 c(j) = cc
                 cc = c(i)
              ENDIF
           end do
        ENDDO
        unite = 1.0D0
        IF ( e1.GT.e4 ) unite = e1 - e4
        e12 = (e1-e2)/unite
        e13 = (e1-e3)/unite
        e14 = (e1-e4)/unite
        e23 = (e2-e3)/unite
        e24 = (e2-e4)/unite
        e34 = (e3-e4)/unite
        facy = 3.D0*DBLE(avol)/unite
        DO ix = 1 , Ne
           e = Xe(ix)
           surfac = 0.D0
           volume = 1.D0
           IF ( e.LE.e1 ) THEN
              volume = 0.D0
              IF ( e.GE.e4 ) THEN
                 ee1 = (e-e1)/unite
                 IF ( DABS(ee1).LT.eps ) ee1 = 0.D0
                 ee2 = (e-e2)/unite
                 IF ( DABS(ee2).LT.eps ) ee2 = 0.D0
                 ee3 = (e-e3)/unite
                 IF ( DABS(ee3).LT.eps ) ee3 = 0.D0
                 ee4 = (e-e4)/unite
                 IF ( DABS(ee4).LT.eps ) ee4 = 0.D0
                 IF ( e.GT.e3 ) THEN
                    IF ( e.GT.e2 ) THEN
                       ! *** E2.LT.E.AND.E.LE.E1
                       surfac = (ee1/e12)*(ee1/e13)
                       volume = 1.D0 + surfac*ee1
                    ELSE
                       ! *** E3.LT.E.AND.E.LE.E2
                       surfac = -(ee3*ee2/e23+ee4*ee1)/e13/e24
                       volume = (0.5D0*ee3*(2.D0*e13*e34+e13*ee4-e34&
                            & *ee1-2.D0*ee1*ee4+ee3*(ee3-3.D0*ee2)&
                            & /e23)/e13+e34*e34)/e24
                    ENDIF
                    ! *** E4.LE.E.AND.E.LE.E3
                 ELSEIF ( e4.EQ.e3 ) THEN
                    IF ( e3.GE.e2 ) THEN
                       IF ( e2.EQ.e1 ) THEN
                          surfac = 1.0D+15
                          volume = 0.5D0
                       ELSE
                          surfac = 1.D0/e12
                       ENDIF
                    ENDIF
                 ELSE
                    surfac = (ee4/e34)*(ee4/e24)
                    volume = surfac*ee4
                 ENDIF
              ENDIF
           ENDIF
           Y(ix) = Y(ix) + facy*surfac
           Z(ix) = Z(ix) + DBLE(avol)*volume
        ENDDO
     ENDDO
  ENDDO
END SUBROUTINE DOSTET


!>
!! Evaluate the linear incident wave field  from
!! linear theory (eta, phi and derivatives)
!!
!!    Evaluation on the free surface
!!    Evaluation on boundaries
!<
!
subroutine incident_linear_wf_finite_standing(wf_type, Wavefield, & !ramp_type,&
	 nfx,xp,nfy,yp,nfz,zp,bottom,tp,wavenum,grav,H, d)
!
USE PRECISION
USE GlobalVariables, ONLY: GhostGridX,GhostGridY,GhostGridZ, swenseTransientTime, &
     West_refl, East_refl, North_refl, South_refl, curvilinearONOFF, SFSOL
USE DataTypes
USE Constants
!
IMPLICIT NONE
INTERFACE
	SUBROUTINE phi_linear_3D_standing(H,angle,Lx,Ly,x,y,z,d,omega,time,grav,phix,phiy,phiz,phi,phit)
    USE PRECISION
   	REAL(KIND=long), INTENT(IN)  :: H,Lx,Ly,x,y,z,d,omega,time,grav,angle
   	REAL(KIND=long), INTENT(OUT) :: phix,phiy,phiz
   	REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
   	END SUBROUTINE phi_linear_3D_standing
END INTERFACE
!
INTEGER nfx, nfy, nfz, nbp, wf_type
REAL(KIND=long) tp, wavenum, grav, H, d
! For curvilinear
REAL(KIND=long), DIMENSION(nfx,nfy) :: xp,yp
REAL(KIND=long), DIMENSION(nfz) :: zp
REAL(KIND=long), DIMENSION(nfx,nfy) :: bottom

!
TYPE(Wavefield_FS) :: Wavefield
! Local variables
INTEGER i, j, k, tmpIdx, Gidx3
REAL(KIND=long) temp1,omega,angle
REAL(KIND=long) zbp
REAL(KIND=long) FAC
!
!
! Time ramp and its derivatives
!time_ramp(:)=ramp_value(ramp_type,tp)
IF (swenseTransientTime/=zero) THEN
  IF(tp==zero) THEN
    FAC = zero
  ELSEIF(tp<=swenseTransientTime) THEN
    !FAC = one/swenseTransientTime*tp
    FAC = -two/(swenseTransientTime**3)*tp**3+three/(swenseTransientTime**2)*tp**2
  ELSE
    FAC = one
  ENDIF
ELSE
  FAC=one
ENDIF
!
omega = sqrt(grav*wavenum*tanh(wavenum*d))
omega=wf_type/abs(wf_type)*omega
!
SFSOL%k=SQRT((two*pi/SFSOL%L)**2+(zero*two*pi/SFSOL%L)**2)
SFSOL%T=SQRT((two*pi)**2/(grav*SFSOL%k*TANH(SFSOL%k*d)) );
SFSOL%c=SQRT(grav/SFSOL%k*TANH(SFSOL%k*d))
      !
      IF (curvilinearONOFF.EQ.0) THEN
        IF((nfx.EQ.1).OR.(nfy.EQ.1)) THEN
          write(*,*) 'This is a 3d case !!'
          stop
        ENDIF
      ELSE
        ! FIXME: 3D only for now
		IF((nfx.EQ.1).OR.(nfy.EQ.1)) THEN
          write(*,*) 'The 2D case in curvilinear SEENSE has to be done...'
          stop
        ENDIF
      ENDIF
      !
      IF (curvilinearONOFF.EQ.1) THEN
      	angle = 20.0_long*PI/180.0_long
      ELSE
        angle= zero
      ENDIF
	  !
      DO j=1,nfx
        DO k=1,nfy
            CALL eta_linear_3D_standing(H,angle,SFsol%L,SFsol%L,xp(j,k),yp(j,k),omega,tp,Wavefield%E_I(j,k),Wavefield%Ex_I(j,k), &
            	 Wavefield%Ey_I(j,k),Wavefield%Exx_I(j,k),Wavefield%Eyy_I(j,k),Wavefield%Et_I(j,k))
        	!
        	! Here phi, is computed on the free-surface z=0
        	!
        	CALL phi_linear_3D_standing(H,angle,SFsol%L,SFsol%L,xp(j,k),yp(j,k),zero,d,omega,tp,grav, &
            	Wavefield%Px_I_s(j,k),Wavefield%Py_I_s(j,k),Wavefield%Pz_I_s(j,k),Wavefield%P_I_s(j,k),Wavefield%Pt_I_s(j,k))
        ENDDO
      END DO
      !
	!
    ! Determine the incident wavefield on the boundary points...
    !
	!
    Wavefield%SourceEx = -FAC*Wavefield%Ex_I
    Wavefield%SourcePx = -FAC*Wavefield%Px_I_s
    Wavefield%SourceEy = -FAC*Wavefield%Ey_I
    Wavefield%SourcePy = -FAC*Wavefield%Py_I_s
    !
  	! FIXME: Assumption here is that the plane is aligned with the x- and y-axes. Extend to
  	!        general curvilinear coordinates.
    ! FIXME: Optimization of loops
    Gidx3 = 1
    !
    ! Bottom boundary
    !
    DO j = 1+GhostGridY, nfy-GhostGridY
		DO i = 1+GhostGridX, nfx-GhostGridX
            ! Wave elevation + derivative (Dimensional)
       		Wavefield%E_I_bp(Gidx3)  = FAC*Wavefield%E_I(i,j)
        	Wavefield%Ex_I_bp(Gidx3) = FAC*Wavefield%Ex_I(i,j)
            Wavefield%Ey_I_bp(Gidx3) = FAC*Wavefield%Ey_I(i,j)
            ! transform on the real z-space... Dimensional
            zbp=bottom(i,j)*zp(1+GhostGridZ)-bottom(i,j)
            !zbp=d*zp(2)-d
            CALL phi_linear_3D_standing(FAC*H,angle,SFsol%L,SFsol%L,xp(i,j),yp(i,j),zbp,d,omega,tp,grav, &
        			Wavefield%Px_I_bp(Gidx3),Wavefield%Py_I_bp(Gidx3),Wavefield%Pz_I_bp(Gidx3))
            ! Global index for Boundary Points, which option ? for now cf NormalX,Y,Z
            Wavefield%GidxTableBP(1,i,j) = Gidx3
            !Wavefield%GidxTableBP(1+GhostGridZ,i,j) = Gidx3
			! Increment global index
            Gidx3 = Gidx3+1
		END DO
	END DO
    !
   	! West  boundary
	!
    i = 1
	!
    DO j = 1+GhostGridY, nfy-GhostGridY
        DO k = 1, nfz
            ! Wave elevation + derivative
            Wavefield%E_I_bp(Gidx3)  = FAC*Wavefield%E_I(i+GhostGridX,j)
            Wavefield%Ex_I_bp(Gidx3) = FAC*Wavefield%Ex_I(i+GhostGridX,j)
            Wavefield%Ey_I_bp(Gidx3) = FAC*Wavefield%Ey_I(i+GhostGridX,j)
            IF (West_refl==0) THEN
				Wavefield%Px_I_bp(Gidx3)=zero; Wavefield%Py_I_bp(Gidx3)=zero; Wavefield%Pz_I_bp(Gidx3)=zero
            ELSE
                ! transform on the real z-space... Dimensional
                zbp=bottom(i+GhostGridX,j)*zp(k)-bottom(i+GhostGridX,j)
                !zbp=d*zp(k)-d
                CALL phi_linear_3D_standing(FAC*H,angle,SFsol%L,SFsol%L,xp(i+GhostGridX,j),yp(i+GhostGridX,j),zbp,d,omega,tp,grav, &
                	Wavefield%Px_I_bp(Gidx3),Wavefield%Py_I_bp(Gidx3),Wavefield%Pz_I_bp(Gidx3))
            ENDIF
            ! Global index for Boundary Points, which option ? for now cf NormalX,Y,Z
            Wavefield%GidxTableBP(k,i,j) = Gidx3
            !Wavefield%GidxTableBP(k,i+GhostGridX,j) = Gidx3
            ! Increment global index
            Gidx3 = Gidx3+1
        END DO
    END DO
	! East  boundary
   	i = nfx
    ! index of the first element (=Nz*(Ny-2*GhostY))
    tmpIdx = Gidx3
	!
    DO j = 1+GhostGridY, nfy-GhostGridY
        DO k = 1, nfz
            ! Wave elevation + derivative
            Wavefield%E_I_bp(Gidx3)  = FAC*Wavefield%E_I(i-GhostGridX,j)
            Wavefield%Ex_I_bp(Gidx3) = FAC*Wavefield%Ex_I(i-GhostGridX,j)
            Wavefield%Ey_I_bp(Gidx3) = FAC*Wavefield%Ey_I(i-GhostGridX,j)
            IF (East_refl==0) THEN
				Wavefield%Px_I_bp(Gidx3)=zero; Wavefield%Py_I_bp(Gidx3)=zero; Wavefield%Pz_I_bp(Gidx3)=zero
           	ELSE
                ! transform on the real z-space... Dimensional
                zbp=bottom(i-GhostGridX,j)*zp(k)-bottom(i-GhostGridX,j)
                !zbp=d*zp(k)-d
                CALL phi_linear_3D_standing(FAC*H,angle,SFsol%L,SFsol%L,xp(i-GhostGridX,j),yp(i-GhostGridX,j),zbp,d,omega,tp,grav, &
                    Wavefield%Px_I_bp(Gidx3),Wavefield%Py_I_bp(Gidx3),Wavefield%Pz_I_bp(Gidx3))
            ENDIF
            ! Global index for Boundary Points, which option ? for now cf NormalX,Y,Z
            Wavefield%GidxTableBP(k,i,j) = Gidx3
            !Wavefield%GidxTableBP(k,i-GhostGridX,j) = Gidx3
            ! Increment global index
            Gidx3 = Gidx3+1
        END DO
    END DO
    !
    ! South boundary
    !
    j = 1
    DO i = 1+GhostGridX, nfx-GhostGridX
        ! index of the first element (=2*Nz*(Ny-2*GhostY)+i)
        tmpIdx = Gidx3
        ! Wave elevation + derivative (Dimensional)
        Wavefield%E_I_bp(Gidx3)  = FAC*Wavefield%E_I(i,j+GhostGridY)
        Wavefield%Ex_I_bp(Gidx3) = FAC*Wavefield%Ex_I(i,j+GhostGridY)
        Wavefield%Ey_I_bp(Gidx3) = FAC*Wavefield%Ey_I(i,j+GhostGridY)
        DO k = 1, nfz
            ! Wave elevation + derivative
            Wavefield%E_I_bp(Gidx3)  = Wavefield%E_I_bp(tmpIdx)
            Wavefield%Ex_I_bp(Gidx3) = Wavefield%Ex_I_bp(tmpIdx)
            Wavefield%Ey_I_bp(Gidx3) = Wavefield%Ey_I_bp(tmpIdx)
            IF (South_refl==0) THEN
                Wavefield%Px_I_bp(Gidx3)=zero; Wavefield%Py_I_bp(Gidx3)=zero; Wavefield%Pz_I_bp(Gidx3)=zero
            ELSE
                ! transform on the real z-space... Dimensional
                zbp=bottom(i,j+GhostGridY)*zp(k)-bottom(i,j+GhostGridY)
                !zbp=d*zp(k)-d
                CALL phi_linear_3D_standing(FAC*H,angle,SFsol%L,SFsol%L,xp(i,j+GhostGridY),yp(i,j+GhostGridY),zbp,d,omega,tp,grav, &
                    Wavefield%Px_I_bp(Gidx3),Wavefield%Py_I_bp(Gidx3),Wavefield%Pz_I_bp(Gidx3))
            ENDIF
            ! Global index for Boundary Points, which option ? for now cf NormalX,Y,Z
            Wavefield%GidxTableBP(k,i,j) = Gidx3
            !Wavefield%GidxTableBP(k,i,j+GhostGridY) = Gidx3
            ! Increment global index
            Gidx3 = Gidx3+1
        END DO
    END DO
    !
    ! North boundary
    j = nfy
    DO i = 1+GhostGridX, nfx-GhostGridX
        ! index of the first element (=2*Nz*(Ny-2*GhostY)+...+i)
        tmpIdx = Gidx3
        ! Wave elevation + derivative (Dimensional)
        Wavefield%E_I_bp(Gidx3)  = FAC*Wavefield%E_I(i,j-GhostGridY)
        Wavefield%Ex_I_bp(Gidx3) = FAC*Wavefield%Ex_I(i,j-GhostGridY)
        Wavefield%Ey_I_bp(Gidx3) = FAC*Wavefield%Ey_I(i,j-GhostGridY)
        DO k = 1, nfz
            ! Wave elevation + derivative
            Wavefield%E_I_bp(Gidx3)  = Wavefield%E_I_bp(tmpIdx)
            Wavefield%Ex_I_bp(Gidx3) = Wavefield%Ex_I_bp(tmpIdx)
            Wavefield%Ey_I_bp(Gidx3) = Wavefield%Ey_I_bp(tmpIdx)
            IF (North_refl==0) THEN
                Wavefield%Px_I_bp(Gidx3)=zero; Wavefield%Py_I_bp(Gidx3)=zero; Wavefield%Pz_I_bp(Gidx3)=zero
            ELSE
              ! transform on the real z-space... Dimensional
              zbp=bottom(i,j-GhostGridY)*zp(k)-bottom(i,j-GhostGridY)
              !zbp=d*zp(k)-d
              CALL phi_linear_3D_standing(FAC*H,angle,SFsol%L,SFsol%L,xp(i,j-GhostGridY),yp(i,j-GhostGridY),zbp,d,omega,tp,grav, &
                  Wavefield%Px_I_bp(Gidx3),Wavefield%Py_I_bp(Gidx3),Wavefield%Pz_I_bp(Gidx3))
            ENDIF
            ! Global index for Boundary Points, which option ? for now cf NormalX,Y,Z
            Wavefield%GidxTableBP(k,i,j) = Gidx3
            !Wavefield%GidxTableBP(k,i,j-GhostGridY) = Gidx3
            ! Increment global index
            Gidx3 = Gidx3+1
        END DO
    END DO
    ! FIXME: How to treat the corners ?
    IF (West_refl==0) THEN
      Wavefield%SourceEx(1+GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
      Wavefield%SourcePx(1+GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
      Wavefield%SourceEy(1+GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
      Wavefield%SourcePy(1+GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
    ENDIF
    IF (East_refl==0) THEN
      Wavefield%SourceEx(nfx-GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
      Wavefield%SourcePx(nfx-GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
      Wavefield%SourceEy(nfx-GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
      Wavefield%SourcePy(nfx-GhostGridX,2+GhostGridY:nfy-1-GhostGridY) = zero
    ENDIF
    IF (South_refl==0) THEN
      Wavefield%SourceEx(2+GhostGridX:nfx-1-GhostGridX,1+GhostGridY) = zero
      Wavefield%SourcePx(2+GhostGridX:nfx-1-GhostGridX,1+GhostGridY) = zero
      Wavefield%SourceEy(2+GhostGridX:nfx-1-GhostGridX,1+GhostGridY) = zero
      Wavefield%SourcePy(2+GhostGridX:nfx-1-GhostGridX,1+GhostGridY) = zero
    ENDIF
    IF (North_refl==0) THEN
      Wavefield%SourceEx(2+GhostGridX:nfx-1-GhostGridX,nfy-GhostGridY) = zero
      Wavefield%SourcePx(2+GhostGridX:nfx-1-GhostGridX,nfy-GhostGridY) = zero
      Wavefield%SourceEy(2+GhostGridX:nfx-1-GhostGridX,nfy-GhostGridY) = zero
      Wavefield%SourcePy(2+GhostGridX:nfx-1-GhostGridX,nfy-GhostGridY) = zero
    ENDIF
    ! Corners are set to zero if both reflexions are zero...
    IF (West_refl==0) THEN
      IF (South_refl==0) THEN
      	Wavefield%SourceEx(1+GhostGridX,1+GhostGridY) = zero
      	Wavefield%SourcePx(1+GhostGridX,1+GhostGridY) = zero
      	Wavefield%SourceEy(1+GhostGridX,1+GhostGridY) = zero
      	Wavefield%SourcePy(1+GhostGridX,1+GhostGridY) = zero
      ENDIF
      IF (North_refl==0) THEN
      	Wavefield%SourceEx(1+GhostGridX,nfy-GhostGridY) = zero
      	Wavefield%SourcePx(1+GhostGridX,nfy-GhostGridY) = zero
      	Wavefield%SourceEy(1+GhostGridX,nfy-GhostGridY) = zero
      	Wavefield%SourcePy(1+GhostGridX,nfy-GhostGridY) = zero
      ENDIF
    ENDIF
    IF (East_refl==0) THEN
      IF (South_refl==0) THEN
      	Wavefield%SourceEx(nfx-GhostGridX,1+GhostGridY) = zero
      	Wavefield%SourcePx(nfx-GhostGridX,1+GhostGridY) = zero
      	Wavefield%SourceEy(nfx-GhostGridX,1+GhostGridY) = zero
      	Wavefield%SourcePy(nfx-GhostGridX,1+GhostGridY) = zero
      ENDIF
      IF (North_refl==0) THEN
      	Wavefield%SourceEx(nfx-GhostGridX,nfy-GhostGridY) = zero
      	Wavefield%SourcePx(nfx-GhostGridX,nfy-GhostGridY) = zero
      	Wavefield%SourceEy(nfx-GhostGridX,nfy-GhostGridY) = zero
      	Wavefield%SourcePy(nfx-GhostGridX,nfy-GhostGridY) = zero
      ENDIF
    ENDIF

RETURN
END SUBROUTINE incident_linear_wf_finite_standing


!>  \file sfc_diff.f
!! This file contains the surface roughness length formulation based on
!! the surface sublayer scheme in
!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998.

!> This module contains the CCPP-compliant GFS surface layer scheme.
      module sfc_diff

      use machine , only : kind_phys

      implicit none

      public :: sfc_diff_init, sfc_diff_run, sfc_diff_finalize

      private

      real (kind=kind_phys), parameter :: ca=.4  ! ca - von karman constant

      contains

      subroutine sfc_diff_init
      end subroutine sfc_diff_init

      subroutine sfc_diff_finalize
      end subroutine sfc_diff_finalize

!> \defgroup GFS_diff_main GFS Surface Layer Scheme Module
!> @{
!> \brief This subroutine calculates surface roughness length.
!!
!! This subroutine includes the surface roughness length formulation
!! based on the surface sublayer scheme in
!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998.
!> \section arg_table_sfc_diff_run Argument Table
!! \htmlinclude sfc_diff_run.html
!!
!>  \section general_diff GFS Surface Layer Scheme General Algorithm
!! - Calculate the thermal roughness length formulation over the ocean (see eq. (25) and (26)
!!  in Zeng et al. (1998) \cite zeng_et_al_1998).
!! - Calculate Zeng's momentum roughness length formulation over land and sea ice.
!! - Calculate the new vegetation-dependent formulation of thermal roughness length
!! (Zheng et al.(2009) \cite zheng_et_al_2009).
!! Zheng et al. (2009) \cite zheng_et_al_2009 proposed a new formulation on
!! \f$ln(Z_{0m}^,/Z_{0t})\f$ as follows:
!! \f[
!!  ln(Z_{0m}^,/Z_{0t})=(1-GVF)^2C_{zil}k(u*Z_{0g}/\nu)^{0.5}
!! \f]
!! where \f$Z_{0m}^,\f$ is the effective momentum roughness length
!! computed in the following equation for each grid, \f$Z_{0t}\f$
!! is the roughness lenghth for heat, \f$C_{zil}\f$ is a coefficient
!! (taken as 0.8), k is the Von Karman constant (0.4),
!! \f$\nu=1.5\times10^{-5}m^{2}s^{-1}\f$ is the molecular viscosity,
!! \f$u*\f$ is the friction velocity, and \f$Z_{0g}\f$ is the bare
!! soil roughness length for momentum (taken as 0.01).
!! \n In order to consider the convergence of \f$Z_{0m}\f$ between
!! fully vegetated and bare soil, the effective \f$Z_{0m}^,\f$ is
!! computed:
!! \f[
!!  \ln(Z_{0m}^,)=(1-GVF)^{2}\ln(Z_{0g})+\left[1-(1-GVF)^{2}\right]\ln(Z_{0m})
!!\f]
!! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes.
!!
      subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav,                &  !intent(in)
     &                    ps,t1,q1,z1,wind,                             &  !intent(in)
     &                    prsl1,prslki,prsik1,prslk1,                   &  !intent(in)
     &                    sigmaf,vegtype,shdmax,ivegsrc,                &  !intent(in)
     &                    z0pert,ztpert,                                &  ! mg, sfc-perts !intent(in)
     &                    flag_iter,redrag,                             &  !intent(in)
     &                    u10m,v10m,sfc_z0_type,                        &  !hafs,z0 type !intent(in)
     &                    wet,dry,icy,                                  &  !intent(in)
     &                    tskin_ocn, tskin_lnd, tskin_ice,              &  !intent(in)
     &                    tsurf_ocn, tsurf_lnd, tsurf_ice,              &  !intent(in)
     &                   snwdph_ocn,snwdph_lnd,snwdph_ice,              &  !intent(in)
     &                     z0rl_ocn,  z0rl_lnd,  z0rl_ice,              &  !intent(inout)
     &                    ustar_ocn, ustar_lnd, ustar_ice,              &  !intent(inout)
     &                       cm_ocn,    cm_lnd,    cm_ice,              &  !intent(inout)
     &                       ch_ocn,    ch_lnd,    ch_ice,              &  !intent(inout)
     &                       rb_ocn,    rb_lnd,    rb_ice,              &  !intent(inout)
     &                   stress_ocn,stress_lnd,stress_ice,              &  !intent(inout)
     &                       fm_ocn,    fm_lnd,    fm_ice,              &  !intent(inout)
     &                       fh_ocn,    fh_lnd,    fh_ice,              &  !intent(inout)
     &                     fm10_ocn,  fm10_lnd,  fm10_ice,              &  !intent(inout)
     &                      fh2_ocn,   fh2_lnd,   fh2_ice,              &  !intent(inout)
     &                    errmsg, errflg)                                  !intent(out)
!
      implicit none
!
      integer, intent(in) :: im, ivegsrc
      integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean

      integer, dimension(im), intent(in) :: vegtype

      logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han)
      logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy

      real(kind=kind_phys), dimension(im), intent(in)    :: u10m,v10m
      real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav
      real(kind=kind_phys), dimension(im), intent(in)    ::             &
     &                    ps,t1,q1,z1,prsl1,prslki,prsik1,prslk1,       &
     &                    wind,sigmaf,shdmax,                           &
     &                    z0pert,ztpert ! mg, sfc-perts
      real(kind=kind_phys), dimension(im), intent(in)    ::             &
     &                    tskin_ocn, tskin_lnd, tskin_ice,              &
     &                    tsurf_ocn, tsurf_lnd, tsurf_ice,              &
     &                   snwdph_ocn,snwdph_lnd,snwdph_ice

      real(kind=kind_phys), dimension(im), intent(inout) ::             &
     &                     z0rl_ocn,  z0rl_lnd,  z0rl_ice,              &
     &                    ustar_ocn, ustar_lnd, ustar_ice,              &
     &                       cm_ocn,    cm_lnd,    cm_ice,              &
     &                       ch_ocn,    ch_lnd,    ch_ice,              &
     &                       rb_ocn,    rb_lnd,    rb_ice,              &
     &                   stress_ocn,stress_lnd,stress_ice,              &
     &                       fm_ocn,    fm_lnd,    fm_ice,              &
     &                       fh_ocn,    fh_lnd,    fh_ice,              &
     &                     fm10_ocn,  fm10_lnd,  fm10_ice,              &
     &                      fh2_ocn,   fh2_lnd,   fh2_ice
      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg
!
!     locals
!
      integer   i
!
      real(kind=kind_phys) :: rat,   thv1, restar, wind10m,
     &                        czilc, tem1, tem2, virtfac

      real(kind=kind_phys) :: tvs, z0, z0max, ztmax
!
      real(kind=kind_phys), parameter ::
     &              charnock=.014, z0s_max=.317e-2                      &! a limiting value at high winds over sea
     &,             vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis               &
     &,             log01=log(0.01), log05=log(0.05), log07=log(0.07)

!     parameter (charnock=.014,ca=.4)!c ca is the von karman constant
!     parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041)
!     parameter (a0p=-7.941,a1p=24.75,b1p=-8.705,b2p=7.899,vis=1.4e-5)

!     real(kind=kind_phys) aa1,bb1,bb2,cc,cc1,cc2,arnu
!     parameter (aa1=-1.076,bb1=.7045,cc1=-.05808)
!     parameter (bb2=-.1954,cc2=.009999)
!     parameter (arnu=.135*rnu)
!
!    z0s_max=.196e-2 for u10_crit=25 m/s
!    z0s_max=.317e-2 for u10_crit=30 m/s
!    z0s_max=.479e-2 for u10_crit=35 m/s
!
! mbek -- toga-coare flux algorithm
!     parameter (rnu=1.51e-5,arnu=0.11*rnu)

! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0

!  initialize variables. all units are supposedly m.k.s. unless specified
!  ps is in pascals, wind is wind speed,
!  surface roughness length is converted to m from cm
!

!       write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type

      do i=1,im
        if(flag_iter(i)) then
          virtfac = 1.0 + rvrdm1 * max(q1(i),1.e-8)
          thv1    = t1(i) * prslki(i) * virtfac

!  compute stability dependent exchange coefficients
!  this portion of the code is presently suppressed
!
          if (dry(i)) then ! Some land
#ifdef GSD_SURFACE_FLUXES_BUGFIX
            tvs   = 0.5 * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) * virtfac
#else
            tvs   = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac
#endif
            z0max = max(1.0e-6, min(0.01 * z0rl_lnd(i), z1(i)))
!** xubin's new z0  over land
            tem1 = 1.0 - shdmax(i)
            tem2 = tem1 * tem1
            tem1 = 1.0  - tem2

            if( ivegsrc == 1 ) then

              if (vegtype(i) == 10) then
                z0max = exp( tem2*log01 + tem1*log07 )
              elseif (vegtype(i) == 6) then
                z0max = exp( tem2*log01 + tem1*log05 )
              elseif (vegtype(i) == 7) then
!               z0max = exp( tem2*log01 + tem1*log01 )
                z0max = 0.01
              elseif (vegtype(i) == 16) then
!               z0max = exp( tem2*log01 + tem1*log01 )
                z0max = 0.01
              else
                z0max = exp( tem2*log01 + tem1*log(z0max) )
              endif

            elseif (ivegsrc == 2 ) then

              if (vegtype(i) == 7) then
                z0max = exp( tem2*log01 + tem1*log07 )
              elseif (vegtype(i) == 8) then
                z0max = exp( tem2*log01 + tem1*log05 )
              elseif (vegtype(i) == 9) then
!               z0max = exp( tem2*log01 + tem1*log01 )
                z0max = 0.01
              elseif (vegtype(i) == 11) then
!               z0max = exp( tem2*log01 + tem1*log01 )
                z0max = 0.01
              else
                z0max = exp( tem2*log01 + tem1*log(z0max) )
              endif

            endif
! mg, sfc-perts: add surface perturbations to z0max over land
            if (z0pert(i) /= 0.0 ) then
              z0max = z0max * (10.**z0pert(i))
            endif

            z0max = max(z0max, 1.0e-6)

!           czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil
            czilc = 0.8

            tem1  = 1.0 - sigmaf(i)
            ztmax = z0max*exp( - tem1*tem1
     &                     * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05)))

! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land
            if (ztpert(i) /= 0.0) then
              ztmax = ztmax * (10.**ztpert(i))
            endif
            ztmax = max(ztmax, 1.0e-6)
!
            call stability
!  ---  inputs:
     &       (z1(i), snwdph_lnd(i), thv1, wind(i),
     &        z0max, ztmax, tvs, grav,
!  ---  outputs:
     &        rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i),
     &        cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i))
          endif ! Dry points

          if (icy(i)) then ! Some ice
            tvs   = 0.5 * (tsurf_ice(i)+tskin_ice(i)) * virtfac
            z0max = max(1.0e-6, min(0.01 * z0rl_ice(i), z1(i)))
!** xubin's new z0  over land and sea ice
            tem1 = 1.0 - shdmax(i)
            tem2 = tem1 * tem1
            tem1 = 1.0  - tem2

            if( ivegsrc == 1 ) then

              z0max = exp( tem2*log01 + tem1*log(z0max) )
            elseif (ivegsrc == 2 ) then
              z0max = exp( tem2*log01 + tem1*log(z0max) )
            endif

            z0max = max(z0max, 1.0e-6)

!           czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height
!           dependance of czil
            czilc = 0.8

            tem1 = 1.0 - sigmaf(i)
            ztmax = z0max*exp( - tem1*tem1
     &                     * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05)))
            ztmax = max(ztmax, 1.0e-6)
!
            call stability
!  ---  inputs:
     &     (z1(i), snwdph_ice(i), thv1, wind(i),
     &      z0max, ztmax, tvs, grav,
!  ---  outputs:
     &      rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i),
     &      cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i))
      endif ! Icy points

! BWG: Everything from here to end of subroutine was after
!      the stuff now put into "stability"

          if (wet(i)) then ! Some open ocean
            tvs        = 0.5 * (tsurf_ocn(i)+tskin_ocn(i)) * virtfac
            z0         = 0.01 * z0rl_ocn(i)
            z0max      = max(1.0e-6, min(z0,z1(i)))
            ustar_ocn(i) = sqrt(grav * z0 / charnock)
            wind10m    = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i))

!**  test xubin's new z0

!           ztmax  = z0max

            restar = max(ustar_ocn(i)*z0max*visi, 0.000001)

!           restar = log(restar)
!           restar = min(restar,5.)
!           restar = max(restar,-5.)
!           rat    = aa1 + (bb1 + cc1*restar) * restar
!           rat    = rat    / (1. + (bb2 + cc2*restar) * restar))
!  rat taken from zeng, zhao and dickinson 1997

            rat   = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57)
            ztmax = max(z0max * exp(-rat), 1.0e-6)
!
            if (sfc_z0_type == 6) then
              call znot_t_v6(wind10m, ztmax)   ! 10-m wind,m/s, ztmax(m)
            else if (sfc_z0_type == 7) then
              call znot_t_v7(wind10m, ztmax)   ! 10-m wind,m/s, ztmax(m)
            else if (sfc_z0_type /= 0) then
              write(0,*)'no option for sfc_z0_type=',sfc_z0_type
              stop
            endif
!
            call stability
!  ---  inputs:
     &       (z1(i), snwdph_ocn(i), thv1, wind(i),
     &        z0max, ztmax, tvs, grav,
!  ---  outputs:
     &        rb_ocn(i), fm_ocn(i), fh_ocn(i), fm10_ocn(i), fh2_ocn(i),
     &        cm_ocn(i), ch_ocn(i), stress_ocn(i), ustar_ocn(i))
!
!  update z0 over ocean
!
            if (sfc_z0_type == 0) then
              z0 = (charnock / grav) * ustar_ocn(i) * ustar_ocn(i)

! mbek -- toga-coare flux algorithm
!             z0 = (charnock / grav) * ustar(i)*ustar(i) +  arnu/ustar(i)
!  new implementation of z0
!             cc = ustar(i) * z0 / rnu
!             pp = cc / (1. + cc)
!             ff = grav * arnu / (charnock * ustar(i) ** 3)
!             z0 = arnu / (ustar(i) * ff ** pp)

              if (redrag) then
                z0rl_ocn(i) = 100.0 * max(min(z0, z0s_max), 1.e-7)
              else
                z0rl_ocn(i) = 100.0 * max(min(z0,.1), 1.e-7)
              endif

            elseif (sfc_z0_type == 6) then   ! wang
               call znot_m_v6(wind10m, z0)  ! wind, m/s, z0, m
               z0rl_ocn(i) = 100.0 * z0          ! cm
            elseif (sfc_z0_type == 7) then   ! wang
               call znot_m_v7(wind10m, z0)  ! wind, m/s, z0, m
               z0rl_ocn(i) = 100.0 * z0          ! cm
            else
               z0rl_ocn(i) = 1.0e-4
            endif

          endif              ! end of if(open ocean)
!
        endif                ! end of if(flagiter) loop
      enddo

      return
      end subroutine sfc_diff_run
!> @}

!----------------------------------------
!>\ingroup GFS_diff_main
      subroutine stability                                              &
!  ---  inputs:
     &     ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav,           &
!  ---  outputs:
     &       rb, fm, fh, fm10, fh2, cm, ch, stress, ustar)
!-----

!  ---  inputs:
      real(kind=kind_phys), intent(in) ::                               &
     &       z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav

!  ---  outputs:
      real(kind=kind_phys), intent(out) ::                              &
     &       rb, fm, fh, fm10, fh2, cm, ch, stress, ustar

!  ---  locals:
      real(kind=kind_phys), parameter :: alpha=5., a0=-3.975            &
     &,             a1=12.32, alpha4=4.0*alpha
     &,             b1=-7.755,  b2=6.041,  alpha2=alpha+alpha, beta=1.0
     &,             a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899
     &,             ztmin1=-999.0

      real(kind=kind_phys) aa,     aa0,    bb,     bb0, dtv,   adtv,
     &                     hl1,    hl12,   pm,     ph,  pm10,  ph2,
     &                     z1i,
     &                     fms,    fhs,    hl0,    hl0inf, hlinf,
     &                     hl110,  hlt,    hltinf, olinf,
     &                     tem1,   tem2, ztmax1

          z1i = 1.0 / z1

          tem1   = z0max/z1
          if (abs(1.0-tem1) > 1.0e-6) then
            ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1))
          else
            ztmax1 = 99.0
          endif
          if( z0max < 0.05 .and. snwdph < 10.0 ) ztmax1 = 99.0

!  compute stability indices (rb and hlinf)

          dtv     = thv1 - tvs
          adtv    = max(abs(dtv),0.001)
          dtv     = sign(1.,dtv) * adtv
#ifdef GSD_SURFACE_FLUXES_BUGFIX
          rb      = max(-5000.0, grav * dtv * z1
     &            / (thv1 * wind * wind))
#else
          rb      = max(-5000.0, (grav+grav) * dtv * z1
     &            / ((thv1 + tvs) * wind * wind))
#endif
          tem1    = 1.0 / z0max
          tem2    = 1.0 / ztmax
          fm      = log((z0max+z1)  * tem1)
          fh      = log((ztmax+z1)  * tem2)
          fm10    = log((z0max+10.) * tem1)
          fh2     = log((ztmax+2.)  * tem2)
          hlinf   = rb * fm * fm / fh
          hlinf   = min(max(hlinf,ztmin1),ztmax1)
!
!  stable case
!
          if (dtv >= 0.0) then
            hl1 = hlinf
            if(hlinf > .25) then
              tem1   = hlinf * z1i
              hl0inf = z0max * tem1
              hltinf = ztmax * tem1
              aa     = sqrt(1. + alpha4 * hlinf)
              aa0    = sqrt(1. + alpha4 * hl0inf)
              bb     = aa
              bb0    = sqrt(1. + alpha4 * hltinf)
              pm     = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) )
              ph     = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) )
              fms    = fm - pm
              fhs    = fh - ph
              hl1    = fms * fms * rb / fhs
              hl1    = min(max(hl1, ztmin1), ztmax1)
            endif
!
!  second iteration
!
            tem1  = hl1 * z1i
            hl0   = z0max * tem1
            hlt   = ztmax * tem1
            aa    = sqrt(1. + alpha4 * hl1)
            aa0   = sqrt(1. + alpha4 * hl0)
            bb    = aa
            bb0   = sqrt(1. + alpha4 * hlt)
            pm    = aa0 - aa + log( (1.0+aa)/(1.0+aa0) )
            ph    = bb0 - bb + log( (1.0+bb)/(1.0+bb0) )
            hl110 = hl1 * 10. * z1i
            hl110 = min(max(hl110, ztmin1), ztmax1)
            aa    = sqrt(1. + alpha4 * hl110)
            pm10  = aa0 - aa + log( (1.0+aa)/(1.0+aa0) )
            hl12  = (hl1+hl1) * z1i
            hl12  = min(max(hl12,ztmin1),ztmax1)
!           aa    = sqrt(1. + alpha4 * hl12)
            bb    = sqrt(1. + alpha4 * hl12)
            ph2   = bb0 - bb + log( (1.0+bb)/(1.0+bb0) )
!
!  unstable case - check for unphysical obukhov length
!
          else                          ! dtv < 0 case
            olinf = z1 / hlinf
            tem1  = 50.0 * z0max
            if(abs(olinf) <= tem1) then
              hlinf = -z1 / tem1
              hlinf = min(max(hlinf,ztmin1),ztmax1)
            endif
!
!  get pm and ph
!
            if (hlinf >= -0.5) then
              hl1   = hlinf
              pm    = (a0  + a1*hl1)  * hl1   / (1.+ (b1+b2*hl1)  *hl1)
              ph    = (a0p + a1p*hl1) * hl1   / (1.+ (b1p+b2p*hl1)*hl1)
              hl110 = hl1 * 10. * z1i
              hl110 = min(max(hl110, ztmin1), ztmax1)
              pm10  = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110)
              hl12  = (hl1+hl1) * z1i
              hl12  = min(max(hl12, ztmin1), ztmax1)
              ph2   = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12)
            else                       ! hlinf < 0.05
              hl1   = -hlinf
              tem1  = 1.0 / sqrt(hl1)
              pm    = log(hl1) + 2. * sqrt(tem1) - .8776
              ph    = log(hl1) + .5 * tem1 + 1.386
!             pm    = log(hl1) + 2.0 * hl1 ** (-.25) - .8776
!             ph    = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386
              hl110 = hl1 * 10. * z1i
              hl110 = min(max(hl110, ztmin1), ztmax1)
              pm10  = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776
!             pm10  = log(hl110) + 2. * hl110 ** (-.25) - .8776
              hl12  = (hl1+hl1) * z1i
              hl12  = min(max(hl12, ztmin1), ztmax1)
              ph2   = log(hl12) + 0.5 / sqrt(hl12) + 1.386
!             ph2   = log(hl12) + .5 * hl12 ** (-.5) + 1.386
            endif

          endif          ! end of if (dtv >= 0 ) then loop
!
!  finish the exchange coefficient computation to provide fm and fh
!
          fm        = fm - pm
          fh        = fh - ph
          fm10      = fm10 - pm10
          fh2       = fh2 - ph2
          cm        = ca * ca / (fm * fm)
          ch        = ca * ca / (fm * fh)
          tem1      = 0.00001/z1
          cm        = max(cm, tem1)
          ch        = max(ch, tem1)
          stress    = cm * wind * wind
          ustar     = sqrt(stress)

      return
!.................................
      end subroutine stability
!---------------------------------

!! add fitted z0,zt curves for hurricane application (used in HWRF/HMON)
!! Weiguo Wang, 2019-0425

      SUBROUTINE znot_m_v6(uref, znotm)
      use machine , only : kind_phys
      IMPLICIT NONE
! Calculate areodynamical roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013)
! For high winds, try to fit available observational data
!
! Bin Liu, NOAA/NCEP/EMC 2017
!
! uref(m/s)   :   wind speed at 10-m height
! znotm(meter):   areodynamical roughness scale over water
!

      REAL(kind=kind_phys), INTENT(IN) :: uref
      REAL(kind=kind_phys), INTENT(OUT):: znotm
      real(kind=kind_phys), parameter  :: p13 = -1.296521881682694e-02,
     &      p12 =  2.855780863283819e-01, p11 = -1.597898515251717e+00,
     &      p10 = -8.396975715683501e+00,

     &      p25 =  3.790846746036765e-10, p24 =  3.281964357650687e-09,
     &      p23 =  1.962282433562894e-07, p22 = -1.240239171056262e-06,
     &      p21 =  1.739759082358234e-07, p20 =  2.147264020369413e-05,

     &      p35 =  1.840430200185075e-07, p34 = -2.793849676757154e-05,
     &      p33 =  1.735308193700643e-03, p32 = -6.139315534216305e-02,
     &      p31 =  1.255457892775006e+00, p30 = -1.663993561652530e+01,

     &      p40 =  4.579369142033410e-04

       if (uref >= 0.0 .and.  uref <= 6.5 ) then
        znotm = exp(p10 + uref * (p11 + uref * (p12 + uref*p13)))
       elseif (uref > 6.5 .and. uref <= 15.7) then
        znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23
     &              + uref * (p24 + uref * p25))))
       elseif (uref > 15.7 .and. uref <= 53.0) then
        znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33
     &                   + uref * (p34 + uref * p35)))))
       elseif ( uref > 53.0) then
         znotm = p40
       else
        print*, 'Wrong input uref value:',uref
       endif

      END SUBROUTINE znot_m_v6

      SUBROUTINE znot_t_v6(uref, znott)
      use machine , only : kind_phys
      IMPLICIT NONE
! Calculate scalar roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF
!
! Bin Liu, NOAA/NCEP/EMC 2017
!
! uref(m/s)   :   wind speed at 10-m height
! znott(meter):   scalar roughness scale over water
!

      REAL(kind=kind_phys), INTENT(IN) :: uref
      REAL(kind=kind_phys), INTENT(OUT):: znott
      real(kind=kind_phys), parameter  :: p00 =  1.100000000000000e-04,
     &      p15 = -9.144581627678278e-10, p14 =  7.020346616456421e-08,
     &      p13 = -2.155602086883837e-06, p12 =  3.333848806567684e-05,
     &      p11 = -2.628501274963990e-04, p10 =  8.634221567969181e-04,

     &      p25 = -8.654513012535990e-12, p24 =  1.232380050058077e-09,
     &      p23 = -6.837922749505057e-08, p22 =  1.871407733439947e-06,
     &      p21 = -2.552246987137160e-05, p20 =  1.428968311457630e-04,

     &      p35 =  3.207515102100162e-12, p34 = -2.945761895342535e-10,
     &      p33 =  8.788972147364181e-09, p32 = -3.814457439412957e-08,
     &      p31 = -2.448983648874671e-06, p30 =  3.436721779020359e-05,

     &      p45 = -3.530687797132211e-11, p44 =  3.939867958963747e-09,
     &      p43 = -1.227668406985956e-08, p42 = -1.367469811838390e-05,
     &      p41 =  5.988240863928883e-04, p40 = -7.746288511324971e-03,

     &      p56 = -1.187982453329086e-13, p55 =  4.801984186231693e-11,
     &      p54 = -8.049200462388188e-09, p53 =  7.169872601310186e-07,
     &      p52 = -3.581694433758150e-05, p51 =  9.503919224192534e-04,
     &      p50 = -1.036679430885215e-02,

     &      p60 =  4.751256171799112e-05

      if (uref >= 0.0 .and. uref < 5.9 ) then
         znott = p00
      elseif (uref >= 5.9 .and. uref <= 15.4) then
         znott = p10 + uref * (p11 + uref * (p12 + uref * (p13
     &               + uref * (p14 + uref * p15))))
      elseif (uref > 15.4 .and. uref <= 21.6) then
         znott = p20 + uref * (p21 + uref * (p22 + uref * (p23
     &               + uref * (p24 + uref * p25))))
      elseif (uref > 21.6 .and. uref <= 42.2) then
         znott = p30 + uref * (p31 + uref * (p32 + uref * (p33
     &               + uref * (p34 + uref * p35))))
      elseif ( uref > 42.2 .and. uref <= 53.3) then
         znott = p40 + uref * (p41 + uref * (p42 + uref * (p43
     &               + uref * (p44 + uref * p45))))
      elseif ( uref > 53.3 .and. uref <= 80.0) then
         znott = p50 + uref * (p51 + uref * (p52 + uref * (p53
     &               + uref * (p54 + uref * (p55 + uref * p56)))))
      elseif ( uref > 80.0) then
         znott = p60
      else
         print*, 'Wrong input uref value:',uref
      endif

      END SUBROUTINE znot_t_v6

      SUBROUTINE znot_m_v7(uref, znotm)
      use machine , only : kind_phys
      IMPLICIT NONE
! Calculate areodynamical roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013)
! For high winds, try to fit available observational data
! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed
!
! Bin Liu, NOAA/NCEP/EMC 2018
!
! uref(m/s)   :   wind speed at 10-m height
! znotm(meter):   areodynamical roughness scale over water
!

      REAL(kind=kind_phys), INTENT(IN) :: uref
      REAL(kind=kind_phys), INTENT(OUT):: znotm

      real(kind=kind_phys), parameter  :: p13 = -1.296521881682694e-02,
     &      p12 =  2.855780863283819e-01, p11 = -1.597898515251717e+00,
     &      p10 = -8.396975715683501e+00,

     &      p25 =  3.790846746036765e-10, p24 =  3.281964357650687e-09,
     &      p23 =  1.962282433562894e-07, p22 = -1.240239171056262e-06,
     &      p21 =  1.739759082358234e-07, p20 =  2.147264020369413e-05,

     &      p35 =  1.897534489606422e-07, p34 = -3.019495980684978e-05,
     &      p33 =  1.931392924987349e-03, p32 = -6.797293095862357e-02,
     &      p31 =  1.346757797103756e+00, p30 = -1.707846930193362e+01,

     &      p40 =  3.371427455376717e-04

      if (uref >= 0.0 .and.  uref <= 6.5 ) then
        znotm = exp( p10 + uref * (p11 + uref * (p12 + uref * p13)))
      elseif (uref > 6.5 .and. uref <= 15.7) then
        znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23
     &              + uref * (p24 + uref * p25))))
      elseif (uref > 15.7 .and. uref <= 53.0) then
        znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33
     &                   + uref * (p34 + uref * p35)))))
      elseif ( uref > 53.0) then
        znotm = p40
      else
        print*, 'Wrong input uref value:',uref
      endif

      END SUBROUTINE znot_m_v7
      SUBROUTINE znot_t_v7(uref, znott)
      use machine , only : kind_phys
      IMPLICIT NONE
! Calculate scalar roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF
! To be compatible with the slightly decreased Cd for higher wind speed
!
! Bin Liu, NOAA/NCEP/EMC 2018
!
! uref(m/s)   :   wind speed at 10-m height
! znott(meter):   scalar roughness scale over water
!

      REAL(kind=kind_phys), INTENT(IN) :: uref
      REAL(kind=kind_phys), INTENT(OUT):: znott

      real(kind=kind_phys), parameter  :: p00 =  1.100000000000000e-04,

     &      p15 = -9.193764479895316e-10, p14 =  7.052217518653943e-08,
     &      p13 = -2.163419217747114e-06, p12 =  3.342963077911962e-05,
     &      p11 = -2.633566691328004e-04, p10 =  8.644979973037803e-04,

     &      p25 = -9.402722450219142e-12, p24 =  1.325396583616614e-09,
     &      p23 = -7.299148051141852e-08, p22 =  1.982901461144764e-06,
     &      p21 = -2.680293455916390e-05, p20 =  1.484341646128200e-04,

     &      p35 =  7.921446674311864e-12, p34 = -1.019028029546602e-09,
     &      p33 =  5.251986927351103e-08, p32 = -1.337841892062716e-06,
     &      p31 =  1.659454106237737e-05, p30 = -7.558911792344770e-05,

     &      p45 = -2.694370426850801e-10, p44 =  5.817362913967911e-08,
     &      p43 = -5.000813324746342e-06, p42 =  2.143803523428029e-04,
     &      p41 = -4.588070983722060e-03, p40 =  3.924356617245624e-02,

     &      p56 = -1.663918773476178e-13, p55 =  6.724854483077447e-11,
     &      p54 = -1.127030176632823e-08, p53 =  1.003683177025925e-06,
     &      p52 = -5.012618091180904e-05, p51 =  1.329762020689302e-03,
     &      p50 = -1.450062148367566e-02, p60 =  6.840803042788488e-05

        if (uref >= 0.0 .and. uref < 5.9 ) then
           znott = p00
        elseif (uref >= 5.9 .and. uref <= 15.4) then
           znott = p10 + uref * (p11 + uref * (p12 + uref * (p13
     &                 + uref * (p14 + uref * p15))))
        elseif (uref > 15.4 .and. uref <= 21.6) then
           znott = p20 + uref * (p21 + uref * (p22 + uref * (p23
     &                 + uref * (p24 + uref * p25))))
        elseif (uref > 21.6 .and. uref <= 42.6) then
           znott = p30 + uref * (p31 + uref * (p32 + uref * (p33
     &                 + uref * (p34 + uref * p35))))
        elseif ( uref > 42.6 .and. uref <= 53.0) then
           znott = p40 + uref * (p41 + uref * (p42 + uref * (p43
     &                 + uref * (p44 + uref * p45))))
        elseif ( uref > 53.0 .and. uref <= 80.0) then
           znott = p50 + uref * (p51 + uref * (p52 + uref * (p53
     &                 + uref * (p54 + uref * (p55 + uref * p56)))))
        elseif ( uref > 80.0) then
           znott = p60
        else
           print*, 'Wrong input uref value:',uref
        endif

        END SUBROUTINE znot_t_v7

!---------------------------------
      end module sfc_diff


!    ------------------------------------------------------------------
!     E C O R E
!    ------------------------------------------------------------------
!
!
      SUBROUTINE ECORE(EL,EC,REL)
!
! *** COMPUTES THE ENERGY OF THE COMMON CLOSED SHELLS
!
      use param_C
      use radial_C
      use nel_C,EL_=>EL
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!      PARAMETER(NOD=220)
!      COMMON/PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MSOO,NCFG,IB,IC,ID
!     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
!      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX_(1))
!      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
      CHARACTER EL(*)*3
      LOGICAL REL
!
      EC = 0.D0
      DO 10 I = 1,NCLOSD
       SUMI = 4*L(I)+2
       TI = RK(I,I,I,I,0,REL)
       DO 20 K = 2,2*L(I),2
        CA = ZCB(L(i),K,L(i)) * (2*L(I)+1)/(4*L(i)+1)
        TI = TI - CA*RK(I,I,I,I,K,REL)
   20  Continue
!                                                 o-o contribution
       IF(MSOO.GT.2) THEN
        if(L(I).eq.1) TI = TI +  8.D0/5.D0 *SN(I,I,I,I,0)
        if(L(I).eq.2) TI = TI + 56.D0/21.D0*SN(I,I,I,I,0)               &
     &                        + 16.D0/21.D0*SN(I,I,I,I,2)
        if(L(I).eq.3) TI = TI + 48.D0/13.D0*SN(I,I,I,I,0)               &
     &                        + 16.D0/13.D0*SN(I,I,I,I,2)               &
     &                        + 80.D0/143.D0*SN(I,I,I,I,4)
       end if
!
       EC = EC + SUMI*((SUMI-1)*TI - HL(EL,I,I,REL))/D2
!
       DO 30 J = 1,I-1
         SUMJ = 4*L(J)+2
         TIJ = RK(I,J,I,J,0,REL)
         DO 40 K=IABS(L(I)-L(J)),L(I)+L(J),2
            CB = ZCB(L(i),K,L(j))/2
            TIJ = TIJ -CB*RK(I,J,J,I,K,REL)
!
         if(MSOO.GT.2.and.L(i).gt.0.and.L(j).gt.0) then
          CN = CB * (L(i)+L(j)+k+2)*(L(i)+L(j)-k)
          CN = CN * (L(i)-L(j)+k+1)*(L(j)-L(i)+k+1)
          CN = CN / ((k+1)*(k+2))
          if(abs(CN).gt.0.0) TIJ = TIJ + CN*2*SN(I,J,J,I,K)
         end if
!
  40     Continue
!
       EC = EC + SUMI*SUMJ*TIJ
!
  30   Continue
  10  Continue
!
      END


      double complex function a6virtLL(st,j1,j2,j3,j4,j5,j6,za,zb)
****************************************************
* virtual amplitude for
* 0->q(p1)+qb(p2)+gam(p3)+gam(p4)+lb*p5)+l(p6)
* where both photon are coming from lepton line
****************************************************
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      character*9 st
      integer j1,j2,j3,j4,j5,j6
      double complex a6treeg,vll
c-----
      a6virtLL = a6treeg(st,j1,j2,j3,j4,j5,j6,za,zb)
     .              *vll(st,j5,j6,j3,j4,j1,j2)
c-----
      return
      end

      double complex function vll(st,j1,j2,j3,j4,j5,j6)
c-----divergent part
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      include 'epinv2.f'
      integer j1,j2,j3,j4,j5,j6
      double complex Lnrat,xl12
      character*9 st
c-----
      xl12=Lnrat(musq,-s(j1,j2))
c-----
      vll = -4D0
     .      -(epinv*epinv2+epinv*xl12+half*xl12**2)
     .      -(3D0/2D0)*(epinv+xl12)
c-----
      return
      end