c
      subroutine testscale (A,m)
       double precision, intent (in):: A(9)
       double precision::scaled(9)
       double precision:: m
c
       print *,"----------------"
       print *,"Begin Scale Test"
       print *,"----------------"
       print *,"Input Tensor:"
       print *,
       call t2print (A)
       print *,
       print *,"Scale Factor:"
       print "(1e12.4)",m
       print *,
       print *,"Output Tensor:"
       call scale2(A,scaled,m)
       call t2print(scaled)
       print *,
       print *,"----------------"
       print *,"End Scale Test"
       print *,"----------------"
c
      end subroutine testscale
c
      subroutine testtpose (A)
       double precision, intent (in)::A(9)
       double precision::posed(9)
c
       print *,"----------------"
       print *,"Begin TPOSE Test"
       print *,"----------------"
       print *,"Input Tensor:"
       print *,
       call t2print (A)
       print *,
       print *,"Output Tensor:"
       call tpose(A,posed)
       call t2print(posed)
       print *,
       print *,"----------------"
       print *,"End TPOSE Test"
       print *,"----------------"
c
      end subroutine testtpose
c
      subroutine testdet (A)
       double precision, intent(in)::A(9)
       double precision:: det_a
c
       print *,"----------------"
       print *,"Begin DET Test"
       print *,"----------------"
       print *,"Input Tensor:"
       print *,
       call t2print (A)
       print *,
       print *,"Determinant:"
       call det(A,det_A)
       print "(1e12.4)",det_A
       print *,
       print *,"----------------"
       print *,"End DET Test"
       print *,"----------------"
c
      end subroutine testdet
c
      subroutine testinv (A)
c
       double precision, intent(in):: A(9)
       double precision::inverse(9)
c
       print *,"----------------"
       print *,"Begin Invert Test"
       print *,"----------------"
       print *,"Input Tensor:"
       print *,
       call t2print (A)
       print *,
       print *,"Inverse Tensor:"
       call invert(A,inverse)
       call t2print(inverse)
       print *,
       print *,"----------------"
       print *,"End Invert Test"
       print *,"----------------"
c
      end subroutine testinv
c
      subroutine testtc_2s2 (A,B)
c
       double precision, intent(in):: A(9),B(9)
       double precision::C(9)
c
       print *,"----------------"
       print *,"Begin tc_2s2 Test"
       print *,"----------------"
       print *,"Input Tensor A:"
       print *,
       call t2print (A)
       print *,
       print *,"Input Tensor B:"
       print *,
       call t2print (B)
       print *,
       print *,"Output Tensor:"
       call tc_2s2(A,B,C)
       call t2print(C)
       print *,
       print *,"----------------"
       print *,"End tc_2s2 Test"
       print *,"----------------"
c
      end subroutine testtc_2s2
c
      subroutine testtc_2d2 (A,B)
c
       double precision, intent(in):: A(9),B(9)
       double precision::c
c
       print *,"----------------"
       print *,"Begin tc_2d2 Test"
       print *,"----------------"
       print *,"Input Tensor A:"
       print *,
       call t2print (A)
       print *,
       print *,"Input Tensor B:"
       print *,
       call t2print (B)
       print *,
       print *,"Output:"
       call tc_2d2(A,B,c)
       print "(1e12.4)",c
       print *,
       print *,"----------------"
       print *,"End tc_2d2 Test"
       print *,"----------------"
c
      end subroutine testtc_2d2
c
      subroutine testtc_4d4 (A,B)
c
       double precision, intent(in):: A(9,9),B(9,9)
       double precision:: C(9,9)
c
       print *,"----------------"
       print *,"Begin tc_4d4 Test"
       print *,"----------------"
       print *,"Input Tensor A:"
       print *,
       call t4print (A)
       print *,
       print *,"Input Tensor B:"
       print *,
       call t4print (B)
       print *,
       print *,"Output:"
       call tc_4d4(A,B,C)
       print *,
       call t4print (C)
       print *,
       print *,"----------------"
       print *,"End tc_4d4 Test"
       print *,"----------------"
c
      end subroutine testtc_4d4
c
      subroutine testinvariants (A)
c
       double precision :: A(9)
       double precision :: x
c
       print *,"----------------"
       print *,"Begin I,J test"
       print *,"----------------"
c
       print *, "Input tensor:"
       print *,
       call t2print(A)
       print *,
       print *,"I1:"
       call I1(A,x)
       print "(1e12.4)",x
       print *,
c
       print *,
       print *,"I2:"
       call I2(A,x)
       print "(1e12.4)",x
       print *,
c
       print *,
       print *,"I3:"
       call I3(A,x)
       print "(1e12.4)",x
       print *,
c
       print *,
       print *,"J1:"
       call J1(A,x)
       print "(1e12.4)",x
       print *,
c
       print *,
       print *,"J2:"
       call J2(A,x)
       print "(1e12.4)",x
       print *,
c
       print *,
       print *,"J3:"
       call J3(A,x)
       print "(1e12.4)",x
       print *,
c
       print *,
       print *,"----------------"
       print *,"End I,J test"
       print *,"----------------"
       print *,
c
      end subroutine testinvariants
c
      subroutine testzrotation (A,de)
c
       double precision, intent (in) :: A(9)
       double precision :: B(9),Q(9)
       double precision :: de,th,pi
c
c     I don't think there's a pi constant
c     in FORTRAN...
c
       pi = 4*atan(1.0_8)
       th = pi*de/180.0_8
c
       print *,"----------------"
       print *,"Start rot test"
       print *,"----------------"
       print *,
       print *,"Input Tensor: "
       print *,
       call t2print (A)
       print *,
       print *,"Input Angle:"
       print "(1e12.4)",de
       print *,
       print *,"Rotated Tensor:"
       print *,
       call qzrad (th,Q)
       call transform2 (A,Q,B)
       call t2print (B)
       print *,
       print *,"----------------"
       print *,"End rot test"
       print *,"----------------"
       return
c
      end subroutine testzrotation
c
      subroutine testIDN (A)
c
       double precision :: A(9),I4(9,9),B(9)
c
       print *,
       print *,"----------------"
       print *,"Start IDN test"
       print *,"----------------"
       print *,
       print *,"Input Tensor:"
       print *,
       call t2print(A)
       print *,
       print *,"Output Tensor (IDN4):"
       print *,
       call IDN4 (I4)
       call tc_4d2(I4,A,B)
       call t2print(B)
       print *,
       print *,"Output Tensor (SYM4):"
       print *,
       call SYM4 (I4)
       call tc_4d2(I4,A,B)
       call t2print(B)
       print *,
       print *,"Output Tensor (ANT4):"
       print *,
       call ANT4 (I4)
       call tc_4d2(I4,A,B)
       call t2print(B)
       print *,
       print *,"Output Tensor (VOL4):"
       print *,
       call VOL4 (I4)
       call tc_4d2(I4,A,B)
       call t2print(B)
       print *,
       print *,"Output Tensor (DEV4):"
       print *,
       call DEV4 (I4)
       call tc_4d2(I4,A,B)
       call t2print(B)
       print *,
       print *,"----------------"
       print *,"End IDN test"
       print *,"----------------"
c
       return
c
      end subroutine testIDN
c
      subroutine testvonMises (A)
c
       double precision, intent (in) :: A(9)
       double precision :: vm
c
       print *,
       print *,"----------------"
       print *,"Start VM test"
       print *,"----------------"
       print *,
       print *,"Input Tensor:"
       print *,
       call t2print(A)
       print *,
c       call SEQ(A,vm)
       print *,
       print *,"von Mises:"
       print *,
c       print "(1e12.4)",vm
       call VMS(A,vm)
       print *,vm
       print *,
       print *,"----------------"
       print *,"End VM test"
       print *,"----------------"
c
       return
c
      end subroutine testvonMises
c
c
        subroutine testCH (A)
c
         double precision, intent (in) :: A(9)
         double precision :: B(9)
         double precision :: I1A,I2A,I3A
         double precision :: I1B,I2B,I3B
c
         call CH (A,B)
         call I1 (A,I1A)
         call I2 (A,I2A)
         call I3 (A,I3A)
         call I1 (B,I1B)
         call I2 (B,I2B)
         call I3 (B,I3B)
         print *,"----------------"
         print *,"Begin CH test"
         print *,"----------------"
         print *,"Input Tensor:"
         print *,
         call t2print (A)
         print *,
         print *,"Principal Values:"
         print *,
         call t2print (B)
         print *,
         print *,"1st Invariant (should be equal)"
         print *,
         print "(2e12.4)",I1A,I1B
         print *,
         print *,
         print *,"2nd Invariant (should be equal)"
         print *,
         print "(2e12.4)",I2A,I2B
         print *,
         print *,
         print *,"3rd Invariant (should be equal)"
         print *,
         print "(2e12.4)",I3A,I3B
         print *,
         print *,"----------------"
         print *,"End CH test"
         print *,"----------------"
c
        end subroutine testCH
c
        subroutine testPD (F)
c
         double precision, intent (in) :: F(9)
         double precision :: R(9),U(9),V(9),C1(9),C2(9)
         call PD (F,R,U,V)
         call tc_2s2(R,U,C1)
         C1 = F-C1
         call tc_2s2(V,R,C2)
         C2 = F-C2
         print *,"----------------"
         print *,"Begin DECOMP test"
         print *,"----------------"
         print *,"Input Tensor:"
         print *,
         call t2print (F)
         print *,
         print *,"R:"
         print *,
         call t2print (R)
         print *,
         print *,"U:"
         print *,
         call t2print (U)
         print *,
         print *,"V:"
         print *,
         call t2print (V)
         print *,
         print *,"C1 (should be zero):"
         print *,
         call t2print (C1)
         print *,
         print *,"C2 (should be zero):"
         print *,
         call t2print (C2)
         print *,"----------------"
         print *,"End DECOMP test"
         print *,"----------------"
c
        end subroutine testPD
c


! Evaluation of standard validation indicators on some types of differences along a transect.
!
! This program is part of the pbl-compare project, and is covered by the MIT license.
!
! Author: Patrizia Favaron

program GenerateIndicators

    use pbl_compare

    implicit none

    ! Constants
    integer, parameter  :: N_VARS   =     7
    integer, parameter  :: N_CASES  =     4
    integer, parameter  :: N        =    64

    ! Locals
    integer                             :: iRetCode
    integer                             :: iVariant
    integer                             :: iCase
    real                                :: rValue
    real, dimension(N_VARS)             :: rvVariantValue
    real, dimension(N, N_CASES)         :: rmPrimarySet
    real, dimension(N, N_CASES)         :: rmSecondarySet
    real, dimension(N_VARS, N_CASES)    :: rmFB
    real, dimension(N_VARS, N_CASES)    :: rmNMSE
    real, dimension(N_VARS, N_CASES)    :: rmMG
    real, dimension(N_VARS, N_CASES)    :: rmVG
    real, dimension(N_VARS, N_CASES)    :: rmFAC2
    real, dimension(N_VARS, N_CASES)    :: rmNAD
    type(CompareType)                   :: tCmp
    real                                :: rDs
    real                                :: rH
    integer                             :: i

    do iVariant = 0, N_VARS - 1

        !do iCase = 1, N_CASES
        do iCase = 1, 4

            select case(iCase)

            case(1)

                ! First case: Single peak of growing size
                rmPrimarySet(:,iCase)   = 1.
                rmSecondarySet(:,iCase) = rmPrimarySet(:,iCase)
                if(iVariant > 0) then
                    rDs = (iVariant + 1) * 100.
                    rmSecondarySet(1, iCase)  = rDs
                else
                    rDs = 1.
                end if
                rvVariantValue(iVariant+1) = rDs

            case(2)

                ! Second case: Heaviside doublets
                if(iVariant > 0) then
                    rH = (iVariant + 1) * 100.
                else
                    rH = 1.
                end if
                rvVariantValue(iVariant+1) = rH
                rmPrimarySet(:,iCase)   = rH * Case2(N, N/4 - N/8 - 1, N/4 + N/8 - 1)
                rmSecondarySet(:,iCase) = rH * Case2(N, N/2 + N/4 - N/8 - 1, N/2 + N/4 + N/8 - 1)

            case(3)

                ! Third case: dilated Gaussian
                if(iVariant > 0) then
                    rDs = (iVariant + 1) * 100.
                else
                    rDs = 1.
                end if
                rvVariantValue(iVariant+1) = rDs
                rmPrimarySet(:,iCase)   = TinyGaussian(N)
                rmSecondarySet(:,iCase) = rDs * rmPrimarySet(:,iCase)

            case(4)

                ! Fourth case: translated Gaussian
                if(iVariant > 0) then
                    rDs = (iVariant + 1) * 100.
                else
                    rDs = 0.
                end if
                rvVariantValue(iVariant+1) = rDs
                rmPrimarySet(:,iCase)   = TinyGaussian(N)
                rmSecondarySet(:,iCase) = rmPrimarySet(:,iCase) + rDs

            end select

            ! Initialize new value, then compute indices based on it
            iRetCode = tCmp % Set(rmPrimarySet(:,iCase), rmSecondarySet(:,iCase))
            if(iRetCode /= 0) then
                print *, "error: Comparison data sets initialization failure - Ret code = ", iRetCode
                stop
            end if
            rmFB(iVariant+1, iCase)   = tCmp % FB()
            rmNMSE(iVariant+1, iCase) = tCmp % NMSE()
            rmMG(iVariant+1, iCase)   = tCmp % MG()
            rmVG(iVariant+1, iCase)   = tCmp % VG()
            rmFAC2(iVariant+1, iCase) = tCmp % FAC2()
            rmNAD(iVariant+1, iCase)  = tCmp % NAD()

        end do

    end do

    ! Print results for the various cases
    ! -1- Case 1
    open(10, file="Indices_1.csv", status="unknown", action="write")
    write(10, "('Variant, Value, FB, NMSE, MG, VG, FAC2, NAD')")
    do i=1,N_VARS
        write(10, "(i1,',',f5.1,6(',',f11.5))") &
            i-1, rvVariantValue(i), rmFB(i,1), rmNMSE(i,1), rmMG(i,1), rmVG(i,1), rmFAC2(i,1), rmNAD(i,1)
    end do
    close(10)
    ! -1- Case 2
    open(10, file="Indices_2.csv", status="unknown", action="write")
    write(10, "('Variant, Value, FB, NMSE, MG, VG, FAC2, NAD')")
    do i=1,N_VARS
        write(10, "(i1,',',f5.1,6(',',f11.5))") &
            i-1, rvVariantValue(i), rmFB(i,2), rmNMSE(i,2), rmMG(i,2), rmVG(i,2), rmFAC2(i,2), rmNAD(i,2)
    end do
    close(10)
    ! -1- Case 3
    open(10, file="Indices_3.csv", status="unknown", action="write")
    write(10, "('Variant, Value, FB, NMSE, MG, VG, FAC2, NAD')")
    do i=1,N_VARS
        write(10, "(i1,',',f5.1,6(',',f11.5))") &
            i-1, rvVariantValue(i), rmFB(i,3), rmNMSE(i,3), rmMG(i,3), rmVG(i,3), rmFAC2(i,3), rmNAD(i,3)
    end do
    close(10)
    ! -1- Case 4
    open(10, file="Indices_4.csv", status="unknown", action="write")
    write(10, "('Variant, Value, FB, NMSE, MG, VG, FAC2, NAD')")
    do i=1,N_VARS
        write(10, "(i1,',',f5.1,6(',',f11.5))") &
            i-1, rvVariantValue(i), rmFB(i,4), rmNMSE(i,4), rmMG(i,4), rmVG(i,4), rmFAC2(i,4), rmNAD(i,4)
    end do
    close(10)

    print *, '*** End Job ***'

