      REAL*8 FUNCTION SL3B0A(MST12,M12,M22,INUM)
      IMPLICIT NONE
      REAL*8 MST12,M12,M22
      INTEGER INUM

      IF (INUM.EQ.1)
     +     SL3B0A = -LOG(M12/MST12)
C***  FINITE PART OF B0(K1,M1,M1)

      IF (INUM.EQ.2)
     +     SL3B0A = 1.D0 -M12/(M12 -M22)*LOG(M12/M22) -Log(m22/mst12)
C***  FINITE PART OF B0(K1,M1,M2)

      RETURN
      END

      REAL*8 FUNCTION SL3B0B(S,MST12,M12,INUM)
      IMPLICIT NONE
      REAL*8 S,MST12,M12
      COMPLEX*16 KBETA,KX
      INTEGER INUM

      IF (INUM.EQ.1)
     +     SL3B0B = 2.D0 - LOG(S/MST12)
C***  FINITE PART OF B0(K1+K2,0,0)

      IF (INUM.EQ.2) THEN
         KBETA  = SQRT( DCMPLX(1.D0 - 4.D0*M12/S))
         KX     = (DCMPLX(1.D0) -KBETA)*(DCMPLX(1.D0)+KBETA)**(-1)
         SL3B0B = 2.D0 -LOG(M12/MST12) +REAL(KBETA*LOG(-KX))
C***  FINITE PART OF B0(K1+K2,M1,M1)
      END IF

      RETURN
      END

      REAL*8 FUNCTION SL3B0C(MST12,M12,M22,INUM)
      IMPLICIT NONE
      REAL*8 MSt12,M12,M22
      COMPLEX*16 KDEL,KA,KB,KX1,KX2
      INTEGER INUM

      IF (INUM.EQ.1)
     +     SL3B0C = 2.D0
C***  FINITE PART OF B0(-P2,0,MST1)

      IF (INUM.EQ.2) THEN
         KDEL = (0.D0,1.D-15)
         KA = dcmplx(1.D0 +(M12 -M22)/Mst12)
         KB = dcmplx(M12/Mst12) -KDEL
         KX1 = KA/2.D0 + SQRT(KA**2/4.D0 - KB)
         KX2 = KA/2.D0 - SQRT(KA**2/4.D0 - KB)
         SL3B0C = 2.D0 + real(
     +        - (1.D0 -KX1)*LOG(1.D0-KX1) -KX1*LOG(-KX1)
     +        - (1.D0 -KX2)*LOG(1.D0-KX2) -KX2*LOG(-KX2) )
C***  FINITE PART OF B0(-P2,M1,m2)
      END IF

      RETURN
      END

      REAL*8 FUNCTION SL3B0D(T,MSt12,M12,M22,INUM)
      IMPLICIT NONE
      REAL*8 MSt12,M12,M22,T,A,B,X1,X2
      INTEGER INUM

      IF (INUM.EQ.1)
     +     SL3B0D = 2.D0 -(T-MSt12)/T*LOG((MSt12-T)/MSt12)
C***  FINITE PART OF B0(K2-P2,0,MST1)

      IF (INUM.EQ.2) THEN
         A = 1.D0 +(M12 -M22)/T
         B = M12/T
         X1 = A/2.D0 + SQRT(A**2/4.D0 - B)
         X2 = A/2.D0 - SQRT(A**2/4.D0 - B)
         SL3B0D = 2.D0 -LOG(-T/MST12)
     +        - (1.D0 -X1)*LOG(ABS(1.D0-X1)) -X1*LOG(ABS(-X1))
     +        - (1.D0 -X2)*LOG(ABS(1.D0-X2)) -X2*LOG(ABS(-X2))
C***  FINITE PART OF B0(K2-P2,M1,M2)
      END IF

      RETURN
      END

      REAL*8 FUNCTION SL3BP(MSt12,M12,M22,INUM)
      IMPLICIT NONE
      REAL*8 MST12,M12,M22,M2
      COMPLEX*16 KA,KB,KX1,KX2,KDEL
      INTEGER INUM

      IF (INUM.EQ.1)
     +     SL3BP = -1.D0/MST12
C***  FINITE PART OF B0P(-P2,0,MST1)

      IF (INUM.EQ.2) THEN
         KDEL = (0.D0,1.D-15)
         KA = dcmplx(1.D0 +(M12 -M22)/MST12)
         KB = dcmplx(M12/MST12) -KDEL
         KX1 = KA/2.D0 + SQRT(KA**2/4.D0 - KB)
         KX2 = KA/2.D0 - SQRT(KA**2/4.D0 - KB)
         SL3BP    = (-1D0 + real(
     +        + (kx1 -kx1**2)/(kx1-kx2)*log((kx1-1.D0)/kx1)
     +        - (kx2 -kx2**2)/(kx1-kx2)*log((kx2-1.D0)/kx2) ))/MST12
C***  FINITE PART OF B0P(-P2,M1,M2)
      END IF

      IF (INUM.EQ.3) THEN
         M2 = M22 -M12
         SL3BP  = -1.D0/2.D0/M2 +M22/M2**2 - M22*M12/M2**3*LOG(M22/M12)
C***  FINITE PART OF B0P(K1,M1,M2)
      END IF

      RETURN
      END

      REAL*8 FUNCTION SL3C0A(S,MST12,M12,M22,INUM)
      IMPLICIT NONE
      REAL*8 MST12,M12,M22,S,ZETA2,pi,SPENCE
      COMPLEX*16 KX,KBEta,KSPENC
      INTEGER INUM

      IF (INUM.EQ.1) THEN
         pi = 4D0 * atan(1D0)
         ZETA2 = pi**2/6D0
         SL3C0A = 1.D0/S*( 0.5D0*LOG(S/MST12)**2 - 3.5D0*ZETA2)
      END IF
C***  FINITE PART OF C0(K1,K2,0,0,0)

      IF (INUM.EQ.2) THEN
         KBETA  = SQRT( DCMPLX(1.D0 - 4.D0*M12/S))
         KX     = (DCMPLX(1.D0) -KBETA)*(DCMPLX(1.D0)+KBETA)**(-1)
         SL3C0A = 1.D0/S * REAL( LOG(-KX)**2 )/2.D0
C***  FINITE PART OF C0(K1,K2,M1,M1,M1)
      END IF

      IF (INUM.EQ.3) THEN
         KBETA  = SQRT( DCMPLX(1.D0 - 4.D0*M12/S))
         KX     = (DCMPLX(1.D0) -KBETA)*(DCMPLX(1.D0)+KBETA)**(-1)
         SL3C0A = 1.D0/S * REAL(
     +        + LOG(-KX)**2 +KSPENC(1.D0 +M22/M12*KX)
     +        + KSPENC(1.D0 +M22/M12/KX)
     +        -2.D0*SPENCE(1.D0 -M22/M12) )
C***  FINITE PART OF C0(K1,K2,M1,M2,M1)
      end if

      RETURN
      END

      REAL*8 FUNCTION SL3C0B(S,MSt12,M12,M22,INUM)
      IMPLICIT NONE
      REAL*8 MST12,M12,M22,S,SB,pi,ZETA2,SPENCE,C0GENS,beta,xs
      INTEGER INUM
      pi = 4D0 * atan(1D0)
      ZETA2 = pi**2/6D0
      beta = sqrt(1d0 - 4*mst12/s)
      sb = s *beta
      Xs = (1d0 -beta)/(1d0 +beta)

      IF (INUM.EQ.1)
     +     SL3C0B = 1.D0/SB *(
     +     - 2.D0*SPENCE(XS) - 2.D0*LOG(XS)*LOG(1-XS)
     +     + LOG(XS)**2/2.D0 - 4.D0*ZETA2 )
C***  FINITE PART OF C0(P1,-P2,MST1,0,MST1)

      IF (INUM.EQ.2)
     +     SL3C0B= 1.D0/SB*(2.D0*SPENCE(-XS) + 0.5D0*LOG(XS)**2 +ZETA2)
C***  FINITE PART OF C0(-P1,-P2,0,MST1,0)

      IF (INUM.EQ.3)
     +     SL3C0B = C0GENS(S,MST12,M12,M22)
C***  FINITE PART OF C0(-P1,-P2,M2,M1,M2)

      RETURN
      END

      REAL*8 FUNCTION SL3C0C(T,MST12,M12,M22,M32,INUM)
      IMPLICIT NONE
      REAL*8 MST12,M12,M22,M32,T,T1,SPENCE,Pi,ZETA2,C0FIN,DEL
      INTEGER INUM
      pi = 4D0 * atan(1D0)
      ZETA2 = pi**2/6D0
      T1 = T -MST12
      DEL = 1.D-4

      IF (INUM.EQ.1)
     +     SL3C0C = 1.D0/T1*
     +     (+ 0.25D0*ZETA2 + LOG(-T1/MST12)**2 +SPENCE(T/MST12))
C***  FINITE PART OF C0(K2,-P2,0,0,MST1)

      IF (INUM.EQ.2)
     +     SL3C0C = C0FIN(DEL,MST12,T,M12,M22,M32)
C***  FINITE PART OF C0(K2,-P2,M1,M2,m3)

      IF (INUM.EQ.3)
     +     SL3C0C = 1.D0/T1*(ZETA2 - SPENCE(T/MST12))
C***  FINITE PART OF C0(K2,-P2,MST1,MST1,0)

      RETURN
      END

      REAL*8 FUNCTION SL3D0(S,T,U,MSt12,M12,M22,M32,INUM)
      IMPLICIT NONE
      REAL*8 MST12,S,T,U,SB,beta,XS,SPENCE,ZETA2,pi,T1,U1
      REAL*8 M12,M22,M32,M1,M2,M3,Rd0REG
      INTEGER INUM
      pi = 4D0 * atan(1D0)
      ZETA2 = pi**2/6D0
      T1 = T -MST12
      U1 = U -MST12
      beta = sqrt(1d0 - 4*mst12/s)
      sb = s *beta
      Xs = (1d0 -beta)/(1d0 +beta)

      IF (INUM.EQ.1)
     +     SL3D0 =
     +     1.D0/S/T1*(2.D0*LOG(S/MST12)*LOG(-T1/MST12) -4.D0*ZETA2)
C***  FINITE PART OF D0(K1,K2,-P2,0,0,0,MST1)

      IF (INUM.EQ.2)
     +     SL3D0 = 1.D0/SB/T1 *(
     +     -2.D0*LOG(XS)*LOG(1.D0-XS) +2.D0*LOG(XS)*LOG(1.D0+XS)
     +     -2.D0*LOG(XS)*LOG(-T1/MST12) -2.D0*SPENCE(XS)
     +     +2.D0*SPENCE(-XS) -3.D0*ZETA2 )
C***  FINITE PART OF D0(K1,K2,-P2,MSt1,MSt1,MSt1,0)

      IF (INUM.EQ.3)
     +     SL3D0 = 1.D0/T1/U1 *(
     +     2.D0*LOG(-T1/MST12)*LOG(-U1/MST12) -7.D0/2.D0*ZETA2 )
C***  FINITE PART OF D0(K1,-P2,K2,MST1,MST1,0,0)

      IF (INUM.eq.4) THEN
         M1 = SQRT(M12)
         M2 = SQRT(M22)
         SL3D0 = RD0REG(MST12,0.D0,0.D0,MST12,S,T,M1,M2,M2,M2)
C***  FINITE PART OF D0(K1,K2,-P2,M2,M2,M2,M1)
      END IF

      IF (INUM.eq.5) THEN
         M1 = SQRT(M12)
         M2 = SQRT(M22)
         SL3D0 =  RD0REG(0.D0,MST12,0.D0,MST12,U,T,M1,M1,M2,M2)
C***  FINITE PART OF D0(K1,-P2,K2,M1,M1,M2,M2)
      END IF

      IF (INUM.eq.6) THEN
         M1 = SQRT(M12)
         M2 = SQRT(M22)
         M3 = SQRT(M32)
         SL3D0 = RD0REG(MST12,0.D0,0.D0,MST12,S,T,M1,M2,M3,M2)
C***  FINITE PART OF D0(K1,K2,-P2,M2,M3,M2,M1)
      END IF

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                     C
C     SUBROUTINE CALCULATING THE GENERAL MASSIVE THREE POINT FUNCTION C
C                                                                     C
C           Cc(p0**2,p1**2,p2**2,m0**2,m1**2,m2**2)                   C
C                                                                     C
C      ONLY THE REAL PART :                                           C
C                                                                     C
C           C(p0**2,p1**2,p2**2,m0**2,m1**2,m2**2)                    C

c ---------------------------------------------------------------------

      real*8 function C0fin(p02,p12,p22,m02,m12,m22)
      implicit real*8 (a-h,m,o-y), complex*16 (z)
      complex*16 Cc
c$$$  attention to different notation

      C0fin = real(Cc(p02,p12,p22,m12,m22,m02))
      return
      end

c ---------------------------------------------------------------------
      complex*16 function Cc(p02,p12,p22,m02,m12,m22)
      implicit real*8 (a-h,m,o-y), complex*16 (z)
      complex*16 Kspenc,detafct
      dimension m2(0:2),p2(0:2,0:2),zy0(0:2),zalpha(0:2)
      dimension zx(0:2,0:1),zy(0:2,0:1)

      zi = dcmplx(0.D0,1.D0)
      pi = 4D0*atan(1.D0)
      eps=1.D-14

