subroutine advectDiffGodunov(time, lo, hi, &
     &            uin , ui_lo, ui_hi, &
     &            dphidtout, uo_lo, uo_hi, &
     &            vx  , vx_lo, vx_hi, &
     &            vy  , vy_lo, vy_hi, &
     &            flxx, fx_lo, fx_hi, &
     &            flxy, fy_lo, fy_hi, &
     &            dx,dt, nu, uselimit) bind(C, name="advectDiffGodunov")

  use amrex_mempool_module, only : bl_allocate, bl_deallocate
  use compute_flux_module, only : godunov_flux_2d

  implicit none

  integer, intent(in) :: lo(2), hi(2), uselimit
  double precision, intent(in) :: dx(2), dt, time, nu
  integer, intent(in) :: ui_lo(2), ui_hi(2)
  integer, intent(in) :: uo_lo(2), uo_hi(2)
  integer, intent(in) :: vx_lo(2), vx_hi(2)
  integer, intent(in) :: vy_lo(2), vy_hi(2)
  integer, intent(in) :: fx_lo(2), fx_hi(2)
  integer, intent(in) :: fy_lo(2), fy_hi(2)
  double precision, intent(in   ) :: uin (ui_lo(1):ui_hi(1),ui_lo(2):ui_hi(2))
  double precision, intent(inout) :: dphidtout(uo_lo(1):uo_hi(1),uo_lo(2):uo_hi(2))
  double precision, intent(in   ) :: vx  (vx_lo(1):vx_hi(1),vx_lo(2):vx_hi(2))
  double precision, intent(in   ) :: vy  (vy_lo(1):vy_hi(1),vy_lo(2):vy_hi(2))
  double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
  double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))

  integer :: i, j
  integer :: glo(2), ghi(2)
  double precision :: umax, vmax

  ! Some compiler may not support 'contiguous'.  Remove it in that case.
  double precision, dimension(:,:), pointer, contiguous :: phix_1d, phiy_1d, phix, phiy, slope

  glo = lo - 1
  ghi = hi + 1

  ! edge states
  call bl_allocate(phix_1d, glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phiy_1d, glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phix   , glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phiy   , glo(1), ghi(1), glo(2), ghi(2))
  ! slope
  call bl_allocate(slope  , glo(1), ghi(1), glo(2), ghi(2))

  ! We like to allocate these **pointers** here and then pass them to a function
  ! to remove their pointerness for performance, because normally pointers could
  ! be aliasing.  We need to use pointers instead of allocatable arrays because
  ! we like to use BoxLib's bl_allocate to allocate memeory instead of the intrinsic
  ! allocate.  Bl_allocate is much faster than allocate inside OMP.
  ! Note that one MUST CALL BL_DEALLOCATE.

  ! check if CFL condition is violated.
  umax = maxval(abs(vx))
  vmax = maxval(abs(vy))

  if ( umax*dt .ge. dx(1) .or. &
       vmax*dt .ge. dx(2) ) then
     print *, "umax = ", umax, ", vmax = ", vmax, ", dt = ", dt, ", dx = ", dx
     call bl_error("CFL violation. Use smaller adv.cfl.")
  end if

  ! call a function to compute flux
  call godunov_flux_2d(lo, hi, dt, dx, &
                       uin, ui_lo, ui_hi, &
                       vx, vx_lo, vx_hi, &
                       vy, vy_lo, vy_hi, &
                       flxx, fx_lo, fx_hi, &
                       flxy, fy_lo, fy_hi, &
                       phix_1d, phiy_1d, phix, phiy, &
                       slope, glo, ghi, nu, uselimit)

  ! Do a conservative update
  do    j = lo(2),hi(2)
     do i = lo(1),hi(1)
        !notice that some mad scientist has reversed the flux difference
        ! rather than just put a negative sign out front.
        dphidtout(i,j) = &
             ( (flxx(i,j) - flxx(i+1,j  )) / dx(1) &
             + (flxy(i,j) - flxy(i  ,j+1)) / dx(2) )
     enddo
  enddo

  ! Scale by face area in order to correctly reflux because flux register requires this
  do    j = lo(2), hi(2)
     do i = lo(1), hi(1)+1
        flxx(i,j) = flxx(i,j) * ( dt * dx(2))
     enddo
  enddo

  ! Scale by face area in order to correctly reflux because flux register requires this
  do    j = lo(2), hi(2)+1
     do i = lo(1), hi(1)
        flxy(i,j) = flxy(i,j) * (dt * dx(1))
     enddo
  enddo

  call bl_deallocate(phix_1d)
  call bl_deallocate(phiy_1d)
  call bl_deallocate(phix)
  call bl_deallocate(phiy)
  call bl_deallocate(slope)

end subroutine advectDiffGodunov

subroutine advectDiffMOL2ndOrd(time, lo, hi, &
     &            uin , ui_lo, ui_hi, &
     &            dphidtout, uo_lo, uo_hi, &
     &            vx  , vx_lo, vx_hi, &
     &            vy  , vy_lo, vy_hi, &
     &            flxx, fx_lo, fx_hi, &
     &            flxy, fy_lo, fy_hi, &
     &            dx,dt, nu, uselimit) bind(C, name="advectDiffMOL2ndOrd")

  use amrex_mempool_module, only : bl_allocate, bl_deallocate
  use compute_flux_module, only : mol2ndord_flux_2d

  implicit none

  integer, intent(in) :: lo(2), hi(2), uselimit
  double precision, intent(in) :: dx(2), dt, time, nu
  integer, intent(in) :: ui_lo(2), ui_hi(2)
  integer, intent(in) :: uo_lo(2), uo_hi(2)
  integer, intent(in) :: vx_lo(2), vx_hi(2)
  integer, intent(in) :: vy_lo(2), vy_hi(2)
  integer, intent(in) :: fx_lo(2), fx_hi(2)
  integer, intent(in) :: fy_lo(2), fy_hi(2)
  double precision, intent(in   ) :: uin (ui_lo(1):ui_hi(1),ui_lo(2):ui_hi(2))
  double precision, intent(inout) :: dphidtout(uo_lo(1):uo_hi(1),uo_lo(2):uo_hi(2))
  double precision, intent(in   ) :: vx  (vx_lo(1):vx_hi(1),vx_lo(2):vx_hi(2))
  double precision, intent(in   ) :: vy  (vy_lo(1):vy_hi(1),vy_lo(2):vy_hi(2))
  double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
  double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))

  integer :: i, j
  integer :: glo(2), ghi(2)
  double precision :: umax, vmax, fhi, flo

  ! Some compiler may not support 'contiguous'.  Remove it in that case.
  double precision, dimension(:,:), pointer, contiguous :: phix_1d, phiy_1d, slope

  glo = lo - 1
  ghi = hi + 1

  ! edge states
  call bl_allocate(phix_1d, glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phiy_1d, glo(1), ghi(1), glo(2), ghi(2))
  ! slope
  call bl_allocate(slope  , glo(1), ghi(1), glo(2), ghi(2))

  ! We like to allocate these **pointers** here and then pass them to a function
  ! to remove their pointerness for performance, because normally pointers could
  ! be aliasing.  We need to use pointers instead of allocatable arrays because
  ! we like to use BoxLib's bl_allocate to allocate memeory instead of the intrinsic
  ! allocate.  Bl_allocate is much faster than allocate inside OMP.
  ! Note that one MUST CALL BL_DEALLOCATE.

  ! check if CFL condition is violated.
  umax = maxval(abs(vx))
  vmax = maxval(abs(vy))
  if ( umax*dt .ge. dx(1) .or. &
       vmax*dt .ge. dx(2) ) then
     print *, "umax = ", umax, ", vmax = ", vmax, ", dt = ", dt, ", dx = ", dx
     call bl_error("CFL violation. Use smaller adv.cfl.")
  end if

  ! call a function to compute flux
  call mol2ndord_flux_2d(lo, hi, dt, dx, &
       uin, ui_lo, ui_hi, &
       vx, vx_lo, vx_hi, &
       vy, vy_lo, vy_hi, &
       flxx, fx_lo, fx_hi, &
       flxy, fy_lo, fy_hi, &
       phix_1d, phiy_1d,  slope, glo, ghi, nu, uselimit)

  ! Do a conservative update
  do    j = lo(2),hi(2)
     do i = lo(1),hi(1)
        !notice that some mad scientist has reversed the flux difference
        ! rather than just put a negative sign out front.
        flo = flxx(i,j)
        fhi = flxx(i+1,j)
        fhi = flxy(i,j+1)
        flo = flxy(i,j  )
        dphidtout(i,j) = &
             ( (flxx(i,j) - flxx(i+1,j  )) / dx(1) &
             + (flxy(i,j) - flxy(i  ,j+1)) / dx(2) )
     enddo
  enddo

  ! Scale by face area in order to correctly reflux because flux register requires this
  do    j = lo(2), hi(2)
     do i = lo(1), hi(1)+1
        flxx(i,j) = flxx(i,j) * ( dt * dx(2))
     enddo
  enddo

  ! Scale by face area in order to correctly reflux because flux register requires this
  do    j = lo(2), hi(2)+1
     do i = lo(1), hi(1)
        flxy(i,j) = flxy(i,j) * (dt * dx(1))
     enddo
  enddo

  call bl_deallocate(phix_1d)
  call bl_deallocate(phiy_1d)
  call bl_deallocate(slope)

end subroutine advectDiffMOL2ndOrd

subroutine advectDiffMOL4thOrd(time, lo, hi, &
                               uin , ui_lo, ui_hi, &
                               dphidtout, uo_lo, uo_hi, &
                               vx  , vx_lo, vx_hi, &
                               vy  , vy_lo, vy_hi, &
                               flxx, fx_lo, fx_hi, &
                               flxy, fy_lo, fy_hi, &
                               dx,dt, nu,          &
                               deblocell, debhicell, &
                               hisidedebfacelo, hisidedebfacehi, &
                               losidedebfacelo, losidedebfacehi, printstuff, uselimit &
                               ) bind(C, name="advectDiffMOL4thOrd")

  use amrex_mempool_module, only : bl_allocate, bl_deallocate
  use compute_flux_module, only : mol4thord_flux_2d_limited, mol4thord_flux_2d_nolimit

  implicit none

  integer, intent(in) :: lo(2), hi(2), printstuff, uselimit
  integer, intent(in) :: deblocell(2), debhicell(2)
  integer, intent(in) :: hisidedebfacelo(2), hisidedebfacehi(2)
  integer, intent(in) :: losidedebfacelo(2), losidedebfacehi(2)
  double precision, intent(in) :: dx(2), dt, time, nu
  integer, intent(in) :: ui_lo(2), ui_hi(2)
  integer, intent(in) :: uo_lo(2), uo_hi(2)
  integer, intent(in) :: vx_lo(2), vx_hi(2)
  integer, intent(in) :: vy_lo(2), vy_hi(2)
  integer, intent(in) :: fx_lo(2), fx_hi(2)
  integer, intent(in) :: fy_lo(2), fy_hi(2)
  double precision, intent(in   ) :: uin (ui_lo(1):ui_hi(1),ui_lo(2):ui_hi(2))
  double precision, intent(inout) :: dphidtout(uo_lo(1):uo_hi(1),uo_lo(2):uo_hi(2))
  double precision, intent(in   ) :: vx  (vx_lo(1):vx_hi(1),vx_lo(2):vx_hi(2))
  double precision, intent(in   ) :: vy  (vy_lo(1):vy_hi(1),vy_lo(2):vy_hi(2))
  double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
  double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))

  integer :: i, j
  integer :: glo(2), ghi(2)
  double precision :: umax, vmax, fhi, flo