contains

    function Case2(n, n_min, n_max) result(rvCase2)

        ! Routine arguments
        integer, intent(in)             :: n
        integer, intent(in)             :: n_min
        integer, intent(in)             :: n_max
        real, dimension(n)              :: rvCase2

        ! Locals
        integer :: i

        ! Generate the information desired
        rvCase2 = 0.
        do i = 1, n
            if(i >= n_min .and. i <= n_max) then
                rvCase2(i) = 1.
            end if
        end do

    end function Case2

    function TinyGaussian(n) result(rvGauss)

        ! Routine arguments
        integer, intent(in)             :: n
        real, dimension(n)              :: rvGauss

        ! Locals
        integer :: i

        ! Compute the information desired
        rvGauss = exp(-50.*[((i-n/2)**2,i=1,n)]/n**2)

    end function TinyGaussian

end program GenerateIndicators


c     program DRSACCUM
c>> 1996-06-18 DRSACCUM Krogh Special code for C conversion.
c>> 1996-05-28 DRSACCUM Krogh Added external state. & moved up formats
c>> 1995-09-15 DRSACCUM Krogh Remove '0' in format (again?)
c>> 1994-10-19 DRSACCUM Krogh  Changes to use M77CON
c>> 1994-08-09 DRSACCUM WVS Removed '0' in formats
c>> 1991-11-20 DRSACCUM CLL Edited for Fortran 90.
c>> 1987-12-09 DRSACCUM Lawson  Initial Code.
c     Demonstration driver for SACCUM.
c--S replaces "?": DR?ACCUM, ?ACCUM, ?HFTI, ?COPY, ?MPVAL
c     ------------------------------------------------------------------
      external SMPVAL
      real             SMPVAL
      integer NMAX, LDIM, LPMAX, NB, MDATA
      parameter(NMAX = 8, LDIM = NMAX + 2, NB = 1, MDATA = 12)
      parameter(LPMAX = NMAX + 2)
      real             X(MDATA),Y(MDATA),P(LPMAX)
      real             A(LDIM,NMAX),B(LDIM)
      real             RNORM(NB), WORK(NMAX)
      real             DOF, R, SIGFAC, TAU, U, YFIT
      integer I, IP(NMAX), IR1, IROW, J, KRANK, N, NCOUNT, NDEG, NROWS
      parameter(TAU = 1.0E-5)
c     ------------------------------------------------------------------
      data X / 2.0E0,  4.0E0,  6.0E0,  8.0E0,  10.0E0,  12.0E0,
     *        14.0E0, 16.0E0, 18.0E0, 20.0E0,  22.0E0,  24.0E0/
      data Y / 2.2E0,  4.0E0,  5.0E0,  4.6E0,  2.8E0,    2.7E0,
     *         3.8E0,  5.1E0,  6.1E0,  6.3E0,  5.0E0,    2.0E0/
      data P(1), P(2) / 13.0E0, 11.0E0 /
c
c     ------------------------------------------------------------------
      N = NMAX
      NDEG = N - 1
      IR1 = 1
      NROWS = 1
c
      do 20 IROW = 1,MDATA
        U = (X(IROW)-P(1)) / P(2)
        I = IR1
        A(I,1) = 1.
        do 10 J = 2, NDEG+1
            A(I,J) = A(I,J-1)*U
   10   continue
        B(I) = Y(IROW)
        call SACCUM(A, LDIM, N, B, LDIM, NB, IR1, NROWS, NCOUNT)
   20 continue
c
      print*,'DRSACCUM..  Demo driver for SACCUM.'
      print '(1x,a,i4,a,i4)','MDATA = ',MDATA,', NCOUNT = ',NCOUNT
      call SHFTI(A,LDIM,IR1-1,N,B,LDIM,NB,TAU,KRANK,RNORM,WORK,IP)
      print '(1x,a,I4)','KRANK = ',KRANK
c
c                      The following stmt does a type conversion.
      DOF = NCOUNT - N
      SIGFAC = RNORM(1) / sqrt(DOF)
      call SCOPY(N, B, 1, P(3), 1)
c++ Code for .C. is inactive
c%%   printf(
c%%      "\n NDEG =%2ld          RNORM =%8.4f          SIGFAC =%8.4f",
c%%       ndeg, Rnorm[1], sigfac );
c%%   printf(
c%%   "\n\n P(1),P(2) =         %15.5f%15.5f\n\n P(3),...,P(NDEG+3) =",
c%%   p[0], p[1]);
c%%   for (i = 2; i < (n + 2); i+=3){
c%%      for (j = i; j <= (i < n ? i+2 : n+1); j++)
c%%           printf("%15.5f", p[j] );
c%%           if (i < n-1) printf("\n                     ");}
c%%   printf( "\n" );
c++ Code for ~.C. is active
      print
     *'(/'' NDEG ='',I2,10X,''RNORM ='',F8.4,10X,''SIGFAC ='',F8.4//
     *'' P(1),P(2) ='',9X,2F15.5//'' P(3),...,P(NDEG+3) ='',3F15.5/
     *(21X,3F15.5))', NDEG,RNORM(1),SIGFAC,(P(I),I=1,N+2)
c++ End
      print '(1X/''  I    X       Y       YFIT  R=Y-YFIT''/1X)'
      do 30 I=1,MDATA
        YFIT=SMPVAL(P,NDEG,X(I))
        R=Y(I)-YFIT
        print '(1X,I2,F6.0,2F9.3,F10.3)', I,X(I),Y(I),YFIT,R
   30 continue
      stop
c
      end


! ------------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2021, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! Example problem:
!
! The following test simulates a brusselator problem from chemical
! kinetics.  This is a PDE system with 3 components, Y = [u,v,w],
! satisfying the equations,
!    u_t = du*u_xx + a - (w+1)*u + v*u^2
!    v_t = dv*v_xx + w*u - v*u^2
!    w_t = dw*w_xx + (b-w)/ep - w*u
! for t in [0, 80], x in [0, 1], with initial conditions
!    u(0,x) =  a  + 0.1*sin(pi*x)
!    v(0,x) = b/a + 0.1*sin(pi*x)
!    w(0,x) =  b  + 0.1*sin(pi*x),
! and with stationary boundary conditions, i.e.
!    u_t(t,0) = u_t(t,1) = 0,
!    v_t(t,0) = v_t(t,1) = 0,
!    w_t(t,0) = w_t(t,1) = 0.
!
! The spatial derivatives are computed using second-order
! centered differences, with the data distributed over N points
! on a uniform spatial grid.
!
! This program solves the problem with the DIRK method, using a
! Newton iteration with a custom linear solver module, and that
! uses the custom fnvector_fortran_mod vector module.
!
! 100 outputs are printed at equal intervals, and run statistics
! are printed at the end.
! ------------------------------------------------------------------

module ode_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none
  integer(c_long), parameter :: N = 201         ! number of intervals
  integer(c_long), parameter :: Nt = 100        ! total number of output times
  integer(c_long), parameter :: Nvar = 3        ! number of solution fields
  integer(c_long), parameter :: neq = N*Nvar    ! total size of solution vector
  real(c_double),  parameter :: dx = 1.d0/(N-1) ! mesh spacing
  real(c_double),  parameter :: a = 0.6d0       ! constant forcing on u
  real(c_double),  parameter :: b = 2.d0        ! steady-state value of w
  real(c_double),  parameter :: du = 0.001d0    ! diffusion coeff for u
  real(c_double),  parameter :: dv = 0.001d0    ! diffusion coeff for v
  real(c_double),  parameter :: dw = 0.001d0    ! diffusion coeff for w
  real(c_double),  parameter :: ep = 1.d-5      ! stiffness parameter
  real(c_double),  parameter :: T0 = 0.d0       ! initial time
  real(c_double),  parameter :: Tf = 10.d0      ! final time
  real(c_double),  parameter :: reltol = 1.d-6  ! solver tolerances
  real(c_double),  parameter :: abstol = 1.d-10

contains

  ! ----------------------------------------------------------------
  ! RhsImplicit provides the right hand side function for the
  ! implicit portion of the ODE: dy/dt = fi(t,y) + fe(t,y).  Here,
  ! this contains only the 'reaction' components of the problem.
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function RhsImplicit(tn, sunvec_y, sunvec_f, user_data) &
       result(ierr) bind(C,name='RhsImplicit')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fnvector_fortran_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn  ! current time
    type(N_Vector) :: sunvec_y   ! solution N_Vector
    type(N_Vector) :: sunvec_f   ! rhs N_Vector
    type(c_ptr)    :: user_data  ! user-defined data

    ! local variables
    type(FVec), pointer :: y, f  ! ptrs to Fortran vector data
    real(c_double)      :: u, v, w
    integer(c_long)     :: i

    !======= Internals ============

    ! extract Fortran vector structures to work with
    call c_f_pointer(sunvec_y%content, y)
    call c_f_pointer(sunvec_f%content, f)

    ! iterate over domain, computing all equations
    do i = 2,N-1

       ! set solution variable shortcuts
       u  = y%data(1,i)
       v  = y%data(2,i)
       w  = y%data(3,i)

       ! Fill in ODE RHS for u
       f%data(1,i) = a - (w+1.d0)*u + v*u*u

       ! Fill in ODE RHS for v
       f%data(2,i) = w*u - v*u*u

       ! Fill in ODE RHS for w
       f%data(3,i) = (b-w)/ep - w*u

    end do

    ! enforce stationary boundary conditions
    f%data(:,1) = 0.d0
    f%data(:,N) = 0.d0

    ! return success
    ierr = 0

  end function RhsImplicit

  ! ----------------------------------------------------------------
  ! RhsExplicit provides the right hand side function for the
  ! explicit portion of the ODE: dy/dt = fi(t,y) + fe(t,y).  Here,
  ! this contains only the 'diffusion' components of the problem.
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function RhsExplicit(tn, sunvec_y, sunvec_f, user_data) &
       result(ierr) bind(C,name='RhsExplicit')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fnvector_fortran_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn  ! current time
    type(N_Vector) :: sunvec_y   ! solution N_Vector
    type(N_Vector) :: sunvec_f   ! rhs N_Vector
    type(c_ptr) :: user_data     ! user-defined data

    ! local variables
    type(FVec), pointer :: y, f  ! ptrs to Fortran vector data
    real(c_double)  :: dconst(3)
    integer(c_long) :: i, j

    !======= Internals ============

    ! extract Fortran vector structures to work with
    call c_f_pointer(sunvec_y%content, y)
    call c_f_pointer(sunvec_f%content, f)

    ! set shortcut variables
    dconst = (/ du/dx/dx, dv/dx/dx, dw/dx/dx /)

    ! Fill in diffusion RHS for each species
    do j = 2,N-1
       do i = 1,Nvar
          f%data(i,j) = (y%data(i,j-1) + y%data(i,j+1) - 2.d0*y%data(i,j))*dconst(i)
       end do
    end do

    ! enforce stationary boundary conditions
    f%data(:,1) = 0.d0
    f%data(:,N) = 0.d0

    ! return success
    ierr = 0

  end function RhsExplicit

  ! ----------------------------------------------------------------
  ! JacFn provides the Jacobian construction function for the
  ! implicit portion of the ODE: J = dfi/dy
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, &
       user_data, sunvec_t1, sunvec_t2, sunvec_t3) &
       result(ierr) bind(C,name='JacFn')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsunmatrix_fortran_mod
    use fnvector_fortran_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn  ! current time
    type(N_Vector)  :: sunvec_y  ! solution N_Vector
    type(N_Vector)  :: sunvec_f  ! rhs N_Vector
    type(SUNMatrix) :: sunmat_J  ! Jacobian matrix
    type(c_ptr)     :: user_data ! user-defined data
    type(N_Vector)  :: sunvec_t1  ! temporary N_Vectors
    type(N_Vector)  :: sunvec_t2
    type(N_Vector)  :: sunvec_t3

    ! local variables
    type(FVec), pointer :: y, f  ! ptrs to Fortran vector data
    type(FMat), pointer :: J     ! ptr to Fortran matrix data
    real(c_double)      :: u, v, w
    integer(c_long)     :: i

    !======= Internals ============

    ! extract Fortran vector and matrix structures to work with
    call c_f_pointer(sunvec_y%content, y)
    call c_f_pointer(sunvec_f%content, f)
    call c_f_pointer(sunmat_J%content, J)

    ! iterate over domain, computing all Jacobian entries
    do i = 2,N-1

       ! set solution variable shortcuts
       u  = y%data(1,i)
       v  = y%data(2,i)
       w  = y%data(3,i)

       ! Fill in Jacobian of all variables wrt u
       J%data(:,1,i) = (/ 2.d0*v*u - (w+1.d0), w - 2.d0*v*u, -w /)

       ! Fill in Jacobian of all variables wrt v
       J%data(:,2,i) = (/ u*u, -u*u, 0.d0 /)

       ! Fill in Jacobian of all variables wrt w
       J%data(:,3,i) = (/ -u, u, -1.d0/ep - u/)

    end do

    ! stationary boundary conditions
    J%data(:,:,1) = 0.d0
    J%data(:,:,N) = 0.d0

    ! return success
    ierr = 0

  end function JacFn

