module Mod_MyRangeGiver
   use typre
   use Mod_Octree
   use Mod_Memor
   use Mod_LinkedList

   !This is a RangeGiver implementation
   type, extends(RangeGiver) :: MyRangeGiver

      integer(ip) :: npoinx, npoiny,npoinz

contains
      procedure :: GiveMeRange => MyGiveMeRange
      procedure :: Initialize
   end type

contains

   subroutine MyGiveMeRange(a,ielem,range)
      use typre
      implicit none
      class(MyRangeGiver) :: a
      integer(ip) :: ielem
      real(rp) :: range(*)

      integer(ip) :: auxipoin
      integer(ip) :: resultpoint(3)

      auxipoin = ielem
      resultpoint(3) = (auxipoin-1)/(a%npoinx*a%npoiny)+1
      auxipoin = auxipoin - (resultpoint(3)-1)*(a%npoinx*a%npoiny)
      resultpoint(2) = (auxipoin-1)/a%npoinx+1
      auxipoin = auxipoin - (resultpoint(2)-1)*a%npoinx
      resultpoint(1) = auxipoin

      range(1) = resultpoint(1)
      range(2) = resultpoint(1)+1
      range(3) = resultpoint(2)
      range(4) = resultpoint(2)+1
      range(5) = resultpoint(3)
      range(6) = resultpoint(3)+1
   end subroutine

   subroutine Initialize(a,npoinx,npoiny,npoinz)
      use typre
      implicit none
      class(MyRangeGiver) :: a
      integer(ip) :: npoinx, npoiny, npoinz

      a%npoinx = npoinx
      a%npoiny = npoiny
      a%npoinz = npoinz
   end subroutine

end module

subroutine Test_OctTree
   use typre
   use Mod_Octree
   use Mod_MyRangeGiver
   use Mod_LinkedList
   implicit none

   integer(ip) :: npoin
   integer(ip) :: npoinx = 5
   integer(ip) :: npoiny = 5
   integer(ip) :: npoinz = 5
   real(rp), pointer :: coord(:,:,:,:)

   type(Octree) :: MyTree
   type(MemoryMan) :: Memor

   integer(ip) :: ipoinx,ipoiny,ipoinz

   class(LinkedListHeader), pointer :: Head
   class(LinkedListStorage), pointer :: Store

   integer(ip) :: mypoint(3), resultpoint(3)
   integer(ip) :: maxpoin

   integer(ip) :: auxipoin
   integer(ip) :: check,foundpoin,idime,ipoin

   real(rp) :: time1,time2

   type(MyRangeGiver) :: MacGyver

   real(rp) :: range(2,3)

   !-----------------------------------------------------
   !Test Octree for points
   maxpoin = 1

   npoin = npoinx*npoiny*npoinz
   allocate(coord(3,npoinx,npoiny,npoinz))

   do ipoinx = 1,npoinx
      do ipoiny = 1,npoiny
         do ipoinz = 1,npoinz
            coord(1,ipoinx,ipoiny,ipoinz) = ipoinx
            coord(2,ipoinx,ipoiny,ipoinz) = ipoiny
            coord(3,ipoinx,ipoiny,ipoinz) = ipoinz
         enddo
      enddo
   enddo

   call cpu_time(time1)

   call MyTree%InitializePointOctree(3_ip,npoin,coord,maxpoin,Memor)
   call cpu_time(time2)
   !write(*,*) 'Time for building Octree: ', time2- time1

   call cpu_time(time1)
   do ipoinx = 1,npoinx
      do ipoiny = 1,npoiny
         do ipoinz = 1,npoinz

            mypoint(1) = ipoinx
            mypoint(2) = ipoiny
            mypoint(3) = ipoinz

            call MyTree%GetListForCoord(coord(:,mypoint(1),mypoint(2),mypoint(3)),Head,Store)
            call Store%GoToFirstOfList(Head)

            foundpoin = -1
            call Store%GetNext(ipoin)
            do while (ipoin /= -1)
               !ipoin to ipoinx, ipoiny, ipoinz
               auxipoin = ipoin
               resultpoint(3) = (auxipoin-1)/(npoinx*npoiny)+1
               auxipoin = auxipoin - (resultpoint(3)-1)*(npoinx*npoiny)
               resultpoint(2) = (auxipoin-1)/npoinx+1
               auxipoin = auxipoin - (resultpoint(2)-1)*npoinx
               resultpoint(1) = auxipoin

               check = 0
               do idime = 1,3
                  if (coord(idime,resultpoint(1),resultpoint(2),resultpoint(3)) &
                  == coord(idime,mypoint(1),mypoint(2),mypoint(3)) ) then
                     check = check + 1
                  endif
               enddo

               if (check == 3) then
                  foundpoin = ipoin
                  write(*,*) 'Found the point. x: ',resultpoint(1), ' y: ',resultpoint(2), ' z: ',resultpoint(3)
                  ipoin = -1
               else
                  call Store%GetNext(ipoin)
               endif
            enddo

            if (foundpoin == -1) then
               write(*,*) 'Did not find the point. x: ',resultpoint(1), ' y: ',resultpoint(2), ' z: ',resultpoint(3)
               call runend('One of the points was not found in Octree')
            endif

         enddo
      enddo
   enddo

   call cpu_time(time2)
   !write(*,*) 'Time for looking for all the points: ', time2- time1

   !----------------------------------------------------------------------
   !Now I test for getting a range
   range(1,1) = 2
   range(2,1) = 5
   range(1,2) = 3
   range(2,2) = 7
   range(1,3) = 2
   range(2,3) = 3

   call MyTree%GetListForRange(range,Head,Store)
   call Store%GoToFirstOfList(Head)

   foundpoin = -1
   call Store%GetNext(ipoin)
   do while (ipoin /= -1)
      !ipoin to ipoinx, ipoiny, ipoinz
      auxipoin = ipoin
      resultpoint(3) = (auxipoin-1)/(npoinx*npoiny)+1
      auxipoin = auxipoin - (resultpoint(3)-1)*(npoinx*npoiny)
      resultpoint(2) = (auxipoin-1)/npoinx+1
      auxipoin = auxipoin - (resultpoint(2)-1)*npoinx
      resultpoint(1) = auxipoin

      write(*,*) (resultpoint(idime),idime=1,3)

      call Store%GetNext(ipoin)
   enddo

   !Deallocate Everything
   call MyTree%Dealloc(Memor)

   write(*,*) 'after Mytreedealloc'

   !------------------------------------------------------------------------
   !Test Octree for elements

   maxpoin = 10

   call cpu_time(time1)
   !Initialize MacGyver
   call MacGyver%Initialize(npoinx,npoiny,npoinz)

   call MyTree%InitializeElementOctree(3,npoin,MacGyver,maxpoin,Memor)
   call cpu_time(time2)
   !write(*,*) 'Time for initializing element Octree: ', time2-time1

   call cpu_time(time1)
   do ipoinx = 1,npoinx
      do ipoiny = 1,npoiny
         do ipoinz = 1,npoinz

            mypoint(1) = ipoinx
            mypoint(2) = ipoiny
            mypoint(3) = ipoinz
            write(*,*) 'Element list for point: ',(mypoint(idime),idime=1,3)

            call MyTree%GetListForCoord(coord(:,mypoint(1),mypoint(2),mypoint(3)),Head,Store)
            call Store%GoToFirstOfList(Head)

            foundpoin = -1
            call Store%GetNext(ipoin)
            do while (ipoin /= -1)
               !ipoin to ipoinx, ipoiny, ipoinz
               auxipoin = ipoin
               resultpoint(3) = (auxipoin-1)/(npoinx*npoiny)+1
               auxipoin = auxipoin - (resultpoint(3)-1)*(npoinx*npoiny)
               resultpoint(2) = (auxipoin-1)/npoinx+1
               auxipoin = auxipoin - (resultpoint(2)-1)*npoinx
               resultpoint(1) = auxipoin

               write(*,*) (resultpoint(idime),idime=1,3)

               call Store%GetNext(ipoin)
            enddo
         enddo
      enddo
   enddo
   call cpu_time(time2)
   !write(*,*) 'Time for getting the list of all elements: ', time2-time1

   call MyTree%Dealloc(Memor)

   stop

end subroutine


        subroutine iddp_aid(eps,m,n,a,work,krank,list,proj)
c
c       computes the ID of the matrix a, i.e., lists in list
c       the indices of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon dimensioned epsilon(m,n-krank)
c       such that the greatest singular value of epsilon
c       <= the greatest singular value of a * eps.
c
c       input:
c       eps -- precision to which the ID is to be computed
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix to be decomposed; the present routine does not
c            alter a
c       work -- initialization array that has been constructed
c               by routine idd_frmi
c
c       output:
c       krank -- numerical rank of a to precision eps
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               proj doubles as a work array in the present routine, so
c               proj must be at least n*(2*n2+1)+n2+1 real*8 elements
c               long, where n2 is the greatest integer less than
c               or equal to m, such that n2 is a positive integer
c               power of two.
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least n*(2*n2+1)+n2+1 real*8 elements
c               long, where n2 is the greatest integer less than
c               or equal to m, such that n2 is a positive integer
c               power of two.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,list(n),krank,kranki,n2
        real*8 eps,a(m,n),proj(*),work(17*m+70)
c
c
c       Allocate memory in proj.
c
        n2 = work(2)
c
c
c       Find the rank of a.
c
        call idd_estrank(eps,m,n,a,work,kranki,proj)
c
c
        if(kranki .eq. 0) call iddp_aid0(eps,m,n,a,krank,list,proj,
     1                                   proj(m*n+1))
c
        if(kranki .ne. 0) call iddp_aid1(eps,n2,n,kranki,proj,
     1                                   krank,list,proj(n2*n+1))
c
c
        return
        end
c
c
c
c