! integer numphi
!  double precision :: phitot, rnumphi

  double precision, dimension(:,:), pointer, contiguous :: &
         fluxptx, fluxpty,  phiptx, phipty,  phiavex, phiavey,  phiptcc

  glo = lo - 3
  ghi = hi + 3

  call bl_allocate(fluxptx  ,glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(fluxpty  ,glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate( phiptx  ,glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate( phipty  ,glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phiavex  ,glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phiavey  ,glo(1), ghi(1), glo(2), ghi(2))
  call bl_allocate(phiptcc  ,glo(1), ghi(1), glo(2), ghi(2))

  ! We like to allocate these **pointers** here and then pass them to a function
  ! to remove their pointerness for performance, because normally pointers could
  ! be aliasing.  We need to use pointers instead of allocatable arrays because
  ! we like to use BoxLib's bl_allocate to allocate memeory instead of the intrinsic
  ! allocate.  Bl_allocate is much faster than allocate inside OMP.
  ! Note that one MUST CALL BL_DEALLOCATE.

  ! check if CFL condition is violated.
  umax = maxval(abs(vx))
  vmax = maxval(abs(vy))
  if ( umax*dt .ge. dx(1) .or. &
       vmax*dt .ge. dx(2) ) then
     print *, "umax = ", umax, ", vmax = ", vmax, ", dt = ", dt, ", dx = ", dx
     call bl_error("CFL violation. Use smaller adv.cfl.")
  end if

  !checking to see if periodic cosine worked
!  if(printstuff.eq.1) then
!     do    j = deblocell(2), debhicell(2)
!!        do i = deblocell(1), debhicell(1)
!           print*, "*** j phiave -2 -1  0  1 = ", j, uin(-2,j),uin(-1,j),uin(0 ,j),uin(1,j), "****"
!           print*, "*** j phiave 62 63 64 65 = ", j, uin(62,j),uin(63,j),uin(64,j),uin(65,j), "****"
!!        enddo
!     enddo
! endif
  ! call a function to compute flux
  if(uselimit.eq.1) then
     call mol4thord_flux_2d_limited(&
          lo, hi, dt, dx, &
          uin, ui_lo, ui_hi, &
          vx, vx_lo, vx_hi, &
          vy, vy_lo, vy_hi, &
          flxx, fx_lo, fx_hi, &
          flxy, fy_lo, fy_hi, &
          fluxptx, phiptx, phiavex,&
          fluxpty, phipty, phiavey,&
          phiptcc, glo, ghi,nu,&
          deblocell, debhicell, &
          hisidedebfacelo, hisidedebfacehi,&
          hisidedebfacelo, hisidedebfacehi, printstuff)
  else
     call mol4thord_flux_2d_nolimit(&
          lo, hi, dt, dx, &
          uin, ui_lo, ui_hi, &
          vx, vx_lo, vx_hi, &
          vy, vy_lo, vy_hi, &
          flxx, fx_lo, fx_hi, &
          flxy, fy_lo, fy_hi, &
          fluxptx, phiptx, phiavex,&
          fluxpty, phipty, phiavey,&
          phiptcc, glo, ghi,nu,&
          deblocell, debhicell, &
          hisidedebfacelo, hisidedebfacehi,&
          hisidedebfacelo, hisidedebfacehi, printstuff)
  endif

  ! Do a conservative update
  do    j = lo(2),hi(2)
     do i = lo(1),hi(1)
        !notice that some mad scientist has reversed the flux difference
        ! rather than just put a negative sign out front.
        flo = flxx(i,j)
        fhi = flxx(i+1,j)
        fhi = flxy(i,j+1)
        flo = flxy(i,j  )
        dphidtout(i,j) = &
             ( (flxx(i,j) - flxx(i+1,j  )) / dx(1) &
             + (flxy(i,j) - flxy(i  ,j+1)) / dx(2) )

     enddo
  enddo

!  if(printstuff.eq.1) then
!     numphi = 0
!     phitot = 0.0d0
!     do    j = losidedebfacelo(2), losidedebfacehi(2)
!        do i = losidedebfacelo(1), losidedebfacehi(1)
!           numphi = numphi + 1
!           phitot = phitot +flxx(i,j)
!           !          print*, "*** i j phiave = ", i, j, phiavex(i,j), "****"
!        enddo
!     enddo
!     if(numphi .gt. 0) then
!        print*, "**************** nflux, final x  flux lo = ", numphi, phitot/numphi
!     endif
!     numphi = 0
!     phitot = 0.0d0
!     do    j = hisidedebfacelo(2), hisidedebfacehi(2)
!        do i = hisidedebfacelo(1), hisidedebfacehi(1)
!           numphi = numphi + 1
!           phitot = phitot +flxx(i,j)
!           !          print*, "*** i j phiave = ", i, j, phiavex(i,j), "****"
!        enddo
!     enddo
!     if(numphi .gt. 0) then
!        print*, "**************** nflux, final x  flux hi = ", numphi, phitot/numphi
!     endif
!
!     numphi = 0
!     rnumphi = 0.0d0
!     phitot = 0.0d0
!     do    j = deblocell(2), debhicell(2)
!        do i = deblocell(1), debhicell(1)
!           numphi = numphi + 1
!           rnumphi = rnumphi+ 1.0d0
!           phitot = phitot + dphidtout(i,j)
!           !          print*, "*** i j phiave = ", i, j, phiavex(i,j), "****"
!        enddo
!     enddo
!     if(numphi .gt. 0) then
!        print*, "**************** ndphidt, final dphidt = ", numphi, phitot/rnumphi
!     endif
! endif

  ! Scale by face area in order to correctly reflux because flux register requires this
  do    j = lo(2), hi(2)
     do i = lo(1), hi(1)+1
        flxx(i,j) = flxx(i,j) * ( dt * dx(2))
     enddo
  enddo

  ! Scale by face area in order to correctly reflux because flux register requires this
  do    j = lo(2), hi(2)+1
     do i = lo(1), hi(1)
        flxy(i,j) = flxy(i,j) * (dt * dx(1))
     enddo
  enddo

  call bl_deallocate(fluxptx)
  call bl_deallocate(fluxpty)
  call bl_deallocate( phiptx)
  call bl_deallocate( phipty)
  call bl_deallocate(phiavex)
  call bl_deallocate(phiavey)
  call bl_deallocate(phiptcc)

end subroutine advectDiffMOL4thOrd


!==============================================================================!
  subroutine Calculate_Shear_And_Vorticity(flow)
!------------------------------------------------------------------------------!
!   Computes the magnitude of the shear stress.                                !
!------------------------------------------------------------------------------!
!   shear = sqrt( 2 * Sij * Sij )                                              !
!   Sij = 1/2 ( dUi/dXj + dUj/dXi )                                            !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Comm_Mod
  use Turb_Mod
  use Field_Mod,  only: Field_Type
  use Grid_Mod,   only: Grid_Type
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type), target :: flow
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  type(Var_Type),  pointer :: u, v, w
  integer                  :: c
!==============================================================================!

  ! Take aliases
  grid => flow % pnt_grid
  call Field_Mod_Alias_Momentum(flow, u, v, w)

  ! Velocity gradients
  call Field_Mod_Grad_Variable(flow, flow % u)
  call Field_Mod_Grad_Variable(flow, flow % v)
  call Field_Mod_Grad_Variable(flow, flow % w)

  do c = -grid % n_bnd_cells, grid % n_cells
    flow % shear(c) = u % x(c)**2                     &
                    + v % y(c)**2                     &
                    + w % z(c)**2                     &
                    + 0.5 * (v % z(c) + w % y(c))**2  &
                    + 0.5 * (u % z(c) + w % x(c))**2  &
                    + 0.5 * (v % x(c) + u % y(c))**2

    flow % vort(c) = - (   0.5 * (v % z(c) - w % y(c))**2  &
                         + 0.5 * (u % z(c) - w % x(c))**2  &
                         + 0.5 * (v % x(c) - u % y(c))**2 )

    flow % shear(c) = sqrt(2.0 * flow % shear(c))
    flow % vort(c)  = sqrt(2.0 * abs(flow % vort(c)))
  end do

  end subroutine


*DECK CLOG10
      COMPLEX FUNCTION CLOG10 (Z)
C***BEGIN PROLOGUE  CLOG10
C***PURPOSE  Compute the principal value of the complex base 10
C            logarithm.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      COMPLEX (CLOG10-C)
C***KEYWORDS  BASE TEN LOGARITHM, ELEMENTARY FUNCTIONS, FNLIB
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CLOG10(Z) calculates the principal value of the complex common
C or base 10 logarithm of Z for -PI .LT. arg(Z) .LE. +PI.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CLOG10
      COMPLEX Z
      SAVE ALOGE
      DATA ALOGE / 0.4342944819 0325182765E0 /
C***FIRST EXECUTABLE STATEMENT  CLOG10
      CLOG10 = ALOGE * LOG(Z)
C
      RETURN
      END


       SUBROUTINE W3FT00(FLD,B,IA,JA,IB,JB,CIP,CJP,FIPB,FJPB,SC,ARG,LIN)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FT00         DATA FIELD TRANFORMATION SUBROUTINE
C   AUTHOR: MCDONELL, J.     ORG: W345        DATE: SEPTEMBER, 1974
C           HOWCROFT, J.
C   UPDATE: JONES,R.E.       ORG: W342        DATE: 27 JUN 84
C
C ABSTRACT: TRANSFORMS DATA CONTAINED IN A GRID ARRAY BY TRANSLATION,
C   ROTATION ABOUT A COMMON POINT AND DILATATION TO A NEW GRID ARRAY.
C
C PROGRAM HISTORY LOG:
C   74-09-01  J.MCDONELL
C   84-06-27  R.E.JONES   CHANGE TO IBM VS FORTRAN
C
C USAGE:  CALL W3FT00 (FA,FB,IA,JA,IB,JB,AIP,AJP,BIP,BJP,SC,ARG,LIN)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     FA     ARG LIST  REAL  ORIGIONAL FIELD DIMENSIONED (IA,IJ)
C     IA     ARG LIST  INTEGER  I-DIMENSION OF THE INPUT ARRAY FA
C     JA     ARG LIST  INTEGER  J-DIMENSION OF THE INPUT ARRAY FA
C     IB     ARG LIST  INTEGER  I-DIMENSION OF THE OUTPUT ARRAY FB
C     JB     ARG LIST  INTEGER  J-DIMENSION OF THE OUTPUT ARRAY FB
C     AIP    ARG LIST  REAL   COMMON POINT I-COORDINATE OF THE ORIGIONAL
C                      FIELD ASSUMING A RIGHT HAND CARTESIAN COORDINATE
C                      SYSTEM. THE POINT NEED NOT BE IN EITHER GRID AND
C                      CAN HAVE FRACTIONAL INDICES).
C     AJP    ARG LIST  REAL  COMMON POINT J-COORDINATE AS AIP ABOVE
C     BIP    ARG LIST  REAL  COMMON POINT I-COORDINATE FOR TRANSFORMED
C                      GRID
C     BJP    ARG LIST  REAL  COMMON POINT J-COORDINATE FOR TRANSFORMED
C                      GRID
C     SC     ARG LIST  REAL  SCALE CHANGE (DILATION) EXPRESSED AS
C                      A RATIO OF THE TRANSFORMED TO THE ORIGIONAL FIELD
C     ARG    ARG LIST  REAL  DEGREE MEASURE OF THE ANGLE REQUIRED TO
C                      ROTATE THE J-ROW OF THE ORIGIONAL GRID INTO
C                      COINCIDENCE WITH THE NEW GRID. (+ COUNTER-
C                      CLOCKWISE, - CLOCKWISE)
C     LIN    ARG LIST  INTEGER  INTERPOLATION METHOD SWITCH
C                      .EQ. 1 BILINEAR INTERPOLATION
C                      .NE. 1 BIQUADRATIC INTERPOLATION
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     FB     ARG LIST  REAL  TRANSFORMED FIELD DIMENSIONED (IB,JB)
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     SIN    COS                                              SYSTEM
C
C   REMARKS: IN GENERAL 'FA' AND 'FB' CANNOT BE EQUIVALENCED
C     ALTHOUGH THERE ARE SITUATIONS IN WHICH IT WOULD BE SAFE TO DO
C     SO. CARE SHOULD BE TAKEN THAT ALL OF THE NEW GRID POINTS LIE
C     WITHIN THE ORIGIONAL GRID, NO ERROR CHECKS ARE MADE.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      REAL  B(IB,JB)
      REAL  ERAS(4)
      REAL  FLD(IA,JA)
C
      EQUIVALENCE (CI,STI), (CJ,STJ)
C
      THETA = ARG * (3.14159 / 180.0)
      SINT  = SIN (THETA)
      COST  = COS (THETA)
C
      DO 180 JN = 1,JB
        FJN   = JN
        FJ    = FJN - FJPB
      DO 180 IN = 1,IB
        FIN   = IN
        FI    = FIN - FIPB
        IOFF  = 0
        JOFF  = 0
        KQUAD = 0
        CI    = CIP + SC * (FI * COST - FJ * SINT)
        CJ    = CJP + SC * (FI * SINT + FJ * COST)
        IM    = CI
        JM    = CJ
        IF ((IM - 1).GT.0) GO TO 20
        IF ((IM - 1).EQ.0) GO TO 40
          II   = 1
          IOFF = 1
          GO TO 50
C
 20   CONTINUE
        IF ((IA - IM - 1).GT.0) GO TO 50
        IF ((IA - IM - 1).EQ.0) GO TO 40
          II   = IA
          IOFF = 1
          GO TO 50
C
 40   CONTINUE
        KQUAD = 5
C
 50   CONTINUE
        IF ((JM - 1).GT.0) GO TO 70
        IF ((JM - 1).EQ.0) GO TO 90
        JJ   = 1
        JOFF = 1
        GO TO 100
C
 70   CONTINUE
        IF ((JA - JM - 1).GT.0) GO TO 100
        IF ((JA - JM - 1).EQ.0) GO TO 90
        JJ   = JA
        JOFF = 1
        GO TO 100
C
 90   CONTINUE
        KQUAD = 5
C
 100  CONTINUE
        IF ((IOFF + JOFF) .EQ. 0)  GO TO 120
        IF ((IOFF + JOFF) .EQ. 2)  GO TO 110
        IF (IOFF .EQ. 1)  JJ = CJ
        IF (JOFF .EQ. 1)  II = CI
C
 110  CONTINUE
        B(IN,JN) = FLD(II,JJ)
        GO TO 180
C
 120  CONTINUE
        I     = STI
        J     = STJ
        FIX   = I
        XDELI = STI - FIX
        FJX   = J
        XDELJ = STJ - FJX
        IF ((KQUAD - 5).EQ.0) GO TO 140
C
        IF ((LIN-1).NE.0) GO TO 150
C
 140  CONTINUE
        ERAS(1) = FLD(I,J)
        ERAS(4) = FLD(I,J+1)
        ERAS(2) = ERAS(1) + (FLD(I+1,J)   - ERAS(1)) * XDELI
        ERAS(3) = ERAS(4) + (FLD(I+1,J+1) - ERAS(4)) * XDELI
        DI      = ERAS(2) + (ERAS(3)      - ERAS(2)) * XDELJ
        GO TO 170
C
 150  CONTINUE
        XI2TM = XDELI * (XDELI - 1.0) * 0.25
        XJ2TM = XDELJ * (XDELJ - 1.0) * 0.25
        J1 = J - 1
C
      DO 160 K = 1,4
        ERAS(K) = (FLD(I+1,J1) - FLD(I,J1)) * XDELI + FLD(I,J1) +
     & (FLD(I-1,J1) - FLD(I,J1) - FLD(I+1,J1) + FLD(I+2,J1)) * XI2TM
        J1 = J1 + 1
 160  CONTINUE
C
        DI = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ + (ERAS(1) -
     &       ERAS(2) -  ERAS(3) + ERAS(4)) * XJ2TM
C
 170  CONTINUE
        B(IN,JN) = DI
C
 180  CONTINUE
C
      RETURN
      END


!> @brief Module that contains subroutines and functions to sample various energy distributions.
MODULE korc_energy_pdfs
  USE korc_types
  USE korc_constants
  USE korc_HDF5
  USE korc_hpc
  USE korc_input

  IMPLICIT NONE

  !> @brief KORC derived type that contains information about a given Gamma distribution function @f$f_\Gamma(x,\kappa,\theta)@f$.
  !! @details We write a given Gamma distribution function in terms of its shape factor @f$\kappa@f$ and scale factor
  !! @f$\theta@f$, so that:
  !!
  !!
  !! @f$f_\Gamma(x,\kappa,\theta) = \frac{1}{\Gamma(\kappa) \theta^\kappa}x^{\kappa-1}\exp{\left(-x/\theta\right)}@f$.
  TYPE, PRIVATE :: GAMMA_PARAMS
     REAL(rp) :: min_energy !< Minimum energy of sampled @f$f_\Gamma(x,\kappa,\theta)@f$ in MeV.
     REAL(rp) :: max_energy !< Maximum energy of sampled @f$f_\Gamma(x,\kappa,\theta)@f$ in MeV.
     REAL(rp) :: min_p !< Minimum momentum of sampled @f$f_\Gamma(x,\kappa,\theta)@f$.
     REAL(rp) :: max_p !< Maximum momentum of sampled @f$f_\Gamma(x,\kappa,\theta)@f$.
     REAL(rp) :: k !< Shape factor @f$\kappa@f$.
     REAL(rp) :: t !< Scale factor @f$\theta@f$.
  END TYPE GAMMA_PARAMS

  TYPE(GAMMA_PARAMS), PRIVATE 	:: gamma_pdf_params !< An instance of the KORC derived type GAMMA_PARAMS
  REAL(rp), PRIVATE, PARAMETER 	:: co = (C_E*1.0E6)/(C_ME*C_C**2) !< Constant with units to transform @f$\mathcal{E}@f$ in
  !! @f$f_\Gamma(\mathcal{E},\kappa,\theta)@f$ from MeV to Joules.
  REAL(rp), PRIVATE, PARAMETER 	:: minmax_buffer_size = 10.0_rp !< This is the size of the buffer zone in each direction when
  !!using a Metropolis-Hastings method to sample a distribution.

  PUBLIC 	:: get_gamma_distribution
  PRIVATE :: initialize_gamma_params,&
       save_gamma_params,&
       sample_gamma_distribution,&
       deg2rad,&
       fRE,&
       random_norm,&
       fGamma

CONTAINS

  !> @brief Subroutine that contains calls to subroutine to generate a gamma distribution for the energy distribution of a given
  !! species in the simulation.
  !!
  !! @param[in] params Core KORC simulation parameters.
  !! @param[in,out] g Relativistic gamma factor @f$\gamma@f$ of the particles in a given species in the simulation. These are so that, they follow
  !! a Gamma distribution in energy. The parameters of the Gamma distributions are given by the user.
  !! @param[out] go Mean value of @f$\gamma@f$ of the particles in a given species. used to calculate the minimum required time step to
  !! resolve in detail the full-orbit dynamics of the particles.
  SUBROUTINE get_gamma_distribution(params,g,go)
    TYPE(KORC_PARAMS), INTENT(IN) 						:: params
    REAL(rp), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) 	:: g
    REAL(rp), INTENT(OUT) 								:: go

    call initialize_gamma_params(params)

    call save_gamma_params(params)

    call sample_gamma_distribution(params,g,go)
  END SUBROUTINE get_gamma_distribution

  !> @brief Subroutine that reads from the input file the parameters of the Gamma distribution
  !! @f$f_\Gamma(x,\kappa,\theta) = \frac{1}{\Gamma(\kappa) \theta^\kappa}x^{\kappa-1}\exp{\left(-x/\theta\right)}@f$.
  !!
  !! @param[in] params Core KORC simulation parameters.
  !! @param max_energy Maximum energy of sampled @f$f_\Gamma(x,\kappa,\theta)@f$ in MeV.
  !! @param min_energy Minimum energy of sampled @f$f_\Gamma(x,\kappa,\theta)@f$ in MeV.
  !! @param k Shape factor @f$\kappa@f$.
  !! @param t Scale factor @f$\theta@f$.
  SUBROUTINE initialize_gamma_params(params)
    TYPE(KORC_PARAMS), INTENT(IN) 	:: params
    REAL(rp) 						:: max_energy
    REAL(rp) 						:: min_energy
    REAL(rp) 						:: k
    REAL(rp) 						:: t

    !NAMELIST /EnergyGammaPDF/ max_energy,min_energy,k,t

    !open(unit=default_unit_open,file=TRIM(params%path_to_inputs),status='OLD',form='formatted')
    !read(default_unit_open,nml=EnergyGammaPDF)
    !close(default_unit_open)

    gamma_pdf_params%min_energy = min_energy_gamma*C_E ! In Joules
    gamma_pdf_params%max_energy = max_energy_gamma*C_E ! In Joules
    gamma_pdf_params%k = k_gamma
    gamma_pdf_params%t = t_gamma

    gamma_pdf_params%max_p = SQRT((gamma_pdf_params%max_energy/(C_ME*C_C**2))**2 - 1.0_rp) ! In units of mc
    gamma_pdf_params%min_p = SQRT((gamma_pdf_params%min_energy/(C_ME*C_C**2))**2 - 1.0_rp) ! In units of mc
  END SUBROUTINE initialize_gamma_params

  !> @brief Function that converts @f$x@f$ from degrees to radians.
  !!
  !! @param x Angle @f$x@f$ in degrees.
  !! @param deg2rad Angle @f$x@f$ converted to radians.
  FUNCTION deg2rad(x)
    REAL(rp), INTENT(IN) 	:: x
    REAL(rp) 				:: deg2rad

    deg2rad = C_PI*x/180.0_rp
  END FUNCTION deg2rad

  !> @brief Function that calculates the value of the Gamma distribution @f$f_\Gamma(x,\kappa,\theta) =
  !! \frac{1}{\Gamma(\kappa) \theta^\kappa}x^{\kappa-1}\exp{\left(-x/\theta\right)}@f$.
  !!
  !! @param x Variable @f$x@f$ of @f$f_\Gamma(x,\kappa,\theta)@f$.
  !! @param k Shape factor @f$\kappa@f$ of @f$f_\Gamma(x,\kappa,\theta)@f$.
  !! @param t Scale factor @f$\theta@f$ of @f$f_\Gamma(x,\kappa,\theta)@f$.
  !! @param fGamma Computed value of @f$f_\Gamma(x,\kappa,\theta)@f$.
  FUNCTION fGamma(x,k,t)
    REAL(rp), INTENT(IN) 	:: x
    REAL(rp), INTENT(IN) 	:: k
    REAL(rp), INTENT(IN) 	:: t
    REAL(rp)				:: fGamma

    fGamma = x**(k - 1.0_rp)*EXP(-x/t)/(GAMMA(k)*t**k)
  END FUNCTION fGamma

  !> Evaluation of the energy distribution function @f$f_{RE}(\mathcal{E})@f$ of runaway electrons as function of the normalized momentum
  !! @f$p' = p/m_ec@f$. Here, @f$p'@f$ is the normalized momentum and @f$m_e@f$ and @f$c@f$ are the electron mass and the speed of light.
  !!
  !! @param p Normalized momentum @f$p' = p/m_ec@f$ of a given electron in the simulation.
  !! @param fRE Computed value of the energy distribution function of runaway electrons.
  !! @param Eo Normalized energy @f$\mathcal{E}' = \sqrt{1 + p'}@f$ of the the electron with normalized momentum @f$p'@f$.
  FUNCTION fRE(p)
    REAL(rp), INTENT(IN) 	:: p ! momentum in units of mc
    REAL(rp) 				:: fRE
    REAL(rp) 				:: Eo ! In units of mc^2

    Eo = SQRT(p**2.0_rp + 1.0_rp)

    fRE = fGamma(Eo,gamma_pdf_params%k,gamma_pdf_params%t*co)
  END FUNCTION fRE

  !> @brief Gaussian random number generator.
  !! @details This function returns a deviate of a Gaussian distribution @f$f_G(x;\mu,\sigma) = \frac{1}{\sigma\sqrt{2\pi}} \exp{\left( -(x-\mu)^2/2\sigma^2 \right)}@f$,
  !! with mean @f$\mu@f$, and standard deviation @f$\sigma@f$.
  !!
  !! We use the Inverse Transform Sampling Method for sampling @f$x@f$. With this method we get @f$x = \sqrt{-2\log{(1-y)}}\cos(2\pi z)@f$,
  !! where @f$y@f$ and @f$z@f$ are uniform random numbers in the interval @f$[0,1]@f$.
  !!
  !! @param[in] mu Mean value @f$\mu@f$ of the Gaussian distribution.
  !! @param[in] mu Standard deviation @f$\sigma@f$ of the Gaussian distribution.
  !! @param random_norm Sampled number @f$x@f$ from the Gaussian distribution @f$f_G(x;\mu,\sigma)@f$.
  !! @param rand1 Uniform random number in the interval @f$[0,1]@f$.
  !! @param rand2 Uniform random number in the interval @f$[0,1]@f$.
  FUNCTION random_norm(mean,sigma)
    REAL(rp), INTENT(IN) 	:: mean
    REAL(rp), INTENT(IN) 	:: sigma
    REAL(rp) 				:: random_norm
    REAL(rp) 				:: rand1
    REAL(rp) 				:: rand2

    call RANDOM_NUMBER(rand1)
    call RANDOM_NUMBER(rand2)

    random_norm = SQRT(-2.0_rp*LOG(1.0_rp-rand1))*COS(2.0_rp*C_PI*rand2);
  END FUNCTION random_norm

  !> @brief Subroutine that samples a Gamma distribution representing the runaways' (marginal) energy distribution function.
  !! @details This subroutine uses the Metropolis-Hastings method for sampling the Gamma distribution representing the runaways'
  !! (marginal) energy distribution function. Unlike the typical Metropolis-Hasting method, after setting the boundaries of the region
  !! we want to sample, we perform a sampling in a larger region that contains the original sampling area plus a buffer region.
  !! After finishing the first sampling, we only keep the particles in the original sampling region, the particles in the p_buffer
  !! are sampled again until all of them lie within the original sampling region. This method ensures that the boundaries are
  !! well sampled.
  !!
  !! @param[in] params Core KORC simulation parameters.
  !! @param[in,out] g Relativistic gamma factor @f$\gamma@f$ of the particles in a given species in the simulation. These are so that,
  !! they follow a Gamma distribution in energy. The parameters of the Gamma distributions are given by the user.
  !! @param[out] go Mean value of @f$\gamma@f$ of the particles in a given species. used to calculate the minimum required time step to
  !! resolve in detail the full-orbit dynamics of the particles.
  !! @param p Sampled normalized momentum @f$p' = p/m_ec@f$ of particles in a given particle species.
  !! @param p_buffer Size along the momentum axis of the buffer used in the Metropolis-Hastings method.
  !! @param p_test The test value of the normalized momentum used in the Metropolis-Hastings method.
  !! @param ratio Ratio of probabilities used to determine when a move in during the sampling is kept as part of the sampled chain.
  !! @param rand_unif A deviate of a uniform random distribution in the interval @f$[0,1]@f$.
  !! @param p_samples Temporary array to keep the sampled normalized momentum.
  !! @param deta Step size along the pitch-angle direction of the random walk used in the Metropolis-Hastings sampling.
  !! @param dp  Step size along the momentum direction of the random walk used in the Metropolis-Hastings sampling.
  !! @param ii Iterator.
  !! @param ppp Number of particles per MPI processes.
  !! @param nsamples Number of total samples in the initial condition of a given simulation.
  !! @param mpierr MPI error status.
  SUBROUTINE sample_gamma_distribution(params,g,go)
    TYPE(KORC_PARAMS), INTENT(IN) 						:: params
    REAL(rp), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) 	:: g
    REAL(rp), INTENT(OUT) 								:: go
    REAL(rp), DIMENSION(:), ALLOCATABLE 				:: p
    REAL(rp) 											:: p_buffer
    REAL(rp) 											:: p_test
    REAL(rp) 											:: ratio
    REAL(rp) 											:: rand_unif
    REAL(rp), DIMENSION(:), ALLOCATABLE 				:: p_samples
    REAL(rp) 											:: deta
    REAL(rp) 											:: dp
    INTEGER 											:: ii
    INTEGER 											:: ppp
    INTEGER 											:: nsamples
    INTEGER 											:: mpierr

    ppp = SIZE(g)
    nsamples = ppp*params%mpi_params%nmpi
    ALLOCATE(p(ppp))

    dp = 1.0_rp

    if (params%mpi_params%rank.EQ.0_idef) then
       ALLOCATE(p_samples(nsamples))! Number of samples to distribute among all MPI processes

       call RANDOM_SEED()
       call RANDOM_NUMBER(rand_unif)
       p_buffer = gamma_pdf_params%min_p + (gamma_pdf_params%max_p - gamma_pdf_params%min_p)*rand_unif

       ii=2_idef
       do while (ii .LE. 1000000_idef)
          p_test = p_buffer + random_norm(0.0_rp,dp)
          do while ((p_test.LT.gamma_pdf_params%min_p).OR.(p_test.GT.gamma_pdf_params%max_p))
             p_test = p_buffer + random_norm(0.0_rp,dp)
          end do

          ratio = fRE(p_test)/fRE(p_buffer)

          if (ratio .GE. 1.0_rp) then
             p_buffer = p_test
             ii = ii + 1_idef
          else
             call RANDOM_NUMBER(rand_unif)
             if (rand_unif .LT. ratio) then
                p_buffer = p_test
                ii = ii + 1_idef
             end if
          end if
       end do

       call RANDOM_SEED()
       call RANDOM_NUMBER(rand_unif)
       p_samples(1) = p_buffer

       ii=2_idef
       do while (ii .LE. nsamples)
          p_test = p_samples(ii-1) + random_norm(0.0_rp,dp)
          do while ((p_test.LT.gamma_pdf_params%min_p).OR.(p_test.GT.gamma_pdf_params%max_p))
             p_test = p_samples(ii-1) + random_norm(0.0_rp,dp)
          end do

          ratio = fRE(p_test)/fRE(p_samples(ii-1))

          if (ratio .GE. 1.0_rp) then
             p_samples(ii) = p_test
             ii = ii + 1_idef
          else
             call RANDOM_NUMBER(rand_unif)
             if (rand_unif .LT. ratio) then
                p_samples(ii) = p_test
                ii = ii + 1_idef
             end if
          end if
       end do

       go = SUM(SQRT(1.0_rp + p_samples**2))/nsamples
    end if

    CALL MPI_SCATTER(p_samples,ppp,MPI_REAL8,p,ppp,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

    CALL MPI_BCAST(go,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

    call MPI_BARRIER(MPI_COMM_WORLD,mpierr)

    g = SQRT(1.0_rp + p**2)

    DEALLOCATE(p)
    if (params%mpi_params%rank.EQ.0_idef) then
       DEALLOCATE(p_samples)
    end if
  END SUBROUTINE sample_gamma_distribution

  !> @brief Surboutine that saves the Gamma distribution parameters to the HDF5 file <i>gamma_distribution_parameters.h5</i>.
  !!
  !! @param[in] params Core KORC simulation parameters.
  !! @param filename String containing the name of the HDF5 file.
  !! @param gname String containing the group name of a set of KORC parameters.
  !! @param attr_array An 1-D array with attributes of 1-D real or integer arrays that are passed to KORC interfaces of HDF5 I/O subroutines.
  !! @param dset Name of data set to be saved to file.
  !! @param attr A single attributes of real or integer data that is passed to KORC interfaces of HDF5 I/O subroutines.
  !! @param h5file_id HDF5 file identifier.
  !! @param group_id HDF5 group identifier.
  !! @param h5error HDF5 error status.
  !! @param units Temporary variable used to add physical units to KORC parameters.
  SUBROUTINE save_gamma_params(params)
    TYPE(KORC_PARAMS), INTENT(IN) 							:: params
    CHARACTER(MAX_STRING_LENGTH) 							:: filename
    CHARACTER(MAX_STRING_LENGTH) 							:: gname
    CHARACTER(MAX_STRING_LENGTH), DIMENSION(:), ALLOCATABLE :: attr_array
    CHARACTER(MAX_STRING_LENGTH) 							:: dset
    CHARACTER(MAX_STRING_LENGTH) 							:: attr
    INTEGER(HID_T) 											:: h5file_id
    INTEGER(HID_T) 											:: group_id
    INTEGER 												:: h5error
    REAL(rp) 												:: units

    if (params%mpi_params%rank .EQ. 0) then
       filename = TRIM(params%path_to_outputs) // "gamma_distribution_parameters.h5"
       call h5fcreate_f(TRIM(filename), H5F_ACC_TRUNC_F, h5file_id, h5error)

       gname = "params"
       call h5gcreate_f(h5file_id, TRIM(gname), group_id, h5error)

       dset = TRIM(gname) // "/min_energy"
       attr = "Minimum energy in avalanche PDF (eV)"
       units = 1.0_rp/C_E
       call save_to_hdf5(h5file_id,dset,units*gamma_pdf_params%min_energy,attr)

       dset = TRIM(gname) // "/max_energy"
       attr = "Maximum energy in avalanche PDF (eV)"
       units = 1.0_rp/C_E
       call save_to_hdf5(h5file_id,dset,units*gamma_pdf_params%max_energy,attr)

       dset = TRIM(gname) // "/max_p"
       attr = "Maximum momentum in avalanche PDF (me*c^2)"
       call save_to_hdf5(h5file_id,dset,gamma_pdf_params%max_p,attr)

       dset = TRIM(gname) // "/min_p"
       attr = "Maximum momentum in avalanche PDF (me*c^2)"
       call save_to_hdf5(h5file_id,dset,gamma_pdf_params%min_p,attr)

       dset = TRIM(gname) // "/k"
       attr = "Shape factor"
       call save_to_hdf5(h5file_id,dset,gamma_pdf_params%k,attr)

       dset = TRIM(gname) // "/t"
       attr = "Scale factor"
       call save_to_hdf5(h5file_id,dset,gamma_pdf_params%t,attr)

       call h5gclose_f(group_id, h5error)

       call h5fclose_f(h5file_id, h5error)
    end if
  END SUBROUTINE save_gamma_params

END MODULE korc_energy_pdfs


*> \brief \b CTZT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL             FUNCTION CTZT01( M, N, A, AF, LDA, TAU, WORK,
*                        LWORK )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LWORK, M, N
*       ..
*       .. Array Arguments ..
*       COMPLEX            A( LDA, * ), AF( LDA, * ), TAU( * ),
*      $                   WORK( LWORK )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CTZT01 returns
*>      || A - R*Q || / ( M * eps * ||A|| )
*> for an upper trapezoidal A that was factored with CTZRQF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrices A and AF.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrices A and AF.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          The original upper trapezoidal M by N matrix A.
*> \endverbatim
*>
*> \param[in] AF
*> \verbatim
*>          AF is COMPLEX array, dimension (LDA,N)
*>          The output of CTZRQF for input matrix A.
*>          The lower triangle is not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the arrays A and AF.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*>          TAU is COMPLEX array, dimension (M)
*>          Details of the  Householder transformations as returned by
*>          CTZRQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The length of the array WORK.  LWORK >= m*n + m.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_lin
*
*  =====================================================================
      REAL             FUNCTION CTZT01( M, N, A, AF, LDA, TAU, WORK,
     $                 LWORK )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), AF( LDA, * ), TAU( * ),
     $                   WORK( LWORK )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               NORMA
*     ..
*     .. Local Arrays ..
      REAL               RWORK( 1 )
*     ..
*     .. External Functions ..
      REAL               CLANGE, SLAMCH
      EXTERNAL           CLANGE, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CAXPY, CLATZM, CLASET, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, MAX, REAL
*     ..
*     .. Executable Statements ..
*
      CTZT01 = ZERO
*
      IF( LWORK.LT.M*N+M ) THEN
         CALL XERBLA( 'CTZT01', 8 )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
      NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
*     Copy upper triangle R
*
      CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M )
      DO 20 J = 1, M
         DO 10 I = 1, J
            WORK( ( J-1 )*M+I ) = AF( I, J )
   10    CONTINUE
   20 CONTINUE
