      subroutine qpot(m1,x,w,Ntraj,qp,qfx)
      implicit real*8(a-h,o-z)
      integer*4,intent(IN) :: Ntraj

      integer INFO
      integer, parameter :: nb=4
      real*8,intent(IN) :: m1
      real*8,intent(IN) :: w(Ntraj),x(Ntraj)
      real*8, intent(OUT) :: qfx(Ntraj),qp(Ntraj)
      real*8 :: rx(ntraj)
      real*8 :: f(nb),s(nb,nb),c(nb,1)

! define c matrix = -1/2*df/dx
      c(1,1) =-0.5d0
      c(2,1) = 0d0
      c(3,1) = 0d0

      do i=1,ntraj
        c(2,1) = c(2,1)+w(i)*2d0*x(i)
        c(3,1) = c(3,1)+w(i)*3d0*x(i)**2
      enddo

      c(2,1) = -0.5d0*c(2,1)
      c(3,1) = -0.5d0*c(3,1)
      c(4,1) = 0d0

!     f*transpose(f) matrix
      s=0d0
      do i=1,Ntraj
      f=(/x(i),x(i)**2,x(i)**3,1d0/)
        do m=1,nb
          do n=1,nb
            s(m,n)=w(i)*f(m)*f(n)+s(m,n)
          end do
        end do
      end do

! calculate matrix c(t)
        call DPOSV('U',nb,1,s,nb,c,nb,INFO)
        if(INFO/=0) then
        print *, "info=",info
        print *, "matrix fails"
        stop
        end if

! the momentum operator r=cf
      ams = -1d0/2d0/m1
      do i=1,Ntraj
        rx(i) = c(1,1)*x(i)+c(2,1)*x(i)**2+c(3,1)*x(i)**3+c(4,1)

! calculate quantum potential
        dr = c(1,1)+2d0*c(2,1)*x(i)+c(3,1)*3d0*x(i)**2
        qp(i)=ams*(rx(i)**2+c(1,1)+c(2,1)*2d0*x(i)+c(3,1)*3d0*x(i)**2)
        qfx(i)=-ams*(2d0*rx(i)*dr+2d0*c(2,1)+c(3,1)*6d0*x(i))

      end do

      return
      end subroutine


      subroutine compute_average_stress()
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Author : Sai Rapaka
!

      use comai, only: nei, neq
      use combi, only: nelm
      use comdi, only: phi
      use comsi, only: bulk, e2, e3, ispm, ispmt
      use comfem

      implicit none

      integer                            :: el, j, n1, n2, n
      integer                            :: node_I, node_J
      integer                            :: iispmd, jispmd
      integer                            :: model_I, model_J
      integer                            :: permmodel

      real*8, dimension(6)               :: intsig
      real*8, dimension(6)               :: avg_stress
      real*8                             :: onedV, fac, biot
      real*8                             :: mean_stress, P_ij
      real*8                             :: eff_stress, xperm
      real*8                             :: bulki, bulkj, bulkbar
      real*8                             :: harmonic_mean

      if(.not. allocated(edgeNum1)) then
        call setup_edgePointers_3D()
      endif

      permFactor = 0.0d0

      do el=1,nei

        avg_stress = 0.0d0
        intsig = 0.0d0
        onedV = 0.0d0

        do j=1,numgausspoints
          fac = detJ(el,j)*gpweight(j)
          intsig = intsig + fem_stress(el,j,:)*fac
          onedV = onedV + fac
        enddo

        avg_stress = intsig/onedV
        mean_stress = sum(avg_stress(1:3))/3.0d0

        do n=1, 12
          node_I = elnode(el, edges(n, 1))
          node_J = elnode(el, edges(n, 2))

          P_ij = 0.5d0*(phi(node_I) + phi(node_J))
          biot = 0.5d0*(bulk(node_I) + bulk(node_J))

          bulki = 3.0d0*e2(node_I) + 2.0d0*e3(node_I)
          bulkj = 3.0d0*e2(node_J) + 2.0d0*e3(node_J)
          bulkbar = harmonic_mean(bulki, bulkj)

          eff_stress = mean_stress + bulkbar*biot*P_ij

        enddo
      enddo

      end subroutine compute_average_stress


      DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,Sf,Al,Be,Ak,Bk,Ag,Bg,C,D,
     &   E,Es)
      IMPLICIT NONE
      DOUBLE PRECISION Ag , Ak , Al , Be , Bg , Bk , C , D , ds , E ,
     &                 Es , lx , S , Sf , sx , X
      SAVE

      IF ( S.LE.Sf ) THEN
         PHO_DORGFS = 0.0
      ELSE
         sx = SQRT(X)
         lx = LOG(1./X)
         ds = S - Sf
         PHO_DORGFS = (ds*X**Ak*(Ag+Bg*sx+C*X**Bk)
     &                +ds**Al*EXP(-E+SQRT(Es*S**Be*lx)))*(1.-X)**D

      END IF
      END FUNCTION


! ============================ Module Description ===========================
! imexsdc_mod Implementation of IMEXSDC method. Contains a 2 subroutines:
!   1. imexsdc  - IMEXSDC timestepping code
!   2. initIM   - initializes Integration Matrix
! ===========================================================================

module imexsdc_mod

    ! Module Parameters
    use omp_lib
    use tools_mod, only: dp, tic, toc, weights
    implicit none
    type imexsdc_settings
        integer :: m
        real(dp), allocatable :: tau(:)
    end type imexsdc_settings

    contains

    ! =======================================================================
    ! IMEXSDC   Implements ETDSDC Numerical Time Integrator
    !
    ! Arguments
    !
    !   L       (input) COMPLEX*16 array, dimension(n)
    !           vector cooresponding to PDE linear operator
    !
    !   N       (input) SUBROUTINE:
    !           cooresponds to PDE nonlinear operator. Must be of the form:
    !               subroutine N(t,y_in,N_out)
    !                   real(kind=8),    intent(in)  :: t
    !                   complex(kind=8), intent(in)  :: y_in(:)
    !                   complex(kind=8), intent(out) :: N_out(:)
    !               end subroutine N
    !
    !   tspan   (input) DOUBLE array, dimension(2)
    !           contains left and right integration bounds
    !
    !   y_in    (input) COMPLEX*16 array, dimension (N)
    !           Initial condition.
    !
    !   options (input) ETDSDC_SETTINGS
    !           derived data type that contains one field:
    !               options%tau : DOUBLE (quadrature points)
    !
    !   y_out   (output) COMPLEX*16 array, dimension (N)
    !           Initial condition.
    !
    !   times   (output) DOUBLE array, dimension(4)
    !           times(1:2) = [cputime,clocktime] for timestepping loop
    !           times(3:4) = [cputime,clocktime] for initializing coefficients,
    ! =======================================================================

    subroutine imexsdc(L,N,tspan,y_in,Nt,options,y_out,times)

        ! Arguments
        complex(dp), intent(in)         :: L(:)
        real(dp),    intent(in)         :: tspan(2)
        complex(dp), intent(inout)      :: y_in(:)
        type(imexsdc_settings), intent(in)  :: options
        integer,         intent(in)         :: Nt
        real(dp),    intent(out)        :: times(4)
        complex(dp), intent(out)        :: y_out(size(y_in))
        ! define interface subroutine function N
        interface
            subroutine N(t,yh_in, N_out, thread_id)
            import :: dp
            complex(dp), intent(in)  :: t
            complex(dp), intent(in)  :: yh_in(:)
            complex(dp), intent(out) :: N_out(:)
            integer, intent(in), optional :: thread_id
            end subroutine N
        end interface

        ! Local Variables
        integer :: i,j,k,nn,m,nL
        real(dp)    :: h, eta(size(options%tau)-1), IM(size(options%tau)-1,size(options%tau))
        complex(dp) :: t
        complex(dp), allocatable :: phi(:,:), phi_n(:,:), IR(:,:),  D(:,:), n_new(:)
        real(dp), allocatable :: tau(:)
        tau = options%tau
        m   = options%m
        nn  = size(tau)
        nL  = size(L)
        h   = (tspan(2)-tspan(1))/(real(Nt,8))
        t   = tspan(1)
        eta = tau(2:nn) - tau(1:nn-1)
        allocate(phi(nn,nL), phi_n(nn, nL),IR(nn-1, nL),D(nn-1,nL),n_new(nL))

        ! Initialize Integration Matrix & Constants
        call tic()
        call initIM(h,tau,IM)
        do i=1,nn-1
            do j=1,nL
                D(i,j) = (1.d0 - h*(eta(i))*L(j))
            enddo
        enddo
        call toc(times(3:4))

        ! timestepping loop
        call tic()
        phi(1,:) = y_in
        do i=1,Nt
            ! Euler step
            do j=1,nn-1
                call N(t + h*tau(j),phi(j,:),phi_n(j,:))
                phi(j+1,:) = (phi(j,:) + h*eta(j)*phi_n(j,:))/D(j,:)
            enddo
            call N(t + h*tau(nn),phi(nn,:),phi_n(nn,:))
            ! Correction Sweeps
            do k=1,m
                !$omp parallel do
                do j=1,nL
                    IR(:,j) = matmul(IM,L(j)*phi(:,j)+phi_n(:,j))
                enddo
                phi(2,:) = (phi(1,:) - h*eta(1)*L*phi(2,:) + IR(1,:))/D(1,:)
                do j=2,nn-1
                    call N(t+h*tau(j),phi(j,:),n_new)
                    phi(j+1,:) = (phi(j,:) - h*eta(j)*L*phi(j+1,:) + h*eta(j)*(n_new - phi_n(j,:)) + IR(j,:))/D(j,:)
                    phi_n(j,:) = n_new;
                enddo
                if(k /= m) then
                    call N(t + h*tau(nn),phi(nn,:),phi_n(nn,:))
                endif
            enddo
            phi(1,:) = phi(nn,:)
            t = t + h
        enddo
        call toc(times(1:2))
        y_out = phi(nn,:);

    end subroutine imexsdc

    ! =======================================================================
    ! INITIM  Initializes IMEXSDC integration matrix using weights function
    !         by Fornberg.
    !
    ! Arguments
    !
    !   h   (input) DOUBLE
    !       timestep
    !
    !   tau (input) DOUBLE array, dimensions(n,1)
    !       normalized quadrature points
    !
    !   IM  (output) DOUBLE array, dimension(n-1,n)
    !       integration matrix
    ! =======================================================================

    subroutine initIM(h,tau,IM)

        ! Arguments
        real(dp), intent(in)  :: h
        real(dp), intent(in)  :: tau(:)
        real(dp), intent(out) :: IM(size(tau)-1,size(tau))

        ! Local Variables
        real(dp) :: eta(size(tau)-1)
        real(dp) :: q(size(tau))
        real(dp) :: A(size(tau),size(tau))
        real(dp) :: p0(size(tau))
        integer  :: i,j,n

        ! Form Integation Matrix
        n     = size(tau)
        eta   = tau(2:n) - tau(1:n-1)

        ! Compute phi functions for Lambda=0 (taylor terms)
        p0(1) = 1
        do j=2,n
            p0(j) = p0(j-1)/j
        enddo

        do i=1,n-1
            q = (tau - tau(i))/eta(i)                   ! scaled quadrature points
            call weights(0.d0,q,n-1,A)                  ! finite difference matrix
            IM(i,:)   = h*eta(i)*matmul(a,p0)           ! store ith row of IM matrix
        enddo
    end subroutine initIM

end module imexsdc_mod


!********************************************************************************
!   FPML_COMP: Compensated Polishing Technique for FPML based on Modified Laguerre's Method
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 31 March 2020
!********************************************************************************
module fpml_comp
	use eft
    use fpml, only : check_nan_inf, dp, main
    implicit none

