*DECK D9ATN1
      DOUBLE PRECISION FUNCTION D9ATN1 (X)
C***BEGIN PROLOGUE  D9ATN1
C***SUBSIDIARY
C***PURPOSE  Evaluate DATAN(X) from first order relative accuracy so
C            that DATAN(X) = X + X**3*D9ATN1(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      DOUBLE PRECISION (R9ATN1-S, D9ATN1-D)
C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB,
C             TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  DATAN(X)  from first order, that is, evaluate
C (DATAN(X)-X)/X**3  with relative error accuracy so that
C        DATAN(X) = X + X**3*D9ATN1(X).
C
C Series for ATN1       on the interval  0.          to  1.00000E+00
C                                        with weighted error   3.39E-32
C                                         log weighted error  31.47
C                               significant figures required  30.26
C                                    decimal places required  32.27
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891115  Corrected third argument in reference to INITDS.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9ATN1
      DOUBLE PRECISION X, XBIG, XMAX, XSML, Y, ATN1CS(40), EPS,
     1  DCSEVL, D1MACH
      LOGICAL FIRST
      SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST
      DATA ATN1CS(  1) / -.3283997535 3552023569 0793992299 0 D-1      /
      DATA ATN1CS(  2) / +.5833432343 1724124499 5166991490 7 D-1      /
      DATA ATN1CS(  3) / -.7400369696 7196464638 0901155141 3 D-2      /
      DATA ATN1CS(  4) / +.1009784199 3372880835 9035751163 9 D-2      /
      DATA ATN1CS(  5) / -.1439787163 5652056214 7130369770 0 D-3      /
      DATA ATN1CS(  6) / +.2114512648 9921075720 7211224343 9 D-4      /
      DATA ATN1CS(  7) / -.3172321074 2546671674 0256499675 7 D-5      /
      DATA ATN1CS(  8) / +.4836620365 4607108253 7785938480 0 D-6      /
      DATA ATN1CS(  9) / -.7467746546 8141126704 3761432277 6 D-7      /
      DATA ATN1CS( 10) / +.1164800896 8244298306 2099864134 2 D-7      /
      DATA ATN1CS( 11) / -.1832088370 8472013926 9995624245 2 D-8      /
      DATA ATN1CS( 12) / +.2901908277 9660633131 7535123045 5 D-9      /
      DATA ATN1CS( 13) / -.4623885312 1063267383 5180572151 2 D-10     /
      DATA ATN1CS( 14) / +.7405528668 7757369179 9219704828 6 D-11     /
      DATA ATN1CS( 15) / -.1191354457 8451366823 7082037341 7 D-11     /
      DATA ATN1CS( 16) / +.1924090144 3917725998 6785569251 8 D-12     /
      DATA ATN1CS( 17) / -.3118271051 0761942722 5447615532 7 D-13     /
      DATA ATN1CS( 18) / +.5069240036 5677317896 9452059303 2 D-14     /
      DATA ATN1CS( 19) / -.8263694719 8028660538 1828440596 4 D-15     /
      DATA ATN1CS( 20) / +.1350486709 8170794205 2650612302 9 D-15     /
      DATA ATN1CS( 21) / -.2212023650 4817460458 4013782319 1 D-16     /
      DATA ATN1CS( 22) / +.3630654747 3813567838 2904764770 9 D-17     /
      DATA ATN1CS( 23) / -.5970345328 8471540524 5121585916 5 D-18     /
      DATA ATN1CS( 24) / +.9834816050 0771331194 4832900573 8 D-19     /
      DATA ATN1CS( 25) / -.1622655075 8550623361 4438760448 0 D-19     /
      DATA ATN1CS( 26) / +.2681186176 9454367963 0132030122 6 D-20     /
      DATA ATN1CS( 27) / -.4436309706 7852554796 3624368810 6 D-21     /
      DATA ATN1CS( 28) / +.7349691897 6524969450 7246551040 0 D-22     /
      DATA ATN1CS( 29) / -.1219077508 3500525882 8940137813 3 D-22     /
      DATA ATN1CS( 30) / +.2024298836 8052154031 8454087679 9 D-23     /
      DATA ATN1CS( 31) / -.3364871555 7973545799 2557636266 6 D-24     /
      DATA ATN1CS( 32) / +.5598673968 3469887494 9293397333 3 D-25     /
      DATA ATN1CS( 33) / -.9323939267 2723202296 2853205333 3 D-26     /
      DATA ATN1CS( 34) / +.1554133116 9959702229 3480789333 3 D-26     /
      DATA ATN1CS( 35) / -.2592569534 1797459227 5742719999 9 D-27     /
      DATA ATN1CS( 36) / +.4328193466 2457346850 3790933333 3 D-28     /
      DATA ATN1CS( 37) / -.7231013125 5954374711 9240533333 3 D-29     /
      DATA ATN1CS( 38) / +.1208902859 8304947729 4216533333 3 D-29     /
      DATA ATN1CS( 39) / -.2022404543 4498975793 1519999999 9 D-30     /
      DATA ATN1CS( 40) / +.3385428713 0464938430 7370666666 6 D-31     /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  D9ATN1
      IF (FIRST) THEN
         EPS = D1MACH(3)
         NTATN1 = INITDS (ATN1CS, 40, 0.1*REAL(EPS))
C
         XSML = SQRT (0.1D0*EPS)
         XBIG = 1.571D0/SQRT(EPS)
         XMAX = 1.571D0/EPS
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.1.0D0) GO TO 20
C
      IF (Y.LE.XSML) D9ATN1 = -1.0D0/3.0D0
      IF (Y.LE.XSML) RETURN