*
*     R = R * P(1) * ... *P(m)
*
      DO 30 I = 1, M
         CALL CLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
     $                WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
     $                WORK( M*N+1 ) )
   30 CONTINUE
*
*     R = R - A
*
      DO 40 I = 1, N
         CALL CAXPY( M, CMPLX( -ONE ), A( 1, I ), 1,
     $               WORK( ( I-1 )*M+1 ), 1 )
   40 CONTINUE
*
      CTZT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK )
*
      CTZT01 = CTZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
      IF( NORMA.NE.ZERO )
     $   CTZT01 = CTZT01 / NORMA
*
      RETURN
*
*     End of CTZT01
*
      END


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

      SUBROUTINE VOL3D( COORD, LSTSN, NSEG, VOLUME, NDIM, NUMESS,
     *   CENT, NUMNP, CENTER)

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

C     DESCRIPTION:
C       This routine computes the volume of a cavity formed
C       by the boundary of an element side set flag

C     FORMAL PARAMETERS:
C       COORD   REAL      Nodal Coordinates
C       LSTSN   INTEGER   List of nodes on this boundary
C       NSEG    INTEGER   Number of segments in this boundary
C       VOLUME  REAL      Volume of this cavity
C       NDIM    INTEGER   Number of Nodes
C       CENT    REAL      Apex of Cavity Volume pentahedra