* remember the masses in denner's article :
*     m(0) between p1 and p2 -> m1
*     m(1) between p1 and p0 -> m0
*     m(2) between p2 and p0 -> m2

      m2(0) = m12
      m2(1) = m02
      m2(2) = m22

      p2(1,0) = p12
      p2(2,0) = p22
      p2(2,1) = p02

      do 77, i=0,2
         p2(i,i) = 0
         do 77, j=i+1,2
             p2(i,j) = p2(j,i)
 77   continue

      zkappa = sqrt( dcmplx( p2(1,0)**2
     &                        +p2(2,1)**2
     &                        +p2(2,0)**2
     &                        -2.D0*( p2(1,0)*p2(2,1)
     &                             +p2(1,0)*p2(2,0)
     &                             +p2(2,0)*p2(2,1) ) ))

       if (real(zi*zkappa) .ne. 0.D0) then
         write(6,*)'warning !!!'
       endif

      do 78 i=0,2
         j=mod(i+1,3)
         k=mod(j+1,3)

         zy0(i) = ( p2(j,k) * ( p2(j,k)
     &                         -p2(k,i)
     &                         -p2(i,j)
     &                         +2.D0*m2(i)
     &                         -m2(j)
     &                         -m2(k)   )
     &          - ( p2(k,i)
     &             -p2(i,j) ) * ( m2(j)
     &                           -m2(k) )
     &          + zkappa*( p2(j,k)
     &                    -m2(j)
     &                    +m2(k)  )
     &                                    )/( 2.D0 * zkappa * p2(j,k) )

         if (zy0(i) .eq. 1.D0) then
           zy0(i) = zy0(i)*(1.D0+eps)
         endif

         zalpha(i) = sqrt( dcmplx( p2(j,k)**2
     &                              +m2(j)**2
     &                              +m2(k)**2
     &                              -2.D0*( p2(j,k)*m2(j)
     &                                   +p2(j,k)*m2(k)
     &                                   +m2(j)*m2(k)  ) ))
     &             *( 1.D0
     &               +zi * eps * p2(j,k) )

         do 78 ip=0,1
             zx(i,ip) = ( p2(j,k)
     &                   -m2(j)
     &                   +m2(k)
     &                   +(-1)**ip * zalpha(i) ) /( 2.D0 * p2(j,k) )

             zy(i,ip) = zy0(i)
     &                 -zx(i,ip)
 78      continue

      zc = dcmplx(0.D0,0.D0)

      do 87, i=0,2
         j=mod(i+1,3)
         k=mod(j+1,3)

         zc1 = dcmplx(0.D0,0.D0)
         do 88, ip=0,1
            zc2 = Kspenc( (zy0(i)-1.D0)/zy(i,ip) )
     &           -Kspenc( zy0(i)/zy(i,ip) )
     &           +detafct( 1D0-zx(i,ip) , 1.D0/zy(i,ip) )
     &                             * log( (zy0(i)-1.D0)/zy(i,ip) )
     &           -detafct( -zx(i,ip) , 1.D0/zy(i,ip) )
     &                             * log( zy0(i)/zy(i,ip) )

 88      zc1 = zc1 + zc2

         zc1 = zc1
     &       - ( detafct( -zx(i,0) , -zx(i,1) )
     &          -detafct( zy(i,0) , zy(i,1) )
     &          -2.D0*pi*zi*Dthetafct( -p2(j,k) )
     &                   *Dthetafct( -real( -zi*zy(i,0)*zy(i,1) ) )  )
     &       * log( (1.D0-zy0(i))/(-zy0(i)) )
 87   zc = zc + zc1

      Cc = zc/zkappa

      return
      end

c -----------------------------------
      complex*16 function detafct(z1,z2)
      implicit real*8 (a-h,o-y), complex*16 (z)

      pi=4.D0*atan(1.D0)

      zi=dcmplx(0.D0,1.D0)
      x1=aimag(z1)
      x2=aimag(z2)
      x12=aimag(z1*z2)

      detafct=2.D0*pi*zi*(
     &     Dthetafct(-x1) * Dthetafct(-x2) * Dthetafct(x12)
     &     -Dthetafct(x1)  * Dthetafct(x2)  * Dthetafct(-x12) )

      return
      end

c ----------------------------------------
      real*8 function Dthetafct(x)
      implicit real*8 (a-h,o-y), complex*16 (z)

      if (x.gt.1.d-99) then
        Dthetafct=1.D0
      else
        Dthetafct=0.D0
      endif

      return
      end


      SUBROUTINE  MAGFAC

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

C
C  PURPOSE:
C      MAGFAC CALCULATES THE DISTANCE BETWEEN ADJACENT GRID POINTS AND
C      THE AREAS OF THE GRID SQUARES, AND CALCULATES THE CORIOLIS
C      PARAMETERS.
C  MODIFIED FROM ORIGINAL BY
C      STEVE POHORSKY    INFORMATICS     TASK 605    JUL 82
C  FOR
C      JIM POLLACK
C  ENVIRONMENT
C      Cray-2            UNICOS 3.0      FORTRAN
C  REVISION HISTORY
C
C  INPUT PARAMETERS
C      RAD     - RADIUS OF MARS IN METERS.
C      DLAT    - THE LATITUDINAL SPACING BETWEEN GRID POINTS IN RADIANS
C                ( PI/36 ).
C      DLON    - THE LONGITUDINAL SPACING BETWEEN GRID POINTS IN RADIANS
C                ( 2*PI/60 ).
C  OUTPUT PARAMETERS
C      LAT(J) ARRAY   - THE LATITUDE OF THE 'PI' GRID POINTS WITH INDEX
C                       J (IN RADIANS.)
C      DXV(J) ARRAY   - EAST-WEST DISTANCE IN METERS BETWEEN ADJACENT
C                       'PI' GRID POINTS.
C      DXU(J) ARRAY   - EAST-WEST DISTANCE IN METERS BETWEEN ADJACENT
C                       'U,PI' GRID POINTS.
C      DXYP(J) ARRAY  - THE AREA OF THE GRID SQUARE AROUND A 'PI' GRID
C                       POINT AT LATITUDE INDEX J. (THE GRID SQUARE IS
C                       THE TRAPEZOID FORMED BY THE FOUR NEIGHBORING
C                       'U,V' POINTS. )
C  CALLED BY
C      INPUT
C
      use grid_h
      use defines_h
      use constants_h, only: PI
      use standard_h

      implicit none

C######################################################################
      integer :: j
C#=====================================================================

C The C grid variables are offset in a strange way such that the C PI grid
C is offset from the pole by DY, NOT DY/2, even though PI points are
C not stored at the pole in the C grid
C
      DO J = 1,L_JSIZE-1
        LAT(J) = (REAL(J)*PI/REAL(L_JSIZE))-(PI/2.0)
      END DO

      DO 420 J=1,L_JSIZE-1
        DXU(J) = RAD*COS(LAT(J))*DLON
  420 CONTINUE

      DO 430 J=2,L_JSIZE-1
        DXV(J) = 0.5*(DXU(J)+DXU(J-1))
  430 CONTINUE

      DXV(1)       = 0.0
      DXV(L_JSIZE) = 0.0

      DO 440 J=2,L_JSIZE-2
        DYV(J) = RAD*DLAT
  440 CONTINUE

      DYV(1)         = RAD*DLAT*1.0
      DYV(L_JSIZE-1) = RAD*DLAT*1.0

      DO 445 J=2,L_JSIZE-2
        DXYP(J) = 0.5*(DXV(J)+DXV(J+1))*DYV(J)
  445 CONTINUE
      DXYP(1) = DXU(1)*DYV(1)
      DXYP(L_JSIZE-1) = DXU(L_JSIZE-1)*DYV(L_JSIZE-1)

      RETURN
      END


function yyy_surf(xxx)
common/surface/nsurf,xsurf(100),ysurf(100)

if(xxx.lt.xsurf(1)) then
	isrf=1
	x1=xsurf(1)
	x2=xsurf(2)
else if(xxx.gt.xsurf(nsurf)) then
	isrf=nsurf-1
	x1=xsurf(nsurf-1)
	x2=xsurf(nsurf)
else
	do isrf=1,nsurf-1
		x1=xsurf(isrf)
		x2=xsurf(isrf+1)
		if((x1-xxx)*(x2-xxx).le.0) exit
	end do
end if

y1=ysurf(isrf)
y2=ysurf(isrf+1)

yyy_surf = y1+((y2-y1)/(x2-x1))*(xxx-x1)

return
end


        subroutine sidereal_time(ut1,lon,lst)

      IMPLICIT REAL*8(A,B,C,D,E,F,G,H,O,P,Q,R,S,T,U,V,W,X,Y,Z)
      REAL*8 LST,LON

      include '../../include/astparms.for'

!       UT1 is in days (JD)
!       lon is in degrees (West is negative)
!       lst is in radians

        parameter (rad_per_sec = 2d0 * pi / 86400d0)

      Tu=(ut1-2451545.D0)/36525.d0

        gmst_0ut = 24110.54841d0 +
     1     Tu * (8640184.812866d0  + Tu * (.093104d0 - Tu * 6.2d-6))

        gmst_0ut = gmst_0ut * rad_per_sec

        lst = gmst_0ut + (ut1+.5d0) * 2d0 * pi + lon * rpd

        lst = mod(lst,2d0*pi)

        return
        end


      SUBROUTINE CHSTWO(BINS1,BINS2,NBINS,KNSTRN,DF,CHSQ,PROB)
      DIMENSION BINS1(NBINS),BINS2(NBINS)
      DF=NBINS-1-KNSTRN
      CHSQ=0.
      DO 11 J=1,NBINS
        IF(BINS1(J).EQ.0..AND.BINS2(J).EQ.0.)THEN
          DF=DF-1.
        ELSE
          CHSQ=CHSQ+(BINS1(J)-BINS2(J))**2/(BINS1(J)+BINS2(J))
        ENDIF
11    CONTINUE
      PROB=GAMMQ(0.5*DF,0.5*CHSQ)
      RETURN
      END


      SUBROUTINE Q2BCD (EST,PLANAR,RMAT,ET,IERROR)
C
C     BASIC CALCULATIONS ARE PERFORMED FOR THE QDMEM2 ELEMENT IN THIS
C     ROUTINE (DOUBLE-PRECISION VERSION)
C
      LOGICAL          PLANAR
      REAL             EST(1)
      DOUBLE PRECISION MAG    ,D12(3) ,G1(3) ,IAREA  ,D13(3),GRID(3,5),
     1                 G2(3)  ,ITWOH  ,D24(3),VEC(3) ,G3(3) ,ET(3,3)  ,
     2                 G5(3)  ,G4(3)  ,DADOTB,RMAT(3,5)
      EQUIVALENCE      (GRID(1,1),G1(1)),(GRID(1,2),G2(1)),
     1                 (GRID(1,3),G3(1)),(GRID(1,4),G4(1)),
     2                 (GRID(1,5),G5(1))
C
C     MOVE GRID COORDINATES AND MAKE DOUBLE-PRECISION IF THIS IS THE
C     DOUBLE-PRECISION VERSION.
C
      DO 10 I = 1,3
      G1(I) = EST(I+10)
      G2(I) = EST(I+14)
      G3(I) = EST(I+18)
      G4(I) = EST(I+22)
   10 CONTINUE
C
C     FORM  D   , D   AND  D   VECTORS
C            13    24       12
C
      DO 20 I = 1,3
      D12(I) = G2(I) - G1(I)
      D13(I) = G3(I) - G1(I)
      D24(I) = G4(I) - G2(I)
   20 CONTINUE
C
C     NVEC = D13 CROSS D24 = K-VECTOR (UN-NORMALIZED)
C
      CALL DAXB (D13,D24,VEC)
      MAG   = DSQRT(DADOTB(VEC,VEC))
      IAREA = 0.5D0*MAG
C
C     NORMALIZE K-VECTOR
C
      IF (MAG) 100,100,30
   30 ET(1,3) = VEC(1)/MAG
      ET(2,3) = VEC(2)/MAG
      ET(3,3) = VEC(3)/MAG
C
C     H = .5 * (D   DOT K-VEC)
C                12
C
      ITWOH = DADOTB(D12,ET(1,3))
C
C     I-VECTOR (UN-NORMALIZED) = (D  ) - 2 H (K-VECTOR)
C                                  12
C
      DO 40 I = 1,3
      VEC(I) = D12(I) - ITWOH*ET(I,3)
   40 CONTINUE
      MAG = DSQRT(DADOTB(VEC,VEC))
C
C     NORMALIZE I-VECTOR
C
      IF (MAG) 100,100,50
   50 ET(1,1) = VEC(1)/MAG
      ET(2,1) = VEC(2)/MAG
      ET(3,1) = VEC(3)/MAG
C
C     JVEC = KVEC CROSS IVEC
C
      CALL DAXB (ET(1,3),ET(1,1),ET(1,2))
C
C     FILL THE SUB-TRIANGLE ELEMENT COORDINATE MATRIX
C
      DO 60 I = 1,3
      G5(I) = 0.25D0*(G1(I) + G2(I) + G3(I) + G4(I))
   60 CONTINUE
      RMAT(1,1) = 0.0D0
      RMAT(2,1) = 0.0D0
      RMAT(3,1) =-ITWOH/2.0D0
      DO 70 I = 2,5
      VEC(1) = GRID(1,I) - G1(1)
      VEC(2) = GRID(2,I) - G1(2)
      VEC(3) = GRID(3,I) - G1(3)
      CALL GMMATD (ET,3,3,0, VEC,3,1,0, RMAT(1,I))
      RMAT(1,I) = RMAT(1,I) + RMAT(1,1)
      RMAT(2,I) = RMAT(2,I) + RMAT(2,1)
      RMAT(3,I) = RMAT(3,I) + RMAT(3,1)
   70 CONTINUE
C
C     SET PLANAR FLAG .TRUE. OR .FALSE.
C
      IF ((ITWOH/2.0D0)**2/IAREA .LE. 0.01D0) GO TO 80
      PLANAR = .FALSE.
      GO TO 90
   80 PLANAR = .TRUE.
C
C     ALL BASIC CALCULATIONS NOW COMPLETE
C
   90 IERROR = 0
      RETURN
C
C     ERROR CONDITION, BAD ELEMENT GEOMETRY.
C
  100 IERROR = 1
      RETURN
      END


$ Declare
   SUBROUTINE SIMFactorMm (a, c, B, W, theta, Mm, Mmmax)
!
! Stress intensity magnification factor Mm
! Mm according to BS 7910:2005 M.3 Flat Plates
!
! Parameters
   USE PublicPar
   IMPLICIT NONE
!
   DOUBLE PRECISION, INTENT(IN)    :: a         ! FT = 2: Crack depth
   DOUBLE PRECISION, INTENT(IN)    :: c         ! FT = 2: Crack width
   DOUBLE PRECISION, INTENT(IN)    :: B         ! FT = 2: Plate thickness
   DOUBLE PRECISION, INTENT(IN)    :: W         ! FT = 2: Plate width
   DOUBLE PRECISION, INTENT(IN)    :: theta     ! FT = 2: Angle in radians (0 => c, pi/2 => a)
   DOUBLE PRECISION, INTENT(OUT)   :: Mm		 ! Stress intensity magnification factor Mm
   DOUBLE PRECISION, INTENT(OUT)   :: Mmmax		 ! Stress intensity magnification factor Mm for maximum stress
!
! Declarations
   DOUBLE PRECISION                :: M1, M2, M3
   DOUBLE PRECISION                :: as, cs
   DOUBLE PRECISION                :: g, radius, adivD, g1, g2
   DOUBLE PRECISION                :: ftheta
   DOUBLE PRECISION                :: fi
!
! Constants
   DOUBLE PRECISION :: pi
   pi = 3.14159265358979D0