end module ode_mod

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use fsundials_context_mod
  use farkode_mod                ! Fortran interface to the ARKode module
  use farkode_arkstep_mod        ! Fortran interface to the ARKStep module
  use fnvector_fortran_mod       ! Custom Fortran N_Vector
  use fsunmatrix_fortran_mod     ! Custom Fortran SUNMatrix
  use fsunlinsol_fortran_mod     ! Custom Fortran SUNLinearSolver
  use ode_mod                    ! ODE functions

  !======= Declarations =========
  implicit none

  ! local variables
  integer(c_int) :: ierr, iout, i
  real(c_double) :: pi, tcur(1), dTout, tout

  type(c_ptr)                    :: sunctx        ! sundials context for the simulation
  type(N_Vector),        pointer :: sunvec_y      ! sundials vector
  type(SUNMatrix),       pointer :: sunmat_A      ! sundials matrix
  type(SUNLinearSolver), pointer :: sunls         ! sundials linear solver
  type(c_ptr)                    :: arkode_mem    ! ARKODE memory

  ! solution vector, N and Nvar are set in the ode_mod moduel
  real(c_double) :: y(Nvar,N)

  !======= Internals ============

  ! initial problem output
  print *, "  "
  print *, "1D Brusselator PDE test problem (F2003 with custom data structures):"
  print '(a,i5,a,i5)', "    N = ", N, ",  NEQ = ", neq
  print '(3(a,es9.2))', "    problem parameters:  a = ", a, ",  b = ", b, ",  ep = ", ep
  print '(3(a,es10.3))', "    diffusion coefficients:  du = ",du,",  dv = ",dv,",  dw = ",dw
  print '(2(a,es8.1))', "    reltol = ",reltol,",  abstol = ",abstol

  ! create the SUNDIALS context for the simulation
  ierr = FSUNContext_Create(c_null_ptr, sunctx)
  if (ierr /= 0) then
    write(*,*) 'Error in FSUNContext_Create'
    stop 1
  end if

  ! initialize SUNDIALS solution vector
  sunvec_y => FN_VMake_Fortran(Nvar, N, y, sunctx)
  if (.not. associated(sunvec_y)) then
    write(*,*) 'ERROR: sunvec = NULL'
    stop 1
  end if

  ! Set initial conditions into y
  pi = 4.d0*datan(1.d0)
  do i = 1,N
    y(1,i) =  a  + 0.1d0*sin(pi*i*dx)  ! u
    y(2,i) = b/a + 0.1d0*sin(pi*i*dx)  ! v
    y(3,i) =  b  + 0.1d0*sin(pi*i*dx)  ! w
  end do

  ! create ARKStep memory
  arkode_mem = FARKStepCreate(c_funloc(RhsExplicit), c_funloc(RhsImplicit), T0, sunvec_y, sunctx)
  if (.not. c_associated(arkode_mem)) then
     print *,'ERROR: arkode_mem = NULL'
     stop 1
  end if

  ! set routines
  ierr = FARKStepSStolerances(arkode_mem, reltol, abstol)
  if (ierr /= 0) then
    write(*,*) 'Error in FARKStepSStolerances'
    stop 1
  end if

  ! initialize custom matrix data structure and solver; attach to ARKStep
  sunmat_A => FSUNMatNew_Fortran(Nvar, N, sunctx)
  if (.not. associated(sunmat_A)) then
     print *,'ERROR: sunmat = NULL'
     stop 1
  end if

  sunls => FSUNLinSolNew_Fortran(Nvar, N, sunctx)
  if (.not. associated(sunls)) then
     print *,'ERROR: sunls = NULL'
     stop 1
  end if

  ! Attach matrix, linear solver, and Jacobian routine to linear solver interface
  ierr = FARKStepSetLinearSolver(arkode_mem, sunls, sunmat_A)
  if (ierr /= 0) then
    write(*,*) 'Error in FARKStepSetLinearSolver'
    stop 1
  end if

  ierr = FARKStepSetJacFn(arkode_mem, c_funloc(JacFn))
  if (ierr /= 0) then
    write(*,*) 'Error in FARKStepSetJacFn'
    stop 1
  end if

  ! main time-stepping loop: calls FARKStepEvolve to perform the integration, then
  ! prints results.  Stops when the final time has been reached
  tcur(1) = T0
  dTout = (Tf-T0)/Nt
  tout = T0+dTout
  print *, "        t      ||u||_rms   ||v||_rms   ||w||_rms"
  print *, "   ----------------------------------------------"
  do iout = 1,Nt

     ! call integrator
     ierr = FARKStepEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL)
     if (ierr /= 0) then
        write(*,*) 'Error in FARKStepEvolve, ierr = ', ierr, '; halting'
        stop 1
     endif

     ! access/print solution statistics
     print '(4(2x,f10.6))', tcur(1), dsqrt(sum(y(1,:)**2)/N), &
          dsqrt(sum(y(2,:)**2)/N), dsqrt(sum(y(3,:)**2)/N)

     ! update output time
     tout = min(tout + dTout, Tf)

  end do
  print *, "   ----------------------------------------------"

  ! diagnostics output
  call ARKStepStats(arkode_mem)

  ! clean up
  call FARKStepFree(arkode_mem)
  call FN_VDestroy(sunvec_y)
  call FSUNMatDestroy(sunmat_A)
  ierr = FSUNLinSolFree(sunls)
  ierr = FSUNContext_Free(sunctx)

end program main

! ----------------------------------------------------------------
! ARKStepStats
!
! Print ARKODE statstics to standard out
! ----------------------------------------------------------------
subroutine ARKStepStats(arkode_mem)

  !======= Inclusions ===========
  use iso_c_binding
  use farkode_mod
  use farkode_arkstep_mod

  !======= Declarations =========
  implicit none

  type(c_ptr), intent(in) :: arkode_mem ! solver memory structure

  integer(c_int)  :: ierr ! error flag

  integer(c_long) :: nsteps(1)     ! num steps
  integer(c_long) :: nst_a(1)      ! num steps attempted
  integer(c_long) :: nfe(1)        ! num explicit function evals
  integer(c_long) :: nfi(1)        ! num implicit function evals
  integer(c_long) :: nfeLS(1)      ! num RHS evals to setup linear solver
  integer(c_long) :: nlinsetups(1) ! num linear solver setups
  integer(c_long) :: nje(1)        ! num Jacobian evaluations
  integer(c_long) :: netfails(1)   ! num error test fails
  integer(c_long) :: nniters(1)    ! nonlinear solver iterations
  integer(c_long) :: nncfails(1)   ! nonlinear solver fails
  integer(c_long) :: njacevals(1)  ! number of Jacobian evaluations

  !======= Internals ============

  ierr = FARKStepGetNumSteps(arkode_mem, nsteps)
  ierr = FARKStepGetNumStepAttempts(arkode_mem, nst_a)
  ierr = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi)
  ierr = FARKStepGetNumLinRhsEvals(arkode_mem, nfeLS)
  ierr = FARKStepGetNumLinSolvSetups(arkode_mem, nlinsetups)
  ierr = FARKStepGetNumJacEvals(arkode_mem, nje)
  ierr = FARKStepGetNumErrTestFails(arkode_mem, netfails)
  ierr = FARKStepGetNumNonlinSolvIters(arkode_mem, nniters)
  ierr = FARKStepGetNumNonlinSolvConvFails(arkode_mem, nncfails)
  ierr = FARKStepGetNumJacEvals(arkode_mem, njacevals)

  print *, ' '
  print *, 'Final Solver Statistics:'
  print '(4x,2(A,i9),A)' ,'Internal solver steps = ',nsteps(1),', (attempted = ',nst_a(1),')'
  print '(4x,2(A,i9))'   ,'Total RHS evals: Fe = ',nfe(1),',  Fi = ',nfi(1)
  print '(4x,A,i9)'      ,'Total linear solver setups    =',nlinsetups(1)
  print '(4x,A,i9)'      ,'Total RHS evals for setting up the linear system =',nfeLS(1)
  print '(4x,A,i9)'      ,'Total number of Jacobian evaluations =',nje(1)
  print '(4x,A,i9)'      ,'Total number of Newton iterations =',nniters(1)
  print '(4x,A,i9)'      ,'Total number of nonlinear solver convergence failures =',nncfails(1)
  print '(4x,A,i9)'      ,'Total number of error test failures =',netfails(1)
  print *, ' '

  return

end subroutine ARKStepStats


module integration

  use bl_types
  implicit none

  real(kind=dp_t), allocatable :: gauss_legendre_5pt_xk(:)
  real(kind=dp_t), allocatable :: gauss_legendre_5pt_wk(:)
  !$acc declare create(gauss_legendre_5pt_xk, gauss_legendre_5pt_wk)
  real(kind=dp_t), allocatable :: gauss_laguerre_5pt_xk(:)
  real(kind=dp_t), allocatable :: gauss_laguerre_5pt_wk(:)
  !$acc declare create(gauss_laguerre_5pt_xk, gauss_laguerre_5pt_wk)

  contains
    subroutine integration_init()
      use bl_types
      implicit none

      allocate(gauss_legendre_5pt_xk(5))
      gauss_legendre_5pt_xk = (/ &
        -0.906179845938664d0, &
        -0.538469310105683d0, &
        0.0d0, &
        0.538469310105683d0, &
        0.906179845938664d0 /)
      allocate(gauss_legendre_5pt_wk(5))
      gauss_legendre_5pt_wk = (/ &
        0.236926885056189d0, &
        0.478628670499366d0, &
        0.568888888888889d0, &
        0.478628670499366d0, &
        0.236926885056189d0 /)
      !$acc update device(gauss_legendre_5pt_xk, gauss_legendre_5pt_wk)
      allocate(gauss_laguerre_5pt_xk(5))
      gauss_laguerre_5pt_xk = (/ &
        0.263560319718141d0, &
        0.141340305910652d1, &
        0.359642577104072d1, &
        0.708581000585884d1, &
        0.126408008442758d2 /)
      allocate(gauss_laguerre_5pt_wk(5))
      gauss_laguerre_5pt_wk = (/ &
        0.521755610582809d0, &
        0.398666811083176d0, &
        0.759424496817076d-1, &
        0.361175867992205d-2, &
        0.233699723857762d-4 /)
      !$acc update device(gauss_laguerre_5pt_xk, gauss_laguerre_5pt_wk)
    end subroutine integration_init

end module integration


MODULE CONSTANTS
   use, intrinsic :: iso_fortran_env, dp=>real64 !define the size of our double precision numbers
   REAL(dp), parameter :: C  = 2.99792458D+10 !Speed of light in cgs
   REAL(dp), PARAMETER :: K_BOLTZ = 1.38065040D-16 ! Boltzmann constant cgs
   REAL(dp), PARAMETER :: HP = 6.62606896D-27 !Planck constant in cgs
   REAL(dp), PARAMETER :: REDUCED_PLANCK=1.054571628d-27
   REAL(dp), PARAMETER :: MH = 1.67262164D-24 !H nucleus mass in cgs
   REAL(dp), PARAMETER :: AMU=1.66053892d-24 !atomic mass unit in cgs
   REAL(dp), PARAMETER :: PI = 3.141592654
   REAL(dp), PARAMETER :: K_BOLTZ_SI=1.38d-23 !Boltzmann constant SI
   REAL(dp), PARAMETER :: PC=3.086d18 !parsec in cgs
   REAL(dp), PARAMETER :: au=2.063d5 !1 AU in cgs
   REAL(dp), PARAMETER :: KM=1.d5 !kilometre in cgs
   REAL(dp), PARAMETER :: SECONDS_PER_YEAR=3.16d7
   REAL(dp), PARAMETER :: T_CMB=2.73
   REAL(dp), PARAMETER :: EV = 1.60217646D-12 ! electron volt in erg
   REAL(dp), PARAMETER :: GRAV_G = 6.674d-8 !gravitational constant in cgs
   REAL(dp), PARAMETER :: SB_CONST=5.6704d-5 !Stefan Boltzmann constant in cgs

   !Error codes for python wrap
   INTEGER, PARAMETER :: PARAMETER_READ_ERROR=-1
   INTEGER, PARAMETER :: PHYSICS_INIT_ERROR=-2
   INTEGER, PARAMETER :: CHEM_INIT_ERROR=-3
   INTEGER, PARAMETER :: INT_UNRECOVERABLE_ERROR=-4
   INTEGER, PARAMETER :: INT_TOO_MANY_FAILS_ERROR=-5
CONTAINS
   !Hold over from heating branch
    SUBROUTINE pair_insertion_sort(array)
    REAL(dp), INTENT(inout) :: array(:)
    INTEGER :: i,j,last
    REAL(dp) :: t1,t2

    last=size(array)
    DO i=2,last-1,2
       t1=min(array(i),array(i+1))
       t2=max(array(i),array(i+1))
       j=i-1
       DO while((j.ge.1).and.(array(j).gt.t2))
          array(j+2)=array(j)
          j=j-1
       ENDDO
       array(j+2)=t2
       DO while((j.ge.1).and.(array(j).gt.t1))
          array(j+1)=array(j)
          j=j-1
       ENDDO
       array(j+1)=t1
    END DO

    IF(mod(last,2).eq.0)then
       t1=array(last)
       DO j=last-1,1,-1
          IF (array(j).le.t1) exit
          array(j+1)=array(j)
       END DO
       array(j+1)=t1
    ENDIF

  END SUBROUTINE pair_insertion_sort

END MODULE CONSTANTS


module mcm_compute

contains

subroutine calc_coupling_elem_spin0(wcl, l1, l2, elem)
    implicit none
    integer, intent(in)   :: l1, l2
    real(8), intent(in)   :: wcl(:)
    real(8), intent(inout):: elem
    real(8) :: thrcof0(2*size(wcl)), l1f, l2f
    integer :: info, l3, wlmin, wlmax, i, lmax
    lmax = size(wcl)-1 ! wcl starts at 0

    call drc3jj(dble(l1), dble(l2), 0d0, 0d0, l1f, l2f, thrcof0, size(thrcof0), info)

    wlmin = int(l1f)
    wlmax = min(lmax, int(l2f))
    elem = 0
    do l3 = wlmin, wlmax
        i = l3 - wlmin + 1
        elem = elem + wcl(l3 + 1) * thrcof0(i)**2
    end do