C     CALLED BY:

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

      DIMENSION COORD(NUMNP, *), LSTSN(*), CENT(3)
      LOGICAL CENTER

      VOLUME = 0.0

      IF (.NOT. CENTER) THEN
        XC = 0.0
        YC = 0.0
        ZC = 0.0
        DO KSEG = 1 , NSEG
          L = LSTSN(4*KSEG)
          K = LSTSN(4*KSEG - 1)
          J = LSTSN(4*KSEG - 2)
          I = LSTSN(4*KSEG - 3)

          X1 = COORD(I,1)
          X2 = COORD(J,1)
          X3 = COORD(K,1)
          X4 = COORD(L,1)

          Y1 = COORD(I,2)
          Y2 = COORD(J,2)
          Y3 = COORD(K,2)
          Y4 = COORD(L,2)

          Z1 = COORD(I,3)
          Z2 = COORD(J,3)
          Z3 = COORD(K,3)
          Z4 = COORD(L,3)

          XC = XC + x1 + x2 + x3 + x4
          YC = YC + y1 + y2 + y3 + y4
          ZC = ZC + z1 + z2 + z3 + z4
        END DO
        CENT(1) = XC / (4*NSEG)
        CENT(2) = YC / (4*NSEG)
        CENT(3) = ZC / (4*NSEG)
      END IF

      X5 = CENT(1)
      Y5 = CENT(2)
      Z5 = CENT(3)

      DO 100 KSEG = 1 , NSEG
         L = LSTSN(4*KSEG)
         K = LSTSN(4*KSEG - 1)
         J = LSTSN(4*KSEG - 2)
         I = LSTSN(4*KSEG - 3)

         X1 = COORD(I,1)
         X2 = COORD(J,1)
         X3 = COORD(K,1)
         X4 = COORD(L,1)

         Y1 = COORD(I,2)
         Y2 = COORD(J,2)
         Y3 = COORD(K,2)
         Y4 = COORD(L,2)

         Z1 = COORD(I,3)
         Z2 = COORD(J,3)
         Z3 = COORD(K,3)
         Z4 = COORD(L,3)

         Z13 = Z1 - Z3
         Z24 = Z2 - Z4
         Z31 = Z3 - Z1
         Z42 = Z4 - Z2
         Z51 = Z5 - Z1
         Z52 = Z5 - Z2
         Z53 = Z5 - Z3
         Z54 = Z5 - Z4

         VP = ((2.*Y5 - Y3) * Z42 + Y2 * (Z53 + Z54) -
     *      Y4 * (Z53 + Z52) ) * X1 +
     *       ( (Y4 - 2.*Y5) * Z31 + Y3 * (Z54 + Z51) -
     *      Y1 * (Z54 + Z53) ) * X2 +
     *       ( (Y1 - 2.*Y5) * Z42 + Y4 * (Z51 + Z52) -
     *      Y2 * (Z54 + Z51) ) * X3 +
     *       ( (2.*Y5 - Y2) * Z31 + Y1 * (Z52 + Z53) -
     *      Y3 * (Z52 + Z51) ) * X4 +
     *     ((Y2 - Y4) * (Z3 - Z1) + (Y3 - Y1) *(Z4 - Z2)) * 2. * X5
         VOLUME = VOLUME + VP / 12.0
  100 CONTINUE

      RETURN
      END


      subroutine setprob()
      implicit none

      double precision th, lambda

      double precision kappa,tfinal
      common /windparms/ kappa,tfinal

      double precision wcloc(3,2)
      common /location_parms/ wcloc

      double precision a_gauss, hmax_gauss
      common /gaussian_parms/ a_gauss, hmax_gauss

      double precision r_cb, hmax_cb, b_cb, c_cb
      common /cosinebell_parms/ r_cb, hmax_cb, b_cb, c_cb

      double precision r_sd, hmax_sd, b_sd, c_sd
      common /slotteddisk_parms/ r_sd, hmax_sd, b_sd, c_sd

      double precision pi, pi2
      common /compi/ pi, pi2

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

c     # These govern the wind speed; don't change final time here
c     # but rather use configuration tfinal.  This is really just
c     # a parameter and determines when the flow condition returns
c     # to its initial position.
      kappa = 2.0
      tfinal = 5.0

c     # -------------------------------------------------
c     # Locations for cosine bell, Gaussian or slotted disks
c     # -------------------------------------------------

      th = 0
      lambda = pi/6.d0
      wcloc(1,1) = cos(th)*cos(lambda)
      wcloc(2,1) = cos(th)*sin(lambda)
      wcloc(3,1) = sin(th)

      th = 0
      lambda = -pi/6.d0
      wcloc(1,2) = cos(th)*cos(lambda)
      wcloc(2,2) = cos(th)*sin(lambda)
      wcloc(3,2) = sin(th)

c     # Gaussian parameters
      hmax_gauss = 1
      a_gauss = 5

c     # Cosine bell parameters
      r_cb = 0.5
      hmax_cb = 1
      b_cb = 0.1d0
      c_cb = 0.9d0

c     # slotted disk parameters
      r_sd = 0.5
      hmax_sd = 1
      b_sd = 0.1d0
      c_sd = 0.9d0

      end


       subroutine qinit(meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux)
      implicit none

      integer maxmx, maxmy, meqn, mbc, mx, my, maux
      double precision xlower, ylower, dx, dy
      double precision q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

      integer initchoice
      common /initchoice_comm/ initchoice

      integer i,j
      double precision xc,yc, xlow, ylow,w,xp,yp,zp
      double precision q0_physical
      integer blockno

      blockno = 0
      do j = 1-mbc,my+mbc
          do i = 1-mbc,mx+mbc
              xc = xlower + (i-0.5)*dx
              yc = ylower + (j-0.5)*dy
              if (initchoice .eq. 0) then
c                 # Discontinuous solution
                  xlow = xlower + (i-1)*dx
                  ylow = ylower + (j-1)*dy
                  call cellave2(blockno,xlow,ylow,dx,dy,w)
                  q(1,i,j) = w
              elseif (initchoice .ge. 1) then
                  call mapc2m_cylinder(xc,yc,xp,yp,zp)
                  q(1,i,j) = q0_physical(xp,yp,zp)
              endif
          enddo
      enddo

      return
      end