!
! Mm for cope
   IF (FlawType .EQ. 9) THEN
      !M1 = 0.076071 * DEXP (-0.16676*a) + 0.088289 * DEXP (-0.010558*a)  ! Positive stress
	  !M2 = -0.31589 * DEXP (-0.14504*a) + -0.24447 * DEXP (0.00052707*a) ! Negative stress
      Mmmax = 1.12D0*(0.5372D0 * DEXP (-0.01056D0*a) + 0.4628D0 * DEXP (-0.1668D0*a)) ! Range
	  Mm = 1.12D0*(0.4344D0 * DEXP (-0.0006855D0*a) + 0.5608D0 * DEXP (-0.1384D0*a))
!
! Mm for through-thickness deck plate crack
   ELSE IF (FlawType .EQ. 8) THEN
      Mm = 1.D0
	  Mmmax = 1.D0
!
! Mm for edge flaws in plates BS 7910:2005 M.3.5
   ELSE IF (FlawType .EQ. 7) THEN
      Mm = 1.12D0 - 0.23D0 * (a/W) + 10.6D0 * (a/W)**2 - 21.7D0 * (a/W)**3 + 30.4D0 * (a/W)**4
	  Mmmax = Mm
!
! Mm for surface flaws in bolts BS 7910:2005 M.6.3.2
   ELSE IF (FlawType .EQ. 6) THEN
      radius = B / 2.D0
	  adivD = a / (2.D0 * radius)
	  IF (adivD .GT. 0.65D0) THEN
		 STOP 'Incorrect input in Subroutine SIMFactorMm: flaw in bolt with a/2r > 0.65'
	  ELSE IF (adivD .LT. 0.004D0) THEN
		 STOP 'Incorrect input in Subroutine SIMFactorMm: flaw in bolt with a/2r < 0.004'
	  ELSE
		Mm = 2.043D0 * DEXP (-31.332D0 * adivD) + 0.6507D0 + 0.5367D0 * adivD + 3.0469D0 * (adivD)**2 - 19.504D0 * (adivD)**3 + 45.647 * (adivD)**4
		Mmmax = Mm
	  END IF
!
! Mm for corner flaws in plates BS 7910:2005 M.3.6
   ELSE IF (FlawType .EQ. 5) THEN
	  IF ((a/c) .LT. 0.2D0) THEN
!         STOP 'Incorrect input in Subroutine SIMFactorMm: corner flaw with a/c < 0.2'
		 as = c * 0.2D0
		 cs = c
	  ELSE IF ((a/c) .GT. 2.D0) THEN
!         STOP 'Incorrect input in Subroutine SIMFactorMm: corner flaw with a/c > 2.0'
		 as = a
		 cs = a * 0.5D0
	  ELSE
	     as = a
		 cs = c
	  END IF
	  IF ((a/B) .GT. 1.D0) THEN
         STOP 'Incorrect input in Subroutine SIMFactorMm: corner flaw with a/B > 1.0'
	  ELSE IF ((as/cs) .LE. 1.D0) THEN
		 M1 = 1.08D0 - 0.03D0 * (as / cs)
		 M2 = (1.06D0 / (0.3D0 + (as / cs))) - 0.44D0
		 M3 = -0.5D0 + 0.25D0 * (as / cs) + 14.8D0 * (1.D0 - (as / cs))**15.D0
		 g1 = 1.D0 + (0.08D0 + 0.4D0 * (as/B)*(as/B)) * (1.D0 - DSIN(theta))**3.D0
		 g2 = 1.D0 + (0.08D0 + 0.15D0 * (as/B)*(as/B)) * (1.D0 - DCOS(theta))**3.D0
	     ftheta = ((as / cs * DCOS(theta))**2 + DSIN(theta)**2)**0.25D0
	     fi = DSQRT(1 + 1.464D0 * ((as / cs)**1.65D0))
	  ELSE
	     M1 = (1.08D0 - 0.03D0 * (cs / as)) * (cs / as)**0.5D0
		 M2 = 0.375 * (cs / as) * (cs / as)
		 M3 = -0.25D0 * (cs / as) * (cs / as)
		 g1 = 1.D0 + (0.08D0 + 0.4D0 * (cs/B)*(cs/B)) * (1.D0 - DSIN(theta))**3.D0
		 g2 = 1.D0 + (0.08D0 + 0.15D0 * (cs/B)*(cs/B)) * (1.D0 - DCOS(theta))**3.D0
	     ftheta = ((cs / as * DSIN(theta))**2 + DCOS(theta)**2)**0.25D0
	     fi = DSQRT(1 + 1.464D0 * ((cs / as)**1.65D0))
	  END IF
      Mm = (M1 + M2 * (as/B)**2 + M3 * (as/B)**4) * g1 * g2 * ftheta / fi
	  Mmmax = Mm
!
! Mm for semi-circular surface flaw in round bar BS 7910:2005 M.3.x
   ELSE IF (FlawType .EQ. 4) THEN
	  radius = B / 2.D0
      g = 1.84D0 / pi * DSQRT (DTAN (pi * a / 4.D0 / radius) / (pi * a / 4.D0 / radius)) / DCOS (pi * a / 4.D0 / radius)
      IF (a/radius .LE. 1.2D0) THEN
		 Mm = g * (0.752D0 + 2.02D0 * (a/2.D0/radius) + 0.37D0 * (1.D0 - DSIN(pi * a / 4.D0 / radius))**3.D0)
		 Mmmax = Mm
	  ELSE
         STOP 'Incorrect input in Subroutine SIMFactorMm: round bar with a/2r > 0.6'
	  END IF
	  !
! Mm for through-width flaws in plates BS 7910:2005 M.3.3
   ELSE IF (FlawType .EQ. 3) THEN
      IF (a/B .LE. 0.6D0) THEN
		 Mm = 1.12D0 - 0.23D0 * (a/B) + 10.6D0 * (a/B)**2.D0 - 21.7D0 * (a/B)**3.D0 + 30.4D0 * (a/B)**4.D0
		 Mmmax = Mm
	  ELSE
         STOP 'Incorrect input in Subroutine SIMFactorMm: long surface flaw with a/B > 0.6'
	  END IF

!
! Mm for through-thickness flaws in plates BS 7910:2005 M.3.1
   ELSE IF (FlawType .EQ. 1) THEN
      Mm = 1.D0
	  Mmmax = Mm
!
! Mm for surface flaws in plates BS 7910:2005 M.3.2.2
   ELSE IF (FlawType .EQ. 2) THEN
!
! Check input
!      write (*,*) a, c, B
      IF (a .LT. 0.0D0) STOP 'Incorrect input in Subroutine SIMFactorMm: a < 0'
      IF (c .LT. 0.0D0) STOP 'Incorrect input in Subroutine SIMFactorMm: c < 0'
!      IF (a/c .LE. 0.2D0) THEN
!         IF (a/B .GE. 1.25D0 * (a/c + 0.6D0)) STOP 'a/B Outside validity conditions in Subroutine SIMFactorMm'
!      END IF
      IF (a/B .GE. 1.D0) STOP 'a/B Outside validity conditions in Subroutine SIMFactorMm'
	  IF ((a/c) .GT. 2.D0) THEN
!         STOP 'Incorrect input in Subroutine SIMFactorMm: corner flaw with a/c > 2.0'
		 as = a
		 cs = a * 0.5D0
	  ELSE
	     as = a
		 cs = c
	  END IF
!
! Factors M1, M2, M3, g, ftheta and fi
! Remark: The functions of M2 and M3 are discontinuing at a/c = 1
      IF (as/cs .LE. 1.D0) THEN
         M1     = 1.13D0 - 0.09D0 * as / cs
	     M2     = 0.89D0 / (0.2D0 + as / cs) - 0.54D0
	     M3     = 0.5D0 - 1.D0 / (0.65D0 + as / cs) + 14.D0 * ((1.D0 - (as / cs))**24.D0)
         g      = 1.D0 + (0.1D0 + 0.35D0 * as * as / B / B) * ((1.D0 - DSIN(theta))**2)
	     ftheta = ((as / cs * DCOS(theta))**2 + DSIN(theta)**2)**0.25D0
	     fi     = DSQRT(1 + 1.464D0 * ((as / cs)**1.65D0))
      ELSE IF (as / cs .LE. 2.D0) THEN
         M1     = DSQRT(cs / as) * (1.D0 + 0.04D0 * cs / as)
	     M2     = 0.2D0 * ((cs / as)**4)
	     M3     = -0.11D0 * ((cs / as)**4)
         g      = 1.D0 + (0.1D0 + 0.35D0 * cs * as / B / B) * ((1.D0 - DSIN(theta))**2)
   	     ftheta = ((cs / as * DSIN(theta))**2 + DCOS(theta)**2)**0.25D0
	     fi     = DSQRT(1 + 1.464D0 * ((cs / as)**1.65D0))
      END IF
!
! Mm
      Mm = (M1 + (M2 + M3 * as * as / B / B) * as * as / B / B) * g * ftheta / fi
	  Mmmax = Mm
	  !Mmmax = 1.D0
   ELSE
      STOP 'Incorrect input in Subroutine SIMFactorMm: Unknown flawtype'
   END IF
   IF (Mm.LT.0.D0) Mm = 0.D0
!
! End subroutine
   RETURN
   END


MODULE Influence3D

  ! Compute the beam influence, i.e. the contribution of a single beam to the complex pressure
  ! mbp 12/2018, based on much older subroutines

  USE bellhopMod
  USE WriteRay
  USE RayNormals
  USE SourceReceiverPositions
  USE ArrMod
  USE sspMod   ! used to construct image beams in the Cerveny style beam routines
  USE cross_products

  IMPLICIT NONE
  INTEGER,       PRIVATE :: itheta, iz, ir, is
  REAL (KIND=8), PRIVATE :: W, s, m, n, Amp, phase, const, phaseInt, Ratio1, &
       L1, L2, rayt( 3 ), &
       RcvrDeclAngle, RcvrAzimAngle, &
       rA, rB, lambda
  REAL     (KIND=8) :: q_tilde( 2 ), q_hat( 2 ), dq_tilde( 2 ), dq_hat( 2 ), DetQint
  COMPLEX ( KIND=8 ) :: delay, dtau