contains
    !************************************************
    !           main comp                           *
    !************************************************
    subroutine main_comp(poly, deg, roots, itmax)
        ! argument variables
        integer, intent(in)             :: deg, itmax
        complex(kind=dp), intent(in)    :: poly(:)
        complex(kind=dp), intent(inout) :: roots(:)
        ! local variables
        integer                         :: i, j, nz
        real(kind=dp)                   :: alpha(deg+1), r
		complex(kind=dp)                :: b, c, z
        ! fpml variables
        integer                         :: conv(deg)
        real(kind=dp)                   :: berr(deg), cond(deg)

        ! call fpml main
        call main(poly, deg, roots, berr, cond, conv, itmax)
        ! polish root approximations
        alpha = abs(poly)
        conv = (/ (0, i=1,deg)/)
        nz = 0
        do i=1,(itmax/2)
            do j=1,deg
                if(conv(j)==0) then
                    z = roots(j)
                    r = abs(z)
                    if(r > 1.0_dp) then
						call rcheck_lag(poly, deg, b, c, z, r, conv(j))
                    else
						call check_lag(poly, deg, b, c, z, r, conv(j))
                    end if
                    if(conv(j)==0) then
                        call modify_lag(deg, b, c, z, j, roots, conv(j))
                        roots(j) = z - c
                    else
                        nz = nz + 1
                        if(nz==deg) return
                    end if
                end if
            end do
        end do
    end subroutine main_comp
    !************************************************
    !                       rcheck_lag              *
    !************************************************
    subroutine rcheck_lag(poly, deg, b, c, z, r, conv)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        integer, intent(out)            :: conv
        real(kind=dp), intent(in)       :: r
        complex(kind=dp), intent(in)    :: poly(:), z
        complex(kind=dp), intent(out)   :: b, c
        ! local variables
        integer                         :: k
		real(kind=dp)					:: g, rr, err
        complex(kind=dp)                :: a, a_err, b_err, c_err, zz
        type(CEFTSum)                   :: sum
        type(CEFTProd)                  :: prod
        ! intrinsic functions
        intrinsic                       :: abs

        ! evaluate polynomial and derivatives
        zz = 1/z
        rr = 1/r
        a = poly(1)
        a_err = cmplx(0.0_dp,0.0_dp,kind=dp)
        b = cmplx(0.0_dp,0.0_dp,kind=dp)
        b_err = cmplx(0.0_dp,0.0_dp,kind=dp)
        c = cmplx(0.0_dp,0.0_dp,kind=dp)
        c_err = cmplx(0.0_dp,0.0_dp,kind=dp)
		err = 0.0_dp
        do k=2,deg+1
            ! product and sum for c
            prod = TwoProductCplx(c,zz)
            sum = TwoSumCplx(prod%p,b)
            ! update c and c_err
            c = sum%x
            c_err = zz*c_err + b_err + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            ! product and sum for b
            prod = TwoProductCplx(b,zz)
            sum = TwoSumCplx(prod%p,a)
            ! update a and a_berr
            b = sum%x
            b_err = zz*b_err + a_err + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            ! product and sum for a
            prod = TwoProductCplx(a,zz)
            sum = TwoSumCplx(prod%p,poly(k))
            ! update a and a_err
            a = sum%x
            a_err = zz*a_err + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            ! update error bound
            err = rr*err + FaithSum(abs(prod%e),abs(prod%f),abs(prod%g),abs(sum%y))
        end do
        ! add error back into result
        c = c + c_err
        b = b + b_err
        a = a + a_err
        ! berr
        g = (4*deg+2)*sqrt(2.0_dp)*eps/(1-eps)
        g = g/(1-g)
		err = mu*abs(a) + (g*err + 2*mu**2*abs(a))
		! laguerre correction terms/ convergence
		if(abs(a)>err) then
            b = b/a
            c = 2*(c/a)
            c = zz**2*(deg-2*zz*b+zz**2*(b**2-c))
            b = zz*(deg-zz*b)
            if(check_nan_inf(b) .or. check_nan_inf(c)) conv = -1
		else
			conv = 1
		end if
    end subroutine rcheck_lag
    !************************************************
    !                       check_lag              	*
    !************************************************
    subroutine check_lag(poly, deg, b, c, z, r, conv)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        integer, intent(out)            :: conv
        real(kind=dp), intent(in)       :: r
        complex(kind=dp), intent(in)    :: poly(:), z
        complex(kind=dp), intent(out)   :: b, c
        ! local variables
        integer                         :: k
		real(kind=dp)					:: g, err
        complex(kind=dp)                :: a, a_err, b_err, c_err
        type(CEFTSum)                   :: sum
        type(CEFTProd)                  :: prod
        ! intrinsic functions
        intrinsic                       :: abs

        ! evaluate polynomial and derivatives
        a = poly(deg+1)
        a_err = cmplx(0.0_dp,0.0_dp,kind=dp)
        b = cmplx(0.0_dp,0.0_dp,kind=dp)
        b_err = cmplx(0.0_dp,0.0_dp,kind=dp)
        c = cmplx(0.0_dp,0.0_dp,kind=dp)
        c_err = cmplx(0.0_dp,0.0_dp,kind=dp)
		err = 0.0_dp
        do k=deg,1,-1
            ! product and sum for c
            prod = TwoProductCplx(c,z)
            sum = TwoSumCplx(prod%p,b)
            ! update c and c_err
            c = sum%x
            c_err = z*c_err + b_err + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            ! product and sum for b
            prod = TwoProductCplx(b,z)
            sum = TwoSumCplx(prod%p,a)
            ! update b and b_err
            b = sum%x
            b_err = z*b_err + a_err + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            ! product and sum for a
            prod = TwoProductCplx(a,z)
            sum = TwoSumCplx(prod%p,poly(k))
            ! update a and a_err
            a = sum%x
            a_err = z*a_err + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            ! update berr
            err = r*err + FaithSum(abs(prod%e),abs(prod%f),abs(prod%g),abs(sum%y))
        end do
        ! add error back into result
        c = c + c_err
        b = b + b_err
        a = a + a_err
        ! berr
        g = (4*deg+2)*sqrt(2.0_dp)*eps/(1-eps)
        g = g/(1-g)
		err = mu*abs(a) + (g*err + 2*mu**2*abs(a))
		! laguerre correction terms/ convergence
		if(abs(a)>err) then
            b = b/a
            c = b**2 - 2*(c/a)
            if(check_nan_inf(b) .or. check_nan_inf(c)) conv = -1
		else
			conv = 1
		end if
    end subroutine check_lag
    !************************************************
    !                       modify_lag              *
    !************************************************
    subroutine modify_lag(deg, b, c, z, j, roots, conv)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg, j
		integer, intent(out)            :: conv
        complex(kind=dp), intent(in)    :: roots(:), z
        complex(kind=dp), intent(inout) :: b, c
        ! local variables
        integer                         :: k
        complex(kind=dp)                :: t
        ! intrinsic functions
        intrinsic                       :: abs, sqrt

        ! Aberth correction terms
        do k=1,j-1
            t = 1/(z - roots(k))
            b = b - t
            c = c - t**2
        end do
        do k=j+1,deg
            t = 1/(z - roots(k))
            b = b - t
            c = c - t**2
        end do
        ! Laguerre correction/ convergence
        t = sqrt((deg-1)*(deg*c-b**2))
        c = b + t
        b = b - t
        if(abs(b)>abs(c)) then
            c = deg/b
        else
            c = deg/c
        end if
		if(abs(c) <= mu*abs(z)) conv = 1
    end subroutine modify_lag
end module fpml_comp


module sunshade

use real_precision

contains

subroutine SET_GOUD_PARAMS()
real(dp) :: soilalbedo,leafalbedo,kbeam,kdiff,m,kbeamstar,canopyalbedo
common /GOUD_PARAMS/soilalbedo,leafalbedo,kbeam,kdiff,m,kbeamstar,canopyalbedo

soilalbedo = 0.15
leafalbedo = 0.15
kbeam = 0.5
kdiff = 0.66
m = sqrt(1.0-leafalbedo)
kbeamstar = m*kbeam
canopyalbedo=2.0*kbeam/(kbeam+kdiff)*(1.0-m)/(1.0+m)

end subroutine SET_GOUD_PARAMS

subroutine GOUDRIAANSLAW2(lyr,lai,beamrad,diffrad,fsunlit,qsunlit,fshade,qshade, &
 soilalbedo,leafalbedo,kbeam,kdiff,m,kbeamstar,canopyalbedo,albedobeam,albedodiff)
implicit none

real(dp) :: lyr,lai,beamrad,diffrad,fsunlit,qsunlit,fshade,qshade
real(dp) :: soilalbedo,leafalbedo,kbeam,kdiff,m,kbeamstar,canopyalbedo,albedobeam,albedodiff

! soilalbedo: value from Wang
! leafalbedo: leaf transmittance and reflectance are equal. Then albedo is the double
! kbeam: extinction coefficent of the direct beam
! kdiff: extinction coefficient of diffuse radiations
! I found somewhere an approximate relation: kbeam=0.75*kdiff
!... hum, I don't know if albedodiff is REAL*8ly different or not... so equal

qshade=(1.0-albedodiff)*diffrad*kdiff*exp(-kdiff*lyr) &
 +(1.0-albedobeam)*beamrad*kbeam*exp(-kbeam*lyr) &
 -(1.0-leafalbedo)*beamrad*kbeamstar*exp(-kbeamstar*lyr)
if (qshade<0.0) qshade=0.0

qsunlit=(1.0-leafalbedo)*kbeamstar*beamrad+qshade

fsunlit=exp(-kbeam*lyr)
fshade=1-fsunlit

return
end subroutine GOUDRIAANSLAW2

subroutine GOUDRIAANSLAW(lyr,lai,beamrad,diffrad,fsunlit,qsunlit,fshade,qshade)
implicit none

real(dp) :: lyr,lai,beamrad,diffrad
real(dp) :: fsunlit,qsunlit,fshade,qshade

real(dp) :: soilalbedo,leafalbedo,canopyalbedo
real(dp) :: albedobeam,albedodiff
real(dp) :: m
real(dp) :: kbeam,kdiff,kbeamstar

!value from Wang
soilalbedo=0.15
!leaf transmittance and reflectance are equal. Then albedo is the double
leafalbedo=2.0*0.075

!extinction coefficent of the direct beam
kbeam=0.5
!extinction coefficient of diffuse radiations
kdiff=0.66
!I found somewhere an approximate relation: kbeam=0.75*kdiff

m=sqrt(1.0-leafalbedo)
kbeamstar=m*kbeam

canopyalbedo=2.0*kbeam/(kbeam+kdiff)*(1.0-m)/(1.0+m)
albedobeam=canopyalbedo+(soilalbedo-canopyalbedo)*exp(-kbeam*lai)
!... hum, I don't know if albedodiff is REAL*8ly different or not... so equal
albedodiff=albedobeam

qshade=(1.0-albedodiff)*diffrad*kdiff*exp(-kdiff*lyr) &
 +(1.0-albedobeam)*beamrad*kbeam*exp(-kbeam*lyr) &
 -(1.0-leafalbedo)*beamrad*kbeamstar*exp(-kbeamstar*lyr)
if (qshade<0.0) qshade=0.0

qsunlit=(1.0-leafalbedo)*kbeamstar*beamrad+qshade

fsunlit=exp(-kbeam*lyr)
fshade=1-fsunlit

end subroutine GOUDRIAANSLAW

subroutine BEERSLAW(lyr,beamrad,diffrad,fsunlit,qsunlit,fshade,qshade)
implicit none
real(dp) :: lyr,beamrad,diffrad
real(dp) :: fsunlit,qsunlit,fshade,qshade
real(dp) :: kbeam,kdiff

!extinction coefficent of the direct beam
kbeam=0.5
!extinction coefficient of diffuse radiations
kdiff=0.66

fshade=1.0
fsunlit=0

qsunlit=0.0
qshade=beamrad*kbeam*exp(-kbeam*lyr)+diffrad*kdiff*exp(-kdiff*lyr)

end subroutine BEERSLAW

subroutine SUNFLECT(lyr,beamrad,diffrad,fsunlit,qsunlit,fshade,qshade)
implicit none
real(dp) :: lyr,beamrad,diffrad
real(dp) :: fsunlit,qsunlit,fshade,qshade
real(dp) :: kbeam,kdiff

!extinction coefficent of the direct beam
kbeam=0.5
!extinction coefficient of diffuse radiations
kdiff=0.66

fsunlit=0.5
fshade=0.5

qsunlit=beamrad*kbeam*exp(-kbeam*lyr)+diffrad*kdiff*exp(-kdiff*lyr)
qshade=qsunlit

end subroutine SUNFLECT

end module sunshade


! The Computer Language Benchmarks Game
! http://shootout.alioth.debian.org/
!
! Simon Geard, 6/1/05
! Modified by Waldemar Spomer, 10/1/09: openmp, one I/O

program mandelbrot
	use omp_lib
	implicit none
	integer N, x, y, bit_num, i, incr, width_bytes
	integer(kind=1) byte_acc, state, mask, res, maskbita, maskbitb
	integer(kind=1), parameter :: K0 = 0, K1 = 1
	integer, parameter :: iter = 50
	real*8, parameter  :: limit2 = 4.0d0
	double precision :: absZ1, absZ2, invert
	character(len=8) argv
	complex(kind=8) Z1, Z2, C1, C2
	logical in_mandelbrot
	! Modified to use pointers
	character(len=1), pointer, dimension(:) :: whole_data, pdata
	double precision, dimension(1:2) :: m1, m2 ! for mask

	nullify(pdata, whole_data)

	call getarg(1,argv)
	read(argv,*) N

	allocate(whole_data(N**2/8),STAT=state)
	! Output pbm header
	write(*,'(a)') 'P4'
	write(*,'(i0,a,i0)') N,' ',N

	width_bytes = ishft(N,-3)
	invert = 2.0d0/N
	! Modified
	!$omp parallel default(private) shared(whole_data,N,width_bytes,invert)
	!$omp do schedule(dynamic)
	do y=1,N-1
		bit_num = 0
		byte_acc = K0
		! Adopted form c++ example
		pdata => whole_data((y-1)*width_bytes:(y)*width_bytes)
		incr=0
		do x=1,N-1,2
			C1 = cmplx(x*invert-1.5d0,y*invert-1.0d0)
			C2 = cmplx((x+1)*invert-1.5d0,y*invert-1.0d0)
			Z1 = C1
			Z2 = C2
			in_mandelbrot = .true.
			res=3
			do i=1,iter

				! Adopted from C/C++ example
				Z1 = Z1**2 + C1
				Z2 = Z2**2 + C2

				absZ1 = real(Z1*conjg(Z1))
				absZ2 = real(Z2*conjg(Z2))

				if (absZ2 <= limit2 .AND. absZ1 <= limit2) then
					mask = 3
				else if (absZ2 > limit2 .AND. absZ1 <= limit2) then
					mask = 2
				else if (absZ2 <= limit2 .AND. absZ1 > limit2) then
					mask = 1
				else if (absZ2 > limit2 .AND. absZ1 > limit2) then
					mask = 0
				end if

				res = iand(res,mask)

				if (res==0) exit
			end do

			bit_num = bit_num + 2
			byte_acc = ior(ishft(byte_acc,2),res)

			if (bit_num == 8) then
				! All bits set so output them
				incr=incr+1
				pdata(incr) = char(byte_acc)
				byte_acc = K0
				bit_num = 0

			end if
		end do
	! End of a row so left-justify the bits we have and output them
	byte_acc = ishft(byte_acc,8-mod(N,8))
	pdata(incr) = char(byte_acc)

	end do
	!$omp end do nowait
	!$omp end parallel
	write(*,*) whole_data
	deallocate(whole_data)
	nullify(pdata, whole_data)