subroutine fgmax_values(mx,my,meqn,mbc,maux,q,aux,dx,dy, &
                   xlower,ylower,mask_patch,values)

    ! Given a grid q (and aux if needed), set the elements of
    !   values(mv,i,j)  for mv=1:FG_NUM_VAL
    ! to the desired values that will be output and/or monitored on
    ! the fixed grid(s).
    !
    ! Only the elements for which mask_patch(i,j) == .true. need be set.

    ! This library routine expects FG_NUM_VAL to be 1, 2, or 5 and sets:
    !   values(1,i,j) = h              (if FG_NUM_VAL >= 1)
    !   values(2,i,j) = speed          (if FG_NUM_VAL >= 2)
    !   values(1,i,j) = momentum       (if FG_NUM_VAL == 5)
    !   values(1,i,j) = momentum flux  (if FG_NUM_VAL == 5)
    !   values(1,i,j) = -depth         (if FG_NUM_VAL == 5)
    ! The max of -depth can be used to determin the minimum depth of water
    ! at a point over the computation, useful in harbors where ships may be
    ! grounded if the depth goes too low.

    use fgmax_module
    use geoclaw_module, only: sea_level, dry_tolerance

    implicit none
    integer, intent(in) :: mx,my,meqn,mbc,maux
    real(kind=8), intent(in) :: q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8), intent(in) :: aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8), intent(in) :: dx,dy,xlower,ylower
    logical, intent(in) :: mask_patch(1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8), intent(inout) :: values(FG_NUM_VAL, 1-mbc:mx+mbc, 1-mbc:my+mbc)

    real(kind=8) :: s,hs,hss,s_dry_tol
    real(kind=8), dimension(:,:), allocatable :: u,v,h

    allocate(h(1-mbc:mx+mbc, 1-mbc:my+mbc))
    if (FG_NUM_VAL > 1) then
        allocate(u(1-mbc:mx+mbc, 1-mbc:my+mbc), v(1-mbc:mx+mbc, 1-mbc:my+mbc))
        endif

    h = q(1,:,:)

    where (mask_patch)
        values(1,:,:) = h
    endwhere

    if (FG_NUM_VAL == 1) then
        return
        endif

    ! compute velocities:
    s_dry_tol = dry_tolerance
    where (mask_patch .and. (h > s_dry_tol))
        u = q(2,:,:) / h
        v = q(3,:,:) / h
    elsewhere
        u = 0.
        v = 0.
    endwhere

    where (mask_patch)
        values(2,:,:) = sqrt(u**2 + v**2)             ! s,    speed
    endwhere

    if (FG_NUM_VAL == 2) then
        return
        endif

    if (FG_NUM_VAL .ne. 5) then
        write(6,*) '*** Error -- expecting FG_NUM_VAL = 1, 2, or 5'
        write(6,*) '***   in fgmax_values, found FG_NUM_VAL = ',FG_NUM_VAL
        stop
        endif

    where (mask_patch)
        values(3,:,:) = h*values(2,:,:)               ! hs,   momentum
        values(4,:,:) = values(3,:,:)*values(2,:,:)   ! hs^2, momentum flux
        values(5,:,:) = -h                            ! to find min h
    endwhere

end subroutine fgmax_values


        Include 'VICMAIN_FOR'
c
C-----THIS PROGRAM TESTS SUBROUTINE MOMATV
c
        Subroutine  Main44
	implicit real*8 (a-z)
	common/c/fl,oal,oas,scl,slat,slon,lss,sss,na,rng
	real*8 om(9),rs(3)
        character*80   header
        Data Header /'           fl   oal   oas   scl   slat   slon   lss   sss
     1  na   rng'/

C
C-----SET UP THE TEST INPUT BUFFER
	fl = 1500.1904
	oal = 500.
	oas = 500.
	scl = 84.821431
	slat = 3.4825339
	slon = 116.72441
	lss = -121.600
	sss = 1662.700
	na = 160.8923
 	rng = 14967727.
c
c-----print the input parameters
c
c	call qprint('           fl   oal   oas   scl   slat   slon   lss   sss
c     1  na   rng',67)

        Call Xvmessage(Header, ' ')
	call prnt(8,10,fl,'.')
c
C-----CALL THE SUBROUTINE TO BE TESTED
c
	CALL momatv(oal,oas,lss,sss,scl,fl,slon,slat,na,rng,om,rs)
c
C-----PRINT THE RESULTING OM MATRIX AND RS VECTOR
c
	CALL PRNT(8,9,oM,' OM MATRIX.')
	CALL PRNT(8,3,rs,' RS VECTOR.')

        Return
	END


module system

  implicit none
  private
  public :: assemble_system1, assemble_system2, assemble_system3

contains

  !---------------------------------------------------------------------!
  ! Assemble Ax = b (Case (a))
  !---------------------------------------------------------------------!

  subroutine assemble_system1(npts, A, b, x0)

    implicit none

    integer, intent(in)  :: npts
    real(8), intent(out) :: A(npts,npts)
    real(8), intent(out) :: b(npts)
    real(8), intent(out) :: x0(npts)

    integer :: M, N
    integer :: i, j, k

    ! Zero all entries
    A = 0.0d0

    ! Size of the linear system
    M = npts ! nrows
    N = npts ! ncols

    ! Assemble matrix
    A(M,1) = 1.0d0
    A(1,N) = 1.0d0
    forall(i=1:M-1) A(i,i+1) = 1.0d0

    ! Assemble right hand side
    b = 0.0d0
    b(1) = 1.0d0

    ! Initial guess
    x0 = 0.0d0

  end subroutine assemble_system1

  !---------------------------------------------------------------------!
  ! Assemble Ax = b (Case (b))
  !---------------------------------------------------------------------!

  subroutine assemble_system2(npts, A, b, x0)

    implicit none

    integer, intent(in)  :: npts
    real(8), intent(out) :: A(npts,npts)
    real(8), intent(out) :: b(npts)
    real(8), intent(out) :: x0(npts)

    integer :: M, N
    integer :: i, j, k

    ! Zero all entries
    A = 0.0d0

    ! Size of the linear system
    M = npts ! nrows
    N = npts ! ncols

    ! Assemble matrix
    forall(i=1:M) A(i,i) = 1.0d0 ! diagonal
    j = 0
    do i = 1, M-1, 2
       j = j + 1
       A(i,i+1) = dble(j) - 1.0d0
    end do

    ! Assemble right hand side
    b = 0.0d0
    b(1) = 1.0d0

    ! Initial guess
    x0 = 0.0d0

  end subroutine assemble_system2

  !-------------------------------------------------------------------!
  !Assemble Ax = b (GMRES)
  !-------------------------------------------------------------------!

  subroutine assemble_system3(npts, A, b, x0)

    implicit none

    integer, intent(in)  :: npts
    real(8), intent(out) :: A(npts,npts)
    real(8), intent(out) :: b(npts)
    real(8), intent(out) :: x0(npts)

    integer :: M, N
    integer :: i, j, k

    ! Zero all entries
    A = 0.0d0

    ! Size of the linear system
    M = npts ! nrows
    N = npts ! ncols

    ! Assemble matrix
    A(1,N) = 1.0d0
    forall(i=2:M) A(i,i-1) = 1.0d0

    ! Assemble right hand side
    b = 0.0d0
    b(1) = 1.0d0

    ! Initial guess
    x0 = 0.0d0

  end subroutine assemble_system3

end module system

!!$program test
!!$
!!$  use system
!!$  use linear_algebra
!!$
!!$  implicit none
!!$
!!$  integer, parameter :: npts = 1000
!!$  real(8), parameter :: max_tol = 1.0d-8
!!$  integer, parameter :: max_it = 100000
!!$  real(8) :: x(npts), b(npts), A(npts,npts), P(npts, npts)
!!$  integer :: iter, flag, i, j
!!$  real(8) :: tol
!!$  complex(8) :: eigs(npts)
!!$
!!$  call assemble_system1(npts, A, b, x)
!!$  !do i = 1,npts
!!$  !   write(*,*) ( A(i,j), j=1,npts )
!!$  !enddo
!!$
!!$  eigs = sqrt(eigvals(matmul(A, transpose(A)))       )
!!$  !do i = 1, npts
!!$ !    !print *, realpart(eigs(i)), imagpart(eigs(i)), abs(eigs(i))
!!$ ! end do
!!$  print *, maxval(realpart(eigs)), minval(realpart(eigs))
!!$
!!$end program test


module gradation_processing
  implicit none
contains
  pure function make_histogram(layer, maximum_number) result(hist)
    implicit none
    integer, intent(in) :: layer(:, :)
    integer, intent(in) :: maximum_number
    integer :: hist(0:maximum_number), layer_shape(2), h, w
    hist = 0

    layer_shape = shape(layer)
    do w = 1, layer_shape(2)
      do h = 1, layer_shape(1)
        hist(layer(h, w)) = hist(layer(h, w)) + 1
      end do
    end do
  end function make_histogram

  pure function linear_translation(img, maximum_value, low_threshold, high_threshold) result(translated)
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in), optional :: maximum_value, low_threshold, high_threshold
    integer :: d, w, h, img_shape(3), i, v_max, v_min, m
    integer, allocatable :: lut(:), translated(:, :, :)

    if (present(maximum_value)) then
      m = 255
    else
      m = maximum_value
    end if
    img_shape = shape(img)
    allocate (translated(img_shape(1), img_shape(2), img_shape(3)))
    allocate (lut(0:maximum_value))

    do d = 1, img_shape(1)
      if (present(low_threshold)) then
        v_min = low_threshold
      else
        v_min = minval(img(d, :, :))
      end if
      if (present(high_threshold)) then
        v_max = high_threshold
      else
        v_max = maxval(img(d, :, :))
      end if
      do i = 0, maximum_value
        lut(i) = min(maximum_value, &
                     max(0, &
                         nint(((real(i) - v_min)/(v_max - v_min))*maximum_value)))
      end do
      do w = 1, img_shape(3)
        do h = 1, img_shape(2)
          translated(d, h, w) = lut(img(d, h, w))
        end do
      end do
    end do
  end function linear_translation

  pure function brightness_translation(img, shift, maximum_value) result(translated)
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: shift
    integer, intent(in), optional :: maximum_value
    integer :: img_shape(3), m
    integer, allocatable :: translated(:, :, :)

    if (present(maximum_value)) then
      m = maximum_value
    else
      m = 255
    end if

    img_shape = shape(img)
    translated = img

    translated = min(m, &
                     max(0, &
                         translated + shift))
  end function brightness_translation

  pure function contrast_translation(img, maximum_value, K) result(translated)
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    real, intent(in) :: K
    integer ::img_shape(3), d, h, w, i
    integer, allocatable :: translated(:, :, :), lut(:)

    allocate (lut(0:maximum_value))

    do i = 0, maximum_value
      lut(i) = min(maximum_value, &
                   max(0, &
                       nint(K*(i - maximum_value/2) + maximum_value/2)))
    end do

    img_shape = shape(img)
    allocate (translated(img_shape(1), img_shape(2), img_shape(3)))
    do w = 1, img_shape(3)
      do h = 1, img_shape(2)
        do d = 1, img_shape(1)
          translated(d, h, w) = lut(img(d, h, w))
        end do
      end do
    end do
  end function contrast_translation

  pure function gamma_correction(img, maximum_value, g) result(translated)
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    real, intent(in) :: g
    integer, allocatable :: translated(:, :, :)
    integer :: lut(0:maximum_value), img_shape(3), d, h, w, i

    img_shape = shape(img)
    allocate (translated(img_shape(1), img_shape(2), img_shape(3)))

    do i = 0, maximum_value
      lut(i) = nint(maximum_value*(real(i)/maximum_value)**(1/g))
    end do

    do w = 1, img_shape(3)
      do h = 1, img_shape(2)
        do d = 1, img_shape(1)
          translated(d, h, w) = lut(img(d, h, w))
        end do
      end do
    end do
  end function gamma_correction

  pure function histogram_equalization(img, maximum_value) result(translated)
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    integer, allocatable :: translated(:, :, :), hist(:), layer(:, :)
    integer :: d, h, w, img_shape(3), i

    img_shape = shape(img)
    allocate (translated(img_shape(1), img_shape(2), img_shape(3)))

    do d = 1, img_shape(1)
      layer = img(d, :, :)
      hist = make_histogram(layer, maximum_value)
      do i = 1, size(hist)
        hist(i) = hist(i - 1) + hist(i)
      end do
      hist = nint(hist*(maxval(layer)/real(img_shape(2)*img_shape(3))))
      do w = 1, img_shape(3)
        do h = 1, img_shape(2)
          translated(d, h, w) = hist(img(d, h, w))
        end do
      end do
    end do
  end function histogram_equalization
end module


!Main part of the program. Contains: loop for simulation and two subroutines for printing information during simulation.

program project5_main
      use dynamics_mod
      integer::i
      real(rk)::sim_time

      !Initialization of simulation information and files
      call read_input()
      call clear_output()

      !Starting information, sim_time is used to keep track of time.
      print "(a)","Initial positions:"
      call pos_info()
      sim_time=0.0

      !Simulation loop
      do i=1, int(instr(3))
        call update_sys()
        sim_time=sim_time+instr(1)

        !Check for info or write
        if(mod(i,int(instr(5)))==0) then
                call write_data(sim_time)
        end if
        if(mod(i,int(instr(4)))==0) then
                call info(i)
        end if
      end do
      print "(a)", "-----"

      !Final information
      print "(a)","Final positions:"
      call pos_info()

contains
        !Subroutine for printing the required information
        subroutine info(step)
                implicit none
                integer,intent(in)::step
                integer::j
                print "(a)", "-----"
                print "(a,i0)", "Number of objects: ",size(system)
                print "(a,f7.1,a)", "Time from the beginning of simulation: ",step*instr(1)/60/60/24," days"
                print "(a,i0)", "Number of steps from the beginning of simulation: ", step
                print "(a,i0)", "Number of steps written to file: ", int(step/instr(5))
                print "(a)", "Positions of objects (meters from origin):"
                call pos_info()
         end subroutine info

         !Subroutine for getting the positions of the objects
         subroutine pos_info()
                 implicit none
                 integer::k
                 do k=1, size(system)
                        print "(a,3ES18.5)", trim(system(k)%description), system(k)%pos
                end do
         end subroutine pos_info
end program


!=============================================================================!
        module const