CONTAINS
  SUBROUTINE Influence3DGeoHatRayCen( xs, alpha, beta, Dalpha, Dbeta, P )

    ! Geometrically-spreading beams with a hat-shaped beam in ray-centered coordinates

    REAL ( KIND=8 ), INTENT( IN  ) :: alpha, beta, Dalpha, Dbeta         ! ray take-off angle
    REAL ( KIND=8 ), INTENT( IN  ) :: xs( 3 )                            ! source coordinate
    COMPLEX        , INTENT( OUT ) :: P( Pos%Ntheta, Pos%Nrz, Pos%NRr )  ! complex pressure
    INTEGER          :: irA, irB, II
    REAL    (KIND=8) :: nA, nB, mA, mB, deltaA, deltaB, t_rcvr( 2, Pos%Ntheta ), &
         a, b, KMAHphase( Beam%Nsteps )
    REAL    (KIND=8) :: e1G( 3, Beam%Nsteps ), e2G( 3, Beam%Nsteps ), e1xe2( 3, Beam%Nsteps ), &
         xt( 3, Beam%Nsteps ),  xtxe1( 3, Beam%Nsteps ),  xtxe2( 3, Beam%Nsteps )

    Ratio1 = SQRT( ABS( COS( alpha ) ) ) * SQRT( Dalpha * Dbeta ) / ray3D( 1 )%c
    CALL ScaleBeam( alpha, Dalpha, Dbeta )   ! scaling for geometric beams

    ! phase shifts at caustics (rotations of Det_Q)
    KMAHphase( 1 ) = 0
    DO is = 2, Beam%Nsteps
       KMAHphase( is ) = KMAHphase( is - 1 )
       IF ( ray3D( is )%DetQ <= 0.0d0 .AND. ray3D( is - 1 )%DetQ > 0.0d0 .OR. &
            ray3D( is )%DetQ >= 0.0d0 .AND. ray3D( is - 1 )%DetQ < 0.0d0 ) KMAHphase( is ) = KMAHphase( is - 1 ) + pi / 2.
    END DO

    ! pre-calculate tangents, normals (e1, e2), etc.
    DO is = 1, Beam%Nsteps
       xt( :, is ) = ray3D( is )%x - xs   ! vector from the origin of the receiver plane to this point on the ray
       CALL RayNormal( ray3D( is )%t, ray3D( is )%phi, ray3D( is )%c, e1G( :, is ), e2G( :, is ) )

       ! e1xe2( :, is ) = cross_product( e1G( :, is ), e2G( :, is ) )
       e1xe2( :, is ) = ray3D( is )%c * ray3D( is )%t   ! unit tangent to ray
    END DO

    ! tangent along receiver bearing line
    t_rcvr( 1, : ) = COS( DegRad * Pos%theta( 1 : Pos%Ntheta ) )
    t_rcvr( 2, : ) = SIN( DegRad * Pos%theta( 1 : Pos%Ntheta ) )

    ReceiverDepths: DO iz = 1, Pos%Nrz
       ! precalculate vector from receiver to each step of ray
       xt( 3, : ) = ray3D( 1 : Beam%Nsteps )%x( 3 ) - Pos%rz( iz )
       DO is = 1, Beam%Nsteps
          xtxe1( :, is ) = cross_product( xt( :, is ), e1G( :, is ) )
          xtxe2( :, is ) = cross_product( xt( :, is ), e2G( :, is ) )
       END DO

       Radials: DO itheta = 1, Pos%Ntheta
          ! step along the beam ...
          ! Most of the time the beam makes no contribution to a receiver
          ! Therefore we try to test that quickly and move on to the next receiver

          Stepping: DO is = 2, Beam%Nsteps

             ! *** Compute coordinates of intercept: nB, mB, rB ***
             deltaA = -DOT_PRODUCT( t_rcvr( :, itheta ), e1xe2( 1 : 2, is - 1 ) )
             deltaB = -DOT_PRODUCT( t_rcvr( :, itheta ), e1xe2( 1 : 2, is     ) )

             IF ( ABS( deltaA ) < 1e-3 .OR. ABS( deltaB ) < 1e-3 ) CYCLE Stepping   ! ray normal || radial of rcvr line

             mA =  DOT_PRODUCT( t_rcvr( :, itheta ), xtxe1( 1 : 2, is - 1 ) ) / deltaA
             mB =  DOT_PRODUCT( t_rcvr( :, itheta ), xtxe1( 1 : 2, is     ) ) / deltaB

             nA = -DOT_PRODUCT( t_rcvr( :, itheta ), xtxe2( 1 : 2, is - 1 ) ) / deltaA
             nB = -DOT_PRODUCT( t_rcvr( :, itheta ), xtxe2( 1 : 2, is     ) ) / deltaB

             rA  = -DOT_PRODUCT( xt( :, is - 1 ), e1xe2( :, is - 1 ) ) / deltaA
             rB  = -DOT_PRODUCT( xt( :, is     ), e1xe2( :, is     ) ) / deltaB

             irA = MAX( MIN( INT( ( rA - Pos%Rr( 1 ) ) / Pos%Delta_r ) + 1, Pos%NRr ), 1 )  ! index of nearest rcvr before normal
             irB = MAX( MIN( INT( ( rB - Pos%Rr( 1 ) ) / Pos%Delta_r ) + 1, Pos%NRr ), 1 )  ! index of nearest rcvr before normal
             ! detect and skip duplicate points (happens at boundary reflection)
             ! IF ( irA /= irB .AND. NORM2( ray3D( is )%x - ray3D( is - 1 )%x ) > 1.0D3 * SPACING( ray3D( is )%x( 1 ) ) ) THEN  ! too slow
             IF ( irA /= irB .AND. NORM2( ray3D( is )%x - ray3D( is - 1 )%x ) > 1.0e-4 ) THEN

                ! *** Compute contributions to bracketted receivers ***
                dq_tilde = ray3D( is )%q_tilde - ray3D( is - 1 )%q_tilde
                dq_hat   = ray3D( is )%q_hat   - ray3D( is - 1 )%q_hat
                dtau     = ray3D( is )%tau     - ray3D( is - 1 )%tau

                II = 0
                IF ( irB <= irA ) II = 1   ! going backwards in range

                Ranges: DO ir = irA + 1 - II, irB + II, SIGN( 1, irB - irA )
                   s = ( Pos%Rr( ir ) - rA ) / ( rB - rA )

                   ! linear interpolation of q's
                   q_tilde = ray3D( is - 1 )%q_tilde + s * dq_tilde
                   q_hat   = ray3D( is - 1 )%q_hat   + s * dq_hat
                   n       = ABS( nA                 + s * ( nB - nA ) )   ! normal distance to ray
                   m       = ABS( mA                 + s * ( mB - mA ) )   ! normal distance to ray

                   ! represent (m, n) as a linear combination a q + b q
                   DetQint = q_tilde( 1 ) * q_hat( 2 ) - q_hat( 1 ) * q_tilde( 2 )   ! area of parallelogram formed by ray tube
                   IF ( DetQint == 0    ) CYCLE Ranges  ! receiver is outside the beam

                   a = ABS( ( -q_hat(   1 ) * m + q_hat(   2 ) * n ) / DetQint ) !!! sign is flipable inside abs
                   b = ABS( (  q_tilde( 1 ) * m - q_tilde( 2 ) * n ) / DetQint )
                   IF ( MAX( a, b ) > 1 ) CYCLE Ranges  ! receiver is outside the beam

                   W = ( 1 - a ) * ( 1 - b )   ! beamshape is a hat function: 1 on center, 0 on edge
                   delay = ray3D( is - 1 )%tau + s * dtau

                   const = ray3D( is )%Amp / SQRT( ABS( DetQint ) )
                   Amp   = const * W   ! hat function

                   ! phase shift at caustics
                   phaseInt = ray3D( is - 1 )%Phase + KMAHphase( is - 1 )
                   IF ( DetQint <= 0.0d0 .AND. ray3D( is - 1 )%DetQ > 0.0d0 .OR. &
                        DetQint >= 0.0d0 .AND. ray3D( is - 1 )%DetQ < 0.0d0 ) phaseInt = phaseInt + pi / 2.

                   CALL ApplyContribution( alpha, beta, xs, P( itheta, iz, ir ) )
                END DO Ranges
             END IF
             mA     = mB
             deltaA = deltaB
          END DO Stepping
       END DO Radials
    END DO ReceiverDepths

  END SUBROUTINE Influence3DGeoHatRayCen

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

  SUBROUTINE Influence3DGeoHatCart( xs, alpha, beta, Dalpha, Dbeta, P, x_rcvrMat, t_rcvr )

    ! Geometrically-spreading beams with a hat-shaped beam

    REAL ( KIND=8 ), INTENT( IN  ) :: alpha, beta, Dalpha, Dbeta         ! ray take-off angle
    REAL ( KIND=8 ), INTENT( IN  ) :: xs( 3 )                            ! source coordinate
    REAL ( KIND=8 ), INTENT( IN  ) :: x_rcvrMat( 2, Pos%Ntheta, Pos%NRr ), t_rcvr( 2, Pos%Ntheta ) ! rcvr coordinates and tangent
    COMPLEX        , INTENT( OUT ) :: P( Pos%Ntheta, Pos%Nrz, Pos%NRr )  ! complex pressure
    INTEGER            :: irT( 1 ), irTT
    REAL    ( KIND=8 ) :: s, rlen, x_ray( 3 ), n_ray_z( 3 ), n_ray_theta(3 ), &
         e1( 3 ), e2( 3 ), x_rcvr( 3 ), x_rcvr_ray( 3 ), &
         L_z, L_diag, e_theta( 3 ), m_prime, a, b, zMin, zMax, &
         Det_Q, Det_Qold
    Ratio1 = SQRT( ABS( COS( alpha ) ) ) * SQRT( Dalpha * Dbeta ) / ray3D( 1 )%c
    CALL ScaleBeam( alpha, Dalpha, Dbeta )   ! scaling for geometric beams

    phase    = 0.0
    Det_QOld = ray3D( 1 )%DetQ   ! used to track phase changes at caustics (rotations of Det_Q)

    ! Compute nearest rcvr before normal
    rA  = NORM2( ray3D( 1 )%x( 1 : 2 ) - xs( 1 : 2 ) )         ! range of ray point
    irT = MINLOC( Pos%Rr( 1 : Pos%NRr ), MASK = Pos%Rr( 1 : Pos%NRr ) .GT. rA )        ! index of receiver
    ir  = irT( 1 )

    Stepping: DO is = 2, Beam%Nsteps
       ! Compute nearest rcvr before normal
       rB  = NORM2( ray3D( is )%x( 1 : 2 ) - xs( 1 : 2 ) )         ! range of ray point

       IF ( ABS( rB - rA ) > 1.0D3 * SPACING( rA ) ) THEN   ! jump to next step if duplicate point
          ! initialize the index of the receiver range
          IF ( is == 2 ) THEN
             IF ( rB > rA ) THEN   ! ray is moving outward in range
                ir = 1             ! index all the way in
             ELSE                  ! ray is moving inward in range
                ir = Pos%NRr       ! index all the way out
             END IF
          END IF

          x_ray = ray3D( is - 1 )%x

          ! compute normalized tangent (we need it to measure the step length)
          rayt = ray3D( is )%x - ray3D( is - 1 )%x
          rlen = NORM2( rayt )

          IF ( rlen > 1.0D3 * SPACING( ray3D( is )%x( 1 ) ) ) THEN  ! Make sure this is not a duplicate point
             rayt = rayt / rlen                                     ! unit tangent to ray
             CALL RayNormal_unit( rayt, ray3D( is )%phi, e1, e2 )   ! Get ray normals e1 and e2

             ! phase shifts at caustics
             Det_Q  = ray3D( is - 1 )%DetQ
             IF ( Det_Q <= 0.0d0 .AND. Det_QOld > 0.0d0 .OR. Det_Q >= 0.0d0 .AND. Det_QOld < 0.0d0 ) phase = phase + pi / 2.
             Det_Qold = Det_Q

             L1 = MAX( NORM2( ray3D( is - 1 )%q_tilde ), NORM2( ray3D( is )%q_tilde ) ) ! beamwidths
             L2 = MAX( NORM2( ray3D( is - 1 )%q_hat   ), NORM2( ray3D( is )%q_hat   ) )

             L_diag = SQRT( L1 ** 2 + L2 ** 2 )   ! worst case is when rectangle is rotated to catch the hypotenuse

             n_ray_theta = [ -rayt( 2 ), rayt( 1 ), 0.D0 ]  ! normal to the ray in the horizontal receiver plane

             ! *** Compute contributions to bracketted receivers ***
             dq_tilde = ray3D( is )%q_tilde - ray3D( is - 1 )%q_tilde
             dq_hat   = ray3D( is )%q_hat   - ray3D( is - 1 )%q_hat
             dtau     = ray3D( is )%tau     - ray3D( is - 1 )%tau

             Ranges: DO
                ! is r( ir ) contained in [ rA, rB ]? Then compute beam influence
                IF ( Pos%Rr( ir ) >= MIN( rA, rB ) .AND. Pos%Rr( ir ) < MAX( rA, rB ) ) THEN

                   Radials: DO itheta = 1, Pos%Ntheta   ! Loop over radials of receiver line

                      x_rcvr( 1 : 2 ) = x_rcvrMat( 1 : 2, itheta, ir )
                      m_prime = ABS( DOT_PRODUCT( x_rcvr( 1 : 2 ) - x_ray( 1 : 2 ), n_ray_theta( 1 : 2 ) ) )  ! normal distance from rcvr to ray segment

                      IF ( m_prime > L_diag ) CYCLE Radials

                      ! The set of possible receivers is a ring
                      ! However, extrapolating the beam backwards produces contributions with s negative and large
                      ! We do not want to accept these contributions--- they have the proper range but are 180 degrees
                      ! away from this segement of the ray
                      ! s = DOT_PRODUCT( x_rcvr( 1 : 2 ) - x_ray( 1 : 2 ), rayt( 1 : 2 ) / NORM2( rayt( 1 : 2 ) ) )   ! a distance along ray    (in x-y plane)
                      ! s = DOT_PRODUCT( x_rcvr( 1 : 2 ) - xs( 1 : 2 ), t_rcvr( 1 : 2, itheta ) ) ! a distance along radial (in x-y plane)
                      s = DOT_PRODUCT( x_rcvr( 1 : 2 ) - xs( 1 : 2 ), x_ray( 1 : 2 ) - xs( 1 : 2 ) ) ! vector to rcvr dotted into vector to ray point

                      ! The real receivers have an s-value in [0, R_len]
                      ! IF ( s < 0D0 .OR. s > NORM2( ray3D( is )%x( 1 : 2 ) - ray3D( is - 1 )%x( 1 : 2 ) ) ) THEN
                      ! IF ( ABS( s ) > NORM2( ray3D( is )%x( 1 : 2 ) - ray3D( is - 1 )%x( 1 : 2 ) ) ) THEN

                      IF ( s < 0D0 ) CYCLE Radials

                      ! calculate z-limits for the beam (could be pre-cacluated for each itheta)
                      e_theta      = [ -t_rcvr( 2, itheta ), t_rcvr( 1, itheta ), 0.0D0 ]  ! normal to the vertical receiver plane
                      ! n_ray_z    = CROSS_PRODUCT( rayt, e_theta )                        ! normal to the ray in the vertical receiver plane
                      n_ray_z( 3 ) = rayt( 1 ) * e_theta( 2 ) - rayt( 2 ) * e_theta( 1 )   ! normal to the ray in the vertical receiver plane

                      IF ( ABS( n_ray_z( 3 ) ) < 1D-9 ) CYCLE Radials   ! avoid divide by zero
                      L_z          = L_diag / ABS( n_ray_z( 3 ) )

                      zmin = MIN( ray3D( is - 1 )%x( 3 ), ray3D( is )%x( 3 ) ) - L_z  ! min depth of ray segment
                      zmax = MAX( ray3D( is - 1 )%x( 3 ), ray3D( is )%x( 3 ) ) + L_z  ! max depth of ray segment

                      ReceiverDepths: DO iz = 1, Pos%Nrz
                         x_rcvr( 3 ) = DBLE( Pos%rz( iz ) )   ! z coordinate of the receiver
                         IF ( x_rcvr( 3 ) < zmin .OR. x_rcvr( 3 ) > zmax ) CYCLE ReceiverDepths

                         x_rcvr_ray = x_rcvr - x_ray