PROGRAM ApplicationDriver

  USE KindModule, ONLY: &
    DP, One, Two, Pi, TwoPi
  USE ProgramHeaderModule, ONLY: &
    iX_B0, iX_B1, iX_E0, iX_E1, &
    nDimsX, nDOFX
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE ReferenceElementModuleX, ONLY: &
    InitializeReferenceElementX, &
    FinalizeReferenceElementX
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    InitializeReferenceElementX_Lagrange, &
    FinalizeReferenceElementX_Lagrange
  USE InputOutputModuleHDF, ONLY: &
    WriteFieldsHDF, &
    ReadFieldsHDF
  USE GeometryFieldsModule, ONLY: &
    nGF, uGF
  USE GeometryComputationModule, ONLY: &
    ComputeGeometryX
  USE EquationOfStateModule, ONLY: &
    InitializeEquationOfState, &
    FinalizeEquationOfState
  USE FluidFieldsModule, ONLY: &
    nCF, nPF, nAF, &
    uCF, uPF, uAF, &
    uDF
  USE InitializationModule, ONLY: &
    InitializeFields
  USE TimeSteppingModule_SSPRK, ONLY: &
    InitializeFluid_SSPRK, &
    FinalizeFluid_SSPRK, &
    UpdateFluid_SSPRK
  USE Euler_SlopeLimiterModule_NonRelativistic_IDEAL, ONLY: &
    InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL, &
    FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL, &
    ApplySlopeLimiter_Euler_NonRelativistic_IDEAL
  USE Euler_PositivityLimiterModule_NonRelativistic_IDEAL, ONLY: &
    InitializePositivityLimiter_Euler_NonRelativistic_IDEAL, &
    FinalizePositivityLimiter_Euler_NonRelativistic_IDEAL, &
    ApplyPositivityLimiter_Euler_NonRelativistic_IDEAL
  USE Euler_UtilitiesModule_NonRelativistic, ONLY: &
    ComputeFromConserved_Euler_NonRelativistic, &
    ComputeTimeStep_Euler_NonRelativistic
  USE Euler_dgDiscretizationModule, ONLY: &
    ComputeIncrement_Euler_DG_Explicit
  USE Euler_TallyModule_NonRelativistic, ONLY: &
    InitializeTally_Euler_NonRelativistic, &
    FinalizeTally_Euler_NonRelativistic, &
    ComputeTally_Euler_NonRelativistic
  USE TimersModule_Euler, ONLY: &
    TimeIt_Euler, &
    InitializeTimers_Euler, FinalizeTimers_Euler, &
    TimersStart_Euler, TimersStop_Euler, &
    Timer_Euler_InputOutput, &
    Timer_Euler_Initialize, &
    Timer_Euler_Finalize

  IMPLICIT NONE

  INCLUDE 'mpif.h'

  CHARACTER(32) :: ProgramName
  CHARACTER(32) :: AdvectionProfile
  CHARACTER(32) :: Direction
  CHARACTER(32) :: RiemannProblemName
  CHARACTER(32) :: CoordinateSystem
  LOGICAL       :: wrt
  LOGICAL       :: UseSlopeLimiter
  LOGICAL       :: UseCharacteristicLimiting
  LOGICAL       :: UseTroubledCellIndicator
  LOGICAL       :: UseConservativeCorrection
  INTEGER       :: iCycle, iCycleD
  INTEGER       :: nX(3), bcX(3), nNodes
  INTEGER       :: RestartFileNumber
  REAL(DP)      :: t, dt, t_end, dt_wrt, t_wrt, wTime
  REAL(DP)      :: xL(3), xR(3), Gamma
  REAL(DP)      :: BetaTVD, BetaTVB
  REAL(DP)      :: LimiterThresholdParameter
  REAL(DP)      :: Eblast

  TimeIt_Euler = .TRUE.
  CALL InitializeTimers_Euler
  CALL TimersStart_Euler( Timer_Euler_Initialize )

  CoordinateSystem = 'CARTESIAN'

  ProgramName = 'RiemannProblem'

  RestartFileNumber = -1

  t = 0.0_DP

  SELECT CASE ( TRIM( ProgramName ) )

    CASE( 'Advection' )

      AdvectionProfile = 'TopHat'

      Direction = 'XY'

      Gamma = 1.4_DP

      nX = [ 64, 64, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 1.0_DP, 1.0_DP, 1.0_DP ]

      bcX = [ 1, 1, 0 ]

      nNodes = 2

      BetaTVD = 1.80_DP
      BetaTVB = 0.0d+00

      iCycleD = 1
      t_end   = SQRT( 2.0d-0 )
      dt_wrt  = 1.0d-2 * t_end

    CASE( 'RiemannProblem' )

      RiemannProblemName = 'Sod'

      Gamma = 1.4_DP

      nX = [ 256, 1, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 1.0_DP, 1.0_DP, 1.0_DP ]

      bcX = [ 2, 0, 0 ]

      nNodes = 3

      BetaTVD = 1.75_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .TRUE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .TRUE.
      LimiterThresholdParameter = 0.03d0

      iCycleD = 10
      t_end   = 2.0d-1
      dt_wrt  = 1.0d-2 * t_end

   CASE( 'RiemannProblemSpherical' )

      CoordinateSystem = 'SPHERICAL'

      Gamma = 1.4_DP

      nX = [ 128, 16, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 2.0_DP, Pi,     TwoPi  ]

      bcX = [ 3, 3, 0 ]

      nNodes = 2

      BetaTVD = 1.75_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .TRUE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .FALSE.
      LimiterThresholdParameter = 0.03_DP

      iCycleD = 1
      t_end   = 5.0d-1
      dt_wrt  = 2.5d-2

   CASE( 'SphericalSedov' )

      Eblast = 1.0d0

      CoordinateSystem = 'SPHERICAL'

      Gamma = 1.4_DP

      nX = [ 256, 1, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 1.2_DP, Pi,     TwoPi  ]

      bcX = [ 2, 0, 0 ]

      nNodes = 3

      BetaTVD = 1.75d+00
      BetaTVB = 0.00d+00

      UseSlopeLimiter           = .TRUE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .TRUE.
      LimiterThresholdParameter = 0.015_DP

      iCycleD = 1
      t_end   = 1.0d+0
      dt_wrt  = 5.0d-2

    CASE( 'IsentropicVortex' )

      Gamma = 1.4_DP

      nX = [ 50, 50, 1 ]
      xL = [ - 5.0_DP, - 5.0_DP, 0.0_DP ]
      xR = [ + 5.0_DP, + 5.0_DP, 1.0_DP ]

      bcX = [ 1, 1, 0 ]

      nNodes = 3

      BetaTVD = 1.75_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .FALSE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .TRUE.
      LimiterThresholdParameter = 0.03_DP

      iCycleD = 10
      t_end   = 10.0_DP
      dt_wrt  = 10.0_DP

    CASE( 'KelvinHelmholtz' )

      Gamma = 5.0_DP / 3.0_DP

      nX = [ 256, 256, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 1.0_DP, 1.0_DP, 1.0_DP ]

      bcX = [ 1, 1, 0 ]

      nNodes = 3

      BetaTVD = 1.50_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .FALSE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .TRUE.
      LimiterThresholdParameter = 0.03_DP

      iCycleD = 10
      t_end   = 3.00_DP
      dt_wrt  = 0.15_DP

    CASE( 'RayleighTaylor' )

      Gamma = 1.4_DP

      nX = [ 16, 48, 1 ]
      xL = [ - 0.25_DP, + 0.25_DP, 0.0_DP ]
      xR = [ - 0.75_DP, + 0.75_DP, 1.0_DP ]

      bcX = [ 1, 3, 0 ]

      nNodes = 3

      BetaTVD = 2.00_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .TRUE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .FALSE.
      LimiterThresholdParameter = 0.03_DP

      UseConservativeCorrection = .TRUE.

      iCycleD = 10
      t_end   = 8.5_DP
      dt_wrt  = 0.1_DP

    CASE( 'Implosion' )

      Gamma = 1.4_DP

      nX = [ 256, 256, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 0.3_DP, 0.3_DP, 1.0_DP ]

      bcX = [ 3, 3, 0 ]

      nNodes = 3

      BetaTVD = 1.50_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .TRUE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .TRUE.
      LimiterThresholdParameter = 0.30_DP

      iCycleD = 10
      t_end   = 2.500_DP
      dt_wrt  = 0.045_DP

    CASE( 'Explosion' )

      Gamma = 1.4_DP

      nX = [ 256, 256, 1 ]
      xL = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR = [ 1.5_DP, 1.5_DP, 1.0_DP ]

      bcX = [ 31, 31, 0 ]

      nNodes = 3

      BetaTVD = 1.75_DP
      BetaTVB = 0.0d+00

      UseSlopeLimiter           = .TRUE.
      UseCharacteristicLimiting = .TRUE.

      UseTroubledCellIndicator  = .TRUE.
      LimiterThresholdParameter = 0.05_DP

      iCycleD = 10
      t_end   = 3.20_DP
      dt_wrt  = 0.32_DP

  END SELECT

  CALL InitializeProgram &
         ( ProgramName_Option &
             = TRIM( ProgramName ), &
           nX_Option &
             = nX, &
           swX_Option &
             = [ 1, 1, 1 ], &
           bcX_Option &
             = bcX, &
           xL_Option &
             = xL, &
           xR_Option &
             = xR, &
           nNodes_Option &
             = nNodes, &
           CoordinateSystem_Option &
             = TRIM( CoordinateSystem ), &
           BasicInitialization_Option &
             = .TRUE. )

  CALL InitializeReferenceElementX

  CALL InitializeReferenceElementX_Lagrange

  CALL ComputeGeometryX( iX_B0, iX_E0, iX_B1, iX_E1, uGF )

  CALL InitializeEquationOfState &
         ( EquationOfState_Option = 'IDEAL', &
           Gamma_IDEAL_Option = Gamma )

  CALL InitializeSlopeLimiter_Euler_NonRelativistic_IDEAL &
         ( BetaTVD_Option = BetaTVD, &
           BetaTVB_Option = BetaTVB, &
           SlopeTolerance_Option &
             = 1.0d-6, &
           UseSlopeLimiter_Option &
             = UseSlopeLimiter, &
           UseCharacteristicLimiting_Option &
             = UseCharacteristicLimiting, &
           UseTroubledCellIndicator_Option &
             = UseTroubledCellIndicator, &
           LimiterThresholdParameter_Option &
             = LimiterThresholdParameter )

  CALL InitializePositivityLimiter_Euler_NonRelativistic_IDEAL &
         ( UsePositivityLimiter_Option = .TRUE., &
           Verbose_Option = .TRUE., &
           Min_1_Option = 1.0d-12, &
           Min_2_Option = 1.0d-12 )

  CALL InitializeFields &
         ( AdvectionProfile_Option &
             = TRIM( AdvectionProfile ), &
           Direction_Option &
             = TRIM( Direction ), &
           RiemannProblemName_Option &
             = TRIM( RiemannProblemName ), &
           SedovEnergy_Option = Eblast )

  IF( RestartFileNumber .GE. 0 )THEN

    CALL ReadFieldsHDF( RestartFileNumber, t, ReadFF_Option = .TRUE. )

  END IF

  CALL ApplySlopeLimiter_Euler_NonRelativistic_IDEAL &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uDF )

  CALL ApplyPositivityLimiter_Euler_NonRelativistic_IDEAL &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF )

  CALL TimersStart_Euler( Timer_Euler_InputOutput )

  CALL ComputeFromConserved_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL WriteFieldsHDF &
         ( t, WriteGF_Option = .TRUE., WriteFF_Option = .TRUE. )

  CALL TimersStop_Euler( Timer_Euler_InputOutput )

  CALL InitializeFluid_SSPRK( nStages = 3 )

  ! --- Evolve ---

  wTime = MPI_WTIME( )

  t_wrt = t + dt_wrt
  wrt   = .FALSE.

  CALL InitializeTally_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF )

  CALL ComputeTally_Euler_NonRelativistic &
       ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, Time = t, &
         SetInitialValues_Option = .TRUE., Verbose_Option = .TRUE. )

  CALL TimersStop_Euler( Timer_Euler_Initialize )

  iCycle = 0
  DO WHILE ( t < t_end )

    iCycle = iCycle + 1

    CALL ComputeTimeStep_Euler_NonRelativistic &
           ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, &
             CFL = 0.5_DP / ( nDimsX * ( Two * DBLE( nNodes ) - One ) ), &
             TimeStep = dt )

    IF( t + dt > t_end )THEN

      dt = t_end - t

    END IF

    IF( t + dt > t_wrt )THEN

      dt    = t_wrt - t
      t_wrt = t_wrt + dt_wrt
      wrt   = .TRUE.

    END IF

    CALL TimersStart_Euler( Timer_Euler_InputOutput )
    IF( MOD( iCycle, iCycleD ) == 0 )THEN

      WRITE(*,'(A8,A8,I8.8,A2,A4,ES13.6E3,A1,A5,ES13.6E3)') &
          '', 'Cycle = ', iCycle, '', 't = ',  t, '', 'dt = ', dt

    END IF
    CALL TimersStop_Euler( Timer_Euler_InputOutput )

    CALL UpdateFluid_SSPRK &
           ( t, dt, uGF, uCF, uDF, ComputeIncrement_Euler_DG_Explicit )

    t = t + dt

    CALL TimersStart_Euler( Timer_Euler_InputOutput )
    IF( wrt )THEN

      CALL ComputeFromConserved_Euler_NonRelativistic &
             ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

      CALL WriteFieldsHDF &
             ( t, WriteGF_Option = .TRUE., WriteFF_Option = .TRUE. )

      CALL ComputeTally_Euler_NonRelativistic &
             ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, Time = t, &
               Verbose_Option = .TRUE. )

      wrt = .FALSE.

    END IF
    CALL TimersStop_Euler( Timer_Euler_InputOutput )

  END DO

  CALL TimersStart_Euler( Timer_Euler_InputOutput )
  CALL ComputeFromConserved_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL WriteFieldsHDF &
         ( t, WriteGF_Option = .TRUE., WriteFF_Option = .TRUE. )
  CALL TimersStop_Euler( Timer_Euler_InputOutput )

  CALL ComputeTally_Euler_NonRelativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, Time = t, &
           Verbose_Option = .TRUE. )

  CALL TimersStart_Euler( Timer_Euler_Finalize )
  CALL FinalizeTally_Euler_NonRelativistic_IDEAL

  wTime = MPI_WTIME( ) - wTime

  WRITE(*,*)
  WRITE(*,'(A6,A,I6.6,A,ES12.6E2,A)') &
    '', 'Finished ', iCycle, ' Cycles in ', wTime, ' s'
  WRITE(*,*)

  CALL FinalizePositivityLimiter_Euler_NonRelativistic_IDEAL

  CALL FinalizeSlopeLimiter_Euler_NonRelativistic_IDEAL

  CALL FinalizeEquationOfState

  CALL FinalizeFluid_SSPRK

  CALL FinalizeReferenceElementX_Lagrange

  CALL FinalizeReferenceElementX

  CALL FinalizeProgram

  CALL TimersStop_Euler( Timer_Euler_Finalize )

  CALL FinalizeTimers_Euler

  WRITE(*,*)
  WRITE(*,'(2x,A)') 'git info'
  WRITE(*,'(2x,A)') '--------'
  WRITE(*,*)
  WRITE(*,'(2x,A)') 'git branch:'
  CALL EXECUTE_COMMAND_LINE( 'git branch' )
  WRITE(*,*)
  WRITE(*,'(2x,A)') 'git describe --tags:'
  CALL EXECUTE_COMMAND_LINE( 'git describe --tags' )
  WRITE(*,*)
  WRITE(*,'(2x,A)') 'git rev-parse HEAD:'
  CALL EXECUTE_COMMAND_LINE( 'git rev-parse HEAD' )
  WRITE(*,*)
  WRITE(*,'(2x,A)') 'date:'
  CALL EXECUTE_COMMAND_LINE( 'date' )
  WRITE(*,*)

END PROGRAM ApplicationDriver


      DOUBLE PRECISION FUNCTION sla_EPJ (DATE)
*+
*     - - - -
*      E P J
*     - - - -
*
*  Conversion of Modified Julian Date to Julian Epoch (double precision)
*
*  Given:
*     DATE     dp       Modified Julian Date (JD - 2400000.5)
*
*  The result is the Julian Epoch.
*
*  Reference:
*     Lieske,J.H., 1979. Astron.Astrophys.,73,282.
*
*  P.T.Wallace   Starlink   February 1984
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE

      sla_EPJ = 2000D0 + (DATE-51544.5D0)/365.25D0

      END


!==============================================================================!
  subroutine Residual_Vector(ni, mat_a, x, r)
!------------------------------------------------------------------------------!
!   Calculates residual vector.                                                !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Comm_Mod
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer           :: ni          ! number of cells inside (i)
  type(Matrix_Type) :: mat_a
  real              :: x(:), r(:)  !  [A]{x}={r}
!-----------------------------------[Locals]-----------------------------------!
  integer  :: i, j, k, sub
!==============================================================================!

  !----------------!
  !   r = b - Ax   !
  !----------------!
  ! Why not callig this: call exchange(x) ???
  do i = 1, ni
    do j = mat_a % row(i), mat_a % row(i+1) - 1
      k = mat_a % col(j)
      r(i) = r(i) - mat_a % val(j) * x(k)
    end do
  end do

  end subroutine


    MODULE cdf_f_mod
