*
*  Definition:
*  ===========
*
*      SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
*     $                     LDT, C, LDC, WORK, LWORK, INFO )
*
*
*     .. Scalar Arguments ..
*      CHARACTER         SIDE, TRANS
*      INTEGER           INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
*     ..
*     .. Array Arguments ..
*      DOUBLE        A( LDA, * ), WORK( * ), C(LDC, * ),
*     $                  T( LDT, * )
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>      SLAMTSQR overwrites the general real M-by-N matrix C with
*>
*>
*>                 SIDE = 'L'     SIDE = 'R'
*> TRANS = 'N':      Q * C          C * Q
*> TRANS = 'T':      Q**T * C       C * Q**T
*>      where Q is a real orthogonal matrix defined as the product
*>      of blocked elementary reflectors computed by tall skinny
*>      QR factorization (DLATSQR)
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SIDE
*>          SIDE is CHARACTER*1
*>          = 'L': apply Q or Q**T from the Left;
*>          = 'R': apply Q or Q**T from the Right.
*>
*> \param[in] TRANS
*>          TRANS is CHARACTER*1
*>          = 'N':  No transpose, apply Q;
*>          = 'T':  Transpose, apply Q**T.
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >=0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix C. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of elementary reflectors whose product defines
*>          the matrix Q.
*>          N >= K >= 0;
*>
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*>          MB is INTEGER
*>          The block size to be used in the blocked QR.
*>          MB > N. (must be the same as DLATSQR)
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          The column block size to be used in the blocked QR.
*>          N >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,K)
*>          The i-th column must contain the vector which defines the
*>          blockedelementary reflector H(i), for i = 1,2,...,k, as
*>          returned by DLATSQR in the first k columns of
*>          its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.
*>          If SIDE = 'L', LDA >= max(1,M);
*>          if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*>          T is REAL array, dimension
*>          ( N * Number of blocks(CEIL(M-K/MB-K)),
*>          The blocked upper triangular block reflectors stored in compact form
*>          as a sequence of upper triangular blocks.  See below
*>          for further details.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= NB.
*> \endverbatim
*>
*> \param[in,out] C
*>          C is REAL array, dimension (LDC,N)
*>          On entry, the M-by-N matrix C.
*>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
*> \param[in] LDC
*>          LDC is INTEGER
*>          The leading dimension of the array C. LDC >= max(1,M).
*>
*> \param[out] WORK
*> \verbatim
*>         (workspace) REAL array, dimension (MAX(1,LWORK))
*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>
*>          If SIDE = 'L', LWORK >= max(1,N)*NB;
*>          if SIDE = 'R', LWORK >= max(1,MB)*NB.
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*>
*> \endverbatim
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
*> representing Q as a product of other orthogonal matrices
*>   Q = Q(1) * Q(2) * . . . * Q(k)
*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
*>   Q(1) zeros out the subdiagonal entries of rows 1:MB of A
*>   Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
*>   Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
*>   . . .
*>
*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
*> stored under the diagonal of rows 1:MB of A, and by upper triangular
*> block reflectors, stored in array T(1:LDT,1:N).
*> For more information see Further Details in GEQRT.
*>
*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
*>     J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
*>     SIAM J. Sci. Comput, vol. 34, no. 1, 2012
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
     $        LDT, C, LDC, WORK, LWORK, INFO )
*
*  -- LAPACK computational routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2013
*
*     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS
      INTEGER           INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
*     ..
*     .. Array Arguments ..
      REAL              A( LDA, * ), WORK( * ), C(LDC, * ),
     $                T( LDT, * )
*     ..
*
* =====================================================================
*
*     ..
*     .. Local Scalars ..
      LOGICAL    LEFT, RIGHT, TRAN, NOTRAN, LQUERY
      INTEGER    I, II, KK, LW, CTR
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           SGEMQRT, STPMQRT, XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      LQUERY  = LWORK.LT.0
      NOTRAN  = LSAME( TRANS, 'N' )
      TRAN    = LSAME( TRANS, 'T' )
      LEFT    = LSAME( SIDE, 'L' )
      RIGHT   = LSAME( SIDE, 'R' )
      IF (LEFT) THEN
        LW = N * NB
      ELSE
        LW = MB * NB
      END IF
*
      INFO = 0
      IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
         INFO = -1
      ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
        INFO = -3
      ELSE IF( N.LT.0 ) THEN
        INFO = -4
      ELSE IF( K.LT.0 ) THEN
        INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
        INFO = -9
      ELSE IF( LDT.LT.MAX( 1, NB) ) THEN
        INFO = -11
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -13
      ELSE IF(( LWORK.LT.MAX(1,LW)).AND.(.NOT.LQUERY)) THEN
        INFO = -15
      END IF
      IF( INFO.EQ.0)  THEN
*
*     Determine the block size if it is tall skinny or short and wide
*
      IF( INFO.EQ.0)  THEN
          WORK(1) = LW
      END IF
      END IF
      IF( INFO.NE.0 ) THEN
        CALL XERBLA( 'SLAMTSQR', -INFO )
        RETURN
      ELSE IF (LQUERY) THEN
       RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN(M,N,K).EQ.0 ) THEN
        RETURN
      END IF
*
      IF((MB.LE.K).OR.(MB.GE.MAX(M,N,K))) THEN
        CALL SGEMQRT( SIDE, TRANS, M, N, K, NB, A, LDA,
     $        T, LDT, C, LDC, WORK, INFO)
        RETURN
       END IF
*
      IF(LEFT.AND.NOTRAN) THEN
*
*         Multiply Q to the last block of C
*
         KK = MOD((M-K),(MB-K))
         CTR = (M-K)/(MB-K)
         IF (KK.GT.0) THEN
           II=M-KK+1
           CALL STPMQRT('L','N',KK , N, K, 0, NB, A(II,1), LDA,
     $       T(1,CTR*K+1),LDT , C(1,1), LDC,
     $       C(II,1), LDC, WORK, INFO )
         ELSE
           II=M+1
         END IF
*
         DO I=II-(MB-K),MB+1,-(MB-K)
*
*         Multiply Q to the current block of C (I:I+MB,1:N)
*
           CTR = CTR - 1
           CALL STPMQRT('L','N',MB-K , N, K, 0,NB, A(I,1), LDA,
     $         T(1, CTR * K + 1), LDT, C(1,1), LDC,
     $         C(I,1), LDC, WORK, INFO )
*
         END DO
*
*         Multiply Q to the first block of C (1:MB,1:N)
*
         CALL SGEMQRT('L','N',MB , N, K, NB, A(1,1), LDA, T
     $            ,LDT ,C(1,1), LDC, WORK, INFO )
*
      ELSE IF (LEFT.AND.TRAN) THEN
*
*         Multiply Q to the first block of C
*
         KK = MOD((M-K),(MB-K))
         II=M-KK+1
         CTR = 1
         CALL SGEMQRT('L','T',MB , N, K, NB, A(1,1), LDA, T
     $            ,LDT ,C(1,1), LDC, WORK, INFO )
*
         DO I=MB+1,II-MB+K,(MB-K)
*
*         Multiply Q to the current block of C (I:I+MB,1:N)
*
          CALL STPMQRT('L','T',MB-K , N, K, 0,NB, A(I,1), LDA,
     $       T(1,CTR * K + 1),LDT, C(1,1), LDC,
     $       C(I,1), LDC, WORK, INFO )
          CTR = CTR + 1
*
         END DO
         IF(II.LE.M) THEN
*
*         Multiply Q to the last block of C
*
          CALL STPMQRT('L','T',KK , N, K, 0,NB, A(II,1), LDA,
     $      T(1, CTR * K + 1), LDT, C(1,1), LDC,
     $      C(II,1), LDC, WORK, INFO )
*
         END IF
*
      ELSE IF(RIGHT.AND.TRAN) THEN
*
*         Multiply Q to the last block of C
*
          KK = MOD((N-K),(MB-K))
          CTR = (N-K)/(MB-K)
          IF (KK.GT.0) THEN
            II=N-KK+1
            CALL STPMQRT('R','T',M , KK, K, 0, NB, A(II,1), LDA,
     $        T(1, CTR * K + 1), LDT, C(1,1), LDC,
     $        C(1,II), LDC, WORK, INFO )
          ELSE
            II=N+1
          END IF
*
          DO I=II-(MB-K),MB+1,-(MB-K)
*
*         Multiply Q to the current block of C (1:M,I:I+MB)
*
              CTR = CTR - 1
              CALL STPMQRT('R','T',M , MB-K, K, 0,NB, A(I,1), LDA,
     $          T(1, CTR * K + 1), LDT, C(1,1), LDC,
     $          C(1,I), LDC, WORK, INFO )
          END DO
*
*         Multiply Q to the first block of C (1:M,1:MB)
*
          CALL SGEMQRT('R','T',M , MB, K, NB, A(1,1), LDA, T
     $              ,LDT ,C(1,1), LDC, WORK, INFO )
*
      ELSE IF (RIGHT.AND.NOTRAN) THEN
*
*         Multiply Q to the first block of C
*
         KK = MOD((N-K),(MB-K))
         II=N-KK+1
         CTR = 1
         CALL SGEMQRT('R','N', M, MB , K, NB, A(1,1), LDA, T
     $              ,LDT ,C(1,1), LDC, WORK, INFO )
*
         DO I=MB+1,II-MB+K,(MB-K)
*
*         Multiply Q to the current block of C (1:M,I:I+MB)
*
          CALL STPMQRT('R','N', M, MB-K, K, 0,NB, A(I,1), LDA,
     $         T(1, CTR * K + 1),LDT, C(1,1), LDC,
     $         C(1,I), LDC, WORK, INFO )
          CTR = CTR + 1
*
         END DO
         IF(II.LE.N) THEN
*
*         Multiply Q to the last block of C
*
          CALL STPMQRT('R','N', M, KK , K, 0,NB, A(II,1), LDA,
     $        T(1, CTR * K + 1),LDT, C(1,1), LDC,
     $        C(1,II), LDC, WORK, INFO )
*
         END IF
*
      END IF
*
      WORK(1) = LW
      RETURN
*
*     End of SLAMTSQR
*
      END


!==========================================================================
elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, &
                                              rho_sa_sa, rho_sa_h, rho_h_h)
! =========================================================================
!
!  Calculates three second-order derivatives of rho with respect to enthalpy.
!  Note that this function uses the using the computationally-efficient
!  expression for specific volume (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  rho_SA_SA = The second-order derivative of rho with respect to
!              Absolute Salinity at constant h & p.     [ J/(kg (g/kg)^2) ]
!  rho_SA_h  = The second-order derivative of rho with respect to
!              SA and h at constant p.                   [ J/(kg K(g/kg)) ]
!  rho_h_h   = The second-order derivative of rho with respect to h at
!              constant SA & p
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_specvol
use gsw_mod_toolbox, only : gsw_specvol_first_derivatives_wrt_enthalpy
use gsw_mod_toolbox, only : gsw_specvol_second_derivatives_wrt_enthalpy

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h

integer :: iflag1, iflag2
real (r8) :: rec_v, rec_v2, rec_v3, v_h, v_h_h, v_sa, v_sa_h, v_sa_sa

iflag1 = 0
if (present(rho_sa_sa) .or. present(rho_sa_h)) iflag1 = ibset(iflag1,1)
if (present(rho_sa_h) .or. present(rho_h_h)) iflag1 = ibset(iflag1,2)

call gsw_specvol_first_derivatives_wrt_enthalpy(sa,ct,p,v_sa,v_h,iflag=iflag1)

iflag2 = 0
if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1)
if (present(rho_sa_h)) iflag2 = ibset(iflag2,2)
if (present(rho_h_h)) iflag2 = ibset(iflag2,3)

call gsw_specvol_second_derivatives_wrt_enthalpy(sa,ct,p,v_sa_sa,v_sa_h,v_h_h, &
                                                 iflag=iflag2)

rec_v = 1.0_r8/gsw_specvol(sa,ct,p)
rec_v2 = rec_v**2
rec_v3 = rec_v2*rec_v

if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3

if (present(rho_sa_h)) rho_sa_h = -v_sa_h*rec_v2 + 2.0_r8*v_sa*v_h*rec_v3

if (present(rho_h_h)) rho_h_h = -v_h_h*rec_v2 + 2.0_r8*v_h*v_h*rec_v3

return
end subroutine

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