!!! rlen factor could be built into rayt
                         ! linear interpolation of q's
                         s       = DOT_PRODUCT( x_rcvr_ray, rayt ) / rlen  ! proportional distance along ray
                         q_tilde = ray3D( is - 1 )%q_tilde + s * dq_tilde
                         q_hat   = ray3D( is - 1 )%q_hat   + s * dq_hat

                         L1 = NORM2( q_tilde )  ! beamwidth is length of the vector
                         L2 = NORM2( q_hat   )  ! beamwidth

                         n  = ABS( DOT_PRODUCT( x_rcvr_ray, e1 ) )         ! normal distance to ray
                         m  = ABS( DOT_PRODUCT( x_rcvr_ray, e2 ) )         ! normal distance to ray

                         ! represent (m, n) as a linear combination a q + b q
                         DetQint = q_tilde( 1 ) * q_hat( 2 ) - q_hat( 1 ) * q_tilde( 2 )   ! area of parallelogram formed by ray tube

                         IF ( DetQint == 0.0 ) CYCLE ReceiverDepths
                         a = ABS( ( -q_hat(   1 ) * m + q_hat(   2 ) * n ) / DetQint )
                         b = ABS( (  q_tilde( 1 ) * m - q_tilde( 2 ) * n ) / DetQint )

                         ! suppose qtilde( 2 ) = qhat( 1 ) = 0
                         !DetQint = q_tilde( 1 ) * q_hat( 2 )   ! area of parallelogram formed by ray tube
                         !a = ABS( n / q_tilde( 1 )  )
                         !b = ABS( m / q_hat(   2 )  )

                         IF ( MAX( a, b ) > 1 .OR. L1 == 0 .OR. L2 == 0 ) CYCLE ReceiverDepths   ! receiver is outside the beam

                         delay = ray3D( is - 1 )%tau + s * dtau

                         ! phase shift at caustics
                         phaseInt = ray3D( is - 1 )%Phase + phase
                         IF ( DetQint <= 0.0d0 .AND. Det_QOld > 0.0d0 .OR. &
                              DetQint >= 0.0d0 .AND. Det_QOld < 0.0d0 ) phaseInt = phaseInt + pi / 2.

                         const = ray3D( is )%Amp / SQRT( ABS( DetQint ) )
                         W     = ( 1 - a ) * ( 1 - b )   ! hat function: 1 on center, 0 on edge
                         Amp   = const * W

                         CALL ApplyContribution( alpha, beta, xs, P( itheta, iz, ir ) )
                      END DO ReceiverDepths
                   END DO Radials

                END IF
                ! bump receiver index, ir, towards rB
                IF ( Pos%Rr( ir ) < rB ) THEN
                   IF ( ir >= Pos%NRr ) EXIT   ! jump out of the search and go to next step on ray
                   irTT = ir + 1               ! bump right
                   IF ( Pos%Rr( irTT ) >= rB ) EXIT
                ELSE
                   IF ( ir <= 1  ) EXIT        ! jump out of the search and go to next step on ray
                   irTT = ir - 1               ! bump left
                   IF ( Pos%Rr( irTT ) <= rB ) EXIT
                END IF
                ir = irTT
             END DO Ranges
          END IF
       END IF
       rA = rB
    END DO Stepping

  END SUBROUTINE Influence3DGeoHatCart

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

  SUBROUTINE Influence3DGeoGaussianRayCen( xs, alpha, beta, Dalpha, Dbeta, P )

    ! Geometrically-spreading beams with a hat-shaped beam in ray-centered coordinates

    REAL, PARAMETER                :: BeamWindow = 4.0                   ! kills beams outside e**(-0.5 * BeamWindow**2 )
    REAL ( KIND=8 ), INTENT( IN  ) :: alpha, beta, Dalpha, Dbeta         ! ray take-off angle
    REAL ( KIND=8 ), INTENT( IN  ) :: xs( 3 )                            ! source coordinate
    COMPLEX        , INTENT( OUT ) :: P( Pos%Ntheta, Pos%Nrz, Pos%NRr )  ! complex pressure
    INTEGER          :: irA, irB, II
    REAL    (KIND=8) :: nA, nB, mA, mB, a, b, deltaA, deltaB, t_rcvr( 2, Pos%Ntheta ), &
         L1_stent, L2_stent, KMAHphase( Beam%Nsteps )
    REAL    (KIND=8) :: e1G( 3, Beam%Nsteps ), e2G( 3, Beam%Nsteps ), e1xe2( 3, Beam%Nsteps ), &
         xt( 3, Beam%Nsteps ),  xtxe1( 3, Beam%Nsteps ),  xtxe2( 3, Beam%Nsteps )
    REAL    (KIND=8) :: MaxRadius_m( Beam%Nsteps - 1 ), MaxRadius_n( Beam%Nsteps - 1 )

    Ratio1 = SQRT( ABS( COS( alpha ) ) ) * SQRT( Dalpha * Dbeta ) / ray3D( 1 )%c / ( 2.0 * pi )
    CALL ScaleBeam( alpha, Dalpha, Dbeta )   ! scaling for geometric beams

    ! phase shifts at caustics (rotations of Det_Q)
    KMAHphase( 1 ) = 0
    DO is = 2, Beam%Nsteps
       KMAHphase( is ) = KMAHphase( is - 1 )
       IF ( ray3D( is )%DetQ <= 0.0d0 .AND. ray3D( is - 1 )%DetQ > 0.0d0 .OR. &
            ray3D( is )%DetQ >= 0.0d0 .AND. ray3D( is - 1 )%DetQ < 0.0d0 ) KMAHphase( is ) = KMAHphase( is - 1 ) + pi / 2.
    END DO

    ! pre-calculate tangents, normals (e1, e2), etc.
    DO is = 1, Beam%Nsteps
       xt( :, is ) = ray3D( is )%x - xs   ! vector from the origin of the receiver plane to this point on the ray
       CALL RayNormal( ray3D( is )%t, ray3D( is )%phi, ray3D( is )%c, e1G( :, is ), e2G( :, is ) )

       ! e1xe2( :, is ) = cross_product( e1G( :, is ), e2G( :, is ) )
       e1xe2( :, is ) = ray3D( is )%c * ray3D( is )%t   ! unit tangent to ray
    END DO

    DO is = 1, Beam%Nsteps - 1
       MaxRadius_m( is ) = BeamWindow * MAX( ABS( ray3D( is )%q_hat(   2 ) ), ABS( ray3D( is + 1 )%q_hat(   2 ) ) )
       MaxRadius_n( is ) = BeamWindow * MAX( ABS( ray3D( is )%q_tilde( 1 ) ), ABS( ray3D( is + 1 )%q_tilde( 1 ) ) )
    END DO

    ! tangent along receiver bearing line
    t_rcvr( 1, : ) = COS( DegRad * Pos%theta( 1 : Pos%Ntheta ) )
    t_rcvr( 2, : ) = SIN( DegRad * Pos%theta( 1 : Pos%Ntheta ) )

    ReceiverDepths: DO iz = 1, Pos%Nrz
       ! precalculate vector from receiver to each step of ray
       xt( 3, : ) = ray3D( 1 : Beam%Nsteps )%x( 3 ) - Pos%rz( iz )
       DO is = 1, Beam%Nsteps
          xtxe1( :, is ) = cross_product( xt( :, is ), e1G( :, is ) )
          xtxe2( :, is ) = cross_product( xt( :, is ), e2G( :, is ) )
       END DO

       Radials: DO itheta = 1, Pos%Ntheta
          ! *** Compute coordinates of intercept: nA, mA, rA ***
          is = 1
          deltaA = -DOT_PRODUCT( t_rcvr( :, itheta ), e1xe2( 1 : 2, is ) )

          ! Check for ray normal || radial of rcvr line
          IF ( ABS( deltaA ) < 1D3 * SPACING( deltaA ) ) THEN
             irA = 0   ! serves as a flag that this normal can't be used
          ELSE
             mA  =  DOT_PRODUCT( t_rcvr( :, itheta ), xtxe1( 1 : 2, is ) ) / deltaA
          END IF

          ! step along the beam ...
          ! Most of the time the beam makes no contribution to a receiver
          ! Therefore we try to test that quickly and move on to the next receiver

          Stepping: DO is = 2, Beam%Nsteps
             lambda = ray3D( is - 1 )%c / freq   ! local wavelength

             ! *** Compute coordinates of intercept: nB, mB, rB ***
             deltaA = -DOT_PRODUCT( t_rcvr( :, itheta ), e1xe2( 1 : 2, is - 1 ) )
             deltaB = -DOT_PRODUCT( t_rcvr( :, itheta ), e1xe2( 1 : 2, is     ) )

             IF ( ABS( deltaA ) < 1e-3 .OR. ABS( deltaB ) < 1e-3 ) CYCLE Stepping   ! ray normal || radial of rcvr line

             mA  =  DOT_PRODUCT( t_rcvr( :, itheta ), xtxe1( 1 : 2, is - 1 ) ) / deltaA
             mB  =  DOT_PRODUCT( t_rcvr( :, itheta ), xtxe1( 1 : 2, is     ) ) / deltaB
!!! stent needs to be applied here already

             ! Possible contribution if max possible beamwidth > min possible distance to receiver
             IF ( MaxRadius_m( is - 1 ) > MIN( ABS( mA ), ABS( mB ) ) .OR. ( mA * mB < 0 ) ) THEN
                nA = -DOT_PRODUCT( t_rcvr( :, itheta ), xtxe2( 1 : 2, is - 1 ) ) / deltaA
                nB = -DOT_PRODUCT( t_rcvr( :, itheta ), xtxe2( 1 : 2, is     ) ) / deltaB

                ! Possible contribution if max possible beamwidth > min possible distance to receiver
                IF ( MaxRadius_n( is - 1 ) > MIN( ABS( nA ), ABS( nB ) ) .OR. ( nA * nB < 0 ) ) THEN
!!! can generate an inexact result if the resulting integer is too big
!!! assumes uniform spacing in Pos%Rr
                   rA  = -DOT_PRODUCT( xt( :, is - 1 ), e1xe2( :, is - 1 ) ) / deltaA
                   rB  = -DOT_PRODUCT( xt( :, is     ), e1xe2( :, is     ) ) / deltaB

                   irA = MAX( MIN( INT( ( rA - Pos%Rr( 1 ) ) / Pos%Delta_r ) + 1, Pos%NRr ), 1 )  ! index of nearest rcvr before normal
                   irB = MAX( MIN( INT( ( rB - Pos%Rr( 1 ) ) / Pos%Delta_r ) + 1, Pos%NRr ), 1 )  ! index of nearest rcvr before normal
                   ! detect and skip duplicate points (happens at boundary reflection)
                   IF ( irA /= irB .AND. NORM2( ray3D( is )%x - ray3D( is - 1 )%x ) > 1.0D3 * SPACING( ray3D( is )%x( 1 ) ) ) THEN

                      ! *** Compute contributions to bracketted receivers ***
                      dq_tilde = ray3D( is )%q_tilde - ray3D( is - 1 )%q_tilde
                      dq_hat   = ray3D( is )%q_hat   - ray3D( is - 1 )%q_hat
                      dtau     = ray3D( is )%tau     - ray3D( is - 1 )%tau

                      II = 0
                      IF ( irB <= irA ) II = 1   ! going backwards in range

                      Ranges: DO ir = irA + 1 - II, irB + II, SIGN( 1, irB - irA )

                         s = ( Pos%Rr( ir ) - rA ) / ( rB - rA )

                         ! linear interpolation of q's
                         q_tilde = ray3D( is - 1 )%q_tilde + s * dq_tilde
                         q_hat   = ray3D( is - 1 )%q_hat   + s * dq_hat
                         n       = ABS( nA                 + s * ( nB - nA ) )   ! normal distance to ray
                         m       = ABS( mA                 + s * ( mB - mA ) )   ! normal distance to ray

                         ! represent (m, n) as a linear combination a q + b q
                         DetQint = q_tilde( 1 ) * q_hat( 2 ) - q_hat( 1 ) * q_tilde( 2 )   ! area of parallelogram formed by ray tube
                         IF ( DetQint == 0    ) CYCLE Ranges  ! receiver is outside the beam

                         a = ABS( ( -q_hat(   1 ) * m + q_hat(   2 ) * n ) / DetQint ) !!! sign is flipable inside abs
                         b = ABS( (  q_tilde( 1 ) * m - q_tilde( 2 ) * n ) / DetQint )

                         !IF ( a + b > BeamWindow ) CYCLE Ranges   ! receiver is outside the beam .OR. L1 == 0 .OR. L2 == 0

                         ! Beam shape function (Gaussian)
                         ! The factor involving L1, L2 compensates for the change in intensity when widening the beam
                         !W   = EXP( -.5 * ( ( n / L1_stent ) ** 2 + ( m / L2_stent ) ** 2 ) ) * L1 / L1_stent * L2 / L2_stent
                         W   = EXP( -.5 * ( a ** 2 + b ** 2 ) )
                         delay = ray3D( is - 1 )%tau + s * dtau

                         const = ray3D( is )%Amp / SQRT( ABS( DetQint ) )
                         Amp   = const * W   ! hat function
                         ! phase shift at caustics
                         phaseInt = ray3D( is - 1 )%Phase + KMAHphase( is - 1 )
                         IF ( DetQint <= 0.0d0 .AND. ray3D( is - 1 )%DetQ > 0.0d0 .OR. &
                              DetQint >= 0.0d0 .AND. ray3D( is - 1 )%DetQ < 0.0d0 ) phaseInt = phaseInt + pi / 2.

                         CALL ApplyContribution( alpha, beta, xs, P( itheta, iz, ir ) )
!!$                         ______________
!!$
!!$                         ! Within beam window?
!!$                         L1 = ABS( q_tilde( is - 1 ) + W * dq_tilde( is - 1 ) )   ! beamwidth
!!$                         IF ( n > BeamWindow * L1 ) CYCLE Ranges                  ! in beamwindow?
!!$
!!$                         L2 = ABS( q_hat(   is - 1 ) + W * dq_hat(   is - 1 ) )   ! beamwidth
!!$                         IF ( m > BeamWindow * L2 ) CYCLE Ranges                  ! in beamwwindow?
!!$
!!$                         ! calculate the beamwidth (must be at least lambda, except in the nearfield)
!!$                         ! comment out the following 2 lines to turn the stent off
!!$                         L1_stent = MAX( L1, MIN( 0.2 * freq * REAL( ray3D( is - 1 )%tau ), pi * lambda ) )
!!$                         L2_stent = MAX( L2, MIN( 0.2 * freq * REAL( ray3D( is - 1 )%tau ), pi * lambda ) )
!!$
!!$                         DetQint = L1 * L2 * ray3D( 1 )%c ** 2 / ( Dalpha * Dbeta )  ! based on actual beamwidth
                      END DO Ranges
                   END IF
                END IF
             END IF
             mA     = mB
             deltaA = deltaB
          END DO Stepping
       END DO Radials
    END DO ReceiverDepths

  END SUBROUTINE Influence3DGeoGaussianRayCen

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

  SUBROUTINE Influence3DGeoGaussianCart( xs, alpha, beta, Dalpha, Dbeta, P, x_rcvrMat, t_rcvr )

    ! Geometrically-spreading beams with a Gaussian-shaped beam

    REAL, PARAMETER                :: BeamWindow = 4.0                   ! kills beams outside e**(-0.5 * BeamWindow**2 )
    REAL ( KIND=8 ), INTENT( IN  ) :: alpha, beta, Dalpha, Dbeta         ! ray take-off angle
    REAL ( KIND=8 ), INTENT( IN  ) :: xs( 3 )                            ! source coordinate
    REAL ( KIND=8 ), INTENT( IN  ) :: x_rcvrMat( 2, Pos%Ntheta, Pos%NRr ), t_rcvr( 2, Pos%Ntheta ) ! rcvr coordinates and tangent
    COMPLEX        , INTENT( OUT ) :: P( Pos%Ntheta, Pos%Nrz, Pos%NRr )  ! complex pressure
    INTEGER            :: irT( 1 ), irTT
    REAL    ( KIND=8 ) :: rlen, a, b, x_ray( 3 ), n_ray_z( 3 ), n_ray_theta( 3 ), &
         e1( 3 ), e2( 3 ), x_rcvr( 3 ), x_rcvr_ray( 3 ), &
         L1_stent, L2_stent, L_z, L_diag, e_theta( 3 ), m_prime, zMin, zMax, &
         Det_Q, Det_Qold

    Ratio1 = SQRT( ABS( COS( alpha ) ) ) * SQRT( Dalpha * Dbeta ) / ray3D( 1 )%c / ( 2.0 * pi )
    CALL ScaleBeam( alpha, Dalpha, Dbeta )   ! scaling for geometric beams

    phase    = 0.0
    Det_QOld = ray3D( 1 )%DetQ   ! used to track phase changes at caustics (rotations of Det_Q)

    ! Compute nearest rcvr before normal
    rA  = NORM2( ray3D( 1 )%x( 1 : 2 ) - xs( 1 : 2 ) )         ! range of ray point
    irT = MINLOC( Pos%Rr( 1 : Pos%NRr ), MASK = Pos%Rr( 1 : Pos%NRr ) .GT. rA )   ! index of receiver
    ir  = irT( 1 )

    Stepping: DO is = 2, Beam%Nsteps
       lambda = ray3D( is - 1 )%c / freq   ! local wavelength
       ! Compute nearest rcvr before normal
       rB  = NORM2( ray3D( is )%x( 1 : 2 ) - xs( 1 : 2 ) )         ! range of ray point

       IF ( ABS( rB - rA ) > 1.0D3 * SPACING( rA ) ) THEN   ! jump to next step if duplicate point
          ! initialize the index of the receiver range
          IF ( is == 2 ) THEN
             IF ( rB > rA ) THEN   ! ray is moving outward in range
                ir = 1             ! index all the way in
             ELSE                  ! ray is moving inward in range
                ir = Pos%NRr       ! index all the way out
             END IF
          END IF

          x_ray = ray3D( is - 1 )%x

          ! compute normalized tangent (we need it to measure the step length)
          rayt = ray3D( is )%x - ray3D( is - 1 )%x
          rlen = NORM2( rayt )

          IF ( rlen > 1.0D3 * SPACING( ray3D( is )%x( 1 ) ) ) THEN  ! Make sure this is not a duplicate point
             rayt = rayt / rlen                                     ! unit tangent to ray
             CALL RayNormal_unit( rayt, ray3D( is )%phi, e1, e2 )   ! Get ray normals e1 and e2

             ! phase shifts at caustics
             Det_Q  = ray3D( is - 1 )%DetQ
             IF ( Det_Q <= 0.0d0 .AND. Det_QOld > 0.0d0 .OR. Det_Q >= 0.0d0 .AND. Det_QOld < 0.0d0 ) phase = phase + pi / 2.
             Det_Qold = Det_Q

             L1 = MAX( NORM2( ray3D( is - 1 )%q_tilde ), NORM2( ray3D( is )%q_tilde ) ) ! beamwidths
             L2 = MAX( NORM2( ray3D( is - 1 )%q_hat   ), NORM2( ray3D( is )%q_hat   ) )

             L_diag = SQRT( L1 ** 2 + L2 ** 2 )   ! worst case is when rectangle is rotated to catch the hypotenuse

             n_ray_theta = [ -rayt( 2 ), rayt( 1 ), 0.D0 ]  ! normal to the ray in the horizontal receiver plane

             ! *** Compute contributions to bracketted receivers ***
             dq_tilde = ray3D( is )%q_tilde - ray3D( is - 1 )%q_tilde
             dq_hat   = ray3D( is )%q_hat   - ray3D( is - 1 )%q_hat
             dtau     = ray3D( is )%tau     - ray3D( is - 1 )%tau

             Ranges: DO
                ! is r( ir ) contained in [ rA, rB ]? Then compute beam influence
                IF ( Pos%Rr( ir ) >= MIN( rA, rB ) .AND. Pos%Rr( ir ) < MAX( rA, rB ) ) THEN

                   Radials: DO itheta = 1, Pos%Ntheta   ! Loop over radials of receiver line

                      x_rcvr( 1 : 2 ) = x_rcvrMat( 1 : 2, itheta, ir )
                      m_prime = ABS( DOT_PRODUCT( x_rcvr( 1 : 2 ) - x_ray( 1 : 2 ), n_ray_theta( 1 : 2 ) ) )  ! normal distance from rcvr to ray segment