!=============================================================================!
!.... Useful constants

        real, parameter :: zero    = 0.0000000000000000000d+0
        real, parameter :: pt25    = 2.5000000000000000000d-1
        real, parameter :: pt33    = 3.3333333333333333333d-1
        real, parameter :: pt5     = 5.0000000000000000000d-1
        real, parameter :: pt66    = 6.6666666666666666666d-1
        real, parameter :: one     = 1.0000000000000000000d+0
        real, parameter :: onept25 = 1.2500000000000000000d+0
        real, parameter :: onept5  = 1.5000000000000000000d+0
        real, parameter :: two     = 2.0000000000000000000d+0
        real, parameter :: four    = 4.0000000000000000000d+0
        real, parameter :: pi      = 3.1415926535897932385d+0

        end module const
!=============================================================================!


MODULE neo_rk4dcur
  INTERFACE rk4d_cur
     SUBROUTINE rk4d_cur1(x,y,h)
       USE neo_precision
       REAL(dp),               INTENT(inout) ::  x
       REAL(dp),               INTENT(in)    ::  h
       REAL(dp), DIMENSION(:), INTENT(inout) ::  y
     END SUBROUTINE rk4d_cur1
  END INTERFACE
END MODULE neo_rk4dcur


FUNCTION RINT13(REL,A,B,X,Y,NRAD,DX_,JRI_,R0_) result(S)
  ! Input: A, B, X, Y, jatom
  !
  ! Output: S
  !
  !     PERFORM RADIAL INTEGRALS REQUIRED BY BHDK13
  !                            D.D.KOELLING
  ! We are integrating f(r) = A(r)*X(r)+ B(r)*Y(r)*1/137
  !  where r-mesh is exponential in the form r=e^{i*dx}
  !  therefore the integral is Int f(r)dr = Int f(e^{i*dx})e^{i*dx}*dx
  !  which can also be written Sum f(r_i)*r_i*dx
  ! The simpson method then collects the even and odd terms and
  ! adds 2/3 and 4/3 to each, and also takes care of the end points.
  !
  IMPLICIT NONE
  !
  REAL*8 :: S
  LOGICAL, intent(in) :: REL   ! relativistic or not
  REAL*8, intent(in)  :: A(NRAD),B(NRAD),X(NRAD),Y(NRAD)
  INTEGER, intent(in) :: NRAD, JRI_
  REAL*8, intent(in)  :: DX_, R0_
  !locals
  REAL*8 :: D, CIN, R, R1, P1, P2, Z2, Z4
  INTEGER :: J, J1
  !
  D=EXP(DX_)
  CIN=1.d0/137.0359895d0**2
  IF(.NOT.REL) CIN=1E-22
  !
  J=3-MOD(JRI_,2)
  J1=J-1
  R=r0_*(D**(J-1))
  R1=R/D
  Z4=0
  Z2=0
  DO
     Z4=Z4+R*(A(J)*X(J)+CIN*B(J)*Y(J)) ! Z4 ~ R*A*X (r)
     R=R*D
     J=J+1
     IF(J.GE.JRI_) EXIT
     Z2=Z2+R*(A(J)*X(J)+CIN*B(J)*Y(J)) ! Z2 ~ R*A*X (r+dr)
     R=R*D
     J=J+1
  ENDDO
  P1=r0_*(A(1)*X(1)+CIN*B(1)*Y(1))
  P2=R1*(A(J1)*X(J1)+CIN*B(J1)*Y(J1))
  S=2*Z2+4*Z4+R*(A(J)*X(J)+CIN*B(J)*Y(J))+P2
  S=(DX_*S+P1)/3.0D0
  IF(J1.GT.1) S=S+0.5D0*DX_*(P1+P2)
  RETURN
END FUNCTION RINT13

FUNCTION RINT13g(C1,C2,A,B,X,Y,NRAD,DX_,JRI_,R0_) result(S)
  ! C1=1, C2=[1.d0/137.0359895d0**2 or 0]
  IMPLICIT NONE
  !     PERFORM RADIAL INTEGRALS REQUIRED BY BHDK13
  !     Nornally C1=1 and C2=1/speed_of_light^2
  !        but here C1 and C2 are arbitrary
  !                            D.D.KOELLING
  REAL*8 :: S
  REAL*8, intent(in) :: C1, C2
  REAL*8, intent(in) :: A(NRAD), B(NRAD), X(NRAD), Y(NRAD)
  INTEGER, intent(in):: NRAD, JRI_
  REAL*8, intent(in) :: DX_, R0_
  ! locals
  INTEGER::            J, J1
  REAL*8 ::   D, P1, P2, R, R1, Z2, Z4
  D = EXP(DX_)
  J = 3-MOD(JRI_,2)
  J1=J-1
  R = r0_*(D**(J-1))
  R1 = R/D
  Z4 = 0
  Z2 = 0
  DO
     Z4=Z4+R*(C1*A(J)*X(J) + C2*B(J)*Y(J))     ! Z4 ~ R*A*X (r)
     R=R*D
     J=J+1
     IF (J .GE. JRI_) EXIT !GOTO 20
     Z2 = Z2 + R*(C1*A(J)*X(J) + C2*B(J)*Y(J))  ! Z2 ~ R*A*X (r+dr)
     R=R*D
     J=J+1
  enddo
  P1 = R0_*(C1*A(1)*X(1) + C2*B(1)*Y(1))
  P2 = R1*(C1*A(J1)*X(J1) + C2*B(J1)*Y(J1))
  S = 2*Z2 + 4*Z4 + R*(C1*A(J)*X(J) + C2*B(J)*Y(J)) + P2
  S = (DX_*S+P1)/3.0D+0
  IF (J1.GT.1) S=S+0.5D0*DX_*(P1+P2)
  RETURN
END FUNCTION RINT13g

REAL*8 FUNCTION Rint13n(N,A,B,X,Y,r0,dx,rel)
  ! PERFORM RADIAL INTEGRALS SIMILAR TO RINT13 in modern form
  !  D.D.KOELLING
  IMPLICIT NONE
  INTEGER, intent(in) :: N
  REAL*8, intent(in)  :: A(N), B(N), X(N), Y(N)
  REAL*8, intent(in)  :: r0, dx
  LOGICAL, intent(in) :: rel
  ! locals
  REAL*8  :: S
  REAL*8  :: CIN, D, Z4, Z2, P1, P2, PN
  INTEGER :: j, i
  REAL*8 :: FM(N), RX(N)

  D=exp(dx)
  RX(1)=r0
  DO j=2,N
     RX(j)=RX(j-1)*D
  ENDDO

  IF (rel) then  ! relativistic or no
     CIN=1.d0/137.0359895d0**2
     FM(:) = RX(:)*(A(:)*X(:)+CIN*B(:)*Y(:))
  else
     FM(:) = RX(:)*A(:)*X(:)
  endif

  j=3-MOD(N,2)

  P1=FM(1)
  P2=FM(j-1)

  Z4=0
  Z2=0
  DO i=j,N-3,2
     Z4=Z4+FM(i)
     Z2=Z2+FM(i+1)
  ENDDO
  Z4=Z4+FM(N-1)
  PN=FM(N)

  S=(dx*(2*Z2+4*Z4+PN+P2)+P1)/3.0D0
  if (j-1.GT.1) S=S+0.5D0*dx*(P1+P2)
  Rint13n=S
  Return
END FUNCTION Rint13n


!***********************************************************************
!   Copyright (c) 2019 D. de Vries
!   Original Copyright (c) 2000 Mark Drela
!
!   This file is part of XFoil.
!
!   XFoil 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 3 of the License, or
!   (at your option) any later version.
!
!   XFoil 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 XFoil.  If not, see <https://www.gnu.org/licenses/>.
!***********************************************************************

!*==M_XUTILS.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
module m_xutils
    implicit none
    !
    !*** Start of declarations rewritten by SPAG
    !
    !*** End of declarations rewritten by SPAG
    !
    !
    !*** Start of declarations rewritten by SPAG
    !
    !*** End of declarations rewritten by SPAG
    !
contains
    subroutine setexp(S, Ds1, Smax, Nn)
        use i_xfoil, only: show_output
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        real :: Ds1, Smax
        integer :: Nn
        real, dimension(Nn) :: S
        intent (in) Ds1, Nn, Smax
        intent (inout) S
        !
        ! Local variables
        !
        real :: aaa, bbb, ccc, disc, dratio, dresdr, ds, ratio, res, rnex, rni, sigma, sigman
        integer :: iter, n, nex
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !........................................................
        !     Sets geometrically stretched array S:
        !
        !       S(i+1) - S(i)  =  r * [S(i) - S(i-1)]
        !
        !       S     (output)  array to be set
        !       DS1   (input)   first S increment:  S(2) - S(1)
        !       SMAX  (input)   final S value:      S(NN)
        !       NN    (input)   number of points
        !........................................................
        !
        sigma = Smax / Ds1
        nex = Nn - 1
        rnex = float(nex)
        rni = 1.0 / rnex
        !
        !---- solve quadratic for initial geometric ratio guess
        aaa = rnex * (rnex - 1.0) * (rnex - 2.0) / 6.0
        bbb = rnex * (rnex - 1.0) / 2.0
        ccc = rnex - sigma
        !
        disc = bbb**2 - 4.0 * aaa * ccc
        disc = max(0.0, disc)
        !
        if (nex<=1) then
            stop 'SETEXP: Cannot fill array.  N too small.'
        elseif (nex==2) then
            ratio = -ccc / bbb + 1.0
        else
            ratio = (-bbb + sqrt(disc)) / (2.0 * aaa) + 1.0
        endif
        !
        if (ratio/=1.0) then
            !
            !---- Newton iteration for actual geometric ratio
            do iter = 1, 100
                sigman = (ratio**nex - 1.0) / (ratio - 1.0)
                res = sigman**rni - sigma**rni
                dresdr = rni * sigman**rni * (rnex * ratio**(nex - 1) - sigman) / (ratio**nex - 1.0)
                !
                dratio = -res / dresdr
                ratio = ratio + dratio
                !
                if (abs(dratio)<1.0E-5) goto 100
                !
            enddo
            if (show_output) write (*, *) 'SETEXP: Convergence failed.  Continuing anyway ...'
        endif
        !
        !---- set up stretched array using converged geometric ratio
        100  S(1) = 0.0
        ds = Ds1
        do n = 2, Nn
            S(n) = S(n - 1) + ds
            ds = ds * ratio
        enddo
        !
    end subroutine setexp

    function atanc(Y, X, Thold)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        real :: Thold, X, Y
        real :: atanc
        intent (in) Thold, X, Y
        !
        ! Local variables
        !
        real :: dtcorr, dthet, thnew
        real, save :: pi, tpi
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !---------------------------------------------------------------
        !     ATAN2 function with branch cut checking.
        !
        !     Increments position angle of point X,Y from some previous
        !     value THOLD due to a change in position, ensuring that the
        !     position change does not cross the ATAN2 branch cut
        !     (which is in the -x direction).  For example:
        !
        !       ATANC( -1.0 , -1.0 , 0.75*pi )  returns  1.25*pi , whereas
        !       ATAN2( -1.0 , -1.0 )            returns  -.75*pi .
        !
        !     Typically, ATANC is used to fill an array of angles:
        !
        !        THETA(1) = ATAN2( Y(1) , X(1) )
        !        DO i=2, N
        !          THETA(i) = ATANC( Y(i) , X(i) , THETA(i-1) )
        !        END DO
        !
        !     This will prevent the angle array THETA(i) from jumping by
        !     +/- 2 pi when the path X(i),Y(i) crosses the negative x axis.
        !
        !     Input:
        !       X,Y     point position coordinates
        !       THOLD   position angle of nearby point
        !
        !     Output:
        !       ATANC   position angle of X,Y
        !---------------------------------------------------------------
        data pi/3.1415926535897932384/
        data tpi/6.2831853071795864769/
        !
        !---- set new position angle, ignoring branch cut in ATAN2 function for now
        thnew = atan2(Y, X)
        dthet = thnew - Thold
        !
        !---- angle change cannot exceed +/- pi, so get rid of any multiples of 2 pi
        dtcorr = dthet - tpi * int((dthet + sign(pi, dthet)) / tpi)
        !
        !---- set correct new angle
        atanc = Thold + dtcorr
        !
    end function atanc
    ! ATANC
end module m_xutils


      SUBROUTINE FIXRTS(D,NPOLES)
      PARAMETER (NPMAX=100)
      DIMENSION D(NPOLES)
      LOGICAL POLISH
      COMPLEX A(NPMAX),ROOTS(NPMAX)
      A(NPOLES+1)=CMPLX(1.,0.)
      DO 11 J=NPOLES,1,-1
        A(J)=CMPLX(-D(NPOLES+1-J),0.)
11    CONTINUE
      POLISH=.TRUE.
      CALL ZROOTS(A,NPOLES,ROOTS,POLISH)
      DO 12 J=1,NPOLES
        IF(CABS(ROOTS(J)).GT.1.)THEN
          ROOTS(J)=1./CONJG(ROOTS(J))
        ENDIF
12    CONTINUE
      A(1)=-ROOTS(1)
      A(2)=CMPLX(1.,0.)
      DO 14 J=2,NPOLES
        A(J+1)=CMPLX(1.,0.)
        DO 13 I=J,2,-1
          A(I)=A(I-1)-ROOTS(J)*A(I)
13      CONTINUE
        A(1)=-ROOTS(J)*A(1)
14    CONTINUE
      DO 15 J=1,NPOLES
        D(NPOLES+1-J)=-REAL(A(J))
15    CONTINUE
      RETURN
      END


      real*8 function gaussn(IG0)
C  GENERATE GAUSSIAN RANDUM DEVIATES WITH ZERO MEAN AND UNIT S.D.
C   INPUT: IG0=ODD INTEGER
      IMPLICIT REAL*8 (A-H,O-Z)
      real*8 xx
      parameter (xx=6.550464984D-19/3.063100571D-00)
      INTEGER*4 IRC
      data IRC /48828125/