end subroutine

subroutine calc_coupling_elem_spin0and2(wcl_00, wcl_02, wcl_20, wcl_22, l1, l2, elems)
    implicit none
    integer, intent(in)   :: l1, l2
    real(8), intent(in)   :: wcl_00(:), wcl_02(:), wcl_20(:), wcl_22(:)
    real(8), intent(inout):: elems(5)
    real(8) :: thrcof0(2*size(wcl_00)), thrcof1(2*size(wcl_00)), l1f, l2f
    integer :: info, l3, wlmin, wlmax, i, lmax

    lmax = size(wcl_00)-1 ! wcl starts at 0

    call drc3jj(dble(l1), dble(l2), 0d0, 0d0, l1f, l2f, thrcof0, size(thrcof0), info)
    call drc3jj(dble(l1), dble(l2), -2d0, 2d0, l1f, l2f, thrcof1, size(thrcof1), info)

    wlmin = int(l1f)
    wlmax = min(lmax, int(l2f))
    elems = 0
    do l3 = wlmin, wlmax
        i = l3 - wlmin + 1
        elems(1) = elems(1) + wcl_00(l3 + 1) * thrcof0(i)**2
        elems(2) = elems(2) + wcl_02(l3 + 1) * thrcof0(i) * thrcof1(i)
        elems(3) = elems(3) + wcl_20(l3 + 1) * thrcof0(i) * thrcof1(i)
        elems(4) = elems(4) + wcl_22(l3 + 1) * thrcof1(i)**2 * (1 + (-1)**(l1 + l2 + l3)) / 2
        elems(5) = elems(5) + wcl_22(l3 + 1) * thrcof1(i)**2 * (1 - (-1)**(l1 + l2 + l3)) / 2
    end do
end subroutine

subroutine calc_coupling_elem_spin0and2_pure(wcl_00, wcl_02, wcl_20, wcl_22, l1, l2, elems)
    implicit none
    integer, intent(in)   :: l1, l2
    real(8), intent(in)   :: wcl_00(:), wcl_02(:), wcl_20(:), wcl_22(:)
    real(8), intent(inout):: elems(5)
    real(8) :: thrcof0(2*size(wcl_00)), thrcofa(2*size(wcl_00)), thrcofb(2*size(wcl_00)), thrcofc(2*size(wcl_00)), l1f, l2f, fac_b, fac_c, combin
    integer :: info, l3, wlmin1, wlmax1, i1, wlmin2, i2, wlmin3, i3, lmax

    lmax = size(wcl_00)-1 ! wcl starts at 0

    call drc3jj(dble(l1), dble(l2), 0d0, 0d0, l1f, l2f, thrcof0, size(thrcof0), info)
    call drc3jj(dble(l1), dble(l2), -2d0, 2d0, l1f, l2f, thrcofa, size(thrcofa), info)
    wlmin1 = int(l1f)
    wlmax1 = min(lmax, int(l2f))
    call drc3jj(dble(l1), dble(l2), -2d0, 1d0, l1f, l2f, thrcofb, size(thrcofb), info)
    wlmin2 = int(l1f)
    call drc3jj(dble(l1), dble(l2), -2d0, 0d0, l1f, l2f, thrcofc, size(thrcofc), info)
    wlmin3 = int(l1f)
    elems = 0
    do l3 = wlmin1, wlmax1
        i1   = l3 - wlmin1 + 1
        i2   = l3 - wlmin2 + 1
        i3   = l3 - wlmin3 + 1
        fac_b = 2 * dsqrt((l3 + 1d0) * l3 / ((l2 - 1d0) * (l2 + 2d0)))
        fac_c = dsqrt((l3 + 2d0) * (l3 + 1d0) * l3 * (l3 - 1d0) / ((l2 + 2d0) * (l2 + 1d0) * l2 * (l2 - 1d0)))

        if (i2 < 0) then
            fac_b = 0d0
        end if

        if (i3 < 0) then
            fac_c = 0d0
        end if

        combin = thrcofa(i1) + fac_b * thrcofb(i2) + fac_c * thrcofc(i3)
        elems(1) = elems(1) + (wcl_00(l3 + 1) * thrcof0(i1)**2d0)
        elems(2) = elems(2) + (wcl_02(l3 + 1) * thrcof0(i1) * combin)
        elems(3) = elems(3) + (wcl_20(l3 + 1) * thrcof0(i1) * combin)
        elems(4) = elems(4) + (wcl_22(l3 + 1) * combin**2 * (1 + (-1)**(l1 + l2 + l3)) / 2)
        elems(5) = elems(5) + (wcl_22(l3 + 1) * combin**2 * (1 - (-1)**(l1 + l2 + l3)) / 2)

    end do
end subroutine

subroutine calc_coupling_spin0(wcl, l_exact, l_band, l_toeplitz, coupling)
    implicit none
    real(8), intent(in)    :: wcl(:)
    integer, intent(in)    :: l_exact , l_band, l_toeplitz
    real(8), intent(inout) :: coupling(:,:)
    integer :: l1, l2, nlmax, lmax_band

    nlmax = size(coupling,1) - 1

    !$omp parallel do private(l2, l1) schedule(dynamic)
    do l1 = 2, min(nlmax, l_exact)
        do l2 = l1, nlmax
            call calc_coupling_elem_spin0(wcl, l1, l2, coupling(l1-1, l2-1))
        end do
    end do

    if (l_exact .lt. nlmax) then
        !$omp parallel do private(l2, l1, lmax_band) schedule(dynamic)
        do l1 = l_exact + 1, l_toeplitz
            if (l1 .lt. l_toeplitz) then
                lmax_band = min(l1 + l_band, nlmax)
            else
                lmax_band = nlmax
            end if

            do l2 = l1, lmax_band
                call calc_coupling_elem_spin0(wcl, l1, l2, coupling(l1-1, l2-1))
            end do
        end do

        if (l_toeplitz .lt. nlmax) then
            !$omp parallel do
            do l1 = l_toeplitz + 1, nlmax
                call calc_coupling_elem_spin0(wcl, l1, l1, coupling(l1-1, l1-1))
            end do
        end if
    end if

end subroutine

subroutine calc_coupling_spin0and2(wcl_00, wcl_02, wcl_20, wcl_22, l_exact, l_band, l_toeplitz, coupling)
    implicit none
    real(8), intent(in)    :: wcl_00(:), wcl_02(:), wcl_20(:), wcl_22(:)
    integer, intent(in)   :: l_exact, l_band, l_toeplitz
    real(8), intent(inout) :: coupling(:,:,:)
    real(8), parameter     :: pi = 3.14159265358979323846264d0
    integer :: l1, l2, nlmax, lmax_band
    nlmax = size(coupling, 1) - 1

    !$omp parallel do private(l2, l1) schedule(dynamic)
    do l1 = 2, min(nlmax, l_exact)
        do l2 = l1, nlmax
            call calc_coupling_elem_spin0and2(wcl_00, wcl_02, wcl_20, wcl_22, l1, l2, coupling(l1-1, l2-1, :))
        end do
    end do

    if (l_exact .lt. nlmax) then
        !$omp parallel do private(l2, l1, lmax_band) schedule(dynamic)
        do l1 = l_exact + 1, l_toeplitz
            if (l1 .lt. l_toeplitz) then
                lmax_band = min(l1 + l_band, nlmax)
            else
                lmax_band = nlmax
            end if
            do l2 = l1, lmax_band
                call calc_coupling_elem_spin0and2(wcl_00, wcl_02, wcl_20, wcl_22, l1, l2, coupling(l1-1, l2-1, :))
            end do
        end do

        if (l_toeplitz .lt. nlmax) then
            !$omp parallel do
            do l1 = l_toeplitz + 1, nlmax
                call calc_coupling_elem_spin0and2(wcl_00, wcl_02, wcl_20, wcl_22, l1, l1, coupling(l1-1, l1-1, :))
            end do
        end if
    end if

end subroutine

subroutine calc_mcm_spin0and2_pure(wcl_00, wcl_02, wcl_20, wcl_22, coupling_array)
    implicit none
    real(8), intent(in)    :: wcl_00(:), wcl_02(:), wcl_20(:), wcl_22(:)
    real(8), intent(inout) :: coupling_array(:,:,:)
    integer :: l1, l2, nlmax
    nlmax = size(coupling_array,1)-1
    !$omp parallel do private(l2,l1) schedule(dynamic)
    do l1 = 2, nlmax
        do l2 = 2, nlmax
            call calc_coupling_elem_spin0and2_pure(wcl_00, wcl_02, wcl_20, wcl_22, l1, l2, coupling_array(l1-1,l2-1,:))
        end do
    end do

end subroutine

subroutine toepliz_array_fortran(toepliz_array, coupling_array, l_toep)
    implicit none
    integer, intent(in)    :: l_toep
    real(8), intent(inout) :: toepliz_array(:,:)
    real(8), intent(in) :: coupling_array(:,:)
    real(8) :: diag(size(coupling_array,1)), row(size(coupling_array,1))
    integer :: l1, l2, nlmax

    nlmax = size(coupling_array, 1) - 1

    !$omp parallel do
    do l1 = 2, nlmax
        diag(l1-1) = coupling_array(l1-1, l1-1)**0.5d0
    end do

    !$omp parallel do
    do l2 = l_toep, nlmax
        row(l2 - l_toep + 1)= coupling_array(l_toep-1,l2-1)/(diag(l_toep-1)*diag(l2-1))
    end do

    !$omp parallel do private(l2,l1) schedule(dynamic)
    do l1 = 2, l_toep
        do l2 = l1,  l1 + nlmax - l_toep
            toepliz_array(l1-1, l2-1) = row(l2-l1+1) * (diag(l1-1)*diag(l2-1))
        end do
    end do

  !$omp parallel do private(l2,l1) schedule(dynamic)
   do l1 = l_toep + 1, nlmax
        do l2 = l1, nlmax
            toepliz_array(l1-1, l2-1) = row(l2-l1+1) * (diag(l1-1)*diag(l2-1))
        end do
  end do

end subroutine

subroutine toepliz_array_fortran2(toepliz_array, coupling_array, l_toep, l_exact)
    implicit none
    integer, intent(in)    :: l_toep, l_exact
    real(8), intent(inout) :: toepliz_array(:,:)
    real(8), intent(in) :: coupling_array(:,:)
    real(8) :: diag(size(coupling_array,1)), row_toep(size(coupling_array,1)), row_exact(size(coupling_array,1))
    integer :: l1, l2, nlmax

    nlmax = size(coupling_array, 1) - 1

    !$omp parallel do
    do l1 = 2, nlmax
        diag(l1-1) = coupling_array(l1-1, l1-1)**0.5d0
    end do

    !$omp parallel do
    do l2 = l_toep, nlmax
        row_toep(l2 - l_toep + 1)= coupling_array(l_toep-1,l2-1)/(diag(l_toep-1)*diag(l2-1))
    end do

    !$omp parallel do
    do l2 = l_exact, nlmax
        row_exact(l2 - l_exact + 1) = coupling_array(l_exact-1,l2-1)/(diag(l_exact-1)*diag(l2-1))
    end do

    !$omp parallel do private(l2,l1) schedule(dynamic)
    do l1 = 2, l_toep
        do l2 = l1,  l1 + nlmax - l_toep
            toepliz_array(l1-1, l2-1) = row_toep(l2-l1+1) * (diag(l1-1)*diag(l2-1))
        end do
        do l2 = l1 + nlmax - l_toep + 1,   nlmax
            toepliz_array(l1-1, l2-1) = row_exact(l2-l1+1) * (diag(l1-1)*diag(l2-1))
        end do
    end do

  !$omp parallel do private(l2,l1) schedule(dynamic)
   do l1 = l_toep + 1, nlmax
        do l2 = l1, nlmax
            toepliz_array(l1-1, l2-1) = row_toep(l2-l1+1) * (diag(l1-1)*diag(l2-1))
        end do
  end do

end subroutine

subroutine fill_upper(mat)
  implicit none
  real(8), intent(inout) :: mat(:,:)
  integer ::  j, k
  !$omp parallel do private(j,k) schedule(dynamic)
    do j = 1, size(mat,2)
      do k = 1, j-1
        mat(j,k) = mat(k,j)
      end do
    end do
end subroutine

subroutine bin_mcm(mcm, binLo, binHi, binsize, mbb, doDl)
    ! Bin the given mode coupling matrix mcm(0:lmax,0:lmax) into
    ! mbb(nbin,nbin) using bins of the given binsize
    implicit none
    real(8), intent(in)    :: mcm(:,:)
    integer, intent(in)    :: binLo(:),binHi(:),binsize(:),doDl
    real(8), intent(inout) :: mbb(:,:)
    integer :: b1, b2, l1, l2, lmax
    lmax = size(mcm,1)-1
    mbb  = 0
    do b2=1,size(mbb,1)
        do b1=1,size(mbb,1)
            do l2=binLo(b2),binHi(b2)
                do l1=binLo(b1),binHi(b1)
                    if (doDl .eq. 1) then
                        mbb(b1,b2)=mbb(b1,b2) + mcm(l1-1,l2-1)*l2*(l2+1d0)/(l1*(l1+1d0)) !*mcm(l2-1,l3-1)
                    else
                        mbb(b1,b2)=mbb(b1,b2) + mcm(l1-1,l2-1)
                    end if
                end do
            end do
            mbb(b1,b2) = mbb(b1,b2) / binsize(b2)

        end do
    end do
end subroutine