!!!!!!!IF ( m_prime > BeamWindow * L_diag ) CYCLE Radials

                      ! The set of possible receivers is a ring
                      ! However, extrapolating the beam backwards produces contributions with s negative and large
                      ! We do not want to accept these contributions--- they have the proper range but are 180 degrees
                      ! away from this segement of the ray
!!! pre-calculate unit ray tangent
                      ! s = DOT_PRODUCT( x_rcvr( 1 : 2 ) - x_ray( 1 : 2 ), rayt( 1 : 2 ) / NORM2( rayt( 1 : 2 ) ) )   ! a distance along ray    (in x-y plane)
                      ! s = DOT_PRODUCT( x_rcvr( 1 : 2 ) - xs( 1 : 2 ), t_rcvr( 1 : 2, itheta ) ) ! a distance along radial (in x-y plane)
                      s = DOT_PRODUCT( x_rcvr( 1 : 2 ) - xs( 1 : 2 ), x_ray( 1 : 2 ) - xs( 1 : 2 ) ) ! vector to rcvr dotted into vector to ray point

                      ! The real receivers have an s-value in [0, R_len]
                      ! IF ( s < 0D0 .OR. s > NORM2( ray3D( is )%x( 1 : 2 ) - ray3D( is - 1 )%x( 1 : 2 ) ) ) THEN
                      ! IF ( ABS( s ) > NORM2( ray3D( is )%x( 1 : 2 ) - ray3D( is - 1 )%x( 1 : 2 ) ) ) THEN

                      IF ( s < 0D0 ) CYCLE Radials

                      ! calculate z-limits for the beam (could be pre-cacluated for each itheta)
                      e_theta      = [ -t_rcvr( 2, itheta ), t_rcvr( 1, itheta ), 0.0D0 ]  ! normal to the vertical receiver plane
                      ! n_ray_z    = CROSS_PRODUCT( rayt, e_theta )                        ! normal to the ray in the vertical receiver plane
                      n_ray_z( 3 ) = rayt( 1 ) * e_theta( 2 ) - rayt( 2 ) * e_theta( 1 )   ! normal to the ray in the vertical receiver plane

                      IF ( ABS( n_ray_z( 3 ) ) < 1D-9 ) CYCLE Radials   ! avoid divide by zero
                      L_z          = BeamWindow * L_diag / ABS( n_ray_z( 3 ) )

                      zmin = MIN( ray3D( is - 1 )%x( 3 ), ray3D( is )%x( 3 ) ) - L_z  ! min depth of ray segment
                      zmax = MAX( ray3D( is - 1 )%x( 3 ), ray3D( is )%x( 3 ) ) + L_z  ! max depth of ray segment

                      ReceiverDepths: DO iz = 1, Pos%Nrz
                         x_rcvr( 3 ) = DBLE( Pos%rz( iz ) )   ! z coordinate of the receiver
                         IF ( x_rcvr( 3 ) < zmin .OR. x_rcvr( 3 ) > zmax ) CYCLE ReceiverDepths

                         x_rcvr_ray = x_rcvr - x_ray

!!! rlen factor could be built into rayt
                         ! linear interpolation of q's
                         s       = DOT_PRODUCT( x_rcvr_ray, rayt ) / rlen  ! proportional distance along ray
                         q_tilde = ray3D( is - 1 )%q_tilde + s * dq_tilde
                         q_hat   = ray3D( is - 1 )%q_hat   + s * dq_hat

                         L1 = NORM2( q_tilde )  ! beamwidth is length of the vector
                         L2 = NORM2( q_hat   )  ! beamwidth

                         n  = ABS( DOT_PRODUCT( x_rcvr_ray, e1 ) )         ! normal distance to ray
                         m  = ABS( DOT_PRODUCT( x_rcvr_ray, e2 ) )         ! normal distance to ray

                         ! represent (m, n) as a linear combination a q + b q
                         DetQint = q_tilde( 1 ) * q_hat( 2 ) - q_hat( 1 ) * q_tilde( 2 )   ! area of parallelogram formed by ray tube
                         IF ( DetQint == 0.0 ) CYCLE ReceiverDepths

                         a = ABS( ( -q_hat(   1 ) * m + q_hat(   2 ) * n ) / DetQint )
                         b = ABS( (  q_tilde( 1 ) * m - q_tilde( 2 ) * n ) / DetQint )

                         IF ( a + b > BeamWindow .OR. L1 == 0 .OR. L2 == 0 ) CYCLE ReceiverDepths   ! receiver is outside the beam

                         delay = ray3D( is - 1 )%tau + s * dtau

                         ! phase shift at caustics
                         phaseInt = ray3D( is - 1 )%Phase + phase
                         IF ( DetQint <= 0.0d0 .AND. Det_QOld > 0.0d0 .OR. &
                              DetQint >= 0.0d0 .AND. Det_QOld < 0.0d0 ) phaseInt = phaseInt + pi / 2.

                         const = ray3D( is )%Amp / SQRT( ABS( DetQint ) )

                         ! calculate the beamwidth (must be at least lambda, except in the nearfield)
                         ! comment out the following 2 lines to turn the stent off
                         !L1_stent  = MAX( L1, MIN( 0.2 * freq * REAL( ray3D( is )%tau ), pi * lambda ) )
                         !L2_stent  = MAX( L2, MIN( 0.2 * freq * REAL( ray3D( is )%tau ), pi * lambda ) )

                         ! Beam shape function (Gaussian)
                         ! The factor involving L1, L2 compensates for the change in intensity when widening the beam

                         !W   = EXP( -.5 * ( n ** 2 + m ** 2 ) ) * L1 / L1_stent * L2 / L2_stent
                         W   = EXP( -.5 * ( a ** 2 + b ** 2 ) )   ! Gaussian
                         Amp = const * W

                         CALL ApplyContribution( alpha, beta, xs, P( itheta, iz, ir ) )
                      END DO ReceiverDepths
                   END DO Radials

                END IF
                ! bump receiver index, ir, towards rB
                IF ( Pos%Rr( ir ) < rB ) THEN
                   IF ( ir >= Pos%NRr ) EXIT   ! jump out of the search and go to next step on ray
                   irTT = ir + 1               ! bump right
                   IF ( Pos%Rr( irTT ) >= rB ) EXIT
                ELSE
                   IF ( ir <= 1  ) EXIT        ! jump out of the search and go to next step on ray
                   irTT = ir - 1               ! bump left
                   IF ( Pos%Rr( irTT ) <= rB ) EXIT
                END IF
                ir = irTT
             END DO Ranges
          END IF
       END IF
       rA = rB
    END DO Stepping

  END SUBROUTINE Influence3DGeoGaussianCart

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

  SUBROUTINE ScaleBeam( alpha, Dalpha, Dbeta )

    REAL ( KIND = 8 ), INTENT( IN ) :: alpha, Dalpha, Dbeta

    ray3D( 1 : Beam%Nsteps )%Amp = Ratio1 * ray3D( 1 : Beam%Nsteps )%c * ray3D( 1 : Beam%Nsteps )%Amp   ! pre-apply some scaling

    ! scaling for geometric beams

    ray3D( 1 : Beam%Nsteps )%DetQ = ray3D( 1 : Beam%Nsteps )%q_tilde( 1 ) * ray3D( 1 : Beam%Nsteps )%q_hat(   2 ) - &
                                    ray3D( 1 : Beam%Nsteps )%q_tilde( 2 ) * ray3D( 1 : Beam%Nsteps )%q_hat(   1 )

    ray3D( 1 : Beam%Nsteps )%q_tilde( 1 ) =                       Dalpha * ray3D( 1 : Beam%Nsteps )%q_tilde( 1 ) / ray3D( 1 )%c
    ray3D( 1 : Beam%Nsteps )%q_tilde( 2 ) =                       Dalpha * ray3D( 1 : Beam%Nsteps )%q_tilde( 2 ) / ray3D( 1 )%c
    ray3D( 1 : Beam%Nsteps )%q_hat(   1 ) = ABS( COS( alpha ) ) * Dbeta  * ray3D( 1 : Beam%Nsteps )%q_hat(   1 ) / ray3D( 1 )%c
    ray3D( 1 : Beam%Nsteps )%q_hat(   2 ) = ABS( COS( alpha ) ) * Dbeta  * ray3D( 1 : Beam%Nsteps )%q_hat(   2 ) / ray3D( 1 )%c

  END SUBROUTINE ScaleBeam

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

  SUBROUTINE ApplyContribution( alpha, beta, xs, U )

    REAL ( KIND=8 ), INTENT( IN    ) :: alpha, beta         ! ray take-off angle
    REAL ( KIND=8 ), INTENT( IN    ) :: xs( 3 )             ! source coordinate
    COMPLEX,         INTENT( INOUT ) :: U

    SELECT CASE( Beam%RunType( 1 : 1 ) )
    CASE ( 'E' )      ! eigenrays
       CALL WriteRay3D( alpha, beta, is, xs )   ! produces no output if NR=1
    CASE ( 'A', 'a' ) ! arrivals
       rayt = ray3D( is )%x - ray3D( is - 1 )%x ! ray tangent !!! does this always need to be done???
       RcvrDeclAngle = RadDeg * ATAN2( rayt( 3 ), NORM2( rayt( 1 : 2 ) ) )
       RcvrAzimAngle = RadDeg * ATAN2( rayt( 2 ), rayt( 1 ) )

       CALL AddArr3D( omega, itheta, iz, ir, Amp, phaseInt, delay, &
            SrcDeclAngle, SrcAzimAngle, RcvrDeclAngle, RcvrAzimAngle, &
            ray3D( is )%NumTopBnc, ray3D( is )%NumBotBnc )
    CASE ( 'C'  )     ! coherent TL
       U = U + CMPLX( Amp * EXP( -i * ( omega * delay - phaseInt ) ) )
    CASE DEFAULT      ! incoherent/semi-coherent TL
       IF ( Beam%Type( 1 : 1 ) == 'B' ) THEN   ! Gaussian beam
          U = U + SNGL( 2. * pi * ( const * EXP( AIMAG( omega * delay ) ) ) ** 2 * W )
       ELSE
          U = U + SNGL(           ( const * EXP( AIMAG( omega * delay ) ) ) ** 2 * W )
       END IF
    END SELECT

  END SUBROUTINE ApplyContribution

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

  SUBROUTINE ScalePressure3D( Dalpha, Dbeta, c, epsilon, P, Ntheta, Nrz, Nr, RunType, freq )

    ! Scale the pressure field

    INTEGER,            INTENT( IN    ) :: Ntheta, Nrz, Nr
    REAL    ( KIND=8 ), INTENT( IN    ) :: Dalpha, Dbeta        ! angular spacing between rays
    REAL    ( KIND=8 ), INTENT( IN    ) :: freq, c              ! source frequency, nominal sound speed
    COMPLEX,            INTENT( INOUT ) :: P( Ntheta, Nrz, Nr ) ! Pressure field
    COMPLEX ( KIND=8 ), INTENT( IN    ) :: epsilon( 2 )
    CHARACTER (LEN=5 ), INTENT( IN    ) :: RunType
    COMPLEX ( KIND=8 )                  :: const