subroutine CommonTangentZone

    USE ModuleThermoIO
    USE ModuleThermo
    USE ModuleGEMSolver
    USE ModuleParseCS
    USE ModuleReinit
    USE ModuleCTZ

    implicit none

    integer :: i, j, k, nnlsInfo, soln, con, tempInd
    integer :: assemblageMatch, assemblageInd
    real(8) :: dSum, tInterp!, tempMol
    real(8), dimension(:,:), allocatable :: stoichTemp, stoichInterp
    integer, dimension(:),   allocatable :: indx
    real(8), dimension(:),   allocatable :: dElCon, dElConTemp, x, work
    character(12), dimension(:), allocatable :: elementTemp
    real(8)                              :: rnorm
    logical                              :: trigger, reinit, unsorted, useNNLS, override
    ! integer, dimension(0:168)            :: iElementsUsed
    real(8), dimension(0:168)            :: dElementMassTemp

    reinit   = .FALSE.
    useNNLS  = .TRUE.
    override = .FALSE.

    trigger = .TRUE.

    if (useNNLS) then
      dElementMassTemp = dElementMass
      call InitThermo
      call CheckSystem
      call CompThermoData
      dElementMass = dElementMassTemp

      allocate(dElCon(nMaxElements),dElConTemp(nMaxElements),x(nMaxElements),work(nMaxElements),indx(nMaxElements))
      allocate(stoichInterp(nMaxElements,nMaxElements),stoichTemp(nMaxElements,nMaxElements))
      allocate(elementTemp(nMaxElements))
      dElCon = 0D0
      dElCon(1:nElements) = dMolesElement
      elementTemp = ''
      elementTemp(1:nElements) = cElementName

      TestAssemblages: do assemblageInd = 1, nAssemblages
          ! If the temperature is out of range, can't use this assemblage
          if ((dTemperature < assemblageTlimits(assemblageInd,1)) .OR. (dTemperature > assemblageTlimits(assemblageInd,2))) then
              cycle TestAssemblages
          end if
          ! If the elements don't match, can't use this assemblage
          do i = 1, nMaxElements
              if (elementTemp(i) /= elementHistory(assemblageInd,i)) cycle TestAssemblages
          end do
          dElConTemp = dElCon
          x = 0D0
          ! Use temperature to interpolate into stoichiometry entries
          if (assemblageTlimits(assemblageInd,1) == assemblageTlimits(assemblageInd,2)) then
              tInterp = 0D0
          else
              tInterp = (dTemperature - assemblageTlimits(assemblageInd,1)) &
                      / (assemblageTlimits(assemblageInd,2) - assemblageTlimits(assemblageInd,1))
          end if
          stoichInterp = 0D0
          do i = 1, nMaxElements
              do j = 1, nMaxElements
                  stoichInterp(i,j) = tInterp * stoichHistory(assemblageInd,2,i,j) + &
                                      (1D0 - tInterp) * stoichHistory(assemblageInd,1,i,j)
              end do
          end do
          stoichTemp = stoichInterp
          call nnls(stoichTemp, nMaxElements, nMaxElements, dElConTemp, x, rnorm, work, indx, nnlsInfo)

          rnorm = 0D0
          ! print *, '-----------------'
          do i = 1, nMaxElements
              dSum = 0D0
              do j = 1, nMaxElements
                dSum = dSum + stoichInterp(i,j) * x(j)
              end do
              rnorm = rnorm + (dSum - dElCon(i))**2
              ! print *, i, dSum, dElCon(i)
          end do
          if (rnorm > maxNorm) then
              cycle TestAssemblages
          else
              ! dMolFraction = dMolFraction_Old
              ! nSkipped = nSkipped + 1
              trigger = .FALSE.
              ! print *, 'skipped'
              ! print *, assemblageHistory(assemblageInd,:)
              ! print *, x / dNormalizeInput
              exit TestAssemblages
          end if
      end do TestAssemblages

      deallocate(dElCon,dElConTemp,x,work,indx)
      deallocate(stoichInterp,stoichTemp)
      deallocate(elementTemp)
    end if

    if (trigger) then
        if (INFOThermo == 0)        call Thermochimica
        if (((nConPhases + nSolnPhases) > 1) .AND. (useNNLS .OR. override)) then
            ! reset data
            assemblageHistory(nAssemblages + 1,:) = 0
            assemblageHistory(nAssemblages + 1,1:nElements) = iAssemblage
            elementHistory(nAssemblages + 1,:) = ''
            elementHistory(nAssemblages + 1,1:nElements) = cElementName(1:nElements)
            ! print *, elementHistory(nAssemblages + 1,:)
            if (nAssemblages < nMaxAssemblages) then
                assemblageTlimits(nAssemblages + 1,1) = 1D5
                assemblageTlimits(nAssemblages + 1,2) = 0D0
            end if
            ! Sort the assemblage for easy comparison later
            unsorted = .TRUE.
            do while (unsorted)
                unsorted = .FALSE.
                do i = 1, nMaxElements-1
                    if (assemblageHistory(nAssemblages + 1,i) < assemblageHistory(nAssemblages + 1,i+1)) then
                        tempInd = assemblageHistory(nAssemblages + 1,i+1)
                        assemblageHistory(nAssemblages + 1,i+1) = assemblageHistory(nAssemblages+1,i)
                        assemblageHistory(nAssemblages + 1,i)   = tempInd
                        ! tempMol = dMolesPhase(i+1)
                        ! dMolesPhase(i+1) = dMolesPhase(i)
                        ! dMolesPhase(i)   = tempMol
                        unsorted = .TRUE.
                    end if
                end do
            end do
            ! print *, assemblageHistory(nAssemblages + 1,:)
            ! print *, dMolesPhase
            ! Now compare to past assemblages
            assemblageMatch = 0
            CompareAssemblages: do i = 1, nAssemblages
                do j = 1, nMaxElements
                    if (assemblageHistory(nAssemblages + 1,j) /= assemblageHistory(i,j)) cycle CompareAssemblages
                end do
                ! if (loopInd == 76) print *, dTemperature, i, assemblageTlimits(i,1), assemblageTlimits(i,2)
                ! print *, '-----------------'
                ! print *, assemblageHistory(nAssemblages + 1,:)
                ! print *, assemblageHistory(i,:)
                ! Check if match is within acceptable temperature bounds
                if ((ABS(dTemperature - assemblageTlimits(i,1)) < tRange) .AND. &
                    (ABS(dTemperature - assemblageTlimits(i,2)) < tRange)) then
                    assemblageMatch = i
                    exit CompareAssemblages
                end if
                ! If it isn't within temperature bounds, one limit of it might still be
                if (nAssemblages < nMaxAssemblages) then
                    if (ABS(dTemperature - assemblageTlimits(i,1)) < tRange) then
                        assemblageTlimits(nAssemblages + 1,1) = assemblageTlimits(i,1)
                        assemblageTlimits(nAssemblages + 1,2) = assemblageTlimits(i,1)
                        stoichHistory(nAssemblages + 1,1,:,:) = stoichHistory(i,1,:,:)
                        stoichHistory(nAssemblages + 1,2,:,:) = stoichHistory(i,1,:,:)
                    end if
                    if (ABS(dTemperature - assemblageTlimits(2,1)) < tRange) then
                        assemblageTlimits(nAssemblages + 1,1) = assemblageTlimits(i,2)
                        assemblageTlimits(nAssemblages + 1,2) = assemblageTlimits(i,2)
                        stoichHistory(nAssemblages + 1,1,:,:) = stoichHistory(i,2,:,:)
                        stoichHistory(nAssemblages + 1,2,:,:) = stoichHistory(i,2,:,:)
                    end if
                end if
            end do CompareAssemblages
            ! If no match found create a new record
            if ((assemblageMatch == 0) .AND. (nAssemblages < nMaxAssemblages)) then
                nAssemblages = nAssemblages + 1
                ! print *, loopInd, nAssemblages
                assemblageMatch = nAssemblages
            end if
            ! Adjust limits for match or new assemblage
            if (assemblageMatch > 0) then
                ! low T limit
                if (dTemperature < assemblageTlimits(assemblageMatch,1)) then
                    assemblageTlimits(assemblageMatch,1) = dTemperature
                    stoichHistory(assemblageMatch,1,:,:) = 0D0
                    RecordStoichLow: do i = 1, nMaxElements
                        k = assemblageHistory(assemblageMatch,i)
                        if (k == 0) cycle RecordStoichLow
                        if (k > 0) then
                            do j = 1, nElements
                                stoichHistory(assemblageMatch,1,j,i) = dStoichSpecies(k,j)
                            end do
                        end if
                        if (k < 0) then
                            call CompStoichSolnPhase(-k)
                            do j = 1, nElements
                                stoichHistory(assemblageMatch,1,j,i) = dEffStoichSolnPhase(-k,j)
                            end do
                        end if
                    end do RecordStoichLow
                end if
                ! high T limit
                if (dTemperature > assemblageTlimits(assemblageMatch,2)) then
                    assemblageTlimits(assemblageMatch,2) = dTemperature
                    stoichHistory(assemblageMatch,2,:,:) = 0D0
                    RecordStoichHigh: do i = 1, nMaxElements
                        k = assemblageHistory(assemblageMatch,i)
                        if (k == 0) cycle RecordStoichHigh
                        if (k > 0) then
                            do j = 1, nElements
                                stoichHistory(assemblageMatch,2,j,i) = dStoichSpecies(k,j)
                            end do
                        end if
                        if (k < 0) then
                            call CompStoichSolnPhase(-k)
                            do j = 1, nElements
                                stoichHistory(assemblageMatch,2,j,i) = dEffStoichSolnPhase(-k,j)
                            end do
                        end if
                    end do RecordStoichHigh
                end if
            end if
        end if
        ! print *, 'dMolesPhase', dMolesPhase
        ! if (INFOThermo == 0)        call SaveReinitData
        if (iPrintResultsMode > 0)  call PrintResults
        soln = nSolnPhases
        con  = nConPhases
        lReinitRequested = ((soln + con < 3)) .AND. reinit
        if ((INFOThermo == 0) .AND. lReinitRequested) call SaveReinitData

        trigger = .TRUE.
        if (INFOThermo == 0) call ResetThermo
        if (INFOThermo >  0) call ThermoDebug
    end if

end subroutine CommonTangentZone


! Mandelbrot set renderer in Fortran 2003
!   $ gfortran -std=f2003 -O3 -ffast-math mandelbrot.f90
!   $ ./a.out >mandelbrot.pgm
program mandelbrot
    implicit none

    real, parameter :: xmin = -2.5, xmax = +1.5
    real, parameter :: ymin = -1.5, ymax = +1.5
    real, parameter :: step = 0.0025
    integer, parameter :: width  = int((xmax - xmin) / step)
    integer, parameter :: height = int((ymax - ymin) / step)
    integer, parameter :: iterations = 255

    integer :: i, x, y
    integer, allocatable :: k(:, :)
    complex, allocatable :: z(:, :)
    complex, allocatable :: c(:, :)

    allocate(k(width, height))
    k = 0
    allocate(z(width, height))
    z = 0
    allocate(c(width, height))
    forall (x = 1:width, y = 1:height)
        c(x, y) = cmplx((x - 1)*step + xmin, (y - 1)*step + ymin)
    end forall

    ! Compute the Mandelbrot set
    do i = 1, iterations
        z = z**2 + c
        where (abs(z) < 2) k = k + 1
    end do

    ! Render Netpbm grayscale image
    print '(a/2i10/i4)', 'P2', width, height, iterations
    print *, int(((real(k) / iterations) ** 0.5) * iterations)
end program


      subroutine fourt(data,nn,ndim,isign,iform,work)