C
 1000 continue
      IF (IG0 .EQ. 0) go to 9999
        IG0=IRc*IG0
        IGA=ABS(IG0)
        Y=DBLE(IGA)
        IF(IGA .LT. 1288490189) THEN
          YY=Y*Y
          gaussn=((xx*YY+1.d0)*3.06310057134D-29*YY
     %            +5.84190096639D-10)*Y
        ELSE IF(IGA .LT. 1997159793) THEN
          gaussn=((2.15247545000D9-Y)*Y+5.13646191373D17)
     %      /((0.448498722421D0*Y-3.55927532674D9)*Y+5.77424700846D18)
        ELSE IF(IGA .LT. 2126008812) THEN
          gaussn=((Y-5.53451026774D9)*Y+7.30305470154D18)
     %      /((1.68096862343D0*Y-7.78160540942D9)*Y+8.96788425914D18)
        ELSE
          T=DSQRT(-DLOG((0.5-2.3283064365387D-10*Y)**2))
          gaussn=(T-(T+7.0309866D0)
     %                /((0.18604881D0*T+3.0556532D0)*T+3.2217897D0))
        ENDIF
        IF (IG0 .LT. 0) gaussn=-gaussn
      RETURN
 9999 continue
        call errmsg('gaussn',
     &              'random seed becomes 0',0,0)
        ig0=irc**2+2
        go to 1000
      END


      SUBROUTINE REALFT(DATA,N,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
      THETA=6.28318530717959D0/2.0D0/DBLE(N)
      C1=0.5
      IF (ISIGN.EQ.1) THEN
        C2=-0.5
        CALL FOUR1(DATA,N,+1)
      ELSE
        C2=0.5
        THETA=-THETA
      ENDIF
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      WR=1.0D0+WPR
      WI=WPI
      N2P3=2*N+3
      DO 11 I=2,N/2+1
        I1=2*I-1
        I2=I1+1
        I3=N2P3-I2
        I4=I3+1
        WRS=SNGL(WR)
        WIS=SNGL(WI)
        H1R=C1*(DATA(I1)+DATA(I3))
        H1I=C1*(DATA(I2)-DATA(I4))
        H2R=-C2*(DATA(I2)+DATA(I4))
        H2I=C2*(DATA(I1)-DATA(I3))
        DATA(I1)=H1R+WRS*H2R-WIS*H2I
        DATA(I2)=H1I+WRS*H2I+WIS*H2R
        DATA(I3)=H1R-WRS*H2R+WIS*H2I
        DATA(I4)=-H1I+WRS*H2I+WIS*H2R
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
11    CONTINUE
      IF (ISIGN.EQ.1) THEN
        H1R=DATA(1)
        DATA(1)=H1R+DATA(2)
        DATA(2)=H1R-DATA(2)
      ELSE
        H1R=DATA(1)
        DATA(1)=C1*(H1R+DATA(2))
        DATA(2)=C1*(H1R-DATA(2))
        CALL FOUR1(DATA,N,-1)
      ENDIF
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute time since 1950 (in days)
C
      SUBROUTINE T1950(IDATE,ITIME,RSC,t) !VRH 7/28/89
      IMPLICIT REAL*8 (A-H,O-Z)

      IYEAR = IDATE/1000
      IDAY = MOD(IDATE,1000) + 365.25*(IYEAR-1900) - 18262.125 !days since 1950
      JTIME = ITIME/1000
      ISEC = MOD(JTIME,100)
      JTIME = JTIME/100
      IMIN = MOD(JTIME,100)
      IHOUR = JTIME/100
      HOUR = IHOUR + (ISEC/60.D0 + IMIN)/60.0D0
      T = IDAY + HOUR/24.0D0
C Make one-way light travel time correction to planet (SEDR79V2 does this
C for planet but T here is for rings).  VRH 7/28/89 - ERT changed to Object
      DELERT = RSC/2.997925D+5/86400.	! Light travel time in days
      T = T - DELERT	!Adjust to Planet observation time
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Determine longitude and time of standard epoch.
C
      SUBROUTINE GETEPOCH(PLANET_ID,ALPHAp,DELTAp,THETA,ZETAZ,phip,t0)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER*4 PLANET_ID

      IF (PLANET_ID.LT.5) RETURN
C
C VRH 7/28/89 - Time of Epochs changed from Earth received time to
C               Planet time.
C
C Saturn:  Carolyn's epoch similar to French's except intersection of
C          Saturn's equator 1950 with Earth's equator at EME1950
C          Carolyn's epoch starts at 23:46 UT, 11/12/80 =
C          Time of Voyager 1 closest approch
C
C Uranus:  French's epoch starts at 20:00 UT, 3/10/77
C
C Neptune: Epoch = 0h ET ( = UT + 56.184 sec), SCET, Aug 25 1989
C                  (determined by NAV team)
C
      IF (PLANET_ID.EQ.5) THEN		!****Jupiter undefined
         T0=0.D0
      ELSE IF (PLANET_ID.EQ.6) THEN	!Carolyn's epoch
         T0 = 365.25*80.0 - 18262.125 + (305.+12.) + 23./24. + 46./1440.
      ELSE IF (PLANET_ID.EQ.7) THEN	!French's epoch
        T0 = 365.25*77.0 - 18262.125 + (31+28+10) + 20./24.  !days since EME50
      ELSE IF (PLANET_ID.EQ.8) THEN
        T0 = 365.25*89.0 - 18262.125 + (31+28+31+30+31+30+30+25)
      ENDIF

C     ....Calculate longitude PHIp
      A =  DSIN(THETA)*DCOS(ZETAZ)
      B = -DSIN(THETA)*DSIN(ZETAZ)
      C =  DCOS(THETA)
      D =  DCOS(DELTAp)*DCOS(ALPHAp)
      E =  DCOS(DELTAp)*DSIN(ALPHAp)
      F =  DSIN(DELTAp)
      X = B*F - C*E
      Y = C*D - A*F
      Z = A*E - B*D
      PHIp = DASIN(Z/DSQRT(X**2+Y**2+Z**2)/DCOS(DELTAp))
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the orbital data, navigate each of the rings.
C IMODE = 0  Get orbital data from OE (C2 common block)
C       = 1  Get orbital data using GETRING (most current parameters)
      SUBROUTINE ERING0(PLANET_ID,T,T0,IMODE)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER*4 PLANET_ID

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      common/coe/oe(110,4),oef,oefname	!Orbital elements for J,S,U,N
      integer*4 oef
      character*256 oefname

      COMMON/C2/DATE,PBUF(4),RBUF(7,15)
      REAL*8 ME0(3,3)

      CALL ME0CALC(ALPHAp,DELTAp,me0)	!Get planet's ME-matrix

      DO IRING=1,15  ! To include new rings VRH 6/7/89
          IF (IMODE.EQ.0) THEN  !VRH 7/27/89 old way - Get from OEF
            CALL MVE(7,14,RBUF(1,IRING),smaa,1,1)	!Get orbital elements
          ELSE
            CALL GETRING(IRING) !Use most current orbital elements
          ENDIF
!  where does T come from ?? <lwk>
          CALL MECALC(ME0,INCL,OMEGAZ,PHIp,PIZERO,
     &           dOMEGA_dt,dw_dt,T,T0,me)
          CALL FROMEME(ME,PSC,sclat,sclon)		! Compute SCLAT,SCLON
          CALL VECTOR3(RSC,SCLAT,SCLON-RLORA,psc3)	! Compute PSC3
          CALL FROMEME(ME,PSUN,sunlat,sunlon)		! Compute SUNLAT,SUNLON
          CALL VECTOR3(RSUN,SUNLAT,SUNLON-RLORA,psun3)	! Compute PSUN3
C             Calculate OM-matrix for ring
          CALL GETANGLES(CM,ME(1,3),PSC,angln,angla,anglb)
          CALL OMMATRIX(ANGLN,ANGLA,ANGLB-SCLON+RLORA,om) !Compute OM-matrix
          CALL PUTRING(IRING)		!Save orbital data
      ENDDO

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Get ring data from orbital elements file
C
      SUBROUTINE RINGIN(PLANET_ID,rings,nrings,oe,oef,oefname)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER*4 PLANET_ID,OEF
      CHARACTER*1 RINGS(15)
      REAL*8 OE(110,4)			!Orbital elements for J,S,U,N
      CHARACTER*256 OEFNAME

      COMMON/C2/DATE,PBUF(4),RBUF(7,15)
      CHARACTER*80 MSG

      CHARACTER*1 DRINGS(15)/'P','1','2','3','4','5','6','7','8','9',
     &			   'V','W','X','Y','Z'/ ! Default VRH 6/7/89
      CHARACTER*1 SRINGS(13)/'P','F','K','E','A','N','S','W','B','M',
     &			   'R','T','C'/
      CHARACTER*1 URINGS(11)/'P','6','5','4','A','B','N','G','D','L',
     &			   'E'/
      CHARACTER*1 RINGS8(11)/'P','A','B','C','5','3','4','2','1','T',
     &                     'N'/

      IF (PLANET_ID.LT.5) RETURN	!No rings for inner planets

      DO I=1,15
        RINGS(I) = DRINGS(I)		! Load Default rings VRH 6/7/89
      ENDDO
      IF (PLANET_ID.EQ.5) THEN
        NRINGS = 1
        RINGS(1) = SRINGS(1)		!Ring=P for Jupiter
      ELSE IF (PLANET_ID.EQ.6) THEN
	NRINGS = 13
	DO I=1,13
          RINGS(I) = SRINGS(I)		!Ring names for Saturn
	ENDDO
      ELSE IF (PLANET_ID.EQ.7) THEN
	NRINGS = 11
	DO I=1,13
          RINGS(I) = URINGS(I)		!Ring names for Uranus
	ENDDO
      ELSE
	NRINGS = 11
	DO I=1,11
          RINGS(I) = RINGS8(I)		!Ring names for Neptune
	ENDDO
      ENDIF
C     ....Open Ring Orbital Element File
      CALL XVPARM('OEF',oefname,icnt,idef,0)
      if (icnt.eq.0) then
        call xvmessage(' Missing OEF parameter....',' ')
        call xvmessage(' See help on OEF parameter.',' ')
        call xvmessage(' NAV task cancelled',' ')
	call abend
      endif
      CALL XVUNIT(oef,'OE',1,IND,'U_NAME',OEFNAME,' ')
      CALL XVSIGNAL(OEF,IND,.TRUE.)
      CALL XVOPEN(OEF,IND,'OPEN_ACT','SA','IO_ACT','SA',' ')
C     ....Read records for J,S,U, and N
      DO L=1,4
         CALL XVREAD(OEF,OE(1,L),ind,' ')
      ENDDO
      CALL XVCLOSE(OEF,ind,' ')
c VRH: 10/11/02 New Ringorbs format
      CALL MVE(8,110,OE(1,PLANET_ID-4),date,1,1)  ! fill C2 common block
      WRITE(MSG,100) NINT(OE(1,PLANET_ID-4))
100   FORMAT('Orbital Elements last update (YYYYDDD): ',I7)
      call xvmessage(msg,' ')
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Write orbital elements to Orbital Elements File.
C
      SUBROUTINE RINGOUT(OEF,OE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 OE(110,4)		!Orbital elements for rings of J,S,U,N
      INTEGER*4 OEF

      COMMON/CPIC/IPROJ,ICAM,FRAME_ID,PLANET_ID
      COMMON/CPIC/TARGET_ID,IDATE,ITIME
      INTEGER*4 IPROJ,ICAM,FRAME_ID,PLANET_ID,TARGET_ID

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/C2/DATE,PBUF(4),RBUF(7,15) !Reclen=8*110
      CHARACTER*16 CDATE

      CALL XVOPEN(OEF,IND,'OP','WRITE','U_NL',4,'U_NS',111,
     &	'U_FORMAT','DOUB','O_FORMAT','DOUB',
     &	'OPEN_ACT','S','IO_ACT','SA',' ')
      IF (IND.LT.1) RETURN
C     ....Build orbital elements for planet in PBUF,RBUF
      CALL DATFMT(1,cdate,i)		!Load current date
      DATE = i
      CALL MVE(8,4,ALPHAp,pbuf,1,1)	!Load planet orientation data
      DO J=1,15				!Load ring orbital elements VRH 6/7/89
         CALL GETRING(J)
         CALL MVE(7,14,SMAA,rbuf(1,j),1,1)
      ENDDO
c VRH: 10/11/02 New Ringorbs format
      CALL MVE(8,110,date,oe(1,planet_id-4),1,1)	!Move to OE buffer

      DO L=1,4
         CALL XVWRIT(OEF,OE(1,L),ind,' ')
      ENDDO
      CALL XVCLOSE(OEF,ind,' ')
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the right-ascension and declination of north pole, compute
C the planet's ME matrix.
C
      SUBROUTINE ME0CALC(ALPHAp,DELTAp,ME0)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 ME0(3,3)

      SINAp = DSIN(ALPHAp)
      COSAp = DCOS(ALPHAp)
      SINDp = DSIN(DELTAp)
      COSDp = DCOS(DELTAp)

      ME0(1,1) = -SINAp
      ME0(2,1) =  COSAp
      ME0(3,1) =  0.D0

      ME0(1,2) = -SINDp*COSAp
      ME0(2,2) = -SINDp*SINAp
      ME0(3,2) =  COSDp

      ME0(1,3) =  COSDp*COSAp
      ME0(2,3) =  COSDp*SINAp
      ME0(3,3) =  SINDp

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Calculate ME, given ME0, angles i, OMEGA, PHIp, and PIZERO,
C apsidal and nodal precession rates dOMEGA_dt and dw_dt,
C and times T and T0.
C Note: ERING data is in EME50 (calculated ME is transformed to ISYSTEM)
C
      SUBROUTINE MECALC(ME0,i,OMEGAZ,PHIp,PIZERO,dOMEGA_dt,
     &              dw_dt,T,T0,ME)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 ME0(3,3),ME(3,3),i
C
      COMMON/SEDR/SEDR(200),LBUF(100),ISYSTEM
      REAL*4 SEDR
      INTEGER LBUF,ISYSTEM  !1=j2000, 2=b1950
      integer b1950, toref
      doubleprecision mtx(3,3)
C
C         Get angles OMEGA and w
      OMEGA = OMEGAZ + dOMEGA_dT*(T-T0)
      wbar = PIZERO + dw_dt*(T-T0)
      w = wbar - OMEGA
C         The ME is initially matrix M1 (rotation from periapse to node
C         about z-axis).
      ME(1,1) =  DCOS(w)
      ME(2,1) =  DSIN(w)
      ME(3,1) =  0.D0

      ME(1,2) = -DSIN(w)
      ME(2,2) =  DCOS(w)
      ME(3,2) =  0.D0

      ME(1,3) =  0.D0
      ME(2,3) =  0.D0
      ME(3,3) =  1.D0
C         At this point, x-axis lies in intersection of planet's equatorial
C         plane and ring plane.  Rotate about x-axis thru inclination angle
C         i so that z-axis aligns with planet's pole (ME = M2*M1).
      DO 20 J=1,3
      TEMP    = DCOS(i)*ME(2,J) - DSIN(i)*ME(3,J)
      ME(3,J) = DSIN(i)*ME(2,J) + DCOS(i)*ME(3,J)
   20 ME(2,J) = TEMP
C         Rotate about z-axis thru angle OMEGA+PHIp so that x-axis coincides
C         with node of planet on EME1950 (ME = M3*M2*M1).
      DO 30 J=1,3
      TEMP    = DCOS(OMEGA+PHIp)*ME(1,J) - DSIN(OMEGA+PHIp)*ME(2,J)
      ME(2,J) = DSIN(OMEGA+PHIp)*ME(1,J) + DCOS(OMEGA+PHIp)*ME(2,J)
   30 ME(1,J) = TEMP
C         Now rotate into EME50 (ME = ME0*M3*M2*M1).
      DO 40 J=1,3
      TEMP1   = ME0(1,1)*ME(1,J)+ME0(1,2)*ME(2,J)+ME0(1,3)*ME(3,J)
      TEMP2   = ME0(2,1)*ME(1,J)+ME0(2,2)*ME(2,J)+ME0(2,3)*ME(3,J)
      ME(3,J) = ME0(3,1)*ME(1,J)+ME0(3,2)*ME(2,J)+ME0(3,3)*ME(3,J)
      ME(1,J) = TEMP1
   40 ME(2,J) = TEMP2
C
C VRH 10/11/02 - transform ME to J2000 if ISYSTEM=1
C
      IF (ISYSTEM.EQ.1) THEN
         call irfnum( 'B1950', b1950)      !get SPICE index of B1950 ref frame
         call irfnum( 'J2000', toref)
         call irfrot(b1950,toref,mtx)      !Get rotation matrix
         call mxm(me,mtx,me)               !Convert from b1950 to isystem
      ENDIF

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Edit orbital data for eccentric rings
C
      SUBROUTINE ERING
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CPIC/IPROJ,ICAM,FRAME_ID,PLANET_ID
      COMMON/CPIC/TARGET_ID,IDATE,ITIME
      COMMON/CPICX/T0,T
      INTEGER*4 IPROJ,ICAM,FRAME_ID,PLANET_ID,TARGET_ID

      COMMON/IPIC/IMG,SL,SS,NL,NS,ICODE !VRH 6/28/89 for RINGPT - show whole ring
      INTEGER*4 SL,SS

      COMMON/CRINGI/JSL,JSS,JNL,JNS,NRPTS,ETYPE
      COMMON/CRINGI/NRF,RINGID(10),EDGE(10),PLANE(10)
      COMMON/CRING/RPTS(2,20000),ARPTS(2,20000),RADII(10),RWIDTH(10)
      COMMON/CRINGC/ RINGS
      INTEGER*4 ETYPE,RINGID,EDGE,PLANE
      REAL*4 RPTS,ARPTS,RADII,RWIDTH
      CHARACTER*1 RINGS(15)

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/COE/OE(110,4),OEF,OEFNAME	!Orbital elements for J,S,U,N
      INTEGER*4 OEF
      CHARACTER*256 OEFNAME

      COMMON/C2/DATE,PBUF(4),RBUF(7,15)

      COMMON/CONST/PI,DTR,RTD

      REAL*8 ME0(3,3)
      CHARACTER*1 RING_ID(20)
      LOGICAL PARMTST,rPARMTST,XVIPTST
      real*4 mindis,maxdis,r

      IF (PLANET_ID.LT.6) THEN
        CALL XVMESSAGE('***No eccentric rings for Jupiter',' ')
        RETURN
      ENDIF
      IRING = -1	!Set to invalid ring-id

   20 CALL XVINTRACT('ERING','ERING')
      IF (XVIPTST('HELP')) CALL XVINTRACT('ERING',' ')
      IF (XVIPTST('EXIT')) RETURN
      ICHANGE = 0

      IF (PARMTST('RING',RING_ID(1),I)) THEN
          CALL UPRCASE(RING_ID)
          DO J=1,15 ! For new rings VRH 6/7/89
            IF (RING_ID(1).EQ.RINGS(J)) THEN
                IRING = J		!Set the ring-id
                CALL GETRING(IRING)	!Get orbital data
                IF (IRING.EQ.1) GOTO 20
                IF (SMAA.EQ.0.) GOTO 20      !Skip drawing zero ring VRH 6/8/89
		mindis = 5.0
		maxdis = 10.0
                CALL RINGPT(SMAA,ECC,OM,PSC3,PSUN3,SCLON,RLORA,RA,RC,
     &              OAL,OAS,ZSCALE,1,1,NL,NS,NLW,NSW,
     &              NSEARCH,0,mindis,maxdis,RPTS,NRPTS)
                IF (NRPTS.GT.0) CALL DRAWCURVE(RPTS,NRPTS,0)
                GOTO 20
            ENDIF
          ENDDO
          CALL XVMESSAGE('***Invalid ring name',' ')
          GOTO 20
      ENDIF

      IF (IRING.EQ.-1) THEN
          CALL XVMESSAGE('***Enter ring-ID before editing',' ')
          CALL XVMESSAGE('   by using RING command',' ')
          GOTO 20
      ENDIF

      IF (XVIPTST('RESTORE')) THEN
         L = PLANET_ID - 4
         CALL MVE(8,110,OE(1,L),date,1,1)
         IF (IRING.EQ.1) THEN !VRH 7/27/89 IRING=1 only changes ALPHAp to ZETAZ
             CALL MVE(8,4,PBUF,alphap,1,1)
         ELSE
             CALL MVE(7,14,RBUF(1,IRING),smaa,1,1)
         ENDIF
         ICHANGE = 1
      ENDIF

      IF (IRING.GT.1) THEN !VRH 7/27/89 IRING>1 only changes SMAA,...,dw_dt
        IF (rPARMTST('SMAA',R,I)) THEN
            IF (R.LT.1.D0) THEN ! VRH fix from SMAA to R 6/14/89
                CALL XVMESSAGE('***Invalid SMAA',' ')
                GOTO 20
            ENDIF
            SMAA = R
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('ECC',R,I)) THEN
            IF (R.LT.0.D0.OR.R.GT.0.99D0) THEN ! VRH fix from ECC to R 6/14/89
                 CALL XVMESSAGE('***Invalid eccentricity',' ')
                 GOTO 20
            ENDIF
            ECC = R
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('INCL',R,I)) THEN
            INCL = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('PIZERO',R,I)) THEN
            PIZERO = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('OMEGZ',R,I)) THEN
            OMEGAZ = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('DW',R,I)) THEN  !VRH 7/22/89 option add
            dw_dt = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('DOMEGZ',R,I)) THEN  !VRH 7/22/89 option add
            dOMEGA_dt = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('RA',R,I).OR.rPARMTST('DEC',R,I).OR.  !VRH 7/27/89
     &    rPARMTST('THETA',R,I).OR.rPARMTST('ZETAZ',R,I)) THEN
          CALL XVMESSAGE('***RA,DEC,THETA,ZETAZ: Valid for RING=P only',
     1     ' ')
        ENDIF
      ELSE
        IF (rPARMTST('RA',R,I)) THEN
            ALPHAp = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('DEC',R,I)) THEN
            DELTAp = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('THETA',R,I)) THEN
            THETA = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('ZETAZ',R,I)) THEN
            ZETAZ = R*DTR
            ICHANGE = 1
        ENDIF

        IF (rPARMTST('SMAA',R,I).OR.rPARMTST('ECC',R,I).OR.
     &      rPARMTST('INCL',R,I).OR.rPARMTST('PIZERO',R,I).OR.
     &      rPARMTST('OMEGZ',R,I).OR.rPARMTST('DW',R,I).OR.
     &      rPARMTST('DOMEGZ',R,I)) THEN
            CALL XVMESSAGE('*** SMAA,ECC,INCL,PIZERO,OMEGAZ,DW,DOMEGZ:',
     &       ' ')
            CALL XVMESSAGE('*** Not valid for RING=P',' ')
        ENDIF
      ENDIF

      IF (XVIPTST('STATUS')) CALL RSTATUS(IRING)

      IF (ICHANGE.EQ.1) THEN
          IF (IRING.NE.1) THEN  !VRH 7/27/89 Renavigate IRING
            IF (SMAA.EQ.0.) THEN     !Skip zero ring VRH 6/14/89
                CALL XVMESSAGE('***Ring SMAA not defined',' ')
                GOTO 20
            END IF
            CALL ME0CALC(ALPHAp,DELTAp,ME0)