end program mandelbrot


      PROGRAM EFU
      PARAMETER(NX=2001)
      DIMENSION Y(NX), S(NX), U(NX), F(NX)
C
      PI = 4.0*ATAN(1.0)
C
      YWALL = -4.8

      YMAX  =  40.0
C
      N = NX
C
      DO I=1, N
        Y(I) = YMAX*FLOAT(I-1)/FLOAT(N-1)
      ENDDO
C
      DO I = 1, N
        S(I) = EXP(-(Y(I)+YWALL)**2)
      ENDDO
C
      I = 1
      U(I) = 0.
      F(I) = 0.
      DO I = 2, N
        DY = Y(I) - Y(I-1)
        U(I) = U(I-1) + 0.5*(S(I)+S(I-1))*DY
        F(I) = F(I-1) + 0.5*(U(I)+U(I-1))*DY
      ENDDO
      SMAX = 1.0
C
      UE = U(N)
      DO I = 1, N
        F(I) = F(I)/UE
        U(I) = U(I)/UE
        S(I) = S(I)/UE
      ENDDO
      SMAX = SMAX/UE
C
      DSUM = 0.
      TSUM = 0.
      ESUM = 0.
      DO I = 2, N
        DY =  Y(I) - Y(I-1)
        UA = (U(I) + U(I-1))*0.5
        DSUM = DSUM + (1.0 - UA   )   *DY
        TSUM = TSUM + (1.0 - UA   )*UA*DY
        ESUM = ESUM + (1.0 - UA**2)*UA*DY
      ENDDO
C
      WRITE(*,*) N, DSUM/TSUM, 1.0/(SMAX*TSUM)
      DO I = 1, N
        WRITE(*,*) Y(I)/TSUM, U(I), S(I)*TSUM
      ENDDO
C
      STOP
      END


      subroutine runCY_000000i(k,l,i1,Xtwiddle,Gtwiddle,Shat7zzzz,N0)
      implicit none