c  june 30, 1983
c  watch out for integer*4 on vax!! nn, isign and iform must all
c    be dimensioned integer*4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c     the fast fourier transform in usasi basic fortran
c
c     transform(j1,j2,...) = sum(data(i1,i2,...)*w1**((i1-1)*(j1-1))
c                                 *w2**((i2-1)*(j2-1))*...),
c     where i1 and j1 run from 1 to nn(1) and w1=exp(isign*2*pi*
c     sqrt(-1)/nn(1)), etc.  there is no limit on the dimensionality
c     (number of subscripts) of the data array.  if an inverse
c     transform (isign=+1) is performed upon an array of transformed
c     (isign=-1) data, the original data will reappear,
c     multiplied by nn(1)*nn(2)*...  the array of input data may be
c     real or complex, at the programmers option, with a saving of
c     up to forty per cent in running time for real over complex.
c     (for fastest transform of real data, nn(1) should be even.)
c     the transform values are always complex, and are returned in the
c     original array of data, replacing the input data.  the length
c     of each dimension of the data array may be any integer.  the
c     program runs faster on composite integers than on primes, and is
c     particularly fast on numbers rich in factors of two.
c
c     timing is in fact given by the following formula.  let ntot be the
c     total number of points (real or complex) in the data array, that
c     is, ntot=nn(1)*nn(2)*...  decompose ntot into its prime factors,
c     such as 2**k2 * 3**k3 * 5**k5 * ...  let sum2 be the sum of all
c     the factors of two in ntot, that is, sum2 = 2*k2.  let sumf be
c     the sum of all other factors of ntot, that is, sumf = 3*k3+5*k5+..
c     the time taken by a multidimensional transform on these ntot data
c     point add time = six microseconds), t = 3000 + ntot*(600+40*sum2+
c     is t = t0 + ntot*(t1+t2*sum2+t3*sumf).  on the cdc 3300 (floating
c     175*sumf) microseconds on complex data.
c     implementation of the definition by summation will run in a time
c
c     proportional to ntot*(nn(1)+nn(2)+...).  for highly composite ntot
c     the savings offered by this program can be dramatic.  a one-dimen-
c     sional array 4000 in length will be transformed in 4000*(600+
c     40*(2+2+2+2+2)+175*(5+5+5)) = 14.5 seconds versus about 4000*
c     4000*175 = 2800 seconds for the straightforward technique.
c
c     the fast fourier algorithm places two restrictions upon the
c     nature of the data beyond the usual restriction that
c     the data form one cycle of a periodic function.  they are--
c     1.  the number of input data and the number of transform values
c     must be the same.
c     2. considering the data to be in the time domain,
c     they must be equi-spaced at intervals of dt.  further, the trans-
c     form values, considered to be in frequency space, will be equi-
c     spaced from 0 to 2*pi*(nn(i)-1)/(nn(i)*dt) at intervals of
c     2*pi/(nn(i)*dt) for each dimension of length nn(i).  of course,
c     dt need not be the same for every dimension.
c
c     the calling sequence is--
c     call fourt(data,nn,ndim,isign,iform,work)
c
c     data is the array used to hold the real and imaginary parts
c     of the data on input and the transform values on output.  it
c     is a multidimensional floating point array, with the real and
c     imaginary parts of a datum stored immediately adjacent in storage
c     (such as fortran iv places them).  the extent of each dimension
c     is given in the integer array nn, of length ndim.  isign is -1
c     to indicate a forward transform (exponential sign is -) and +1
c     for an inverse transform (sign is +).  iform is +1 if the data and
c     the transform values are complex.  it is 0 if the data are real
c     but the transform values are complex.  if it is 0, the imaginary
c     parts of the data should be set to zero.  as explained above, the
c     transform values are always complex and are stored in array data.
c     work is an array used for working storage.  it is not necessary
c     if all the dimensions of the data are powers of two.  in this case
c     it may be replaced by 0 in the calling sequence.  thus, use of
c     powers of two can free a good deal of storage.  if any dimension
c     is not a power of two, this array must be supplied.  it is
c     floating point, one dimensional of length equal to twice the
c     largest array dimension (i.e., nn(i) ) that is not a power of
c     two.  therefore, in one dimension for a non power of two,
c     work occupies as many storage locations as data.  if supplied,
c     work must not be the same array as data.  all subscripts of all
c     arrays begin at one.
c
c     example 1.  three-dimensional forward fourier transform of a
c     complex array dimensioned 32 by 25 by 13 in fortran iv.

c     complex array dimensioned 32 by 25 by 13 in fortran iv.
c     dimension data(32,25,13),work(50),nn(3)
c     complex data
c     data nn/32,25,13/
c     do 1 i=1,32
c     do 1 j=1,25
c     do 1 k=1,13
c  1  data(i,j,k)=complex value
c     call fourt(data,nn,3,-1,1,work)
c
c     example 2.  one-dimensional forward transform of a real array of
c     length 64 in fortran ii.
c     dimension data(2,64)
c     do 2 i=1,64
c     data(1,i)=real part
c  2  data(2,i)=0.
c     call fourt(data,64,1,-1,0,0)
c
c     there are no error messages or error halts in this program.  the
c     program returns immediately if ndim or any nn(i) is less than one.
c
c     program by norman brenner from the basic program by charles
c     rader (both of mit lincoln laboratory).  may 1967.  the idea
c     for the digit reversal was suggested by ralph alter (also mit ll).
c     this is the fastest and most versatile version of the fft known
c     to the author.  a program called four2 is available that also
c     performs the fast fourier transform and is written in usasi basic
c     fortran.  it is about one third as long and restricts the
c     dimensions of the input array (which must be complex) to be powers
c     of two.  another program, called four1, is one tenth as long and
c     runs two thirds as fast on a one-dimensional complex array whose
c     length is a power of two.
c
c     reference--
c     fast fourier transforms for fun and profit, w. gentleman and
c     g. sande, 1966 fall joint computer conference.
c
c     the work reported in this document was performed at lincoln lab-
c     oratory, a center for research operated by massachusetts institute
c     of technology, with the support of the u.s. air force under
c     contract af 19(628)-5167.
      dimension data(*),nn(1),ifact(32),work(1)
      integer*4 nn,isign,iform
      twopi=6.283185307
      rthlf=.7071067812
      if(ndim-1)920,1,1
1     ntot=2
      do 2 idim=1,ndim
      if(nn(idim))920,920,2
2     ntot=ntot*nn(idim)
c
c     main loop for each dimension
c
      np1=2
      do 910 idim=1,ndim
      n=nn(idim)
      np2=np1*n
      if(n-1)920,900,5
c
c     is n a power of two and if not, what are its factors
c
5     m=n
      ntwo=np1
      if=1
      idiv=2
10    iquot=m/idiv
      irem=m-idiv*iquot
      if(iquot-idiv)50,11,11
11    if(irem)20,12,20
12    ntwo=ntwo+ntwo
      ifact(if)=idiv
      if=if+1
      m=iquot
      go to 10
20    idiv=3
      inon2=if
30    iquot=m/idiv
      irem=m-idiv*iquot
      if(iquot-idiv)60,31,31
31    if(irem)40,32,40
32    ifact(if)=idiv
      if=if+1
      m=iquot
      go to 30
40    idiv=idiv+2
      go to 30
50    inon2=if
      if(irem)60,51,60
51    ntwo=ntwo+ntwo
      go to 70
60    ifact(if)=m
70    non2p=np2/ntwo
c
c     separate four cases--
c        1. complex transform
c        2. real transform for the 2nd, 3rd, etc. dimension.  method--
c           transform half the data, supplying the other half by con-
c           jugate symmetry.
c        3. real transform for the 1st dimension, n odd.  method--
c           set the imaginary parts to zero.
c        4. real transform for the 1st dimension, n even.  method--
c           transform a complex array of length n/2 whose real parts
c           are the even numbered real values and whose imaginary parts
c           are the odd numbered real values.  separate and supply
c           the second half by conjugate symmetry.
c
      icase=1
      ifmin=1
      i1rng=np1
      if(idim-4)74,100,100
74    if(iform)71,71,100
71    icase=2
      i1rng=np0*(1+nprev/2)
      if(idim-1)72,72,100
72    icase=3
      i1rng=np1
      if(ntwo-np1)100,100,73
73    icase=4
      ifmin=2
      ntwo=ntwo/2
      n=n/2
      np2=np2/2
      ntot=ntot/2
      i=1
      do 80 j=1,ntot
      data(j)=data(i)
80    i=i+2
c
c     shuffle data by bit reversal, since n=2**k.  as the shuffling
c     can be done by simple interchange, no working array is needed
c
100   if(non2p-1)101,101,200
101   np2hf=np2/2
      j=1
      do 150 i2=1,np2,np1
      if(j-i2)121,130,130
121   i1max=i2+np1-2
      do 125 i1=i2,i1max,2
      do 125 i3=i1,ntot,np2
      j3=j+i3-i2
      tempr=data(i3)
      tempi=data(i3+1)
      data(i3)=data(j3)
      data(i3+1)=data(j3+1)
      data(j3)=tempr
125   data(j3+1)=tempi
130   m=np2hf
140   if(j-m)150,150,141
141   j=j-m
      m=m/2
      if(m-np1)150,140,140
150   j=j+m
      go to 300
c
c     shuffle data by digit reversal for general n
c
200   nwork=2*n
      do 270 i1=1,np1,2
      do 270 i3=i1,ntot,np2
      j=i3
      do 260 i=1,nwork,2
      if(icase-3)210,220,210
210   work(i)=data(j)
      work(i+1)=data(j+1)
      go to 240
220   work(i)=data(j)
      work(i+1)=0.
240   ifp2=np2
      if=ifmin
250   ifp1=ifp2/ifact(if)
      j=j+ifp1
      if(j-i3-ifp2)260,255,255
255   j=j-ifp2
      ifp2=ifp1
      if=if+1
      if(ifp2-np1)260,260,250
260   continue
      i2max=i3+np2-np1
      i=1
      do 270 i2=i3,i2max,np1
      data(i2)=work(i)
      data(i2+1)=work(i+1)
270   i=i+2
c     main loop for factors of two.
c     w=exp(isign*2*pi*sqrt(-1)*m/(4*mmax)).  check for w=isign*sqrt(-1)
c     and repeat for w=w*(1+isign*sqrt(-1))/sqrt(2).
c
300   if(ntwo-np1)600,600,305
305   np1tw=np1+np1
      ipar=ntwo/np1
310   if(ipar-2)350,330,320
320   ipar=ipar/4
      go to 310
330   do 340 i1=1,i1rng,2
      do 340 k1=i1,ntot,np1tw
      k2=k1+np1
      tempr=data(k2)
      tempi=data(k2+1)
      data(k2)=data(k1)-tempr
      data(k2+1)=data(k1+1)-tempi
      data(k1)=data(k1)+tempr
340   data(k1+1)=data(k1+1)+tempi
350   mmax=np1
360   if(mmax-ntwo/2)370,600,600
370   lmax=max0(np1tw,mmax/2)
      do 570 l=np1,lmax,np1tw
      m=l
      if(mmax-np1)420,420,380
380   theta=-twopi*float(l)/float(4*mmax)
      if(isign)400,390,390
390   theta=-theta
400   wr=cos(theta)
      wi=sin(theta)
410   w2r=wr*wr-wi*wi
      w2i=2.*wr*wi
      w3r=w2r*wr-w2i*wi
      w3i=w2r*wi+w2i*wr
420   do 530 i1=1,i1rng,2
      kmin=i1+ipar*m
      if(mmax-np1)430,430,440
430   kmin=i1
440   kdif=ipar*mmax
450   kstep=4*kdif
      if(kstep-ntwo)460,460,530
460   do 520 k1=kmin,ntot,kstep
      k2=k1+kdif
      k3=k2+kdif
      k4=k3+kdif
      if(mmax-np1)470,470,480
470   u1r=data(k1)+data(k2)
      u1i=data(k1+1)+data(k2+1)
      u2r=data(k3)+data(k4)
      u2i=data(k3+1)+data(k4+1)
      u3r=data(k1)-data(k2)
      u3i=data(k1+1)-data(k2+1)
      if(isign)471,472,472
471   u4r=data(k3+1)-data(k4+1)
      u4i=data(k4)-data(k3)
      go to 510
472   u4r=data(k4+1)-data(k3+1)
      u4i=data(k3)-data(k4)
      go to 510
480   t2r=w2r*data(k2)-w2i*data(k2+1)
      t2i=w2r*data(k2+1)+w2i*data(k2)
      t3r=wr*data(k3)-wi*data(k3+1)
      t3i=wr*data(k3+1)+wi*data(k3)
      t4r=w3r*data(k4)-w3i*data(k4+1)
      t4i=w3r*data(k4+1)+w3i*data(k4)
      u1r=data(k1)+t2r
      u1i=data(k1+1)+t2i
      u2r=t3r+t4r
      u2i=t3i+t4i
      u3r=data(k1)-t2r
      u3i=data(k1+1)-t2i
      if(isign)490,500,500
490   u4r=t3i-t4i
      u4i=t4r-t3r
      go to 510
500   u4r=t4i-t3i
      u4i=t3r-t4r
510   data(k1)=u1r+u2r
      data(k1+1)=u1i+u2i
      data(k2)=u3r+u4r
      data(k2+1)=u3i+u4i
      data(k3)=u1r-u2r
      data(k3+1)=u1i-u2i
      data(k4)=u3r-u4r
520   data(k4+1)=u3i-u4i
      kdif=kstep
      kmin=4*(kmin-i1)+i1
      go to 450
530   continue
      m=m+lmax
      if(m-mmax)540,540,570
540   if(isign)550,560,560
550   tempr=wr
      wr=(wr+wi)*rthlf
      wi=(wi-tempr)*rthlf
      go to 410
560   tempr=wr
      wr=(wr-wi)*rthlf
      wi=(tempr+wi)*rthlf
      go to 410
570   continue
      ipar=3-ipar
      mmax=mmax+mmax
      go to 360
c
c     main loop for factors not equal to two.
c     w=exp(isign*2*pi*sqrt(-1)*(j1+j2-i3-1)/ifp2)
c
600   if(non2p-1)700,700,601
601   ifp1=ntwo
      if=inon2
610   ifp2=ifact(if)*ifp1
      theta=-twopi/float(ifact(if))
      if(isign)612,611,611
611   theta=-theta
612   wstpr=cos(theta)
      wstpi=sin(theta)
      do 650 j1=1,ifp1,np1
      thetm=-twopi*float(j1-1)/float(ifp2)
      if(isign)614,613,613
613   thetm=-thetm
614   wminr=cos(thetm)
      wmini=sin(thetm)
      i1max=j1+i1rng-2
      do 650 i1=j1,i1max,2
      do 650 i3=i1,ntot,np2
      i=1
      wr=wminr
      wi=wmini
      j2max=i3+ifp2-ifp1
      do 640 j2=i3,j2max,ifp1
      twowr=wr+wr
      j3max=j2+np2-ifp2
      do 630 j3=j2,j3max,ifp2
      jmin=j3-j2+i3
      j=jmin+ifp2-ifp1
      sr=data(j)
      si=data(j+1)
      oldsr=0.
      oldsi=0.
      j=j-ifp1
620   stmpr=sr
      stmpi=si
      sr=twowr*sr-oldsr+data(j)
      si=twowr*si-oldsi+data(j+1)
      oldsr=stmpr
      oldsi=stmpi
      j=j-ifp1
      if(j-jmin)621,621,620
621   work(i)=wr*sr-wi*si-oldsr+data(j)
      work(i+1)=wi*sr+wr*si-oldsi+data(j+1)
630   i=i+2
      wtemp=wr*wstpi
      wr=wr*wstpr-wi*wstpi
640   wi=wi*wstpr+wtemp
      i=1
      do 650 j2=i3,j2max,ifp1
      j3max=j2+np2-ifp2
      do 650 j3=j2,j3max,ifp2
      data(j3)=work(i)
      data(j3+1)=work(i+1)
650   i=i+2
      if=if+1
      ifp1=ifp2
      if(ifp1-np2)610,700,700
c
c     complete a real transform in the 1st dimension, n even, by con-
c     jugate symmetries.
c
700   go to (900,800,900,701),icase
701   nhalf=n
      n=n+n
      theta=-twopi/float(n)
      if(isign)703,702,702
702   theta=-theta
703   wstpr=cos(theta)
      wstpi=sin(theta)
      wr=wstpr
      wi=wstpi
      imin=3
      jmin=2*nhalf-1
      go to 725
710   j=jmin
      do 720 i=imin,ntot,np2
      sumr=(data(i)+data(j))/2.
      sumi=(data(i+1)+data(j+1))/2.
      difr=(data(i)-data(j))/2.
      difi=(data(i+1)-data(j+1))/2.
      tempr=wr*sumi+wi*difr
      tempi=wi*sumi-wr*difr
      data(i)=sumr+tempr
      data(i+1)=difi+tempi
      data(j)=sumr-tempr
      data(j+1)=-difi+tempi
720   j=j+np2
      imin=imin+2
      jmin=jmin-2
      wtemp=wr*wstpi
      wr=wr*wstpr-wi*wstpi
      wi=wi*wstpr+wtemp
725   if(imin-jmin)710,730,740
730   if(isign)731,740,740
731   do 735 i=imin,ntot,np2
735   data(i+1)=-data(i+1)
740   np2=np2+np2
      ntot=ntot+ntot
      j=ntot+1
      imax=ntot/2+1
745   imin=imax-2*nhalf
      i=imin
      go to 755
750   data(j)=data(i)
      data(j+1)=-data(i+1)
755   i=i+2
      j=j-2
      if(i-imax)750,760,760
760   data(j)=data(imin)-data(imin+1)
      data(j+1)=0.
      if(i-j)770,780,780
765   data(j)=data(i)
      data(j+1)=data(i+1)
770   i=i-2
      j=j-2
      if(i-imin)775,775,765
775   data(j)=data(imin)+data(imin+1)
      data(j+1)=0.
      imax=imin
      go to 745
780   data(1)=data(1)+data(2)
      data(2)=0.
      go to 900
c
c     complete a real transform for the 2nd, 3rd, etc. dimension by
c     conjugate symmetries.
c
800   if(i1rng-np1)805,900,900
805   do 860 i3=1,ntot,np2
      i2max=i3+np2-np1
      do 860 i2=i3,i2max,np1
      imax=i2+np1-2
      imin=i2+i1rng
      jmax=2*i3+np1-imin
      if(i2-i3)820,820,810
810   jmax=jmax+np2
820   if(idim-2)850,850,830
830   j=jmax+np0
      do 840 i=imin,imax,2
      data(i)=data(j)
      data(i+1)=-data(j+1)
840   j=j-2
850   j=jmax
      do 860 i=imin,imax,np0
      data(i)=data(j)
      data(i+1)=-data(j+1)
860   j=j-np0
c
c     end of loop on each dimension
c
900   np0=np1
      np1=np2
910   nprev=n
920   return
      end


********************************************************************
      SUBROUTINE outreg(un)
*     write solution
      implicit none
      include 'usr.com'
      include 'atm.com'
*     IMPORT/EXPORT
      real    un(ndim)
*     LOCAL
      integer i,j,k
      real    u(0:n,0:m,0:l+la+1),v(0:n,0:m,0:l+la+1)
      real    w(0:n+1,0:m+1,0:l+la),p(0:n+1,0:m+1,0:l+la+1)
      real    t(0:n+1,0:m+1,0:l+1+la),s(0:n+1,0:m+1,0:l+1+la)
      real    rho(0:n+1,0:m+1,0:l+1+la)
      real    cay,tay,c1,c2,dum1,dum2,h1,h2,xnes,lambda
      real    check,swl,swo
      real    hfun, salfun
*
      call usol(un,u,v,w,p,t,s)
      xnes = par(NLES)
      lambda = par(LAMB)
      rho    = lambda*s - t *( 1 + xnes*alpt1) -
     +            xnes*t*t*alpt2+xnes*t*t*t*alpt3
      call forcing
C----------------------------------------------------------
C    integral check 1: advection of salt
      write(17,*)  'advection of salt'
      check= 0.0
      do i = 1, n
      do j = 1, m
      do k = 1, l
         if( landm(i,j,l) == OCEAN ) then
         check = check +
     &      (u(i,j,k)+u(i,j-1,k))*(s(i+1,j,k)+s(i,j,k))/(4*dx)-
     &      (u(i-1,j,k)+u(i-1,j-1,k))*(s(i,j,k)+s(i-1,j,k))/(4*dx)+
     &      (v(i,j,k)+v(i-1,j,k))*(s(i,j+1,k)+s(i,j,k))*cos(yv(j))/(4*dy)-
     &      (v(i,j-1,k)+v(i-1,j-1,k))*(s(i,j,k)+s(i,j-1,k))*cos(yv(j-1))/(4*dy)+
     &      w(i,j,k)*(s(i,j,k+1)+s(i,j,k))*cos(y(j))/(2*dz*dfzW(k)) -
     &      w(i,j,k-1)*(s(i,j,k)+s(i,j,k-1))*cos(y(j))/(2*dz*dfzW(k-1))
          endif
      enddo
      enddo
      enddo
      write(17,*) 'int_V \nabla(u S) d^3x =', check * dx*dy*dz
C    integral check 2: surface integral of freshwater flux
      write(17,*)  'surface salt flux'
      check = 0.0
      do i=1,n
      do j=1,m
         if( landm(i,j,l) == OCEAN ) then
            if (SRES == 0) then
               check = fs(i,j) * cos(y(j)) + check
            else
               check = par(BIOT)*(par(SALT)*par(COMB)*salfun(x(i),y(j))  - s(i,j,l))
            endif
         endif
      enddo
      enddo
      write(17,*) 'int_S F_S d^2x =', check * dx * dy
C    integral check 3: conservation of salt
      write(17,*)  'salt conservation'
      check = 0.0
      do k = 1, l
      do i = 1, n
      do j = 1, m
         if( landm(i,j,k) == OCEAN ) then
            check = s(i,j,k) * cos(y(j)) * dfzT(k) + check
         endif
      enddo
      enddo
      enddo
      write(17,*) 'int_V  S d^3x =', check*dx*dy*dz
C    integral check 4: mixing terms (note: hor and vert both zero)
C    so not PH and PV necessary
      write(17,*)  'salt diffuson'
      check = 0.0
      do k = 1, l
         h1 = 1./(dfzT(k)*dfzW(k))
         h2 = 1./(dfzT(k)*dfzW(k-1))
         do j = 1, m
            cay = cos(y(j))
            c1 = cos(yv(j))
            c2 = cos(yv(j-1))
            do i = 1, n
               if( landm(i,j,k) == OCEAN ) then
               check =  check + cos(y(j)) * dfzT(k) * (
     &(   s(i+1,j,k)+   s(i-1,j,k)-      2*s(i,j,k))/(dx*dx*cay*cay)+
     &(c1*s(i,j+1,k)+c2*s(i,j-1,k)-(c1+c2)*s(i,j,k))/(dy*dy*cay)    +
     &(h1*s(i,j,k+1)+h2*s(i,j,k-1)-(h1+h2)*s(i,j,k))/(dz*dz)        )
               endif
            enddo
         enddo
      enddo
      write(17,*) 'int_V  \nabla^2 S d^3x = ', check *dx*dy*dz
C----------------------------------------------------------
C    integral check 5: advection of heat
      write(17,*)  'advection of heat'
      check = 0.0
      do i = 1, n
      do j = 1, m
      do k = 1, l
         if( landm(i,j,k) == OCEAN ) then
         check = check +
     &      (u(i,j,k)+u(i,j-1,k))*(t(i+1,j,k)+t(i,j,k))/(4*dx)-
     &      (u(i-1,j,k)+u(i-1,j-1,k))*(t(i,j,k)+t(i-1,j,k))/(4*dx)+
     &      (v(i,j,k)+v(i-1,j,k))*(t(i,j+1,k)+t(i,j,k))*cos(yv(j))/(4*dy)-
     &      (v(i,j-1,k)+v(i-1,j-1,k))*(t(i,j,k)+t(i,j-1,k))*cos(yv(j-1))/(4*dy)+
     &      w(i,j,k)*(t(i,j,k+1)+t(i,j,k))*cos(y(j))/(2*dz*dfzW(k)) -
     &      w(i,j,k-1)*(t(i,j,k)+t(i,j,k-1))*cos(y(j))/(2*dz*dfzW(k-1))
          endif
      enddo
      enddo
      enddo
      write(17,*) 'int_V \nabla(u T) d^3x =', check * dx*dy*dz
C    integral check 6: surface integral of heat flux (uncoupled case)
      IF (la == 0) THEN
      write(17,*)  'surface heat flux, uncoupled'
      check = 0.0
      do i=1,n
      do j=1,m
         if( landm(i,j,l) == OCEAN ) then
            if (TRES == 0) then
               check = ft(i,j) * cos(y(j)) + check
            else
               check = par(BIOT)*(par(TEMP)*par(COMB)*hfun(x(i),y(j))  - t(i,j,l))
            endif
         endif
      enddo
      enddo
      write(17,*) 'int_S Q_T d^2x =', check * dx * dy
C    integral check 7: mixing terms (note: hor and vert both zero)
C    so not PH and PV necessary
      write(17,*)  'heat diffuson'
      check = 0.0
      do k = 1, l
         h1 = 1./(dfzT(k)*dfzW(k))
         h2 = 1./(dfzT(k)*dfzW(k-1))
         do j = 1, m
            cay = cos(y(j))
            c1 = cos(yv(j))
            c2 = cos(yv(j-1))
            do i = 1, n
                if( landm(i,j,l) == OCEAN ) then
               check =  check + cos(y(j)) * dfzT(k) * (
     &(   t(i+1,j,k)+   t(i-1,j,k)-      2*t(i,j,k))/(dx*dx*cay*cay)+
     &(c1*t(i,j+1,k)+c2*t(i,j-1,k)-(c1+c2)*t(i,j,k))/(dy*dy*cay)    +
     &(h1*t(i,j,k+1)+h2*t(i,j,k-1)-(h1+h2)*t(i,j,k))/(dz*dz)        )
                endif
            enddo
         enddo
      enddo
      write(17,*) 'int_V \nabla^2 T d^3x = ', check *dx*dy*dz
      ENDIF
C----------------------------------------------------------
C    integral check 8: mass balance
      write(17,*)  'volume conservation'
      check = 0.0
      do j = 1, m
         cay = cos(y(j))
         c1 = cos(yv(j))
         c2 = cos(yv(j-1))
         do k = 1, l
         do i = 1, n
            if( landm(i,j,l) == OCEAN ) then
            check = check +dfzT(k)*( (u(i,j,k) +u(i,j-1,k)  - u(i-1,j,k)  - u(i-1,j-1,k)  )/(2*dx)+
     +                     ((v(i,j,k)+v(i-1,j,k))*c1- (v(i,j-1,k)+v(i-1,j-1,k))*c2)/(2*dy)+
     +                     (w(i,j,k)   - w(i,j,k-1))*cay/(dz*dfzT(k)) )
             endif
         enddo
         enddo
      enddo
      write(17,*) 'int_V \nabla u d^3x  =', check * dx*dy*dz
*    integral check 9:  geometric conservation
      write(17,*)  'geometry check'
      check = 0.0
      do k = 1, l
         check = check + dfzT(k)
      enddo
      write(17,*) 'int_z dfz dz - 1 .... =', check * dz - 1.
C----------------------------------------------------------
      IF (la == 1) THEN
C    integral check 10: land energy balance
      write(17,*)  'surface land-atm heat flux'
      check = 0.0
      swl = 0.0
      do i=1,n
         do j=1,m
              IF (landm(i,j,l) == LAND) THEN
                   check = check + (t(i,j,l) - t(i,j,l+1))*cos(y(j))
                   swl = par(COMB)*par(SUNP) * suno(j)*cos(y(j)) /Ooa + swl
              ENDIF
         enddo
      enddo
      write(17,*) 'int_S_l  (t-tatm)-sw d^2x =', (check-swl)*dx*dy
C    integral check 11: ocean energy balance
      write(17,*)  'surface ocean-atm heat flux'
      check = 0.0
      swo = 0.0
      do i=1,n
         do j=1,m
              IF (landm(i,j,l) == OCEAN) THEN
                   check = check + (t(i,j,l) - t(i,j,l+1))*cos(y(j))
                   swo = par(COMB)*par(SUNP)*suno(j)*cos(y(j)) /Ooa + swo
              ENDIF
         enddo
      enddo
      write(17,*) 'int_S_o (t-tatm)-sw d^2x=', (check-swo)*dx*dy
C    integral check 12: global energy balance
      write(17,*)  'surface energy balance'
      check = 0.0
      swo = 0.0
      do i=1,n
         do j=1,m
          check = check + t(i,j,l+1)*cos(y(j))
          swo = par(COMB)* par(SUNP)*(suna(j)+suno(j)/Ooa - amua)*cos(y(j))/bmua + swo
         enddo
      enddo
      write(17,*) 'int_S tatm -sw d^2x =', (check-swo)*dx*dy
C----------------------------------------------------------
      ENDIF
      END


      DOUBLE PRECISION FUNCTION PHO_CT14ALPHAS(Qq)

      IMPLICIT NONE
      DOUBLE PRECISION ALScteq , q , QBAse , QINi , QMAx , Qq , tt ,
     &                 TV , UPD , XMIn , XV
      INTEGER IPDsformat , IPDsset , ISEtch , jlq , jm , jq , ju , lo ,
     &        lpri , MAXVAL , MXF , MXPQX , MXQ , MXVal , MXX , NFMx ,
     &        NT , NX

      PARAMETER (MXX=201,MXQ=40,MXF=6,MAXVAL=4)
      PARAMETER (MXPQX=(MXF+1+MAXVAL)*MXQ*MXX)
      DOUBLE PRECISION alsout

      COMMON /CTQPAR1/ QBAse , XV(0:MXX) , TV(0:MXQ) , UPD(MXPQX) ,
     &                 ALScteq(0:MXQ)/CTQPAR2/ NX , NT , NFMx ,
     &                 MXVal/XQRANGE/ QINi , QMAx ,
     &                 XMIn/SETCHANGE/ ISEtch , IPDsset , IPDsformat

      DATA q , jq/ - 1D0 , 0/
      SAVE

      IF ( IPDsset.NE.1 )
     &      STOP 'pho_CT14Alphas: the PDF table was not initialized'

      IF ( IPDsformat.LT.11 ) THEN
         IF ( lpri.GT.4 ) WRITE (lo,*)
     &  'STOP in pho_CT14alphas: the PDF table file has an older format'
         IF ( lpri.GT.4 ) WRITE (lo,*)
     &         'and does not include the table of QCD coupling values.'
         IF ( lpri.GT.4 ) WRITE (lo,*)
     &         'You can still compute the PDFs, but do not call'
         IF ( lpri.GT.4 ) WRITE (lo,*)
     &   'the pho_CT14alphas function for the interpolation of alpha_s.'
         STOP
      END IF

      q = Qq
      tt = LOG(LOG(q/QBAse))

C         --------------   Find lower end of interval containing Q, i.e.,
C                          get jq such that qv(jq) .le. q .le. qv(jq+1)...
      jlq = -1
      ju = NT + 1
 100  IF ( ju-jlq.GT.1 ) THEN
         jm = (ju+jlq)/2
         IF ( tt.GE.TV(jm) ) THEN
            jlq = jm
         ELSE
            ju = jm
         END IF
         GOTO 100
      END IF

      IF ( jlq.LE.0 ) THEN
         jq = 0
      ELSE IF ( jlq.LE.NT-2 ) THEN
C                                  keep q in the middle, as shown above
         jq = jlq - 1
      ELSE
C                         JLq .GE. Nt-1 case:  Keep at least 4 points >= Jq.
         jq = NT - 3

      END IF
C                                 This is the interpolation variable in Q
      CALL PHO_POLINT4F(TV(jq),ALScteq(jq),tt,alsout)

      PHO_CT14ALPHAS = alsout

C                                       ********************
      END FUNCTION


      SUBROUTINE DIAT(NI,NJ,XI,XJ,DI)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
***************************************************************************
*
*   DIAT CALCULATES THE DI-ATOMIC OVERLAP INTEGRALS BETWEEN ATOMS
*        CENTERED AT XI AND XJ.
*
*   ON INPUT NI  = ATOMIC NUMBER OF THE FIRST ATOM.
*            NJ  = ATOMIC NUMBER OF THE SECOND ATOM.
*            XI  = CARTESIAN COORDINATES OF THE FIRST ATOM.
*            XJ  = CARTESIAN COORDINATES OF THE SECOND ATOM.
*
*  ON OUTPUT DI  = DIATOMIC OVERLAP, IN A 9 * 9 MATRIX. LAYOUT OF
*                  ATOMIC ORBITALS IN DI IS
*                  1   2   3   4   5            6     7       8     9
*                  S   PX  PY  PZ  D(X**2-Y**2) D(XZ) D(Z**2) D(YZ) D(XY)
*
*   LIMITATIONS:  IN THIS FORMULATION, NI AND NJ MUST BE LESS THAN 54
*         EXPONENTS ARE ASSUMED TO BE PRESENT IN COMMON BLOCK EXPONT.
*
***************************************************************************
      INTEGER PQ1,A,PQ2,B,PQA,PQB,AA,BB,PVAL1,PVAL2,YETA
      LOGICAL FIRST
      COMMON /EXPONT/ EMUS(54),EMUP(54),EMUD(54)
      DIMENSION DI(9,9),S(3,3,3),UL1(3),UL2(3),C(3,5,5),NPQ(54)
     +          ,XI(3),XJ(3)
      DATA NPQ/1,1, 2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3, 4,4,4,4,4,4,4,4,
     +4,4,4,4,4,4,4,4,4,4, 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5/
      DATA FIRST /.TRUE./
      X1=XI(1)
      X2=XJ(1)
      Y1=XI(2)
      Y2=XJ(2)
      Z1=XI(3)
      Z2=XJ(3)
      PQ1=NPQ(NI)
      PQA=PQ1
      PQ2=NPQ(NJ)
      PQB=PQ2
      UL1(1)=EMUS(NI)
      UL2(1)=EMUS(NJ)
      UL1(2)=EMUP(NI)
      UL2(2)=EMUP(NJ)
      DO 349 I=1,9
      DO 350 J=1,9
      DI(I,J)=0.0D0
 350  CONTINUE
 349  DI(I,I)=1.D0
      CALL COE(X1,Y1,Z1,X2,Y2,Z2,PQ1,PQ2,C,R)
          IF (PQ1.GT.3) GO TO 351
          A=PQ1-1
          GO TO 352
 351      A=2
 352      CONTINUE
          IF (PQ2.GT.3) GO TO 353
          B=PQ2-1
          GO TO 354
 353      B=2
 354      CONTINUE
          IA=A+1
          IB=B+1
       IF(PQ1.LT.4.AND.PQ2.LT.4) THEN
          CALL DIAT2(NI,EMUS(NI),EMUP(NI),R,NJ,EMUS(NJ),EMUP(NJ),S)
C      WRITE(6,'(3I4,F12.6)')(((I,J,K,S(I,J,K),I=1,2),J=1,2),K=1,2)
      ELSE
          DO 355 I=1,3
              DO 355 J=1,3
                  DO 355 K=1,3
                  S(I,J,K)=0.0D0
 355      CONTINUE
          DO 363 I=1,IA
              IB=B+1
              DO 363 J=1,IB
                  IF (A.LT.B) GO TO 357
                  NEWK=B
                  GO TO 358
 357              NEWK=A
 358              CONTINUE
                  NK1=NEWK+1
                  DO 363 K=1,NK1
                      IF(K.GT.I.OR.K.GT.J) GOTO 363
                      U1=UL1(I)
                      U2=UL2(J)
                      YETA=PQA+PQB+3
                      S(I,J,K)=SS(PQA,PQB,I,J,K,U1,U2,R,YETA,FIRST)
C      WRITE(6,'(3I4,F12.6)')I,J,K,S(I,J,K)
 363      CONTINUE
      ENDIF
      DO 369 I=1,IA
      DO 369 J=1,IB
      IF (I.EQ.1) GO TO 10
      IF (I.EQ.2) GO TO 11
      KMIN=1
      KMAX=5
      GO TO 12
 11   KMIN=2
      KMAX=4
      GO TO 12
 10   KMIN=3
      KMAX=3
 12   DO 369 K=KMIN,KMAX
      IF (J.EQ.1) GO TO 13
      IF (J.EQ.2) GO TO 14
      LMIN=1
      LMAX=5
      GO TO 15
 14   LMIN=2
      LMAX=4
      GO TO 15
 13   LMIN=3
      LMAX=3
 15   DO 369 L=LMIN,LMAX
      IF (J.EQ.2) GO TO 364
      AA=1
      GO TO 365
 364  AA=-1
 365  CONTINUE
      IF (J.GT.2) GO TO 366
      BB=1
      GO TO 367
 366  BB=-1
 367  CONTINUE
      CALL VAL(I,K,PVAL1)
      CALL VAL(J,L,PVAL2)
      DI((PVAL1+1),(PVAL2+1))=S(I,J,1)*C(I,K,3)*C(J,L,3)*AA+(C(I,K,4)*C(
     1J,L,4)+C(I,K,2)*C(J,L,2))*BB*S(I,J,2)+(C(I,K,5)*C(J,L,5)+C(I,K,1)*
     2C(J,L,1))*S(I,J,3)
 369  CONTINUE
      RETURN
      END
      SUBROUTINE VAL(L,M,PVAL)
      INTEGER L,M,PVAL
      IF (L.EQ.1) PVAL=0
      IF ((L.EQ.2).AND.(M.EQ.2)) PVAL=2
      IF ((L.EQ.2).AND.(M.EQ.3)) PVAL=3
      IF ((L.EQ.2).AND.(M.EQ.4)) PVAL=1
      IF (L.EQ.3) PVAL=12-L-M
      RETURN
      END
      FUNCTION SS(NA,NB,LA,LB,M,UC,UD,R1,YETA,FIRST)
      DOUBLE PRECISION UC,SS,UD,R1,R
      LOGICAL FIRST
      INTEGER A,C,D,PP,B,Q,YETA
      DOUBLE PRECISION ER,P,BA,EX,QUO,S1,S2,QQ,QEB,SUM,SUM1,X,
     1FA(14),BI(13,13),AFF(3,3,3),AF(20),BF(20),UA,UB,SA
      DATA AFF/27*0. D0/
      R=R1
      UA=UC
      UB=UD
      IF(UA.GT.0.D0) GOTO 88
      SA=0.D0
      GO TO 99
   88 IF(UB.GT.0.D0) GOTO 299
      SA=0.D0
      GO TO 99
 299  CONTINUE
      R=R/0.529167D0
      ER=R
      GO TO 304
  300 FA(1)=1.D0
      DO 301 I=1,13
      FA(I+1)=FA(I)*I
 301  CONTINUE
      FIRST=.FALSE.
      DO 302 I=1,13
      BI(I,1)=1.D0
      BI(I,I)=1.D0
 302  CONTINUE
      DO 303 I=1,12
      I1=I-1
      DO 303 J=1,I1
      BI(I+1,J+1)=BI(I,J+1)+BI(I,J)
 303  CONTINUE
      AFF(1,1,1)=1.D0
      AFF(2,1,1)=1.D0
      AFF(2,2,1)=1.D0
      AFF(3,1,1)=1.5D0
      AFF(3,2,1)=1.73205D0
      AFF(3,3,1)=1.224745D0
      AFF(3,1,3)=-0.5D0
      GO TO 305
  304 IF(FIRST)GOTO 300
 305  CONTINUE
      P=(UA+UB)*ER*0.5D0
      BA=(UA-UB)*ER*0.5D0
      EX=EXP(BA)
      QUO=1/P
      AF(1)=QUO*EXP(-P)
      NANB=NA+NB
      DO 306 N=1,19
      AF(N+1)=N*QUO*AF(N)+AF(1)
 306  CONTINUE
      NANB1=NANB+1
      DO 309 N=1,13
      IF(ABS(BA).LT.0.1D0) GOTO 308
      S1=0.D0
      S2=0.D0
      QQ=1.D0
      DO 307 I=1,N
      QQ=QQ*BA
      QEB=1.D0/(QQ*FA(N+1-I))
      S1=S1+QEB
      INI=(N-I+1)/2
      S2=S2+2.D0*((INI*2-(N-1)+I)-1.5D0)*QEB
 307  CONTINUE
      BF(N)=-FA(N)*(S1/EX+S2*EX)
      GO TO 309
 308  IN=N/2
      BF(N)=0.D0
      IF(N.NE.IN*2) BF(N)=2.D0/N
 309  CONTINUE
      SUM=0.D0
      LAM1=LA-M+1
      LBM1=LB-M+1
      DO 311 I=1,LAM1,2
      DO 311 J=1,LBM1,2
      A=NA+I-LA
      B=NB+J-LB
      C=LA-I-M+1
      D=LB-J-M+1
      SUM1=0.D0
      IA=A+1
      IB=B+1
      IC=C+1
      ID=D+1
      AB=A+B-1
      DO 310 K1=1,IA
      DO 310 K2=1,IB
      DO 310 K3=1,IC
      DO 310 K4=1,ID
      DO 310 K5=1,M
      DO 310 K6=1,M
      Q=AB-K1-K2+K3+K4+2*K5
      PP=K1+K2+K3+K4+2*K6-5
      JX=M+K2+K4+K5+K6-5
      IX=JX/2
      SUM1=SUM1+BI(IA,K1)*BI(IB,K2)*BI(IC,K3)*BI(ID,K4)*BI(M,K5)*BI(
     1M,K6)*2.D0*(IX*2-JX+0.5D0)*AF(Q)*BF(PP)
 310  CONTINUE
      SUM=SUM+SUM1*AFF(LA,M,I)*AFF(LB,M,J)
 311  CONTINUE
      X=R
      DO 312 I=1,NA
      X=X*R*UA
 312  CONTINUE
      DO 313 I=1,NB
      X=X*R*UB
 313  CONTINUE
      SA=SUM*X*SQRT(UA*UB/(FA(NA+NA+1)*FA(NB+NB+1))*((LA+LA-1
     1)*(LB+LB-1)))/(2.D0**M)
 99   CONTINUE
      SS=SA
      RETURN
      END
      SUBROUTINE COE(X1,Y1,Z1,X2,Y2,Z2,PQ1,PQ2,C,R)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER PQ1,PQ2,PQ,CO
      DIMENSION C(3,5,5)
      XY=(X2-X1)**2+(Y2-Y1)**2
      R=SQRT(XY+(Z2-Z1)**2)
      XY=SQRT(XY)
      IF (XY.EQ.0.D0) GO TO 800
      CA=(X2-X1)/XY
      CB=(Z2-Z1)/R
      SA=(Y2-Y1)/XY
      SB=XY/R
      GO TO 804
 800  IF (Z2-Z1) 801,802,803
 801  CA=-1.D0
      CB=-1.D0
      SA=0.D0
      SB=0.D0
      GO TO 804
  802 CA=0.D0
      CB=0.D0
      SA=0.D0
      SB=0.D0
      GO TO 804
  803 CA=1.D0
      CB=1.D0
      SA=0.D0
      SB=0.D0
 804  CONTINUE
      CO=0
      DO 805 I=1,5
      DO 805 J=1,5
      DO 805 K=1,3
      C(K,I,J)=0.D0
 805  CONTINUE
      IF (PQ1.GT.PQ2) GO TO 806
      PQ=PQ2
      GO TO 807
 806  PQ=PQ1
 807  CONTINUE
      C(1,3,3)=1.D0
      IF (PQ.LT.2) GO TO 808
      C(2,4,4)=CA*CB
      C(2,4,3)=CA*SB
      C(2,4,2)=-SA
      C(2,3,4)=-SB
      C(2,3,3)=CB
      C(2,3,2)=0.D0
      C(2,2,4)=SA*CB
      C(2,2,3)=SA*SB
      C(2,2,2)=CA
      IF (PQ.LT.3) GO TO 808
      C2A=2*CA*CA-1.D0
      C2B=2*CB*CB-1.D0
      S2A=2*SA*CA
      S2B=2*SB*CB
      C(3,5,5)=C2A*CB*CB+0.5D0*C2A*SB*SB
      C(3,5,4)=0.5D0*C2A*S2B
      C(3,5,3)=0.8660254037841D0*C2A*SB*SB
      C(3,5,2)=-S2A*SB
      C(3,5,1)=-S2A*CB
      C(3,4,5)=-0.5D0*CA*S2B
      C(3,4,4)=CA*C2B
      C(3,4,3)=0.8660254037841D0*CA*S2B
      C(3,4,2)=-SA*CB
      C(3,4,1)=SA*SB
      C(3,3,5)=0.5773502691894D0*SB*SB*1.5D0
      C(3,3,4)=-0.8660254037841D0*S2B
      C(3,3,3)=CB*CB-0.5D0*SB*SB
      C(3,2,5)=-0.5D0*SA*S2B
      C(3,2,4)=SA*C2B
      C(3,2,3)=0.8660254037841D0*SA*S2B
      C(3,2,2)=CA*CB
      C(3,2,1)=-CA*SB
      C(3,1,5)=S2A*CB*CB+0.5D0*S2A*SB*SB
      C(3,1,4)=0.5D0*S2A*S2B
      C(3,1,3)=0.8660254037841D0*S2A*SB*SB
      C(3,1,2)=C2A*SB
      C(3,1,1)=C2A*CB
 808  CONTINUE
      RETURN
      END


      subroutine runY_00li(k,l,i1,Xtwiddle,Gtwiddle,Shat4,N0)
      implicit none
C---  Expression for Eq. 5.58b
C---  Calculates D00li, requires D00ll
C---  Small terms of order Xtwiddle(0,k)*Diii,Xtwiddle(0,0)*Diiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat4(np,z3max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Dv(dzzii(z2(l,i1))+N0,ep)=
     . (-2*Gtwiddle(k,i1)*Dv(dzzii(z2(l,l))+N0,ep)
     . +Gtwiddle(k,1)*Shat4(1,z3(l,l,i1),ep)
     . +Gtwiddle(k,2)*Shat4(2,z3(l,l,i1),ep)
     . +Gtwiddle(k,3)*Shat4(3,z3(l,l,i1),ep)
     . +Xtwiddle(0,k)*Dv(diii(z3(l,l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diiii(z4(k,l,l,i1))+N0,ep))/(4*Gtwiddle(k,l))

      enddo

      return
      end


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program MagDip_test
    use meshread_mod
    use EFIEDuffy_functions
    use MFIEDuffy_functions
    use EFIE_functions
    use linalg_mod
    use CFIE_mod
    use mpi
    use EFIE_RWG_matrices
    use spherePEC_mod
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    ! Variables
    type(Mesh) :: msh, msh_evl
    complex(8), allocatable :: Zefie(:,:), Einc(:,:), V1(:)
    complex(8), allocatable :: Zmfie(:,:), Hinc(:,:), V2(:), EMat(:, :)
    complex(8), allocatable :: I1(:), I2(:), Epot(:,:,:), Hpot(:,:,:), Ztest(:,:)
    complex(8), allocatable :: Es1(:,:), Es2(:,:), Eexact(:,:), Hexact(:,:)
    real(8), allocatable :: xEvl(:,:)
    real(8) :: ExNorm1, Error1, Error2
    integer :: nEvl
    integer, parameter :: nNS = 6        ! number of quadrature points for EFIE
    integer, parameter :: nNS2 = 6        ! number of quadrature points for EFIE Sauter-Schwab
    complex(8), allocatable :: Eproj(:)
    complex(8), allocatable :: Mvec(:)

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8) :: k        ! free-space wavenumber [1/m]
    real(8) :: w        ! angular frequency [rad/s]
    real(8) :: pol(3), src(3)
    character(len=100) :: file_msh, file_evl

    logical :: TE_mode  ! for planewave
    real(8) :: beta     ! angle of incidence of planewave

    k = 3d0 * PI                    ! free-space wavenumber [1/m]
    w = k / sqrt(ep0 * mu0)          ! angular frequency [rad/s]
    pol = [1.0d0, 1.0d0, 1.0d0]      ! polarization vector
    src = [-0.1d0, -0.1d0, -0.25d0]  ! location of dipole source

    TE_mode = .false.  ! for planewave
    beta = pi / 4d0

    file_msh = 'meshes/convergence_sphere/sph0400.msh' !sph0250
    file_evl = 'meshes/convergence_sphere/sphNF0300.msh'

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute EFIE matrices
    if (id == 0) print *, "EFIE"
    call genEFIESauterSchwabMat(Zefie, msh, k, nNS, nNS2)
    !call genEFIEDuffyMat(Z3, msh, k, nNS, nNS2)
    call genEFIESauterSchwabMat_RWG(Ztest, msh, k, nNS, nNS2)

    ! Compute MFIE matrices
    if (id == 0) print *, "MFIE"
    !call genMFIESauterSchwabMat(Z2, msh, k, EMat)
    call genMFIEMat(Zmfie, msh, k, EMat)

    ! Solve system
    if (id == 0) then
        allocate(V1(msh%nbEdg))
        allocate(I1(msh%nbEdg))
        allocate(V2(msh%nbEdg))
        allocate(I2(msh%nbEdg))

        ! Incident fields
        call DipoleFieldsOnMesh(pol, src, k, msh, Einc, Hinc)  ! Magnetic dipole
        Hinc = Hinc / (IU * w * mu0)        ! adjust constants

!        call DipoleFieldsOnMesh(pol, src, k, msh, Hinc, Einc)  ! Electric dipole
!        Einc = Einc / (-IU * w * ep0)        ! adjust constants

!        call planewave_on_mesh(beta, k, msh, Einc, TE_mode, Hinc)  ! planewave
!        Hinc = Hinc / (w * mu0)        ! adjust constants

        ! Compute projections <f_m, nxE>
        allocate(Eproj(msh%nbEdg))
        Eproj = genRHSMFIE(Einc, msh)

        ! Compute currents
        allocate(Mvec(msh%nbEdg))
        call linsolve(Mvec, EMat, -Eproj, msh%nbEdg)

        ! test RHS
        V1 = k**2 / (IU *w * mu0) * matmul(Ztest, Mvec)

        ! EFIE RHS
        V2 = genRHS(Einc, msh)
        V2 = V2 / (IU * w * mu0)  ! adjust constants

        ! Solve
        call linsolve(I1, -0.5d0*Emat+Zmfie, V1, msh%nbEdg) ! test
        call linsolve(I2, Zefie, V2, msh%nbEdg) ! EFIE
    end if

    ! Load eval mesh
    call load_gmsh(file_evl, msh_evl)
    nEvl = msh_evl%nbELm
    allocate(xEvl(1:nEvl,1:3))
    xEvl = msh_evl%CNTR + (msh%h/2.0d0**(0))*msh_evl%NRM

    ! Compute exact solution
    if (id==0) then
        call DipoleFieldsOnEvlMsh(pol, src, k, xEvl, Eexact, Hexact)  ! magnetic dipole
        Hexact = Hexact / (IU * w * mu0)        ! adjust constants

!        call DipoleFieldsOnEvlMsh(pol, src, k, xEvl, Hexact, Eexact)  ! electric dipole
!        Eexact = Eexact / (-IU * w * ep0)        ! adjust constants

!        call sphere_scattered_field(xEvl, k, 1d0, beta, Eexact, TE_mode)  ! planewave
!        Eexact = -Eexact         ! adjust constants

        ExNorm1 = maxval(sqrt(abs(Eexact(:,1))**2+abs(Eexact(:,2))**2+abs(Eexact(:,3))**2))
    endif

    ! Compute EFIE potencial
    call genEFIEPot(Epot, nEvl, xEvl, msh, k)

    ! Compute MFIE potencial
    call genMFIEPot(Hpot, nEvl, xEvl, msh, k)

    ! Compute BEM solution and error
    if (id==0) then
        Epot = Epot * (IU * w * mu0) ! adjust constants

        ! test
        allocate(Es1(1:nEvl,1:3))
        Es1(:,1) = matmul(Epot(:,:,1), I1) - matmul(Hpot(:,:,1), Mvec)
        Es1(:,2) = matmul(Epot(:,:,2), I1) - matmul(Hpot(:,:,2), Mvec)
        Es1(:,3) = matmul(Epot(:,:,3), I1) - matmul(Hpot(:,:,3), Mvec)
        Es1 = Es1 - Eexact
        Error1 = maxval(sqrt(abs(Es1(:,1))**2+abs(Es1(:,2))**2+abs(Es1(:,3))**2))

        ! EFIE
        allocate(Es2(1:nEvl,1:3))
        Es2(:,1) = matmul(Epot(:,:,1), I2)
        Es2(:,2) = matmul(Epot(:,:,2), I2)
        Es2(:,3) = matmul(Epot(:,:,3), I2)
        Es2 = Es2 - Eexact
        Error2 = maxval(sqrt(abs(Es2(:,1))**2+abs(Es2(:,2))**2+abs(Es2(:,3))**2))

        write(*,*) 'h ',' Error test: '
        write(*,*) msh%h, Error1 / ExNorm1

        write(*,*) 'h ',' Error EFIE: '
        write(*,*) msh%h, Error2 / ExNorm1

        print *, I1(5:15)/I2(5:15)

    end if

    call MPI_Finalize(ierr)
end program


!----------------------------------------------------------------------
! Module: module_parameters.f90
!> Purpose: compute NICAS parameters
!>

!> Author: Benjamin Menetrier
!>

!> Licensing: this code is distributed under the CeCILL-C license
!>

!> Copyright © 2017 METEO-FRANCE
!----------------------------------------------------------------------
module module_parameters

use model_interface, only: model_read,model_write
use module_namelist, only: datadir,prefix,model,levs,ntry,nrep,lsqrt,Lbh_file,Lbh,Lbv_file,Lbv,resol,network
use module_parameters_convol, only: compute_convol_network,compute_convol_distance
use module_parameters_interp, only: compute_interp_h,compute_interp_v,compute_interp_s
use netcdf
use omp_lib
use tools_const, only: pi,req,deg2rad,rad2deg,sphere_dist,vector_product,vector_triple_product
use tools_display, only: msgerror,prog_init,prog_print
use tools_missing, only: msvali,msvalr,msi,msr,isnotmsr,isnotmsi
use tools_nc, only: ncfloat,ncerr
use type_ctree, only: ctreetype,create_ctree,find_nearest_neighbors,delete_ctree
use type_mpl, only: mpl,mpl_bcast
use type_randgen, only: initialize_sampling,rand_integer
use type_sdata, only: sdatatype
implicit none

private
public :: compute_parameters

contains

!----------------------------------------------------------------------
! Subroutine: compute_parameters
!> Purpose: compute NICAS parameters
!----------------------------------------------------------------------
subroutine compute_parameters(sdata)

implicit none

! Passed variables
type(sdatatype),intent(inout) :: sdata !< Sampling data

! Local variables
integer :: il0,il0_prev,il1,ic0,ic1,ic2,i,is,il0i
integer :: mask_cell(sdata%nc0)
integer :: ifors(sdata%nfor)
integer :: ncid,nc1_id,two_id,namax_id,nl1_id,nc2_id,lon_id,lat_id,na_id,larc_id
real :: distnorm
real :: rh0(sdata%nc0,sdata%nl0),rv0(sdata%nc0,sdata%nl0),rh0min(sdata%nc0)
real,allocatable :: rh1(:,:),rv1(:,:),rh2(:,:),rv2(:,:),rhs(:),rvs(:)
character(len=1024) :: filename
character(len=1024) :: subr = 'compute_parameters'

! Compute grid mesh
write(mpl%unit,'(a7,a)') '','Compute grid mesh'
call compute_grid_mesh(sdata)

! Forced points in the subrid (TODO: rethink that)
sdata%nfor = 0
allocate(sdata%ifor(sdata%nfor))

! Compute adaptive mesh
write(mpl%unit,'(a7,a)') '','Compute adaptive mesh'

! Read length-scales and transform to Gaspari-Cohn (1999) function parameters
if (trim(Lbh_file)=='') then
   do il0=1,sdata%nl0
      rh0(:,il0) = Lbh(il0)
   end do
else
   call model_read(trim(Lbh_file),'Lh',sdata,rh0)
end if
if (trim(Lbv_file)=='') then
   do il0=1,sdata%nl0
      rv0(:,il0) = Lbv(il0)
   end do
else
   call model_read(trim(Lbv_file),'Lv',sdata,rv0)
end if
write(mpl%unit,'(a10,a,e10.3,a,e10.3)') '','Average length-scales (H/V): ',sum(rh0)/float(sdata%nc0*sdata%nl0),' / ',sum(rv0)/float(sdata%nc0*sdata%nl0)

! Compute scaled support radii
rh0 = 2.0*rh0/(sqrt(0.3)*req)
rv0 = 2.0*rv0/sqrt(0.3)
write(mpl%unit,'(a10,a,e10.3,a,e10.3)') '','Average scaled support radii (H/V): ',sum(rh0)/float(sdata%nc0*sdata%nl0),' / ',sum(rv0)/float(sdata%nc0*sdata%nl0)

! Basic horizontal mesh defined with the minimum support radius
rh0min = minval(rh0,dim=2)
sdata%nc1 = floor(2.0*maxval(sdata%area)*resol**2/(sqrt(3.0)*(sum(rh0min,mask=isnotmsr(rh0min))/float(count(isnotmsr(rh0min))))**2))+sdata%nfor
mask_cell = 0
do ic0=1,sdata%nc0
   if (any(sdata%mask(ic0,:))) mask_cell(ic0) = 1
end do
allocate(sdata%ic1_to_ic0(sdata%nc1))
call initialize_sampling(sdata%rng,sdata%nc0,dble(sdata%lon),dble(sdata%lat),mask_cell,rh0min,ntry,nrep,sdata%nc1,sdata%nfor,sdata%ifor,sdata%ic1_to_ic0)

! Inverse conversion
allocate(sdata%ic0_to_ic1(sdata%nc0))
call msi(sdata%ic0_to_ic1)
do ic1=1,sdata%nc1
   ic0 = sdata%ic1_to_ic0(ic1)
   sdata%ic0_to_ic1(ic0) = ic1
end do

! Compute horizontal interpolation data
write(mpl%unit,'(a7,a)') '','Compute horizontal interpolation data'
call compute_interp_h(sdata)

! Adapt support radii
allocate(rh1(sdata%nc1,sdata%nl0))
allocate(rv1(sdata%nc1,sdata%nl0))
do ic1=1,sdata%nc1
   rh1(ic1,:) = rh0(sdata%ic1_to_ic0(ic1),:)
   rv1(ic1,:) = rv0(sdata%ic1_to_ic0(ic1),:)
end do

! Vertical sampling
write(mpl%unit,'(a7,a)',advance='no') '','Vertical sampling: '
allocate(sdata%llev(sdata%nl0))
il0_prev = 1
do il0=1,sdata%nl0
   ! Look for convolution levels
   if ((il0==1).or.(il0==sdata%nl0)) then
      ! Keep first and last levels
      sdata%llev(il0) = .true.
   else
      ! Compute normalized distance with level il0_prev
      distnorm = abs(sdata%vunit(il0)-sdata%vunit(il0_prev))/sqrt(0.5*(minval(rv1(:,il0))**2+minval(rv1(:,il0_prev))**2))
      sdata%llev(il0) = distnorm>1.0/resol
   end if

   ! Update
   if (sdata%llev(il0)) il0_prev = il0
end do
sdata%nl1 = count(sdata%llev)
allocate(sdata%il1_to_il0(sdata%nl1))
il1 = 0
do il0=1,sdata%nl0
   if (sdata%llev(il0)) then
      write(mpl%unit,'(i3,a)',advance='no') levs(il0),' '
      il1 = il1+1
      sdata%il1_to_il0(il1) = il0
   end if
end do
write(mpl%unit,'(a)') ''

! Inverse conversion
allocate(sdata%il0_to_il1(sdata%nl0))
call msi(sdata%il0_to_il1)
do il1=1,sdata%nl1
   il0 = sdata%il1_to_il0(il1)
   sdata%il0_to_il1(il0) = il1
end do

! Compute vertical interpolation data
write(mpl%unit,'(a7,a)') '','Compute vertical interpolation data'
call compute_interp_v(sdata)

! Adapt support radii
allocate(rh2(sdata%nc1,sdata%nl1))
allocate(rv2(sdata%nc1,sdata%nl1))
do il1=1,sdata%nl1
   rh2(:,il1) = rh1(:,sdata%il1_to_il0(il1))
   rv2(:,il1) = rv1(:,sdata%il1_to_il0(il1))
end do

! Horizontal subsampling
allocate(sdata%nc2(sdata%nl1))
allocate(sdata%ic2il1_to_ic1(sdata%nc1,sdata%nl1))
do il1=1,sdata%nl1
   il0 = sdata%il1_to_il0(il1)
   sdata%nc2(il1) = floor(2.0*sdata%area(il0)*resol**2/(sqrt(3.0)*(sum(rh2(:,il1),mask=isnotmsr(rh2(:,il1)))/float(count(isnotmsr(rh2(:,il1)))))**2))+sdata%nfor
   sdata%nc2(il1) = min(sdata%nc2(il1),sdata%nc1)
   if (sdata%nc2(il1)<sdata%nc1) then
      ! Compute subsampling
      do i=1,sdata%nfor
         ifors(i) = i
      end do
      call initialize_sampling(sdata%rng,sdata%nc1,dble(sdata%lon(sdata%ic1_to_ic0)),dble(sdata%lat(sdata%ic1_to_ic0)),mask_cell(sdata%ic1_to_ic0),rh0(sdata%ic1_to_ic0,il0),ntry,nrep,sdata%nc2(il1),sdata%nfor,ifors,sdata%ic2il1_to_ic1(1:sdata%nc2(il1),il1))
   else
      do ic2=1,sdata%nc2(il1)
         sdata%ic2il1_to_ic1(ic2,il1) = ic2
      end do
   end if
end do

! Final conversions
sdata%ns = sum(sdata%nc2)
allocate(sdata%is_to_ic1(sdata%ns))
allocate(sdata%is_to_il1(sdata%ns))
allocate(sdata%is_to_ic2(sdata%ns))
allocate(sdata%ic0il0_to_is(sdata%nc0,sdata%nl0))
allocate(sdata%ic2il1_to_ic0(sdata%nc1,sdata%nl1))
allocate(sdata%ic2il1_to_is(sdata%nc1,sdata%nl1))
allocate(sdata%ic1il1_to_is(sdata%nc1,sdata%nl1))
call msi(sdata%ic0il0_to_is)
call msi(sdata%ic2il1_to_is)
call msi(sdata%ic1il1_to_is)
is = 0
do il1=1,sdata%nl1
   do ic2=1,sdata%nc2(il1)
      is = is+1
      ic1 = sdata%ic2il1_to_ic1(ic2,il1)
      ic0 = sdata%ic1_to_ic0(ic1)
      il0 = sdata%il1_to_il0(il1)

      sdata%is_to_ic1(is) = ic1
      sdata%is_to_il1(is) = il1
      sdata%is_to_ic2(is) = ic2
      sdata%ic0il0_to_is(ic0,il0) = is
      sdata%ic2il1_to_ic0(ic2,il1) = ic0
      sdata%ic2il1_to_is(ic2,il1) = is
      sdata%ic1il1_to_is(ic1,il1) = is
   end do
end do

! Compute subsampling horizontal interpolation data
write(mpl%unit,'(a7,a)') '','Compute subsampling horizontal interpolation data'
call compute_interp_s(sdata)

! Adapt support radii
allocate(rhs(sdata%ns))
allocate(rvs(sdata%ns))
do is=1,sdata%ns
   rhs(is) = rh2(sdata%is_to_ic1(is),sdata%is_to_il1(is))
   rvs(is) = rv2(sdata%is_to_ic1(is),sdata%is_to_il1(is))
end do

! Compute convolution data
write(mpl%unit,'(a7,a)') '','Compute convolution data'
if (network) then
   call compute_convol_network(sdata,rh0,rv0)
else
   call compute_convol_distance(sdata,rhs,rvs)
end if

! Compute subgrid mesh
write(mpl%unit,'(a7,a)') '','Compute subgrid mesh'
call compute_subgrid_mesh(sdata)

if (mpl%main) then
   ! Write mesh
   write(mpl%unit,'(a7,a)') '','Write subgrid mesh'
   filename = trim(prefix)//'_mesh.nc'
   call ncerr(subr,nf90_create(trim(datadir)//'/'//trim(filename),or(nf90_clobber,nf90_64bit_offset),ncid))
   call ncerr(subr,nf90_def_dim(ncid,'nc1',sdata%nc1,nc1_id))
   call ncerr(subr,nf90_def_dim(ncid,'two',2,two_id))
   call ncerr(subr,nf90_def_dim(ncid,'namax',maxval(sdata%na),namax_id))
   call ncerr(subr,nf90_def_dim(ncid,'nl1',sdata%nl1,nl1_id))
   call ncerr(subr,nf90_def_var(ncid,'nc2',nf90_int,(/nl1_id/),nc2_id))
   call ncerr(subr,nf90_def_var(ncid,'lon',ncfloat,(/nc1_id,nl1_id/),lon_id))
   call ncerr(subr,nf90_def_var(ncid,'lat',ncfloat,(/nc1_id,nl1_id/),lat_id))
   call ncerr(subr,nf90_def_var(ncid,'na',nf90_int,(/nl1_id/),na_id))
   call ncerr(subr,nf90_def_var(ncid,'larc',nf90_int,(/two_id,namax_id,nl1_id/),larc_id))
   call ncerr(subr,nf90_enddef(ncid))
   call ncerr(subr,nf90_put_var(ncid,nc2_id,sdata%nc2))
   call ncerr(subr,nf90_put_var(ncid,na_id,sdata%na))
   do il1=1,sdata%nl1
      call ncerr(subr,nf90_put_var(ncid,lon_id,sdata%lon(sdata%ic2il1_to_ic0(1:sdata%nc2(il1),il1))*rad2deg,(/1,il1/),(/sdata%nc2(il1),1/)))
      call ncerr(subr,nf90_put_var(ncid,lat_id,sdata%lat(sdata%ic2il1_to_ic0(1:sdata%nc2(il1),il1))*rad2deg,(/1,il1/),(/sdata%nc2(il1),1/)))
      call ncerr(subr,nf90_put_var(ncid,larc_id,sdata%larc(:,1:sdata%na(il1),il1),(/1,1,il1/),(/2,sdata%na(il1),1/)))
   end do
   call ncerr(subr,nf90_close(ncid))
   call model_write(filename,'rh',sdata,rh0*req)
   call model_write(filename,'rv',sdata,rv0)
end if

! Print results
write(mpl%unit,'(a7,a)') '','Global parameters'
write(mpl%unit,'(a10,a,i8)') '','nc0 =       ',sdata%nc0
write(mpl%unit,'(a10,a,i8)') '','nl0 =       ',sdata%nl0
write(mpl%unit,'(a10,a,i8)') '','nc1 =       ',sdata%nc1
write(mpl%unit,'(a10,a,i8)') '','nl1 =       ',sdata%nl1
do il1=1,sdata%nl1
   write(mpl%unit,'(a10,a,i2,a,i8)') '','nc2(',il1,') =   ',sdata%nc2(il1)
end do
write(mpl%unit,'(a10,a,i8)') '','ns =        ',sdata%ns
do il0i=1,sdata%nl0i
   write(mpl%unit,'(a10,a,i2,a,i8)') '','h(',il0i,')%n_s = ',sdata%h(il0i)%n_s
end do
do il0i=1,sdata%nl0i
   write(mpl%unit,'(a10,a,i2,a,i8)') '','v(',il0i,')%n_s = ',sdata%v(il0i)%n_s
end do
do il1=1,sdata%nl1
   write(mpl%unit,'(a10,a,i2,a,i8)') '','s(',il1,')%n_s = ',sdata%s(il1)%n_s
end do
write(mpl%unit,'(a10,a,i8)') '','c%n_s =     ',sdata%c%n_s

end subroutine compute_parameters

!----------------------------------------------------------------------
! Subroutine: compute_grid_mesh
!> Purpose: compute grid mesh
!----------------------------------------------------------------------
subroutine compute_grid_mesh(sdata)

implicit none

! Passed variables
type(sdatatype),intent(inout) :: sdata !< Sampling data

! Local variables
integer :: nc0,lnew,info,ic0,jc0,kc0,i,ibnd,il0
integer :: redundant(sdata%nc0)
integer,allocatable :: order(:),list(:),lptr(:),lend(:),near(:),next(:),ic0_bnd(:,:,:)
real :: latbnd(2),lonbnd(2),v1(3),v2(3)
real,allocatable :: x(:),y(:),z(:),dist(:)
logical :: init

! Look for redundant or masked points
call msi(redundant)
do ic0=1,sdata%nc0
   if (.not.isnotmsi(redundant(ic0))) then
      do jc0=ic0+1,sdata%nc0
         if ((abs(sdata%lon(ic0)-sdata%lon(jc0))<tiny(1.0)).and.(abs(sdata%lat(ic0)-sdata%lat(jc0))<tiny(1.0))) redundant(jc0) = ic0
      end do
   end if
end do
nc0 = count(.not.isnotmsi(redundant))

! Allocation
allocate(order(nc0))
allocate(list(6*(nc0-2)))
allocate(lptr(6*(nc0-2)))
allocate(lend(nc0))
allocate(near(nc0))
allocate(next(nc0))
allocate(x(nc0))
allocate(y(nc0))
allocate(z(nc0))
allocate(dist(nc0))

! Shuffle arrays (more efficient to compute the Delaunay triangulation)
ic0 = 0
do jc0=1,sdata%nc0
   if (.not.isnotmsi(redundant(jc0))) then
      ic0 = ic0+1
      order(ic0) = jc0
   end if
end do
do ic0=nc0,2,-1
   call rand_integer(sdata%rng,1,nc0,jc0)
   kc0 = order(jc0)
   order(jc0) = order(ic0)
   order(ic0) = kc0
end do

! Transform to cartesian coordinates
call trans(nc0,sdata%lat(order),sdata%lon(order),x,y,z)

! Create mesh
list = 0
call trmesh(nc0,x,y,z,list,lptr,lend,lnew,near,next,dist,info)

if (.not.allocated(sdata%grid_nnb)) then
   ! Allocation
   allocate(sdata%grid_nnb(sdata%nc0))

   ! Count neighbors
   sdata%grid_nnb = 0
   do ic0=1,nc0
      i = lend(ic0)
      init = .true.
      do while ((i/=lend(ic0)).or.init)
         sdata%grid_nnb(order(ic0)) = sdata%grid_nnb(order(ic0))+1
         i = lptr(i)
         init = .false.
      end do
   end do

   ! Allocation
   allocate(sdata%grid_inb(maxval(sdata%grid_nnb),sdata%nc0))

   ! Find neighbors
   sdata%grid_nnb = 0
   do ic0=1,nc0
      i = lend(ic0)
      init = .true.
      do while ((i/=lend(ic0)).or.init)
         sdata%grid_nnb(order(ic0)) = sdata%grid_nnb(order(ic0))+1
         sdata%grid_inb(sdata%grid_nnb(order(ic0)),order(ic0)) = order(abs(list(i)))
         i = lptr(i)
         init = .false.
      end do
   end do

   ! Copy neighbors for redudant points
   do ic0=1,sdata%nc0
      if (isnotmsi(redundant(ic0))) then
         sdata%grid_nnb(ic0) = sdata%grid_nnb(redundant(ic0))
         sdata%grid_inb(:,ic0) = sdata%grid_inb(:,redundant(ic0))
      end if
   end do
end if

! Compute distances
allocate(sdata%grid_dnb(maxval(sdata%grid_nnb),sdata%nc0))
do ic0=1,sdata%nc0
   do i=1,sdata%grid_nnb(ic0)
      call sphere_dist(sdata%lon(ic0),sdata%lat(ic0),sdata%lon(sdata%grid_inb(i,ic0)),sdata%lat(sdata%grid_inb(i,ic0)),sdata%grid_dnb(i,ic0))
      sdata%grid_dnb(i,ic0) = (sdata%grid_dnb(i,ic0)/req)**2
   end do
end do

! Allocation
allocate(sdata%nbnd(sdata%nl0))
allocate(ic0_bnd(2,nc0,sdata%nl0))

! Find border points
do il0=1,sdata%nl0
   sdata%nbnd(il0) = 0
   do ic0=1,nc0
      ! Check mask points only
      if (.not.sdata%mask(order(ic0),il0)) then
         i = lend(ic0)
         init = .true.
         do while ((i/=lend(ic0)).or.init)
            jc0 = abs(list(i))
            kc0 = abs(list(lptr(i)))
            if (.not.sdata%mask(order(jc0),il0).and.sdata%mask(order(kc0),il0)) then
               ! Create a new boundary arc
               sdata%nbnd(il0) = sdata%nbnd(il0)+1
               if (sdata%nbnd(il0)>nc0) call msgerror('too many boundary arcs')
               ic0_bnd(1,sdata%nbnd(il0),il0) = order(ic0)
               ic0_bnd(2,sdata%nbnd(il0),il0) = order(jc0)
            end if
            i = lptr(i)
            init = .false.
         end do
      end if
   end do
end do

! Allocation
allocate(sdata%xbnd(2,maxval(sdata%nbnd),sdata%nl0))
allocate(sdata%ybnd(2,maxval(sdata%nbnd),sdata%nl0))
allocate(sdata%zbnd(2,maxval(sdata%nbnd),sdata%nl0))
allocate(sdata%vbnd(3,maxval(sdata%nbnd),sdata%nl0))

do il0=1,sdata%nl0
   ! Compute boundary arcs
   do ibnd=1,sdata%nbnd(il0)
      latbnd = sdata%lat(ic0_bnd(:,ibnd,il0))
      lonbnd = sdata%lon(ic0_bnd(:,ibnd,il0))
      call trans(2,latbnd,lonbnd,sdata%xbnd(:,ibnd,il0),sdata%ybnd(:,ibnd,il0),sdata%zbnd(:,ibnd,il0))
   end do
   do ibnd=1,sdata%nbnd(il0)
      v1 = (/sdata%xbnd(1,ibnd,il0),sdata%ybnd(1,ibnd,il0),sdata%zbnd(1,ibnd,il0)/)
      v2 = (/sdata%xbnd(2,ibnd,il0),sdata%ybnd(2,ibnd,il0),sdata%zbnd(2,ibnd,il0)/)
      call vector_product(v1,v2,sdata%vbnd(:,ibnd,il0))
   end do
end do

end subroutine compute_grid_mesh

!----------------------------------------------------------------------
! Subroutine: compute_subgrid_mesh
!> Purpose: compute subgrid mesh
!----------------------------------------------------------------------
subroutine compute_subgrid_mesh(sdata)

implicit none

! Passed variables
type(sdatatype),intent(inout) :: sdata !< Sampling data

! Local variables
integer :: lnew,info,nt,ia,il1,it,i,i1,i2,ic1,namax
integer,allocatable :: list(:),lptr(:),lend(:),near(:),next(:),ltri(:,:)
real,allocatable :: x(:),y(:),z(:),dist(:)
logical :: init

! Allocation
allocate(list(6*(sdata%nc1-2)))
allocate(lptr(6*(sdata%nc1-2)))
allocate(lend(sdata%nc1))
allocate(near(sdata%nc1))
allocate(next(sdata%nc1))
allocate(x(sdata%nc1))
allocate(y(sdata%nc1))
allocate(z(sdata%nc1))
allocate(dist(sdata%nc1))
allocate(ltri(9,2*(sdata%nc1-2)))

! Transform to cartesian coordinates
call trans(sdata%nc1,sdata%lat(sdata%ic1_to_ic0),sdata%lon(sdata%ic1_to_ic0),x,y,z)

! Create mesh
list = 0
call trmesh(sdata%nc1,x,y,z,list,lptr,lend,lnew,near,next,dist,info)

! Allocation
allocate(sdata%subgrid_nnb(sdata%nc1))

! Count neighbors
sdata%subgrid_nnb = 0
do ic1=1,sdata%nc1
   i = lend(ic1)
   init = .true.
   do while ((i/=lend(ic1)).or.init)
      sdata%subgrid_nnb(ic1) = sdata%subgrid_nnb(ic1)+1
      i = lptr(i)
      init = .false.
   end do
end do

! Allocation
allocate(sdata%subgrid_inb(maxval(sdata%subgrid_nnb),sdata%nc1))
allocate(sdata%subgrid_dnb(maxval(sdata%subgrid_nnb),sdata%nc1))

! Find neighbors
sdata%subgrid_nnb = 0
do ic1=1,sdata%nc1
   i = lend(ic1)
   init = .true.
   do while ((i/=lend(ic1)).or.init)
      sdata%subgrid_nnb(ic1) = sdata%subgrid_nnb(ic1)+1
      sdata%subgrid_inb(sdata%subgrid_nnb(ic1),ic1) = abs(list(i))
      i = lptr(i)
      init = .false.
   end do
end do

! Compute distances
do ic1=1,sdata%nc1
   do i=1,sdata%subgrid_nnb(ic1)
      call sphere_dist(sdata%lon(ic1),sdata%lat(ic1),sdata%lon(sdata%subgrid_inb(i,ic1)),sdata%lat(sdata%subgrid_inb(i,ic1)),sdata%subgrid_dnb(i,ic1))
      sdata%subgrid_dnb(i,ic1) = (sdata%subgrid_dnb(i,ic1)/req)**2
   end do
end do

! Create triangles list
call trlist(sdata%nc1,list,lptr,lend,9,nt,ltri,info)
namax = maxval(ltri(7:9,1:nt))

! Release memory
deallocate(list)
deallocate(lptr)
deallocate(lend)
deallocate(near)
deallocate(next)
deallocate(x)
deallocate(y)
deallocate(z)
deallocate(dist)
deallocate(ltri)

! Initialization
allocate(sdata%na(sdata%nl1))
allocate(sdata%larc(2,namax,sdata%nl1))
call msi(sdata%larc)

do il1=1,sdata%nl1
   ! Allocation
   allocate(list(6*(sdata%nc2(il1)-2)))
   allocate(lptr(6*(sdata%nc2(il1)-2)))
   allocate(lend(sdata%nc2(il1)))
   allocate(near(sdata%nc2(il1)))
   allocate(next(sdata%nc2(il1)))
   allocate(x(sdata%nc2(il1)))
   allocate(y(sdata%nc2(il1)))
   allocate(z(sdata%nc2(il1)))
   allocate(dist(sdata%nc2(il1)))
   allocate(ltri(9,2*(sdata%nc2(il1)-2)))

   ! Transform to cartesian coordinates
   call trans(sdata%nc2(il1),sdata%lat(sdata%ic2il1_to_ic0(1:sdata%nc2(il1),il1)),sdata%lon(sdata%ic2il1_to_ic0(1:sdata%nc2(il1),il1)),x,y,z)

   ! Create mesh
   list = 0
   call trmesh(sdata%nc2(il1),x,y,z,list,lptr,lend,lnew,near,next,dist,info)

   ! Create triangles list
   call trlist(sdata%nc2(il1),list,lptr,lend,9,nt,ltri,info)

   ! Copy arcs list
   sdata%na(il1) = maxval(ltri(7:9,1:nt))
   do ia=1,sdata%na(il1)
      it = 1
      do while (it<=nt)
         if (any(ltri(7:9,it)==ia)) exit
         it = it+1
      end do
      i = 1
      do while (i<=3)
         if (ltri(6+i,it)==ia) exit
         i = i+1
      end do
      i1 = mod(i+1,3)
      if (i1==0) i1 = 3
      i2 = mod(i+2,3)
      if (i2==0) i2 = 3
      sdata%larc(1,ia,il1) = ltri(i1,it)
      sdata%larc(2,ia,il1) = ltri(i2,it)
   end do

   ! Release memory
   deallocate(list)
   deallocate(lptr)
   deallocate(lend)
   deallocate(near)
   deallocate(next)
   deallocate(x)
   deallocate(y)
   deallocate(z)
   deallocate(dist)
   deallocate(ltri)
end do

end subroutine compute_subgrid_mesh

end module module_parameters