C
      D9ATN1 = -0.25D0 + DCSEVL (2.D0*Y*Y-1.D0, ATN1CS, NTATN1)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'D9ATN1',
     +   'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2)
      IF (Y .GT. XBIG) CALL XERMSG ('SLATEC', 'D9ATN1',
     +   'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1)
C
      D9ATN1 = (ATAN(X) - X) / X**3
      RETURN
C
      END


        DOUBLE COMPLEX FUNCTION InProd_zero(p1,l1,p2,l2)
c////////////////////////////////////////////////////////////////
c         small s_{+,-}(p1,p2) for massless case:              //
c                 p1^2 = p2^2 = 0                              //
c                                                              //
c     k0(0) = 1.d0                                             //
c     k0(1) = 1.d0                                             //
c     k0(2) = 0.d0  Kleisse_Stirling k0 points to X-axis       //
c     k0(3) = 0.d0                                             //
c                                                              //
c////////////////////////////////////////////////////////////////
           IMPLICIT NONE
           INTEGER           l1,l2,i
           DOUBLE PRECISION  p1(0:3),p2(0:3)
           DOUBLE PRECISION  forSqrt1,forSqrt2,sqrt1,sqrt2
           DOUBLE COMPLEX    i_,Dcmplx
           LOGICAL           equal
           INTRINSIC         Dcmplx
           PARAMETER         ( i_=(0.d0,1.d0) )
           INCLUDE 'MC_Declare.h'

           equal = .TRUE.
           DO i=0,3
             IF (p1(i).NE.p2(i))  equal = equal.AND..FALSE.
           ENDDO

           IF ( (l1.EQ.l2) .OR. equal ) THEN

              InProd_zero = Dcmplx(0d0,0d0)

           ELSEIF ( (l1.EQ.+1) .AND. (l2.EQ.-1) ) THEN

              forSqrt1 = (p1(0)-p1(1))/(p2(0)-p2(1))
              forSqrt2 = 1.0d0/forSqrt1
              sqrt1    = Dsqrt(forSqrt2)
              sqrt2    = Dsqrt(forSqrt1)

              InProd_zero = (p1(2)+i_*p1(3))*sqrt1 -
     &                      (p2(2)+i_*p2(3))*sqrt2

           ELSEIF ( (l1.EQ.-1) .AND. (l2.EQ.+1) ) THEN

              forSqrt1 = (p1(0)-p1(1))/(p2(0)-p2(1))
              forSqrt2 = 1.0d0/forSqrt1
              sqrt1    = Dsqrt(forSqrt2)
              sqrt2    = Dsqrt(forSqrt1)

              InProd_zero = (p2(2)-i_*p2(3))*sqrt2 -
     &                      (p1(2)-i_*p1(3))*sqrt1

           ELSE

              WRITE(MCLUN,*) " "
              WRITE(MCLUN,*) " ERROR IN InProd_zero:"
              WRITE(MCLUN,*) "       WRONG VALUES FOR l1,l2: l1,l2 = -1,+1"
              WRITE(MCLUN,*) " "
              STOP

           ENDIF

        RETURN
        END


       subroutine conductivity_v3(isoillayers,peat_fraction,
     $  soilporosity,porositycombined,thermcondmineral,thermcondpeat,
     $  dry_soil_thcnd,soilsolid_thcnd,
     $  heatcapmineral,heatcappeat,dry_soil_heatc)

      implicit none
      integer ilayer,isoillayers,ibaselayer
      real*8  thermcondmineral,thermcondpeat,thermcondair
      real*8  heatcapmineral,heatcappeat
      real*8  soilporosity,mineraldensity,dry_mineral_thcnd
      real*8  porositycombined(isoillayers),peat_fraction(isoillayers)
      real*8  dry_soil_thcnd(isoillayers),soilsolid_thcnd(isoillayers)
      real*8  heatcaplayer(isoillayers),dry_soil_heatc(isoillayers)

c  bulk density and thermal conductivity of the mineral soil
      mineraldensity    = 2700.0d0*(1.0d0 - soilporosity)
      dry_mineral_thcnd = (0.135d0*mineraldensity + 64.70d0)/
     $   (2700.0d0 - 0.947d0*mineraldensity)

      do ilayer = 1, isoillayers

c  thermal conductivity of the dry soil (including peat)
         dry_soil_thcnd(ilayer) = 0.05d0 * peat_fraction(ilayer) +
     $     dry_mineral_thcnd * (1.0d0 - peat_fraction(ilayer))

c  thermal conductivity of the mineral soil
         soilsolid_thcnd(ilayer) = (1.0d0 - peat_fraction(ilayer))*
     $     thermcondmineral + thermcondpeat * peat_fraction(ilayer)

         heatcaplayer(ilayer) =
     $     heatcappeat * peat_fraction(ilayer) +
     $     heatcapmineral * (1.0d0 - peat_fraction(ilayer))

         dry_soil_heatc(ilayer) =
     $     heatcaplayer(ilayer) * (1-porositycombined(ilayer))

c  I do not think I should treat the bedrock separately --- I will change the "porosity" here.
c        write(111,*) ilayer,peat_fraction(ilayer),
c     $     dry_soil_thcnd(ilayer),soilsolid_thcnd(ilayer),
c     $     dry_soil_heatc(ilayer)
      enddo    ! end of loop over soil layers

      end


module aloha2d_coupling
  use aloha2D_constants, only : wp

  implicit none

    ! Ports attributes
    real, private :: a1, b1, y1, z1
    real, private :: a2, b2, y2, z2
    integer, private :: m1, n1
    integer, private :: m2, n2
    character(len=1), private  :: mode1, mode2

    real :: nz_quad ! nz index of the first integration loop

  contains

    !
    !
    ! Coupling admittance integral evaluation
    !
    !
    function eval_K(aa1, bb1, yy1, zz1, mod1, mm1, nn1, aa2, bb2, yy2, zz2, mod2, mm2, nn2) result(K)
      use aloha2d_constants

      implicit none

      real, intent(in) :: aa1, bb1, aa2, bb2, yy1, yy2, zz1, zz2
      integer, intent(in) :: mm1, nn1, mm2, nn2
      character(len=1), intent(in) :: mod1, mod2
      complex :: K

      real :: Kr=0.0,Ki=0.0

      ! Copy the input parameters into the module,
      ! in order to use these parameters from the module instead of
      ! having to pass them by arguments...
      a1 = aa1
      a2 = aa2
      b1 = bb1
      b2 = bb2
      y1 = yy1
      y2 = yy2
      z1 = zz1
      z2 = zz2
      mode1 = mod1
      mode2 = mod2
      m1 = mm1
      m2 = mm2
      n1 = nn1
      n2 = nn2

      ! Real an imaginary parts
      Call integral_real_f(Kr)
      Call integral_imag_f(Ki)
      K = one*Kr+j*Ki

    end function eval_K

    subroutine spectralFunction(ny,nz,f_ny_nz)
      use aloha2d_globalParameters, only : k0
      use aloha2d_constants, only : Y0
      use aloha2d_plasma_admittance
      use aloha2d_rectangularWaveguides, only : spectralEigenVector

      implicit none

      real, intent(in) :: ny,nz
      complex, intent(out):: f_ny_nz

      complex :: g_S_interp,g_F_interp
      complex :: Ys_yy_interp, Ys_yz_interp, Ys_zy_interp, Ys_zz_interp
      complex :: Ey1,Ez1,Hy1,Hz1,Ey2,Ez2,Hy2,Hz2

      ! calculates the modal function in the (ny,nz) space
      call spectralEigenVector(ny,nz,a1,b1,m1,n1,y1,z1,mode1,Ey1,Ez1,Hy1,Hz1)
      call spectralEigenVector(ny,nz,a2,b2,m2,n2,y2,z2,mode2,Ey2,Ez2,Hy2,Hz2)

      ! evaluate the plasma admitance tensor from interpolation
      ! TODO : correct q bug ??
      call interpolate_gS_gF(ny,nz, g_S_interp,g_F_interp)
      !g_S_interp = eval_gS_fem(ny,nz)
      !g_F_interp = eval_gF_fem(ny,nz)

      ! Part to be replaced by OLGA evaluation of the admittance
      call eval_admittanceTensor(ny,nz, &
                g_S_interp,g_F_interp, &
                Ys_yy_interp,Ys_yz_interp,Ys_zy_interp,Ys_zz_interp)

      ! Integrande
      f_ny_nz = Y0*k0**2/(4.*pi**2)*&
                (conjg(Hy1)*(Ys_yy_interp*Ey2 + Ys_yz_interp*Ez2)+&
                 conjg(Hz1)*(Ys_zy_interp*Ey2 + Ys_zz_interp*Ez2))

    end subroutine spectralFunction

Subroutine integral_real_f(Kr)
      use aloha2d_constants, only : epsrel, epsabs
      use aloha2d_plasma

      implicit none

      real, intent(out) :: Kr

      integer :: npts2=2,neval,ier!,limit=400,leniw=802,lenw=2000,last,iwork(802)
      real :: a_nz,b_nz, K_tamp=0.0
      real :: points(2), abserr !,work(2000)
      real :: demi_intervalle=0.2

      real, external :: f_real_nz

      ! TODO
      ! This section could be easily distributed, each all the integral being calculated by one core

      !write(*,*) 'real part'
      !write(*,*) 'nz domain 1/5'

      a_nz=nz_min
      b_nz=-SQRT(ABS(S))-demi_intervalle
      !Call qag(f_real_nz,a_nz,b_nz,epsabs,epsrel,quad_key,K_tamp, &
      !      abserr,neval,ier,limit,lenw,last,iwork,work)
      Call qags(f_real_nz,a_nz,b_nz,epsabs,epsrel,&
                K_tamp, abserr,neval,ier)

      Kr=K_tamp

      !write(*,*) Kr
      !write(*,*) 'nz domain 2/5'

      a_nz=-SQRT(ABS(S))-demi_intervalle
      b_nz=-SQRT(ABS(S))+demi_intervalle
      points(1)=-SQRT(ABS(S))
      Call qagp(f_real_nz,a_nz,b_nz,npts2,points,epsabs,epsrel,&
          K_tamp ,abserr,neval,ier)
      Kr=Kr+K_tamp

      !write(*,*) Kr
      !write(*,*) 'nz domain 3/5'

      a_nz=-SQRT(ABS(S))+demi_intervalle
      b_nz=SQRT(ABS(S))-demi_intervalle
      Call qags(f_real_nz,a_nz,b_nz,epsabs,epsrel,&
            K_tamp,abserr, neval,ier)
      Kr=Kr+K_tamp

      !write(*,*) Kr
      !write(*,*) 'nz domain 4/5'

      a_nz=+SQRT(ABS(S))-demi_intervalle
      b_nz=+SQRT(ABS(S))+demi_intervalle
      points(1)=SQRT(ABS(S))
      Call qagp(f_real_nz,a_nz,b_nz,npts2,points,epsabs,epsrel,&
                K_tamp,abserr,neval,ier)
      Kr=Kr+K_tamp

      !write(*,*) Kr
      !write(*,*) 'nz domain 5/5'

      a_nz=+SQRT(ABS(S))+demi_intervalle
      b_nz=nz_max
      !Call qag(f_real_nz,a_nz,b_nz,epsabs,epsrel,quad_key,K_tamp,abserr, &
      !       neval,ier,limit,lenw,last,iwork,work)

      Call qags(f_real_nz,a_nz,b_nz,epsabs,epsrel,&
              K_tamp,abserr, neval,ier)
      Kr=Kr+K_tamp

      !write(*,*) Kr

End subroutine integral_real_f

Subroutine integral_imag_f(Ki)
      use aloha2d_constants, only : quad_key, epsrel, epsabs
      use aloha2d_plasma

      implicit none

      real, intent(out) :: Ki

      integer :: npts2=2,neval,ier!,limit=400,leniw=802,lenw=2000,last,iwork(802)
      real :: a_nz,b_nz, Ki_tamp=0.0
      real :: points(2),abserr !,work(2000),
      real :: demi_intervalle=0.2

      real, external :: f_imag_nz

      ! TODO
      ! This section could be easily distributed, each all the integral being calculated by one core

      !write(*,*) 'imag part'
      !write(*,*) 'nz domain 1/5'

      a_nz=nz_min
      b_nz=-SQRT(ABS(S))-demi_intervalle
      Call qags(f_imag_nz,a_nz,b_nz,epsabs,epsrel,&
                Ki_tamp, abserr,neval,ier)

      Ki=Ki_tamp

      !write(*,*) Ki
      !write(*,*) 'nz domain 2/5'

      a_nz=-SQRT(ABS(S))-demi_intervalle
      b_nz=-SQRT(ABS(S))+demi_intervalle
      points(1)=-SQRT(ABS(S))
      Call qagp(f_imag_nz,a_nz,b_nz,npts2,points,epsabs,epsrel,&
          Ki_tamp ,abserr,neval,ier)
      Ki=Ki+Ki_tamp

      !write(*,*) Ki
      !write(*,*) 'nz domain 3/5'

      a_nz=-SQRT(ABS(S))+demi_intervalle
      b_nz=SQRT(ABS(S))-demi_intervalle
      Call qags(f_imag_nz,a_nz,b_nz,epsabs,epsrel,&
            Ki_tamp,abserr, neval,ier)
      Ki=Ki+Ki_tamp

      !write(*,*) Ki
      !write(*,*) 'nz domain 4/5'

      a_nz=+SQRT(ABS(S))-demi_intervalle
      b_nz=+SQRT(ABS(S))+demi_intervalle
      points(1)=SQRT(ABS(S))
      Call qagp(f_imag_nz,a_nz,b_nz,npts2,points,epsabs,epsrel,&
                Ki_tamp,abserr,neval,ier)
      Ki=Ki+Ki_tamp

      !write(*,*) Ki
      !write(*,*) 'nz domain 5/5'

      a_nz=+SQRT(ABS(S))+demi_intervalle
      b_nz=nz_max
      Call qags(f_imag_nz,a_nz,b_nz,epsabs,epsrel,&
              Ki_tamp,abserr, neval,ier)
      Ki=Ki+Ki_tamp

      !write(*,*) Ki

End subroutine integral_imag_f

! Calculates arrays of spectral electric and magnetic field components
! Returned array of size nb_ny x nb_nz
subroutine spect_discr(aa, bb, yy, zz, mode, mm, nn, &
                       eyt_ny_nz, ezt_ny_nz, hyt_ny_nz, hzt_ny_nz)
    use aloha2d_plasma_admittance
    use aloha2d_rectangularwaveguides

    implicit none

    real, intent(in) :: aa, bb, yy, zz
    character(len=1), intent(in) :: mode
    integer, intent(in) :: mm, nn
    complex, dimension(:), allocatable, intent(out) :: eyt_ny_nz, ezt_ny_nz, hyt_ny_nz, hzt_ny_nz

    integer :: incr ! arrays index
    real :: ny, nz
    complex :: ey_ny_nz, ez_ny_nz, hy_ny_nz, hz_ny_nz ! spectral components of the field

    allocate(eyt_ny_nz(GRID_NY_NB*GRID_NZ_NB), ezt_ny_nz(GRID_NY_NB*GRID_NZ_NB))
    allocate(hyt_ny_nz(GRID_NY_NB*GRID_NZ_NB), hzt_ny_nz(GRID_NY_NB*GRID_NZ_NB))

    incr=1

    ! nz first then ny
    Do n1=0,GRID_NZ_NB-1
      !write(*,*) n1+1,'/',GRID_NZ_NB
      nz = GRID_NZ_MIN + n1*GRID_DNZ

      Do n2=0,GRID_NY_NB-1
            ny = GRID_NY_MIN + n2*GRID_DNY

            call spectralEigenVector(ny, nz, aa, bb, mm, nn, yy, zz, mode, &
                                    ey_ny_nz, ez_ny_nz, hy_ny_nz, hz_ny_nz)

            ! save into the arrays
            eyt_ny_nz(incr)=ey_ny_nz
            ezt_ny_nz(incr)=ez_ny_nz
            hyt_ny_nz(incr)=hy_ny_nz
            hzt_ny_nz(incr)=hz_ny_nz

            incr=incr+1
        end do
    end do
end subroutine spect_discr

end module aloha2d_coupling

      !
      ! integrand of the spectral function
      !
      !
      function f_real(ny) result(f_r)
        use aloha2d_constants, only : wp
        use aloha2d_coupling, only : nz_quad, spectralFunction

        implicit none

        real, intent(in) :: ny ! quadpack uses default precision real
        real :: f_r

        complex :: f_ny_nz

        call spectralFunction(ny,nz_quad,f_ny_nz)

        f_r = real(f_ny_nz)

      End function f_real

      !
      ! integrand of the spectral function
      !
      !
      function f_imag(ny) result(f_i)
        use aloha2d_constants, only : wp
        use aloha2d_coupling, only : nz_quad, spectralFunction

        implicit none

        real, intent(in) :: ny ! quadpack uses default precision real
        real :: f_i

        complex :: f_ny_nz

        call spectralFunction(ny,nz_quad,f_ny_nz)

        f_i = aimag(f_ny_nz)

      End function f_imag

  !
  ! Integrand F(ny,nz), integrated along ny
  !
  function f_real_nz(nz_dp) result(f_nz_r)
    use aloha2d_globalParameters, only : ny_min, ny_max !
    use aloha2d_constants ! epsrel, epsabs, quadkey
    use aloha2d_plasma
    use aloha2d_coupling, only : nz_quad

    implicit none

    real, intent(in) :: nz_dp ! quadpack use default real precision
    real :: f_nz_r

    real :: nz

    real :: tamp, demi_intervalle=0.2
    real :: a_ny, b_ny, points(2), abserr
    integer :: npts2=1+2 ! one break point +2 (cf doc)
    integer :: ier,neval!,limit=400,leniw=802,lenw=2000,last,work,iwork(802)

    real, external :: f_real

      !write(*,*) '    f_real_nz'
    ! copy the current nz value to global memory
    ! casting the values to default real for quadpack
    nz = nz_dp
    nz_quad = nz

      If (SQRT(ABS(S-nz**2.)).LE.ny_max) Then

         If (SQRT(ABS(S-nz**2.)).GE.(ny_max-demi_intervalle)) Then
            !write(*,*) '    1st ny domain'

            a_ny=real(ny_min) ! cast to default real precision for compatibility with quadpack
            b_ny=real(-SQRT(ABS(S-nz**2.))+demi_intervalle)
            points(1)=-SQRT(ABS(S-nz**2.))
            Call qagp(f_real,a_ny,b_ny,npts2,points,epsabs, &
              epsrel,tamp,abserr,neval,ier)
            f_nz_r=tamp
            !write(*,*) '    2nd ny domain'
            a_ny=real(-SQRT(ABS(S-nz**2.))+demi_intervalle)
            b_ny=real(SQRT(ABS(S-nz**2.))-demi_intervalle)
            Call qags(f_real,a_ny,b_ny,epsabs,epsrel,tamp,abserr, &
                     neval,ier)
            f_nz_r=f_nz_r+tamp
            !write(*,*) '    3rd and last ny domain'
            a_ny=real(+SQRT(ABS(S-nz**2.))-demi_intervalle)
            b_ny=real(ny_max)
            points(1)=SQRT(ABS(S-nz**2.))
            Call qagp(f_real,a_ny,b_ny,npts2,points,epsabs, &
              epsrel,tamp,abserr,neval,ier)
            f_nz_r=f_nz_r+tamp

         Else
            !write(*,*) '    1st ny domain'
            a_ny=real(ny_min)
            b_ny=real(-SQRT(ABS(S-nz**2.))-demi_intervalle)
            Call qags(f_real,a_ny,b_ny,epsabs,epsrel,tamp,abserr, &
                     neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_r=tamp
            !write(*,*) '    2nd ny domain'
            a_ny=real(-SQRT(ABS(S-nz**2.))-demi_intervalle)
            b_ny=real(-SQRT(ABS(S-nz**2.))+demi_intervalle)
            points(1)=-SQRT(ABS(S-nz**2.))
            Call qagp(f_real,a_ny,b_ny,npts2,points,epsabs, &
              epsrel,tamp,abserr,neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_r=f_nz_r+tamp
            !write(*,*) '    3rd ny domain'
            a_ny=real(-SQRT(ABS(S-nz**2.))+demi_intervalle)
            b_ny=real(SQRT(ABS(S-nz**2.))-demi_intervalle)
            Call qags(f_real,a_ny,b_ny,epsabs,epsrel,tamp,abserr, &
                     neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_r=f_nz_r+tamp
            !write(*,*) '    4th ny domain'
            a_ny=real(+SQRT(ABS(S-nz**2.))-demi_intervalle)
            b_ny=real(+SQRT(ABS(S-nz**2.))+demi_intervalle)
            points(1)=SQRT(ABS(S-nz**2.))
            Call qagp(f_real,a_ny,b_ny,npts2,points,epsabs, &
              epsrel,tamp,abserr,neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_r=f_nz_r+tamp
            !write(*,*) '    5th and last ny domain'
            a_ny=real(SQRT(ABS(S-nz**2.))+demi_intervalle)
            b_ny=real(ny_max)
            Call qags(f_real,a_ny,b_ny,epsabs,epsrel,tamp,abserr, &
                     neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_r=f_nz_r+tamp

         Endif

      Else
        !write(*,*) '    1st and last ny domain'
         a_ny=real(ny_min)
         b_ny=real(ny_max)
         Call qags(f_real,a_ny,b_ny,epsabs,epsrel,f_nz_r,abserr, &
             neval,ier)

      Endif
  End function f_real_nz

  !
  ! Integrand F(ny,nz), integrated along ny
  !
  function f_imag_nz(nz) result(f_nz_i)
    use aloha2d_globalParameters
    use aloha2d_constants ! epsrel, epsabs, quadkey
    use aloha2d_plasma
    use aloha2d_coupling, only : nz_quad

    implicit none

    real, intent(in) :: nz
    real :: f_nz_i

    real :: tamp, demi_intervalle=0.2
    real :: a_ny, b_ny, points(2), abserr
    integer :: npts2=2
    integer :: ier,neval!,limit=400,leniw=802,lenw=2000,last,work,iwork(802)

    real, external :: f_imag

    ! copy the current nz value to global memory
    nz_quad = nz

      If (SQRT(ABS(S-nz**2.)).LE.ny_max) Then

         If (SQRT(ABS(S-nz**2.)).GE.(ny_max-demi_intervalle)) Then

            a_ny=ny_min
            !TODO : est ce qu il n'y a pas un probleme avec les bornes ci-dessous ??
            b_ny=-SQRT(ABS(S-nz**2.))+demi_intervalle
            points(1)=-SQRT(ABS(S-nz**2.))
            Call qagp(f_imag,a_ny,b_ny,npts2,points,epsabs,&
              epsrel,tamp,abserr,neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_i=tamp

            a_ny=-SQRT(ABS(S-nz**2.))+demi_intervalle
            b_ny=SQRT(ABS(S-nz**2.))-demi_intervalle
            Call qags(f_imag,a_ny,b_ny,epsabs,epsrel,tamp,abserr,&
                     neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_i=f_nz_i+tamp

            a_ny=+SQRT(ABS(S-nz**2.))-demi_intervalle
            b_ny=ny_max
            points(1)=SQRT(ABS(S-nz**2.))
            Call qagp(f_imag,a_ny,b_ny,npts2,points,epsabs,&
              epsrel,tamp,abserr,neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_i=f_nz_i+tamp

          Else
            a_ny=real(ny_min)
            b_ny=real(-SQRT(ABS(S-nz**2.))-demi_intervalle)
            Call qags(f_imag,a_ny,b_ny,epsabs,epsrel,tamp,abserr,&
                     neval,ier)
            ! JH 24/03/2013
            ! The follwing isNaN test below intend to avoid
            ! a NaN value in tamp for some high order mode (TE0n?)
            if (isNaN(tamp)) tamp = 0.0;

            f_nz_i=tamp

            a_ny=real(-SQRT(ABS(S-nz**2.))-demi_intervalle)
            b_ny=real(-SQRT(ABS(S-nz**2.))+demi_intervalle)
            points(1)=-SQRT(ABS(S-nz**2.))
            Call qagp(f_imag,a_ny,b_ny,npts2,points,epsabs,&
              epsrel,tamp,abserr,neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_i=f_nz_i+tamp

            a_ny=-SQRT(ABS(S-nz**2.))+demi_intervalle
            b_ny=SQRT(ABS(S-nz**2.))-demi_intervalle
            Call qags(f_imag,a_ny,b_ny,epsabs,epsrel,tamp,abserr,&
                     neval,ier)
            if (isNaN(tamp)) tamp = 0.0;

            f_nz_i=f_nz_i+tamp

            a_ny=+SQRT(ABS(S-nz**2.))-demi_intervalle
            b_ny=+SQRT(ABS(S-nz**2.))+demi_intervalle
            points(1)=SQRT(ABS(S-nz**2.))
            Call qagp(f_imag,a_ny,b_ny,npts2,points,epsabs,&
              epsrel,tamp,abserr,neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_i=f_nz_i+tamp

            a_ny=SQRT(ABS(S-nz**2.))+demi_intervalle
            b_ny=ny_max
            Call qags(f_imag,a_ny,b_ny,epsabs,epsrel,tamp,abserr,&
                     neval,ier)
            if (isNaN(tamp)) tamp = 0.0;
            f_nz_i=f_nz_i+tamp

         Endif

      Else ! Pas de pole dans le domaine d' integration : un seul interval d' integration

         a_ny=ny_min
         b_ny=ny_max
         Call qags(f_imag,a_ny,b_ny,epsabs,epsrel,f_nz_i,abserr,&
             neval,ier)

      Endif

End function f_imag_nz


module type_explicit_runge_kutta
    use mod_kinds,                      only: rk,ik
    use mod_constants,                  only: ZERO,HALF,ONE,TWO,SIX
    use mod_spatial,                    only: update_space

    use type_time_integrator_marching,  only: time_integrator_marching_t
    use type_chidg_data,                only: chidg_data_t
    use type_nonlinear_solver,          only: nonlinear_solver_t
    use type_linear_solver,             only: linear_solver_t
    use type_preconditioner,            only: preconditioner_t
    use type_chidg_vector,

    use mod_define_explicit_RK_methods, only: method_selector

    implicit none
    private

    !>  Solution advancement via a general explicit Runge-Kutta method
    !!
    !!  Given the system of partial differential equations consisting of the time-derivative
    !!  of the solution vector and a spatial residual as
    !!
    !!  \f$ \frac{\partial Q}{\partial t} + R(Q) = 0 \f$
    !!
    !!  The solution of the next time level is then computed as
    !!
    !!  \f$ Q^{n+1} = Q^{n} + \sum_{i = 1}^{s} b_{i} \Delta Q_{i} \f$
    !!
    !!  or
    !!
    !!  \f$ Q^{n+1} = Q^{n} + \Delta Q \f$
    !!
    !!  where
    !!
    !!  \f$ \Delta Q = \sum_{i = 1}^{s} b_{i} \Delta Q_{i} \f$
    !!
    !!  with
    !!
    !!  \f$ \Delta Q_{i} = -\Delta t m^{-1} R(Q^{n} + \sum_{j = 1}^{i-1} a_{ij} \Delta Q_{j}) \f$
    !!
    !!  where \f$ M \f$ refers to the mass matrix, \f$ s \f$ refers to the number of the stages in the
    !!  method and \f$ a_{ij}'s & b_{j}'s \f$ refer to the coefficents defined by the Butcher tableau
    !!
    !!
    !!  This routine computes \f$ \Delta Q \f$ and updates the solution
    !!
    !!
    !!  @author Mayank Sharma
    !!  @date   1/18/2017
    !!
    !!
    !---------------------------------------------------------------------------------------------------------------------
    type, extends(time_integrator_marching_t), public :: explicit_runge_kutta_t

    contains

        procedure   :: step

    end type explicit_runge_kutta_t
    !*********************************************************************************************************************

contains

    !>  Solve for update dq
    !!
    !!  \f$ \Delta Q_{i} = -\Delta t m^{-1} R(Q^{n} + \sum_{j = 1}^{i-1} a_{ij} \Delta Q_{j}) \f$
    !!
    !!  @author Mayank Sharma
    !!  @date   18/1/2017
    !!
    !!
    !---------------------------------------------------------------------------------------------------------------------
    subroutine step(self,data,nonlinear_solver,linear_solver,preconditioner)
        class(explicit_runge_kutta_t),              intent(inout)   :: self
        type(chidg_data_t),                         intent(inout)   :: data
        class(nonlinear_solver_t),      optional,   intent(inout)   :: nonlinear_solver
        class(linear_solver_t),         optional,   intent(inout)   :: linear_solver
        class(preconditioner_t),        optional,   intent(inout)   :: preconditioner

        !
        ! Variables read from subroutines defining the explicit RK methods
        !
        integer(ik)                          :: nstage
        real(rk),            allocatable     :: a(:,:)
        real(rk),            allocatable     :: b(:)
        !
        ! Variables defined for use in this module
        !
        type(chidg_vector_t), allocatable    :: delq(:)
        type(chidg_vector_t)                 :: q_n, q_adv
        character(100)                       :: filename
        character(len = :),  allocatable     :: time_scheme
        integer(ik)                          :: itime = 1, nsteps, ielem, wcount, iblk, ieqn, idom, istage, j
        real(rk),            allocatable     :: vals(:)

        associate( q   => data%sdata%q,      &
                   dq  => data%sdata%dq,     &
                   rhs => data%sdata%rhs,    &
                   lhs => data%sdata%lhs,    &
                   dt  => data%time_manager%dt )

            !
            ! Get name of the RK method being used
            !
            time_scheme = data%time_manager%get_name()

            !
            ! Get nstage, a and b for a particular scheme
            ! All methods defined in mod_explicit_RK_methods.f90
            !
            call method_selector(time_scheme,nstage,a,b)

            !
            ! Copy the solution vector at the present time level to a temporary vector
            !
            q_n = q

            !
            ! q_adv is a temporary vector used to advance the solution after each stage
            ! Computed using an accumulated sum
            ! Initialize q_adv
            !
            q_adv = q_n

            if (allocated(delq)) deallocate(delq)
            allocate(delq(nstage))

            !
            ! Loop through the stages of the present RK method
            !
            do istage = 1,nstage

                !
                ! Update Spatial Residual and Linearization (rhs, lin)
                !
                call update_space(data,differentiate=.false.)
                call self%residual_norm%push_back(rhs%norm(ChiDG_COMM))

                do idom = 1,data%mesh%ndomains()
                    do ielem = 1,data%mesh%domain(idom)%nelem
                        do ieqn = 1,data%eqnset(idom)%prop%nprimary_fields()

                            vals = matmul(data%mesh%domain(idom)%elems(ielem)%invmass, &
                                          rhs%dom(idom)%vecs(ielem)%getvar(ieqn,itime))
                            call rhs%dom(idom)%vecs(ielem)%setvar(ieqn,itime,vals)

                        end do  ! ieqn
                    end do  ! ielem
                end do  ! idom

                !
                ! Calculate stagewise update and its contribution to the final update
                !
                dq = (-dt)*rhs
                delq(istage) = b(istage)*dq

                !
                ! Compute the solution vector to pass to update_space for the next stage
                ! Refer to scheme description above
                !
                if (istage < nstage) then
                    do j = 1,istage
                        q = q + (a(istage + 1,j)*delq(j)/b(j))
                    end do
                end if

                !
                ! Clear working vector
                !
                call rhs%clear()

                !
                ! Update q_adv after each stage
                !
                q_adv = add_chidg_vector_chidg_vector(q_adv, delq(istage))

            end do  ! istage

            !
            ! Advance solution
            !
            q = q_adv

        end associate

    end subroutine step
    !*********************************************************************************************************************

end module type_explicit_runge_kutta


program GenerateEvents
    !Run from the command line
    ! ./GenerateEvents M_X SIGMA_SI RHO
    ! where
    !   - M_X is the WIMP mass in GeV
    !   - SIGMA_SI is the WIMP-nucleon xsec in cm^2
    !   - RHO is the local density in GeV/cm^3

use ranlib_poisson
use LabFuncs
use DDrate
use modulation
use utils
use expt !E_min, E_max, t_start(), t_end(), A_det, m_det, resolution

implicit none

double precision :: N_exp
integer :: i, N_obs

double precision :: m_x, sigma_SI, rho

double precision, allocatable :: events_E(:), events_t(:)
double precision, allocatable :: reslist(:)

!RNG stuff
integer :: values(1:8), k
integer, dimension(:), allocatable :: seed
double precision, allocatable :: x(:)
double precision :: r

!Stuff for doing the inverse transform sampling
integer :: NE = 200
integer :: Nt
integer :: i_t, i_E
integer :: i_cut

!Lists for generating the inverse CDFs in (t, E)
double precision, allocatable :: tlist(:), Elist(:)
double precision, allocatable :: rate(:), cum_rate(:)

!Load in cross section and density from the command line
character(len=100) :: input_str
call getarg(1, input_str)
read(input_str, *) m_x

call getarg(2, input_str)
read(input_str,*) sigma_SI

call getarg(3, input_str)
read(input_str,*) rho

write(*,*) "Generating events using:"
write(*,*) "    m_x [GeV]:", sigma_SI
write(*,*) "    sigma_SI [cm^2]:", sigma_SI
write(*,*) "    rho [GeV/cm^3]:", rho

! Initialise seed for rng
call initialize()
call date_and_time(values=values)
call random_seed(size=k)
allocate(seed(1:k))
seed(:) = values(8)
call random_seed(put=seed)
call random_number(r)
call set_initial_seed ( floor(1d6*r), floor(1d7*r) )

!Read in the data tables for the daily modulations
call initialise_modulation

! Calculate total number of events
N_exp = (rho/rho0)*m_det*Nevents(E_min, E_max, t_start(), t_end(), A_det, m_x, sigma_SI)
write(*,*) "    N_exp:", N_exp
N_obs = IGNPOI(real(N_exp))
write(*,*) "    N_obs:", N_obs

allocate(events_E(N_obs))
allocate(events_t(N_obs))
allocate(x(N_obs))

!----------------
write(*,*) "    Sampling event times..."

!Calculate the rate using roughly 100 time steps per day
Nt = 99*nint(t_end() - t_start()) + 1

allocate(tlist(Nt))
allocate(rate(Nt))
allocate(cum_rate(Nt))

! Sampling event rate as a function of time
! integrated over energy
tlist = linspace(t_start(), t_end(), Nt)
do i_t = 1, Nt
    rate(i_t) = (rho/rho0)*m_det*Nevents_fixedt(E_min, E_max, tlist(i_t), A_det, m_x, sigma_SI)
end do

! Inverse transform sample to get event times
cum_rate =  cumtrapz(tlist, rate)
cum_rate = cum_rate/cum_rate(Nt)
call random_number(x)

events_t = linterp(cum_rate, tlist, x)

deallocate(tlist)
deallocate(rate)
deallocate(cum_rate)

!----------------
write(*,*) "    Sampling event energies..."

allocate(Elist(NE))
allocate(reslist(NE))
allocate(rate(NE))
allocate(cum_rate(NE))

Elist = 10**(linspace(log10(E_th), log10(E_max), NE))

do i = 1, N_obs
    do i_E = 1, NE
        rate(i_E) = (rho/rho0)*m_det*dRdE_res(Elist(i_E), events_t(i), A_det, m_x, sigma_SI)
    end do

    !Find the point where the rate drops to zero,
    !and cut there, otherwise the interpolation
    !can get screwed up...
    i_cut = 1
    do while (rate(i_cut) > 1d-30)
        i_cut = i_cut + 1
        if (i_cut > NE) then
            exit
        end if
    end do
    !In fact, cut one step earlier, just to be sure...
    i_cut = i_cut - 1

    cum_rate(1:i_cut) =  cumtrapz(Elist(1:i_cut), rate(1:i_cut))
    cum_rate(1:i_cut) = cum_rate(1:i_cut)/cum_rate(i_cut)

    call random_number(r)
    events_E(i) = linterp_scalar(cum_rate(1:i_cut), Elist(1:i_cut), r)

end do

!Save to file
write(*,*) "    Saving to file <events.txt>..."

open (unit = 2, file = "events.txt")
do i = 1, N_obs
    write (2, *) events_t(i), events_E(i)
end do
close(2)

end program GenerateEvents


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine gaspipe_fanno(node1,node2,nodem,nelem,lakon,kon,
     &        ipkon,nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &        nodef,idirf,df,cp,r,physcon,dvi,numf,set,
     &        shcon,nshcon,rhcon,nrhcon,ntmat_,co,vold,mi,ttime,time,
     &        iaxial,iplausi)
!
!     pipe with friction losses (Fanno Formulas) GAPF
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity,crit,wrongdir
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(*),idirf(*),index,iflag,
     &     inv,ipkon(*),kon(*),icase,k_oil
     &     ,nshcon(*),nrhcon(*),ntmat_,mi(*),nodea,nodeb,
     &     nodec,iaxial,iplausi
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(*),kappa,r,A,d,l,
     &     T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(*),p2p1,km1,dvi,
     &     kp1,kdkm1,km1d2k,reynolds,pi,lambda,lld,xflow_air,
     &     C2,tdkp1,ttime,time,pt2zpt1,ks,form_fact,xflow_oil,
     &     pt2zpt1_c,Qred1_crit,Qred,phi,M1,M2,Qred1,co(3,*),
     &     shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),vold(0:mi(2),*),
     &     radius,bb,cc,ee1,ee2,dfdM1,dfdM2,M1_c,Z1,Z2
!
!
!
      if(iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif(iflag.eq.1)then
!
         pi=4.d0*datan(1.d0)
!
         index=ielprop(nelem)
         kappa=(cp/(cp-r))
         A=prop(index+1)
         d=prop(index+2)
         l=prop(index+3)
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPFA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPFI') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=nint(prop(index+7))
!
         if(lakon(nelem)(7:8).eq.'FR') then
!
!           flexible radius
!
            nodea=nint(prop(index+1))
            nodeb=nint(prop(index+2))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
!
            A=pi*radius**2
            d=2*radius
!
         elseif(lakon(nelem)(7:8).eq.'RL') then
!
!           flexible radius and length
!
            nodea=nint(prop(index+1))
            nodeb=nint(prop(index+2))
            nodec=nint(prop(index+3))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
            d=2*radius
            A=pi*radius**2
            l=dsqrt((co(2,nodec)+vold(2,nodec)-
     &           co(2,nodeb)-vold(2,nodeb))**2)
         endif
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(pt1.ge.pt2) then
            inv=1
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            Tt1=v(0,node2)-physcon(1)
            Tt2=v(0,node1)-physcon(1)
         endif
!
         p2p1=pt2/pt1
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         tdkp1=2.d0/kp1
         C2=tdkp1**kdkm1
!
!        estimate of the flow using the orifice relationships
!        the flow is needed for Reynolds, Reynolds is needed
!        for the friction coefficient
!
         if(v(1,nodem)*inv.le.0.d0) then
            if(p2p1.gt.C2) then
               xflow=inv*pt1*A*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa)
     &              *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(Tt1)
            else
               xflow=inv*pt1*A*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/
     &              dsqrt(Tt1)
            endif
         else
            xflow=v(1,nodem)*iaxial
         endif
!
!        calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1d-30) then
            write(*,*) '*ERROR in gaspipe_fanno: '
            write(*,*) '       no dynamic viscosity defined'
            write(*,*) '       dvi= ',dvi
            call exit(201)
         endif
!
         reynolds=dabs(xflow)*d/(dvi*A)
!
         call friction_coefficient(l,d,ks,reynolds,form_fact,
     &        lambda)
!
!        estimate of the flow using the incompressible relationships
!        for a gas pipe (for zero initial flow or flow from low
!        to high pressure)
!
         if(v(1,nodem)*inv.le.0.d0) then
            xflow=inv*A*dsqrt(d/(lambda*l)*2*pt1/(r*Tt1)*(pt1-pt2))
         endif
!
         call pt2zpt1_crit(pt2,pt1,Tt1,lambda,kappa,r,l,d,
     &         pt2zpt1_c,Qred1_crit,crit,icase,M1_c)
!
         Qred=dabs(xflow)*dsqrt(Tt1)/(A*pt1)
!
!        correcting the mass flow if not physical
!        (pt2/pt1 too small or Qred too big)
!
         if(crit) then
!
!           the flow is set to half the critical value
!
            xflow=0.5d0*inv*Qred1_crit*pt1*A/dsqrt(Tt1)
         elseif(Qred.gt.Qred1_crit) then
!
!           the flow is set to half the critical value
!
            xflow=0.5d0*inv*Qred1_crit*pt1*A/dsqrt(Tt1)
         endif
!
!        isothermal case: correcting the temperatures
!
         if(icase.eq.1) then
            call ts_calc(xflow,Tt1,pt1,kappa,r,A,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,A,T2,icase)
            if(inv.eq.1) then
               v(3,node1)=T1
               v(3,node2)=T1
               if(nactdog(0,node2).eq.1) then
                  v(0,node2)=T1*(Tt2/T2)
               endif
            else
               v(3,node2)=T1
               v(3,node1)=T1
               if(nactdog(0,node1).eq.1) then
                  v(0,node1)=T1*(Tt2/T2)
               endif
            endif
         endif
!
      elseif(iflag.eq.2)then
!
         numf=5
!
         pi=4.d0*datan(1.d0)
!
         kappa=(cp/(cp-r))
         km1=kappa-1.d0
         kp1=kappa+1.d0
!
         index=ielprop(nelem)
         A=prop(index+1)
         d=prop(index+2)
!
         l=prop(index+3)
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPFA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPFI') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=nint(prop(index+7))
!
         if(lakon(nelem)(7:8).eq.'FR') then
!
!           flexible radius
!
            nodea=nint(prop(index+1))
            nodeb=nint(prop(index+2))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
            A=pi*radius**2
            d=2*radius
!
         elseif(lakon(nelem)(7:8).eq.'RL') then
!
!           flexible radius and length
!
            nodea=nint(prop(index+1))
            nodeb=nint(prop(index+2))
            nodec=nint(prop(index+3))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
            d=2*radius
            A=pi*radius**2
            l=dsqrt((co(2,nodec)+vold(2,nodec)-
     &           co(2,nodeb)-vold(2,nodeb))**2)
         endif
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         xflow=v(1,nodem)*iaxial
!
!        inv is the sign of the flow
!        xflow is replaced by its absolute value
!        wrongdir means that the flow goes from low
!        pressure to high pressure
!
         if(xflow.lt.0.d0) then
            inv=-1
         else
            inv=1
         endif
c         xflow=dabs(xflow)
         if((pt1-pt2)*inv.lt.0.d0) then
            wrongdir=.true.
         else
            wrongdir=.false.
         endif
!
!        the element is reoriented such that the mass flow
!        is directed from node 1 to node 2;
!        the pressure in node 1 may be more or less than
!        the pressure in node 2
!
         if(pt1.gt.pt2) then
!
            Tt1=v(0,node1)-physcon(1)
            call ts_calc(xflow,Tt1,pt1,kappa,r,A,T1,icase)
!
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
            nodef(5)=node2
         else
            pt1=v(2,node2)
            pt2=v(2,node1)
!
            Tt1=v(0,node2)-physcon(1)
            call ts_calc(xflow,Tt1,pt1,kappa,r,A,T1,icase)
!
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
            nodef(5)=node1
         endif
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=2
         idirf(5)=0
!
         pt2zpt1=pt2/pt1
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1d-30) then
            write(*,*) '*ERROR in gaspipe_fanno: '
            write(*,*) '       no dynamic viscosity defined'
            write(*,*) '       dvi= ',dvi
            call exit(201)
         endif
!
         reynolds=dabs(xflow)*d/(dvi*A)
!
!        calculation of the friction coefficient
!
         if(xflow_oil.ne.0d0) then
!
!           two-phase-flow
!
            xflow_air=xflow
            call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow_air,
     &           xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &           v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &           shcon,rhcon,ntmat_,mi)
            lambda=lambda*phi
         else
!
!           for pure air
!
c            phi=1.d0
            call friction_coefficient(l,d,ks,reynolds,form_fact,
     &           lambda)
         endif
!
!        calculating the critical conditions
!
         call pt2zpt1_crit(pt2,pt1,Tt1,lambda,kappa,r,l,d,
     &         pt2zpt1_c,Qred1_crit,crit,icase,M1_c)
!
         if(wrongdir) lambda=-lambda
!
         Qred1=dabs(xflow)*dsqrt(Tt1)/(A*pt1)
!
!        check whether flow is critical
!        assigning the physcical correct sign to xflow
!
         if(crit) then
            xflow=inv*Qred1_crit*A*pt1/dsqrt(Tt1)
!
!           check whether flow has changed; if so, update v
!           for consistency
!
            if(dabs((xflow-iaxial*v(1,nodem))/xflow).gt.1.d-5) then
               iplausi=0
               if(nactdog(1,nodem).ne.0) v(1,nodem)=xflow/iaxial
            endif
!
            M1=dsqrt(2/km1*((Tt1/T1)-1.d0))
            if(icase.eq.0) then
               M1=min(M1,0.999d0)
            else
               M1=min(M1,0.999d0/dsqrt(kappa))
            endif
         else
            if(Qred1.gt.Qred1_crit) then
               xflow=inv*Qred1_crit*A*pt1/dsqrt(Tt1)
!
!              check whether flow has changed; if so, update v
!              for consistency
!
               if(dabs((xflow-iaxial*v(1,nodem))/xflow).gt.1.d-5) then
                  iplausi=0
                  if(nactdog(1,nodem).ne.0) v(1,nodem)=xflow/iaxial
               endif
!
               M1=M1_c
            else
               M1=dsqrt(2/km1*((Tt1/T1)-1.d0))
            endif
!
!           determining M2: Tt2 -> T2 -> Tt2/T2 -> M2
!           the actual value of Tt2 is not relevant
!
            if(icase.eq.0) then
               Tt2=Tt1
            elseif(inv.eq.1) then
               Tt2=v(0,node2)-physcon(1)
            else
               Tt2=v(0,node1)-physcon(1)
            endif
            call ts_calc(xflow,Tt2,pt2,kappa,r,A,T2,icase)
            M2=dsqrt(2/km1*((Tt2/T2)-1.d0))
         endif
!
         Z1=M1**2
!
         bb=km1/2.d0
         cc=-kp1/(2.d0*km1)
         ee1=M1*(1.d0+bb*Z1)/(1.d0+bb*Z1*(1.d0+2.d0*cc))
!
!     definition of the coefficients
!
         lld=lambda*l/d
!
!        adiabatic case
!
         if(icase.eq.0) then
!
            dfdM1=2.d0*(Z1-1.d0)/(kappa*M1**3*(1.d0+bb*Z1))
!
            if(.not.crit) then
!
!              residual
!
               Z2=M2**2
!
               ee2=M2*(1.d0+bb*Z2)/(1.d0+bb*Z2*(1.d0+2.d0*cc))
               dfdM2=2.d0*(1.d0-Z2)/(kappa*M2**3*(1.d0+bb*Z2))
!
               f=(1.d0/Z1-1.d0/Z2)/kappa+kp1/(2.d0*kappa)*
     &           dlog(((1.d0+bb*Z2)*Z1)/
     &                ((1.d0+bb*Z1)*Z2))-lld
!
!              pressure node1
!
               df(1)=-dfdM1*ee1/pt1
!
!              temperature node1
!
               df(2)=dfdM1*ee1/(2.d0*Tt1)
!
!              mass flow
!
               df(3)=(dfdM1*ee1+dfdM2*ee2)/(xflow)
!
!              pressure node2
!
               df(4)=-dfdM2*ee2/pt2
!
!              temperature node2
!
               df(5)=dfdM2*ee2/(2.d0*Tt2)
!
            else
!
               f=(1.d0/Z1-1.d0)/kappa+kp1/(2.d0*kappa)*
     &           dlog(((1.d0+bb)*Z1)/
     &                ((1.d0+bb*Z1)))-lld
!
!              pressure node1
!
               df(1)=-dfdM1*ee1/pt1
!
!              temperature node1
!
               df(2)=dfdM1*ee1/(2.d0*Tt1)
!
!              mass flow
!
               df(3)=dfdM1*ee1/(xflow)
!
!              pressure node2
!
               df(4)=0.d0
!
!              temperature node2
!
               df(5)=0.d0
!
            endif
         elseif(icase.eq.1) then
!
!           isothermal icase
!
            dfdM1=2.d0*(kappa*Z1-1.d0)/(kappa*M1**3)
!
            if(.not.crit) then
!
               Z2=M2**2
!
               ee2=M2*(1.d0+bb*Z2)/(1.d0+bb*Z2*(1.d0+2.d0*cc))
               dfdM2=2.d0*(1.d0-kappa*Z2)/(kappa*M2**3)
!
!              redidual
!
               f=(1.d0/Z1-1.d0/Z2)/kappa+dlog(Z1/Z2)-lld
!
!              pressure node1
!
               df(1)=-dfdM1*ee1/pt1
!
!              temperature node1
!
               df(2)=dfdM1*ee1/(2.d0*Tt1)
!
!              mass flow
!
               df(3)=(dfdM1*ee1+dfdM2*ee2)/(xflow)
c               df(3)=(dfdM1*ee1+dfdM2*ee2)/(inv*xflow)
!
!              pressure node2
!
               df(4)=-dfdM2*ee2/pt2
!
!              temperature node2
!
               df(5)=dfdM2*ee2/(2.d0*Tt2)
!
            else
!
!              residual
!
               f=(1.d0/Z1-kappa)/kappa+dlog(kappa*Z1)-lld
!
!              pressure node1
!
               df(1)=-dfdM1*ee1/pt1
!
!              temperature node1
!
               df(2)=dfdM1*ee1/(2.d0*Tt1)
!
!              mass flow
!
               df(3)=dfdM1*ee1/(xflow)
c               df(3)=dfdM1*ee1/(inv*xflow)
!
!              pressure node2
!
               df(4)=0.d0
!
!              temperature node2
!
               df(5)=0.d0
!
            endif
         endif
!
!     output
!
      elseif(iflag.eq.3) then
!
         pi=4.d0*datan(1.d0)
!
         kappa=(cp/(cp-r))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         km1d2k=km1/(2.d0*kappa)
!
         index=ielprop(nelem)
         A=prop(index+1)
         d=prop(index+2)
         l=prop(index+3)
!
         lambda=0.5d0
!
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPFA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPFI') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=nint(prop(index+7))
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(pt1.gt.pt2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)-physcon(1)
            call ts_calc(xflow,Tt1,pt1,kappa,r,A,T1,icase)
            if(icase.eq.0) then
               Tt2=Tt1
            else
               T2=T1
            endif
!
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node2)-physcon(1)
            call ts_calc(xflow,Tt1,pt1,kappa,r,A,T1,icase)
            if(icase.eq.0) then
               Tt2=Tt1
            else
               T2=T1
            endif
!
         endif
!
         pt2zpt1=pt2/pt1
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1d-30) then
            write(*,*) '*ERROR in gaspipe_fanno: '
            write(*,*) '       no dynamic viscosity defined'
            write(*,*) '       dvi= ',dvi
            call exit(201)
         endif
!
         reynolds=dabs(xflow)*d/(dvi*A)
!
        if(reynolds.lt.1.d0) then
            reynolds= 1.d0
         endif
!
!     definition of the friction coefficient for 2 phase flows and pure air
!
         if(xflow_oil.ne.0d0) then
            call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &           xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &           v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &           shcon,rhcon,ntmat_,mi)
            lambda=lambda*phi
!
!     for pure air
!
         else
            phi=1.d0
            call friction_coefficient(l,d,ks,reynolds,form_fact,
     &           lambda)
         endif
!
         call pt2zpt1_crit(pt2,pt1,Tt1,lambda,kappa,r,l,d,
     &        pt2zpt1_c,Qred1_crit,crit,icase,M1_c)
!
!     definition of the coefficients
!
         M1=dsqrt(2/km1*((Tt1/T1)-1))
         if(crit) then
            if(icase.eq.0) then
               M2=1.d0
               T2=2.d0*Tt2/kp1
            else
               M2=1.d0/dsqrt(kappa)
               Tt2=T2*(1.d0+km1d2k)
            endif
         else
            if(icase.eq.0) then
               call ts_calc(xflow,Tt2,pt2,kappa,r,A,T2,icase)
            else
               Tt2=v(0,node2)-physcon(1)
               call tt_calc(xflow,Tt2,pt2,kappa,r,A,T2,icase)
            endif
            M2=dsqrt(2/km1*((Tt2/T2)-1))
         endif
!
         write(1,*) ''
         write(1,55) ' from node ',node1,
     &           ' to node ', node2,':   air massflow rate = ',xflow,
     &           ' , oil massflow rate = ',xflow_oil
!
         if(inv.eq.1) then
            write(1,53)'       Inlet node ',node1,' :    Tt1 = ',Tt1,
     &              ' , Ts1 = ',T1,'  , Pt1 = ',pt1,
     &              ' , M1 = ',M1
            write(1,*)'             Element ',nelem,lakon(nelem)
            write(1,57)'             dvi = ',dvi,' , Re = '
     &              ,reynolds
            write(1,58)'             PHI = ',phi,' , LAMBDA = ',
     &              lambda,
     &              ', LAMBDA*l/d = ',lambda*l/d,' , ZETA_PHI = ',
     &              phi*lambda*l/d
            write(1,53)'      Outlet node ',node2,' :    Tt2 = ',
     &              Tt2,
     &              ' , Ts2 = ',T2,'  , Pt2 = ',pt2,
     &              ' , M2 = ',M2
!
         else if(inv.eq.-1) then
            write(1,53)'       Inlet node ',node2,':    Tt1= ',Tt1,
     &              ' , Ts1= ',T1,' , Pt1= ',pt1,
     &              ' , M1= ',M1
            write(1,*)'             Element ',nelem,lakon(nelem)
            write(1,57)'             dvi = ',dvi,' , Re = '
     &              ,reynolds
            write(1,58)'             PHI = ',phi,' , LAMBDA = ',
     &              lambda,
     &              ', LAMBDA*l/d = ',lambda*l/d,' , ZETA_PHI = ',
     &              phi*lambda*l/d
            write(1,53)'      Outlet node ',node1,' :    Tt2 = ',
     &              Tt2,
     &              ' , Ts2 = ',T2,'  , Pt2 =',pt2,
     &              ' , M2 = ',M2
         endif
      endif
!
 55   format(1X,a,i6,a,i6,a,e11.4,a,e11.4)
 53   format(1X,a,i6,a,e11.4,a,e11.4,a,e11.4,a,e11.4)
 57   format(1X,a,e11.4,a,e11.4)
 58   format(1X,a,e11.4,a,e11.4,a,e11.4,a,e11.4)
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


      subroutine e3source(xx, src)
c-----------------------------------------------------------------------
c
c  this routine computes the body force term.
c
c  currently this computes a swirl body with the axis alligned with
c  the z-coordinate
c
c-----------------------------------------------------------------------

      include "common.h"

      real*8   xx(npro,nsd), src(npro,nsd)

      real*8   nu

      real*8   r, Stheta, dpdz, rP5
      if(datmat(2,5,1).eq. 0) then  ! calc swirl
c
c  This is the body force which will drive a swirl in a pipe flow
c
         bigR    = 0.5d0
         dpdz    = datmat(1,5,1)
         do iel = 1, npro

            r   = sqrt( xx(iel,1)**2 + xx(iel,2)**2)
            rP5 = (r/bigR)**5

            Stheta = dpdz * sin(0.5*pi*rP5)

            src(iel,1) = -xx(iel,2)/r * Stheta
            src(iel,2) =  xx(iel,1)/r * Stheta
            src(iel,3) =  dpdz
         enddo
      else  ! contrived test problem

c$$$         nu=datmat(1,2,1)
c$$$         omag=datmat(3,5,1) ! frame rotation rate
c$$$         e1 = one/sqrt(3.0d0) ! axis of rotation
c$$$         e2 = e1
c$$$         e3 = e1
c$$$         om1=omag*e1
c$$$         om2=omag*e2
c$$$         om3=omag*e3
c$$$         w=0
c$$$
c$$$         do iel = 1, npro
c$$$
c$$$            x = xx(iel,1)
c$$$            y = xx(iel,2)
c$$$            z = xx(iel,3)
c$$$
c$$$c
c$$$c  The following are MAPLE generated forcing functions for
c$$$c  a contrived flow in a rotating reference frame.
c$$$c
c$$$
c$$$      t1 = x**2
c$$$      t2 = t1**2
c$$$      t5 = dexp(14.D0*x)
c$$$      t6 = t2*x*t5
c$$$      t7 = y**2
c$$$      t8 = t7**2
c$$$      t9 = t8*t7
c$$$      t12 = t2*t5
c$$$      t15 = nu*t1
c$$$      t17 = dexp(7.D0*x)
c$$$      t18 = t7*y
c$$$      t19 = t17*t18
c$$$      t22 = t1*x
c$$$      t23 = nu*t22
c$$$      t24 = t17*y
c$$$      t29 = t17*t7
c$$$      t34 = nu*x
c$$$      t43 = nu*t2
c$$$      t46 = -40.D0*t6*t9-6.D0*t12*t7+92.D0*t15*t19+132.D0*t23*t24+80.D0*
c$$$     #t6*t18-252.D0*t23*t29+168.D0*t23*t19+96.D0*t34*t29-64.D0*t34*t19+2
c$$$     #2.D0*t15*t24-138.D0*t15*t29+294.D0*t43*t29
c$$$      t50 = t2*t22*t5
c$$$      t57 = nu*t17
c$$$      t60 = t8*y
c$$$      t65 = t2**2
c$$$      t66 = t65*t5
c$$$      t73 = t22*t5
c$$$      t77 = t2*t1*t5
c$$$      t80 = -196.D0*t43*t19-96.D0*t50*t9-122.D0*t43*t24-32.D0*t34*t24-4.
c$$$     #D0*t57*y+36.D0*t12*t60+192.D0*t50*t18+98.D0*t66*t8+24.D0*t12*t18+2
c$$$     #8.D0*t66*t9-24.D0*t73*t60-336.D0*t77*t60
c$$$      t106 = -336.D0*t50*t8-12.D0*t12*t9+8.D0*t73*t9-140.D0*t6*t8+28.D0*
c$$$     #t73*t8+12.D0*t15*t17+12.D0*t43*t17+288.D0*t50*t60+112.D0*t77*t9-22
c$$$     #4.D0*t77*t18-56.D0*t66*t18+120.D0*t6*t60
c$$$      t131 = -8.D0*t57*t18-20.D0*t6*t7+56.D0*t77*t7-42.D0*t12*t8-24.D0*t
c$$$     #23*t17-48.D0*t50*t7+4.D0*t73*t7-16.D0*t73*t18+392.D0*t77*t8+14.D0*
c$$$     #t66*t7-84.D0*t66*t60+12.D0*t57*t7
c$$$      fx = t46+t80+t106+t131
c$$$
c$$$
c$$$      t1 = x**2
c$$$      t2 = t1**2
c$$$      t3 = nu*t2
c$$$      t5 = dexp(7.D0*x)
c$$$      t6 = t5*y
c$$$      t9 = y**2
c$$$      t10 = t9**2
c$$$      t11 = nu*t10
c$$$      t18 = t1*x
c$$$      t22 = nu*x
c$$$      t25 = nu*t18
c$$$      t32 = dexp(14.D0*x)
c$$$      t33 = t2*t32
c$$$      t39 = t2*t1*t32
c$$$      t40 = t10*t9
c$$$      t43 = t1*t32
c$$$      t46 = t9*y
c$$$      t47 = t10*t46
c$$$      t50 = -84.D0*t3*t6+343.D0*t11*t5*t2+66.D0*t11*t5*x-98.D0*t11*t5*t1
c$$$     #8-24.D0*t22*t6+120.D0*t25*t6-287.D0*t11*t5*t1-140.D0*t33*t10+14.D0
c$$$     #*t3*t5-56.D0*t39*t40-28.D0*t43*t40+8.D0*t43*t47
c$$$      t52 = t2*x*t32
c$$$      t55 = t18*t32
c$$$      t62 = t10*y
c$$$      t69 = nu*t5
c$$$      t80 = 120.D0*t52*t10-32.D0*t55*t47+56.D0*t33*t47+30.D0*t11*t5-216.
c$$$     #D0*t52*t62-144.D0*t55*t62+72.D0*t39*t62-60.D0*t69*t46+30.D0*t69*t9
c$$$     #-20.D0*t25*t5-20.D0*t43*t10+36.D0*t43*t62
c$$$      t86 = nu*t1
c$$$      t89 = t5*t9
c$$$      t92 = t5*t46
c$$$      t109 = 112.D0*t55*t40+80.D0*t55*t10-12.D0*t86*t6-275.D0*t86*t89+57
c$$$     #4.D0*t86*t92-218.D0*t25*t89+196.D0*t25*t92+90.D0*t22*t89-132.D0*t2
c$$$     #2*t92+427.D0*t3*t89+8.D0*t39*t46+4.D0*t43*t46
c$$$      t134 = 16.D0*t39*t47+28.D0*t33*t46-48.D0*t52*t47+252.D0*t33*t62+16
c$$$     #8.D0*t52*t40-24.D0*t52*t46-686.D0*t3*t92+2.D0*t86*t5-40.D0*t39*t10
c$$$     #-196.D0*t33*t40-16.D0*t55*t46+4.D0*t22*t5
c$$$      fy = t50+t80+t109+t134
c$$$
c$$$
c$$$      t3 = om3*x
c$$$      t5 = dexp(7.D0*x)
c$$$      t7 = x**2
c$$$      t12 = y**2
c$$$      t15 = (-1.D0+y)**2
c$$$      fxa = 2.D0*om2*w+2.D0*t3*t5*(2.D0+x-10.D0*t7+7.D0*t7*x)*t12*t15+om
c$$$     #2*(om1*y-om2*x)-om3*(t3-om1*z)
c$$$
c$$$      t1 = x**2
c$$$      t4 = (-1.D0+x)**2
c$$$      t7 = dexp(7.D0*x)
c$$$      t10 = y**2
c$$$      fya = 4.D0*om3*t1*t4*t7*y*(1.D0-3.D0*y+2.D0*t10)-2.D0*om1*w+om3*(o
c$$$     #m2*z-om3*y)-om1*(om1*y-om2*x)
c$$$
c$$$
c$$$      t3 = dexp(7.D0*x)
c$$$      t5 = x**2
c$$$      t10 = y**2
c$$$      t13 = (-1.D0+y)**2
c$$$      t19 = (-1.D0+x)**2
c$$$      fza = -2.D0*om1*x*t3*(2.D0+x-10.D0*t5+7.D0*t5*x)*t10*t13-4.D0*om2*
c$$$     #t5*t19*t3*y*(1.D0-3.D0*y+2.D0*t10)+om1*(om3*x-om1*z)-om2*(om2*z-om
c$$$     #3*y)
c$$$
c$$$      src(iel,1) =  fx + fxa
c$$$      src(iel,2) =  fy + fya
c$$$      src(iel,3) =       fza
c$$$      enddo
!Analytic lid case

      do iel = 1, npro
            x = xx(iel,1)
            y = xx(iel,2)
            z = xx(iel,3)
            Re = 1.0/datmat(1,2,1)
c
c  The following are MAPLE generated forcing functions for
c  a Lid Driven cavity flow with an analytic solution
c
            t2 = x**2
            t3 = t2**2
            t4 = t3*x
            t7 = t2*x
            t8 = 8*t7
            t13 = y**2
            t20 = t13**2
            t21 = t20-t13
            t26 = t3**2
            t30 = t3*t2
            t37 = t13*y
            t54 = -8/Re*(24.E0/5.E0*t4-12*t3+t8+2*(4*t7-6*t2+2*x)*(12
     &           *t13-2)+(24*x-12)*t21)-64*(t26/2-2*t3*t7+3*t30-2*t4+t3
     &           /2)*(-24*t20*y+8*t37-4*y)+64*t21*(4*t37-2*y)*(-4*t30+12
     &           *t4-14*t3+t8-2*t2)

            src(iel,1) = 0.0
            src(iel,2) = t54
            src(iel,3) = 0.0
         enddo

      endif
      return
      end

!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!******************************************************************
!-------------------------------------------------------------------

      subroutine e3sourceSclr ( Sclr,      Sdot,      gradS,
     &                          dwl,       shape_funct,     shg,
     &                          yl,        dxidx,     rmu,
     &                          u1,        u2,        u3,   xl,
     &                          srcR,      srcL,      uMod,
     &                          srcRat)

c-----------------------------------------------------------------------
c
c     calculate the coefficients for the Spalart-Allmaras
c     turbulence model and its jacobian
c
c     input:
c             Sclr  :   The scalar that is being transported in this pde.
c             gradS :   spatial gradient of Sclr
c             rmu   :   kinematic viscosity
c
c     output:
c             rmu   :   diffusion for eddy viscosity equation
c             srcR  :   residual terms for
c                         (srcR * turb)
c             srcL :   jacobian of srcR
c
c-----------------------------------------------------------------------
      use     turbSA
      use turbKE
      include "common.h"
c coming in
      real*8  Sclr(npro),          Sdot(npro),
     &        gradS(npro,nsd),     dwl(npro,nenl),
     &        shape_funct(npro,nshl),    shg(npro,nshl,nsd),
     &        yl(npro,nshl,ndof),  dxidx(npro,nsd,nsd),
     &        rmu(npro),           u1(npro),
     &        u2(npro),            u3(npro),
     &        xl(npro,nenl,nsd)
c going out
      real*8  srcR(npro),          srcL(npro),
     &        uMod(npro,nsd)
c used locally

      real*8  gradV(npro,nsd,nsd), absVort(npro),
     &        dwall(npro)
      real*8  chi,    chiP3,   fv1,   fv2,     st,    r,
     &        g,      fw,      s,     viscInv, k2d2Inv,
     &        dP2Inv, sixth,   tmp,   tmp1,    p,     dp,
     &        fv1p,   fv2p,    stp,         gp,      fwp,   rp,
     &        chiP2,  mytmp(npro),         sign_levelset(npro),
     &        sclr_ls(npro)
!MR CHANGE
      real*8  SclrNN,qfac,dx,dy,dz,dmax
      real*8  rd,fd,dwallsqqfact,ep
!MRCHANGE
c    Kay-Epsilon
      real*8 Ry(npro), Rt(npro), RtP2(npro), f2(npro), f1(npro),
     &       kay(npro), epsilon(npro), fmu(npro), fmui(npro),
     &       srcjac(npro,4), srcRat(npro)
      integer e,n
c----------------------------------------------------------------------
c
c           --             --              --           --
c           |      cb2      |           1  |             |
c   phi,  + |u  - -----phi, | phi,  - -----|(nu+phi)phi, |
c       t   | i   sigma    i|     i   sigma|            i|
c           --             --              --           --,
c                                                          i
c
c                  ~              phi^2
c            - cb1*S*phi + cw1*fw*-----
c                                  d^2
c
c----------------------------------------------------------------------
c
      if(iRANS.eq.-1) then    ! spalart almaras model
c
c.... compute the global gradient of u
c
         gradV = zero
         do n = 1, nshl
c
c          du_i/dx_j
c
c           i j   indices match array where V is the velocity (u in our notes)
            gradV(:,1,1) = gradV(:,1,1) + shg(:,n,1) * yl(:,n,2)
            gradV(:,2,1) = gradV(:,2,1) + shg(:,n,1) * yl(:,n,3)
            gradV(:,3,1) = gradV(:,3,1) + shg(:,n,1) * yl(:,n,4)
c
            gradV(:,1,2) = gradV(:,1,2) + shg(:,n,2) * yl(:,n,2)
            gradV(:,2,2) = gradV(:,2,2) + shg(:,n,2) * yl(:,n,3)
            gradV(:,3,2) = gradV(:,3,2) + shg(:,n,2) * yl(:,n,4)
c
            gradV(:,1,3) = gradV(:,1,3) + shg(:,n,3) * yl(:,n,2)
            gradV(:,2,3) = gradV(:,2,3) + shg(:,n,3) * yl(:,n,3)
            gradV(:,3,3) = gradV(:,3,3) + shg(:,n,3) * yl(:,n,4)
c                                             a j     u   a i
c from our notes where we had N_{a,j} = dN_a/dx_j  note that i is off by one because p was first in yl vector
c
         enddo
c
c.... magnitude of vorticity
c
         absVort  = sqrt( (gradV(:,2,3) - gradV(:,3,2)) ** 2
     &                  + (gradV(:,3,1) - gradV(:,1,3)) ** 2
     &                  + (gradV(:,1,2) - gradV(:,2,1)) ** 2 )
         dwall = zero
         do n = 1, nenl
            dwall     = dwall + shape_funct(:,n) * dwl(:,n)
         enddo

         sixth   = 1.0/6.0
c
c.... compute source and its jacobian
c
         do e = 1, npro
            SclrNN= max(Sclr(e),zero)
c trip after the plane x-z=-1
c           if((xl(e,1,1)-xl(e,1,3)-0.1) .lt. zero) SclrNN=zero
c trip after the plane whose normal is (0.8660254;0;0.5) and origin is (0.19551661;0;-0.28607881)
c namely 0.8660254x+0.5z-0.0262829=0
c            if((0.8660254*xl(e,1,1)+0.5*xl(e,1,3)-0.0262829) .lt. zero)
c     &              SclrNN=zero
!            if((0.86230254*xl(e,1,1)-0.0842707*xl(e,1,2)
!               +0.49933235*xl(e,1,3)-0.0260094) .lt. zero)

!2W downstream
!            if((0.86230254*xl(e,1,1)-0.0842707*xl(e,1,2)
!     &         +0.49933235*xl(e,1,3)-0.0298618) .lt. zero)
!     &                  SclrNN=zero

!DDES upstream
!            if((0.86230254*xl(e,1,1)-0.0842707*xl(e,1,2)
!     &         +0.49933235*xl(e,1,3)+0.03658399) .lt. zero)
!     &                  SclrNN=zero

            if(iles.lt.0) then     ! for DES97 or DDES

               dx=maxval(xl(e,:,1))-minval(xl(e,:,1))
               dy=maxval(xl(e,:,2))-minval(xl(e,:,2))
               dz=maxval(xl(e,:,3))-minval(xl(e,:,3))
               dmax=max(dx,max(dy,dz))
               dmax=0.325*dmax

               if(iles .eq. -1) then  ! Original  DES97
                 dwall(e) = min(dmax,dwall(e))

               elseif(iles .eq. -2) then ! DDES

                 qfac = sqrt(
     &                gradV(e,1,1)**2+gradV(e,1,2)**2+gradV(e,1,3)**2
     &              + gradV(e,2,1)**2+gradV(e,2,2)**2+gradV(e,2,3)**2
     &              + gradV(e,3,1)**2+gradV(e,3,2)**2+gradV(e,3,3)**2 )

                 ! The following lines fix an issue when all vertices on
                 ! an element are located on a wall with no-slip wall
                 ! conditions imposed, which lead to a divistion by 0

                 !rd=SclrNN*saKappaP2Inv/(dwall(e)**2*qfac)
                 dwallsqqfact = max(dwall(e)**2*qfac,1.0d-12)
                 rd = SclrNN*saKappaP2Inv/dwallsqqfact
                 fd = one-tanh((8.0000000000000000d0*rd)**3)
                 dwall(e) = dwall(e)-fd*max(zero,dwall(e)-dmax)

               endif

            endif ! if (iles .lt.0)

            if (dwall(e) .ne. 0) dP2Inv = 1.0 / dwall(e)**2

            k2d2Inv = dP2Inv * saKappaP2Inv

            viscInv = 1.0/datmat(1,2,1)
            chi     = SclrNN * viscInv !skipping the kiy kie for now
            chiP2   = chi * chi
            chiP3   = chi * chiP2

            ep=zero
            if(Sclr(e).gt.zero) ep=one

            tmp     = 1.0 / ( chiP3 + saCv1P3 )
            fv1     = chiP3 * tmp
            fv1p    = 3.0 * viscInv * saCv1P3 * chiP2 * tmp**2

            tmp     = 1.0 / (1.0 + chi * fv1)
            fv2     = 1.0 - chi * tmp
            fv2p    = (chiP2 * fv1p - viscInv) * tmp**2

            s       = absVort(e) !prd(e,2)
            tmp     = SclrNN * k2d2Inv !eOkdP2
            st      = s + fv2 * tmp
            stp     = ep*k2d2Inv * fv2 + tmp*fv2p

            r       = zero
            rp      = zero
            if (st .gt. epsM ) then
                r = tmp / st
                r       = min( max(r, -8.0d0), 8.0d0)
                rp = k2d2Inv / st**2 * (ep*st - SclrNN*stp)
            endif
            rP5     = r * (r * r) ** 2
            tmp     = 1.0 + saCw2 * (rP5 - 1.0)
            g       = r * tmp
            gp      = rp * (tmp + 5.0 * saCw2 * rP5)

            gP6     = (g * g * g) ** 2
            tmp     = 1.0 / (gP6 + saCw3P6)
            tmp1    = ( (1.0 + saCw3P6) * tmp ) ** sixth
            fw      = g * tmp1
            fwp     = gp * tmp1 * saCw3P6 * tmp
            if(abs(r).gt.7.0d0) fwp=zero

            tmp1     = saCw1 * dP2Inv*SclrNN
            prat     = ep*saCb1*st  !prodRat
            srcRat(e)= prat - ep*fw * tmp1

            tmp     = zero
            if(prat .lt. zero) tmp=prat
            if(stp .lt. zero) tmp=tmp+SaCb1*stp*SclrNN
            if(fw   .gt. zero) tmp=tmp-two*tmp1*fw
            if(fwp  .gt. zero) tmp=tmp-tmp1*SclrNN*fwp

            srcL(e)  = -1.0*tmp
            srcR(e)   = srcRat(e)*SclrNN
         enddo
c
c.... One source term has the form (beta_i)*(phi,_i).  Since
c     the convective term has (u_i)*(phi,_i), it is useful to treat
c     beta_i as a "correction" to the velocity.  In calculating the
c     stabilization terms, the new "modified" velocity (u_i-beta_i) is
c     then used in place of the pure velocity for stabilization terms,
c     and the source term sneaks into the RHS and LHS.  Here, the term
c     is given by beta_i=(cb_2)*(phi,_i)/(sigma)
c

         tmp = saCb2 * saSigmaInv
         uMod(:,1) = u1(:) - tmp * gradS(:,1)
         uMod(:,2) = u2(:) - tmp * gradS(:,2)
         uMod(:,3) = u3(:) - tmp * gradS(:,3)

      elseif(iRANS.eq.-2) then    ! K-epsilon
c.... compute the global gradient of u
c
         gradV = zero
         do n = 1, nshl
c
c          du_i/dx_j
c
c           i j   indices match array where V is the velocity (u in our notes)
            gradV(:,1,1) = gradV(:,1,1) + shg(:,n,1) * yl(:,n,2)
            gradV(:,2,1) = gradV(:,2,1) + shg(:,n,1) * yl(:,n,3)
            gradV(:,3,1) = gradV(:,3,1) + shg(:,n,1) * yl(:,n,4)
c
            gradV(:,1,2) = gradV(:,1,2) + shg(:,n,2) * yl(:,n,2)
            gradV(:,2,2) = gradV(:,2,2) + shg(:,n,2) * yl(:,n,3)
            gradV(:,3,2) = gradV(:,3,2) + shg(:,n,2) * yl(:,n,4)
c
            gradV(:,1,3) = gradV(:,1,3) + shg(:,n,3) * yl(:,n,2)
            gradV(:,2,3) = gradV(:,2,3) + shg(:,n,3) * yl(:,n,3)
            gradV(:,3,3) = gradV(:,3,3) + shg(:,n,3) * yl(:,n,4)
c                                             a j     u   a i
c from our notes where we had N_{a,j} = dN_a/dx_j  note that i is off by one because p was first in yl vector
c
         enddo

         dwall = zero
         do n = 1, nenl
            dwall     = dwall + shape_funct(:,n) * dwl(:,n)
         enddo

         kay(:)=zero
         epsilon(:)=zero
         do ii=1,npro
            do jj = 1, nshl
               kay(ii) =  kay(ii) + shape_funct(ii,jj) * yl(ii,jj,6)
               epsilon(ii) =  epsilon(ii)
     &              + shape_funct(ii,jj) * yl(ii,jj,7)
            enddo
         enddo
c        no source term in the LHS yet
         srcL(:)=zero

         call elm3keps   (kay,     epsilon,
     &                    dwall,   gradV,
     &                    srcRat,  srcR,     srcJac)
         if(isclr.eq.1) srcL = srcJac(:,1)
         if(isclr.eq.2) srcL = srcJac(:,4)
         iadvdiff=0 ! scalar advection-diffusion flag
         if(iadvdiff.eq.1)then
            srcL(:)=zero
            srcR(:)=zero
            srcRat(:)=zero
         endif
c
c.... No source terms with the form (beta_i)*(phi,_i) for K or E
c
         uMod(:,1) = u1(:) - zero
         uMod(:,2) = u2(:) - zero
         uMod(:,3) = u3(:) - zero

      elseif (iLSet.ne.0) then
         if (isclr.eq.1)  then

            srcR = zero
            srcL = zero

         elseif (isclr.eq.2) then !we are redistancing level-sets

CAD   If Sclr(:,1).gt.zero, result of sign_term function 1
CAD   If Sclr(:,1).eq.zero, result of sign_term function 0
CAD   If Sclr(:,1).lt.zero, result of sign_term function -1

            sclr_ls = zero      !zero out temp variable

            do ii=1,npro

               do jj = 1, nshl  ! first find the value of levelset at point ii

                  sclr_ls(ii) =  sclr_ls(ii)
     &                        + shape_funct(ii,jj) * yl(ii,jj,6)

               enddo

               if (sclr_ls(ii) .gt. epsilon_ls)then

                  sign_levelset(ii) = one

               elseif  (abs(sclr_ls(ii)) .le. epsilon_ls)then

                  sign_levelset(ii) = sclr_ls(ii)/epsilon_ls
     &                  + sin(pi*sclr_ls(ii)/epsilon_ls)/pi

               elseif (sclr_ls(ii) .lt. epsilon_ls) then

                  sign_levelset(ii) = - one

               endif

               srcR(ii) = sign_levelset(ii)

            enddo

            srcL =  zero

cad   The redistancing equation can be written in the following form
cad
cad   d_{,t} + sign(phi)*( d_{,i}/|d_{,i}| )* d_{,i} = sign(phi)
cad
cad   This is rewritten in the form
cad
cad   d_{,t} + u * d_{,i} = sign(phi)
cad

CAD   For the redistancing equation the "velocity" term is calculated as
CAD   follows

            mytmp = sign_levelset / sqrt( gradS(:,1)*gradS(:,1)
     &                            + gradS(:,2)*gradS(:,2)
     &                            + gradS(:,3)*gradS(:,3))

            uMod(:,1) = mytmp * gradS(:,1) ! These are for the LHS
            uMod(:,2) = mytmp * gradS(:,2)
            uMod(:,3) = mytmp * gradS(:,3)

            u1 = umod(:,1)      ! These are for the RHS
            u2 = umod(:,2)
            u3 = umod(:,3)

         endif    ! close of scalar 2 of level set

      else        ! NOT turbulence and NOT level set so this is a simple
                  ! scalar. If your scalar equation has a source term
                  ! then add your own like the above but leave an unforced case
                  ! as an option like you see here

         srcR = zero
         srcL = zero
      endif

      return
      end


  function geta (alev, e, iz, in, is)

! ======================================================================
!
! ***************This routine was originally in the LAHET code**********
!  GETA
!      Calculate level density parameter
! ======================================================================
! <variables>
!     iz   :   charge  of nucleus                                 (IN)
!     in   :   neutron number of nucleus                          (IN)
!     e    :   excitation energy of nucleus                       (IN)
! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, September, 2003.
!    Modified by K. K. Gudima, November, 2004.
!    Edited by A. J. Sierk, January, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams,      only: zro, one, eighth
    use evaporationFissionData, only: inn, iiz, aMax, isn, isz, &
         & amean, con, paire0, st0, &
         & levelDensityGCCIFlag, levelDensitySpecFlag

    implicit none
    real(real64),   intent(in   ) :: alev
    real(real64),   intent(in   ) :: e
    integer(int32), intent(in   ) :: iz
    integer(int32), intent(in   ) :: in
    integer(int32), intent(  out) :: is
    real(real64)                  :: geta

    integer(int32) :: ia, ia0
    real(real64)   :: aa, deldel, fa, fu, gu, u

! ======================================================================

    real(real64), parameter, dimension(aMax) :: fa0 = &
       & [   ( (eighth),               ia0 =   1,  25), &
       &     ( (amean(ia0)/dble(ia0)), ia0 =  26, 240), &
       &     ( ((amean(240) + (2.5d0 - 0.1d0*amean(240))* &
       &        (dble(ia0) - 240.d0))/dble(ia0) &
       &                        ),     ia0 = 241, aMax)   ]

! ======================================================================

    ia = in + iz
    aa = dble(ia)
    if (alev /= levelDensityGCCIFlag) then
!   a = A/a0 ...simple level density parameter:
       if ( alev == levelDensitySpecFlag ) then
          geta = aa*eighth
       else
          geta = aa/alev
       endif
       return
    endif

! Gilbert-Cameron-Cook-Ignatyuk (GCCI) level density parameter:
    if (iz > iiz .or. in > inn) then
       geta = aa*eighth
       return
    endif
    if (in >= 9 .and. iz >= 9) then
       if (isz(iz).or.isn(in)) then
          is = 2
       else
          is = 1
       endif
       fa = (9.17d-3*st0(iz,in) + con(is))
    else
       fa = fa0(ia)
    endif

    deldel = paire0(iz, in)
    u = max(5.d-2*(e - deldel), 1.d-5)
    fu = exp(-u)
    gu = (one - fu)/u
    geta = aa*(fa*gu + (one - gu)*(0.1375d0 - 8.36d-5*aa))

    return
! ======================================================================
  end function geta


      subroutine tauint2(xp,yp,zp,nxp,nyp,nzp,xmax,ymax,zmax,
     +                  xface,yface,zface,rhokap,
     +                  xcell,ycell,zcell,tflag,iseed,delta)

      implicit none

      include 'grid.txt'

      integer tflag,iseed,xcell,ycell,zcell
      real*8 xp,yp,zp,nxp,nyp,nzp,xmax,ymax,zmax
      real ran2

      integer celli,cellj,cellk
      real*8 tau,taurun,taucell,d,d1,dcell,xcur,ycur,zcur,dsx,dsy,dsz
      real*8 dx,dy,dz,smax,delta

c***** tflag=0 means photon is in envelope
      tflag=0

c**** generate random optical depth tau
      tau=-alog(ran2(iseed))

c***** set the cumulative distance and optical depth (d and taurun)
c***** along the photon path to zero.  set the current photon coordinates.
c***** note that the origin of the (xcur,ycur,zcur) system is at the
c***** bottom corner of the grid.
      taurun=0.
      d=0.
      xcur=xp+xmax
      ycur=yp+ymax
      zcur=zp+zmax

      celli=xcell
      cellj=ycell
      cellk=zcell

c***** calculate smax -- maximum distance photon can travel
      if(nxp.gt.0.) then
         dsx=(2.*xmax-xcur)/nxp
      elseif(nxp.lt.0.) then
         dsx=-xcur/nxp
      elseif(nxp.eq.0.) then
         dsx=1.e2*xmax
      endif

      if(nyp.gt.0.) then
         dsy=(2.*ymax-ycur)/nyp
      elseif(nyp.lt.0.) then
         dsy=-ycur/nyp
      elseif(nyp.eq.0.) then
         dsy=1.e2*ymax
      endif

      if(nzp.gt.0.) then
         dsz=(2.*zmax-zcur)/nzp
      elseif(nzp.lt.0.) then
         dsz=-zcur/nzp
      elseif(nzp.eq.0.) then
         dsz=1.e2*zmax
      endif

      smax=amin1(dsx,dsy,dsz)
      if(smax.lt.delta) then
         tflag=1
         return
      endif

c***** integrate through grid
      dowhile((taurun.lt.tau).and.(d.lt.(.999*smax)))

c***** find distance to next x, y, and z cell walls.
c***** note that dx is not the x-distance, but the actual distance along
c*****the direction of travel to the next x-face, and likewise for dy and dz.
         if(nxp.gt.0.) then
            dx=(xface(celli+1)-xcur)/nxp
            if(dx.lt.delta) then
               xcur=xface(celli+1)
               celli=celli+1
               dx=(xface(celli+1)-xcur)/nxp
            endif
         elseif(nxp.lt.0.) then
            dx=(xface(celli)-xcur)/nxp
            if(dx.lt.delta) then
               xcur=xface(celli)
               dx=(xface(celli-1)-xcur)/nxp
               celli=celli-1
            endif
         elseif(nxp.eq.0.) then
            dx=1.e2*xmax
         endif

         if(nyp.gt.0.) then
            dy=(yface(cellj+1)-ycur)/nyp
            if(dy.lt.delta) then
               ycur=yface(cellj+1)
               cellj=cellj+1
               dy=(yface(cellj+1)-ycur)/nyp
            endif
         elseif(nyp.lt.0.) then
            dy=(yface(cellj)-ycur)/nyp
            if(dy.lt.delta) then
               ycur=yface(cellj)
               dy=(yface(cellj-1)-ycur)/nyp
               cellj=cellj-1
            endif
         elseif(nyp.eq.0.) then
            dy=1.e2*ymax
         endif

         if(nzp.gt.0.) then
            dz=(zface(cellk+1)-zcur)/nzp
            if(dz.lt.delta) then
               zcur=zface(cellk+1)
               cellk=cellk+1
               dz=(zface(cellk+1)-zcur)/nzp
            endif
         elseif(nzp.lt.0.) then
            dz=(zface(cellk)-zcur)/nzp
            if(dz.lt.delta) then
               zcur=zface(cellk)
               dz=(zface(cellk-1)-zcur)/nzp
               cellk=cellk-1
            endif
         elseif(nzp.eq.0.) then
            dz=1.e2*zmax
         endif

      if((celli.gt.nxg).or.(celli.lt.0)) print*,'celli',celli,xcur
      if((cellj.gt.nyg).or.(cellj.lt.0)) print*,'celli',cellj,ycur
      if((cellk.gt.nyg).or.(cellk.lt.0)) print*,'celli',cellk,zcur

c***** distances are only zero if photon is on cell wall.  if it is
c***** on cell wall then set to arbitrary large distance, since we will
c***** in fact hit another wall

c******* THIS USED TO BE (dx.eq.0.)

         if( (dx.eq.0.) .or. ((abs(dx)).lt.(delta)) ) dx=1.e2*xmax
         if( (dy.eq.0.) .or. ((abs(dy)).lt.(delta)) ) dy=1.e2*ymax
         if( (dz.eq.0.) .or. ((abs(dz)).lt.(delta)) ) dz=1.e2*zmax

c***** find distance to next cell wall -- minimum of dx, dy, and dz
         dcell=amin1(dx,dy,dz)
         if(dcell.le.0.) then
            print *,'tauint2: dcell < 0',dx,dy,dz,nxp,nyp,nzp
            print *,xcur,ycur,zcur,celli,cellj,cellk
         endif
         if(dx.lt.0.) dcell=amin1(dy,dz)
         if(dy.lt.0.) dcell=amin1(dx,dz)
         if(dz.lt.0.) dcell=amin1(dx,dy)

c***** optical depth to next cell wall is
c***** taucell= (distance to cell)*(opacity of current cell)
         taucell=dcell*rhokap(celli,cellj,cellk)

c***** if taurun+taucell>tau then scatter at distance d+d1.
c***** update photon position and cell.
c***** if taurun+taucell<tau then photon moves distance dcell
c***** (i.e. ends up on next cell wall) and update photon position
c***** and cell.
         if((taurun+taucell).ge.tau) then
            d1=(tau-taurun)/rhokap(celli,cellj,cellk)
            d=d+d1
            taurun=taurun+taucell
            xcur=xcur+d1*nxp
            ycur=ycur+d1*nyp
            zcur=zcur+d1*nzp

c*************** Linear Grid ************************
            celli=int(nxg*xcur/(2.*xmax))+1
            cellj=int(nyg*ycur/(2.*ymax))+1
            cellk=int(nzg*zcur/(2.*zmax))+1
c****************************************************

         else

            d=d+dcell
            taurun=taurun+taucell
            xcur=xcur+dcell*nxp
            ycur=ycur+dcell*nyp
            zcur=zcur+dcell*nzp

c*************** Linear Grid ************************
            celli=int(nxg*xcur/(2.*xmax))+1
            cellj=int(nyg*ycur/(2.*ymax))+1
            cellk=int(nzg*zcur/(2.*zmax))+1
c****************************************************

          endif

      end do

c***** calculate photon final position.  if it escapes envelope then
c***** set tflag=1.  if photon doesn't escape leave tflag=0 and update
c***** photon position.
      if((d.ge.(.999*smax))) then
             tflag=1
      else
         xp=xp+d*nxp
         yp=yp+d*nyp
         zp=zp+d*nzp
         xcell=int(nxg*(xp+xmax)/(2.*xmax))+1
         ycell=int(nyg*(yp+ymax)/(2.*ymax))+1
         zcell=int(nzg*(zp+zmax)/(2.*zmax))+1
      endif

      return
      end