!!!! this routine should be eliminated

    ! Compute scale factor for field
    SELECT CASE ( RunType( 2 : 2 ) )
    CASE ( 'C' )   ! Cerveny Gaussian beams in Cartesian coordinates
       ! epsilon is normally imaginary here, so const is complex
       const = SQRT( epsilon( 1 ) * epsilon( 2 ) ) * freq * Dbeta * Dalpha / ( SQRT( c ) ) **3  ! put this factor into the beam instead?
       P( :, :, : ) = CMPLX( const, KIND=4 ) * P( :, :, : )
    CASE DEFAULT
       const = 1.0
    END SELECT

    IF ( RunType( 1 : 1 ) /= 'C' ) P = SQRT( REAL( P ) ) ! For incoherent run, convert intensity to pressure

  END SUBROUTINE ScalePressure3D
END MODULE Influence3D


*> \brief \b SLAKF2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LDZ, M, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDA, * ), D( LDA, * ),
*      $                   E( LDA, * ), Z( LDZ, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> Form the 2*M*N by 2*M*N matrix
*>
*>        Z = [ kron(In, A)  -kron(B', Im) ]
*>            [ kron(In, D)  -kron(E', Im) ],
*>
*> where In is the identity matrix of size n and X' is the transpose
*> of X. kron(X, Y) is the Kronecker product between the matrices X
*> and Y.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          Size of matrix, must be >= 1.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          Size of matrix, must be >= 1.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL, dimension ( LDA, M )
*>          The matrix A in the output matrix Z.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A, B, D, and E. ( LDA >= M+N )
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL, dimension ( LDA, N )
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL, dimension ( LDA, M )
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is REAL, dimension ( LDA, N )
*>
*>          The matrices used in forming the output matrix Z.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*>          Z is REAL, dimension ( LDZ, 2*M*N )
*>          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of Z. ( LDZ >= 2*M*N )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup real_matgen
*
*  =====================================================================
      SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDZ, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDA, * ), D( LDA, * ),
     $                   E( LDA, * ), Z( LDZ, * )
*     ..
*
*  ====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IK, J, JK, L, MN, MN2
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLASET
*     ..
*     .. Executable Statements ..
*
*     Initialize Z
*
      MN = M*N
      MN2 = 2*MN
      CALL SLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
*
      IK = 1
      DO 50 L = 1, N
*
*        form kron(In, A)
*
         DO 20 I = 1, M
            DO 10 J = 1, M
               Z( IK+I-1, IK+J-1 ) = A( I, J )
   10       CONTINUE
   20    CONTINUE
*
*        form kron(In, D)
*
         DO 40 I = 1, M
            DO 30 J = 1, M
               Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
   30       CONTINUE
   40    CONTINUE
*
         IK = IK + M
   50 CONTINUE
*
      IK = 1
      DO 90 L = 1, N
         JK = MN + 1
*
         DO 80 J = 1, N
*
*           form -kron(B', Im)
*
            DO 60 I = 1, M
               Z( IK+I-1, JK+I-1 ) = -B( J, L )
   60       CONTINUE
*
*           form -kron(E', Im)
*
            DO 70 I = 1, M
               Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
   70       CONTINUE
*
            JK = JK + M
   80    CONTINUE
*
         IK = IK + M
   90 CONTINUE
*
      RETURN
*
*     End of SLAKF2
*
      END


! combined the code in C.1.4 into a module to make it a program unit to parse
module c_1_4
  type, abstract :: drawable_object
     real, dimension(3) :: rgb_color=(/1.0, 1.0, 1.0/) ! White
     real, dimension(2) :: position=(/0.0,0.0/) ! Centroid
   contains
     procedure(render_x), pass(object), deferred :: render
  end type drawable_object

  abstract interface
     subroutine render_x(object, window)
       class(drawable_object), intent(in) :: object
       class(x_window), intent(inout) :: window
     end subroutine render_x
  end interface

  type, extends(drawable_object) :: drawable_triangle ! Not ABSTRACT
     real, dimension(2,3) :: vertices ! In relation to centroid
   contains
     procedure, pass(object) :: render=>render_triangle_x
  end type drawable_triangle

contains
  subroutine render_triangle_x(object, window)
    class(drawable_triangle), intent(in) :: object
    class(x_window), intent(inout) :: window
  end subroutine render_triangle_x
end module c_1_4


!*****************************************************************!
!                            Melissa                              !
!-----------------------------------------------------------------!
!   COPYRIGHT (C) 2017  by INRIA and EDF. ALL RIGHTS RESERVED.    !
!                                                                 !
! This source is covered by the BSD 3-Clause License.             !
! Refer to the  LICENCE file for further information.             !
!                                                                 !
!-----------------------------------------------------------------!
!  Original Contributors:                                         !
!    Theophile Terraz,                                            !
!    Bruno Raffin,                                                !
!    Alejandro Ribes,                                             !
!    Bertrand Iooss,                                              !
!*****************************************************************!

module heat_utils

  implicit none

  include "mpif.h"

  contains

!-------------------------functions

  function func(x, y, t, lx, ly)

    implicit none

    real*8 :: func, x, y, t, lx, ly
    !func = 2*(y-y**2+x-x**2)
    !func = sin(x)+cos(y)
    func = 0.d0
    !func = (exp(-(x-lx/2.)**2))*(exp(-(y-ly/2.)**2))*cos(t*acos(0.0)/2)

  end function

  function g(x, y, t, param)

    implicit none

    real*8 :: g, x, y, t, param
    !g = 0.
    !g = sin(x)+cos(y)
    g = param

  end function

  function h(x, y, t, param)

    implicit none

    real*8 :: h, x, y, t, param
    !h = 0.
    !h = sin(x)+cos(y)
    h = param

   end function

  function num(i, j, nx)

    implicit none

    integer :: num, i, j, nx
    num = i+(j-1)*nx

  end function

  function invert_num_j(nx, num)

    implicit none

    integer :: num, nx
    integer :: invert_num_j
    invert_num_j = floor((num-1)/real(nx))+1

  end function

  function invert_num_i(nx, num)

    implicit none

    integer :: num, j, nx
    integer :: invert_num_i
    j = invert_num_j(nx, num)
    if (num-(j-1)*nx == 0) then
      invert_num_i = nx
    else
      invert_num_i = num-(j-1)*nx
    end if

  end function

!-------------------------subroutines

  subroutine load(me, n, Np, i1, iN) bind (c, name = 'load')

    implicit none

    integer :: me, n, Np, i1, iN
    integer :: card, surplus

    card = n/Np
    surplus = mod(n, Np)

    if(me < surplus) then
       i1 = me*card+me+1
       iN = i1+card
    else
       i1 = me*card+surplus+1
       iN = i1+card-1
    end if

  end subroutine load

  subroutine filling_A(d, dx, dy, dt, nx, ny, a) bind (c, name = 'filling_A') ! pour remplir A

    implicit none

    real*8, intent(in) :: d, dx, dy, dt
    integer, intent(in) :: nx, ny
    real*8, dimension(3), intent(out) :: a

    a(1) = -d*dt/(dx**2)
    a(2) = 1.D0+2.D0*d*dt*(1.D0/dx**2+1.D0/dy**2)
    a(3) = -d*dt/(dy**2)

  end subroutine filling_A

  subroutine filling_F(nx, ny, u, d, dx, dy, dt, t, f, i1, in, lx, ly, param) bind (c, name = 'filling_F')

    implicit none

    integer, intent(in) :: nx, ny, i1, in
    real*8, dimension(*) :: f
    real*8, dimension(*) :: u
    real*8, dimension(*) :: param
    integer :: i, j, k
    real*8, intent(in) :: d, dx, dy, dt, t, lx, ly

    do k = 1, in-i1+1
      f(k) = 0
      i = invert_num_i(nx, i1+k-1)
      j = invert_num_j(nx, i1+k-1)
      f(k) = f(k)+func(i*dx, j*dy, t, lx, ly)*dt+u(k)
      if (i == 1) then
        f(k) = f(k)+d*dt*h(0.d0, j*dy, t, param(2))/(dx**2)
      else if (i == nx) then
        f(k) = f(k)+d*dt*h((i+1)*dx, j*dy, t, param(3))/(dx**2)
      end if
      if (j == 1) then
        f(k) = f(k)+d*dt*g(i*dx, 0.d0, t, param(4))/(dy**2)
      else if (j == ny) then
        f(k) = f(k)+d*dt*g(i*dx, (j+1)*dy, t, param(5))/(dy**2)
      end if
    end do

  end subroutine filling_F

  subroutine rename(Me, name, simu_number)! bind (c, name = 'rename')

    implicit none

    integer :: Me, simu_number
    character*32  :: name
    character*3 :: tn
    character*5 :: sn
    integer :: i1, i2, i3, i4, i5
    i1 = Me/100
    i2  = ( Me - 100*i1)/10
    i3 = Me - 100*i1 -10*i2
    tn = char(i1+48)//char(i2+48)//char(i3+48)
    i1 = simu_number/10000
    i2 = (simu_number - 10000*i1)/1000
    i3 = (simu_number - 10000*i1 - 1000*i2)/100
    i4 = (simu_number - 10000*i1 - 1000*i2 - 100*i3)/10
    i5 = simu_number - 10000*i1 -1000*i2 - 100*i3 - 10*i4
    sn = char(i1+48)//char(i2+48)//char(i3+48)//char(i4+48)//char(i5+48)
    name = 'sol'//tn//'_'//sn//'.dat'

  end subroutine rename

  subroutine init(u0, i1, iN, dx, dy, nx, lx, ly, temp) bind (c, name = 'init')

    implicit none

    real*8, dimension(*) :: u0
    real*8, intent(in) :: dx, dy, lx, ly, temp
    integer, intent(in) :: i1, in, nx
    integer :: i
    do i = i1, in
      u0(i-i1+1) = temp
      !u0(i-i1+1) = func(invert_num_i(nx, i)*dx, invert_num_j(nx, i)*dy, 0.D0, lx, ly)
    end do

  end subroutine init

  subroutine finalize(dx, dy, nx, ny, i1, in, u, f, me, simu_number) bind (c, name = 'finalize')

    implicit none

    real*8, dimension(*), intent(inout) :: u, f
    integer, intent(in) :: nx, ny, i1, in, me, simu_number
    real*8, intent(in) :: dx, dy
    integer :: i, j
    character*32 :: name

    call rename(me, name, simu_number)

    open(unit = 13, file = name, action = 'write')
    do j = i1, in
      write(13, *) dx*invert_num_i(nx, j), dy*invert_num_j(nx, j), u(j-i1+1)
    end do
    close(13)

  end subroutine finalize

!------------------------- CG subroutines

  subroutine ConjGrad(Ah, F, U, nx, ny, epsilon, i1, in, np, me, next, previous, mpi_comm) bind (c, name = 'conjgrad')

    implicit none

    real*8, dimension(3) :: Ah
    real*8, dimension(:), pointer :: x1, x2
    real*8, dimension(*) :: F, U
    real*8, dimension(:), pointer :: R, P, Q, T, T1
    integer :: i, k, nx, ny, i1, in, charge, np, statinfo, me, next, previous
    real*8, intent(in) :: epsilon
    real*8 :: rho, rho_, beta, delta, a, residu, residu1, residu2
    integer, intent(in) :: mpi_comm
    integer, dimension(mpi_status_size) :: status

    charge = in-i1+1
    allocate(R(charge), P(charge), Q(charge))
    allocate(x1(nx), x2(nx))

    residu = 1.
    x1 = 0.0
    x2 = 0.0
    do i = 1, charge
       U(i) = 0.0
       R(i) = -F(i)
    end do

    i = 1
    call mpi_allreduce(scal(r , r , charge), rho, 1, mpi_real8, mpi_sum, mpi_comm, statinfo)

    do while(residu > epsilon)
       rho_ = rho
       call mpi_allreduce(scal(r, r, charge), rho, 1, mpi_real8, mpi_sum, mpi_comm, statinfo)
       if(i  ==  1) then
          do k = 1, charge
             P(k) = R(k)
          end do
       else
          beta = rho/rho_
          do k = 1, charge
             P(k) = beta*P(k)+R(k)
          end do
       end if

          call mpi_send(p(1:nx), nx, mpi_real8, previous, 999, mpi_comm, statinfo)
          call mpi_send(p(charge-nx+1:charge), nx, mpi_real8, next, 888, mpi_comm, statinfo)
          call mpi_recv(x1, nx, mpi_real8, previous, 888, mpi_comm, status, statinfo)
          call mpi_recv(x2, nx, mpi_real8, next, 999, mpi_comm, status, statinfo)

       call multiply(ah, p, q, nx, ny, i1, in, x1, x2)
       q = -q
       call mpi_allreduce(scal(p, q, charge), delta, 1, mpi_real8, mpi_sum, mpi_comm, statinfo)
       a = rho/delta
       do k = 1, charge
          U(k) = U(k)+a*P(k)
          R(k) = R(k)-a*Q(k)
       end do
       i = i+1
       call mpi_allreduce(scal(r, r, charge), residu1, 1, mpi_real8, mpi_sum, mpi_comm, statinfo)
       call mpi_allreduce(scal(f, f, charge), residu2, 1, mpi_real8, mpi_sum, mpi_comm, statinfo)
       residu = sqrt(residu1)/sqrt(residu2)

    end do

    deallocate(R, P, Q)
    deallocate(x1, x2)

  end subroutine ConjGrad

  function scal(X, Y, n) result(z)

    implicit none

    real*8 :: z
    real*8, dimension(*) :: X, Y
    integer :: i, n

    z = 0.0

    do i = 1, n
       z = z+X(i)*Y(i)
    end do

  end function scal

  subroutine multiply(a, x, y, nx, ny, i1, in, x1, x2) ! Ax = y

    implicit none

    real*8, dimension(3) :: a
    real*8, dimension(:), pointer, intent(in) :: x, x1, x2
    integer, intent(in) :: nx, ny
    real*8, dimension(:), pointer, intent(inout) :: y
    integer :: j, i, k, l, m, i1, in

    l = 1
    m = 1
    do k = 1, size(y)
      i = invert_num_i(nx, (i1+k-1))
      j = invert_num_j(nx, (i1+k-1))
      y(k) = x(k)*a(2)
      if ((i /= 1) .and. (i /= nx)) then
        if (k == 1) then
          y(k) = y(k)+x1(nx)*a(1)+x(k+1)*a(1)
        else if (k == size(y)) then
          y(k) = y(k)+x(k-1)*a(1)+x2(1)*a(1)
	else
          y(k) = y(k)+x(k-1)*a(1)+x(k+1)*a(1)
	end if
      else if (i == 1) then
        if (k == size(y)) then
          y(k) = y(k)+x(k+1)*a(1)+x2(1)*a(1)
	else
          y(k) = y(k)+x(k+1)*a(1)
	end if
      else
        y(k) = y(k)+x(k-1)*a(1)
      end if
      if ((j /= 1) .and. (j /= ny)) then
        if (k <= nx) then
          y(k) = y(k)+x(k+nx)*a(3)+x1(l)*a(3)
          l = l+1
        else if (k >= (size(y)-nx+1)) then
          y(k) = y(k)+x2(m)*a(3)+x(k-nx)*a(3)
          m = m+1
	else
          y(k) = y(k)+x(k+nx)*a(3)+x(k-nx)*a(3)
	end if
      else if (j == 1) then
          y(k) = y(k)+x(k+nx)*a(3)
      else
          y(k) = y(k)+x(k-nx)*a(3)
      end if
    end do

  end subroutine multiply

end module heat_utils


module slf_interpol

    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    pure subroutine interpol(x_in, y_in, x_out, y_out)
        real(r64), dimension(:), intent(in) :: x_in, y_in
        real(r64), intent(in) :: x_out
        real(r64), intent(out) :: y_out
        real(r64) :: x0,x1,y0,y1,t,control
        integer :: i, i_nearest, n

        if (size(y_in) /= size(x_in)) error stop "size(y_in) /= size(x_in)"

        n = size(y_in)
        t = abs(x_in(1)-x_in(n))

        ! find the nearest point
        control = x_in(2) - x_in(1)
        do i=1,n
            if (i .gt. 1) then
                if ( control * (x_in(i)-x_in(i-1)) .le. 0 ) then
                    error stop 'interpol: x-axis points should be either in ascending or descending order'
                endif
            endif
            if ( (abs(x_in(i)-x_out) .lt. abs(t)) .or. (i .eq. 1) ) then
                i_nearest = i
                t = x_in(i)-x_out
            end if
        end do

        if ( t .eq. 0. ) then
            y_out = y_in(i_nearest)
            return
        else if (t .gt. 0) then
            if ( i_nearest .eq. 1 ) then
                y_out = y_in(1)
                return
            endif
            x1 = x_in(i_nearest)
            y1 = y_in(i_nearest)
            x0 = x_in(i_nearest-1)
            y0 = y_in(i_nearest-1)
        else
            if ( i_nearest .eq. n ) then
                y_out = y_in(n)
                return
            endif
            x0 = x_in(i_nearest)
            y0 = y_in(i_nearest)
            x1 = x_in(i_nearest+1)
            y1 = y_in(i_nearest+1)
        end if

        t = (x1 - x_out) / (x1-x0)
        y_out = t * y0 + (1.-t) * y1

    end subroutine

    pure function interpolf(x,y,x0) result(y0)
      real(r64), intent(in) :: x(:), y(:), x0
      real(r64) :: y0
      call interpol(x,y,x0,y0)
    end function

end module


program main
  use mod_monolis
  implicit none
  integer(4) :: nnode, nelem, elem(2,4)
  real(8), allocatable :: val(:), vec(:,:)

  type(monolis_structure) :: mat !> 疎行列変数

  call monolis_global_initialize()

  call monolis_initialize(mat, "./") !> 疎行列変数の初期化

  nnode = 5
  nelem = 4
  elem(1,1) = 1; elem(2,1) = 2;
  elem(1,2) = 2; elem(2,2) = 3;
  elem(1,3) = 3; elem(2,3) = 4;
  elem(1,4) = 4; elem(2,4) = 5;

  call monolis_get_nonzero_pattern(mat, nnode, 2, 1, nelem, elem)

  !> 16  2  0  0  0
  !>  2 12  3  0  0
  !>  0  3  1  2  0
  !>  0  0  2 20  5
  !>  0  0  0  5 30
  !> call monolis_add_scalar_to_sparse_matrix(mat, 1, 1, 1, 1, 16.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 1, 2, 1, 1,  2.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 2, 1, 1, 1,  2.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 2, 2, 1, 1, 12.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 2, 3, 1, 1,  3.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 3, 2, 1, 1,  3.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 3, 3, 1, 1,  1.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 3, 4, 1, 1,  2.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 4, 3, 1, 1,  2.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 4, 4, 1, 1, 20.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 4, 5, 1, 1,  5.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 5, 4, 1, 1,  5.0d0)
  !> call monolis_add_scalar_to_sparse_matrix(mat, 5, 5, 1, 1, 30.0d0)

  !>  2  1  0  0  0
  !>  1  2  1  0  0
  !>  0  1  2  2  0
  !>  0  0  1  2  1
  !>  0  0  0  1  2
  call monolis_add_scalar_to_sparse_matrix(mat, 1, 1, 1, 1,  2.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 1, 2, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 2, 1, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 2, 2, 1, 1,  2.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 2, 3, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 3, 2, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 3, 3, 1, 1,  2.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 3, 4, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 4, 3, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 4, 4, 1, 1,  2.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 4, 5, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 5, 4, 1, 1,  1.0d0)
  call monolis_add_scalar_to_sparse_matrix(mat, 5, 5, 1, 1,  2.0d0)

  !> eigen_value
  !> 3.73205E+00
  !> 3.00000E+00
  !> 2.00000E+00
  !> 1.00000E+00
  !> 2.67949E-01

  !> e_mode
  !> 2.88675E-01 5.00000E-01 5.77350E-01 5.00000E-01 2.88675E-01
  !> 5.00000E-01 5.00000E-01-2.42335E-16-5.00000E-01-5.00000E-01
  !> 5.77350E-01-6.48664E-17-5.77350E-01 1.61183E-16 5.77350E-01
  !> 5.00000E-01-5.00000E-01-2.82388E-16 5.00000E-01-5.00000E-01
  !> 2.88675E-01-5.00000E-01 5.77350E-01-5.00000E-01 2.88675E-01

  allocate(val(5), source = 0.0d0)
  allocate(vec(5,5), source = 0.0d0)

  !mat%PRM%is_debug = .true.
  mat%PRM%show_iterlog = .false.
  mat%PRM%show_time = .false.
  mat%PRM%show_summary = .false.
  call monolis_eigen_inverted_standard_lanczos(mat, 5, 1.0d-6, 5, val, vec)

  write(*,*)"val"
  write(*,"(1pe12.5)")val

  write(*,*)"vec"
  write(*,"(1p5e12.5)")vec

  call monolis_finalize(mat) !> 疎行列変数の解放

  call monolis_global_finalize()
end program main


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

!> Correct covariances for fixed ensemble sizes.
!> See Anderson, J. L., 2011: Localization and Sampling Error Correction
!>   in Ensemble Kalman Filter Data Assimilation.
!> Submitted for publication, Jan 2011.  Contact author.

program full_error

! This version of the program reads the ensemble size and base filename
! for the output from a namelist.

use      types_mod, only : r8
use  utilities_mod, only : open_file, close_file, error_handler,       &
                           find_namelist_in_file, check_namelist_read, &
                           do_nml_file, do_nml_term, nmlfileunit,      &
                           initialize_utilities, finalize_utilities, E_ERR
use random_seq_mod, only : random_seq_type, init_random_seq, &
                           twod_gaussians

implicit none

character(len=*), parameter :: source = 'full_error.f90'

integer, parameter :: num_times   = 1
integer, parameter :: num_samples = 100000000

! ---------------
! namelist items

integer            :: ens_size = 80
character(len=256) :: output_filename = 'final_full'

namelist /full_error_nml/ ens_size, output_filename

type (random_seq_type) :: ran_id
real(r8), allocatable  :: pairs(:,:), temp(:)

real(r8) :: zero_2(2) = 0.0, cov(2, 2)
real(r8) :: t_correl, sample_correl, alpha, beta
real(r8) :: s_mean(2), s_var(2), reg_mean, reg_sd, t_sd1, t_sd2, true_correl_mean
real(r8) :: tcorrel_sum(201), reg_sum(201), reg_2_sum(201)

integer  :: i, j, k, bin_num, bin_count(201)
integer  :: iunit, io

character(len=16)  :: formstring
character(len=256) :: outname
character(len=512) :: errstring

!
! start of executable code
!

call initialize_utilities('full_error')

! Read the namelist entry
call find_namelist_in_file("input.nml", "full_error_nml", iunit)
read(iunit, nml = full_error_nml, iostat = io)
call check_namelist_read(iunit, io, "full_error_nml")

! Record the namelist values used for the run
if (do_nml_file()) write(nmlfileunit, nml=full_error_nml)
if (do_nml_term()) write(     *     , nml=full_error_nml)

call close_file(iunit)

call init_random_seq(ran_id)

write(*, *) 'stats for ensemble size ', ens_size

allocate(pairs(2, ens_size), temp(ens_size))

bin_count   = 0
tcorrel_sum = 0.0_r8
reg_sum     = 0.0_r8
reg_2_sum   = 0.0_r8

! Uniformly distributed sequence of true correlations
do j = 1, num_samples
   ! Assume that true correlation is uniform [-1,1]
   t_correl = -1.0_r8 + 2.0_r8 * ((j - 1) / (num_samples - 1.0_r8))
   if(j > num_samples) t_correl = 0.0_r8

   do k = 1, num_times

      t_sd1 = 1.0_r8
      t_sd2 = 1.0_r8

      ! Generate the covariance matrix for this correlation
      cov(1, 1) = t_sd1**2
      cov(2, 2) = t_sd2**2
      cov(1, 2) = t_correl * t_sd1 * t_sd2
      cov(2, 1) = cov(1, 2)

      ! Loop to generate an ensemble size sample from this correl
      ! Generate a random sample of size ens_size from something with this correlation
      do i = 1, ens_size
         call twod_gaussians(ran_id, zero_2, cov, pairs(:, i))
      enddo

      ! Compute the sample correlation
      call comp_correl(pairs, ens_size, sample_correl)

      ! Bin statistics for each 0.01 sample correlation bin;
      !  start with just mean true correlation
      bin_num = (sample_correl + 1.0_r8) / 0.01_r8   + 1
      ! Keep a sum of the sample_correl and squared to compute standard deviation
      tcorrel_sum(bin_num) = tcorrel_sum(bin_num) + t_correl
      !-----------------
      ! Also interested in finding out what the spurious variance reduction factor is
      ! First need to compute sample s.d. for the obs and unobs variable
      do i = 1, 2
         temp = pairs(i, :)
         call sample_mean_var(temp, ens_size, s_mean(i), s_var(i))
      enddo

      !-----------------
      reg_sum(bin_num) = reg_sum(bin_num) + t_correl * sqrt(s_var(2) / s_var(1))
      reg_2_sum(bin_num) = reg_2_sum(bin_num) + (t_correl * sqrt(s_var(2) / s_var(1)))**2

      bin_count(bin_num) = bin_count(bin_num) + 1

   enddo
enddo

! make the size of the integer output .X, .XX, .XXX, etc
! depending on the number of decimal digits in the value.
if (ens_size < 10) then
   formstring = '(2A,I1)'
else if (ens_size < 100) then
   formstring = '(2A,I2)'
else if (ens_size < 1000) then
   formstring = '(2A,I3)'
else if (ens_size < 10000) then
   formstring = '(2A,I4)'
else if (ens_size < 100000) then
   formstring = '(2A,I5)'
else
   formstring = '(2A,I8)'
endif

! filename
write(outname, formstring) trim(output_filename), '.', ens_size

! text file, overwrite existing file if present
iunit = open_file(outname, 'formatted', 'write')

! always generate exactly 200 entries in the output file
do i = 1, 200
   ! must have at least 2 counts to compute a std dev
   if(bin_count(i) <= 1) then
      write(errstring, *) 'Bin ', i, ' has ', bin_count(i), ' counts'
      call error_handler(E_ERR,'full_error', errstring, &
         source, text2="All bins must have at least 2 counts")
   endif

   ! Compute the standard deviation of the true correlations
   true_correl_mean = tcorrel_sum(i) / bin_count(i)
   reg_mean = reg_sum(i) / bin_count(i)
   reg_sd = sqrt((reg_2_sum(i) - bin_count(i) * reg_mean**2) / (bin_count(i) - 1))

   if(reg_sd <= 0.0_r8) then
      alpha = 1.0_r8
   else
      !!!beta = reg_mean**2 / reg_sd**2
   ! Correct for bias in the standard deviation for very small ensembles, too
      beta = reg_mean**2 / (reg_sd**2 * (1.0_r8 + 1.0_r8 / ens_size))
      alpha = beta / (1.0_r8 + beta)
   endif

   write(*, *) 'bin, count, mean ', i, bin_count(i), true_correl_mean, alpha
   write(iunit, 10)   i, bin_count(i), true_correl_mean, alpha
enddo

10 format (I4,I9,2G25.14)

call close_file(iunit)

! print out just to stdout how many counts, if any, fell beyond bin 200
write(*, *) 'bin, count, mean ', 201, bin_count(201), 0, 0

deallocate(pairs, temp)

call finalize_utilities()

! end of main program

contains

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

subroutine comp_correl(ens, n, correl)

integer,  intent(in)  :: n
real(r8), intent(in)  :: ens(2, n)
real(r8), intent(out) :: correl

real(r8) :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x  = sum(ens(2, :))
sum_y  = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

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

subroutine sample_mean_var(x, n, mean, var)

integer,  intent(in)  :: n
real(r8), intent(in)  :: x(n)
real(r8), intent(out) :: mean, var

real(r8) :: sx, s_x2

sx   = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var  = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var

end program full_error


      subroutine spl_def (npts, x, y, knots, nknots, coeffs)
      implicit real*8 (a-h,o-z)
      integer npts, k, nest, nknots, lwork
      real*8 x(npts), y(npts), w(npts)
      parameter (k=3)
      real*8 knots(npts+k+1),coeffs(npts+k+1)
      real*8 xe, xb, s, fp, work(npts*(k+1)+(npts+k+1)*(7+3*k))
      integer iwork(npts+k+1), ier
      nest=npts+k+1
      lwork=npts*(k+1)+nest*(7+3*k)

      iopt = 0
      s = 0.0
      xb=x(1)
      xe=x(npts)
      do i = 1, npts
          w(i) = 1.0
      enddo

      call curfit(iopt, npts, x, y, w, xb, xe, k, s, nest,
     .   nknots, knots, coeffs, fp, work, lwork, iwork, ier)

      end

      real*8 function spl_ev(knots, nknots, coeffs, x_new)
      implicit real*8 (a-h,o-z)
      integer nknots, k, ier
      real*8 knots(nknots), coeffs(nknots), x_new, y_new

      k = 3

      call splev(knots, nknots, coeffs, k, x_new, y_new, 1, ier)

      spl_ev = y_new
      return
      end