subroutine binning_matrix(mcm, binLo, binHi, binsize, bbl, doDl)
    implicit none
    real(8), intent(in)    :: mcm(:,:)
    integer(8), intent(in)    :: binLo(:),binHi(:),binsize(:),doDl
    real(8), intent(inout) :: bbl(:,:)
    integer(8) :: b2, l1, l2,lmax

    lmax = size(mcm,1)-1
    ! mcm is transposed
    ! compute \sum_{l'} M_l'l
    do l1=2,lmax
        do b2=1,size(binLo)
            do l2=binLo(b2),binHi(b2)
                if (doDl .eq. 1) then
                    bbl(l1-1,b2)=bbl(l1-1,b2)+mcm(l1-1,l2-1)*l2*(l2+1d0)/(l1*(l1+1d0))
                else
                     bbl(l1-1,b2)=bbl(l1-1,b2)+mcm(l1-1,l2-1)
                end if
            end do
            bbl(l1-1,b2)=bbl(l1-1,b2)/(binsize(b2)*1d0)
        end do
    end do
end subroutine

end module


      subroutine eigs33(a,r,eig)
      implicit none
      real*8 a(3,3),r(3,3),eig(3)

c     Use extended double precision real for internal variables if possible
      integer ex_real_kind
      parameter (ex_real_kind=max(
     $     selected_real_kind(precision(1.d0) * 2),
     $     selected_real_kind(precision(1.d0) + 1),
     $     selected_real_kind(precision(1.d0))))

      integer itmax
      parameter (itmax=8)

      integer it
      real(ex_real_kind) one,d,c,s,x11,x21,x31,x22,x33,x32,
     $     r11,r21,r31,r12,r22,r32,r13,r23,r33,rr,
     $     fact,dd,u,g,y33,y22,y11
      parameter (one=1.)

      d=abs(complex(a(2,1),a(3,1)))
      if(d .ne. 0.d0)then
        c=a(2,1)/d
        s=a(3,1)/d
      else
        c=1.d0
        s=0.d0
      endif
      x11=a(1,1)
      x21=d
      x31=0.d0
      x22=a(2,2)*c**2+a(3,3)*s**2+2.d0*a(3,2)*c*s
      x33=a(2,2)*s**2+a(3,3)*c**2-2.d0*a(3,2)*c*s
      x32=a(3,2)*(c-s)*(c+s)+(a(3,3)-a(2,2))*c*s
      r11=1.d0
      r21=0.d0
      r31=0.d0
      r12=0.d0
      r22=c
      r32=s
      r13=0.d0
      r23=-s
      r33=c
      fact=1.d0
      it=0
1     continue
      it=it+1
c     write(*,'(1x6f12.6)')x11,x21,x31,x22,x32,x33
      dd=abs(x11)+abs(x22)
      if(abs(x21)/fact+dd .eq. dd)then
        eig(1)=dble(x11)
        u=x22-x33
        d=abs(complex(u,2.d0*x32))
        if(d .eq. 0.d0)then
          eig(2)=dble(x22)
          eig(3)=dble(x33)
        else
          c=sqrt(.5d0*(1.d0+abs(u)/d))
          s=sign(sqrt(2.d0*x32**2/d/(d+abs(u))),u*x32)
c         eig(2) * eig(3) == x22 * x33 - x32^2
c         eig(2) + eig(3) == x22 + x33
c         d := Sqrt[(x22 - x33)^2 + (2 * x32)^2]
c         eig(2)=.5d0*(x22+x33+sign(d,u))
c         eig(3)=.5d0*(x22+x33-sign(d,u))
          if(sign(one,x22+x33) * sign(one,u) .ge. 0.d0)then
            eig(2)=.5d0*dble(x22+x33+sign(d,u))
            eig(3)=dble(x22*x33-x32**2)/eig(2)
          else
            eig(3)=.5d0*dble(x22+x33-sign(d,u))
            eig(2)=dble(x22*x33-x32**2)/eig(3)
          endif
          rr=r12
          r12= c*rr+s*r13
          r13=-s*rr+c*r13
          rr=r22
          r22= c*rr+s*r23
          r23=-s*rr+c*r23
          rr=r32
          r32= c*rr+s*r33
          r33=-s*rr+c*r33
        endif
        go to 1000
      endif
      dd=abs(x22)+abs(x33)
      if(abs(x32)/fact+dd .eq. dd)then
        eig(3)=dble(x33)
        u=x11-x22
        d=abs(complex(u,2.d0*x21))
        if(d .eq. 0.d0)then
          eig(1)=dble(x11)
          eig(2)=dble(x22)
        else
          c=sqrt(.5d0*(1.d0+abs(u)/d))
          s=sign(sqrt(2.d0*x21**2/d/(d+abs(u))),u*x21)
c         eig(1) * eig(2) == x11 * x22 - x21^2
c         eig(1) + eig(2) == x11 + x22
c         d := Sqrt[(x11 - x22)^2 + (2 * x21)^2]
c         eig(1)=.5d0*(x11+x22+sign(d,u))
c         eig(2)=.5d0*(x11+x22-sign(d,u))
          if(sign(one,x11+x22) * sign(one,u) .ge. 0.d0)then
            eig(1)=.5d0*dble(x11+x22+sign(d,u))
            eig(2)=dble(x11*x22-x21**2)/eig(1)
          else
            eig(2)=.5d0*dble(x11+x22-sign(d,u))
            eig(1)=dble(x11*x22-x21**2)/eig(2)
          endif
          rr=r11
          r11= c*rr+s*r12
          r12=-s*rr+c*r12
          rr=r21
          r21= c*rr+s*r22
          r22=-s*rr+c*r22
          rr=r31
          r31= c*rr+s*r32
          r32=-s*rr+c*r32
        endif
        go to 1000
      endif
      u=x22-x11
      d=abs(complex(u,2.d0*x21))
      g=x11-2.d0*x21**2/(u+sign(d,u))
      d=abs(complex(x32,x33-g))
      c=(x33-g)/d
      s=-x32/d
      y22=x22
      y33=x33
      x22=y22*c**2+y33*s**2+2.d0*x32*c*s
      x33=y22*s**2+y33*c**2-2.d0*x32*c*s
      x32=x32*(c-s)*(c+s)-(y22-y33)*c*s
      x31=-x21*s
      x21= x21*c
      rr=r12
      r12= c*rr+s*r13
      r13=-s*rr+c*r13
      rr=r22
      r22= c*rr+s*r23
      r23=-s*rr+c*r23
      rr=r32
      r32= c*rr+s*r33
      r33=-s*rr+c*r33
      if(abs(x31)/fact+abs(x32) .ne. abs(x32))then
        d=abs(complex(x32,x31))
        c=x32/d
        s=-x31/d
        y11=x11
        y22=x22
        x11=y11*c**2+y22*s**2+2.d0*x21*c*s
        x22=y11*s**2+y22*c**2-2.d0*x21*c*s
        x21=x21*(c-s)*(c+s)-(y11-y22)*c*s
        x32=d
        rr=r11
        r11= c*rr+s*r12
        r12=-s*rr+c*r12
        rr=r21
        r21= c*rr+s*r22
        r22=-s*rr+c*r22
        rr=r31
        r31= c*rr+s*r32
        r32=-s*rr+c*r32
      endif
      if(it .gt. itmax)then
        fact=fact*4.d0
        it=0
      endif
      go to 1
1000  r(1,1)=dble(r11)
      r(2,1)=dble(r21)
      r(3,1)=dble(r31)
      r(1,2)=dble(r12)
      r(2,2)=dble(r22)
      r(3,2)=dble(r32)
      r(1,3)=dble(r13)
      r(2,3)=dble(r23)
      r(3,3)=dble(r33)
      return
      end

      real*8 function eigr33(r,u,ndim)
      use macmath
      implicit none
      integer*4 ndim
      real*8 r(ndim,3),u(3),a,b,s2,u1,u2,u3,w,x1,x2,x3,c,s
      s2=r(1,3)**2+r(2,3)**2
      if(s2 .eq. 0.d0)then
        if(r(3,3) .gt. 0.d0)then
          u(1)=0.d0
          u(2)=0.d0
          u(3)=1.d0
          eigr33=atan2(-r(1,2),r(1,1))
        else
          u1=r(1,2)
          u2=1.d0-r(1,1)
          w=hypot(u1,u2)
          u(1)=u1/w
          u(2)=u2/w
          u(3)=0.d0
          eigr33=pi
        endif
      else
        b=r(3,2)*r(1,3)-r(3,1)*r(2,3)
        a=-(1.d0+r(1,1))*r(2,3)**2+(r(1,2)+r(2,1))*r(1,3)*r(2,3)
     1    -(1.d0+r(2,2))*r(1,3)**2
        u1=b*r(1,3)+a*r(2,3)
        u2=b*r(2,3)-a*r(1,3)
        u3=b*(1.d0+r(3,3))
c        w=sign(hypot(u1,hypot(u2,u3)),u3*r(3,3))
c        w=sign(hypot3(u1,u2,u3),u3*r(3,3))
        w=sign(norm2([u1,u2,u3]),u3*r(3,3))
        u1=u1/w
        u2=u2/w
        u3=u3/w
        x1=r(1,1)*u2-r(1,2)*u1
        x2=r(2,1)*u2-r(2,2)*u1
        x3=r(3,1)*u2-r(3,2)*u1
        c=x1*u2-x2*u1
        s=(x1*u1+x2*u2)*u3-x3*(u1**2+u2**2)
        eigr33=atan2(s,c)
        u(1)=u1
        u(2)=u2
        u(3)=u3
      endif
      return
      end

      subroutine rot33(r,u,phi,ndim)
      implicit none
      integer*4 ndim
      real*8 r(ndim,3),u(3),phi,w,u1,u2,u3,c,s,q,th
c      w=hypot(u(1),hypot(u(2),u(3)))
      w=norm2([u(1),u(2),u(3)])
      u1=u(1)/w
      u2=u(2)/w
      u3=u(3)/w
      th=tan(.5d0*phi)
      s=2.d0*th/(1.d0+th**2)
      q=th*s
      c=1.d0-q
c      q=2.d0*sin(.5d0*phi)**2
      r(1,1)=u1**2+(u2**2+u3**2)*c
      r(2,1)=u1*u2*q+u3*s
      r(3,1)=u1*u3*q-u2*s
      r(2,2)=u2**2+(u3**2+u1**2)*c
      r(3,2)=u2*u3*q+u1*s
      r(1,2)=u2*u1*q-u3*s
      r(3,3)=u3**2+(u1**2+u2**2)*c
      r(1,3)=u3*u1*q+u2*s
      r(2,3)=u3*u2*q-u1*s
      return
      end


C
C	$Id$
C
      DOUBLE PRECISION FUNCTION CSFVAL (B1,B2,B3,V1,V2,V3,F1,
     .                                F2,F3,G1,G2,G3,CSSIG1,
     .                                CSSIG2,SIG3)
      DOUBLE PRECISION B1, B2, B3, V1(3), V2(3), V3(3), F1,
     .                 F2, F3, G1(3), G2(3), G3(3), CSSIG1,
     .                 CSSIG2, SIG3
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   05/09/92
C
C   Given data values and gradients at the three vertices of
C a spherical triangle containing a point P, this routine
C computes the value of F at P where F interpolates the ver-
C tex data.  Along the triangle sides, the interpolatory
C function F is the Hermite interpolatory tension spline
C defined by the values and tangential gradient components
C at the endpoints, and the gradient component normal to the
C triangle side varies linearly with respect to arc-length
C between the normal gradient components at the endpoints.
C A first-order C-1 blending method is used on the underly-
C ing planar triangle.  Since values and gradients on an arc
C depend only on the vertex data, the method results in C-1
C continuity when used to interpolate over a triangulation.
C
C   The blending method consists of taking F(P) to be a
C weighted sum of the values at PP of three univariate Her-
C mite interpolatory tension splines defined on the line
C segments which join the vertices to the opposite sides and
C pass through PP:  the central projection of P onto the
C underlying planar triangle.  The tension factors for these
C splines are obtained by linear interpolation between the
C pair of tension factors associated with the triangle sides
C which join at the appropriate vertex.
C
C   A tension factor SIGMA associated with a Hermite interp-
C olatory tension spline is a nonnegative parameter which
C determines the curviness of the spline.  SIGMA = 0 results
C in a cubic spline, and the spline approaches the linear
C interpolant as SIGMA increases.
C
C On input:
C
C       B1,B2,B3 = Barycentric coordinates of PP with re-
C                  spect to the (planar) underlying triangle
C                  (V1,V2,V3), where PP is the central
C                  projection of P onto this triangle.
C
C       V1,V2,V3 = Cartesian coordinates of the vertices of
C                  a spherical triangle containing P.  V3
C                  Left V1->V2.
C
C       F1,F2,F3 = Data values associated with the vertices.
C
C       G1,G2,G3 = Gradients associated with the vertices.
C                  Gi is orthogonal to Vi for i = 1,2,3.
C
C       CSSIG1,CSSIG2,SIG3 = Tension factors associated with the
C                        triangle sides opposite V1, V2, and
C                        V3, respectively.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       CSFVAL = Interpolated value at P.
C
C Each vector V above contains X, Y, and Z components in
C   V(1), V(2), and V(3), respectively.
C
C SSRFPACK modules required by CSFVAL:  CSARCINT, CSARCLEN, CSHVAL
C
C Intrinsic function called by CSFVAL:  SQRT
C
C***********************************************************
C
      DOUBLE PRECISION CSHVAL
      INTEGER I
      DOUBLE PRECISION C1, C2, C3, DS, DUM, DV, F, G(3),
     .                 Q1(3), Q2(3), Q3(3), SIG, SUM, S1,
     .                 S2, S3, U1(3), U2(3), U3(3), U1N,
     .                 U2N, U3N, VAL
C
C Local parameters:
C
C C1,C2,C3 =    Coefficients (weight functions) of partial
C                 interpolants.  C1 = 1 on the edge opposite
C                 V1 and C1 = 0 on the other edges.  Simi-
C                 larly for C2 and C3.  C1+C2+C3 = 1.
C DS =          Directional derivative (scaled by distnace)
C                 at U1, U2, or U3:  DS = (G,U1-V1)/U1N =
C                 -(G,V1)/U1N on side opposite V1, where G/
C                 U1N (plus an orthogonal component) is the
C                 projection of G onto the planar triangle
C DUM =         Dummy variable for calls to CSARCINT
C DV =          Directional derivatives (scaled by distance)
C                 at a vertex:  D1 = (G1,U1-V1) = (G1,U1)
C F,G =         Value and gradient at Q1 Q2, or Q3 obtained
C                 by interpolation along one of the arcs of
C                 the spherical triangle
C I =           DO-loop index
C Q1,Q2,Q3 =    Central projections of U1, U2, and U3 onto
C                 the sphere and thus lying on an arc of the
C                 spherical triangle
C SIG =         Tension factor for a side-vertex (partial)
C                 interpolant:  obtained by linear interpo-
C                 lation applied to triangle side tensions
C SUM =         Quantity used to normalize C1, C2, and C3
C S1,S2,S3 =    Sums of pairs of barycentric coordinates:
C                 used to compute U1, U2, U3, and SIG
C U1,U2,U3 =    Points on the boundary of the planar trian-
C                 gle and lying on the lines containing PP
C                 and the vertices.  U1 is opposite V1, etc.
C U1N,U2N,U3N = Quantities used to compute Q1, Q2, and Q3
C                 (magnitudes of U1, U2, and U3)
C VAL =         Local variable used to accumulate the con-
C                 tributions to CSFVAL
C
C
C Compute weight functions C1, C2, and C3.
C
      C1 = B2*B3
      C2 = B3*B1
      C3 = B1*B2
      SUM = C1 + C2 + C3
      IF (SUM .LE. 0.) THEN
C
C P coincides with a vertex.
C
        CSFVAL = B1*F1 + B2*F2 + B3*F3
        RETURN
      ENDIF
C
C Normalize C1, C2, and C3.
C
      C1 = C1/SUM
      C2 = C2/SUM
      C3 = C3/SUM
C
C Compute (S1,S2,S3), (U1,U2,U3) and (U1N,U2N,U3N).
C
      S1 = B2 + B3
      S2 = B3 + B1
      S3 = B1 + B2
      U1N = 0.
      U2N = 0.
      U3N = 0.
      DO 1 I = 1,3
        U1(I) = (B2*V2(I) + B3*V3(I))/S1
        U2(I) = (B3*V3(I) + B1*V1(I))/S2
        U3(I) = (B1*V1(I) + B2*V2(I))/S3
        U1N = U1N + U1(I)*U1(I)
        U2N = U2N + U2(I)*U2(I)
        U3N = U3N + U3(I)*U3(I)
    1   CONTINUE
C
C Compute Q1, Q2, and Q3.
C
      U1N = SQRT(U1N)
      U2N = SQRT(U2N)
      U3N = SQRT(U3N)
      DO 2 I = 1,3
        Q1(I) = U1(I)/U1N
        Q2(I) = U2(I)/U2N
        Q3(I) = U3(I)/U3N
    2   CONTINUE
C
C Compute interpolated value (VAL) at P by looping on
C   triangle sides.
C
      VAL = 0.
C
C Contribution from side opposite V1:
C
C   Compute value and gradient at Q1 by interpolating
C     between V2 and V3.
C
      CALL CSARCINT (Q1,V2,V3,F2,F3,G2,G3,CSSIG1, F,G,DUM)
C
C   Add in the contribution.
C
      DV = G1(1)*U1(1) + G1(2)*U1(2) + G1(3)*U1(3)
      DS = -(G(1)*V1(1) + G(2)*V1(2) + G(3)*V1(3))/U1N
      SIG = (B2*SIG3 + B3*CSSIG2)/S1
      VAL = VAL + C1*CSHVAL(B1,F1,F,DV,DS,SIG)
C
C Contribution from side opposite V2:
C
C   Compute value and gradient at Q2 by interpolating
C     between V3 and V1.
C
      CALL CSARCINT (Q2,V3,V1,F3,F1,G3,G1,CSSIG2, F,G,DUM)
C
C   Add in the contribution.
C
      DV = G2(1)*U2(1) + G2(2)*U2(2) + G2(3)*U2(3)
      DS = -(G(1)*V2(1) + G(2)*V2(2) + G(3)*V2(3))/U2N
      SIG = (B3*CSSIG1 + B1*SIG3)/S2
      VAL = VAL + C2*CSHVAL(B2,F2,F,DV,DS,SIG)
C
C Contribution from side opposite V3:
C
C   Compute interpolated value and gradient at Q3
C     by interpolating between V1 and V2.
C
      CALL CSARCINT (Q3,V1,V2,F1,F2,G1,G2,SIG3, F,G,DUM)
C
C   Add in the final contribution.
C
      DV = G3(1)*U3(1) + G3(2)*U3(2) + G3(3)*U3(3)
      DS = -(G(1)*V3(1) + G(2)*V3(2) + G(3)*V3(3))/U3N
      SIG = (B1*CSSIG2 + B2*CSSIG1)/S3
      CSFVAL = VAL + C3*CSHVAL(B3,F3,F,DV,DS,SIG)
      RETURN
      END


module model_critical_sound_speed
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: ZERO, HALF, ONE, TWO, PI, RKTOL
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use mod_fluid
    use DNAD_D
    use ieee_arithmetic
    implicit none

    !> Based on the reference:
    !! Fernandez, Pablo, Cuong Nguyen, and Jaime Peraire.
    !! "A physics-based shock capturing method for unsteady laminar and turbulent flows."
    !! 2018 AIAA Aerospace Sciences Meeting. 2018.
    !!
    !! @author  Eric M. Wolf
    !! @date    09/06/2018
    !!
    !--------------------------------------------------------------------------------
    type, extends(model_t)  :: critical_sound_speed_t

    contains

        procedure   :: init
        procedure   :: compute

    end type critical_sound_speed_t
    !***************************************************************************************

contains

    !>
    !!
    !!
    !! @author  Eric M. Wolf
    !! @date    09/06/2018
    !!
    !--------------------------------------------------------------------------------
    subroutine init(self)
        class(critical_sound_speed_t), intent(inout)   :: self

        call self%set_name('Critical Sound Speed')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Critical Sound Speed')
        call self%add_model_field('Stagnation Temperature')
    end subroutine init
    !***************************************************************************************

    !>
    !!
    !!
    !! @author  Eric M. Wolf
    !! @date    07/11/2018
    !!
    !--------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(critical_sound_speed_t),  intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        integer(ik) :: ii
        type(AD_D), allocatable,    dimension(:) ::         &
            t, t_stag, c_star,   &
            div_vel, density, mom1, mom2, mom3, vel_mag

        real(rk),   allocatable,    dimension(:) :: h
        real(rk) :: Dmax, d0, delta_d

        density = worker%get_field('Density',    'value')
        mom1    = worker%get_field('Momentum-1', 'value')
        mom2    = worker%get_field('Momentum-2', 'value')
        mom3    = worker%get_field('Momentum-3', 'value')

        vel_mag = ZERO*density
        vel_mag = (mom1**TWO+mom2**TWO+mom3**TWO)/density**TWO
        t = worker%get_field('Temperature', 'value')
        t_stag = t + vel_mag/(TWO*cp)

        call worker%store_model_field('Stagnation Temperature', 'value', t_stag)

        c_star = ZERO*density
        c_star = sqrt(gam*Rgas*(TWO/(gam+ONE))*((t_stag)))

        call worker%store_model_field('Critical Sound Speed', 'value', c_star)

    end subroutine compute
    !***************************************************************************************

end module model_critical_sound_speed


SUBROUTINE rhsLinearFreeSurface3D_SWENSE(t,Wavefield,g,rhsE,rhsP,Nx,Ny)
!
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx,Ny
REAL(KIND=long) :: g,t
REAL(KIND=long), DIMENSION(Nx,Ny) :: rhsE, rhsP ! GD remove: E, Ex, Ey, P, Px, Py, W,
!REAL(KIND=long), DIMENSION(Nx,Ny) :: E_I,Ex_I,Ey_I,Et_I,Px_I,Py_I,W_I,Pt_I
TYPE(Wavefield_FS) :: Wavefield

rhsE = Wavefield%W + Wavefield%Pz_I_s - Wavefield%Et_I     ! kinematic FS BC
rhsP = -g*(Wavefield%E+Wavefield%E_I) - Wavefield%Pt_I_s   ! dynamic FS BC!

END SUBROUTINE rhsLinearFreeSurface3D_SWENSE


subroutine compute_sigma(nr_tab,r_tab,virial_mass,virial_radius,&
     & nfw_concentration,virial_overdensity,halo_type,&
     & bulge_mass,bulge_radius,disc_mass,disc_radius,black_hole_mass,&
     & fmax,fcut,velocity_anisotropy_amplitude,velocity_anisotropy_radius,&
     & sigr_tab,sigp_tab,sigm_tab)

  use kinematics

  implicit none

  integer(kind=4) :: nr_tab
  real(kind=8), dimension(nr_tab), intent(inout) :: r_tab
  real(kind=8), dimension(nr_tab), intent(inout) :: sigr_tab
  real(kind=8), dimension(nr_tab), intent(inout) :: sigp_tab
  real(kind=8), dimension(nr_tab), intent(inout) :: sigm_tab

  real(kind=8) :: virial_mass,virial_radius,virial_velocity
  real(kind=8) :: nfw_concentration,virial_overdensity
  integer(kind=4) :: halo_type
  real(kind=8) :: disc_mass,disc_radius
  real(kind=8) :: bulge_mass,bulge_radius
  real(kind=8) :: black_hole_mass
  real(kind=8) :: velocity_anisotropy_amplitude,velocity_anisotropy_radius
  real(kind=8) :: fmax,rmax,fcut,rcut

  logical :: isbh                         ! Is a black hole present?

  integer(kind=4) :: i,j,k,l,m,n,nn
  real(kind=8) :: sum

  nrbin=nr_tab

  allocate(rtab(nrbin))       ! Tabulated radius
  allocate(sigma_r(nrbin))      ! Tabulated mass
  allocate(sigma_p(nrbin))      ! Tabulated mass
  allocate(sigma_m(nrbin))      ! Tabulated mass

  do n=1,nrbin
     rtab(n)=r_tab(n)
     sigma_r(n)=0.0
     sigma_p(n)=0.0
     sigma_m(n)=0.0
  end do

  halotype=halo_type
  m200=virial_mass
  mbulge=bulge_mass*m200
  mdisc=disc_mass*m200
  mbh=black_hole_mass*m200

  c200=nfw_concentration
  virial_radius=getrvir(m200,virial_overdensity,rhocrit0)
  r200=virial_radius
  rs=r200/c200                                  ! NFW Scale radius
  fbulge=bulge_radius
  fdisc=disc_radius
  beta0=velocity_anisotropy_amplitude
  r_a=velocity_anisotropy_radius*r200

  if(mbulge.gt.0.0 .and. fbulge.le.0.0) stop 'Error: fbulge.le.0.0'
  if(mdisc.gt.0.0 .and. fdisc.le.0.0) stop 'Error: fdisc.le.0.0'

  ! Compute component masses, in units of 1e10 solar masses

  if(mbh.gt.0.0) then
     write(*,*) 'Assuming a central black hole...'
     write(*,*) 'MBH: ',mbh
     write(*,*)
  end if

  if(halo_type.eq.0) then
     write(*,*) 'Assuming a Hernquist halo...'
     write(*,*) 'Halo properties:'
     write(*,*) 'M200: ',m200
     write(*,*) 'R200: ',r200
     write(*,*) 'Mtot: ',m200*(1+(1/c200)*sqrt(2*(dlog(1+c200)-c200/(1+c200))))
     write(*,*) 'Scale radius:',rs*sqrt(2*(dlog(1+c200)-c200/(1+c200)))
     write(*,*)
  end if

  if(halo_type.eq.1) then
     write(*,*) 'Assuming a NFW halo...'
     write(*,*) 'Halo properties:'
     write(*,*) 'M200: ',m200
     write(*,*) 'R200: ',r200
     write(*,*) 'Scale radius:',rs
     write(*,*)
  end if

  if(mbulge.gt.0.0) then
     rbulge=fbulge*rs
     if(halo_type.eq.0) &
          & rbulge=rbulge*sqrt(2*(dlog(1+c200)-c200/(1+c200)))     ! in units of kiloparsecs
     write(*,*) 'Assuming a Hernquist bulge...'
     write(*,*) 'Bulge properties:'
     write(*,*) 'Mtot: ',mbulge
     write(*,*) 'Scale radius:',rbulge
     write(*,*)
  end if

  mhalo=m200-mbulge-mdisc-mbh
  rmax=fmax*r200
  rcut=fcut*r200

  do i=1,nrbin
     call qromo(sgfunc,dlog(rtab(i)),dlog(rmax),sum,midpnt)
     sigma_r(i)=-rtab(i)**(-2*get_vel_anisotropy(rtab(i)))*sum/rho(rtab(i))
  end do

  rmax=0.98*rtab(nrbin)

  i=1

  do
     if(rtab(i).gt.rcut) exit
     radius=rtab(i)
     call qromo(funk,dlog(rtab(i)),dlog(rmax),sum,midpnt)
     sigma_p(i)=sum
     i=i+1
  end do

  j=i-1

  do i=1,j
     radius=rtab(i)
     call qromo(sigma_mass,dlog(radius),dlog(rmax),sum,midpnt)
     sigma_m(i)=sum
     sigma_p(i)=2.*sigma_p(i)/sigma_m(i)
  end do

  nr_tab=j

  do i=1,nr_tab
     sigr_tab(i)=sqrt(sigma_r(i))
     sigp_tab(i)=sqrt(sigma_p(i))
     sigm_tab(i)=sigma_m(i)
  end do

  deallocate(rtab,sigma_r,sigma_p,sigma_m)

  return

end subroutine compute_sigma


c______________________________________________________________________
c
      subroutine rr_rbst(xr,xc,lomit,var,nt,nd,nsta,ih,ie,n1,i1,
     &   xp,itmax_stk,itmax_ln,orient,decl,theta,ngrp,igrp,
     &   lpwout,ioupw,pw,z,sig_s,sig_e,nu,l_ref_proj,bref,period,
     &   pwrmin)

ccc   robust array remote reference subroutine

ccc    ==> XR(nd,nt) is input data (not modified)
ccc    ==> XC(nd,nt) is input "cleaned" data (not modified)
ccc    ==> LOMIT is a logical array; true for data vectors to omit
ccc    ==> VAR(nt) is input estimate of noise variances in each channel
ccc    ==> IH,IE arrays of indices for start point of H/E channel groupings
ccc    ==> I1 is list of channel #s to use for reference (could be all ... of just some)
ccc    ==> N1 is # of channels to use for reference
ccc    ==>  orient, decl channel orientations, local declination
ccc    ==>  theta is rotation direction for output
ccc    ==>  lpwout = .true. if full array TF is to be output on this
ccc         call to rr_rbst
ccc    ==> ioupw(1) is 0 to NOT output full array TF ... otherwise is
ccc          unit # for output
ccc    ==> ioupw(2) is normal field defn for array TF ... = -1 for avg
ccc    ==>  bref defines reference fields for Pw output file
ccc    <== Z is remote ref local site TF for all stations

ccc    ==> XP is work space iterations

      include 'iosize.inc'
      parameter (npcmax = 4,n2max=ntmx,npc = 2
     &      ,npcs = (npc*(npc+1))/2 )
      parameter (nwork=npcmax*(ntfmax+2*n2max+npcmax+100+1)
     &                 +ntfmax*ntmx)

      complex xr(nd,nt),xc(nd,nt),xp(nd,nt),pctf(2,ntmx)
ccc      complex xr(nd,nt),xc(nd,nt),xp(nd,nt),pctf(2,0:ntmx)
      real var(nt),eval(ntmx),orient(*),decl(*),theta,pwrmin
      complex s(nsmx),se(nsmx),u(ntmx,npcmax),work(nwork),b(ntmx2)
     &  ,a(2,2),c(2),y(ntmx2),pw(*),sig_s(2,2,*),sig_e(nchemx,nchemx,*),
     &   z(nchemx,2,*),bref(ntmx,2),xxinv(npc,npc)
      real sediag(ntmx),period
      integer ih(*),ie(*),i1(n1),i0(ntmx),ioupw(2),
     &    ngrp,igrp(ntmx+1,ngrpmx),nu(ngrpmx)
      logical lrbst,lomit(nd),l_ref_proj,lpwout

ccc   STAGE I :  ESTIMATE POLARIZATION PARAMTERS FOR EACH TIME SEGMENT
      iw2 = npc*nd+1
      ns = (nt*(nt+1))/2

ccc   divide omitted data by 10**10
      nomit = 0
      do i = 1,nd
         if(lomit(i)) then
            nomit = nomit + 1
            do j = 1,nt
               xr(i,j) = xr(i,j)*1.e-10
               xc(i,j) = xc(i,j)*1.e-10
            enddo
         endif
      enddo

ccc   normalize "cleaned" data before finding PCs
      do j = 1,n1
         scale = 1./sqrt(var(i1(j)))
         i0(j) = j
         do i = 1,nd
            iw = iw2+(j-1)*nd+i-1
            work(iw) = xc(i,i1(j))*scale
         enddo
      enddo

ccc   make SDM
      call rbstk2(work(iw2),n1,nd,s,xp,itmax_stk)
ccc   compute principal components of normalized SDM
      call rsp(s,n1,npcmax,u,eval,0,xp,dum)

      if(l_ref_proj) then
         call refproj(n1,i1,nt,npcmax,u,bref,nd,eval)
      endif

ccc   form NPC linear combinations of data ... estiamtes of polarization
ccc    vectors ...
ccc    (NPC = 2 always in practice)
      call lc_dat(work(iw2),nd,n1,u,n1,npc,i0,work)

ccc   if requested by setting -M  option, omit all FCs for which net SNR
ccc   does not meet minimum threshold
c      write(0,*) 'PWRMIN   == ',pwrmin
      if(pwrmin .gt. 0 ) call minpwr(work,nd,npc,nt,work(iw2),pwrmin
     &           ,nomit)

ccc   STAGE II :  ESTIMATE FULL ARRAY TF, with full residual matrix
ccc        (Huber Weights, pulling individual channels toward predicted)

ccc   work(1)  is begining of PC data series array
ccc   estimate H, E RR TFs for each MT station
ccc      the integers iw# serve to partition the array WORK
ccc      into the different pieces used inside RBSTREG
ccc      WORK should be dimensioned to allow for NPC*(ND+2*N2+NPC+NB+1)
ccc       complex numbers;  NB is block size inside RBSTREG, currently
ccc       set to 100 (bigger than needed, but who cares? ... this is
ccc       tiny compared to ND)
ccc      copy PC data series array; QR in rbstreg will overwrite
      nd2 = npc*nd
      call ccopy(nd2,work,1,work(iw2),1)

      iw2 = npc*nd+1       !
      iw3 = iw2+npc*nd     ! start of array bsv
      iw4 = iw3+nt*2       ! start of array xxinv
      iw5 = iw4+npc*npc    ! start of array work (inside rbstreg)
c      write(0,*)work(iw2),work(iw3),work(iw5)
c      write(0,*)nd,npc,nt,itmax_ln,icvg,nomit
      call rbstreg(work(iw2),xr,xp,nd,npc,nt,pctf,work(iw3),
     &          work(iw5),se,xxinv,itmax_ln,icvg,nomit)
      if(icvg.lt.0) then
         write(0,*) 'in RR_RBST: did not converge'
         write(0,*) 'icvg= ',icvg
      else
         write(0,*) '# of iterations = ',icvg
      endif

ccc   output array TF with error, signal covariance matrices
      nf = nd-nomit

ccc   adjustment of residual covariance ... needs further
ccc    testing/thought ...
ccc      call adj_res(se,pctf,var,nt,u,n1,i1,work(iw2))

      call wrt_pctf(ioupw(1),nt,ns,pctf,se,xxinv,nf,period)

ccc   this minor correction routine still needs to be checked ...
c     if(l_ref_proj) call refproj_cor(nt,u,pctf,sig_s(1,1,nsta),nu)

ccc   Convert PC TF to Plane wave response with average = normal
      ij = 0
      do j = 1,2
         do i = 1,nt
            ij = ij + 1
            y(ij) = pctf(j,i)
         enddo
      enddo

      call mkbih(b,nt,ih,ie,nsta,ioupw(2))
      c(1) = 1.
      c(2) = 0.
      call anfld(y,nt,nt,b,c,a(1,1),pw)
      c(1) = 0.
      c(2) = 1.
      call anfld(y,nt,nt,b,c,a(1,2),pw(nt+1))

ccc   STAGE III  :  estimate TFs for each desired "group" relative
ccc    to the first two channels in the group ... channels in each
ccc    group are specified in array igrp

ccc   In this last stage we do the final step for robust RR (redescending
ccc    influence curve, downeighting (to zero mostly) all channels in a
ccc    group if enough are deemed "bad" ...
ccc   After computation of TFs, elements needed for the Z**** file
ccc     are computed, and apparent resistivities, phases and error bars
ccc    are computed

ccc   get error variance from robust TF fit
      call diag(se,nt,sediag)

      if(itmax_ln.gt.0) then
         lrbst = .true.
      else
         ndnt = nd*nt
         call ccopy(ndnt,xr,1,xp,1)
         lrbst = .false.
      endif
ccc   start of work array inside rr_wt
      iw3 = iw2 + nd/2+1
      iref_sta = ioupw(2)
      call rr_wt(lrbst,work,xr,xp,lomit,nt,nd,ngrp,igrp,orient,decl,
     &   theta,work(iw3),sediag,work(iw2),z,sig_s,sig_e,
     &   pctf,nu)

ccc   restore omitted data
      do i = 1,nd
         if(lomit(i)) then
            do j = 1,nt
               xr(i,j) = xr(i,j)*1.e+10
               xc(i,j) = xc(i,j)*1.e+10
            enddo
         endif
      enddo

      return
      end
c______________________________________________________________________
c
      subroutine rr_wt(lrbst,xc,xr,xp,lomit,nt,nd,ngrp,igrp,orient,decl
     &   ,theta,work,var,wts,z,sig_s,sig_e,pctf,nu)

      include 'nstamx.inc'
      integer nt,nd,igrp(ntmx+1,*),nu(*)
      real orient(2,*),decl(*),theta,wts(nd),var(nt)
      complex xc(nd,2),xr(nd,nt),xp(nd,nt),work(*),pctf(2,*),
     &        z(nchemx,2,*),sig_s(2,2,*),
     &        sig_e(nchemx,nchemx,*),sig_r(2,2)
      logical lrbst,lomit(nd)

ccc   ==> input: prediciton channels (PC FCs) in xc
ccc              raw data in xr
ccc              predicted data from Huber weights TF in xp
ccc              estimates of local noise variances in var
ccc              the usual array info stuff (nsta, ih, orient, etc)

ccc   - do final weighted RR estimate
ccc   - change coordinates
ccc   - calculate quantities needed for error bars

ccc   do weights etc. separtely for each station/group
      do k = 1,ngrp
ccc      first calculate weights for each FC vector

         nch = igrp(1,k)
         nche = nch-2
         iw1 = 2*nd+1
         iw2 = iw1 + nch*nd
         iw3 = iw2 + nch*nd
         iw4 = iw3 + 2*nt
         iw5 = iw4 + 4
         iw6 = iw5 + nch*nch

         if(lrbst) then
            call mk_wts(xr,xp,var,lomit,nch,nd,igrp(2,k),nu(k),wts)
ccc         (note still not accounting for "isolated point cleaning"
ccc         in error calculation)
         else
ccc         weights are just ones ...
            do i = 1,nd
               wts(i) = 1.
            enddo
            nu(k) = nd
            nomit = 0
         endif

ccc      multiply all channels in group (plus predictors by weights)
ccc      (also sorts out desired predicted channels ... so call even
ccc        for non-robust case)
         call mult_wts(xc,work,xp,work(iw1),igrp(2,k),nch,nd,wts)

ccc      do standard LS on this modified data, returning TFs
ccc      (ref to local) in array pctf
ccc      calling with max # of iterations set to zero; just LS fit of
ccc      (already) weighted data
         nomit = nd-nu(k)
         call rbstreg(work,work(iw1),work(iw2),nd,2,nch,pctf
     &      ,work(iw3),work(iw6),work(iw5),sig_r,0,icvg,nomit)

ccc      calculate RR TFs; matrices needed for error scalcs
         call mt_tran_err(pctf,work(iw1),nd,nch,nu(k),sig_r,
     &       nche,z(1,1,k),sig_e(1,1,k),sig_s(1,1,k))
      enddo     !  do k = 1,ngrp

      return
      end
c______________________________________________________________________
c
      subroutine mk_wts(xr,xp,var,lomit,nch,nd,igrp,nu,wts)
      integer nch,nd,igrp(nch)
      include 'nstamx.inc'
      complex xr(nd,*),xp(nd,*)
      real wts(nd),var(*),scale(nchmx)
      logical lomit(nd)
ccc   INPUT: raw data, predicted data, variances, for nch
ccc          channels of data (one station);
ccc          lomit = logical array; true to omit data a priori
ccc   OUTPUT: weights, "cleaned up" data (for cases where bad
ccc           data is in only one channel
ccc           The cleaned data to be used is in XP; the weights are in
ccc           WTS
ccc   HOW?  each channel for which complex errors exceed r1 sds (average
ccc         between real and imaginary parts) is replaced by prediction
ccc         If the number of channels replaced exceeds nbadmx,
ccc         the overall weight for the data vector is set to 0.
ccc
      parameter (r1 = 2.)
      nbadmx = max(1,nint(float(nch)/3.))

      do j = 1,nch
         scale(j) = sqrt(var(igrp(j)))*r1
      enddo

      nu = 0
      do i = 1,nd
         nbad = 0
         do k = 1,nch
            j = igrp(k)
            if(abs(xr(i,j)-xp(i,j)).gt.scale(k)) then
               nbad = nbad + 1
ccc            use prediction instead of data
            else
ccc            use raw data
               xp(i,j) = xr(i,j)
            endif
         enddo
         if((nbad.gt.nbadmx).or.lomit(i)) then
            wts(i) = 0.0
         else
            nu = nu + 1
            wts(i) = 1.0
         endif
      enddo
      return
      end
c______________________________________________________________________
c
      subroutine mult_wts(xc,xcw,xp,xpw,igrp,nch,nd,wts)
      integer nd,nch,igrp(nch)
      complex xc(nd,2),xcw(nd,2),xp(nd,nch),xpw(nd,nch)
      real wts(nd)

      do i = 1,nd
         do j = 1,2
            xcw(i,j) = wts(i)*xc(i,j)
         enddo
         do k = 1,nch
            j = igrp(k)
            xpw(i,k) = wts(i)*xp(i,j)
         enddo
      enddo
      return
      end
c______________________________________________________________________
c
      subroutine mt_tran_err(pctf,xp,nd,nch,nu,rrinv,nche,z,sig_e,
     &   sig_s)
      include 'nstamx.inc'
      complex pctf(2,nch),z(nchemx,2),sig_e(nchemx,nchemx),htf(2,2),det,
     &    sig_s(2,2),xp(nd,nch),rrinv(2,2),cdotc

ccc   updated version of mt_tran, with improved error estimates
ccc   ( ... mt_tran is WRONG)
ccc   ==> takes Remote TFs as input in pctf, rrinv,
ccc       along with reference, data series
ccc   <== Outputs: (1) Z (nche TFs relating final nche channels to
ccc                    first two),
ccc                (2) SIG_E (residual covariance for RR TFs)
ccc                (3) SIG_S (coherent signal power matrix ...
ccc                     [RH]inv [RR] [HR]inv

      det=pctf(1,1)*pctf(2,2)-pctf(1,2)*pctf(2,1)
      if(abs(det).eq.(0.)) go to 60
      htf(1,1)=pctf(2,2)/det
      htf(2,2)=pctf(1,1)/det
      htf(1,2)=-pctf(1,2)/det
      htf(2,1)=-pctf(2,1)/det

      do i = 1,2
         do j = 1,2
         sig_s(i,j) = 0.0
            do k = 1,2
               do l = 1,2
                  sig_s(i,j) = sig_s(i,j)
     &                 + htf(i,k)*rrinv(k,l)*conjg(htf(j,l))
               enddo
            enddo
         enddo
         do j = 1,nche
            z(j,i) = 0.0
            do k = 1,2
               z(j,i) = z(j,i) + htf(i,k)*pctf(k,j+2)
            enddo
         enddo
      enddo

ccc   calculate residual covariance
ccc   first compute residuals to RR fit
      do j = 1,nche
         do i = 1,nd
            do k = 1,2
               xp(i,j+2) = xp(i,j+2) - z(j,k)*xp(i,k)
            enddo
         enddo
      enddo
ccc   now form residual cross-product matrix
      do i = 1,nche
         do j = 1,i
            sig_e(i,j) = cdotc(nd,xp(1,j+2),1,xp(1,i+2),1)/nu
            if(i.ne.j) sig_e(j,i) = conjg(sig_e(i,j))
         enddo
      enddo
      return

60    continue
      write(0,*) 'Determinant is zero!!!!'
      do i = 1,2
         do j = 1,nche
            z(i,j) = (-999.,-999.)
         enddo
         do j = 1,2
            sig_s(i,j) = (0.,0.)
         enddo
      enddo
      return

      end
c______________________________________________________________________
c
      subroutine wrt_pctf(iou_pctf,nt,ns,pctf,cov,xxinv,nf,period)
      complex pctf(2,nt),cov(ns),xxinv(2,2)
      real period
      integer nf
      write(iou_pctf) period,nf,nt,ns
      write(iou_pctf) pctf,xxinv,cov
      return
      end
ccc_____________________________________________________________________
ccc
      subroutine adj_res(cov,pctf,var,nt,y,n1,i1,a)
ccc   adjusts residual covariance to correct for the effect
ccc   of projection of a portion of noise space into predicted
ccc   data vectors before computation of residuals

ccc   THIS IS AN APPROXIMATE (and ad-hoc) CORRECTION
ccc   Idea:  for the correction assume a diagonal error
ccc    covariance calculate the effect on the residual covariance
ccc    and then add this to the covariance

      complex y(n1,2),cov(*),pctf(2,nt),a(nt,nt)
      real var(nt)
      integer nt,k,l,i1(n1)

ccc   construnct array prediction filter
      do j = 1,nt
         do i = 1,nt
            a(i,j) = (0.,0.)
         enddo
      enddo
      do j = 1,n1
         scale = 1./sqrt(var(i1(j)))
         do i = 1,nt
            do l = 1,2
              a(i,j) = a(i,j) + pctf(l,i)*y(i1(j),l)
            enddo
            a(i,j) = a(i,j) * scale
         enddo
      enddo

ccc   add correction to error covariance
      ii = 0
      do i = 1,nt
         do j = 1,i
            ii = ii + 1
            cov(ii) = cov(ii) - a(i,j)*var(j) - conjg(a(j,i))*var(j)
            do l = 1,nt
               cov(ii) = cov(ii) + a(i,l)*var(l)*conjg(a(j,l))
            enddo
         enddo
      enddo
      return
      end


!
!     -------------------------------------------------------------
!      C 1 E 0 S M
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF FOLLOWING              *
!                                                 ---         ---  *
!                                                 I  Q   1  C   I  *
!     CLEBSCH - GORDAN COEFFICIENT:               I             I  *
!                                                 I  QM  0  CM  I  *
!                                                 ---         ---  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                          December 1993   *
!
      SUBROUTINE C1E0SM(Q, QM, C, CM, A)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  07:48:27  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE) , INTENT(IN) :: Q
      REAL(DOUBLE) , INTENT(IN) :: QM
      REAL(DOUBLE) , INTENT(IN) :: C
      REAL(DOUBLE) , INTENT(IN) :: CM
      REAL(DOUBLE) , INTENT(OUT) :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IIQ, IIC, IS, IG
!-----------------------------------------------
      A = ZERO
      IIQ = TWO*Q + TENTH
      IIC = TWO*C + TENTH
      IF (ITTK(IIQ,IIC,2) == 0) RETURN
      IF (ABS(QM - CM) <= EPS) THEN
         IF (Q + TENTH >= ABS(QM)) THEN
            IF (C + TENTH >= ABS(CM)) THEN
               IF (ABS(QM) > EPS) GO TO 5
               IS = Q + C + ONE + TENTH
               IF ((IS/2)*2 /= IS) GO TO 4
    5          CONTINUE
               IG = Q - C + TWO + TENTH
               IF (IG > 0) THEN
                  IF (IG <= 3) THEN
                     SELECT CASE (IG)
                     CASE DEFAULT
                        A = -SQRT(((C + CM + ONE)*(C - CM + ONE))/((C + ONE)*(&
                           TWO*C + THREE)))
                        RETURN
                     CASE (2)
                        A = CM/SQRT(C*(C + ONE))
                        RETURN
                     CASE (1)
                        A = SQRT(((C + CM)*(C - CM))/((TWO*C - ONE)*C))
                        RETURN
                     END SELECT
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
      ENDIF
    4 CONTINUE
      A = ZERO
      RETURN
      END SUBROUTINE C1E0SM


C ================================================================
      Subroutine FEM3Dext(XY1, XY2, XY3, XY4,
     &                    lbE, lbF, lbR, lbP, DDATA, IDATA, iSYS,
     &                    LDA, A, F, nRow, nCol,
     &                    templateR, templateC)
C ================================================================
      Include 'fem3Dtet.fd'
      Include 'assemble.fd'

C ================================================================
      Real*8  XY1(*), XY2(*), XY3(*), XY4(*)

      Integer lbE, lbF(4), lbR(6), lbP(4)
      Real*8  DDATA(*)
      Integer IDATA(*), iSYS(*)

      Real*8  A(LDA, *), F(*)
      Integer templateR(*), templateC(*)

C Local variables
      Integer  Ddiff, Dconv, Drhs, Dbc
      External Ddiff, Dconv, Drhs, Dbc

      Real*8   XYP(3, 4)
      Real*8   x, y, z, eBC(1)

C ================================================================
      nRow = 10
      nCol = 10

c ... set up templates
      Do i = 1, 4
         templateR(i) = Vdof
      End do
      Do i = 1, 6
         templateR(i+4) = Rdof
      End do

      Do k = 1, nCol
         templateC(k) = templateR(k)
      End do

c ... compute the stiffness matrix
      Do i = 1, 3
         XYP(i, 1) = XY1(i)
         XYP(i, 2) = XY2(i)
         XYP(i, 3) = XY3(i)
         XYP(i, 4) = XY4(i)
      End do

      label = lbE

      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              GRAD, FEM_P2, GRAD, FEM_P2,
     &              label, Ddiff, DDATA, IDATA, iSYS, 5,
     &              LDA, A, ir, ic)

c ... compute right hand side
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              IDEN, FEM_P0, IDEN, FEM_P2,
     &              lbE, Drhs, DDATA, IDATA, iSYS, 5,
     &              LDA, F, ir, ic)

c ... impose boundary conditions (assume nRow = nCol) at nodes of triangle
      Do k = 1, 4
         If(lbP(k).ne.0) Then
            If(k.EQ.1) Then
               x = XY1(1)
               y = XY1(2)
               z = XY1(3)
            ElseIf(k.EQ.2) Then
               x = XY2(1)
               y = XY2(2)
               z = XY2(3)
            ElseIf(k.EQ.3) Then
               x = XY3(1)
               y = XY3(2)
               z = XY3(3)
            ElseIf(k.EQ.4) Then
               x = XY4(1)
               y = XY4(2)
               z = XY4(3)
            End if

c  ...  Dbc may change iSYS
            ibc = Dbc(x, y, z, lbP(k), DDATA, IDATA, iSYS, eBC)

            If(ibc.EQ.BC_DIRICHLET) Then
               Call applyDIR(LDA, nRow, A, F, k, eBC(1))
              !  write(*,*) iSYS(3),iSYS(5)
!               do i=1,10
    !           write(*,*) (A(i,k),i=1,10), F(k)

            End if
         End if
      End do
!edge bc
      k = 0
      Do i = 1, 3
         Do j = i + 1, 4
            k = k + 1

            If( (lbP(i).GT.0 .AND. lbP(j).GT.0) ) Then
               x = (XYP(1, i) + XYP(1, j)) / 2
               y = (XYP(2, i) + XYP(2, j)) / 2
               z = (XYP(3, i) + XYP(3, j)) / 2

c  ...  Dbc will change iSYS(1:2)
               lbc = min( lbP(i), lbP(j) )
!               If (lbc.eq.9.and.x.le.0d0) lbc = 3 ! reset label for edge on inhomogeneous Dirichlet face
               ibc = Dbc(x, y, z, lbc, DDATA, IDATA, iSYS, eBC)

               If(ibc.EQ.BC_DIRICHLET) Then
                  Call applyDIR(LDA, nRow, A, F, k+4,  eBC(1))
                End if
            End if
         End do
      End do

      Return
      End

C ======================================================================
C  Diffusion tensor
C ======================================================================
      Integer Function Ddiff(x, y, z, label, DDATA, IDATA, iSYS, Coef)
      include 'fem3Dtet.fd'

      Real*8  x, y, z, DDATA(*), Coef(1, 1)
      Integer label, IDATA(*), iSYS(*)
C ======================================================================
      iSYS(1) = 1
      iSYS(2) = 1

       Coef(1, 1) = 1.0
      Ddiff = TENSOR_SCALAR

      Return
      End

C ======================================================================
C Boundary condition
C ======================================================================
      Integer Function Dbc(x, y, z, label, DDATA, IDATA, iSYS, eBC)
      Include 'assemble.fd'
C ======================================================================
      Real*8  x, y, z, DDATA(*), eBC(*)
      Integer label, IDATA(*), iSYS(*)

C ======================================================================
      real*8 M_PI
      M_PI = 3.14159265358979323846
      iSYS(1) = 1
      iSYS(2) = 1

      Dbc = BC_DIRICHLET
      eBC(1)  = sin(M_PI*x)*sin(M_PI*y)*sin(M_PI*z) !/(3*M_PI*M_PI)

      Return
      End

C ======================================================================
C Right hand side
C ======================================================================
      Integer Function Drhs(x, y, z, label, DDATA, IDATA, iSYS, F)
      Include 'fem3Dtet.fd'
C ======================================================================
      Real*8  x, y, z, DDATA(*), F(*)
      Integer label, IDATA(*), iSYS(*)

C ======================================================================
      Real*8 M_PI
       M_PI = 3.14159265358979323846
      iSYS(1) = 1
      iSYS(2) = 1

      F(1) = sin(M_PI*x)*sin(M_PI*y)*sin(M_PI*z)*(3*M_PI*M_PI)
      Drhs = TENSOR_SCALAR

      Return
      End


      subroutine durhamalg(p,npartons,y32,y43,z3,z4,z5,z6)
      implicit none
c--- Given a set of 4-vectors, determine the values of the parameters
c--- y32 and y43 at which the event is described in terms of a 2-jet
c--- and 3-jet event, respectively.
c--- Also returns the energy fractions of the jets (z3,z4,z5,z6)
c--- If there are at most 3 jets, returns <0 for y43 and for z6
c--- If there are at most 2 jets, returns <0 for y32 and for z5
      include 'constants.f'
      double precision p(mxpart,4),q(mxpart,4),r(mxpart,4),
     . y32,y43,z3,z4,z5,z6,yij,M
      integer npartons,i,j,imin,jmin,icount

      if     (npartons .gt. 4) then
        write(6,*) 'Too many partons for this version of the Durham'
        write(6,*) 'algorithm; at most 4 are allowed.'
        stop
      elseif (npartons .lt. 2) then
        write(6,*) 'Too few partons for this version of the Durham'
        write(6,*) 'algorithm; need at least 2.'
        stop
      endif

      y43=-1d0
      y32=-1d0
      z6=-1d0
      z5=-1d0

c--- skip to 2-parton section if there are only 2 partons
      if (npartons .eq. 2) then
        do i=3,4
        do j=1,4
        r(i,j)=p(i,j)
        enddo
        enddo
        goto 33
      endif

c--- skip to 3-parton section if there are only 3 partons
      if (npartons .eq. 3) then
        do i=3,5
        do j=1,4
        q(i,j)=p(i,j)
        enddo
        enddo
        goto 22
      endif

c--- find lowest yij amongst 4 jets
      y43=0d0

      do i=3,5
      do j=i+1,6
        yij=(p(i,1)*p(j,1)+p(i,2)*p(j,2)+p(i,3)*p(j,3))
     .      /dsqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
     .      /dsqrt(p(j,1)**2+p(j,2)**2+p(j,3)**2)
        yij=2d0*min(p(i,4),p(j,4))**2*(1d0-yij)
        if ((yij .lt. y43) .or. ((i.eq.3) .and. (j.eq.4))) then
          imin=i
          jmin=j
          y43=yij
        endif
      enddo
      enddo

      z6=min(p(3,4),p(4,4),p(5,4),p(6,4))

c--- make momenta for 3-jet event by adding 4-vectors
c---  (NO LONGER use P scheme, i.e. add 3 vectors
c---  and rescale energy to make massless)
      icount=3
      do i=3,6
      do j=1,4
        if     (i .eq. imin) then
        q(icount,j)=p(imin,j)+p(jmin,j)
        elseif (i .eq. jmin) then
        continue
        else
          q(icount,j)=p(i,j)
        endif
      enddo
      if (i .ne. jmin) icount=icount+1
      enddo

c      do i=3,5
c        q(i,4)=dsqrt(q(i,1)**2+q(i,2)**2+q(i,3)**2)
c      enddo

c--- cluster into 3 jets
   22 continue

c--- find lowest yij amongst 3 jets
      y32=0d0

      do i=3,4
      do j=i+1,5
        yij=(q(i,1)*q(j,1)+q(i,2)*q(j,2)+q(i,3)*q(j,3))
     .      /dsqrt(q(i,1)**2+q(i,2)**2+q(i,3)**2)
     .      /dsqrt(q(j,1)**2+q(j,2)**2+q(j,3)**2)
        yij=2d0*min(q(i,4),q(j,4))**2*(1d0-yij)
        if ((yij .lt. y32) .or. ((i.eq.3) .and. (j.eq.4))) then
          imin=i
          jmin=j
          y32=yij
        endif
      enddo
      enddo

      z5=min(q(3,4),q(4,4),q(5,4))

c--- make momenta for 3-jet event by adding 4-vectors
c---  (NO LONGER use P scheme, i.e. add 3 vectors
c---  and rescale energy to make massless)
      icount=3
      do i=3,5
      do j=1,4
        if     (i .eq. imin) then
        r(icount,j)=q(imin,j)+q(jmin,j)
      elseif (i .eq. jmin) then
        continue
      else
        r(icount,j)=q(i,j)
      endif
      enddo
      if (i .ne. jmin) icount=icount+1
      enddo

c      do i=3,4
c        r(i,4)=dsqrt(r(i,1)**2+r(i,2)**2+r(i,3)**2)
c      enddo

c--- now we have 2 jets
   33 continue

      z4=min(r(3,4),r(4,4))
      z3=max(r(3,4),r(4,4))

c--- Now rescale all properties by onium mass (M) appropriately
      M=-p(1,4)-p(2,4)

      y43=y43/M**2
      y32=y32/M**2

      z3=2d0*z3/M
      z4=2d0*z4/M
      z5=2d0*z5/M
      z6=2d0*z6/M

      return
      end