C             Calculate ME-matrix for ring
            CALL MECALC(ME0,INCL,OMEGAZ,PHIp,PIZERO,
     &               dOMEGA_dt,dw_dt,T,T0,ME)
            CALL FROMEME(ME,PSC,SCLAT,SCLON)		! Compute SCLAT,SCLON
            CALL VECTOR3(RSC,SCLAT,SCLON-RLORA,PSC3)	! Compute PSC3
            CALL FROMEME(ME,PSUN,SUNLAT,SUNLON)	! Compute SUNLAT,SUNLON
            CALL VECTOR3(RSUN,SUNLAT,SUNLON-RLORA,PSUN3) ! Compute PSUN3
C             Calculate OM-matrix for ring
            CALL GETANGLES(CM,ME(1,3),PSC,ANGLN,ANGLA,ANGLB)
            CALL OMMATRIX(ANGLN,ANGLA,ANGLB-SCLON+RLORA,OM) !Compute OM-matrix
	    mindis = 5.0
	    maxdis = 10.0
            CALL RINGPT(SMAA,ECC,OM,PSC3,PSUN3,SCLON,RLORA,RA,RC,
     &            OAL,OAS,ZSCALE,1,1,NL,NS,NLW,NSW,NSEARCH,0,
     &            mindis,maxdis,RPTS,NRPTS)
            IF (NRPTS.GT.0) CALL DRAWCURVE(RPTS,NRPTS,1)
            CALL PUTRING(IRING)
          ELSE  !Renavigate all rings VRH 7/27/89
            CALL XVMESSAGE('Updating all rings',' ')
            CALL GETEPOCH(PLANET_ID,ALPHAp,DELTAp,THETA,ZETAZ,phip,t0)
            CALL ERING0(PLANET_ID,T,T0,1)
            CALL GETRING(1)  !Restore P-ring
          ENDIF
          GOTO 20
      ENDIF

      IF (XVIPTST('WRITE')) CALL RINGOUT(OEF,OE)
      GOTO 20
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to print summary of ring orbital data
C
      SUBROUTINE RSTATUS(IRING)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CPIC/IPROJ,ICAM,FRAME_ID,PLANET_ID
      COMMON/CPIC/TARGET_ID,IDATE,ITIME
      INTEGER*4 IPROJ,ICAM,FRAME_ID,PLANET_ID,TARGET_ID

      COMMON/CRINGI/JSL,JSS,JNL,JNS,NRPTS,ETYPE
      COMMON/CRINGI/NRF,RINGID(10),EDGE(10),PLANE(10)
      COMMON/CRINGC/ RINGS
      INTEGER*4 ETYPE,RINGID,EDGE,PLANE
      CHARACTER*1 RINGS(15)

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD
      CHARACTER*80 MSG
      CHARACTER PLANET*6,YEAR*4

  100 FORMAT('Orbital Data for ',A1,'-Ring')
  108 FORMAT('Semi-Major Axis (km)                SMAA  ',F10.0)
  109 FORMAT('Eccentricity                        ECC   ',F10.5)
  110 FORMAT('Inclination (deg)                   INCL  ',F10.5)
  111 FORMAT('Longitude of Periapse (deg)         PIZERO',F10.5)
  112 FORMAT('Longitude of Ascending Node (deg)   OMEGAZ',F10.5)
  113 FORMAT('Precession of Periapse (deg/day)    dw/dt ',F10.5)
  114 FORMAT('Precession of Node (deg/day)        dOM/dt',F10.5)
  115 FORMAT('R.A. of ',A6,' pole (deg)           RA    ',F10.5)
  116 FORMAT('DEC  of ',A6,' pole (deg)           DEC   ',F10.5)
  117 FORMAT('Earth pole ',A4,' (deg)               THETA ',F10.5)
  118 FORMAT('Earth pole ',A4,' (deg)               ZETAZ ',F10.5)

      WRITE(MSG,100) RINGS(IRING)
      CALL XVMESSAGE(MSG,' ')

      IF (IRING.GT.1) THEN
        WRITE(MSG,108) SMAA
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,109) ECC
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,110) INCL*RTD
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,111) PIZERO*RTD
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,112) OMEGAZ*RTD
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,113) dw_dt*RTD  !VRH 7/22/89 option add
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,114) dOMEGA_dt*RTD  !VRH 7/22/89 option add
        CALL XVMESSAGE(MSG,' ')
      ELSE
        IF (PLANET_ID.EQ.6) THEN
           PLANET = 'Saturn'
           YEAR = '1950'
        ELSE IF (PLANET_ID.EQ.7) THEN
           PLANET = 'Uranus'
           YEAR = '1950'
        ELSE
           PLANET = 'Neptune'
           YEAR = '1950'
        ENDIF

        WRITE(MSG,115) PLANET,ALPHAp*RTD
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,116) PLANET,DELTAp*RTD
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,117) YEAR,THETA*RTD
        CALL XVMESSAGE(MSG,' ')

        WRITE(MSG,118) YEAR,ZETAZ*RTD
        CALL XVMESSAGE(MSG,' ')
      ENDIF

      RETURN
      END