! ----------------------------------------------------------------------

!                                cdf_f_mod
!                                *=*=*=*=*

!  -  SUBROUTINE CDF_F( WHICH, CUM, CCUM, F, DFN, DFD, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_F(F,  DFN, DFD, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_F(F, DFN, DFD, STATUS,  CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_F( CUM, CCUM, DFN, DFD, STATUS, CHECK_INPUT)

!                             The Distribution
!                             ================

!  F is the distribution of the ratio of two independent random
!  variables. The numerator random variable is distributed as chi-squared
!  with DF degrees of freedom divided by DF. The denominator random
!  variable is distributed as chi-squared with DFD degrees of freedom
!  divided by DFD.The density of the f distribution is defined on x in
!  [0,+Infinity] and is proportional to:

!                                (DFN-2)/2)
!                               x
!                        -------------------------
!                                      (DFN+DFD)/2
!                        [1+(DFN/DFD)x]

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    four arguments is to be calculated.
!  Input Range: [ 1:2 ]
!     1.  CUM and CCUM
!     2.  F
!  NOTE: DFN and DFD will not be computed because CUM is not monotone in
!    either argument.
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the f distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the f
!    distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: F. The upper limit of integration of the f density.
!    The lower limit is 0.
!  Input Range: [ 0:10^100 ]
!  - REAL (dpkind) :: DFN. The numerator degrees of freedom.
!  Range: [ 10^-3:10^10 ]
!  - REAL (dpkind) :: DFD. The denominator degrees of freedom.
!  Range: [ 10^-3:10^10 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code.
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 F outside range
!     -5 DFN outside range
!     -6 DFD outside range
!      3 CUM + CCUM is not nearly one
!     10 can not solve cdf_beta calling from local_cum_f
!    -50 Answer (if any) is BELOW the LOWER search bound
!     50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.

!   NOTE: CUM and CCUM must add to (nearly) one.

!   NOTE: The value of the CDF of the f distribution is NOT necessarily
!         monotone in either degree of freedom argument. There may thus
!         be two values that provide a given DCF value.
!         This routine assumes monotonicity and will find an arbitrary one
!         of the two values.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_f, cdf_f, cum_f, inv_f
! ..
! .. Parameters ..
      REAL (dpkind), PARAMETER :: tiny = 1.0E-100_dpkind
! ..
    CONTAINS

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

      FUNCTION ccum_f(f,dfn,dfd,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_f
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: dfd, dfn, f
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_f(which=1,ccum=ccum_f,f=f,dfn=dfn,dfd=dfd,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION ccum_f

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

      SUBROUTINE cdf_f(which,cum,ccum,f,dfn,dfd,status,check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: dfd, dfn, f
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_f%name,'cum','ccum', &
          local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = f
        params(4) = dfn
        params(5) = dfd

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_f,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF
        END IF

! ++++++++++          ++++++++++          ++++++++++
! Compute the Answers
! ++++++++++          ++++++++++          ++++++++++

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)
        CASE (1)

          CALL local_cum_f(f,dfn,dfd,local_cum,local_ccum,status)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)
          f = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_f,3,local)

          DO
            CALL rc_interval_zf(zf_status,f,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_f(f,dfn,dfd,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF
          END DO

! Can NOT solve for Degrees of Freedom

        END SELECT

        IF (has_status) THEN
! Set the status of the zero finder
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_f

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

      FUNCTION cum_f(f,dfn,dfd,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_f
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: dfd, dfn, f
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_f(which=1,cum=cum_f,f=f,dfn=dfn,dfd=dfd,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION cum_f

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

      FUNCTION inv_f(cum,ccum,dfn,dfd,status,check_input)
! Solves the INVERSE F-distribution problem:
! Given cum (or/and ccum), dfn, and dfd, computes f.
! .. Function Return Value ..
        REAL (dpkind) :: inv_f
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind), INTENT (IN) :: dfd, dfn
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_f(which=2,cum=cum,ccum=ccum,f=inv_f,dfn=dfn,dfd=dfd, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_f

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

      SUBROUTINE local_cum_f(f,dfn,dfd,cum,ccum,status)
!----------------------------------------------------------------------

!                              Function

!     Computes the integral from 0 to F of the f-density.
!     f    --> Upper limit of integration of the f-density.
!     dfn  --> Degrees of freedom of the numerator
!     dfd  --> Degrees of freedom of the denominator
!     cum  <-- Cumulative f-distribution.
!     ccum <-- Complement of Cumulative f-distribution.
!     status <-- tells the caller whether the problem was successfully solved.
!                Set to 10 if cdf_beta has no answer and status was used in
!                the initial call to cdf_f (otherwise, it breaks down)

!                              Method

!     Formula   26.6.2   of   Abramowitz   and   Stegun,  Handbook  of
!     Mathematical  Functions (1966) is used to reduce the computation
!     of the  cumulative  distribution function for the  F  variate to
!     that of an incomplete beta.

!                              Note
!     If F is less than or equal to 0, 0 is returned.
!------------------------------------------------------------------
! .. Use Statements ..
        USE cdf_beta_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: dfd, dfn, f
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Local Scalars ..
        REAL (dpkind) :: dsum, prod, xx, yy
        INTEGER :: beta_status
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        IF (f<=zero) THEN
          cum = zero
          ccum = one
          RETURN
        END IF

        beta_status = 0

        prod = dfn*f

!     XX is such that the incomplete beta with parameters
!     DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM

!     YY is 1 - XX

!     Calculate the smaller of XX and YY accurately

        dsum = dfd + prod

        IF (xx>half) THEN
          yy = prod/dsum
          xx = one - yy
        ELSE
          xx = dfd/dsum
          yy = one - xx
        END IF

        CALL cdf_beta(1,ccum,cum,xx,yy,half*dfd,half*dfn, &
          status=beta_status)

        IF (beta_status/=0) THEN
! cdf_beta has NO answer.

          IF (PRESENT(status)) THEN
            status = 10
          ELSE
            WRITE (*,*) 'Error in local_cum_f call to cdf_beta'
            WRITE (*,*) 'Status: ', beta_status

            STOP 'Error in local_cum_f call to cdf_beta'
          END IF

        END IF

        RETURN

      END SUBROUTINE local_cum_f

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

    END MODULE cdf_f_mod


	SUBROUTINE IM_BTOT  ( nvals, brit, tmpk, iret )
C************************************************************************
C* IM_BTOT								*
C*									*
C* This image processing function converts an 8-bit brightness pixel	*
C* temperature count (in a 4-byte integer word) to a real temperature	*
C* (degrees K).	Brightness counts are also called mode-A counts or Ca.	*
C*									*
C* The following equation is used:					*
C*									*
C*	IF  (BRIT >= 176)  TMPK = 418 - BRIT				*
C*	IF  (BRIT <  176)  TMPK = 330 - (BRIT/2)			*
C*									*
C* SUBROUTINE IM_BTOT  ( NVALS, BRIT, TMPK, IRET )			*
C*									*
C* Input parameters:							*
C*	NVALS		INTEGER		Number of values to convert	*
C*	BRIT		INTEGER		Brightness (0-255)		*
C*									*
C* Output parameters:							*
C*	TMPK		REAL		Temperature in Kelvin		*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* J. Cowie/COMET	 4/96						*
C* T. Lee/GSC		 9/99	Changed input to integer		*
C* D.W.Plummer/NCEP	 2/03	Change from function to subroutine	*
C* T. Piper/SAIC	07/06	Set iret to zero			*
C************************************************************************
        INCLUDE		'GEMPRM.PRM'
	INTEGER		brit(*)
	REAL		tmpk(*)
C------------------------------------------------------------------------
	iret = 0
	DO  ii = 1, nvals
C
	    IF  ( ( brit(ii) .lt. 0 ) .or. ( brit(ii) .gt. 255 ) )  THEN
	        tmpk(ii) = RMISSD
	    ELSE IF ( brit(ii) .ge. 176 ) THEN
	        tmpk(ii) = 418.0 - brit(ii)
	    ELSE
	        tmpk(ii) = 330.0 - ( brit(ii) /2.0 )
	    END IF
C
	END DO
C*
	RETURN
	END


    !Gets predicted BBN mass fraction YHe by interpolating in pre-computed grid

    !Module originally from Jan Hamann, 4/2010
    !Rewrittten with updated table from Parthenope by AL Dec 2013
    module bbn
    use settings
    use Interpolation
    implicit none

    type, extends(TInterpGrid2D) :: TBBNPredictions
        integer :: data_col = 4
        character(LEN=128) :: BBN_data_file = 'PArthENoPE_880.2_standard.dat'
    contains
    procedure :: Error => BBNPredictions_error
    procedure :: FirstUse =>  BBN_Init
    end type TBBNPredictions

    type(TBBNPredictions), target, save :: BBN_YHe
    !Helium mass fraction (not Y_P^BBN nucleon fraction, which is column 5)

    type(TBBNPredictions), target, save :: BBN_YpBBN = TBBNPredictions(data_col=5)
    type(TBBNPredictions), target, save :: BBN_YpBBN_err = TBBNPredictions(data_col=6)
    type(TBBNPredictions), target, save :: BBN_DH = TBBNPredictions(data_col=7)
    type(TBBNPredictions), target, save :: BBN_DH_err = TBBNPredictions(data_col=8)

    contains

    function GetYPBBN(Yhe)
    !Convert yhe defined as mass fraction (CMB codes), to nucleon ratio definition
    real(mcp), intent(in) :: Yhe
    real(mcp) GetYPBBN
    real(mcp), parameter :: m_proton = 1.672621637e-27
    real(mcp), parameter :: m_H = 1.673575e-27
    real(mcp), parameter :: not4 = 3.9715
    real(mcp), parameter :: m_He = m_H * not4

    GetYPBBN =  4 * m_H * Yhe / (m_He - Yhe * (m_He - 4*m_H))

    end function GetYPBBN

    subroutine BBN_Init(this)
    class(TBBNPredictions):: this

    if (feedback > 1) print*,'Initialising BBN data '//trim(this%BBN_data_file)//', col:', this%data_col

    call this%InitFromFile(trim(DataDir)//this%BBN_data_file, xcol=1,ycol=3, zcol=this%data_col)

    if (feedback > 1) print*,'Done. Interpolation table is ', this%nx,' by ',this%ny

    end subroutine BBN_Init

    subroutine BBNPredictions_error(this,S,v1,v2)
    class(TBBNPredictions):: this
    character(LEN=*), intent(in) :: S
    class(*), intent(in), optional :: v1, v2

    !Current tables don't have errors in so can't use this.
    call this%TInterpGrid2D%Error('BBN Error: '//S,v1,v2)

    end subroutine BBNPredictions_error

    end module bbn


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module explicit_scalar_tendencies

  ! This module manages the calculation of the explicit component of the scalar tendencies.

  use definitions,          only: wp,t_grid,t_state,t_diag,t_tend
  use multiplications,      only: scalar_times_vector_h
  use divergence_operators, only: divv_h
  use run_nml,              only: nlins,ncols

  implicit none

  private

  public :: expl_scalar_tend

  contains

  subroutine expl_scalar_tend(grid,state,tend,diag)

    type(t_grid),  intent(in)    :: grid  ! model grid
    type(t_state), intent(in)    :: state ! state with which to calculate the divergence
    type(t_tend),  intent(inout) :: tend  ! state which will contain the tendencies
    type(t_diag),  intent(inout) :: diag  ! diagnostic quantities

    ! explicit mass density integration
    ! calculating the mass density flux
    call scalar_times_vector_h(state%rho,state%wind_u,state%wind_v,diag%u_placeholder,diag%v_placeholder)
    ! calculating the divergence of the mass density flux
    call divv_h(diag%u_placeholder,diag%v_placeholder,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:),grid)
    tend%rho(:,:,:) = -diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)

    ! explicit potential temperature density integration
    ! calculating the potential temperature density flux
    diag%scalar_placeholder(:,:,:) = grid%theta_bg(:,:,:) + state%theta_pert(:,:,:)
    call scalar_times_vector_h(diag%scalar_placeholder,diag%u_placeholder,diag%v_placeholder, &
    diag%u_placeholder,diag%v_placeholder)
    ! calculating the divergence of the potential temperature density flux
    call divv_h(diag%u_placeholder,diag%v_placeholder,diag%scalar_placeholder(2:nlins+1,2:ncols+1,:),grid)
    tend%rhotheta(:,:,:) = -diag%scalar_placeholder(2:nlins+1,2:ncols+1,:)

  end subroutine

end module explicit_scalar_tendencies


program vin
  integer :: numbers(9,9)
  numbers = 3
  numbers(1,1:3) = numbers(2:4,3) + numbers(6,3:5) + 2 - numbers(8,2)
  print *,numbers
end program vin


module postmod

  use type_kinds, only: fp_kind
  implicit none

  integer ndeg,nasm
  parameter(ndeg=6,nasm=560)

contains

 subroutine smver(field,vsmth,nlat,nsig)
   implicit none
   integer nlat,nsig,i,k,kk
   real(fp_kind),dimension(nlat,nsig):: field
   real(fp_kind),dimension(nsig):: field_tmp
   real(fp_kind),dimension(nsig,nsig),intent(in) :: vsmth
   field_tmp=0
   do i=1,nlat
     do kk=1,nsig
       field_tmp(kk)=0
       do k=1,nsig
         field_tmp(kk)=field_tmp(kk)+vsmth(k,kk)*field(i,k)
       enddo
     end do
    field(i,1:nsig)=field_tmp(1:nsig)
   enddo
 return
 end subroutine smver

 subroutine smoothlat(field,nlevs,degs)
   use variables,only: nlat
   implicit none

   integer j,j2,k,nlevs
   real(fp_kind),dimension(nlat,nlevs):: field
   real(fp_kind),dimension(nlat):: field_sm
   real(fp_kind),dimension(nlat,nlat):: weights
   real(fp_kind) degs

! get weights for smoothing in lat direction
   call get_weights(degs,weights)

! smooth the field array based on weights computed
   do k=1,nlevs
     field_sm=0.0
     do j=2,nlat-1
       do j2=2,nlat-1
         field_sm(j)=field_sm(j)+weights(j,j2)*field(j2,k)
       end do
     end do

! redefine field to be smoothed
     do j=2,nlat-1
       field(j,k)=field_sm(j)
     end do
     field(1,k)=field(2,k)
     field(nlat,k)=field(nlat-1,k)

   end do   !end do loop over levs
 return

 end subroutine smoothlat

 subroutine get_weights(degs,wsmooth)
   use variables,only: nlat,deg2rad,rlats
   implicit none

   real(fp_kind),dimension(nlat):: rnorm,slat
   real(fp_kind),dimension(nlat,nlat):: wsmooth
   real(fp_kind),dimension(-nlat+4:nlat-2) :: wsmtemp

   real(fp_kind) sum,errmax,degs,arg,denom
   integer j,jj

! use difference in sin(lat) to calculate weighting
   do j=2,nlat-1
     slat(j)=sin(rlats(j))
   end do
   denom=1.0/(deg2rad*degs)

!   do jj=2,nlat-1
!     arg=.5*(denom*(slat(2)-slat(jj)))**2
!     wsmtemp(jj-1)=exp(-arg)
!   end do
!   do jj=-nlat+4,0
!     wsmtemp(jj)=wsmtemp(2-jj)
!   enddo

   rnorm=0.
   do j=2,nlat-1
     do jj=2,nlat-1
       arg=.5*(denom*(slat(j)-slat(jj)))**2
       wsmooth(j,jj)=exp(-arg)
       rnorm(j)=rnorm(j)+wsmooth(j,jj)
     end do
   end do

   rnorm(1)=rnorm(2)
   rnorm(nlat)=rnorm(nlat-1)

   rnorm=1./rnorm
   errmax=0.
   do j=2,nlat-1
     sum=0.0
     do jj=2,nlat-1
       wsmooth(j,jj)=rnorm(j)*wsmooth(j,jj)
       sum=sum+wsmooth(j,jj)
     end do
     errmax=max(abs(sum-1._fp_kind),errmax)
   end do

 return
 end subroutine get_weights

 subroutine writefiles
   use type_kinds,only: double,single,fp_kind
   use variables,only: smooth_vert_variances,vsmth,laddoz
   use variables,only: nlat,nlon,nsig
   use variables,only: sfvar,vpvar,tvar,qvar,qivar,qlvar,qrvar,qsvar,cvar,psvar,nrhvar,ozvar
   use variables,only: sfhln,vphln,thln,qhln,qihln,qlhln,qrhln,qshln,chln,pshln,ozhln
   use variables,only: sfvln,vpvln,tvln,qvln,qivln,qlvln,qrvln,qsvln,cvln,ozvln
   use variables,only: tcon,vpcon,pscon
   use variables,only: hydromet
   use sstmod
   implicit none

!  Single precision variables for visualization
   real*4,allocatable,dimension(:,:,:):: tcon4
   real*4,allocatable,dimension(:,:):: sfvar4,vpvar4,tvar4,qvar4,cvar4,nrhvar4,ozvar4
   real*4,allocatable,dimension(:,:):: sfhln4,vphln4,thln4,qhln4,chln4,ozhln4
   real*4,allocatable,dimension(:,:):: sfvln4,vpvln4,tvln4,qvln4,cvln4,ozvln4
   real*4,allocatable,dimension(:,:):: qivar4,qihln4,qivln4,qlvar4,qlhln4,qlvln4
   real*4,allocatable,dimension(:,:):: qrvar4,qrhln4,qrvln4,qsvar4,qshln4,qsvln4
   real*4,allocatable,dimension(:,:):: vpcon4,pscon4,varsst4,corlsst4
   real*4,allocatable,dimension(:):: psvar4,pshln4

   real(fp_kind),allocatable,dimension(:,:):: qdummy
   integer i,j,k,m,outf,ncfggg,iret,kindex
   character(255) grdfile
   character*5 var(40)

! Interpolate sst statistics
! go file for use in GSI analysis code
   call create_sstvars(nlat,nlon)
   call sst_stats

   do k=1,nsig
     do i=1,nlat
       sfvar(i,k)=sqrt(sfvar(i,k))
       vpvar(i,k)=sqrt(vpvar(i,k))
       tvar(i,k) =sqrt(tvar(i,k))
       nrhvar(i,k)=sqrt(nrhvar(i,k))
       qvar(i,k) =sqrt(qvar(i,k))
       cvar(i,k) =sqrt(cvar(i,k))
       ozvar(i,k)=sqrt(ozvar(i,k))
     end do
   end do
   if (hydromet) then
      do k=1,nsig
        do i=1,nlat
          qivar(i,k)=sqrt(qivar(i,k))
          qlvar(i,k)=sqrt(qlvar(i,k))
          qrvar(i,k)=sqrt(qrvar(i,k))
          qsvar(i,k)=sqrt(qsvar(i,k))
        end do
      end do
   endif

   do i=1,nlat
     psvar(i)=sqrt(psvar(i))
   end do

   if(smooth_vert_variances)then
    call smver(sfvar,vsmth,nlat,nsig)
    call smver(vpvar,vsmth,nlat,nsig)
    call smver(tvar,vsmth,nlat,nsig)
    call smver(qvar,vsmth,nlat,nsig)
    if (hydromet) then
       call smver(qivar,vsmth,nlat,nsig)
       call smver(qlvar,vsmth,nlat,nsig)
       call smver(qrvar,vsmth,nlat,nsig)
       call smver(qsvar,vsmth,nlat,nsig)
    endif
    call smver(cvar,vsmth,nlat,nsig)
    call smver(ozvar,vsmth,nlat,nsig)
    call smver(nrhvar,vsmth,nlat,nsig)
   endif

! reset stats for cloud (FROM ADDOZ CODE)
!_RT_NON_SENSE   nrhvar(1:nlat,52:nsig)=0.0
   cvar=0
   chln=100*1.e3
   cvln=0.5

! write out files;
   outf=45
   open(outf,file='berror_stats.grd',form='unformatted')
   rewind outf
   if (hydromet) then
      write(outf) nsig,nlat,&
                  sfvar,vpvar,tvar,qvar,nrhvar,qivar,qlvar,qrvar,qsvar,ozvar,cvar,psvar,&
                  sfhln,vphln,thln,qhln,qihln,qlhln,qrhln,qshln,ozhln,chln,pshln,&
                  sfvln,vpvln,tvln,qvln,qivln,qlvln,qrvln,qsvln,ozvln,cvln,&
                  tcon,vpcon,pscon,&
                  varsst,corlsst
   else ! for file compliance, fill in w/ zeros when not hydrometeors are wanted
      allocate(qdummy(nlat,nsig))
      qdummy=0.0
      write(outf) nsig,nlat,&
                  sfvar,vpvar,tvar,qvar,nrhvar,qdummy,qdummy,qdummy,qdummy,ozvar,cvar,psvar,&
                  sfhln,vphln,thln,qhln,qdummy,qdummy,qdummy,qdummy,ozhln,chln,pshln,&
                  sfvln,vpvln,tvln,qvln,qdummy,qdummy,qdummy,qdummy,ozvln,cvln,&
                  tcon,vpcon,pscon,&
                  varsst,corlsst
      deallocate(qdummy)
   endif
   close(outf)

    var=' '
    var(1)='sf'
    var(2)='vp'
    var(3)='t'
    var(4)='q'
    var(5)='qi'
    var(6)='ql'
    var(7)='qr'
    var(8)='qs'
    var(9)='oz'
    var(10)='cw'
    var(11)='ps'
    var(12)='sst'

   open(outf,file='gsi.berror_stats',form='unformatted')
     rewind outf
     write(outf) nsig,nlat,nlon
     write(outf) tcon,vpcon,pscon
     write(outf) var(1),nsig
     write(outf) sfvar
     write(outf) sfhln
     write(outf) sfvln
     write(outf) var(2),nsig
     write(outf) vpvar
     write(outf) vphln
     write(outf) vpvln
     write(outf) var(3),nsig
     write(outf) tvar
     write(outf) thln
     write(outf) tvln
     write(outf) var(4),nsig
     write(outf) qvar,nrhvar
     write(outf) qhln
     write(outf) qvln
     write(outf) var(5),nsig
     write(outf) qivar
     write(outf) qihln
     write(outf) qivln
     write(outf) var(6),nsig
     write(outf) qlvar
     write(outf) qlhln
     write(outf) qlvln
     write(outf) var(7),nsig
     write(outf) qrvar
     write(outf) qrhln
     write(outf) qrvln
     write(outf) var(8),nsig
     write(outf) qsvar
     write(outf) qshln
     write(outf) qsvln
     write(outf) var(9),nsig
     write(outf) ozvar
     write(outf) ozhln
     write(outf) ozvln
     write(outf) var(10),nsig
     write(outf) cvar
     write(outf) chln
     write(outf) cvln
     m=1
     write(outf) var(11),m
     write(outf) psvar
     write(outf) pshln
     write(outf) var(12),m
     write(outf) varsst
     write(outf) corlsst
   close(outf)

! allocate single precision arrays
   allocate(sfvar4(nlat,nsig),vpvar4(nlat,nsig),tvar4(nlat,nsig),qvar4(nlat,nsig),&
            qivar4(nlat,nsig),qlvar4(nlat,nsig),qrvar4(nlat,nsig),qsvar4(nlat,nsig),&
            cvar4(nlat,nsig),nrhvar4(nlat,nsig),ozvar4(nlat,nsig))
   allocate(sfhln4(nlat,nsig),vphln4(nlat,nsig),thln4(nlat,nsig),qhln4(nlat,nsig),&
            qihln4(nlat,nsig),qlhln4(nlat,nsig),qrhln4(nlat,nsig),qshln4(nlat,nsig),&
            chln4(nlat,nsig), ozhln4(nlat,nsig))
   allocate(sfvln4(nlat,nsig),vpvln4(nlat,nsig),tvln4(nlat,nsig),qvln4(nlat,nsig),&
            qivln4(nlat,nsig),qlvln4(nlat,nsig),qrvln4(nlat,nsig),qsvln4(nlat,nsig),&
            cvln4(nlat,nsig), ozvln4(nlat,nsig))
   allocate(pscon4(nlat,nsig),vpcon4(nlat,nsig))
   allocate(varsst4(nlat,nlon),corlsst4(nlat,nlon))
   allocate(tcon4(nlat,nsig,nsig))
   allocate(psvar4(nlat),pshln4(nlat))

! Load single precision arrays for visualization
   do k=1,nsig
     do i=1,nlat
       sfvar4(i,k)=sfvar(i,k)
       vpvar4(i,k)=vpvar(i,k)
       tvar4(i,k)=tvar(i,k)
       nrhvar4(i,k)=nrhvar(i,k)
       qvar4(i,k)=qvar(i,k)
       if (hydromet) then
          qivar4(i,k)=qivar(i,k)
          qlvar4(i,k)=qlvar(i,k)
          qrvar4(i,k)=qrvar(i,k)
          qsvar4(i,k)=qsvar(i,k)
       else
          qivar4(i,k)=0.0
          qlvar4(i,k)=0.0
          qrvar4(i,k)=0.0
          qsvar4(i,k)=0.0
       endif
       cvar4(i,k)=cvar(i,k)
       ozvar4(i,k)=ozvar(i,k)

       sfhln4(i,k)=sfhln(i,k)
       vphln4(i,k)=vphln(i,k)
       thln4(i,k)=thln(i,k)
       qhln4(i,k)=qhln(i,k)
       if (hydromet) then
          qihln4(i,k)=qihln(i,k)
          qlhln4(i,k)=qlhln(i,k)
          qrhln4(i,k)=qrhln(i,k)
          qshln4(i,k)=qshln(i,k)
       else
          qihln4(i,k)=0.0
          qlhln4(i,k)=0.0
          qrhln4(i,k)=0.0
          qshln4(i,k)=0.0
       endif
       chln4(i,k)=chln(i,k)
       ozhln4(i,k)=ozhln(i,k)

       sfvln4(i,k)=1./sfvln(i,k)
       vpvln4(i,k)=1./vpvln(i,k)
       tvln4(i,k)=1./tvln(i,k)
       qvln4(i,k)=1./qvln(i,k)
       if (hydromet) then
          qivln4(i,k)=1./qivln(i,k)
          qlvln4(i,k)=1./qlvln(i,k)
          qrvln4(i,k)=1./qrvln(i,k)
          qsvln4(i,k)=1./qsvln(i,k)
       else
          qivln4(i,k)=0.0
          qlvln4(i,k)=0.0
          qrvln4(i,k)=0.0
          qsvln4(i,k)=0.0
       endif
       cvln4(i,k)=1./cvln(i,k)
       ozvln4(i,k)=1./ozvln(i,k)

     end do
   end do
   do i=1,nlat
     psvar4(i)=psvar(i)
     pshln4(i)=pshln(i)
   end do
   do j=1,nlon
     do i=1,nlat
       varsst4(i,j)=varsst(i,j)
       corlsst4(i,j)=corlsst(i,j)
     end do
   end do
   do m=1,nsig
     do k=1,nsig
       do i=1,nlat
         tcon4(i,k,m)=tcon(i,k,m)
       end do
     end do
   end do
   do k=1,nsig
     do i=1,nlat
       pscon4(i,k)=pscon(i,k)
       vpcon4(i,k)=vpcon(i,k)
     end do
   end do

! CREATE SINGLE PRECISION BYTE-ADDRESSABLE FILE FOR GRADS
! OF LATIDUDE DEPENDENT VARIABLES
   grdfile='bgstats_sp.grd'
   ncfggg=len_trim(grdfile)
   call baopenwt(22,grdfile(1:ncfggg),iret)
   call wryte(22,4*nlat*nsig,sfvar4)
   call wryte(22,4*nlat*nsig,vpvar4)
   call wryte(22,4*nlat*nsig,tvar4)
   call wryte(22,4*nlat*nsig,qvar4)
   call wryte(22,4*nlat*nsig,nrhvar4)
   call wryte(22,4*nlat*nsig,qivar4)
   call wryte(22,4*nlat*nsig,qlvar4)
   call wryte(22,4*nlat*nsig,qrvar4)
   call wryte(22,4*nlat*nsig,qsvar4)
   call wryte(22,4*nlat*nsig,ozvar4)
   call wryte(22,4*nlat*nsig,cvar4)
   call wryte(22,4*nlat,psvar4)
   call wryte(22,4*nlat*nsig,sfhln4)
   call wryte(22,4*nlat*nsig,vphln4)
   call wryte(22,4*nlat*nsig,thln4)
   call wryte(22,4*nlat*nsig,qhln4)
   call wryte(22,4*nlat*nsig,qihln4)
   call wryte(22,4*nlat*nsig,qlhln4)
   call wryte(22,4*nlat*nsig,qrhln4)
   call wryte(22,4*nlat*nsig,qshln4)
   call wryte(22,4*nlat*nsig,ozhln4)
   call wryte(22,4*nlat*nsig,chln4)
   call wryte(22,4*nlat,pshln4)
   call wryte(22,4*nlat*nsig,sfvln4)
   call wryte(22,4*nlat*nsig,vpvln4)
   call wryte(22,4*nlat*nsig,tvln4)
   call wryte(22,4*nlat*nsig,qvln4)
   call wryte(22,4*nlat*nsig,qivln4)
   call wryte(22,4*nlat*nsig,qlvln4)
   call wryte(22,4*nlat*nsig,qrvln4)
   call wryte(22,4*nlat*nsig,qsvln4)
   call wryte(22,4*nlat*nsig,ozvln4)
   call wryte(22,4*nlat*nsig,cvln4)
   call wryte(22,4*nlat*nsig*nsig,tcon4)
   call wryte(22,4*nlat*nsig,vpcon4)
   call wryte(22,4*nlat*nsig,pscon4)
   call baclose(22,iret)

! CREATE SINGLE PRECISION BYTE-ADDRESSABLE FILE FOR GRADS
! OF SST STATISTICS
   grdfile='sststats_sp.grd'
   ncfggg=len_trim(grdfile)
   call baopenwt(23,grdfile(1:ncfggg),iret)
   call wryte(23,4*nlat*nlon,varsst4)
   call wryte(23,4*nlat*nlon,corlsst4)
   call baclose(23,iret)

   deallocate(tcon4)
   deallocate(sfvar4,vpvar4,tvar4,qvar4,qivar4,qlvar4,qrvar4,qsvar4,cvar4,nrhvar4,sfhln4,&
              vphln4,thln4,qhln4,qihln4,qlhln4,qrhln4,qshln4,chln4,sfvln4,vpvln4,tvln4,&
              qvln4,qivln4,qlvln4,qrvln4,qsvln4,cvln4,vpcon4,pscon4,varsst4,corlsst4, &
              ozvar4,ozhln4,ozvln4)
   deallocate(psvar4,pshln4)

  call destroy_sstvars

 return
 end subroutine writefiles

end module postmod


PROGRAM aa2xyz

  implicit none

  real(8) :: ax,aa(3,3),aa_tmp(3,3),aa_inv(3,3)
  character(len=8) :: cbuf
  integer,parameter :: u0=5, u1=1
  integer :: natom, nelem
  real(8),allocatable :: aa_atom(:,:), xyz_atom(:,:)
  integer,allocatable :: ki_atom(:), mi_atom(:), zi_atom(:)
  integer :: i

  rewind u0

  read(u0,*) cbuf, ax
  read(u0,*) cbuf, aa(1:3,1)
  read(u0,*) cbuf, aa(1:3,2)
  read(u0,*) cbuf, aa(1:3,3)
  read(u0,*) cbuf

  read(u0,*) nelem, natom

  allocate( xyz_atom(3,natom) ) ; xyz_atom=0.0d0
  allocate( aa_atom(3,natom)  ) ; aa_atom=0.0d0
  allocate( ki_atom(natom)    ) ; ki_atom=0
  allocate( mi_atom(natom)    ) ; mi_atom=0
  allocate( zi_atom(nelem)    ) ; zi_atom=0

  backspace(u0)

  read(u0,*) nelem, natom, zi_atom(1:nelem)
  do i=1,natom
     read(u0,*) ki_atom(i), aa_atom(:,i), mi_atom(i)
  end do

  aa_tmp = ax*aa
  call get_inverse_lattice( aa_tmp, aa_inv )

  if ( cbuf == "XYZ" ) then
     xyz_atom = aa_atom
     aa_atom  = matmul( aa_inv, xyz_atom )
  else if ( cbuf == "AA" ) then
     xyz_atom = matmul( aa_tmp, aa_atom )
  else
     stop "error!"
  end if

  open(u1,file="atomic_coordinates_aa")
  write(u1,'("AX",1f20.15)') ax
  write(u1,'("A1",3f20.15)') aa(:,1)
  write(u1,'("A2",3f20.15)') aa(:,2)
  write(u1,'("A3",3f20.15)') aa(:,3)
  write(u1,'("AA")')
  write(u1,*) nelem, natom, zi_atom(1:nelem), " /"
  do i=1,natom
     write(u1,'(1x,i5,3f20.12,i4)') ki_atom(i), aa_atom(:,i), mi_atom(i)
  end do
  close(u1)

  open(u1,file="atomic_coordinates_xyz")
  write(u1,'("AX",1f20.15)') ax
  write(u1,'("A1",3f20.15)') aa(:,1)
  write(u1,'("A2",3f20.15)') aa(:,2)
  write(u1,'("A3",3f20.15)') aa(:,3)
  write(u1,'("XYZ")')
  write(u1,*) nelem, natom, zi_atom(1:nelem), " /"
  do i=1,natom
     write(u1,'(1x,i5,3f20.12,i4)') ki_atom(i), xyz_atom(:,i), mi_atom(i)
  end do
  close(u1)

END PROGRAM aa2xyz

SUBROUTINE get_inverse_lattice( a, ainv )
  implicit none
  real(8),intent(IN)  :: a(3,3)
  real(8),intent(OUT) :: ainv(3,3)
  real(8) :: b(3,3), v
  b(1,1) = a(2,2)*a(3,3) - a(3,2)*a(2,3)
  b(2,1) = a(3,2)*a(1,3) - a(1,2)*a(3,3)
  b(3,1) = a(1,2)*a(2,3) - a(2,2)*a(1,3)
  b(1,2) = a(2,3)*a(3,1) - a(3,3)*a(2,1)
  b(2,2) = a(3,3)*a(1,1) - a(1,3)*a(3,1)
  b(3,2) = a(1,3)*a(2,1) - a(2,3)*a(1,1)
  b(1,3) = a(2,1)*a(3,2) - a(3,1)*a(2,2)
  b(2,3) = a(3,1)*a(1,2) - a(1,1)*a(3,2)
  b(3,3) = a(1,1)*a(2,2) - a(2,1)*a(1,2)
  call calc_Volume( a, v )
  ainv(:,:) = transpose( b(:,:) )/v
END SUBROUTINE get_inverse_lattice

SUBROUTINE calc_Volume( aa, Va )
  implicit none
  real(8),intent(IN)  :: aa(3,3)
  real(8),intent(OUT) :: Va
  Va = aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1) &
      +aa(1,3)*aa(2,1)*aa(3,2)-aa(1,3)*aa(2,2)*aa(3,1) &
      -aa(1,2)*aa(2,1)*aa(3,3)-aa(1,1)*aa(2,3)*aa(3,2)
END SUBROUTINE calc_Volume


 subroutine cross_sections_Raman_1cm_init( &
    maxlay,          temp,            jmax,            &
    nsmax,           wavelength_ns,   wavenr_ns,       &
    relN2,           relO2,           linestr_Sto_N2,  &
    linestr_aSt_N2,  linestr_Sto_O2,  linestr_aSt_O2,  &
    dwn_Sto_N2,      dwn_aSt_N2,      dwn_Sto_O2,      &
    dwn_aSt_O2,      csram_Sto_N2,    csram_aSt_N2,    &
    csram_Sto_O2,    csram_aSt_O2)

!-----------------------------------------------------------
! Subroutine:
!    csram1cminit
!
! Purpose:
!    Calculate Raman cross section for
!    N2, O2 and air
!------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

! nr of wavelengths
  integer,intent(in):: &
     jmax,  &  !maximum rotational quantum number J (=50 suffices)
     nsmax, &
     maxlay

! wavelengths around incident light (ns_elas) [nm]
  real(kind=dp):: &
    wavelength_ns(0:nsmax), &
    wavenr_ns(0:nsmax)

  real(kind=dp),intent(in):: &
    relN2, & !N2 volume mixing ratio
    relO2, & !O2 volume mixing ratio
    temp(maxlay) !temperature [k] each layer

 real(kind=dp),dimension(0:nsmax):: &
    rn_N2,      & !refraction index of N2
    rn_O2         !refraction index of O2

  real(kind=dp):: &
    Wcm,        & !wavelengthlength [cm]
    WNmu,       & !1/wavelengthlength [um-1]
    frac_rn_N2, &
    frac_rn_O2, &
    rn_N2m1,    &
    rn_O2m1,    &
    fk_N2,      & !king factor
    fk_O2,      &
    dens,       &
    alpha2_N2,  &
    alpha2_O2,  &
    elasfac_N2, &
    elasfac_O2, &
    factor_N2,  &
    factor_O2,  &
    Ej_N2,      &
    Ej_O2,      &
    scale_N2,   &
    scale_O2,   &
    statesum_N2, &
    statesum_O2, &
    linestrnorm_N2, &
    linestrnorm_O2

! parametrization of refraction index of N2 and O2 ( Bates 1984 )
  real(kind=dp):: &
     a_N2(3),   &
     b_N2(3),   &
     a_O2(4),   &
     b_O2(4)
  data &
     a_N2 / 6855.200d0,  5989.242d0,  6998.749d0             /, &
     b_N2 / 3243157.0d0, 3363266.3d0, 3233582.0d0            /, &
     a_O2 / 21351.1d0,   20564.8d0,   22120.4d0,  23796.7d0  /, &
     b_O2 / 218567.0d0,  248089.9d0,  203187.6d0, 168988.4d0 /

! RLOSCH = AVOGA/V_MOL Loschmidt constant [part. cm-3]
! AVOGA                Avogadro constant [part. mol-1]
! boltz  = Rgas/AVOGA    Boltzmann constant [J K-1]
! Rgas                   molar gas constant [J K-1 mol-1]
  real(kind=dp),parameter::    &
     pi       = 3.141592653589793115997963468544d0, &
     temp_std = 273.15d0,       &  !standard temperature [K]
     dair     = 2.5474d+19,     &  !molar nrdensity air [part. cm-3]
     rlosch   = 2.686777d+19,   &  ![part. cm-3]
     avoga    = 6.0221419d+23 , &  ![part. mol-1]
     V_MOL    = 22.41399d-3,    &  ![m3 mol-1]
     boltz    = 1.380650d-23,   &  ![J K-1]
     Rgas     = 8.314472d0,     &  ![J K-1 mol-1]
     C_light  = 2.9979245d+08,  &  ![m s-1]
     h_Planck = 6.6260687d-34,  &  ![js]
     hc       = h_Planck * c_light

! quantum rotational constants
  real(kind=dp):: &
     b0_N2, &
     b0_O2, &
     d0_N2, &
     d0_O2

! Penney et al, 1974, joiner OMI ATBM 2005]
  data &
     b0_N2 /1.989d+02/, & ![1/m] Be-ae*(v+0.5)
     b0_O2 /1.437d+02/, & ![1/m]
     d0_N2 /5.760d-04/, & ![1/m].de+be*(v+0.5) centrifugal const.
     d0_O2 /4.852d-04/    ![1/m]

  integer::ni,ns,j,k,ind_N2,ind_O2

  real(kind=dp),dimension(0:nsmax):: &
     eps_N2,   &  !epsilon for N2
     eps_O2       !epsilon for O2

  real(kind=dp),dimension(0:nsmax):: &
     gamma2_N2, & !pol. anisotropies gamma^2 for N2
     gamma2_O2    !pol. anisotropies gamma^2 for O2

  real(kind=dp):: &
      facnorm_N2, &   !normalization factor for N2
      facnorm_O2, &   !normalization factor for O2
      wt_N2(0:jmax),  &   !overlap weights for N2
      wt_O2(0:jmax)       !overlap weights for O2

  real(kind=dp):: &          !Placzek-Teller coeff. sec. index
      CPT(0:jmax+2,2),  &    !1:  CPT(j-> j+2), 2: CPT(j-> j-2)
      fac_N2(0:jmax+2,maxlay),& !statistical weight for N2
      fac_O2(0:jmax+2,maxlay),& !statistical weight for O2
      dwn_Sto_N2(0:jmax),     &    !wavenumber shift for N2 [cm^-1]
      dwn_aSt_N2(0:jmax),    &      !wavenumber shift for O2 [cm^-1]
      dwn_Sto_O2(0:jmax), &
      dwn_aSt_O2(0:jmax)

  integer:: &
      gj_N2(0:jmax+2), &  !statistical weights for N2
      gj_O2(0:jmax+2), &  !statistical weights for O2
      nf_N2(0:jmax), &    !assign index for N2
      nf_O2(0:jmax)      !assign index for O2

  real(kind=dp),intent(out):: &
      linestr_Sto_N2(0:jmax,maxlay), & !N2 Stokes
      linestr_aSt_N2(0:jmax,maxlay), & !N2 anti-Stokes
      linestr_Sto_O2(0:jmax,maxlay), & !O2 Stokes
      linestr_aSt_O2(0:jmax,maxlay)    !O2 anti-Stokes

  real(kind=dp):: &
      csray_N2(0:nsmax), & !N2 Rayleigh cross section
      csray_O2(0:nsmax), & !O2 Rayleigh cross section
      cscab_N2(0:nsmax), & !N2 Cabannes cross section
      cscab_O2(0:nsmax)    !O2 Cabannes cross section

  real(kind=dp),intent(out):: &
      csram_Sto_N2(maxlay,0:jmax,0:nsmax), & !N2 Stokes
      csram_aSt_N2(maxlay,0:jmax,0:nsmax), & !N2 anti-Stokes
      csram_Sto_O2(maxlay,0:jmax,0:nsmax), & !O2 Stokes
      csram_aSt_O2(maxlay,0:jmax,0:nsmax)    !O2 anti-Stokes

  logical,parameter::energy_conservation = .true.

!---------------------------------------------------
!            Cabannes
!               |
!      Stokes   |  anti-
!               |  Stokes
!           |   |
!         | | | |   |       Rayleigh = Cabannes+Raman
!       | | | | | | | | |
!
!               --> wavenr
!---------------------------------------------------

! TODO:
! - Improve calculation of absolute linestrength
!   Absolute values of Raman cross sections are
!   not correct yet
! - Allow more complicated calculation of
!   Placzeck-Teller coefficient for O2

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

  do ns=0,nsmax

     WNmu = (1.d+07/wavelength_ns(ns)) * 1.d-4

!    king correction factor
     fk_N2 = 1.034d0 + 3.17d-4 * WNmu**2
     fk_O2 = 1.096d0 + 1.385d-03*WNmu**2 + 1.448d-4*WNmu**4

!    anisotropic polarizability factor eps
     eps_N2(ns) = 9.d0/2.d0 * (fk_N2-1.d0)
     eps_O2(ns) = 9.d0/2.d0 * (fk_O2-1.d0)

!    refraction index of N2  (n(N2)-1) [Bates1984]
     ni = 1
     if(wavelength_ns(ns).lT.468.d0) ni = 2
     if(wavelength_ns(ns).lT.254.d0) ni = 3
     rn_N2m1   = (a_N2(ni) + b_N2(ni)/(144.d0-WNmu**2))*1.d-08
     rn_N2(ns) = 1.d0 + rn_N2m1

!    refraction index of O2  (n(O2)-1) [Bates1984]
     ni = 1
     if(wavelength_ns(ns).lT.546.d0)  ni = 2
     if(wavelength_ns(ns).lT.288.d0)  ni = 3
     if(wavelength_ns(ns).lT.221.d0)  ni = 4
     rn_O2m1  = (a_O2(ni) + b_O2(ni)/(40.90d0-WNmu**2))*1.d-08
     rn_O2(ns) = 1.d0 + rn_O2m1

!    (n**2-1)/(n**2+2)
     frac_rn_N2 = (rn_N2(ns)**2-1.d0)**2/(rn_N2(ns)**2+2.d0)**2
     frac_rn_O2 = (rn_O2(ns)**2-1.d0)**2/(rn_O2(ns)**2+2.d0)**2

!    square of average polarizability alpha
     alpha2_N2 = RN_N2m1**2/(2.d0*pi*RLOSCH)**2
     alpha2_O2 = RN_O2m1**2/(2.d0*pi*RLOSCH)**2

!    square of polarizability anisotropy gamma
     gamma2_N2(ns) = eps_N2(ns)*alpha2_N2
     gamma2_O2(ns) = eps_O2(ns)*alpha2_O2

!    Dair is given for 15 degree Celius
!    scale to standard temp T = 273.15 K because of refractive index
     dens = (288.16d0/temp_std) * Dair

     Wcm = wavelength_ns(ns) * 1.d-7 !change units nm -> cm

!    Rayleigh cross sections
     csray_N2(ns) = 24.d0*pi**3/(Wcm**4*dens**2)*frac_rn_N2*fk_N2
     csray_O2(ns) = 24.d0*pi**3/(Wcm**4*dens**2)*frac_rn_O2*fk_O2

!    Elastic scattering fraction
     elasfac_N2 = (18.d0+eps_N2(ns))/(18.d0+4.d0*eps_N2(ns))
     elasfac_O2 = (18.d0+eps_O2(ns))/(18.d0+4.d0*eps_O2(ns))

!    Cabannes cross sections
     cscab_N2(ns) = elasfac_N2 * csray_N2(ns)
     cscab_O2(ns) = elasfac_O2 * csray_O2(ns)

  enddo

!---------------------------------------------------------------------
! Statistical weights
!---------------------------------------------------------------------

  do j = 0,jmax+2
     if(2*int(j/2).eq.j)then !even
        gj_N2(j) = 6
        gj_O2(j) = 0
     else                    !odd
        gj_N2(j) = 3
        gj_O2(j) = 1
     endif
  enddo

!---------------------------------------------------------------------
! Placzek-Teller coefficients
! Assume N2 and O2 molecules are simple linear rotors
!---------------------------------------------------------------------

  do j = 0,jmax+2
     CPT(j,1) = dble(3*(j+1)*(j+2))/dble(2*(2*J+1)*(2*j+3))
     CPT(j,2) = dble(3*j*(j-1))    /dble(2*(2*j-1)*(2*j+3))
  enddo

!----------------------------------------------------------------------
! Population of rotational levels, wavenumber shifts
!----------------------------------------------------------------------

  do k = 1,maxlay

!    Approximation (Penney, 1973) using I nuclear spin = 1, 0 for N2, O2
     statesum_N2 = boltz*temp(k)*(2.d0*1.d0+1.d0)**2/(2.d0*hc*b0_N2)
     statesum_O2 = boltz*temp(k)*(2.d0*0.d0+1.d0)**2/(2.d0*hc*b0_O2)

     facnorm_N2 = 0.d0
     facnorm_O2 = 0.d0

     do j = 0,jmax+2

        Ej_N2 = b0_N2 * hc * dble(j)*dble(j+1) - &
                d0_N2 * hc * dble(j)**2.d0*dble(j+1)**2.d0
        Ej_O2 = b0_O2 * hc * dble(j)*dble(j+1) - &
                d0_O2 * hc * dble(j)**2.d0*dble(j+1)**2.d0

        fac_N2(j,k) = exp(-Ej_N2/(boltz*temp(k)))
        fac_O2(j,k) = exp(-Ej_O2/(boltz*temp(k)))

        facnorm_N2 = facnorm_N2 + &
                      dble(gj_N2(j))*dble(2*j+1)*fac_N2(j,k)

        facnorm_O2 = facnorm_O2 + &
                      dble(gj_O2(j))*dble(2*j+1)*fac_O2(j,k)

     enddo

!    Better to divide by statesum than by facnorm?
     do j = 0,jmax+2
        fac_N2(j,k) = dble(gj_N2(j))*dble(2*j+1)*fac_N2(j,k)/facnorm_N2   !/statesum_N2
        fac_O2(j,k) = dble(gj_O2(j))*dble(2*j+1)*fac_O2(j,k)/facnorm_O2   !/statesum_O2
     enddo

  enddo

!----------------------------------------------------------------------
! Remove part of above
! convert m-1 to cm-1
!----------------------------------------------------------------------

! Stokes energy shift Eq.(1.5) thesis
! lower final energy state, negative wavenrshifts

  do j=0,jmax
     dwn_Sto_N2(j) = -(4.d0*b0_N2-6.d0*d0_N2)*(dble(j)+1.5d0) + &
                       8.d0*d0_N2 * (dble(j)+1.5d0)**3
     dwn_Sto_O2(j) = -(4.d0*b0_O2-6.d0*d0_O2)*(dble(j)+1.5d0) + &
                       8.d0*d0_O2 * (dble(j)+1.5d0)**3

     dwn_Sto_N2(j) = 1.d-2 * dwn_Sto_N2(j)
     dwn_Sto_O2(j) = 1.d-2 * dwn_Sto_O2(j)
  enddo

! Anti-Stokes energy shifts Eq.(1.4) thesis
! higher final energy state, postive wavenrshifts
! save in array(0:jmax) by shifting index j -> j-2

  do j=2,jmax+2
     dwn_aSt_N2(j-2) = (4.d0*b0_N2-6.d0*d0_N2)*(dble(j)-0.5d0) - &
                        8.d0*d0_N2 * (dble(j)-0.5d0)**3
     dwn_aSt_O2(j-2) = (4.d0*b0_O2-6.d0*d0_O2)*(dble(j)-0.5d0) - &
                        8.d0*d0_O2 * (dble(j)-0.5d0)**3

     dwn_aSt_N2(j-2) = 1.d-2 * dwn_aSt_N2(j-2)
     dwn_aSt_O2(j-2) = 1.d-2 * dwn_aSt_O2(j-2)
  enddo

!----------------------------------------------------------------------
! The closest wavelength pixel of the 1 cm-1 grid wavelength to
! the Stokes or anti-Stokes lines  is indicated by ind(dwn+0.5)
! because of the equally spaced grid
!----------------------------------------------------------------------

  k = maxlay

  do j = 0,jmax

     ind_N2 = int(dwn_Sto_N2(j)+0.5d0)
     ind_O2 = int(dwn_Sto_O2(j)+0.5d0)

     if(dwn_Sto_N2(j).le.dble(ind_N2))then
        nf_N2(j) = ind_N2-1
        wt_N2(j) = ind_N2-dwn_Sto_N2(j)
     else
        nf_N2(j) = ind_N2
        wt_N2(j) = ind_N2-dwn_Sto_N2(j)+1
     endif

     if(dwn_Sto_O2(j).le.dble(ind_O2))then
        nf_O2(j) = ind_O2-1
        wt_O2(j) = ind_O2-dwn_Sto_O2(j)
     else
        nf_O2(j) = ind_O2
        wt_O2(j) = ind_O2-dwn_Sto_O2(j)+1
     endif

  enddo

!----------------------------------------------------------------------
! Linestrengths belonging to dwn and nf grid 0..jmax
!----------------------------------------------------------------------

  do k = 1,maxlay

     linestrnorm_N2 = 0.d0
     linestrnorm_O2 = 0.d0

     do j = 0,jmax

        linestr_Sto_N2(j,k) = fac_N2(j,k)   * CPT(j,1)
        linestr_Sto_O2(j,k) = fac_O2(j,k)   * CPT(j,1)
        linestr_aSt_N2(j,k) = fac_N2(j+2,k) * CPT(j+2,2)
        linestr_aSt_O2(j,k) = fac_O2(j+2,k) * CPT(j+2,2)

        linestrnorm_N2 = linestrnorm_N2 + &
                         linestr_Sto_N2(j,k) + linestr_aSt_N2(j,k)

        linestrnorm_O2 = linestrnorm_O2 + &
                         linestr_Sto_O2(j,k) + linestr_aSt_O2(j,k)
     enddo

     if((linestrnorm_N2.ne.0.d0).and.(linestrnorm_O2.ne.0.d0))then
         do j = 0,jmax
            linestr_Sto_N2(j,k) = linestr_Sto_N2(j,k) / linestrnorm_N2
            linestr_Sto_O2(j,k) = linestr_Sto_O2(j,k) / linestrnorm_O2
            linestr_aSt_N2(j,k) = linestr_aSt_N2(j,k) / linestrnorm_N2
            linestr_aSt_O2(j,k) = linestr_aSt_O2(j,k) / linestrnorm_O2
         enddo
     endif

  enddo

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

 goto 222

 ! N2
 do j=jmax,0,-1
    write(*,'(4I6,F16.8,d24.16)') &
       j,-nf_N2(j),maxlay,j,-dwn_Sto_N2(j),linestr_Sto_N2(j,maxlay)
 enddo
 do j=0,jmax
    write(*,'(4I6,F16.8,d24.16)') &
       j, nf_N2(j),1,j, dwn_Sto_N2(j),linestr_aSt_N2(j,maxlay)
 enddo

 ! O2
 do j=jmax,0,-1
    write(*,'(4I6,F16.8,d24.16)') &
       j,-nf_O2(j),maxlay,j,-dwn_Sto_O2(j),linestr_Sto_O2(j,maxlay)
 enddo
 do j=0,jmax
    write(*,'(4I6,F16.8,d24.16)') &
       j, nf_O2(j),maxlay,j, dwn_Sto_O2(j), linestr_aSt_O2(j,maxlay)
 enddo

222 continue

!----------------------------------------------------------------------
! Raman cross sections
! csram = 256/27 * pi**5 * (nu+dnu)**4 * linestr * gamma**2
!----------------------------------------------------------------------

  do ns=0,nsmax

     factor_N2 = 256.d0 * pi**5 / 27.d0 * gamma2_N2(ns)
     factor_O2 = 256.d0 * pi**5 / 27.d0 * gamma2_O2(ns)

     do j = 0,jmax
        do k = 1,maxlay
           csram_Sto_N2(k,j,ns) = factor_N2 * &
                                   linestr_Sto_N2(j,k) * &
                                    (wavenr_ns(ns)+dwn_Sto_N2(j))**4

           csram_aSt_N2(k,j,ns) = factor_N2 * &
                                   linestr_aSt_N2(j,k) * &
                                    (wavenr_ns(ns)+dwn_aSt_N2(j))**4

           csram_Sto_O2(k,j,ns) = factor_O2 * &
                                   linestr_Sto_O2(j,k) * &
                                    (wavenr_ns(ns)+dwn_Sto_O2(j))**4

           csram_aSt_O2(k,j,ns) = factor_O2 * &
                                   linestr_aSt_O2(j,k) * &
                                    (wavenr_ns(ns)+dwn_aSt_O2(j))**4
        enddo
     enddo
  enddo

!----------------------------------------------------------------------
! Make sure that
! cscab + sum(csram) = csray
!----------------------------------------------------------------------

  if(energy_conservation)then

     do ns=0,nsmax

!       Elastic scattering fraction
        elasfac_N2 = (18.d0+eps_N2(ns))/(18.d0+4.d0*eps_N2(ns))
        elasfac_O2 = (18.d0+eps_O2(ns))/(18.d0+4.d0*eps_O2(ns))

        do k=1,maxlay

           scale_N2 = 0.d0
           scale_O2 = 0.d0

           do j=0,jmax

              scale_N2 = scale_N2 + &
                          (csram_Sto_N2(k,j,ns) + csram_aSt_N2(k,j,ns)) &
                            / csray_N2(ns)

              scale_O2 = scale_O2 + &
                          (csram_Sto_O2(k,j,ns) + csram_aSt_O2(k,j,ns)) &
                            / csray_O2(ns)
           enddo

           !write(*,*) k,'scale_N2 = ',scale_N2
           !write(*,*) k,'scale_O2 = ',scale_O2

           do j = 0,jmax
              csram_Sto_N2(k,j,ns) = csram_Sto_N2(k,j,ns)/scale_N2 * &
                                      (1.d0-elasfac_N2)
              csram_aSt_N2(k,j,ns) = csram_aSt_N2(k,j,ns)/scale_N2 * &
                                      (1.d0-elasfac_N2)
              csram_Sto_O2(k,j,ns) = csram_Sto_O2(k,j,ns)/scale_O2 * &
                                      (1.d0-elasfac_O2)
              csram_aSt_O2(k,j,ns) = csram_aSt_O2(k,j,ns)/scale_O2 * &
                                      (1.d0-elasfac_O2)
           enddo

        enddo

     enddo

  endif

  return
  end subroutine cross_sections_Raman_1cm_init


      SUBROUTINE GEOTRN(MODE, XIN, EIN, DIN, EOUT, DOUT)                ABSH0495
C***********************************************************************ABSH0496
C*****GEOTRN TRANSFORMS ELONGATION AND TRIANGULARITY FROM A MOMENTS TO *ABSH0497
C*****A GEOMETRICAL REPRESENTATION AND VICE VERSA.                     *ABSH0498
C*****REFERENCES:                                                      *ABSH0499
C*****L.L.LAO,S.P.HIRSHMAN,R.M.WIELAND,ORNL/TM-7616 (1981).            *ABSH0500
C*****                                ,PHYS FLUIDS 24 (1981) AUG       *ABSH0501
C*****L.L.LAO,R.M.WIELAND,W.A.HOULBERG,S.P.HIRSHMAN,ORNL/TM-7871 (1981)*ABSH0502
C*****LAST REVISION: 6/81 L.L.LAO, R.M.WIELAND, AND W.A.HOULBERG ORNL. *ABSH0503
C*****CALCULATED PARAMETERS:                                           *ABSH0504
C*****EOUT-OUTPUT ELONGATION.                                          *ABSH0505
C*****DOUT-OUTPUT TRIANGULARITY.                                       *ABSH0506
C*****INPUT PARAMETERS:                                                *ABSH0507
C*****MODE-DESIGNATES DIRECTION OF TRANSFORMATION.                     *ABSH0508
C*****    =1 GEOMETRICAL => MOMENTS.                                   *ABSH0509
C*****    =2 MOMENTS => GEOMETRICAL.                                   *ABSH0510
C*****XIN-INPUT REDUCED MINOR RADIUS                                   *ABSH0511
C*****EIN-INPUT ELONGATION.                                            *ABSH0512
C*****DIN-INPUT TRIANGULARITY.                                         *ABSH0513
C***********************************************************************ABSH0514
      IF (XIN.LE.0.0) GO TO 30                                          ABSH0515
      IF (MODE.EQ.2) GO TO 20                                           ABSH0516
C*****GEOMETRICAL ==> MOMENTS REPRESENTATION.                           ABSH0517
      DOUT = DIN/4.0                                                    ABSH0518
      CTC = 0.0                                                         ABSH0519
      DO 10 I=1,10                                                      ABSH0520
           CTC = 4.0*DOUT/(SQRT(XIN**2+32.0*DOUT**2)+XIN)               ABSH0521
           DOUT = XIN*DIN/(4.0-6.0*CTC**2)                              ABSH0522
   10 CONTINUE                                                          ABSH0523
      EOUT = XIN*EIN/(SQRT(1.0-CTC*CTC)*(XIN+2.0*DOUT*CTC))             ABSH0524
      RETURN                                                            ABSH0525
C*****MOMENTS ==> GEOMETRICAL REPRESENTATION.                           ABSH0526
   20 CTC = 4.0*DIN/(SQRT(XIN**2+32.0*DIN**2)+XIN)                      ABSH0527
      STC = SQRT(1.0-CTC*CTC)                                           ABSH0528
      S2TC = 2.0*STC*CTC                                                ABSH0529
      C2TC = 2.0*CTC*CTC - 1.0                                          ABSH0530
      EOUT = EIN*(XIN*STC+DIN*S2TC)/XIN                                 ABSH0531
      DOUT = DIN*(1.0-3.0*C2TC)/XIN                                     ABSH0532
      RETURN                                                            ABSH0533
   30 EOUT = EIN                                                        ABSH0534
      DOUT = DIN                                                        ABSH0535
      RETURN                                                            ABSH0536
      END                                                               ABSH0537


c***************************************************************************
c			TU4_GETACCB.F
c*************************************************************************
c GETACCB returns the bary. acc. on each of n mutually
c interacting objects by direct pairwise summation
c
c
c             Input:
c                 nbod          ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of planets (real array)
c                 j2rp2,j4rp4   ==>  J2*radii_pl^2 and  J4*radii_pl^4
c                                     (real scalars)
c                 xb,yb,zb      ==>  position of planets in beri coord
c                                    (real arrays)
c             Output:
c               axb,ayb,azb   ==>  accel in beri coord (real arrays)
c
c Remarks:  Based on Martin's NB4M routines
c Authors:  Martin Duncan
c Date:    3/8/93
c Last revision: 4/5/95

      subroutine tu4_getaccb(nbod,mass,j2rp2,j4rp4,xb,yb,zb,axb,ayb,azb)

      include '../swift.inc'

c...  Inputs Only:
      integer nbod
      real*8 mass(nbod),j2rp2,j4rp4
      real*8 xb(nbod),yb(nbod),zb(nbod)

c...  Output
      real*8 axb(nbod),ayb(nbod),azb(nbod)

c...  Internals
      real*8 xx,yy,zz,rr2,fac,mi,mj
      real*8 axx,ayy,azz,fac1
      real*8 xh(NPLMAX),yh(NPLMAX),zh(NPLMAX),irh(NPLMAX)
      real*8 aoblx(NPLMAX),aobly(NPLMAX),aoblz(NPLMAX)
      integer i,j

c----
c...  executable code

      xh(1) = 0.0d0
      yh(1) = 0.0d0
      zh(1) = 0.0d0

c...  do sun part first
      axb(1) = 0.0d0
      ayb(1) = 0.0d0
      azb(1) = 0.0d0
      i = 1
      do j = i+1,nbod
         mi = mass(i)
         mj = mass(j)
         xx = xb(i) - xb(j)
         yy = yb(i) - yb(j)
         zz = zb(i) - zb(j)
         rr2 = xx**2 + yy**2 + zz**2

         fac1 = 1.d0/sqrt(rr2)
         fac = fac1/rr2
c         if (j.eq.2) write(*,*) fac, rr2, xx , yy , zz

c..      save for the J2 and J4 calculations
         xh(j) = -xx
         yh(j) = -yy
         zh(j) = -zz
         irh(j) = fac1

         axx = xx*fac
         ayy = yy*fac
         azz = zz*fac
         axb(i) = axb(i) - axx*mj
         ayb(i) = ayb(i) - ayy*mj
         azb(i) = azb(i) - azz*mj
         axb(j) =   axx*mi
         ayb(j) =   ayy*mi
         azb(j) =   azz*mi
      enddo

      do i = 2,nbod-1
         do j = i+1,nbod
            mi = mass(i)
            mj = mass(j)
            xx = xb(i) - xb(j)
            yy = yb(i) - yb(j)
            zz = zb(i) - zb(j)
            rr2 = xx**2 + yy**2 + zz**2
            fac = 1.d0/(rr2*sqrt(rr2))
            axx = xx*fac
            ayy = yy*fac
            azz = zz*fac
            axb(i) = axb(i) - axx*mj
            ayb(i) = ayb(i) - ayy*mj
            azb(i) = azb(i) - azz*mj
            axb(j) = axb(j) + axx*mi
            ayb(j) = ayb(j) + ayy*mi
            azb(j) = azb(j) + azz*mi
         enddo
      enddo

      if(j2rp2.ne.0.0d0) then
         call obl_acc(nbod,mass,j2rp2,j4rp4,xh,yh,zh,irh,
     &        aoblx,aobly,aoblz)
         do i = 1,nbod
            axb(i) = axb(i) + aoblx(i)
            ayb(i) = ayb(i) + aobly(i)
            azb(i) = azb(i) + aoblz(i)
         enddo
      endif

      return
      end                       !  tu4_getaccb
c____________________________________________________________________________


program range

  ! Original version by Alan Nathan
  ! Modifcations by Chris Long

  parameter(noptmax=7)
  !parameter(pi=3.1415926,twopi=2.*pi,rad=pi/180,ftm=12./39.37,
  !  mtf=1/ftm,rpm=60./twopi)
  parameter(pi=3.1415926)
  parameter(twopi=2.*pi)
  parameter(rad=pi/180,ftm=12./39.37,mtf=1/ftm,rpm=60./twopi)
  parameter(ndmax=200)

  real, dimension(1:ndmax)::rhodata,vdata,thetadata,vwind
  common/data/ rhodata,vdata,thetadata,vwind
  common/flag/iflag
  parameter(const0=5.283e-3,rho0=1.175)
  common/spin/ctht,stht,cphi,sphi

  ! local version of best fit trajectory parameters
  common/fitting/cd0,cddot,cdspin,w0,theta0,tau0

  ! local version of input parameters
  ! in mph,det,kg/m^3,mph,mph
  common/input/v0,theta,rho,const,vwx,vwy

  ! in ft/s^2,ft
  common/constants/g,radius

  parameter(nterms=8,npts=1000)
  common/initial/xstart(nterms)
  common/path/t(npts),x(nterms,npts)

  ! ft/s^2
  g=32.179
  circ=9.125
  ! radius of ball in ft
  radius=circ/twopi/12

  ! no wind
  vwx=0.
  vwy=0.

  ! index i:
  !   1,2,3 ==> xi,yi,zi
  !   4,5,6 ==> vx,vy,vz
  !   7,8 ==> r*wb,r*ws

  ! wb=backspin rate
  ! ws=sidespin rate

  ! note on the right-handed coordinate:
  !   z is vertical with positive upward
  !   y is catcher-pitcher line
  !   x points to catcher's right

  ! NOTE:  This current version is 2D, so that x=vx=ws=0
  ! It is easy to reinstate these to make it full 3D

  ! read in parameters for Cd,wb

  ! input paramters
  open(unit=20,file='parameters.csv',status='old')
  read(20,*)
  read(20,*)cd0,cddot,cdspin,w0,theta0,tau0
  close(20)

  ! output file
  !open(unit=21,file='TrajectoryCalculatorOutput.csv',status='unknown')
  ! Default status should be unknown
  ! output file
  open(unit=21,file='TrajectoryCalculatorOutput.csv')

  open(unit=20,file='trajectory_input.csv',status='old')
  ! input data
  ! skip header
  read(20,*)
  do i=1,ndmax
     read(20,*,end=200)rhodata(i),vdata(i),thetadata(i),vwind(i)
     !print*,rhodata(i),vdata(i),thetadata(i),vwind(i)
  end do
200 ndata=i-1
  tmax=10.
  ! write header
  write(21,251)

  do i=1,ndata
     rho=rhodata(i)
     const=const0*(rho/rho0)
     v0=vdata(i)
     theta=thetadata(i)
     vwy=vwind(i)*1.467
     vwx=0.
     xstart(1)=0.
     xstart(2)=2.
     xstart(3)=3.
     xstart(4)=0.
     ctht=cos(theta*rad)
     stht=sin(theta*rad)
     xstart(5)=(v0*1.467)*ctht
     xstart(6)=(v0*1.467)*stht
     cphi=1.
     sphi=0.
     spin=(w0/rpm)*(v0/100.)*(theta-theta0)/(27.5-theta0)
     xstart(7)=radius*spin
     xstart(8)=0.

     ! spin rate=w0 at v0=100. and theta=27.5 and 0 at theta=aparm(5)

     ! integrate to get trajectory, then distance

     call rkdumb(xstart,nterms,0.,tmax,npts)
     call dist(range,time)
     sfact=xstart(7)/(1.467*v0)
     cdi=cd0*(1.+cddot*(100.-v0))*(1.+cdspin*sfact**2)
     write(21,250)rho,v0,theta,spin*rpm,sfact,cdi,vwind(i),range,time
     write(6,250)rho,v0,theta,spin*rpm,sfact,cdi,vwind(i),range,time
  end do

251 format(' rho, v0, theta, spin, sfact, cdi, vwind, distance, tof')
250 format(f8.3,',',2(f8.1,','),f8.0,',',2(f8.3,','),10(f8.1,','))
  close(21)
  !stop
end program range


      INTEGER FUNCTION MA02OZ( SKEW, M, A, LDA, DE, LDDE )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the number of zero rows (and zero columns) of a complex
C     (skew-)Hamiltonian matrix,
C
C           (  A    D   )
C       H = (           ).
C           (  E  +/-A' )
C
C     FUNCTION VALUE
C
C     MA02OZ  INTEGER
C             The number of zero rows.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SKEW    CHARACTER*1
C             Specifies whether the matrix is Hamiltonian or skew-
C             Hamiltonian as follows:
C             = 'H':  The matrix is Hamiltonian;
C             = 'S':  The matrix is skew-Hamiltonian.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrices A, D, and E.  M >= 0.
C
C     A       (input) COMPLEX*16 array, dimension (LDA,M)
C             The leading M-by-M part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     DE      (input) COMPLEX*16 array, dimension (LDDE,M+1)
C             The leading M-by-M lower triangular part of this array
C             must contain the lower triangular part of the (skew-)
C             Hermitian matrix E, and the M-by-M upper triangular
C             part of the submatrix in the columns 2 to M+1 of this
C             array must contain the upper triangular part of the
C             (skew-)Hermitian matrix D. If S is skew-Hamiltonian, the
C             real parts of the entries on the diagonal and the first
C             superdiagonal of this array, which should be zero, are
C             not used. If S is Hamiltonian, the imaginary parts of the
C             entries on the diagonal and the first superdiagonal of
C             this array, which should be zero, are not used.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.  LDDE >= MAX(1,M).
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Sep. 2016.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, skew-Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      COMPLEX*16         CZERO
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          SKEW
      INTEGER            LDA, LDDE, M
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), DE( LDDE, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            ISSKEW
      INTEGER            I, J, NZ
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DIMAG
C     ..
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
      NZ = 0
C
      IF( M.GT.0 ) THEN
         ISSKEW = LSAME( SKEW, 'S' )
C
C        Scan columns 1 .. M.
C
         I = 0
C        WHILE ( I.LE.M ) DO
   10    CONTINUE
         I = I + 1
         IF( I.LE.M ) THEN
            DO 20  J = 1, M
               IF( A( J, I ).NE.CZERO )
     $            GO TO 10
   20       CONTINUE
            DO 30  J = 1, I - 1
               IF( DE( I, J ).NE.CZERO )
     $            GO TO 10
   30       CONTINUE
            IF( ISSKEW ) THEN
               IF( DIMAG( DE( I, I ) ).NE.ZERO )
     $            GO TO 10
            ELSE
               IF( DBLE( DE( I, I ) ).NE.ZERO )
     $            GO TO 10
            END IF
            DO 40  J = I + 1, M
               IF( DE( J, I ).NE.CZERO )
     $            GO TO 10
   40       CONTINUE
C
            NZ = NZ + 1
            GO TO 10
C
C           END WHILE 10
         END IF
C
C        Scan columns M+1 .. 2*M.
C
         I = 0
C        WHILE ( I.LE.M ) DO
   50    CONTINUE
         I = I + 1
         IF( I.LE.M ) THEN
            DO 60  J = 1, M
               IF( A( I, J ).NE.CZERO )
     $            GO TO 50
   60       CONTINUE
            DO 70  J = 1, I - 1
               IF( DE( J, I+1 ).NE.CZERO )
     $            GO TO 50
   70       CONTINUE
            IF( ISSKEW ) THEN
               IF( DIMAG( DE( I, I+1 ) ).NE.ZERO )
     $            GO TO 50
            ELSE
               IF( DBLE( DE( I, I+1 ) ).NE.ZERO )
     $            GO TO 50
            END IF
            DO 80  J = I + 1, M
               IF( DE( I, J+1 ).NE.CZERO )
     $            GO TO 50
   80       CONTINUE
C
            NZ = NZ + 1
            GO TO 50
C
         END IF
C        END WHILE 50
      END IF
C
      MA02OZ = NZ
      RETURN
C
C *** Last line of MA02OZ ***
      END


      subroutine depos(xb,xe,cdep,a,b,c,phi,theta,ilast,dl,ldlast)
c
c     + + + PURPOSE + + +
c     Calculates deposition in each segment of the hillslope.
c
c     Called from subroutine ROUTE.
c     Author(s): G. Foster, M. Nearing, D. Flanagan
c     Reference in User Guide:
c
c     Changes: Changed DEPEQ from a FUNCTION, into a SUBROUTINE
c              named DEPEQS, with an argument called DEPEQ.
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/14/91 to 02/26/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real xb, xe, cdep, a, b, c, phi, theta, dl, ldlast, xterm
      integer ilast
c
c     + + + ARGUMENT DEFINITIONS + + +
c     xb     - n.d. distance where deposition begins
c     xe     - n.d. distance where deposition ends
c     cdep   - portion of solution to deposition equation
c     a      - shear stress equation coefficient
c     b      - shear stress equation coefficient
c     c      - shear stress equation coefficient
c     phi    - n.d. deposition parameter
c     theta  - n.d. interill detachment parameter
c     ilast  - index counter at last point where load computed
c     dl     - n.d. deposition rate at distance x=xe
c     ldlast - n.d. sediment load at distance x=xe
c     xterm  -
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
      include 'pmxhil.inc'
c
c     + + + COMMON BLOCKS + + +
      include 'cdist1.inc'
c       read: xinput(101,mxplan)
      include 'cends1.inc'
c       read: ktrato
      include 'cerdva1.inc'
      include 'cerdva2.inc'
c     modify: detach(101), load(101), tc(101)
      include 'cinfco1.inc'
c       read: qostar
      include 'cstruc.inc'
c       read: iplane
c
c     + + + LOCAL VARIABLES + + +
      integer ibeg, i, loopfg
      real tclast
c
c     ibeg   - counter variable value at first deposition point
c     tclast - n.d. transport capacity at distance x=xe
c     loopfg - flag.  1 = exit L3 Loop.
c
c     + + + SUBROUTINES CALLED + + +
c     depeqs
c
c     + + + END SPECIFICATIONS + + +
c
      ibeg = ilast + 1
c
c     *** L1 IF ***
      if (ibeg.lt.102) then
c
c       *** L2 IF ***
        if (xinput(ibeg,iplane).gt.xe) then
c         Original Code:
c         dl=depeq(xb,cdep,a,b,phi,theta,xe)
c
          if (qostar.le.-1.0.or.qostar.ge.0.0.or.xe.le.-qostar) then
            call depeqs(xb,cdep,a,b,phi,theta,xe,dl)
            xterm = a * xe ** 2 + b * xe + c
            tclast = xterm * ktrato
            if (tclast.le.0.0) tclast = 0.0
            ldlast = tclast - dl * (xe+qostar) / phi
          else
            tclast = 0.0
            ldlast = 0.0
          end if
        else
c
c         *** Begin L3 Loop ***
          i = ilast
          loopfg = 0
   10     continue
          i = i + 1
          if (xinput(i,iplane).le.xe) then
c
c           Check if point is past end of runoff on a Case 4 plane.
c
            if (qostar.le.-1.0.or.qostar.ge.0.0.or.xinput(i,iplane).le.
     1          -qostar) then
c
c             Original Code:
c             detach(i)=depeq(xb,cdep,a,b,phi,theta,
              call depeqs(xb,cdep,a,b,phi,theta,xinput(i,iplane),
     1            detach(i))
              xterm = a * xinput(i,iplane) ** 2 + b * xinput(i,iplane) +
     1            c
              tc(i) = xterm * ktrato
              if (tc(i).lt.0.0) tc(i) = 0.0
c
              load(i) = tc(i) - detach(i) * (xinput(i,iplane)+qostar) /
     1            phi
c
c             Added by dcf - 8/13/90  -  to prevent erroneous calculation
c             of detachment by deposition equation (for case 4 plane)
c
              if (theta.le.0.0.and.i.gt.1.and.load(i).gt.load(i-1))
     1            load(i) = load(i-1)
c
            else
              load(i) = 0.0
              tc(i) = 0.0
            end if
c
            if (load(i).lt.0.0) load(i) = 0.0
            ilast = i
            if (xinput(i,iplane).ge.1.0) loopfg = 1
          else
            loopfg = 1
          end if
c
c         *** End L3 Loop ***
          if (i.lt.101.and.loopfg.eq.0) go to 10
c
c
c
c         corrections made 5/17/91 by dcf to prevent bombing -
c         for case of CASE 4 plane where xe is greater than -qostar
c
c
c         CASE 1 is most typical - on an OFE on which flow does
c         not end.
c
          if (qostar.ge.0.0.or.qostar.le.-1.0) then
            call depeqs(xb,cdep,a,b,phi,theta,xe,dl)
            xterm = a * xe ** 2 + b * xe + c
            tclast = xterm * ktrato
            if (tclast.lt.0.0) tclast = 0.0
            ldlast = tclast - dl * (xe+qostar) / phi
c
          else
c
c           Case 2 is for an OFE on which flow does end, but
c           it does not end on the current slope segment.
c
            if (xe.lt.-qostar) then
              call depeqs(xb,cdep,a,b,phi,theta,xe,dl)
              xterm = a * xe ** 2 + b * xe + c
              tclast = xterm * ktrato
              if (tclast.lt.0.0) tclast = 0.0
              ldlast = tclast - dl * (xe+qostar) / phi
c
            else
c
c             Case 3 is for an OFE on which flow ends, and on which
c             it ends on the current slope segment.
c
              tclast = 0.0
              ldlast = 0.0
              dl = 0.0
c
            end if
c
          end if
c
c
          if (ldlast.lt.0.0) ldlast = 0.0
          if (tclast.lt.0.0) tclast = 0.0
c       if(dl.gt.0.0) dl = 0.0
c
c       *** L2 ENDIF ***
        end if
c
c     *** L1 ENDIF ***
      end if
c
      return
      end


c ------------------------------------------------------------
      subroutine mtzm (vh, vs, rx, ngrid, rmt, rws, jrmt, jrws, vhar,
     &                 vex)
!  subroutine for calculation of the muffin-tin zero level for
!  monoatomic crystals, using a spherical average of the potential
!  between muffin-tin radius and wigner-seitz radius, as in eq 3.31
!  of loucks, transformed to the exponential grid rx?
!                       rx(i)=exp(-8.8+0.05(i-1))
!  integration by trapezium rule.  jrmt,jrws are grid points outside
!  muffin-tin radius and wigner-seitz radius respectively

      dimension vh(ngrid), vs(ngrid), rx(ngrid)
      double precision sumh, sume

      dx=0.05
      ddx=0.5*dx
      dxx=exp(3.*dx)
      x=alog(rx(jrmt)/rmt)
      rdx=x/dx
      xx=rx(jrmt-1)**3
      xxmt=xx*dxx
      sumh=0.5*x*(rdx*xx*vh(jrmt-1)+(2.-rdx)*xxmt*vh(jrmt))
      sume=0.5*x*(rdx*xx*vs(jrmt-1)+(2.-rdx)*xxmt*vs(jrmt))
      xx=xxmt
      jrw=jrws-1
      if (jrmt .eq. jrw) goto 20
      vh1=ddx*xx*vh(jrmt)
      vx1=ddx*xx*vs(jrmt)
      jrm=jrmt+1
      do 10 j = jrm, jrw
        xx=xx*dxx
        vh2=ddx*xx*vh(j)
        vx2=ddx*xx*vs(j)
        sumh=sumh+vh1+vh2
        sume=sume+vx1+vx2
        vh1=vh2
   10   vx1=vx2
   20 x=alog(rws/rx(jrw))
      rdx=x/dx
      xxws=xx*dxx
      sumh=sumh+0.5*x*((2.-rdx)*xx*vh(jrw)+rdx*xxws*vh(jrws))
      sume=sume+0.5*x*((2.-rdx)*xx*vs(jrw)+rdx*xxws*vs(jrws))
      c=3./(rws*rws*rws-rmt*rmt*rmt)
      vhar=c*sumh
      vex=c*sume
      vint=vhar+vex
      write (11,30) vhar, vex, vint
      return

   30 format (///'muffin-tin zero by spherical average',/' average hartr
     &ee potential: ',6x,f14.5,5x,'average exchange potential: ',f12.5,/
     &'muffin-tin zero: ',f12.5)
      end