C---  Expression for C000000i obtained from 5.50, following the comment after
C     5.50 on how to add adcing adcitional "00" pairs
C---  (similar to Eq. 5.56b but with "0000" added)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7zzzz(np,z2max,-2:0)

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

      do ep=-2,0

      Cv(czzzzzzi(i1)+N0,ep)=
     . (-2d0*Gtwiddle(k,i1)*Cv(czzzzzzi(l)+N0,ep)
     . +Gtwiddle(k,1)*Shat7zzzz(1,z2(l,i1),ep)
     . +Gtwiddle(k,2)*Shat7zzzz(2,z2(l,i1),ep)
     . +Xtwiddle(0,k)*Cv(czzzzii(z2(l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Cv(czzzziii(z3(k,l,i1))+N0,ep)
     . )/(2d0*Gtwiddle(k,l))

      enddo

      return
      end


	SUBROUTINE GAZMML ( mproj, msppj, np, dlat, dlon, polat,
     +			    polon, rotat, azmsav, xl, yl, iret )
C************************************************************************
C* GAZMML								*
C* 									*
C* This subroutine converts a point from latitude longitude		*
C* coordinates to linear intermediate coordinates for azimuthal map	*
C* projections. 							*
C*									*
C* GAZMML  ( MPROJ,  MSPPJ, NP, DLAT, DLON, POLAT, POLON, ROTAT, 	*
C*           AZMSAV, XL, YL, IRET )					*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Map class			*
C*	MSPPJ		INTEGER		Map projection			*
C*	NP		INTEGER		Number of points		*
C* 	DLAT (NP)	REAL		Latitudes			*
C* 	DLON (NP)	REAL		Longitudes			*
C*	POLAT		REAL		Pole latitude			*
C*	POLON		REAL		Central longitude		*
C*	ROTAT		REAL		Rotation (not used)		*
C*	AZMSAV		REAL		Special azimuthal angle (unused)*
C* 									*
C* Output parameters:							*
C*	XL (NP)		REAL		X linear coordinates		*
C*	YL (NP)		REAL		Y linear coordinates		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 7/87	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* B. Doty/RDS		 7/87	Fixed Orthographic out-of-hemisphere	*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* A. Taylor/ARL        12/93   Enabled Oblique Azimuthal               *
C* K. Brill/NMC          1/94   Cleanup                                 *
C* D. Keiser/GSC	10/95	Fixed rounding error of "z" with EPS	*
C* K. Brill/EMC		 3/96	Remove Taylor code; general rotated proj*
C* K. Brill/EMC		 5/96	Check for latitude out of range		*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
C*
	REAL		xl (*), yl (*), dlat (*), dlon (*)
C*
	INCLUDE		'ERMISS.FNC'
C-------------------------------------------------------------------------
	iret  = NORMAL
C
C*	Loop through all points.
C
	DO  i = 1, np
C
C*	  Check for missing data.
C
	  IF ( ERMISS (dlat (i)) .or. ERMISS (dlon (i)) .or.
     +	       dlat (i) .gt. 90.0 .or. dlat (i) .lt. -90.0 )  THEN
	    xl (i) = RMISSD
	    yl (i) = RMISSD
	  ELSE
	    rlat   = dlat (i) * DTR
	    rlon   = dlon (i) * DTR
	    xl (i) = RMISSD
	    yl (i) = RMISSD
	    gamp   = RMISSD
	    r      = RMISSD
C
C*	   Ignore bad data.
C
	   IF  ( ( ERMISS (rlat) ) .or. ( ERMISS (rlon) ) )  THEN
C
C*	      Compute projection angles.
C
C*		North azimuthal projection
C
	      ELSE IF  ( msppj .eq. MSANOR )  THEN
		gamp = rlon - polon
		a    = HALFPI - rlat
C
C*		South azimuthal projtection
C
	      ELSE IF ( msppj .eq. MSASOU ) THEN
		gamp = - ( rlon - polon )
		a    = rlat   + HALFPI
	    END IF
C
C*	    Select  range computation based on projection type.
C
C*	    Stereographic projection
C
	    IF ( ( mproj .eq. MPASTR ) .and. ( a .lt. PI ) ) THEN
		r = TAN ( a / 2.0 )
C
C*		  Azimuthal equidistant projection
C
	      ELSE IF ( mproj .eq. MPAEQU ) THEN
		r = a
C
C*		Orthographic projection
C
	      ELSE IF ( mproj .eq. MPAORT ) THEN
		IF ( a .le. HALFPI ) THEN
		  r = SIN ( a )
		 ELSE
		  r = 1.0
		END IF
C
C* 		Lambert equal area projection
C
	      ELSE IF  ( mproj .eq. MPALAM )  THEN
		r = 2.0 * sin ( a ) / SQRT ( 2.0 * ( 1.0 + COS ( a ) ) )
C
C*		Gnomic projection
C
	      ELSE IF  ( ( mproj .eq. MPAGNO ) .and.
     +			 ( a .lt. HALFPI ) )  THEN
		r = TAN ( a )
	    END IF
C
C*	    Convert polar coodinates to Cartesian.
C
	    IF  ( ( ERMISS ( gamp ) ) .or. ( ERMISS ( r ) ) )  THEN
		xl (i) = RMISSD
		yl (i) = RMISSD
	      ELSE
		xl (i)  = r * COS ( gamp )
		yl (i)  = r * SIN ( gamp )
	    END IF
	  END IF
	END DO
C*
	RETURN
	END


      subroutine eplane(ibpln,iepln,slplen,alpha,m,ealpha)
c
c     + + + PURPOSE + + +
c     Calculates the equivalent depth discharge coefficient for
c     using the equivalent plane method; this is for handling
c     multiple strips down the hillslope.
c
c     ====================================================================
c     *  Note: The only equation that Chezy was used for is:             *
c     *          alphq = (chezy(i)*sqrt(avgslp(i)))**power2              *
c     *                                                                  *
c     *        The equation for Chezy is:                                *
c     *          chezy(i) = alpha(i)/sqrt(avgslp(i))                     *
c     *                                                                  *
c     *        If the two equations are combined into:                   *
c     *          sdst  = sdst + (suml*alpha(i)**power2)/(tmpvr1-tmpvr2)  *
c     *                                                                  *
c     *        CHEZY(I) & AVGSLP(I) are not needed.  CRM 4/11/91         *
c     ====================================================================
c
c     Called from IRS
c     Author(s): Hernandez, Stone
c     Reference in User Guide:
c
c     Changes:
c         1) Local vars. AVS, SUMS, DSTT, CHEZY(20), DFL, SML &
c            POWER1 not used -- removed from code.
c         2) XNPLN, AVGSLP, & REMAX not needed -- removed from
c            parameter list. Corresponding changes made in call
c            from IRS.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/09/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
c       read: mxplan
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer ibpln, iepln
      real slplen(mxplan), alpha(mxplan), m, ealpha
c
c     + + + ARGUMENT DEFINITIONS + + +
c     ibpln  - beginning segment (plane) number
c     iepln  - ending segment (plane) number
c     slplen - length of each plane (m)
c     alpha  - alpha for individual segment
c     m      - 3/2
c     ealpha - equivalent alpha for combined segments
c
c     + + + LOCAL VARIABLES + + +
      real suml, power2, power3, cml, tmpvr1, sdst, tmpvr2
      integer i
c
c     + + + LOCAL DEFINITIONS + + +
c     suml   - total length (m) of all the segments
c     power2 - 1./m
c     power3 - (m+1.)/m; ie, power2 + 1.
c     cml    - cumulative length (through current segment in loop)
c     tmpvr1 - temporary storage variable, changed each time through loop.
c     sdst   - WAS average storage at equilibrium (modified during recoding)
c     tmpvr2 - holds value of TMPVR1 previous time through the loop.
c
c     + + + END SPECIFICATIONS + + +
c
      suml = 0.
      do 10 i = ibpln, iepln
        suml = suml + slplen(i)
   10 continue
c
c     Computation of exponents
c
      power2 = 1. / m
      power3 = power2 + 1.
c
      cml = 0.
      sdst = 0.
      tmpvr2 = 0.
      do 20 i = ibpln, iepln
        cml = cml + slplen(i)
        tmpvr1 = cml ** power3
        sdst = sdst + (tmpvr1-tmpvr2) / (alpha(i)**power2)
        tmpvr2 = tmpvr1
   20 continue
c
c     Computation of equivalent alpha
c
      ealpha = (suml/sdst) ** m * suml
c
      return
      end


SUBROUTINE cexpli(mo, z, w)

!-----------------------------------------------------------------------
!           EVALUATION OF THE COMPLEX EXPONENTIAL INTEGRAL
!-----------------------------------------------------------------------

! From the NSWC Mathematics Library
! Original code by Hershey, A.V. & Alfred Morris.

! Arguments:
! If mo = 0, then w = Ei(z),
!       otherwise w = exp(-z).Ei(z)

! Accuracy:
! If mo = 0, Re(w) and Im(w) are accurate to within 2 units in the 12th
! significant digit, except when z is near a zero of either the real or
! imaginary part of Ei(z).

IMPLICIT NONE
INTEGER, PARAMETER   :: dp = SELECTED_REAL_KIND(12, 60)

INTEGER, INTENT(IN)       :: mo
COMPLEX (dp), INTENT(IN)  :: z
COMPLEX (dp), INTENT(OUT) :: w

! Local variables
REAL (dp), PARAMETER :: pi = 3.14159265358979_dp, euler = .577215664901533_dp
REAL (dp), PARAMETER :: cd(18) = (/ 0.0_dp, .311105957086528E-01_dp,  &
     .103661260539112E+00_dp, .216532335244554E+00_dp, .369931427960192E+00_dp,  &
     .566766259990589E+00_dp, .814042066324748E+00_dp, .112384247540813E+01_dp,  &
     .151400478148512E+01_dp, .200886795032284E+01_dp, .264052411823592E+01_dp,  &
     .345098449933392E+01_dp, .449583360763202E+01_dp, .585058263409822E+01_dp,  &
     .762273501463380E+01_dp, .997814501584578E+01_dp, .132122064896408E+02_dp,  &
     .180322948376021E+02_dp /),   &
                        ce(18) = (/ .850156516121093E-02_dp,  &
     .505037465849058E-01_dp, .836817368956407E-01_dp, .107047582417607E+00_dp,  &
     .120424719029462E+00_dp, .125096631582229E+00_dp, .122314435224685E+00_dp,  &
     .112621417553907E+00_dp, .963419407392582E-01_dp, .747398422757511E-01_dp,  &
     .508596135953441E-01_dp, .290822706773628E-01_dp, .132201640530101E-01_dp,  &
     .443802939829067E-02_dp, .992612478987576E-03_dp, .126579795112011E-03_dp,  &
     .702150908253350E-05_dp, .910281532564632E-07_dp /)
REAL (dp)    :: qf(2), sm(2), tm(2), ts(2), g0(2), gn(2), h0(2), hn(2), wn(2),  &
                c, cy, d, e, eps, n, np1, qm, r, ss, sy, tol, u, x, y
INTEGER      :: i
LOGICAL      :: ind

!     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
!            SMALLEST NUMBER SUCH THAT 1.D0 + EPS > 1.D0.

eps = EPSILON(1.0_dp)

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

x = REAL(z, KIND=dp)
y = AIMAG(z)
r = dcpabs(x,y)
eps = MAX(eps, 1.e-15_dp)

IF (r > 1.0) THEN
  IF (r >= 40.0) GO TO 40
  IF (r >= 4.0) THEN
    IF (x <= 0.0 .OR. ABS(y) > 8.0) GO TO 40
    IF (r < 10.0 .AND. ABS(y) > 1.8*x) GO TO 40
  ELSE
    IF (x < 0.09*y*y) GO TO 20
    IF (r > 3.6 .AND. ABS(y) > 1.8*x) GO TO 40
  END IF
END IF

!                        TAYLOR SERIES

sm(1) = 0.0
sm(2) = 0.0
tm(1) = x
tm(2) = y
n = 1.0
10 n = n + 1.0
ts(1) = tm(1) * x - tm(2) * y
ts(2) = tm(1) * y + tm(2) * x
tm(1) = ts(1) / n
tm(2) = ts(2) / n
ts(1) = tm(1) / n
ts(2) = tm(2) / n
sm(1) = sm(1) + ts(1)
sm(2) = sm(2) + ts(2)
IF (anorm(ts(1), ts(2)) > eps*anorm(sm(1), sm(2))) GO TO 10
sm(1) = x + sm(1)
sm(2) = y + sm(2)

sm(1) = (euler + LOG(r)) + sm(1)
sm(2) = ATAN2(-y, -x) + sm(2)
GO TO 70

!                      RATIONAL EXPANSION

20 sm(1) = 0.0
sm(2) = 0.0
DO i = 1, 18
  ts(1) = x - cd(i)
  ts(2) = y
  ss = ts(1) * ts(1) + ts(2) * ts(2)
  sm(1) = sm(1) + ce(i) * ts(1) / ss
  sm(2) = sm(2) - ce(i) * ts(2) / ss
END DO
GO TO 60

!         PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION
!                       FOR EXP(-Z)*EI(Z)

40 x = -x
y = -y
d = 4.0 * r
IF (r < 10.0) d = 32.0
g0(1) = 1.0
g0(2) = 0.0
gn(1) = (1.0+x) / d
gn(2) = y / d
h0(1) = 1.0
h0(2) = 0.0
u = x + 2.0
hn(1) = u / d
hn(2) = gn(2)
w = CMPLX(1.0+x, y, KIND=dp) / CMPLX(u, y, KIND=dp)
wn(1) = REAL(w, KIND=dp)
wn(2) = AIMAG(w)
np1 = 1.0
tol = 4.0 * eps

50 n = np1
np1 = n + 1.0
e = (n*np1) / d
u = u + 2.0
tm(1) = ((u*gn(1)-y*gn(2))-e*g0(1)) / d
tm(2) = ((u*gn(2)+y*gn(1))-e*g0(2)) / d
g0(1) = gn(1)
g0(2) = gn(2)
gn(1) = tm(1)
gn(2) = tm(2)
tm(1) = ((u*hn(1)-y*hn(2))-e*h0(1)) / d
tm(2) = ((u*hn(2)+y*hn(1))-e*h0(2)) / d
h0(1) = hn(1)
h0(2) = hn(2)
hn(1) = tm(1)
hn(2) = tm(2)

tm(1) = wn(1)
tm(2) = wn(2)
w = CMPLX(gn(1), gn(2), KIND=dp) / CMPLX(hn(1), hn(2), KIND=dp)
wn(1) = REAL(w, KIND=dp)
wn(2) = AIMAG(w)
IF (anorm(tm(1)-wn(1),tm(2)-wn(2)) > tol*anorm(wn(1),wn(2)))  &
GO TO 50

x = REAL(z, KIND=dp)
y = AIMAG(z)
w = w / z
sm(1) = REAL(w, KIND=dp)
sm(2) = AIMAG(w)

!                         TERMINATION

60 ind = x <= 0.0 .OR. ABS(y) > 1.e-2
IF (ind .AND. mo /= 0) GO TO 90
c = pi
IF (y > 0.0) c = -pi
qm = EXP(x)
cy = COS(y)
sy = SIN(y)
qf(1) = qm * cy
qf(2) = qm * sy
IF (mo == 0) GO TO 80

r = c / qm
sm(1) = sm(1) + r * sy
sm(2) = sm(2) + r * cy
GO TO 90

70 IF (mo == 0) GO TO 90
ind = .true.
qm = EXP(-x)
qf(1) = qm * COS(-y)
qf(2) = qm * SIN(-y)

80 ts(1) = qf(1) * sm(1) - qf(2) * sm(2)
ts(2) = qf(1) * sm(2) + qf(2) * sm(1)
sm(1) = ts(1)
sm(2) = ts(2)
IF (.NOT.ind) sm(2) = sm(2) + c

90 w = CMPLX(sm(1), sm(2), KIND=dp)
RETURN

CONTAINS

FUNCTION dcpabs(x, y) RESULT(fn_val)
!     --------------------------------------
!     EVALUATION OF SQRT(X*X + Y*Y)
!     --------------------------------------
REAL (dp), INTENT(IN) :: x, y
REAL (dp)             :: fn_val

! Local variable
REAL (dp) :: a

IF (ABS(x) > ABS(y)) THEN
  a = y / x
  fn_val = ABS(x) * SQRT(1.0_dp + a*a)
  RETURN
END IF
IF (y /= 0.0_dp) THEN
  a = x / y
  fn_val = ABS(y) * SQRT(1.0_dp + a*a)
  RETURN
END IF
fn_val = 0.0_dp
RETURN
END FUNCTION dcpabs

FUNCTION anorm(x, y) RESULT(fn_val)
! Replaces the statement function anorm in the F77 code.

REAL (dp), INTENT(IN) :: x, y
REAL (dp)             :: fn_val

fn_val = MAX(ABS(x), ABS(y))
RETURN
END FUNCTION anorm

END SUBROUTINE cexpli


************************************************************************
*     Author: R.K. Ellis                                               *
*     July, 1998/July 2005/June 2007                                   *
************************************************************************

      double complex function L0(x,y)
      implicit none
      include 'constants.f'
      double complex Lnrat
      double precision x,y,denom
      denom=one-x/y
      if (abs(denom) .lt. 1d-7) then
      L0=-cone-dcmplx(denom*(half+denom/3d0))
      else
      L0=Lnrat(x,y)/dcmplx(denom)
      endif
      return
      end

      double complex function L1(x,y)
      implicit none
      include 'constants.f'
      double precision x,y,denom
      double complex L0
      denom=one-x/y
      if (abs(denom) .lt. 1d-7) then
      L1=-half*cone-dcmplx(denom/3d0*(one+0.75d0*denom))
      else
      L1=(L0(x,y)+cone)/dcmplx(denom)
      endif
      return
      end

      double complex function L2(x,y)
      implicit none
      include 'constants.f'
      double complex Lnrat
      double precision x,y,r,denom
      r=x/y
      denom=one-r
      if (abs(denom) .lt. 1d-7) then
      L2=(dcmplx(10d0)+denom*(dcmplx(15d0)+dcmplx(18d0)*denom))
     . /dcmplx(60d0)
      else
      L2=(Lnrat(x,y)-dcmplx(0.5d0*(r-1d0/r)))/dcmplx(denom)**3
      endif
      return
      end

      double complex function L0old(x,y)
      implicit none
      include 'constants.f'
      double complex Lnrat
      double precision x,y,denom
      denom=one-x/y
      L0old=Lnrat(x,y)/dcmplx(denom)
      return
      end

      double complex function L1old(x,y)
      implicit none
      include 'constants.f'
      double precision x,y,denom
      double complex L0old
      denom=one-x/y
      L1old=(L0old(x,y)+cone)/dcmplx(denom)
      return
      end

      double complex function Ls0(x1,y1,x2,y2)
      implicit none
      include 'constants.f'
      double precision x1,x2,y1,y2,r1,r2
      double complex Lsm1
      r1=x1/y1
      r2=x2/y2
      Ls0=Lsm1(x1,y1,x2,y2)/dcmplx(one-r1-r2)
      return
      end

      double complex function Ls1(x1,y1,x2,y2)
      implicit none
      include 'constants.f'
      double precision x1,x2,y1,y2,r1,r2
      double complex Ls0,L0
      r1=x1/y1
      r2=x2/y2
      Ls1=(Ls0(x1,y1,x2,y2)+L0(x1,y1)+L0(x2,y2))/dcmplx(one-r1-r2)
      return
      end

      double complex function Lsm1(x1,y1,x2,y2)
      implicit none
      include 'constants.f'
      double precision x1,x2,y1,y2,r1,r2,omr1,omr2,ddilog
      double complex dilog1,dilog2,Lnrat
      r1=x1/y1
      r2=x2/y2
      omr1=one-r1
      omr2=one-r2
      if (omr1 .gt. one) then
         dilog1=dcmplx(pisqo6-ddilog(r1))-Lnrat(x1,y1)*dcmplx(log(omr1))
      else
         dilog1=dcmplx(ddilog(omr1))
      endif
      if (omr2 .gt. one) then
         dilog2=dcmplx(pisqo6-ddilog(r2))-Lnrat(x2,y2)*dcmplx(log(omr2))
      else
          dilog2=dcmplx(ddilog(omr2))
      endif
      lsm1=dilog1+dilog2+Lnrat(x1,y1)*Lnrat(x2,y2)-dcmplx(pisqo6)
      return
      end

      double complex function Lsm1_2mh(s,t,m1sq,m2sq)
      implicit none
      include 'constants.f'
      double precision s,t,m1sq,m2sq
      double complex lsm1_2mht,I3m
      Lsm1_2mh=Lsm1_2mht(s,t,m1sq,m2sq)
     & +(half*(s-m1sq-m2sq)+m1sq*m2sq/t)*I3m(s,m1sq,m2sq)
      return
      end

      double complex function Lsm1_2mht(s,t,m1sq,m2sq)
      implicit none
      include 'constants.f'
      double precision s,t,m1sq,m2sq,ddilog,r1,r2,omr1,omr2
      double complex Lnrat,dilog1,dilog2
      r1=m1sq/t
      r2=m2sq/t
      omr1=one-r1
      omr2=one-r2

      if (omr1 .gt. one) then
      dilog1=dcmplx(pisqo6-ddilog(r1))-Lnrat(-m1sq,-t)*dcmplx(log(omr1))
      else
      dilog1=dcmplx(ddilog(omr1))
      endif
      if (omr2 .gt. one) then
      dilog2=dcmplx(pisqo6-ddilog(r2))-Lnrat(-m2sq,-t)*dcmplx(log(omr2))
      else
      dilog2=dcmplx(ddilog(omr2))
      endif
      lsm1_2mht=-dilog1-dilog2
     & +half*(Lnrat(-s,-m1sq)*Lnrat(-s,-m2sq)-Lnrat(-s,-t)**2)
      return
      end

      double complex function Lsm1_2me(s,t,m1sq,m3sq)
      implicit none
c---- formula taken from G.~Duplancic and B~Nizic [arXiv:hep-ph/0006249 v2]
c---- Eq 71
c---- Lsm1_2me notation follows from
c----  Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
c----  %``Dimensionally regulated pentagon integrals,''
c----  Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
c----  [arXiv:hep-ph/9306240].
c----  %%CITATION = HEP-PH 9306240;%%
c----  Eqs. (I.13)
C---- analytic continuation has been checked by calculating numerically.
      include 'constants.f'
      integer j
      double precision s,t,m1sq,m3sq,ddilog,arg(4),omarg(4),f2me,htheta
      double complex Li2(4),wlog(4)
C--- define Heaviside theta function (=1 for x>0) and (0 for x < 0)
      htheta(s)=half+half*sign(one,s)

      f2me=(s+t-m1sq-m3sq)/(s*t-m1sq*m3sq)

      arg(1)=f2me*s
      arg(2)=f2me*t
      arg(3)=f2me*m1sq
      arg(4)=f2me*m3sq

      do j=1,4
         omarg(j)=one-arg(j)
         wlog(j)=log(abs(arg(j)))
     .     +impi*dcmplx(htheta(-arg(j))*sign(one,f2me))
         if (omarg(j) .gt. one) then
             Li2(j)=dcmplx(pisqo6-ddilog(arg(j)))
     .       -wlog(j)*dcmplx(log(omarg(j)))
          else
             Li2(j)=dcmplx(ddilog(omarg(j)))
         endif
      enddo
      Lsm1_2me=Li2(1)+Li2(2)-Li2(3)-Li2(4)

      return
      end

c      double complex function Lsm1_2me(s,t,m1sq,m3sq)
c      implicit none
c      include 'constants.f'
c      integer j
c      double precision s,t,m1sq,m3sq,ddilog,arg(5),omarg(5)
c      double complex Lnrat,Li2(5),wlog(5)
c      arg(1)=m1sq/s
c      wlog(1)=Lnrat(-m1sq,-s)

c      arg(2)=m1sq/t
c      wlog(2)=Lnrat(-m1sq,-t)

c      arg(3)=m3sq/s
c      wlog(3)=Lnrat(-m3sq,-s)

c      arg(4)=m3sq/t
c      wlog(4)=Lnrat(-m3sq,-t)

c      arg(5)=arg(1)*arg(4)
c      wlog(5)=Lnrat(-m1sq,-s)+Lnrat(-m3sq,-t)

c      do j=1,5
c         omarg(j)=one-arg(j)
c         if (omarg(j) .gt. one) then
c             Li2(j)=dcmplx(pisqo6-ddilog(arg(j)))-wlog(j)*log(omarg(j))
c          else
c             Li2(j)=dcmplx(ddilog(omarg(j)))
c         endif
c      enddo
c      Lsm1_2me=Li2(5)-Li2(1)-Li2(2)-Li2(3)-Li2(4)-half*Lnrat(-s,-t)**2
c      return
c      end


	SUBROUTINE OA_BARN  ( ngrid, weight, srad, kexy, nstn,
     +			      data, slat, slon, gelat, gelon, coslat,
     +			      cosslt, extrap, gsflag, gpinb, stninb,
     +                        isn, grid, iret )
C************************************************************************
C* OA_BARN								*
C*									*
C* This subroutine performs a single pass of a Barnes analysis.  The	*
C* weighting function used is						*
C*									*
C*	WF = [ EXP ( DIST ** 2 / WEIGHT ) ]				*
C*									*
C* where DIST is the distance from the station to the grid point.	*
C* Locations and distances in this subroutine are now defined in	*
C* latitude/longitude.  Distance between a grid point and a station	*
C* is computed as							*
C*									*
C* DIST ** 2 = [ ( lat (grid) - lat (stn) ) ** 2 +			*
C*	       ( ( lon (grid) - lon (stn) ) * avgcos ) ** 2 ],		*
C*									*
C* where AVGCOS is the average cosine of latitude between grid point	*
C* and station.	If the grid point latitude is too close to a pole,	*
C* a more exact formula is used:					*
C*									*
C* DIST ** 2 = [ ( lat (grid) - lat (stn) ) ** 2 +			*
C*	       2 * ( 1 - cos ( lon (grid) - lon (stn) )			*
C*		 * cos ( lat (grid) ) * cos ( lat (stn) ) ].		*
C*									*
C* ISN is the number of stations used for each grid computed.  Only	*
C* data within the distance [ SQRT (SRAD) ] of a grid point is		*
C* included in the analysis.						*
C*									*
C* EXTRAP controls whether the ordinary Barnes analysis is used.	*
C* If EXTRAP = .FALSE., a check is made to ensure that data is		*
C* absent in no more than three consecutive octals about a grid point.	*
C* If four or more consecutive octals are devoid of data, as might be	*
C* the case at an offshore grid point, the grid point value is returned	*
C* as missing.								*
C*									*
C* OA_BARN ( NGRID, WEIGHT, SRAD, KEXY, NSTN, DATA, SLAT, SLON,		*
C*	     GELAT, GELON, COSLAT, COSSLT, EXTRAP, GSFLAG, GPINB	*
C*	     STNINB, ISN, GRID, IRET )					*
C*									*
C* Input parameters:							*
C*	NGRID		INTEGER		Number of grids			*
C*	WEIGHT		REAL		Weighting factor		*
C*	SRAD		REAL		Search radius in grid coords	*
C*	KEXY		INTEGER		# of points in extend grid	*
C*	NSTN		INTEGER		Number of stations		*
C*	DATA		REAL		Station data			*
C*	 (NGRID,NSTN)							*
C*	SLAT   (NSTN)	REAL		Station latitudes		*
C*	SLON   (NSTN)	REAL		Station longitudes		*
C*	GELAT  (KEXY)	REAL		Grid point latitudes		*
C*	GELON  (KEXY)	REAL		Grid point longitudes		*
C*	COSLAT (KEXY)	REAL		COS (lat) at grid pts		*
C*	COSSLT (NSTN)	REAL		COS (lat) at stations		*
C*	EXTRAP		LOGICAL		Allow extrapolation		*
C*	GSFLAG		LOGICAL		Flag for first guess		*
C*	GPINB  (KEXY)	LOGICAL		Flags for inbound grid points	*
C*	STNINB (NSTN)	LOGICAL		Flag for inbound stations	*
C*									*
C* Output parameters:							*
C*	ISN   (NGRID)	INTEGER		# stations used for grid	*
C*	GRID		REAL		Grid data			*
C*	 (NGRID,KEXY)							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 7/86						*
C* M. desJardins/GSFC	10/88	Documentation				*
C* K. Brill/GSC		 4/90	Put missing value check in grid update	*
C* J. Nielsen/SUNYA	12/90	Included exact formula for distance,	*
C*				ignored if approximation valid or FAST	*
C* J. Nielsen/SUNYA	12/90	Included option for no extrapolation	*
C* K. Brill/NMC		06/91	Removed FAST option and cleaned up;	*
C*				Improved approximate calculation;	*
C*				Use different Cartesian frame for data	*
C*				extrapolation check			*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* S. Jacobs/NCEP	 6/98	Added guess flag calling sequence	*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C* J. Wu/SAIC           04/05   Added bounds blocking			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( MINSTN = 3 )
	PARAMETER	( LLDTMX = LLSTFL * MMFILE )
	REAL		data ( NGRID, NSTN )
	REAL		slat (*), slon (*), gelat ( * ), gelon (*),
     +			coslat ( * ), cosslt ( * ), grid ( NGRID, KEXY )
	LOGICAL		extrap, gsflag, gpinb ( * ), stninb ( * )
	INTEGER		isn ( * )
C*
	REAL		sum (LLOAGD), swt (LLOAGD)
	REAL		gnmlat (LLMXGD), gnmlon (LLMXGD)
	REAL		snmlat (LLDTMX), snmlon (LLDTMX)
	INTEGER		mod8 (10)
	LOGICAL		hit ( 8, LLOAGD )
	LOGICAL		incmpl, intersect
	INCLUDE		'ERMISS.FNC'
	DATA		mod8 /2,3,4,5,6,7,8,1,2,3/
C*
C------------------------------------------------------------------------
	iret = 0
	rtd2 = RTD * RTD
	sr = sqrt(srad)
	isect = 1
C
C*	Check the value entered for the weight.  Compute the reciprocal
C*	to use multiplication instead of division.
C
	IF  ( weight .le. 0. )  THEN
	    www   = 5.051457 * 2. / PI
	    wtfac = 1. /www
	  ELSE
	    wtfac = 1. / weight
	END IF
C
C*      Transform to normalized coordinates for bounds checking.
C
        CALL GTRANS ( 'M', 'N', kexy, gelat, gelon,
     +                          gnmlat, gnmlon, iret )
        CALL GTRANS ( 'M', 'N', nstn, slat, slon,
     +                          snmlat, snmlon, iret )
C
C*	Loop through all grid points.
C
	DO  ixy = 1, kexy
	    glat   = gelat  ( ixy )
	    glon   = gelon  ( ixy )
	    gnlat   = gnmlat  ( ixy )
	    gnlon   = gnmlon  ( ixy )
C
C*          Check if the grid point should be blocked.
C
	    IF  ( gpinb ( ixy ) )  THEN
	        DO  igrid = 1, ngrid
	            grid ( igrid, ixy ) = RMISSD
                END DO
	    END IF
C
	    IF  ( gpinb ( ixy ) )  THEN
		GO TO 222
	    END IF
C
C*	    Initialize the weighted data arrays and the hit array.
C
	    DO  igrid = 1, ngrid
		sum ( igrid ) = 0.
		swt ( igrid ) = 0.
		isn ( igrid ) = 0
	    END DO
	    IF  ( .not. extrap )  THEN
		DO  igrid = 1, ngrid
		    DO  isec = 1, 8
			hit ( isec, igrid ) = .false.
		    END DO
		END DO
	    END IF
C
C*	    Loop through each station.
C
	    DO  is = 1, nstn
C
C*              Skip the station if it is inside of the blocking bounds
C
		IF  ( stninb ( is ) )  GO TO 111
C
C*		Compute distance and check that it is less than the
C*		search radius.
C
		at = slat (is)
		on = slon (is)
C
C*		Do points span dateline?
C
		IF ( on - glon .gt. 180. ) THEN
		    on = on - 360.
		ELSE IF ( on - glon .lt. -180. ) THEN
		    on = on + 360.
		END IF
C*
		diflon = ABS ( on - glon )
C*
		IF ( ( glat .gt. 90. - sr  .or. glat .lt. sr - 90. )
     +					.and.
     +		   ( diflon .gt. sr .or. diflon .gt. 60. ) ) THEN
C
C*		   Within search radius of pole; need to use exact
C*		   formula.
C
		   dsq = ( at - glat ) ** 2
		   IF ( dsq .le. srad ) dsq = dsq +
     +		           2. * ( 1. - COS ( diflon * DTR ) ) *
     +			   cosslt ( is ) * coslat ( ixy ) * rtd2
C*
		   IF ( ( .not. extrap ) .and. (dsq .le. srad) ) THEN
C
C*			Express station position relative to the grid
C*			point using a coordinate system with (0,0) at
C*			the NP with the grid point at (0, - colatitude).
C*			The location of the station is computed in
C*			this coordinate system and then translated in
C*			+y direction by an amount equal to the
C*			colatitude of the grid point.
C
			IF ( glat .lt. 0 ) THEN
			    rg = 90 + glat
			ELSE
			    rg = 90 - glat
			END IF
C*
			IF ( at .lt. 0 ) THEN
			    rr = 90 + at
			ELSE
			    rr = 90 - at
			END IF
			theta = ( ( on - glon ) - 90. ) * DTR
			on = rr * COS ( theta )
			at = rr * SIN ( theta ) + rg
	 	   END IF
C*
		ELSE
C
C*		     Use the approximate formula.
C
		     avgcos = .5 * ( coslat (ixy) + cosslt (is) )
		     dsq = ( at - glat ) **2 + ( diflon * avgcos ) **2
C
C*		     Adjust lon to approximate Cartesian frame with the
C*		     origin at the grid point.
C
		     IF  ( ( .not. extrap ) .and. ( dsq .le. srad ) )
     +			THEN
			on = ( on - glon ) * avgcos
		   	at = ( at - glat )
		     END IF
		END IF
C
C*               Skip the station if the segment ( station to grid point)
C*               intersects with the blocking boundaries.
C
		IF  ( dsq .le. srad )  THEN
		    CALL OA_BNDCHK ( gnlat, gnlon, snmlat(is),
     + 			             snmlon(is), intersect, iret )
                    IF ( intersect )  GO TO 111
                END IF
C
		IF  ( dsq .le. srad )  THEN
C
C*		    If no extrapolation is allowed; set the position
C*		    of the station relative to the grid point by
C*		    octant number.  (ON is x; AT is y.)
C
                    IF  ( at .gt. 0.0 .and. .not. extrap ) THEN
                        IF  ( on .gt. 0.0 ) THEN
                       	    IF  ( on .gt. at ) THEN
                                isect = 1
                            ELSE
                                isect = 2
                            END IF
                        ELSE
                            IF ( at .gt. -on ) THEN
                                isect = 3
                            ELSE
                                isect = 4
                            END IF
                        END IF
                    ELSE IF ( .not. extrap ) THEN
                        IF  ( on .gt. 0.0 ) THEN
                       	    IF  ( -at .gt. on ) THEN
                            	isect = 7
                            ELSE
                                isect = 8
                            END IF
                        ELSE
                            IF  ( on .lt. at ) THEN
                            	isect = 5
                            ELSE
                           	isect = 6
                            END IF
                        END IF
		    END IF
C
C*		    Compute weight to use and apply over levels and
C*		    parameters.
C
		    wt = EXP ( (-dsq) * wtfac )
		    DO  igrid = 1, ngrid
			sdata = data ( igrid, is )
			IF  ( .not. ERMISS (sdata) )  THEN
			    sum (igrid) = sum (igrid) + wt*sdata
			    swt (igrid) = swt (igrid) + wt
			    isn (igrid) = isn (igrid) + 1
			    hit ( isect, igrid ) = .true.
			END IF
		    END DO
		END IF
111	      CONTINUE
	    END DO
C
C*	    Calculate grid point values.
C
	    IF  ( extrap )  THEN
	      DO  igrid = 1, ngrid
		gv = grid ( igrid, ixy )
		IF  ( isn (igrid) .ge. MINSTN .and. .not. ERMISS ( gv )
     +               )  THEN
		    grid ( igrid, ixy ) = grid ( igrid, ixy ) +
     +					  sum (igrid) / swt (igrid)
		ELSE
		    IF  ( .not. gsflag )  THEN
			grid ( igrid, ixy ) = RMISSD
		    END IF
	        END IF
	      END DO
	    ELSE
	      DO  igrid = 1, ngrid
		gv = grid ( igrid, ixy )
		IF  ( isn (igrid) .ge. MINSTN .and. .not. ERMISS ( gv )
     +               )  THEN
		  isec = 1
		  incmpl = .false.
C
C*		  Make sure no more than three consecutive octals did
C*		  not have data.
C
		  DO WHILE  ( ( isec .le. 8 ) .and. .not. incmpl )
		     IF  ( ( .not. hit ( isec  , igrid ) ) .and.
     +		 	 ( .not. hit ( mod8 (isec), igrid ) ) .and.
     +			 ( .not. hit ( mod8 (isec+1), igrid ) ) .and.
     +			 ( .not. hit ( mod8 (isec+2), igrid ) ) ) THEN
			 incmpl = .true.
		     ELSE
			 isec = isec + 1
		     END IF
		  END DO
C*
		  IF  ( incmpl )  THEN
		     IF  ( .not. gsflag )  THEN
			grid ( igrid, ixy ) = RMISSD
		     END IF
		  ELSE
		     grid ( igrid, ixy ) = grid ( igrid, ixy ) +
     +					   sum (igrid) / swt (igrid)
		  END IF
		ELSE
		  IF  ( .not. gsflag )  THEN
		      grid ( igrid, ixy ) = RMISSD
		  END IF
		END IF
	      END DO
	    END IF
C
222         CONTINUE
C
	END DO
C*
	RETURN
	END


!==========================================================================
elemental function gsw_entropy_from_pt (sa, pt)
!==========================================================================
!
!  Calculates specific entropy of seawater.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  pt  =  potential temperature (ITS-90)                          [ deg C ]
!
!  entropy  =  specific entropy                                [ J/(kg*K) ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, pt

real (r8) :: gsw_entropy_from_pt

integer, parameter :: n0 = 0
integer, parameter :: n1 = 1

real (r8), parameter :: pr0 = 0.0_r8

gsw_entropy_from_pt = -gsw_gibbs(n0,n1,n0,sa,pt,pr0)

return
end function

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


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE DSTORT (X1, X2, X3, X4, Y1, Y2, Y3, Y4, VALUE)
C***********************************************************************

C  SUBROUTINE DSTORT = CALCULATES A DISTORTION METRIC FOR AN ELEMENT
C                    USING THE IDEAS IN THE PAPER BY ODDY, 1988.

C***********************************************************************

C  SETUP THE JACOBIAN MATRIX

      XJ11 = (X1 * .125) + (X2 * .375) - (X3 * .375) - (X4 * .125)
      XJ12 = (Y1 * .125) + (Y2 * .375) - (Y3 * .375) - (Y4 * .125)
      XJ21 = - (X1 * .375) + (X2 * .375) + (X3 * .125) - (X4 * .125)
      XJ22 = - (Y1 * .375) + (Y2 * .375) + (Y3 * .125) - (Y4 * .125)

C  NORMALIZE THE JACOBIAN WITH RESPECT TO THE ELEMENT SIZE

      DETERM = (XJ11 * XJ22) - (XJ12 * XJ21)
      IF (DETERM .LE. 0.) THEN
         VALUE = 1.0E10
         RETURN
      ENDIF
      FACTOR = 1. / SQRT (DETERM)
      XJ11 = XJ11 * FACTOR
      XJ12 = XJ12 * FACTOR
      XJ21 = XJ21 * FACTOR
      XJ22 = XJ22 * FACTOR

C  NOW USE THE SECOND INVARIANT OF GREEN'S STRAIN

      C11 = XJ11*XJ11 + XJ21*XJ21
      C12 = XJ11*XJ12 + XJ21*XJ22
      C22 = XJ12*XJ12 + XJ22*XJ22

      VALUE = C11**2 + 2.*(C12**2) + C22**2 -
     &   (.5 * (C11+C22)**2 )
      VALUE = AMAX1 (VALUE, 0.)

      RETURN

      END


      Real Function CombConf(Method,p1,p2,mua,mub,ICode)
C Gives the confidence level by which the cross section is rejected as too
C high when it is rejected by two measurements with confidence levels p1 and
C p2.  The two measurements have total expected number of events mu1 and mu2.
C The Method is as numbered in CDMS_Edelweiss.pdf.
C ICode is as in C0Int except it's 5 if XC0 has a problem.
      Implicit None
      Integer Method,ICode1,ICode2,ICode
      Real p1,p2,mu1,mu2,z,x1,x2,mua,mub,x,XC0,C0,C0Int
C      Real tmp1,tmp2,tmp3,tmp4
C
      ICode=5
      CombConf=0.
      mu1=max(mua,mub)
      mu2=min(mua,mub)
      If(Method.lt.3 .or. Method.gt.6) Then
         Write(6,*) "This Method is not implemented"
      ElseIf(Method.eq.3) Then
         x1=XC0(p1,mua,ICode1)
         x2=XC0(p2,mub,ICode2)
         If(ICode1.ne.0 .or. ICode2.ne.0) Then
            Write(6,*) "CombConf trouble computing XC0.",p1,p2,mua,
     1        mub,ICode1,ICode2
            CombConf=0.
            ICode=5
            Return
         Else
            ICode=0
         EndIf
         z=x1+x2
         If(z.le.0.) Then
            CombConf=0.
         ElseIf(z.le.mu2) Then
            CombConf=C0Int(0.,z,mu1,mu2,z,ICode)
         ElseIf(z.le.mu1) Then
            CombConf=C0(z-mu2,mu1) + C0Int(z-mu2,z,mu1,mu2,z,ICode)
         ElseIf( z .lt. (mu1+mu2)*.99999 ) Then
            CombConf=C0(z-mu2,mu1) + exp(-mu1)*C0(z-mu1,mu2)
     2       + C0Int(z-mu2,mu1,mu1,mu2,z,ICode)
         ElseIf( z .lt. 1.00001*(mu1+mu2)) Then
C Allow for some roundoff error with no events in either experiment
            CombConf=1.-exp(-(mu1+mu2))
         Else
            CombConf=1.
         EndIf
      ElseIf(Method.eq.4) Then
         ICode=0
         z=max(p1,p2)
         If(z.le.0.) Then
            CombConf=0.
         ElseIf(z.lt.1.-exp(-mu2)) Then
            CombConf=z*z
         ElseIf(z.lt.1.-exp(-mu1)) Then
            CombConf=z
         Else
            CombConf=1.
         EndIf
      ElseIf(Method.eq.5) Then
         ICode=0
         z=min(p1,p2)
         If(z.le.0) Then
            CombConf=0.
         ElseIf(z.lt.1.00001-exp(-mu2)) Then
            CombConf=z*(2.-z)
         Else
            CombConf=1.
         EndIf
      ElseIf(Method.eq.6) Then
         ICode=0
         z=p1*p2
         x=(1.-exp(-mu1))*(1.-exp(-mu2))
         If(z.le.0.) Then
            CombConf=0.
         ElseIf(z.lt.x+0.00001) Then
            CombConf=z*( (1.-exp(-(mu1+mu2)))/x + log(x/z) )
         Else
            CombConf=1.
         EndIf
      Else
         Write(6,*) "You should never get here"
      EndIf
      Return
      End


!-------Определение координат места и поправки часов приемника-------
!-------------Author: Волков Д.В.-------АО мат-меха СПбГУ----------

subroutine geo_coord(X, Y, Z, P_0, delta_ts, lon, lat, dt)
    implicit none
	real(8), dimension(4), intent(in) :: X, Y, Z, P_0, delta_ts
	real(8), intent(out) :: lon, lat, dt
    integer(2) i
	real(8), dimension(4) :: P
	real(8), parameter :: c = 299792458.d0, a_WGS = 6378137.d0, b_WGS = 6356752.d0, level_spbu=0.0005d0
    !------вспомогательные суммы, разности и пр.:
	real(8), dimension(3) :: delta_P, delta_X, delta_Y, delta_Z, A
	real(8), dimension(3) :: sigma_P, sigma_X, sigma_Y, sigma_Z
    !------рабочая матрица
	real(8), dimension(3,3) :: matrix
	real(8) :: Dbig, Db_1, Db_2, Db_3, d1, d2, d3
	real(8) :: Xa, Ya, Za, ax, ay, az, a4, b4, c4
	real(8) :: eps_1, eps_2, e_t, e_st, X_fin, Y_fin, Z_fin, psi

    forall (i=1:4)
        P(i) = P_0(i) + c*delta_ts(i)
    end forall

    do i=1,3
        delta_P(i) = P(i+1) - P(i)
        delta_Z(i) = Z(i+1) - Z(i)
        delta_X(i) = X(i+1) - X(i)
        delta_Y(i) = Y(i+1) - Y(i)

        sigma_P(i) = P(i) + P(i+1)
        sigma_Z(i) = Z(i) + Z(i+1)
        sigma_Y(i) = Y(i) + Y(i+1)
        sigma_X(i) = X(i) + X(i+1)

        A(i) = (delta_X(i)*sigma_X(i)+delta_Y(i)*sigma_Y(i)+delta_Z(i)*sigma_Z(i)-delta_P(i)*sigma_P(i))/2
    enddo

    call create_mx(delta_X(1),delta_Y(1),delta_Z(1),delta_X(2),delta_Y(2),delta_Z(2),delta_X(3),delta_Y(3),delta_Z(3),matrix)
    call det3x3(matrix, Dbig)

    call create_mx(A(1),delta_Y(1),delta_Z(1),A(2),delta_Y(2),delta_Z(2),A(3),delta_Y(3),delta_Z(3),matrix)
    call det3x3(matrix, Db_1)

    call create_mx(delta_X(1),A(1),delta_Z(1),delta_X(2),A(2),delta_Z(2),delta_X(3),A(3),delta_Z(3),matrix)
    call det3x3(matrix, Db_2)

    call create_mx(delta_X(1),delta_Y(1),A(1),delta_X(2),delta_Y(2),A(2),delta_X(3),delta_Y(3),A(3),matrix)
    call det3x3(matrix, Db_3)

    call create_mx(-1*delta_P(1),delta_Y(1),delta_Z(1),-1*delta_P(2),delta_Y(2),delta_Z(2),-1*delta_P(3),delta_Y(3),delta_Z(3),matrix)
    call det3x3(matrix, d1)

    call create_mx(delta_X(1),-1*delta_P(1),delta_Z(1),delta_X(2),-1*delta_P(2),delta_Z(2),delta_X(3),-1*delta_P(3),delta_Z(3),matrix)
    call det3x3(matrix, d2)

    call create_mx(delta_X(1),delta_Y(1),-1*delta_P(1),delta_X(2),delta_Y(2),-1*delta_P(2),delta_X(3),delta_Y(3),-1*delta_P(3),matrix)
    call det3x3(matrix, d3)

    Xa = Db_1/Dbig
    Ya = Db_2/Dbig
    Za = Db_3/Dbig

    ax = d1/Dbig
    ay = d2/Dbig
    az = d3/Dbig
    !----коэфф. кв. уравнения:
    a4 = 1 - ax*ax - ay*ay - az*az
    b4 = P(4) + (X(4) - Xa)*ax + (Y(4) - Ya)*ay + (Z(4) - Za)*az
    c4 = P(4)*P(4) - (X(4) - Xa)*(X(4) - Xa) - (Y(4) - Ya)*(Y(4) - Ya) - (Z(4) - Za)*(Z(4) - Za)

    eps_1 = (-1*b4 + sqrt(b4*b4 - a4*c4))/a4
    eps_2 = (-1*b4 - sqrt(b4*b4 - a4*c4))/a4
    if(abs(eps_1/c)>level_spbu) then
        dt = eps_2/c
    else if(abs(eps_2/c)>level_spbu) then
        dt = eps_1/c
    endif

    X_fin = Xa + dt*c*ax
    Y_fin = Ya + dt*c*ay
    Z_fin = Za + dt*c*az

    !----параметры трансформации
    e_t = (a_WGS*a_WGS - b_WGS*b_WGS)/(a_WGS*a_WGS)
    e_st = (a_WGS*a_WGS - b_WGS*b_WGS)/(b_WGS*b_WGS)

    !----долгота
    lon = atan(Y_fin/X_fin)

    !----широта
    psi = atan((a_WGS*Z_fin)/(b_WGS*sqrt(X_fin*X_fin + Y_fin*Y_fin)))
    lat = atan((Z_fin + e_st*b_WGS*(sin(psi)**3))/(sqrt(X_fin*X_fin + Y_fin*Y_fin) - e_t*a_WGS*(cos(psi)**3)))

endsubroutine geo_coord

!----процедурка для подсчета определителя 3х3

subroutine det3x3(matr, det_out)
    implicit none
	real(8), dimension(3,3), intent(in) :: matr
	real(8), intent(out) :: det_out

    det_out = matr(1,1)*(matr(2,2)*matr(3,3) - matr(2,3)*matr(3,2)) - matr(1,2)*(matr(2,1)*matr(3,3)-matr(2,3)*matr(3,1))
    det_out = det_out + matr(1,3)*(matr(2,1)*matr(3,2)-matr(2,2)*matr(3,1))

endsubroutine det3x3

!---процедурка заполнения рабочей матрицы

subroutine create_mx(m11,m12,m13,m21,m22,m23,m31,m32,m33,matrix)
    implicit none
	real(8), intent(in) :: m11,m12,m13,m21,m22,m23,m31,m32,m33
	real(8), dimension(3,3), intent(out) :: matrix

    matrix(1,1) = m11
    matrix(1,2) = m12
    matrix(1,3) = m13

    matrix(2,1) = m21
    matrix(2,2) = m22
    matrix(2,3) = m23

    matrix(3,1) = m31
    matrix(3,2) = m32
    matrix(3,3) = m33

endsubroutine create_mx


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE CALC_GEN_MASS

! Generates generalized mass from mass matrix and eigenvectors:

!   The generalized mass matrix is a square matrix of terms:

!         MIJ = EIGEN_VEC(i)'*MLL*EIGEN_VEC(j)   where EIGEN_VEC(i) is the ith eigenvector and MLL is the L-set mass matrix
!                                                The ' indicates a transpose of EIGEN_VEC(i)

!   Array GEN_MASS is a 1-D array of the diagonal terms, MIJ (i = j) from the square generalized mass matrix outlined above.
!   This subr calculates all NDOFL diagonal terms of the generalized mass matrix plus all off diagonal terms below the diagonal.
!   The diagonal terms go into array GEN_MASS. The off diagonal terms are not stored, only the largest one, MAXMIJ is kept, and
!   output later, so that the user will know to what accuracy the eigenvectors were calculated

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, NDOFL, NTERM_KLLDn, NTERM_MLLn, NVEC, SOL_NAME
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ZERO, ONE
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG
      USE PARAMS, ONLY                :  EPSIL
      USE SUBR_BEGEND_LEVELS, ONLY    :  CALC_GEN_MASS_BEGEND
      USE EIGEN_MATRICES_1, ONLY      :  GEN_MASS, EIGEN_VEC
      USE MODEL_STUF, ONLY            :  EIG_CRIT, MAXMIJ, MIJ_COL, MIJ_ROW, NUM_FAIL_CRIT
      USE SPARSE_MATRICES, ONLY       :  I_KLLDn, J_KLLDn, KLLDn, I_MLLn, J_MLLn, MLLn
      USE SPARSE_MATRICES, ONLY       :  SYM_MLLn
      USE LAPACK_BLAS_AUX

      USE CALC_GEN_MASS_USE_IFs

      IMPLICIT NONE

      CHARACTER, PARAMETER            :: CR13 = CHAR(13)   ! This causes a carriage return simulating the "+" action in a FORMAT
      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'CALC_GEN_MASS'

      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = CALC_GEN_MASS_BEGEND
      INTEGER(LONG)                   :: I,J,K             ! DO loop indices

      REAL(DOUBLE)                    :: DMIJ              ! DABS of MIJ
      REAL(DOUBLE)                    :: MAX               ! Temporary variable used in finding MAXMIJ
      REAL(DOUBLE)                    :: MIJ               ! The i,j-th value from gen. mass matrix. Used to find MAXMIJ
      REAL(DOUBLE)                    :: OUTVECI(NDOFL,1)  ! One eigenvector
      REAL(DOUBLE)                    :: OUTVECJ(NDOFL,1)  ! One eigenvector
      REAL(DOUBLE)                    :: ZVEC(NDOFL,1)     ! Intermediate matrix in the calculation of GEN_MASS

      INTRINSIC                       :: DABS

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
!xx   WRITE(SC1, * )                                       ! Advance 1 line for screen messages

      NUM_FAIL_CRIT = 0
      MIJ_ROW       = 1
      MIJ_COL       = 1
      MAX           = ZERO
      MAXMIJ        = ZERO

      DO I=1,NVEC

         WRITE(SC1,12345,ADVANCE='NO') I, NVEC, CR13

         DO K=1,NDOFL                                      ! Calc diag terms
            OUTVECI(K,1) = EIGEN_VEC(K,I)
         ENDDO

         IF (SOL_NAME(1:8) == 'BUCKLING') THEN
            CALL MATMULT_SFF ( 'KLLDn', NDOFL, NDOFL, NTERM_KLLDn, 'N'     , I_KLLDn, J_KLLDn, KLLDn, 'OUTVECI', NDOFL, 1,         &
                                OUTVECI, 'N', 'ZVEC', ONE, ZVEC )
         ELSE
            CALL MATMULT_SFF ( 'MLLn' , NDOFL, NDOFL, NTERM_MLLn , SYM_MLLn, I_MLLn , J_MLLn , MLLn , 'OUTVECI', NDOFL, 1,         &
                                OUTVECI, 'N', 'ZVEC', ONE, ZVEC )
         ENDIF

         GEN_MASS(I) = DDOT ( NDOFL, OUTVECI, 1, ZVEC, 1 )
         GEN_MASS(I) = ABS(GEN_MASS(I))
         IF (DEBUG(48) == 0) THEN                          ! Calc off-diag terms

            DO J=1,I-1

               WRITE(SC1,22345,ADVANCE='NO') J, NVEC, I, NVEC, CR13

               DO K=1,NDOFL
                  OUTVECJ(K,1) = EIGEN_VEC(K,J)
               ENDDO

               IF (SOL_NAME(1:8) == 'BUCKLING') THEN
                  CALL MATMULT_SFF ( 'KLLDn', NDOFL, NDOFL, NTERM_KLLDn, 'N'     , I_KLLDn, J_KLLDn, KLLDn, 'OUTVECJ', NDOFL, 1,   &
                                      OUTVECJ, 'N', 'ZVEC', ONE, ZVEC )
               ELSE
                  CALL MATMULT_SFF ( 'MLLn' , NDOFL, NDOFL, NTERM_MLLn , SYM_MLLn, I_MLLn , J_MLLn , MLLn , 'OUTVECJ', NDOFL, 1,   &
                                      OUTVECJ,'N', 'ZVEC', ONE, ZVEC )
               ENDIF

               MIJ = DDOT ( NDOFL, OUTVECI, 1, ZVEC, 1 )

               DMIJ = DABS(MIJ)
               IF (DMIJ > MAX) THEN
                  MAXMIJ  = MIJ
                  MAX     = DMIJ
                  MIJ_ROW = I
                  MIJ_COL = J
               ENDIF
               IF (DMIJ > EIG_CRIT) THEN
                  NUM_FAIL_CRIT = NUM_FAIL_CRIT + 1
               ENDIF

            ENDDO

         ENDIF

      ENDDO

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
12345 format(5X,'Diag term for eigenvector ',i5,' of ',i5,'                                  ',A)

22345 format(5X,'Off-diag term ',i5,' of ',i5,' for vector ',i5,' of ',i5,'                    ',A)

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

      END SUBROUTINE CALC_GEN_MASS


module ode_params
  use, intrinsic :: iso_c_binding
  implicit none

  integer(c_long), parameter :: neq = 3
end module ode_params

! Right hand side of ODE for CVODE to solve.

module rhs_mod
  implicit none

  contains

    integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) &
           result(ierr) bind(C,name='RhsFn')

      use, intrinsic :: iso_c_binding
      use fnvector_serial
      use cvode_interface
      use ode_params

      implicit none

      real(c_double), value :: tn
      type(c_ptr), value    :: sunvec_y
      type(c_ptr), value    :: sunvec_f
      type(c_ptr), value    :: user_data

      ! pointers to data in SUNDAILS vectors
      real(c_double), pointer :: yvec(:)
      real(c_double), pointer :: fvec(:)

      ! get data arrays from SUNDIALS vectors
      call N_VGetData_Serial(sunvec_f, neq, fvec)
      call N_VGetData_Serial(sunvec_y, neq, yvec)

      fvec(1) = -0.04D0 * yvec(1) + 1.0D4 * yvec(2) * yvec(3)
      fvec(3) = 3.0D7 * yvec(2) * yvec(2)
      fvec(2) = -fvec(1) - fvec(3)

      ierr = 0
      return
    end function RhsFn

end module rhs_mod

module jac_mod

  implicit none

  contains

    integer(c_int) function JacFn(N, tn, sunvec_y, sunvec_f, sunDlsMat_J, &
           user_data, tmp1, tmp2, tmp3) result(ierr) bind(C,name='JacFn')
        ! ----------------------------------------------------------------
        ! Description: JacFn provides the Jacobian function J(t,y) = df/dy
        !
        ! Inputs:
        !           N - problem size
        !          tn - current time
        !    sunvec_y - C pointer to current solution N_Vector
        !    sunvec_f - C pointer to right-hand side function N_Vector
        ! sunDlsMat_J - C pointer to dense Jacobian matrix
        !   user_data - C pointer to user-defined data
        !        tmp1 - temporary workspace N_Vector
        !        tmp2 - temporary workspace N_Vector
        !        tmp3 - temporary workspace N_Vector
        !
        ! Output:
        !        ierr - return flag:
        !                0 = success,
        !                1 = recoverable error,
        !               -1 = non-recoverable error
        ! ----------------------------------------------------------------

        !======= Inclusions ===========
        use, intrinsic :: iso_c_binding
        use fnvector_serial
        use sundials_fdlsmat
        use ode_params

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

        ! calling variables
        integer(c_long), value :: N
        real(c_double),  value :: tn
        type(c_ptr),     value :: sunvec_y
        type(c_ptr),     value :: sunvec_f
        type(sundlsmat)        :: sundlsmat_J
        type(c_ptr),     value :: user_data
        type(c_ptr),     value :: tmp1, tmp2, tmp3

        ! pointers to data in SUNDAILS vector and matrix
        real(c_double), pointer :: yvec(:)
        real(c_double), pointer :: Jmat(:,:)

        real(c_double) :: y1, y2, y3

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

        ! get data array from SUNDIALS vector
        call N_VGetData_Serial(sunvec_y, neq, yvec)

        ! get data array from SUNDIALS matrix
        call sundlsmat_GetData_Dense(sundlsmat_J, Jmat)

          y1 = yvec(1)
          y2 = yvec(2)
          y3 = yvec(3)
          jmat(1,1) = -0.04d0
          jmat(1,2) = 1.0d4 * y3
          jmat(1,3) = 1.0d4 * y2
          jmat(2,1) =  0.04d0
          jmat(2,2) = -1.0d4 * y3 - 6.0d7 * y2
          jmat(2,3) = -1.0d4 * y2
          jmat(3,2) = 6.0d7 * y2

          ierr = 0
          return
    end function JacFn

end module jac_mod


! { dg-do run }
!
! Check that MVBITS is available for the largest integer kind (PR 67140)
!
program test
  use iso_fortran_env
  integer, parameter :: k = integer_kinds(size(integer_kinds))

  integer(kind=k) :: i = 6
  call mvbits(7_k,2,2,i,0)
  if (i /= 5) call abort
end


! { dg-do compile }
! { dg-options "-O -fdump-tree-original -finline-matmul-limit=0 -Warray-temporaries" }
program main
  implicit none
  real, dimension(2,2) :: a, b, c, d
  integer :: i
  real :: x, z
  character(60) :: line
  real, external :: ext_func
  interface
     elemental function element(x)
       real, intent(in) :: x
       real :: elem
     end function element
     pure function mypure(x)
       real, intent(in) :: x
       integer :: mypure
     end function mypure
     elemental impure function elem_impure(x)
       real, intent(in) :: x
       real :: elem_impure
     end function elem_impure
  end interface

  data a /2., 3., 5., 7./
  data b /11., 13., 17., 23./
  write (unit=line, fmt='(4F7.2)') matmul(a,b)  &
       & + matmul(a,b)    ! { dg-warning "Creating array temporary" }
  z = sin(x) + cos(x) + sin(x) + cos(x)
  print *,z
  x = ext_func(a) + 23 + ext_func(a)
  print *,d,x
  z = element(x) + element(x)
  print *,z
  i = mypure(x) - mypure(x)
  print *,i
  z = elem_impure(x) - elem_impure(x)
  print *,z
end program main
! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_func" 2 "original" } }
! { dg-final { scan-tree-dump-times "element" 1 "original" } }
! { dg-final { scan-tree-dump-times "mypure" 1 "original" } }
! { dg-final { scan-tree-dump-times "elem_impure" 2 "original" } }


module fcn_isentropic_vortex
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_point,     only: point_t
    use type_function,  only: function_t
    implicit none
    private

    !>  @TODO NEEDS FIXED
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(function_t), public :: isentropic_vortex_f
        private

        real(rk)    :: rho = ONE
        real(rk)    :: p   = ONE

        real(rk)    :: gam  = 1.4_rk
        real(rk)    :: beta = FIVE
        real(rk)    :: xo
        real(rk)    :: yo
        real(rk)    :: zo

        real(rk)    :: uinf = ONE
        real(rk)    :: vinf = ONE
        real(rk)    :: winf = ZERO

        integer(ik) :: ivar

    contains

        procedure   :: init
        procedure   :: compute

    end type isentropic_vortex_f
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(isentropic_vortex_f),  intent(inout)  :: self

        !
        ! Set function name
        !
        !self%name = "isentropic vortex  ::  weeeee!"
        call self%set_name("isentropic vortex  ::  weeeee!")

        !
        ! Set function options to default settings
        !
        call self%dict%set('uinf',1._rk)
        call self%dict%set('vinf',0._rk)
        call self%dict%set('winf',0._rk)
        call self%dict%set('beta',0._rk)
        call self%dict%set('xo',1._rk)
        call self%dict%set('yo',1._rk)
        call self%dict%set('zo',1._rk)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !-----------------------------------------------------------------------------------------
    elemental function compute(self,time,coord) result(val)
        class(isentropic_vortex_f),     intent(in)  :: self
        real(rk),                       intent(in)  :: time
        type(point_t),                  intent(in)  :: coord

        real(rk)                                    :: val

        real(rk)    :: x,   y,   z, &
                       du, dv, u, v, w, &
                       gam, beta, r, T, rho, p

        x = coord%c1_
        y = coord%c2_
        z = coord%c3_

        gam = self%gam
        beta = self%beta

        r = sqrt((x - self%xo)**TWO + (y - self%yo)**TWO)
        T = ONE - ((gam - ONE)*(beta**TWO)/(EIGHT*gam*PI**TWO))*exp(ONE - r**TWO)
        rho = T**(ONE/(gam-ONE))
        p   = rho*T

        du = (beta/(TWO*PI))*exp((ONE-r**TWO)/TWO)*(-(y-self%yo))
        dv = (beta/(TWO*PI))*exp((ONE-r**TWO)/TWO)*((x-self%xo))
        u  = self%uinf + du
        v  = self%vinf + dv
        w  = ZERO

        select case (self%ivar)
            ! RHO
            case (1)
                val = rho

            ! RHO-U
            case (2)
                val = rho*u

            ! RHO-V
            case (3)
                val = rho*v

            ! RHO-W
            case (4)
                val = rho*w

            ! RHO-E
            case (5)
                val = p/(gam-ONE)  +  HALF*rho*(u*u + v*v + w*w)

        end select

    end function compute
    !**********************************************************************************

end module fcn_isentropic_vortex


      SUBROUTINE REDUCE (N,MA,A,MB,B,LOW,IGH,CSCALE,WK)
CSE
C
CPS       PURPOSE:
C
C             REDUCES, IF POSSIBLE, THE ORDER OF THE GENERALIZED
C             EIGENVALUE PROBLEM A*X = (LAMBDA)*B*X BY PERMUTING
C             THE ROWS AND COLUMNS OF A AND B SO THAT THEY EACH HAVE
C             THE FORM
C                        U  X  Y
C                        0  C  Z
C                        0  0  R
C
C             WHERE U AND R ARE UPPER TRIANGULAR AND C,X,Y,AND Z ARE
C             ARBITRARY. THUS, THE ISOLATED EIGENVALUES CORRESPONDING
C             TO THE TRIANGULAR MATRICES ARE OBTAINED BY A DIVISION,
C             LEAVING ONLY EIGENVALUES CORRESPONDING TO THE CENTER
C             MATRICES TO BE COMPUTED.
C
CPE
CAS          ***  ARGUMENT LIST  ***
C
C  INPUT PARAMETERS:
C
C  N - THE ORDER OF THE MATRICES A AND B;
C
C  MA - THE ROW (FIRST) DIMENSION OF THE ARRAY A AS SPECIFIED
C       IN THE CALLING PROGRAM;
C
C  A - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MA AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX A AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  MB - THE ROW (FIRST) DIMENSION OF THE ARRAY B AS SPECIFIED IN
C       THE CALLING PROGRAM;
C
C  B - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MB AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX B AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE.
C
C  OUTPUT PARAMETERS:
C
C  A - CONTAINS THE PERMUTED A MATRIX;
C
C  B - CONTAINS THE PERMUTED B MATRIX;
C
C  LOW - THE INTEGER SPECIFYING THE BEGINNING INDEX OF THE SUBMATRICES
C        OF A AND B CONTAINING THE NON-ISOLATED EIGENVALUES;
C
C  IGH - THE INTEGER SPECIFYING THE ENDING INDEX OF THE SUBMATRICES
C        OF A AND B CONTAINING THE NON-ISOLATED EIGENVALUES. IF
C        IGH=1 (THEN LOW MUST BE 1 ALSO), THE PERMUTED A AND B
C        MATRICES ARE UPPER TRIANGULAR;
C
C  CSCALE - THE REAL ARRAY OF DIMENSION AT LEAST N CONTAINING THE
C           REQUIRED COLUMN PERMUTATIONS IN ITS FIRST LOW-1 AND ITS
C           IGH+1 THROUGH N LOCATIONS;
C
C  WK - THE REAL ARRAY OF DIMENSION AT LEAST N CONTAINING THE
C       REQUIRED ROW PERMUTATIONS IN ITS FIRST LOW-1 AND ITS
C       IGH+1 THROUGH N LOCATIONS.
C
CAE
C  REQUIRED SUBPROGRAMS - NONE
C
C  REQUIRED FUNCTIONS - NONE
C
C  REFERENCE - R.C. WARD, BALANCING THE GENERALIZED EIGENVALUE
C              PROBLEM, TECHNICAL REPORT ORNL/CSD-47, OAK RIDGE,
C              TENNESSEE, 1979.
C
C              [SAME TITLE] SIAM J. SCI. STAT. COMPUT., VOL 2,
C                           NO 2, JUNE 1981, PP 141-152.
C
C ****
C
      DIMENSION A(MA,N),B(MB,N),CSCALE(N),WK(N)
      DOUBLE PRECISION A,B,CSCALE,WK,F
      K = 1
      L = N
      GO TO 20
C ****
C     FIND ROW WITH ONE NONZERO IN COLUMNS 1 THROUGH L
C ****
   10 L = LM1
      IF (L .NE. 1) GO TO 20
      WK(1) = 1
      CSCALE(1) = 1
      GO TO 200
C
   20 LM1 = L-1
      DO 70 II=1,L
         I = L+1-II
         DO 30 J=1,LM1
            JP1 = J+1
            IF (A(I,J) .NE. 0. .OR. B(I,J) .NE. 0.) GO TO 40
   30    CONTINUE
         J = L
         GO TO 60
   40    DO 50 J=JP1,L
            IF (A(I,J) .NE. 0. .OR. B(I,J) .NE. 0.) GO TO 70
   50    CONTINUE
         J = JP1-1
   60    M = L
         IFLOW = 1
         GO TO 150
   70 CONTINUE
      GO TO 90
C ****
C     FIND COLUMN WITH ONE NONZERO IN ROWS K THROUGH N
C ****
   80 K = K+1
C
   90 DO 140 J=K,L
         DO 100 I=K,LM1
            IP1 = I+1
            IF (A(I,J) .NE. 0. .OR. B(I,J) .NE. 0.) GO TO 110
  100    CONTINUE
         I = L
         GO TO 130
  110    DO 120 I=IP1,L
            IF (A(I,J) .NE. 0. .OR. B(I,J) .NE. 0.) GO TO 140
  120    CONTINUE
         I = IP1-1
  130    M = K
         IFLOW = 2
         GO TO 150
  140 CONTINUE
      GO TO 200
C ****
C     PERMUTE ROWS M AND I
C ****
  150 WK(M) = I
      IF (I .EQ. M) GO TO 170
      DO 160 IS=K,N
         F = A(I,IS)
         A(I,IS) = A(M,IS)
         A(M,IS) = F
         F = B(I,IS)
         B(I,IS) = B(M,IS)
         B(M,IS) = F
  160 CONTINUE
C ****
C     PERMUTE COLUMNS M AND J
C ****
  170 CSCALE(M) = J
      IF (J .EQ. M) GO TO 190
      DO 180 IS=1,L
         F = A(IS,J)
         A(IS,J) = A(IS,M)
         A(IS,M) = F
         F = B(IS,J)
         B(IS,J) = B(IS,M)
         B(IS,M) = F
  180 CONTINUE
C
  190 GO TO (10,80), IFLOW
C ****
C     EXIT REDUCE
C ****
  200 LOW = K
      IGH = L
      RETURN
      END


!
! Hyperbolic step functions for differentiable replacement of IF statements
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 09-Nov-2010
!                       paul.vandelst@noaa.gov
!

MODULE CSEM_Hyperbolic_Step

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE CSEM_Type_Kinds, ONLY: fp => CSEM_fp
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Hyperboic_Step
  PUBLIC :: Hyperboic_Step_TL
  PUBLIC :: Hyperboic_Step_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id: Hyperbolic_Step.f90 21141 2012-09-14 17:40:43Z paul.vandelst@noaa.gov $'
  ! Literals
  REAL(fp), PARAMETER :: ZERO   = 0.0_fp
  REAL(fp), PARAMETER :: POINT5 = 0.5_fp
  REAL(fp), PARAMETER :: ONE    = 1.0_fp
  ! X-input maximum value
  REAL(fp), PARAMETER :: XCUTOFF = 70.0_fp

CONTAINS

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Hyperboic_Step
!
! PURPOSE:
!       Subroutine to compute a hyperbolic, differentiable, step function:
!
!         g(x) = 0.5(1 + TANH(x))
!
!       NOTE: No input checking of the validity of the x-argument for use
!             with TANH() is done.
!
! CALLING SEQUENCE:
!       CALL Hyperboic_Step( x, g )
!
!
! INPUTS:
!       x:      The function abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       g:      The hyperbolic step function value.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Hyperboic_Step( x, g )
    REAL(fp), INTENT(IN)  :: x
    REAL(fp), INTENT(OUT) :: g
    g = POINT5 * ( ONE + TANH(x) )
  END SUBROUTINE Hyperboic_Step

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Hyperboic_Step_TL
!
! PURPOSE:
!       Subroutine to compute the tangent-linear form of a hyperbolic,
!       differentiable, step function:
!
!         g(x) = 0.5(1 + TANH(x))
!
!       NOTE: Computations are only performed for input |x| < 70 to avoid
!             infinite result for COSH().
!
! CALLING SEQUENCE:
!       CALL Hyperboic_Step_TL( x, x_TL, g_TL )
!
!
! INPUTS:
!       x:      The function abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
!       x_TL:   The tangent-linear abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       g_TL:   The tangent-linear hyperbolic step function value.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Hyperboic_Step_TL( x, x_TL, g_TL )
    REAL(fp), INTENT(IN)  :: x, x_TL
    REAL(fp), INTENT(OUT) :: g_TL
    IF ( ABS(x) < XCUTOFF ) THEN
      g_TL = POINT5 * x_TL / COSH(x)**2
    ELSE
      g_TL = ZERO
    END IF
  END SUBROUTINE Hyperboic_Step_TL

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Hyperboic_Step_AD
!
! PURPOSE:
!       Subroutine to compute the adjoint of a hyperbolic, differentiable,
!       step function:
!
!         g(x) = 0.5(1 + TANH(x))
!
!       NOTE: Computations are only performed for input |x| < 70 to avoid
!             infinite result for COSH().
!
! CALLING SEQUENCE:
!       CALL Hyperboic_Step_AD( x, g_AD, x_AD )
!
!
! INPUTS:
!       x:      The function abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
!       g_AD:   The adjoint hyperbolic step function value.
!               NOTE: *** SET TO ZERO UPON EXIT ***
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       x_AD:   The adjoint abscissa.
!               NOTE: *** MUST CONTAIN VALUE UPON ENTRY ***
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Hyperboic_Step_AD( x, g_AD, x_AD )
    REAL(fp), INTENT(IN)     :: x
    REAL(fp), INTENT(IN OUT) :: g_AD  ! AD Input
    REAL(fp), INTENT(IN OUT) :: x_AD  ! AD Output
    IF ( ABS(x) < XCUTOFF ) THEN
      x_AD = x_AD + POINT5 * g_AD / COSH(x)**2
    END IF
    g_AD = ZERO
  END SUBROUTINE Hyperboic_Step_AD

END MODULE CSEM_Hyperbolic_Step


Subroutine computeMinDetQ &
    (AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)

	use funcAux
	use multiscaleLib, only : getMinDetQ

    implicit none

    !   ===== SUBROUTINE ARGUMENTS  =======
    integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
    Real*8 :: DelT, DTm,Time ! all reals
    Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

    !   =====   END ARGUMENTS  =======
    integer, parameter :: NdimE = 2, nStepTheta = 999
    integer :: ip1 , ip2, iShiftC, iShiftMinDetQ, iShiftThetaCrit
    Real*8 ::  MinDetQ, ThetaCrit, betaCrit

	iShiftC = nint(commonPar(1))
	iShiftMinDetQ = nint(commonPar(2))
	iShiftThetaCrit = nint(commonPar(3))

	call getMinDetQ(minDetQ,ThetaCrit,betaCrit, Sol1,NdimE,idofT,1,iShiftC,nStepTheta) !! is '1' because is just one node

	ip1 = iShiftMinDetQ + 1
	ip2 = iShiftThetaCrit + 1

	AE(ip1,ip1) = 1.0d0
	AE(ip2,ip2) = 1.0d0
	AE(ip2 + 1,ip2 + 1) = 1.0d0

	BE(ip1) =  MinDetQ

	if(MinDetQ<0.0d0) then !! ThetaCrit is the immediately pre bifurcation angle
		BE(ip2) =  Sol1(ip2)
	else
		BE(ip2) =  ThetaCrit
		BE(ip2 + 1) =  betaCrit
	end if

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine computeMinDetQS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    use funcAux

    implicit none

    Integer :: MaxLRows,Ndim,iDofT, iAdd
    Integer ::  Coupling(MaxLRows,MaxLRows)
    Real*8 :: CommonPar(*)
    integer :: iShiftMinDetQ, iShiftThetaCrit, ip1, ip2

	iShiftMinDetQ = nint(commonPar(2))
	iShiftThetaCrit = nint(commonPar(3))

	ip1 = iShiftMinDetQ + 1
	ip2 = iShiftThetaCrit + 1

	Coupling(ip1,ip1) = 1
	Coupling(ip2,ip2) = 1

end Subroutine