module rm
	contains
! =====================================================================
      SUBROUTINE RANMAR(RVEC,LENV,INI)
! =====================================================================
! Universal random number generator proposed by Marsaglia and Zaman
! in report FSU-SCRI-87-50
!        modified by F. James, 1988 and 1989, to generate a vector
!        of pseudorandom numbers RVEC of length LENV, and to put in
!        the COMMON block everything needed to specify currrent state,
!        and to add input and output entry points RMARIN, RMARUT.
!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!!!  Calling sequences for RANMAR:                                  ++
!!!      CALL RANMAR (RVEC, LEN)   returns a vector RVEC of LEN     ++
!!!                   32-bit random floating point numbers between  ++
!!!                   zero and one.                                 ++
!!!      CALL RMARIN(I1,N1,N2)   initializes the generator from one ++
!!!                   32-bit integer I1, and number counts N1,N2    ++
!!!                  (for initializing, set N1=N2=0, but to restart ++
!!!                    a previously generated sequence, use values  ++
!!!                    output by RMARUT)                            ++
!!!      CALL RMARUT(I1,N1,N2)   outputs the value of the original  ++
!!!                  seed and the two number counts, to be used     ++
!!!                  for restarting by initializing to I1 and       ++
!!!                  skipping N1*100000000+N2 numbers.              ++
!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DIMENSION RVEC(*)
      COMMON/RASET1/U(97),C,I97,J97
      PARAMETER (MODCNS=1000000000)
      SAVE CD, CM, TWOM24, NTOT, NTOT2, IJKL
      DATA NTOT,NTOT2,IJKL/-1,0,0/
      integer,dimension(8)::values
      integer,intent(in)::INI

      IF (NTOT .GE. 0)  GO TO 50

!        Default initialization. User has called RANMAR without RMARIN.
      call date_and_time(VALUES=values)
!http://gcc.gnu.org/onlinedocs/gcc-4.0.4/gfortran/DATE_005fAND_005fTIME.html
      !IJKL = values(8)
      IJKL = INI
      NTOT = 0
      NTOT2 = 0
      KALLED = 0
      GO TO 1

      ENTRY      RMARIN(IJKLIN, NTOTIN,NTOT2N)
!         Initializing routine for RANMAR, may be called before
!         generating pseudorandom numbers with RANMAR. The input
!         values should be in the ranges:  0<=IJKLIN<=900 OOO OOO
!                                          0<=NTOTIN<=999 999 999
!                                          0<=NTOT2N<<999 999 999!
! To get the standard values in Marsaglia's paper, IJKLIN=54217137
!                                            NTOTIN,NTOT2N=0
      IJKL = IJKLIN
      NTOT = MAX(NTOTIN,0)
      NTOT2= MAX(NTOT2N,0)
      KALLED = 1
!          always come here to initialize
    1 CONTINUE
      IJ = IJKL/30082
      KL = IJKL - 30082*IJ
      I = MOD(IJ/177, 177) + 2
      J = MOD(IJ, 177)     + 2
      K = MOD(KL/169, 178) + 1
      L = MOD(KL, 169)
      WRITE(6,'(A,I10,2X,2I10)') ' SEMILLA RANMAR:',IJKL,NTOT,NTOT2
!      PRINT '(A,4I10)', '   I,J,K,L= ',I,J,K,L
      DO 2 II= 1, 97
      S = 0.
      T = .5
      DO 3 JJ= 1, 24
         M = MOD(MOD(I*J,179)*K, 179)
         I = J
         J = K
         K = M
         L = MOD(53*L+1, 169)
         IF (MOD(L*M,64) .GE. 32)  S = S+T
    3    T = 0.5*T
    2 U(II) = S
      TWOM24 = 1.0
      DO 4 I24= 1, 24
    4 TWOM24 = 0.5*TWOM24
      C  =   362436.*TWOM24
      CD =  7654321.*TWOM24
      CM = 16777213.*TWOM24
      I97 = 97
      J97 = 33
!       Complete initialization by skipping
!            (NTOT2*MODCNS + NTOT) random numbers
      DO 45 LOOP2= 1, NTOT2+1
      NOW = MODCNS
      IF (LOOP2 .EQ. NTOT2+1)  NOW=NTOT
      IF (NOW .GT. 0)  THEN
        WRITE(6,'(A,I15)') ' RMARIN SKIPPING OVER ',NOW
       DO 40 IDUM = 1, NTOT
       UNI = U(I97)-U(J97)
       IF (UNI .LT. 0.)  UNI=UNI+1.
       U(I97) = UNI
       I97 = I97-1
       IF (I97 .EQ. 0)  I97=97
       J97 = J97-1
       IF (J97 .EQ. 0)  J97=97
       C = C - CD
       IF (C .LT. 0.)  C=C+CM
   40  CONTINUE
      ENDIF
   45 CONTINUE
      IF (KALLED .EQ. 1)  RETURN
!
!          Normal entry to generate LENV random numbers
   50 CONTINUE
      DO 100 IVEC= 1, LENV
      UNI = U(I97)-U(J97)
      IF (UNI .LT. 0.)  UNI=UNI+1.
      U(I97) = UNI
      I97 = I97-1
      IF (I97 .EQ. 0)  I97=97
      J97 = J97-1
      IF (J97 .EQ. 0)  J97=97
      C = C - CD
      IF (C .LT. 0.)  C=C+CM
      UNI = UNI-C
      IF (UNI .LT. 0.) UNI=UNI+1.
      RVEC(IVEC) = UNI
!             Replace exact zeros by uniform distr. *2**-24
         IF (UNI .EQ. 0.)  THEN
         ZUNI = TWOM24*U(2)
!             An exact zero here is very unlikely, but let's be safe.
         IF (ZUNI .EQ. 0.) ZUNI= TWOM24*TWOM24
         RVEC(IVEC) = ZUNI
         ENDIF
  100 CONTINUE
      NTOT = NTOT + LENV
         IF (NTOT .GE. MODCNS)  THEN
         NTOT2 = NTOT2 + 1
         NTOT = NTOT - MODCNS
         ENDIF
      RETURN
!           Entry to output current status
      ENTRY RMARUT(IJKLUT,NTOTUT,NTOT2T)
      IJKLUT = IJKL
      NTOTUT = NTOT
      NTOT2T = NTOT2
      RETURN
      END  subroutine

end module rm


!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!*                                                                     *
!* Copyright (c) 2019-2021, De Graef Group, Carnegie Mellon University *
!* All rights reserved.                                                *
!*                                                                     *
!* Author: William C. Lenthe                                           *
!*                                                                     *
!* EMSphInx is available for academic or non-profit non-commercial     *
!* research use. Please, see the license.txt file in this distribution *
!* for further details.                                                *
!*                                                                     *
!* Interested in a commercial license? Contact:                        *
!*                                                                     *
!* Center for Technology Transfer and Enterprise Creation              *
!* 4615 Forbes Avenue, Suite 302                                       *
!* Pittsburgh, PA 15213                                                *
!*                                                                     *
!* phone. : 412.268.7393                                               *
!* email  : innovation@cmu.edu                                         *
!* website: https://www.cmu.edu/cttec/                                 *
!*                                                                     *
!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

!--------------------------------------------------------------------------
! EMsoft:DSHT.f90
!--------------------------------------------------------------------------
!
! MODULE: DSHT
!
!> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
!
!> @brief Discrete Spherical Harmonic Transform (DSHT) routines
!
!> @details This implements Will Lenthe's square_sphere.hpp routines for the computation of
!> the spherical harmonic Fourier Transform, which are subsequently used in the EMSphInx algorithm.
!> @reference: Reinecke , M. (2011). Libpsht–algorithms for efficient spherical harmonic transforms.
!>               Astronomy & Astrophysics, 526, A108.
!> @reference: Schaeffer, N. (2013). Efficient spherical harmonic transforms aimed at pseudospectral
!>               numerical simulations. Geochemistry, Geophysics, Geosystems, 14(3), 751-758.
!> @note: grid requirements:
!>          -pixels are arranged on N_\phi \approx \sqrt{N_{pix}} iso-latitude rings w/ colatitude of
!>           ring y = \theta_y
!>          -within a ring pixels are equidistance in azimuthal angle and have identical weight (solid
!>           angle) w_y
!>          -the number of pixels in a given ring N_{\phi,y} can vary
!>          -the first pixel in a ring is at azimuthal angle \phi_{0,y}
!>        the square lambert grid satisfies these requirements:
!>          -\sqrt{ 2.5 * N_{pix} } rings for side length 3, rapidly approaching \sqrt{2 * N_{pix} }
!>           rings (within 1% at side length 9)
!>          -all grid points cover the same solid angle -> w_y = 1 / rings
!>          -\phi_{0,y} = 0 for odd side lengths (must be calculated for even side lengths)
!>          -for the reverse transformation (synthesis) all N_{\phi,y} are even
!> @note: optimizations implemented (see Schaeffer for details):
!>          -use of real values FFT -> factor of 2 savings on FFT
!>          -mirror (conjugate) symmetry of spherical harmonics -> factor of 2 on direct summations
!>           [only possible for ring positions that are symmetric across the equator]
!>          -polar optimization (implicitly via equal area grid)
!> @note: I've opted for on the fly (vs precomputed calculations) since the single thread performance
!>        was very similar and on the fly has much lower memory overhead
!> @note: single thread performance is comparable to SHTns compiled without SIMD enabled for the same
!>        number of rings, but non legendre root rings -> half the bandwidth
!> @note: complexity is ~n^2.7 for reasonable bandwidths (should probably be something like log(n)*n^2)
!
!> @date 01/16/19 MDG 1.0 original, based on Will Lenthe's C++ routines
!> @date 07/29/19 WCL 2.0 switch from dim to half dim
!--------------------------------------------------------------------------
module DSHT

use local
use Lambert
use fft_wrap
use, intrinsic :: iso_c_binding

implicit none

  private ! default everything to private

  ! types
  public :: DiscreteSHT          ! actual interface for computing SHT
  public :: DiscreteSHTConstants ! read only constants for DiscreteSHT (+ associated helper functions)

  ! functions

  !@brief                   : compute grid ring latitudes
  !@param d [IN] integer    : half grid size - square grid is (-d:d,-d:d)
  !@param t [IN] character(): grid type ('legendre' or 'lambert')
  !@return       real(0:d)  : cosine(latitudes of grid rings) [north hemisphere only]
  public :: SH_cosLats

  !@brief                         : compute grid direction cosines
  !@param d [IN] integer          : half grid size - square grid is (-d:d,-d:d)
  !@param t [IN] character()      : grid type ('legendre' or 'lambert')
  !@return       real(3,-d:d,-d:d): (x,y,z) direction cosines for each grid point [north hemisphere only]
  public :: SH_dirCos

  !@brief                             : interpolate a square lambert image on a sqaure legendre grid
  !@param di [IN] intger              : input  image size
  !@param ni [IN] real(-di:do, -di:do): input  square lambert image (north hemisphere)
  !@param si [IN] real(-di:do, -di:do): input  square lambert image (south hemisphere)
  !@param do [IN] intger              : output image size
  !@param no [IN] real(-di:do, -di:do): output square lambert image (north hemisphere)
  !@param so [IN] real(-di:do, -di:do): output square lambert image (south hemisphere)
  public :: LegendreInterp

  ! primarily for debugging
  public :: SH_printRow, SH_printRing

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!                                                                    !!
  !!  these are the thread safe components required for a discrete SHT  !!
  !!                                                                    !!
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  type DiscreteSHTConstants
    integer(kind=irg)             :: d           ! half length of square Lambert projection - grid is (-d:d,-d:d),
                                                 ! e.g. dim is 2*d+1, Nt == d+1
    integer(kind=irg)             :: maxL        ! maximum bandwidth of square lambert projection (must be < Nt
                                                 ! for arbitrary rings (Nt*2 for legendre rings))
    integer(kind=irg)             :: Nw          ! number of different types of weights [(dim-2) / 8 + 1]
    real   (kind=dbl),allocatable :: r1x2(:)     ! precomputed sqrt(1-x*x) values
    real   (kind=dbl),allocatable :: wy(:,:)     ! weighting factor for each ring [Nt * Nw]
    real   (kind=dbl),allocatable :: cosTy(:)    ! cosine of latitude of each ring [Nt]
    real   (kind=dbl),allocatable :: amn(:,:)    ! precomputed a^m_n values for on the fly ylm calculation [maxL^2]
    real   (kind=dbl),allocatable :: bmn(:,:)    ! precomputed b^m_n values for on the fly ylm calculation [maxL^2]
    type   (RealFFT ),allocatable :: fftPlans(:) ! array of plans for 1D real <--> complex ffts
  contains
    !@brief                        : initialize a discrete SHT constants type
    !@param d      [IN] integer    : half grid size - square grid is (-d:d,-d:d)
    !@param l      [IN] integer    : maximum bandwidth
    !@param layout [IN] character(): grid type ('legendre' or 'lambert')
    procedure         :: init    => DiscreteSHTConstants_Init

    !@brief: clean up a discrete SHT constants type
    procedure         :: destroy => DiscreteSHTConstants_Destroy

    !@brief: clean up resources automatically
    final             ::            DiscreteSHTConstants_Finalize ! just calls destroy w/ polymorphism
  end type DiscreteSHTConstants

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!                                                                    !!
  !!           this is the main type to do discrete SHT with            !!
  !!                                                                    !!
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  type DiscreteSHT
    ! these are the non-thread safe components required for a discrete SHT
    complex(C_DOUBLE_COMPLEX    ),pointer     :: cWrk1(:), cWrk2(:) ! complex working arrays for a single ring
    real   (C_DOUBLE            ),pointer     :: rWrk1(:), rWrk2(:) ! real working array for a single ring
    type   (FFTBuffer           )             :: pc1, pc2, pr1, pr2 ! fft allocated arrays for pointers

    ! these are the thread safe (read only) components required for a discrete SHT
    type  (DiscreteSHTConstants),allocatable  :: shtLut

  contains
    !@brief                        : initialize a discrete SHT calculator
    !@param d      [IN] integer    : half grid size - square grid is (-d:d,-d:d)
    !@param l      [IN] integer    : maximum bandwidth
    !@param layout [IN] character(): grid type ('legendre' or 'lambert')
    procedure :: init       => DiscreteSHT_Init

    !@brief: clean up a discrete SHT calculator
    procedure :: destroy    => DiscreteSHT_Destroy

    !@brief: automatically clean up on destruction
    final     ::               DiscreteSHT_Finalize

    !@brief                                      : compute harmonic coefficients from a spherical function
    !@param mLPNH [IN   ] real (-d:d   , -d:d   ): square grid of function values for north hemisphere
    !@param mLPSH [IN   ] real (-d:d   , -d:d   ): square grid of function values for south hemisphere
    !@param alm   [INOUT] cmplx( 0:bw-1,  0:bw-1): location to write harmonic coefficients
    procedure :: analyze    => SH_analyze

    !@brief                                      : compute harmonic coefficients from a spherical function
    !@param alm   [IN   ] cmplx( 0:bw-1,  0:bw-1): harmonic coefficients to synthesize
    !@param mLPNH [INOUT] real (-d:d   , -d:d   ): square grid to write function values for north hemisphere
    !@param mLPSH [INOUT] real (-d:d   , -d:d   ): square grid to write function values for south hemisphere
    !@param limL  [IN   ] real (-d:d   , -d:d   ): maximum bandwidth to use (exclusive) [must be < maxL, 0 to use all bandwidths]
    procedure :: synthesize => SH_synthesize

  end type DiscreteSHT

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                    !!
!!                                                                    !!
!!                                                                    !!
!!                          Helper Functions                          !!
!!                                                                    !!
!!                                                                    !!
!!                                                                    !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !--------------------------------------------------------------------------
  !
  ! FUNCTION: SH_cosLats
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief return the cosines of the Lambert or Legendre latitudes
  !
  !> @param d half grid size - square grid is (-d:d,-d:d)
  !> @param t grid type ('legendre' or 'lambert')
  !> returns lat
  !
  !> @date 01/21/19 MDG 1.0 original, based on Will Lenthe's classes in square_sphere.hpp
  !> @date 07/30/19 WCL 2.0 modified to take half grid size instead of full grid size
  !--------------------------------------------------------------------------
  recursive function SH_cosLats(d, t) result(lat)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_cosLats
    use error

  implicit none

    integer  (kind=irg),INTENT(IN)  :: d
    character(fnlen   ),INTENT(IN)  :: t
    real     (kind=dbl)             :: lat(0:d)

    integer  (kind=irg)             :: i, count, denom, numer, delta, info
    logical                         :: even
    real     (kind=dbl),allocatable :: upd(:), diagonal(:)

    if (trim(t).eq.'lambert') then ! Lambert latitudinal grid
    ! note: the c++ version of the code uses the side length dim == d * 2 + 1
    ! set some constants
      count = d+1
      even = .TRUE.
      if (mod(d,2).ne.0) even = .FALSE.

      denom = 4 * d * d
      numer = denom
      delta = 4
      if (even.eqv..TRUE.) then
        numer = numer - 1
        delta = 8
      end if

      do i = 0, count-1
        lat(i) = dble(numer)/dble(denom)
        numer = numer - delta
        delta = delta + 8
      end do
    else if (trim(t).eq.'legendre') then ! Legendre latitudinal grid (we'll use a Lapack routine to get the latitudes)
      ! this block compute the roots of the Legendre polynomial for N == d * 2 - 1
      count = d * 2 - 1 ! skip north + south pole (and don't double count equator)
      allocate(diagonal(count),upd(count))
      diagonal = 0.D0
      upd = (/ (dble(i) / dsqrt(4.D0 * dble(i)**2 - 1.D0), i=1,count) /)
      call dsterf(count, diagonal, upd, info)
      lat(0) = 1 ! add north pole back in
      lat(1:) = -diagonal(1:d) ! fill in after north pole
      lat(d) = 0.D0     ! force the last one to zero
      deallocate(diagonal, upd)
    else
      call FatalError('SH_cosLats','type must be "lambert" or "legendre" (got "' // trim(t) // '")')
    end if

  end function SH_cosLats

  !--------------------------------------------------------------------------
  !
  ! FUNCTION: SH_dirCos
  !
  !> @author Will Lenthe, Carnegie Mellon University
  !
  !> @brief compute grid direction cosines
  !
  !> @param d half grid size - square grid is (-d:d,-d:d)
  !> @param t grid type ('legendre' or 'lambert')
  !> returns (x,y,z) direction cosines for each grid point [north hemisphere only]
  !
  !> @date 07/30/19 WCL 1.0 original
  !--------------------------------------------------------------------------
  recursive function SH_dirCos(d, t) result(dc)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_dirCos
    use constants

  implicit none

    integer  (kind=irg),INTENT(IN) :: d
    character(fnlen   ),INTENT(IN) :: t
    real     (kind=dbl)            :: dc(3,-d:d,-d:d)

    real     (kind=dbl)            :: n(3), cosLats(0:d)

    integer                        :: i, j, ai, aj, ar
    real     (kind=dbl)            :: sX, sY, qq, x, y, h

    ! start by getting the ring lattitudes
    cosLats = SH_cosLats(d,t)

    ! finally loop over output grid computing direction cosines
    do j = -d, d ! loop over first dimension of square grid
      aj = abs(j) ! get absolute radius
      y = real(j)/real(d)! get y position in [-1,1]
      do i = -d, d ! loop over second dimension of square grid
        ai = abs(i) ! get absolute radius
        x = real(i)/real(d) ! get x position in [-1,1]
        ar = maxval((/ ai, aj /) ) ! determine distance to center (ring number)

        if (ar.eq.0) then ! this is the north pole, don't divide by 0
          n = (/ 0.D0, 0.D0, 1.D0 /)
        else ! this is a normal point
          ! compute fractional progress to current ring
          sX = real(i) / ar
          sY = real(j) / ar

          ! do square lambert longitude calculation
          qq = cPi * sX * sY * 0.25D0
          if (ai.le.aj) then
            x = sY * sin(qq)
            y = sY * cos(qq)
          else
            x = sX * cos(qq)
            y = sX * sin(qq)
          end if
          h = sqrt(x*x+y*y)

          ! assemble unit direction
          n(3) = cosLats(ar) ! get z coordinate from cosine(ring latitude)
          qq = sqrt(1.D0-n(3)*n(3)) / h ! determine how much magnitude is left for x and y
          n(1) = qq * x ! x direction cosine
          n(2) = qq * y ! y direction cosine
        end if
        dc(:,i,j) = n ! save result
      end do  ! i
    end do ! j

  end function SH_dirCos

  !--------------------------------------------------------------------------
  !
  ! FUNCTION: LegendreInterp
  !
  !> @author Will Lenthe, Carnegie Mellon University
  !
  !> @brief interpolate a square lambert image on a sqaure legendre grid
  !
  !> @param di input  image size
  !> @param ni input  square lambert image (north hemisphere)
  !> @param si input  square lambert image (south hemisphere)
  !> @param do output image size
  !> @param no output square lambert image (north hemisphere)
  !> @param so output square lambert image (south hemisphere)
  !
  !> @date 07/30/19 WCL 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine LegendreInterp(di, ni, si, do, no, so)
  !DEC$ ATTRIBUTES DLLEXPORT :: LegendreInterp
    use imageOPs
    use Lambert
  implicit none
    integer  (kind=irg),INTENT(IN   ) :: di
    real     (kind=dbl),INTENT(IN   ) :: ni(-di:di,-di:di)
    real     (kind=dbl),INTENT(IN   ) :: si(-di:di,-di:di)
    integer  (kind=irg),INTENT(IN   ) :: do
    real     (kind=dbl),INTENT(INOUT) :: no(-do:do,-do:do)
    real     (kind=dbl),INTENT(INOUT) :: so(-do:do,-do:do)

    real     (kind=dbl)               :: ns(-do:do,-do:do), ss(-do:do,-do:do) ! scaled hemispheres
    real     (kind=dbl)               :: dc(3,-do:do,-do:do) ! square legendre direction cosines
    real     (kind=dbl)               :: n(3), xy(2)
    integer                           :: i, j, ierr, ix, iy, ix2, iy2
    real     (kind=dbl)               :: x, y, fx, fy, cx, cy, vn, vs
    character(fnlen   )               :: t = 'legendre'

    ! start by rescaling input image to have ~the same pixel size at the output image if needed
    if(di.eq.do) then
      ns = ni ! copy input north hemisphere to scaled north hemisphere
      ss = si ! copy input south hemisphere to scaled south hemisphere
    else
      call RescaleImage(ni, ns, .TRUE.) ! rescale input north hemisphere to output size (and make mean value 0)
      call RescaleImage(si, ss, .TRUE.) ! rescale input north hemisphere to output size (and make mean value 0)
    endif

    ! next get direction associated with each legendre grid point (output grid)
    dc = SH_dirCos(do, t)

    ! finally loop over output grid bilinearly interpolating
    do j = -do, do ! loop over first dimension of square grid
      do i = -do, do ! loop over second dimension of square grid
        n(:) = dc(:,i,j)

        ! now that we have the direction of our legendre grid get corresponding position position on lambert grid
        xy = LambertSphereToSquare(n, ierr) * do ! adjust from [-1,1] to [-do, do]
        x = xy(1)
        y = xy(2)

        ! get bounding indices
        ix = int(x) ! truncate to int
        iy = int(y) ! truncate to int
        if(x.ge.0.D0) then
          ix2 = min(ix+1,  do)
        else
          ix2 = max(ix-1, -do)
        endif
        if(y.ge.0.D0) then
          iy2 = min(iy+1,  do)
        else
          iy2 = max(iy-1, -do)
        endif

        ! bilinearly interpolate from the square lambert grid
        fx = abs(x - ix) ! fractional progress between pixels in x direction
        fy = abs(y - iy) ! fractional progress between pixels in y direction
        cx = 1.D0 - fx   ! complement of fx
        cy = 1.D0 - fy   ! complement of fy
        vn = cx * cy * ns(ix ,iy ) &
           + fx * cy * ns(ix2,iy ) &
           + cx * fy * ns(ix ,iy2) &
           + fx * fy * ns(ix2,iy2)
        vs = cx * cy * ss(ix ,iy ) &
           + fx * cy * ss(ix2,iy ) &
           + cx * fy * ss(ix ,iy2) &
           + fx * fy * ss(ix2,iy2)
        no(i,j) = vn
        so(i,j) = vs
      end do  ! i
    end do ! j
  end subroutine LegendreInterp

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_printRow
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief Print square lambert projection in row major order to a file 'SHTC-printrow.txt'
  !
  !> @param d
  !> @param dunit
  !> @param sqr
  !> @param fname
  !
  !> @date 01/16/19 MDG 1.0 original, based on Will Lenthe's classes in square_sphere.hpp
  !--------------------------------------------------------------------------
  recursive subroutine SH_printRow(d, dunit, sqr, fname)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_printRow

  implicit none

    integer  (kind=irg),INTENT(IN) :: d
    integer  (kind=irg),INTENT(IN) :: dunit
    real     (kind=dbl),INTENT(IN) :: sqr(-d:d,-d:d)
    character(fnlen   ),INTENT(IN) :: fname

    integer  (kind=irg)            :: i, j

    open(unit=dunit,file=trim(fname),status='unknown',form='formatted')

    do j=-d,d
      do i=-d,d
        write (dunit,"(F12.6)") sqr(j,i)
      end do
    end do

    close(unit=dunit,status='keep')

  end subroutine SH_printRow

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_printRing
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief Print square lambert projection in row major order to a file 'SHTC-printrow.txt'
  !
  !> @note  This routine has not been tested yet...
  !
  !> @param dim
  !> @param dunit
  !> @param rng
  !> @param fname
  !
  !> @date 01/16/19 MDG 1.0 original, based on Will Lenthe's classes in square_sphere.hpp
  !--------------------------------------------------------------------------
  recursive subroutine SH_printRing(dim, dunit, rng, fname)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_printRing

  implicit none

    integer  (kind=irg),INTENT(IN) :: dim
    integer  (kind=irg),INTENT(IN) :: dunit
    real     (kind=dbl),INTENT(IN) :: rng(:)
    character(fnlen   ),INTENT(IN) :: fname

    integer  (kind=irg)            :: i, j, idx, numRings, cutoff, r, count
    logical                        :: even, sh

    idx = 0
    even = .FALSE.
    if (mod(dim,2).eq.0) even = .TRUE.
    numRings = dim
    if (even.eqv..TRUE.) numRings = numRings - 1
    cutoff = (dim - 1)/2

    open(unit=dunit,file=trim(fname),status='unknown',form='formatted')

    do i=0,numRings-1
      sh = .FALSE.
      if (i.gt.cutoff) sh = .TRUE.
      r = i
      if (sh.eqv..TRUE.) r = 2*cutoff-r
      count = 8 * r
      if (even.eqv..TRUE.) then
        count = count + 4
      else
        if (r.eq.0) count = count + 1
      end if
      do j=0,count-1
        write (dunit,"(F12.6)") rng(idx)
        idx = idx + 1
      end do
    end do

    close(unit=dunit,status='keep')

  end subroutine SH_printRing

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_readRing
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief get a single ring from a square lambert projection
  !
  !> @param d
  !> @param MP
  !> @param ringID
  !> @param buffer
  !
  !> @date 01/16/19 MDG 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine SH_readRing(d, MP, ringID, buffer)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_readRing

  use error

  implicit none

    integer(kind=irg),INTENT(IN   ) :: d
    real   (kind=dbl),INTENT(IN   ) :: MP(-d:d,-d:d)
    integer(kind=irg),INTENT(IN   ) :: ringID
    real   (kind=dbl),INTENT(INOUT) :: buffer(0:8*ringID-1)

    integer(kind=irg)               :: i, j, icol, jrow, idx

    if (ringID.gt.d) call FatalError('SH_readRing','requested ring number does not exist')

    ! set the starting location
    idx = 0
    icol = ringID
    jrow = 0
    buffer(idx) = MP(icol, jrow)

    if (ringID.gt.1) then  ! this is a regular ring
    ! we spiral counter-clockwise through the array and make a 90° turn at the diagonals
    ! go up to the upper right diagonal
      do jrow=1,ringID
        idx = idx + 1
        buffer(idx) = MP(icol, jrow)
      end do
    ! move to the upper left diagonal
      jrow = ringID
      do icol = ringID-1,-ringID,-1
        idx = idx + 1
        buffer(idx) = MP(icol, jrow)
      end do
    ! move to the lower left diagonal
      icol = -ringID
      do jrow=ringID-1,-ringID,-1
        idx = idx + 1
        buffer(idx) = MP(icol, jrow)
      end do
    ! move to the lower right diagonal
      jrow = -ringID
      do icol = -ringID+1,ringID
        idx = idx + 1
        buffer(idx) = MP(icol, jrow)
      end do
    ! and close the ring
      icol = ringID
      do jrow=-ringID+1,-1
        idx = idx + 1
        buffer(idx) = MP(icol, jrow)
      end do
    else  ! this is the innermost ring with 8 slots
      buffer(1) = MP( 1, 1)
      buffer(2) = MP( 0, 1)
      buffer(3) = MP(-1, 1)
      buffer(4) = MP(-1, 0)
      buffer(5) = MP(-1,-1)
      buffer(6) = MP( 0,-1)
      buffer(7) = MP( 1,-1)
    end if

  end subroutine SH_readRing

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_writeRing
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief write a single ring to a square lambert projection
  !
  !> @param d
  !> @param MP
  !> @param ringID
  !> @param buffer
  !
  !> @date 01/16/19 MDG 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine SH_writeRing(d, MP, ringID, buffer)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_writeRing

    use error

  implicit none

    integer(kind=irg),INTENT(IN   ) :: d
    real   (kind=dbl),INTENT(INOUT) :: MP(-d:d,-d:d)
    integer(kind=irg),INTENT(IN   ) :: ringID
    real   (kind=dbl),INTENT(IN   ) :: buffer(0:8*ringID-1)

    integer(kind=irg)               :: i, j, icol, jrow, idx

    if (ringID.gt.d) call FatalError('SH_writeRing','requested ring number does not exist')

    ! set the starting location
    idx = 0
    icol = ringID
    jrow = 0
    MP(icol, jrow) = buffer(idx)

    if (ringID.gt.1) then  ! this is a regular ring
    ! we spiral counter-clockwise through the array and make a 90° turn at the diagonals
    ! go up to the upper right diagonal
      do jrow=1,ringID
        idx = idx + 1
        MP(icol, jrow) = buffer(idx)
      end do
    ! move to the upper left diagonal
      jrow = ringID
      do icol = ringID-1,-ringID,-1
        idx = idx + 1
        MP(icol, jrow) = buffer(idx)
      end do
    ! move to the lower left diagonal
      icol = -ringID
      do jrow=ringID-1,-ringID,-1
        idx = idx + 1
        MP(icol, jrow) = buffer(idx)
      end do
    ! move to the lower right diagonal
      jrow = -ringID
      do icol = -ringID+1,ringID
        idx = idx + 1
        MP(icol, jrow) = buffer(idx)
      end do
    ! and close the ring
      icol = ringID
      do jrow=-ringID+1,-1
        idx = idx + 1
        MP(icol, jrow) = buffer(idx)
      end do
    else  ! this is the innermost ring with 8 slots
      MP( 1, 1) = buffer(1)
      MP( 0, 1) = buffer(2)
      MP(-1, 1) = buffer(3)
      MP(-1, 0) = buffer(4)
      MP(-1,-1) = buffer(5)
      MP( 0,-1) = buffer(6)
      MP( 1,-1) = buffer(7)
    end if

  end subroutine SH_writeRing

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_computeWeightsSkip
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief compute quadrature weights for rings (w_y in equation 10 of Reinecke)
  !
  !> @note  This will only work correctly for the Legendre case
  !
  !> @details For details, see https://doi.org/10.1111/j.1365-246X.1994.tb03995.x
  !
  !> @param SHTC
  !> @param skp ring to exclude from weights (e.g. skip = 0 will exclude the poles)
  !> @param ind index of weights to fill in SHTC%wy
  !
  !> @date 01/16/19 MDG 1.0 original
  !> @date 07/29/19 WCL 2.0 switch from dim to half dim
  !--------------------------------------------------------------------------
  recursive subroutine SH_computeWeightsSkip(SHTC, skp, ind)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_computeWeightsSkip

    use constants
    use io
    use error

  implicit none

    type   (DiscreteSHTConstants),INTENT(INOUT) :: SHTC
    integer(kind=irg            ),INTENT(IN   ) :: skp
    integer(kind=irg            ),INTENT(IN   ) :: ind

    integer(kind=irg            )               :: dim, nMat, gridPoints, INFO, i, j, io_int(1)
    integer(kind=irg            ),allocatable   :: IPIV(:)
    real   (kind=dbl            )               :: wn, w0, delta
    real   (kind=dbl            ),allocatable   :: a(:,:), x(:), b(:)

    dim  = SHTC%d * 2 + 1
    nMat = SHTC%d ! == # ring pairs -1

    ! build matrix of the form a_ij = cos(2*i*latitude[j]) for Sneeuw equation (21)
    ! We'll compute them using Chebyshev recursion: cos(ni) = T_n(cos(i)) with: T_0(x) = 1,
    !  T_1(x) = x, T_{n}(x) = 2x T_{n-1}(x) - T_{n-2}(x)
    allocate(a(0:nMat-1,0:nMat-1), x(0:nMat-1), b(0:nMat-1))

    a(0,:) = 1.D0
    ! fill the second row with cos(2theta_j) values using the double angle formula for cos(2x)
    if (skp.eq.0) then
      do i=1,nMat
        x(i-1) = SHTC%cosTy(i)*SHTC%cosTy(i)*2.D0-1.D0
      end do
    else
      do i=0,skp-1
        x(i) = SHTC%cosTy(i)*SHTC%cosTy(i)*2.D0-1.D0
      end do
      do i=skp,nMat-1
        x(i) = SHTC%cosTy(i+1)*SHTC%cosTy(i+1)*2.D0-1.D0
      end do
    end if
    a(1,:) = x(:)

    ! loop over remaining rows using Chebyshev recursion to fill in cos(2*n*i)
    do j=2,nMat-1
      a(j,:) = x(:) * a(j-1,:) * 2.D0 - a(j-2,:)
    end do
    deallocate(x)

    ! build the column vector for the right hand side of the equation
    b = (/ (-1.D0/(4.D0*dble(i)*dble(i)-1.D0),i=0,nMat-1 ) /)

    ! solve the equation     a * wgt = b   (we'll use a Lapack routine to do so)
    allocate(IPIV(nMat))
    call dgesv(nMat, 1, a, nMat, IPIV, b, nMat, INFO)
    if (INFO.ne.0) then
      if (INFO.gt.0) then
        io_int(1) = INFO
        call WriteValue(' The following matrix argument had an illegal value',io_int,1)
      else
        io_int(1) = -INFO
        call WriteValue(' The following U matrix element is zero :',io_int,1,'(I2,$')
        call Message('; Matrix factorization completed, but solution could not be computed.')
      end if
      call FatalError('SH_computeWeightsSkip','Error returned from LAPACK dgesv routine ... ')
    end if
    deallocate(IPIV)

    ! make sure we didn't run into precision issues
    delta = sum(b) - 1.D0     ! should be zero
    if (delta.gt.(epsilon(1.D0)**(1.D0/3.D0))/64.D0) then
        write (*,*) 'delta = ',delta
        call FatalError('SH_computeWeightsSkip','insufficient precision to accurately compute ring weights')
    end if

    ! compute the solid angle of a grid point
    gridPoints = dim*dim*2 -(dim-1)*4     ! total number of points on sphere (equator has double cover)
    wn = cPi * 4.D0 / dble(gridPoints)    ! solid angle of single point (solid angle of sphere / # grid points)
    w0 = wn * dble( dim * (dim-2) +2 )    ! initial scaling factor (doesn't account for different # pts in each ring)

    ! copy to output correcting alignment for missing ring
    SHTC%wy(0    :skp , ind) = b(0:skp)
    SHTC%wy(      skp , ind) = 0.D0
    SHTC%wy(skp+1:nMat, ind) = b(skp:nMat-1)

    ! rescale weights by solid angle and ratio of points to equatorial points and use
    ! symmetry to fill southern hemisphere weights (the master pattern always has an
    ! odd number of points along the side so we simplify the original C++ code, using offset = 0)
    SHTC%wy(0,ind) = SHTC%wy(0,ind) * w0 ! need to divide by for for even
    do i=1, nMat
      SHTC%wy(i,ind) = SHTC%wy(i,ind) * w0 / dble(8 * i) ! (8*i+4) for even
    enddo

  end subroutine SH_computeWeightsSkip

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                    !!
!!                                                                    !!
!!                                                                    !!
!!                    DiscreteSHTConstants Members                    !!
!!                                                                    !!
!!                                                                    !!
!!                                                                    !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: DiscreteSHTConstants_Init
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief Initialize a number of constants
  !
  !> @param this structure to keep all relevant pre-computed variables
  !> @param d edge length of the Lambert grid (odd number, full length)
  !> @param l bandwidth
  !> @param layout  Lambert or Legendre colatitudinal angles ?
  !
  !> @date 01/16/19 MDG 1.0 original, based on Will Lenthe's classes in square_sphere.hpp
  !> @date 07/29/19 WCL 2.0 switch from dim to half dim
  !--------------------------------------------------------------------------
  recursive subroutine DiscreteSHTConstants_Init(this, d, l, layout)
  !DEC$ ATTRIBUTES DLLEXPORT :: DiscreteSHTConstants_Init

    use error
    use constants
    use io

  implicit none

    class    (DiscreteSHTConstants),INTENT(INOUT) :: this
    integer  (kind=irg            ),INTENT(IN   ) :: d
    integer  (kind=irg            ),INTENT(IN   ) :: l
    character(fnlen               ),INTENT(IN   ) :: layout

    integer(kind=irg        )                     :: n, m, m2, n2, i, y, Nr, limit

    ! clean up an existing object
    call this%destroy()

    ! set a few constants
    this%d    = d           ! half length of square Lambert projection
    this%maxL = l           ! max bandwidth of square lambert projection (must be <Nt for arbitrary rings (Nt*2 for legendre rings))
    this%Nw   = (2*d-1)/4+1 ! number of different types of weights [(dim-2) / 8 + 1]

    ! start with a sanity check on bandwidth and dimensions
    if (d.lt.1) call FatalError('DiscreteSHTConstants_Init','square lambert half side length must be at least 1')
    if (trim(layout).eq.'legendre') then
      limit = 2*d
      if (l.ge.limit) call FatalError('DiscreteSHTConstants_Init','maximum bandwidth is side # rings - 1 (for Legendre latitudes)')
    else if (trim(layout).eq.'lambert') then
      if (l.gt.this%d) call FatalError('DiscreteSHTConstants_Init','maximum bandwidth is (Lambert square side length) / 2')
    else
      call FatalError('DiscreteSHTConstants_Init','type must be "lambert" or "legendre" (got "' // trim(layout) // '")')
    end if

    ! allocate memory
    allocate(this%r1x2    (0:this%d)            ) ! precomputed sqrt(1-x*x) values
    allocate(this%wy      (0:this%d,0:this%Nw-1)) ! weighting factor for each ring [Nt * Nw]
    allocate(this%cosTy   (0:this%d)            ) ! cosine of latitude of each ring [Nt]
    allocate(this%amn     (0:l        ,0:l     )) ! precomputed a^m_n values for on the fly ylm calculation [maxL^2]
    allocate(this%bmn     (0:l        ,0:l     )) ! precomputed b^m_n values for on the fly ylm calculation [maxL^2]
    allocate(this%fftPlans(0:this%d)            ) ! array of plans for 1D real <--> complex ffts

    ! get the cosines of the latitudes
    this%cosTy = SH_cosLats(this%d, layout)

    ! and precompute the sqrt(1-x*x) values for the Legendre polynomials
    this%r1x2 = sqrt( 1.D0 - this%cosTy * this%cosTy )

    ! compute amn and bmn values

    ! first compute a^m_m and a^m_{m+1}
    this%amn = 0.D0
    this%bmn = 0.D0
    this%amn(0,0) = sqrt(1.D0/ (4.D0 * cPi))
    do m=1,this%maxL-1
      this%amn(m,m) = this%amn(m-1,m-1) * sqrt(1.D0 + 1.D0 / (2.D0*m))
    end do

    do m=0,this%maxL-1  ! first index of amn and bmn arrays
    ! compute remaining a^m_n and b^m_n values
        m2 = m*m
        do n=m+1,this%maxL-1    ! second index
          n2 = n*n
          this%amn(m, n) = sqrt( (4.D0*n2-1.D0)/dble(n2-m2) )  ! Schaeffer Eq. 17
          this%bmn(m, n) = sqrt( (2.D0*n+1.D0) * dble((n-1)*(n-1)-m2) / (2.D0*n-3.D0)/ dble(n2-m2) )  ! Schaeffer Eq. 18
        end do
    end do

    ! compute the ring weights (scales with dim^4 !!!)
    i = 0
    if (trim(layout).eq.'legendre') then ! legendre weights
      call SH_computeWeightsSkip(this, i, i) ! compute weights once with north pole excluded
      do i=1, this%Nw-1
        this%wy(:,i) = this%wy(:,0) ! copy weights to other rings
      enddo
    else if (trim(layout).eq.'lambert') then ! lambert weights
      do i=0, this%Nw-1
        call SH_computeWeightsSkip(this, i, i) ! compute weights for each excluded ring
      enddo
    else
      call FatalError('DiscreteSHTConstants_Init','type must be "lambert" or "legendre" (got "' // trim(layout) // '")')
    endif

    ! finally, build the array of pointers to fft plans; we need a backward and forward plan for each latitudinal ring size
    do y=1,this%d
      Nr = maxval( (/ 1, 8*y /) )
      call this%fftPlans(y)%init(Nr, FFT_PLAN_ESTIMATE)
    end do

  end subroutine DiscreteSHTConstants_Init

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: DiscreteSHTConstants_Destroy
  !
  !> @author Will Lenthe, Carnegie Mellon University
  !
  !> @brief Free a number of arrays
  !
  !> @param this structure to keep all relevant pre-computed variables
  !
  !> @date 07/17/19 WCL 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine DiscreteSHTConstants_Destroy(this)
  !DEC$ ATTRIBUTES DLLEXPORT :: DiscreteSHTConstants_Destroy
  implicit none

    class(DiscreteSHTConstants),INTENT(INOUT) :: this

    if(allocated(this%r1x2    )) deallocate(this%r1x2    )
    if(allocated(this%wy      )) deallocate(this%wy      )
    if(allocated(this%cosTy   )) deallocate(this%cosTy   )
    if(allocated(this%amn     )) deallocate(this%amn     )
    if(allocated(this%bmn     )) deallocate(this%bmn     )
    if(allocated(this%fftPlans)) deallocate(this%fftPlans)
  end subroutine DiscreteSHTConstants_Destroy

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: DiscreteSHTConstants_Finalize
  !
  !> @author Will Lenthe, Carnegie Mellon University
  !
  !> @brief call %destroy at cleanup
  !
  !> @param this structure to keep all relevant pre-computed variables
  !
  !> @date 07/17/19 WCL 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine DiscreteSHTConstants_Finalize(this)
  !DEC$ ATTRIBUTES DLLEXPORT :: DiscreteSHTConstants_Finalize
  implicit none
    type(DiscreteSHTConstants),INTENT(INOUT) :: this
    call this%destroy()
  end subroutine DiscreteSHTConstants_Finalize

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                    !!
!!                                                                    !!
!!                                                                    !!
!!                    DiscreteSHTConstants Members                    !!
!!                                                                    !!
!!                                                                    !!
!!                                                                    !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  recursive subroutine DiscreteSHT_Init(this, d, l, layout)
  !DEC$ ATTRIBUTES DLLEXPORT :: DiscreteSHT_Init

  implicit none

    class  (DiscreteSHT),INTENT(INOUT) :: this
    integer  (kind=irg ),INTENT(IN   ) :: d
    integer  (kind=irg ),INTENT(IN   ) :: l
    character(fnlen    ),INTENT(IN   ) :: layout
    integer(kind=irg   )               :: Npy

    ! clean up an existing object
    call this%destroy()

    ! first allocate constants
    allocate(this%shtLut)
    call this%shtLut%init(d, l, layout)

    ! next allocate fft specidic memory
    Npy = (this%shtLut%d+1)*8 ! largest ring size (equator)
    call this%pc1%allocCplx(Npy)
    call this%pc2%allocCplx(Npy)
    call this%pr1%allocReal(Npy)
    call this%pr2%allocReal(Npy)

    ! finally wrap fft memory
    call c_f_pointer(this%pc1%ptr, this%cWrk1, [Npy])
    call c_f_pointer(this%pc2%ptr, this%cWrk2, [Npy])
    call c_f_pointer(this%pr1%ptr, this%rWrk1, [Npy])
    call c_f_pointer(this%pr2%ptr, this%rWrk2, [Npy])
  end subroutine DiscreteSHT_Init

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: DiscreteSHT_Destroy
  !
  !> @author Will Lenthe, Carnegie Mellon University
  !
  !> @brief Free a number of arrays
  !
  !> @param this structure to keep all relevant pre-computed variables
  !
  !> @date 07/17/19 WCL 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine DiscreteSHT_Destroy(this)
  !DEC$ ATTRIBUTES DLLEXPORT :: DiscreteSHT_Destroy
  implicit none
    class(DiscreteSHT),INTENT(INOUT) :: this ! for final

    ! free fft allocated memory
    call this%pc1%free()
    call this%pc2%free()
    call this%pr1%free()
    call this%pr2%free()

    ! break pointer association
    nullify(this%cWrk1)
    nullify(this%cWrk2)
    nullify(this%rWrk1)
    nullify(this%rWrk1)

    ! free shtLut
    if(allocated(this%shtLut)) then
      call this%shtLut%destroy()
      deallocate(this%shtLut)
    endif
  end subroutine DiscreteSHT_Destroy

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: DiscreteSHT_Finalize
  !
  !> @author Will Lenthe, Carnegie Mellon University
  !
  !> @brief call %destroy at cleanup
  !
  !> @param this structure to keep all relevant pre-computed variables
  !
  !> @date 07/17/19 WCL 1.0 original
  !--------------------------------------------------------------------------
  recursive subroutine DiscreteSHT_Finalize(this)
  !DEC$ ATTRIBUTES DLLEXPORT :: DiscreteSHT_Finalize
  implicit none
    type(DiscreteSHT),INTENT(INOUT) :: this
    call this%destroy()
  end subroutine DiscreteSHT_Finalize

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_analyze
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief compute spherical harmonic coefficients from a spherical function (forward transformation)
  !
  !> @param pts value of function to analyze at each grid point (row major order, northern
  !             followed by southern hemisphere)
  !> @param alm location to write alm values maxL * maxL with (m,l) stored: (0,0), (0,1), (0,2), ...,
  !             (0,maxL-1), (1,0), (1,1), (1,2), ..., (maxL-1,0), (maxL-1,1), (maxL-1,maxL-1)
  !
  !> @date 01/21/19 MDG 1.0 original
  !> @date 07/29/19 WCL 2.0 switch from dim to half dim
  !--------------------------------------------------------------------------
  recursive subroutine SH_analyze(this, mLPNH, mLPSH, alm)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_analyze

  implicit none

    class  (DiscreteSHT),INTENT(INOUT)   :: this
    real   (kind=dbl   ),INTENT(IN   )   :: mLPNH(-this%shtLut%d:this%shtLut%d     ,-this%shtLut%d:this%shtLut%d     )
    real   (kind=dbl   ),INTENT(IN   )   :: mLPSH(-this%shtLut%d:this%shtLut%d     ,-this%shtLut%d:this%shtLut%d     )
    complex(kind=dbl   ),INTENT(INOUT)   :: alm  (             0:this%shtLut%maxL-1,             0:this%shtLut%maxL-1)

    integer(kind=irg        )            :: y, Npy, fftN, maxdim, mLim, m, d , n
    complex(kind=dbl        )            :: nPt, sPt
    real   (kind=dbl        )            :: x, wy, r1x2, kpmm, pmn, pmn1, pmn2, wcorr
    complex(C_DOUBLE_COMPLEX),pointer    :: outp
    complex(kind=dbl        )            :: sigma, delta

    ! fill alm with complex zeroes
    alm = cmplx(0.D0,0.D0)

    ! for each ring we have a series of operations...
    do y=1,this%shtLut%d
    ! copy current rings and compute G_{m,y} by fft (Reinecke equation 10) leveraging real symmetry
      Npy = maxval( (/ 1, 8*y /) )
      fftN = Npy/2+1   ! number of fft points: half from real -> conjugate symmetric, this includes problematic points
                       ! (imag == 0 from conjugate symmetry)

    ! read a ring from Northern and Southern hemispheres, and perform the correct fft on it to result in complex-valued data
      call SH_readRing(this%shtLut%d, mLPNH, y, this%rWrk1) ! extract yth ring from north pole into rWrk1
      call this%shtLut%fftPlans(y)%forward(this%rWrk1, this%cWrk1)
      call SH_readRing(this%shtLut%d, mLPSH, y, this%rWrk1) ! extract yth ring from south pole into rWrk
      call this%shtLut%fftPlans(y)%forward(this%rWrk1, this%cWrk2)

    ! compute G_{m,y} +/- G_{m,Nt-1-y} since they are multiplied by symmetric values
      mLim = minval( (/ this%shtLut%maxL, fftN /) )   ! anything after l+1 isn't needed and anything after fftN is 0
      do m=0,mLim-1

    ! get ring weight w_y
    ! weights excluding only the closest problematic ring (missing complex value due to real even dft) are most stable + accurate
    ! negate odd m values to correct for sign error in legendre polynomial calculation
        wcorr = 1.D0
        if (mod(m,2).eq.1) wcorr = -1.D0

    ! combine northern / southern hemisphere rings to take advantages of spherical harmonic symmetry
        nPt = wcorr * this%cWrk1(m+1) * cmplx(this%shtLut%wy(y,m/4),0.D0)
        sPt = wcorr * this%cWrk2(m+1) * cmplx(this%shtLut%wy(y,m/4),0.D0)

        this%cWrk1(m+1) = nPt + sPt ! for even l+m (harmonics are     symmetric across equator)
        this%cWrk2(m+1) = nPt - sPt ! for odd  l+m (harmonics are antisymmetric across equator)
      end do

    ! calculate seed values for on the fly legendre polynomial calculation (already done in the setup routine)
      x = this%shtLut%cosTy(y)       ! cosine of ring latitude
      r1x2 = this%shtLut%r1x2(y)     ! (1-x)^\frac{1}{2}: constant for P^m_m calculation
      kpmm = 1.D0             ! (1 - x^2) ^ \frac{|m|}{2} for m = 0: for P^m_m calculation

    ! accumulate a_{l,m} via direct summation (Reinecke equation 9) via on the fly summation
      do m=0,mLim-1

    ! first compute P^m_m
        pmn2 = this%shtLut%amn(m,m) * kpmm    ! recursively compute P^m_m (Schaeffer equation 13)
        kpmm = kpmm * r1x2             ! update recursion for (1 - x^2) ^ \frac{|m|}{2}
        alm(m,m) = alm(m,m) + this%cWrk1(m+1) * pmn2
        if (m+1.eq.this%shtLut%maxL) EXIT     ! P^m_{m+1} doesn't exist

    ! now compute P^m_{m+1}
        pmn1 = this%shtLut%amn(m,m+1) * x * pmn2   ! P^m_n for n = m+1 (Schaeffer equation 14)
        alm(m+1,m) = alm(m+1,m) + this%cWrk2(m+1)  * pmn1

    ! now compute the remaining polynomial values
        do n=m+2, this%shtLut%maxL-1
          pmn = this%shtLut%amn(m,n) * x * pmn1 - this%shtLut%bmn(m,n) * pmn2     ! P^m_n (Schaeffer equation 15)
          pmn2 = pmn1
          pmn1 = pmn
          if (mod(n+m,2).eq.0) then
            alm(n,m) = alm(n,m) + this%cWrk1(m+1) * pmn
          else
            alm(n,m) = alm(n,m) + this%cWrk2(m+1)  * pmn
          end if
        end do
      end do
    end do
  end subroutine SH_analyze

  !--------------------------------------------------------------------------
  !
  ! SUBROUTINE: SH_synthesize
  !
  !> @author Will Lenthe/Marc De Graef, Carnegie Mellon University
  !
  !> @brief compute a real values spherical function from spherical harmonic coefficients (reverse transformation)
  !
  ! @param  alm : spherical harmonic coefficients (non negative, maxL * maxL)
  ! @param  mLPNH : location to write function value at each grid point (row major order, northern followed by southern hemisphere)
  ! @param  mLPSH : location to write function value at each grid point (row major order, northern followed by southern hemisphere)
  ! @param  limL : maximum bandwidth to use (exclusive) in reverse calculation (must be < maxL), if 0 all bandwidths are used
  !
  !> @date 01/27/19 MDG 1.0 original
  !> @date 07/29/19 WCL 2.0 switch from dim to half dim
  !--------------------------------------------------------------------------
  recursive subroutine SH_synthesize(this, alm, mLPNH, mLPSH, limL)
  !DEC$ ATTRIBUTES DLLEXPORT :: SH_synthesize

    use error
    use ieee_arithmetic

  implicit none

    class  (DiscreteSHT),INTENT(INOUT)       :: this
    complex(kind=dbl   ),INTENT(IN   )       :: alm(               0:this%shtLut%maxL-1,             0:this%shtLut%maxL-1)
    real   (kind=dbl   ),INTENT(INOUT)       :: mLPNH(-this%shtLut%d:this%shtLut%d     ,-this%shtLut%d:this%shtLut%d     )
    real   (kind=dbl   ),INTENT(INOUT)       :: mLPSH(-this%shtLut%d:this%shtLut%d     ,-this%shtLut%d:this%shtLut%d     )
    integer(kind=irg   ),INTENT(IN   )       :: limL

    integer(kind=irg)                        :: y, Npy, fftN, mLim, bndMax, d, m, n, Nr, i
    real   (kind=dbl)                        :: x, r1x2, kpmm, pmn1, pmn2, pmn
    complex(kind=dbl)                        :: sigma, delta

    ! sanity check bandwidth limit
    if (limL.ge.this%shtLut%maxL) then
      call FatalError('SH_synthesize','limL must be < maxL')
    end if
    if (limL.eq.0) then
      bndMax = this%shtLut%maxL
    else
      bndMax = limL
    end if

    ! compute inverse SHT one ring at a time
    do y=1, this%shtLut%d  ! loop over rings

      Npy  = maxval( (/1, 8 * y /) )! get number of points in this ring
      fftN = Npy/2 + 1  ! number of fft points: half from real -> conjugate symmetric,
                        ! this includes problematic points (imag == 0 from conjugate symmetry)

    ! calculate seed values for on the fly legendre polynomial calculation (we've already initialized these in the set up)
      x = this%shtLut%cosTy(y)  ! cosine of ring latitude
      r1x2 = this%shtLut%r1x2(y)! (1-x)^\frac{1}{2}: constant for P^m_m calculation
      kpmm = 1.D0        ! (1 - x^2) ^ \frac{|m|}{2} for m = 0: for P^m_m calculation

      this%cWrk1 = cmplx(0.D0,0.D0)   ! for symmetric modes
      this%cWrk2 = cmplx(0.D0,0.D0)   ! for antisymmetric modes

      mLim = minval( (/ this%shtLut%maxL, fftN /) )   ! anything after l+1 isn't needed and anything after fftN is 0
      do m = 0, mLim-1
    ! first compute P^m_m
        pmn2 = this%shtLut%amn(m,m) * kpmm    ! recursively compute P^m_m (Schaeffer equation 13)
        kpmm = kpmm * r1x2             ! update recursion for (1 - x^2) ^ \frac{|m|}{2}
        this%cWrk1(m+1) = this%cWrk1(m+1) + alm(m,m) * pmn2
        if (m+1.eq.this%shtLut%maxL) EXIT     ! P^m_{m+1} doesn't exist

    ! now compute P^m_{m+1}
        pmn1 = this%shtLut%amn(m,m+1) * x * pmn2   ! P^m_n for n = m+1 (Schaeffer equation 14)
        this%cWrk2(m+1) = this%cWrk2(m+1) + alm(m+1,m) * pmn1

    ! now compute the remaining polynomial values
        do n=m+2, this%shtLut%maxL-1
          pmn = this%shtLut%amn(m,n) * x * pmn1 - this%shtLut%bmn(m,n) * pmn2     ! P^m_n (Schaeffer equation 15)
          pmn2 = pmn1
          pmn1 = pmn
          if (mod(n+m,2).eq.0) then
            this%cWrk1(m+1) = this%cWrk1(m+1) + alm(n,m) * pmn
          else
            this%cWrk2(m+1) = this%cWrk2(m+1) + alm(n,m) * pmn
          end if
        end do
      end do

    ! now convert from F_{m,y} +- F_{m,Nt-1-y} -> F_{m,y} and F_{m,Nt-1-y}
       do m = 0, mLim-1
    ! combine northern / southern hemisphere rings to take advantages of spherical harmonic symmetry
    ! negate odd m values to correct for sign error in legendre polynomial calculation
        if (mod(m,2).eq.1) then
          sigma = -this%cWrk1(m+1)         ! F_{m,y} + F_{m,Nt-1-y}
          delta = -this%cWrk2(m+1)         ! F_{m,y} - F_{m,Nt-1-y}
        else
          sigma = this%cWrk1(m+1)          ! F_{m,y} + F_{m,Nt-1-y}
          delta = this%cWrk2(m+1)          ! F_{m,y} - F_{m,Nt-1-y}
        end if
        this%cWrk1(m+1) = sigma + delta    ! northern hemisphere point
        this%cWrk2(m+1) = sigma - delta    ! southern hemisphere point
      end do

    ! do the inverse ffts of F_{m,y} and F_{m,Nt-1-y} (Reinecke equation 7) and copy to output

      this%rWrk1 = 0.D0
      call this%shtLut%fftPlans(y)%inverse(this%cWrk1, this%rWrk1)
      call SH_writeRing(this%shtLut%d, mLPNH, y, this%rWrk1)

      this%rWrk1 = 0.D0
      call this%shtLut%fftPlans(y)%inverse(this%cWrk2, this%rWrk1)
      call SH_writeRing(this%shtLut%d, mLPSH, y, this%rWrk1)
    end do
  end subroutine SH_synthesize

end module DSHT


C
C $Id: phi2sp.f,v 1.5 2008-07-27 00:17:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION PHI2SP (ECCENT,TS)
C
C FUNCTION TO COMPUTE LATITUDE ANGLE (PHI-2).
C
      IMPLICIT REAL (A-Z)
      INTEGER II,NIT
      COMMON /ERRMZ0/ IERR
        INTEGER IERR
      SAVE   /ERRMZ0/
      COMMON /PRINZ0/ IPEMSG,IPELUN,IPPARM,IPPLUN
        INTEGER IPEMSG,IPELUN,IPPARM,IPPLUN
      SAVE   /PRINZ0/
      DATA HALF,ONE,TWO /0.5E0,1.0E0,2.0E0/
      DATA TOL,NIT /1.0E-10,15/
      DATA HALFPI /1.5707963267948966E0/
C
      ECCNTH = HALF * ECCENT
      PHI = HALFPI - TWO * ATAN (TS)
      DO 020 II = 1,NIT
      SINPI = SIN (PHI)
      CON = ECCENT * SINPI
      DPHI = HALFPI - TWO * ATAN (TS * ((ONE - CON) /
     .       (ONE + CON)) ** ECCNTH) - PHI
      PHI = PHI + DPHI
      IF (ABS(DPHI) .GT. TOL) GO TO 020
      PHI2SP = PHI
      RETURN
  020 CONTINUE
C
      IF (IPEMSG .EQ. 0) WRITE (IPELUN,2000) NIT,ECCENT,TS
 2000 FORMAT (/' ERROR PHI2SP' /
     .         ' LATITUDE FAILED TO CONVERGE AFTER',I3,' ITERATIONS'/
     .         ' ECCENTRICITY =',E25.16,'   TS =',E25.16)
      IERR = 002
      RETURN
C
      END


*> \brief \b SGBT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK,
*                          RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            KL, KU, LDA, LDAFAC, M, N
*       REAL               RESID
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGBT01 reconstructs a band matrix  A  from its L*U factorization and
*> computes the residual:
*>    norm(L*U - A) / ( N * norm(A) * EPS ),
*> where EPS is the machine epsilon.
*>
*> The expression L*U - A is computed one column at a time, so A and
*> AFAC are not modified.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of subdiagonals within the band of A.  KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of superdiagonals within the band of A.  KU >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The original matrix A in band storage, stored in rows 1 to
*>          KL+KU+1.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER.
*>          The leading dimension of the array A.  LDA >= max(1,KL+KU+1).
*> \endverbatim
*>
*> \param[in] AFAC
*> \verbatim
*>          AFAC is REAL array, dimension (LDAFAC,N)
*>          The factored form of the matrix A.  AFAC contains the banded
*>          factors L and U from the L*U factorization, as computed by
*>          SGBTRF.  U is stored as an upper triangular band matrix with
*>          KL+KU superdiagonals in rows 1 to KL+KU+1, and the
*>          multipliers used during the factorization are stored in rows
*>          KL+KU+2 to 2*KL+KU+1.  See SGBTRF for further details.
*> \endverbatim
*>
*> \param[in] LDAFAC
*> \verbatim
*>          LDAFAC is INTEGER
*>          The leading dimension of the array AFAC.
*>          LDAFAC >= max(1,2*KL*KU+1).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (min(M,N))
*>          The pivot indices from SGBTRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (2*KL+KU+1)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          norm(L*U - A) / ( N * norm(A) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK,
     $                   RESID )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            KL, KU, LDA, LDAFAC, M, N
      REAL               RESID
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, I2, IL, IP, IW, J, JL, JU, JUA, KD, LENJ
      REAL               ANORM, EPS, T
*     ..
*     .. External Functions ..
      REAL               SASUM, SLAMCH
      EXTERNAL           SASUM, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SAXPY, SCOPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
*     Quick exit if M = 0 or N = 0.
*
      RESID = ZERO
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
*     Determine EPS and the norm of A.
*
      EPS = SLAMCH( 'Epsilon' )
      KD = KU + 1
      ANORM = ZERO
      DO 10 J = 1, N
         I1 = MAX( KD+1-J, 1 )
         I2 = MIN( KD+M-J, KL+KD )
         IF( I2.GE.I1 )
     $      ANORM = MAX( ANORM, SASUM( I2-I1+1, A( I1, J ), 1 ) )
   10 CONTINUE
*
*     Compute one column at a time of L*U - A.
*
      KD = KL + KU + 1
      DO 40 J = 1, N
*
*        Copy the J-th column of U to WORK.
*
         JU = MIN( KL+KU, J-1 )
         JL = MIN( KL, M-J )
         LENJ = MIN( M, J ) - J + JU + 1
         IF( LENJ.GT.0 ) THEN
            CALL SCOPY( LENJ, AFAC( KD-JU, J ), 1, WORK, 1 )
            DO 20 I = LENJ + 1, JU + JL + 1
               WORK( I ) = ZERO
   20       CONTINUE
*
*           Multiply by the unit lower triangular matrix L.  Note that L
*           is stored as a product of transformations and permutations.
*
            DO 30 I = MIN( M-1, J ), J - JU, -1
               IL = MIN( KL, M-I )
               IF( IL.GT.0 ) THEN
                  IW = I - J + JU + 1
                  T = WORK( IW )
                  CALL SAXPY( IL, T, AFAC( KD+1, I ), 1, WORK( IW+1 ),
     $                        1 )
                  IP = IPIV( I )
                  IF( I.NE.IP ) THEN
                     IP = IP - J + JU + 1
                     WORK( IW ) = WORK( IP )
                     WORK( IP ) = T
                  END IF
               END IF
   30       CONTINUE
*
*           Subtract the corresponding column of A.
*
            JUA = MIN( JU, KU )
            IF( JUA+JL+1.GT.0 )
     $         CALL SAXPY( JUA+JL+1, -ONE, A( KU+1-JUA, J ), 1,
     $                     WORK( JU+1-JUA ), 1 )
*
*           Compute the 1-norm of the column.
*
            RESID = MAX( RESID, SASUM( JU+JL+1, WORK, 1 ) )
         END IF
   40 CONTINUE
*
*     Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
      IF( ANORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
      END IF
*
      RETURN
*
*     End of SGBT01
*
      END


!***********************************************************************
!                                                                      *
      SUBROUTINE CGAMMA(ARGR, ARGI, RESR, RESI)
!                                                                      *
!   This subroutine returns in RES the complex Gamma function of the   *
!   complex argument ARG.  The suffixes R and I respectively distin-   *
!   guish the real and imaginary parts OF both RES and ARG.            *
!                                                                      *
!   Only RESR is nonzero if ARGI is zero.                              *
!                                                                      *
!   The  ARCTAN function required must return angles (in radians) in   *
!   the range  [0,2*\pi).                                              *
!                                                                      *
!   Subprogram(S) required: ARCTAN.                                    *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:46:48   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEF_C
      USE arctan_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE), INTENT(IN) :: ARGI, ARGR
      REAL(DOUBLE), INTENT(OUT) :: RESR, RESI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE), DIMENSION(7) :: FN, FD
      REAL(DOUBLE) :: HLNTPI, TWOI, DIFF, ARGUM, CLNGI, FACNEG, ARGUR, OVLFAC, &
         CLNGR, FAC, OBASQ, ARGUI, ARGUI2, OVLFR, OVLFI, TERMR, TERMI, ARGUR2, &
         OBASQR, OBASQI, ZFACR, ZFACI
      LOGICAL,SAVE :: FIRST, NEGARG
!----------------------------------------------------------------------*
!                                                                      *
!   These are the Bernoulli numbers B02, B04, ..., B14, expressed as   *
!   rational numbers. From abramowitz and stegun, p. 810.              *
!
      DATA FN/ 1.0D00, -1.0D00, 1.0D00, -1.0D00, 5.0D00, -691.0D00, 7.0D00/
      DATA FD/ 6.0D00, 30.0D00, 42.0D00, 30.0D00, 66.0D00, 2730.0D00, 6.0D00/
!
!----------------------------------------------------------------------*
!
      DATA HLNTPI/ 1.0D00/
!
      DATA FIRST/ .TRUE./
!
!   On the first entry to this routine, set up the constants required
!   for the reflection formula (cf. Abramowitz and Stegun 6.1.17) and
!   Stirling's approximation (cf. Abramowitz and Stegun 6.1.40).
!
      IF (FIRST) THEN
!
         HLNTPI = 0.5D00*LOG(PI + PI)
!
         DO I = 1, 7
            FN(I) = FN(I)/FD(I)
            TWOI = DBLE(I + I)
            FN(I) = FN(I)/(TWOI*(TWOI - 1.0D00))
         END DO
!
         FIRST = .FALSE.
!
      ENDIF
!
!   Cases where the argument is real
!
      IF (ARGI == 0.0D00) THEN
!
!   Cases where the argument is real and negative
!
         IF (ARGR <= 0.0D00) THEN
!
!   Stop with an error message if the argument is too near a pole
!
            DIFF = ABS(DBLE(NINT(ARGR)) - ARGR)
            IF (DIFF <= PRECIS + PRECIS) THEN
               WRITE (*, 300) ARGR, ARGI
               STOP
            ELSE
!
!   Otherwise use the reflection formula (Abramowitz and Stegun 6.1.17)
!   to ensure that the argument is suitable for Stirling's formula
!
               ARGUM = PI/(-ARGR*SIN(PI*ARGR))
               IF (ARGUM < 0.0D00) THEN
                  ARGUM = -ARGUM
                  CLNGI = PI
               ELSE
                  CLNGI = 0.0D00
               ENDIF
               FACNEG = LOG(ARGUM)
               ARGUR = -ARGR
               NEGARG = .TRUE.
!
            ENDIF
!
!   Cases where the argument is real and positive
!
         ELSE
!
            CLNGI = 0.0D00
            ARGUR = ARGR
            NEGARG = .FALSE.
!
         ENDIF
!
!   Use Abramowitz and Stegun formula 6.1.15 to ensure that
!   the argument in Stirling's formula is greater than 10
!
         OVLFAC = 1.0D00
    2    CONTINUE
         IF (ARGUR < 10.0D00) THEN
            OVLFAC = OVLFAC*ARGUR
            ARGUR = ARGUR + 1.0D00
            GO TO 2
         ENDIF
!
!   Now use Stirling's formula to compute Log (Gamma (ARGUM))
!
         CLNGR = (ARGUR - 0.5D00)*LOG(ARGUR) - ARGUR + HLNTPI
         FAC = ARGUR
         OBASQ = 1.0D00/(ARGUR*ARGUR)
         DO I = 1, 7
            FAC = FAC*OBASQ
            CLNGR = CLNGR + FN(I)*FAC
         END DO
!
!   Include the contributions from the recurrence and reflection
!   formulae
!
         CLNGR = CLNGR - LOG(OVLFAC)
         IF (NEGARG) CLNGR = FACNEG - CLNGR
!
      ELSE
!
!   Cases where the argument is complex
!
         ARGUR = ARGR
         ARGUI = ARGI
         ARGUI2 = ARGUI*ARGUI
!
!   Use the recurrence formula (Abramowitz and Stegun 6.1.15)
!   to ensure that the magnitude of the argument in Stirling's
!   formula is greater than 10
!
         OVLFR = 1.0D00
         OVLFI = 0.0D00
    4    CONTINUE
         ARGUM = SQRT(ARGUR*ARGUR + ARGUI2)
         IF (ARGUM < 10.0D00) THEN
            TERMR = OVLFR*ARGUR - OVLFI*ARGUI
            TERMI = OVLFR*ARGUI + OVLFI*ARGUR
            OVLFR = TERMR
            OVLFI = TERMI
            ARGUR = ARGUR + 1.0D00
            GO TO 4
         ENDIF
!
!   Now use Stirling's formula to compute Log (Gamma (ARGUM))
!
         ARGUR2 = ARGUR*ARGUR
         TERMR = 0.5D00*LOG(ARGUR2 + ARGUI2)
         TERMI = ARCTAN(ARGUI,ARGUR)
         CLNGR = (ARGUR - 0.5D00)*TERMR - ARGUI*TERMI - ARGUR + HLNTPI
         CLNGI = (ARGUR - 0.5D00)*TERMI + ARGUI*TERMR - ARGUI
         FAC = (ARGUR2 + ARGUI2)**(-2)
         OBASQR = (ARGUR2 - ARGUI2)*FAC
         OBASQI = -2.0D00*ARGUR*ARGUI*FAC
         ZFACR = ARGUR
         ZFACI = ARGUI
         DO I = 1, 7
            TERMR = ZFACR*OBASQR - ZFACI*OBASQI
            TERMI = ZFACR*OBASQI + ZFACI*OBASQR
            FAC = FN(I)
            CLNGR = CLNGR + TERMR*FAC
            CLNGI = CLNGI + TERMI*FAC
            ZFACR = TERMR
            ZFACI = TERMI
         END DO
!
!   Add in the relevant pieces from the recurrence formula
!
         CLNGR = CLNGR - 0.5D00*LOG(OVLFR*OVLFR + OVLFI*OVLFI)
         CLNGI = CLNGI - ARCTAN(OVLFI,OVLFR)
!
      ENDIF
!
!   Now exponentiate the complex Log Gamma function to get
!   the complex Gamma function
!
      IF (CLNGR<=EXPMAX .AND. CLNGR>=EXPMIN) THEN
         FAC = EXP(CLNGR)
      ELSE
         WRITE (*, 301) CLNGR
         STOP
      ENDIF
      RESR = FAC*COS(CLNGI)
      RESI = FAC*SIN(CLNGI)
!
      RETURN
!
  300 FORMAT('CGAMMA: Argument (',1P,1D19.12,',',1D19.12,')',&
         ' too close to a pole.')
  301 FORMAT('CGAMMA: Argument to exponential function',' (',1P,1D19.12,&
         ') out of range.')
      RETURN
!
      END SUBROUTINE CGAMMA


      SUBROUTINE MF_XDERIV

c     Differential equations for (R+1)/C where R is the reflection
c     matrix as defined by Budden.  The equations are derived from the
c     differential equations for R given by Budden in Proc. Roy. Soc.
c     (London), A227, pp.516-537 (1955).  Storage into the array
c     'RMTRX' is made so that the equations may be used with either
c     the main set of integration variables, or with the comparison
c     set, X.  Differential equations for the derivatives of (R+1)/C
c     wrt c=COS(THETA) are also used if IDERIV is set non-zero.

      implicit complex (a-h,o-z)

      real           omega,wavenr
      complex        mikov2

      common/mf_flag/iexact,iovflo,kexact,lowg,nodivd,noevct,
     &               nofinl,nointg,nomesh,notlin
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_rmtx/r11,r21,r12,r22,dr11dc,dr21dc,dr12dc,dr22dc,dr11dh,
     &               dr21dh,dr12dh,dr22dh,dr11ch,dr21ch,dr12ch,dr22ch
     &      /mf_rntg/r(8),drdh(8),roe(8),rnd(5)
     &      /mf_smtx/a11,a22,b11,b12,b22,c11,c21,c22,d11,d21,d12,d22,
     &               db11dc,db22dc,dc11dc,dc22dc,dd11dc,dd21dc,dd12dc
     &      /mf_xntg/x(4),dxdh(4)

      dimension      rmtrx(8),deriv(8),rtm(4),drtmdc(4)

      equivalence   (rmtrx(1),r11),(deriv(1),dr11dh)

      call MF_LGTORI (x,rtm,drtmdc,0)

      if (iovflo .ne. 0) RETURN

      mikov2=CMPLX(0.,-.5*wavenr)

      d11r11=d11*r11
      d12r21=d12*r21
      d21r12=d21*r12
      d22r22=d22*r22
      r11r22=r11*r22
      r12r21=r12*r21

      dr11dh=mikov2*(a11+(b11+c11+d11r11+d12r21+d21r12)*r11
     &              +b12*r21+c21*r12+d22*r12r21)
      dr21dh=mikov2*((b22+c11+d11r11+d12r21+d22r22)*r21
     &               +c21*r22+d21*r11r22)
      dr12dh=mikov2*((b11+c22+d11r11+d21r12+d22r22)*r12
     &               +b12*r22+d12*r11r22)
      dr22dh=mikov2*(a22+(b22+c22+d12r21+d21r12+d22r22)*r22
     &              +d11*r12r21)

      call MF_TODLGS (dxdh,rtm,drtmdc,0)

      RETURN
      END      ! MF_XDERIV


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!========================================================================================
! A class to calculate sensitivity values for magnetic field.
!
! Vitaliy Ogarko, UWA, CET, Australia, 2015-2016.
!========================================================================================
module magnetic_field

  use global_typedefs
  use grid

  implicit none

  private

  ! The vacuum magnetic permeability (SI).
  double precision, parameter :: mu0 = PI * 4.d-7

  ! Degrees to radians conversion factor.
  double precision, parameter :: d2rad = PI / 180.d0

  ! Main class.
  type, public :: t_magnetic_field
    private

    ! For optimization of mbox() function calculation precompute these parameters.
    double precision :: fm1, fm2, fm3, fm4, fm5, fm6

    ! External/background (average regional) field intensity (nT).
    double precision :: intensity

  contains
    private

    procedure, public, pass :: initialize => magnetic_field_initialize
    procedure, public, pass :: magprism => magnetic_field_magprism

    procedure, private, pass :: mbox
    procedure, private, nopass :: dircos

  end type t_magnetic_field

contains

!==============================================================================
! Initialization.
! See parameters description in mbox() function.
!==============================================================================
subroutine magnetic_field_initialize(this, mi, md, fi, fd, theta, intensity)
  class(t_magnetic_field), intent(inout) :: this
  double precision, intent(in) :: mi, md, fi, fd, theta, intensity

  double precision :: ma, mb, mc
  double precision :: fa, fb, fc

  this%intensity = intensity

  call this%dircos(mi, md, theta, ma, mb, mc)
  call this%dircos(fi, fd, theta, fa, fb, fc)

  this%fm1 = ma * fb + mb * fa
  this%fm2 = ma * fc + mc * fa
  this%fm3 = mb * fc + mc * fb
  this%fm4 = ma * fa
  this%fm5 = mb * fb
  this%fm6 = mc * fc

end subroutine magnetic_field_initialize

!====================================================================================================
! Calculates the sensitivity kernel.
!====================================================================================================
subroutine magnetic_field_magprism(this, nelements, data_j, grid, Xdata, Ydata, Zdata, sensit_line)
  class(t_magnetic_field), intent(in) :: this
  integer, intent(in) :: nelements, data_j
  type(t_grid), intent(in) :: grid
  real(kind=CUSTOM_REAL), intent(in) :: Xdata(:), Ydata(:), Zdata(:)

  real(kind=CUSTOM_REAL), intent(out) :: sensit_line(:)

  integer :: i
  real(kind=CUSTOM_REAL) :: t1, t2

  do i = 1, nelements

    call this%mbox(Xdata(data_j), Ydata(data_j), Zdata(data_j), &
                   grid%X1(i), grid%Y1(i), grid%Z1(i), grid%X2(i), grid%Y2(i), t1)

    call this%mbox(Xdata(data_j), Ydata(data_j), Zdata(data_j), &
                   grid%X1(i), grid%Y1(i), grid%Z2(i), grid%X2(i), grid%Y2(i), t2)

    sensit_line(i) = (t1 - t2) / (4.d0 * PI)

  enddo

end subroutine magnetic_field_magprism

!===================================================================================
!  Subroutine MBOX computes the total field anomaly of an infinitely
!  extended rectangular prism. Sides of prism are parallel to x,y,z
!  axes, and z is vertical down. Bottom of prism extends to infinity.
!  Two calls to mbox can provide the anomaly of a prism with finite
!  thickness; e.g.,
!
!     call mbox(x0,y0,z0,x1,y1,z1,x2,y2,mi,md,fi,fd,m,theta,t1)
!     call mbox(x0,y0,z0,x1,y1,z2,x2,y2,mi,md,fi,fd,m,theta,t2)
!     t=t1-t2
!
!  Requires subroutine DIRCOS.
!  Method from Ref. [1]. For more details see also Refs. [2-3].
!  [1] B. K. Bhattacharyya, Magnetic anomalies due to prism-shaped bodies with arbitrary polarization, Geophysics, 29, 1964.
!  [2] B. K. Bhattacharyya, Computer modeling in gravity and magnetic interpretation, Geophysics, 43, 1978.
!  [3] B. K. Bhattacharyya, A generalized multibody model for inversion of magnetic anomalies, Geophysics, 45, 1980.
!
!  Input parameters:
!    Observation point is (x0,y0,z0). Prism extends from x1 to
!    x2, y1 to y2, and z1 to infinity in x, y, and z directions,
!    respectively.  Magnetization defined by inclination mi,
!    declination md, intensity m.  Ambient field defined by
!    inclination fi and declination fd.  X axis has declination
!    theta. Distance units are irrelevant but must be consistent.
!    Angles are in degrees, with inclinations positive below
!    horizontal and declinations positive east of true north.
!    Magnetization in A/m.
!
!  Output parameters:
!    Total field anomaly t, in nT.
!===================================================================================
subroutine mbox(this, x0, y0, z0, x1, y1, z1, x2, y2, t)
  class(t_magnetic_field), intent(in) :: this
  double precision, intent(in) :: x0, y0, z0, x1, y1, z1, x2, y2
  double precision, intent(out) :: t

  ! Local variables.
  double precision :: alpha(2), beta(2)
  double precision :: alphabeta, alphasq, arg1, arg2, arg3, arg4
  double precision :: h, hsq, r0, r0h, r0sq, sign, tatan, tlog
  integer :: i, j

  alpha(1) = x1 - x0
  alpha(2) = x2 - x0

  beta(1) = y1 - y0
  beta(2) = y2 - y0

  h = z1 - z0

  ! Sanity check.
  if (h < 0.d0) then
    print *, "Error in mbox: negative depth h =", h
    stop
  endif

  t = 0.
  hsq = h**2

  do i = 1, 2
    alphasq = alpha(i)**2
    do j = 1, 2
      sign = 1.
      if (i /= j) sign = -1.

      r0sq = alphasq + beta(j)**2 + hsq
      r0 = dsqrt(r0sq)
      r0h = r0 * h
      alphabeta = alpha(i) * beta(j)

      arg1 = (r0 - alpha(i)) / (r0 + alpha(i))
      arg2 = (r0 - beta(j)) / (r0 + beta(j))
      arg3 = alphasq + r0h + hsq
      arg4 = r0sq + r0h - alphasq

      tlog = this%fm3 * dlog(arg1) / 2. + this%fm2 * dlog(arg2) / 2. - this%fm1 * dlog(r0 + h)
      tatan = - this%fm4 * datan2(alphabeta, arg3) - this%fm5 * datan2(alphabeta, arg4) + this%fm6 * datan2(alphabeta, r0h)

      t = t + sign * (tlog + tatan)
    enddo
  enddo

  !t = t * mu0 * this%intensity
  t = t * this%intensity

end subroutine mbox

!==============================================================================
!  Subroutine DIRCOS computes direction cosines from inclination
!  and declination.
!
!  Input parameters:
!    incl:  inclination in degrees positive below horizontal.
!    decl:  declination in degrees positive east of true north.
!    azim:  azimuth of x axis in degrees positive east of north.
!
!  Output parameters:
!    a,b,c:  the three direction cosines.
!==============================================================================
subroutine dircos(incl, decl, azim, a, b, c)
  double precision, intent(in) :: incl, decl, azim
  double precision, intent(out) :: a, b, c

  double precision :: xincl, xdecl, xazim

  xincl = incl * d2rad
  xdecl = decl * d2rad
  xazim = azim * d2rad

  a = dcos(xincl) * dcos(xdecl - xazim)
  b = dcos(xincl) * dsin(xdecl - xazim)
  c = dsin(xincl)

end subroutine dircos

end module magnetic_field


*----------------------------------------------------------------------*
      subroutine get_genealogical_coeff(s2,ms2,nc,na,ncoup,
     &               coeff,cperm,aperm)
*----------------------------------------------------------------------*
*     retrieve the genealogical coupling coefficients for an
*     arbitrary operator consisting of a string of creators
*     followed by a string of annihilators for a given alpha/beta perm.
*
*     s2 = 2*S, ms2 = 2*Ms, nc = # of C operators, na = # of A operators
*     ncoup = # of possible coupling pathways = # of components
*     cperm, aperm: alpha/beta permutation for C and A string
*
*     matthias, apr 2013
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     s2, ms2, nc, na, ncoup, cperm(nc), aperm(na)
      real(8), intent(out) ::
     &     coeff(ncoup)

      integer ::
     &     icoup, nup, branchperm(nc+na), iel, is2, ims2, ic, ia
      real(8) ::
     &     sigma
      logical ::
     &     branchnext

      logical, external ::
     &     next_perm

      ! now come the loops through the branching diagram
      icoup = 0
      if (mod(nc+na+s2,2).ne.0)
     &   call quit(1,'get_genealogical_coeff','impossible S')
      nup = (nc+na+s2)/2 !total number of up-couplings
      branchperm(1:nup) = 0 ! initial up-couplings
      branchperm(nup+1:nc+na) = 1 !initial down-couplings
      branchnext = .true.
      branch_loop: do while (branchnext)
        ! we may not couple below S=0
        do iel = 1, nc+na
          if (sum(branchperm(1:iel)).gt.iel/2) then
            ! next branch
            branchnext = next_perm(branchperm,nc+na)
            cycle branch_loop
          end if
        end do
        icoup = icoup + 1
c dbg
c        write(lulog,'(a,20i2)') 'current branch:',branchperm
c dbgend

        ! walk along the path and couple everything together
        is2 = 0
        ims2 = 0
        iel = 0
        coeff(icoup) = 1d0
c dbg
c        print *,'icoup: ',icoup
c dbgend
        ! first C string
        do ic = 1, nc
          iel = iel + 1
          is2 = is2-2*branchperm(iel)+1 ! couple total spin up/down
          ims2 = ims2+cperm(ic) ! couple Ms up/down
          ! get coefficient
          sigma = 0.5d0*dble(cperm(ic)) ! alpha or beta
c dbg
c          print *,'get coeff. for is2,ims2,sigma=',is2,ims2,sigma
c dbgend
          if (branchperm(iel).eq.0) then ! up case
            coeff(icoup) = coeff(icoup) *
     &         sqrt(max(0d0,(dble(is2)/2d0+sigma*dble(ims2))/dble(is2)))
          else ! down case
            coeff(icoup) = -2d0*sigma*coeff(icoup) *
     &         sqrt(max(0d0,(dble(is2)/2d0+1d0-sigma*dble(ims2))/
     &              (dble(is2)+2d0)))
          end if
        end do
        ! now A string in reverse order
        do ia = na, 1, -1
          iel = iel + 1
          is2 = is2-2*branchperm(iel)+1 ! couple total spin up/down
          ims2 = ims2-aperm(ia) ! couple Ms down/up
          ! get coefficient
          sigma = -0.5d0*dble(aperm(ia)) ! beta or alpha
          if (branchperm(iel).eq.0) then ! up case
            coeff(icoup) = coeff(icoup) *
     &         sqrt(max(0d0,(dble(is2)/2d0+sigma*dble(ims2))/dble(is2)))
          else ! down case
            coeff(icoup) = -2d0*sigma*coeff(icoup) *
     &         sqrt(max(0d0,(dble(is2)/2d0+1d0-sigma*dble(ims2))/
     &              (dble(is2)+2d0)))
          end if
          ! beta? -> change sign!
          if (aperm(ia).eq.-1) coeff(icoup)
     &                        = -coeff(icoup)
        end do

        ! next branch
        branchnext = next_perm(branchperm,nc+na)
      end do branch_loop

      return
      end


      DOUBLE PRECISION FUNCTION DKINT(I,J,A,B,IV,IW,R,Z)
      DOUBLE PRECISION BINT, C1P, C2P, C1, C2, AW, A, B, R, Z,DKJ, DKEF
      DOUBLE PRECISION SP1
      DIMENSION  R(1) , Z(1)
      BINT = 0.0D0
      IW1 = IW + 1
      C1P = B
      C2P = A
      C1 = C1P
      C2 = C2P
      AW = 0.0D0
      IF( R(I) .NE. 0.0D0 .AND. R(J) .NE. 0.0D0 ) AW = DLOG(R(J)/R(I))
      DO 100 IT = 1,IW1
      IC = IW - IT + 1
      IF (IC.EQ.0) C1 = 1.0D0
      IF (IT.EQ.1) C2 = 1.0D0
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C THE FOLLOWING CODE REPLACES DOUBLE PRECISION FUNCTION DKEF
C
      IF(IT.EQ.1) GO TO 20
      IN=1
      ID=1
      DO 10 K=2,IT
      IN=IN*(IW-K+2)
      ID=ID*(K-1)
   10 CONTINUE
      DKEF=IN/ID
      GO TO 30
   20 DKEF=1.0D0
   30 CONTINUE
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C THE FOLLOWING CODE REPLACES DOUBLE PRECISION FUNCTION DKJ
C
      IS1 = IC+IV+1
      IF(IS1.EQ.0) GO TO 60
      SP1=IS1
      DKJ=( R(J)**IS1 - R(I)**IS1 )  /  SP1
      GO TO 70
   60 DKJ = AW
   70 CONTINUE
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      BINT = BINT + C1 ** IC *DKJ * C2 ** (IT - 1) * DKEF
      C1 = C1P
      C2 = C2P
  100 CONTINUE
      AW = IW
      BINT = BINT / AW
      DKINT = BINT
      RETURN
      END


      SUBROUTINE PLANETS(TSEC50,KPLANET,KCOORD,KUNITS,POS,LUERR,IERR)
      IMPLICIT REAL*8(A-H,M,O-Z)
C
C PLANETS GIVES THE GEOCENTRIC POSITION OF A SPECIFIED PLANET AT TIME
C TSEC50. POSITIONS ARE DETERMINED ANALYTICALLY USING KEPLERIAN MOTION
C ABOUT THE SUN, THEN TRANSLATING TO GEOCENTRIC.
C
C VARIABLE DIM I/O  TYPE  DESCRIPTION
C -------- --- ---  ----  -----------
C
C TSEC50    1   I    R*8  TIME AT WHICH THE POSITION IS WANTED.
C                         ACCURACY DOES NOT WARRANT ET-UT CONSIDERATION.
C                         IN SEC SINCE 1/1/50, 0.0 HR
C
C KPLANET   1   I    I*4  NUMBER IDENTIFYING THE PLANET.
C
C                          = 0, SUN
C                          = 1, MERCURY
C                          = 2, VENUS
C                          = 3, EARTH
C                          = 4, MARS
C                          = 5, JUPITER
C                          = 6, SATURN
C                          = 7, URANUS
C                          = 8, NEPTUNE
C                          = 9, PLUTO
C                          = OTHERWISE, ERROR. POSITION RETURNED AS ZERO
C
C KCOORD    1   I    I*4  COORDINATE SYSTEM TO WHICH POSITION VECTOR IS
C                         TO BE REFERENCED.
C
C                          = 1, GEOCENTRIC MEAN EARTH EQTR/EQNX OF 1950.
C                          = 2, GEOCENTRIC MEAN EARTH EQUATOR AND
C                               EQUINOX OF DATE(DATE=TSEC50)
C                          = 3, GEOCENTRIC TRUE EARTH EQUATOR AND
C                               EQUINOX OF DATE(DATE=TSEC50)
C                          = OTHERWISE, ERROR. POSITION RETURNED AS ZERO
C
C KUNITS    1   I    I*4  FLAG INDICATING THE LENGTH UNITS WANTED FOR
C                         POS.
C
C                          = 1, ASTRONOMICAL UNITS. 1 AU IS DETERMINED
C                               BY THE VALUE IN THE FUNCTION SUBROUTINE
C                               CONST.
C                          = OTHERWISE, KILOMETERS
C
C POS       3   O    R*8  CARTESIAN GEOCENTRIC POSITION VECTOR OF THE
C                         PLANET CENTER.
C
C LUERR     1   I    I*4  FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                          = ZERO OR NEGATIVE, NO MESSAGE IS POSSIBLE.
C
C IERR      1   O    I*4  ERROR OUTPUT FLAG.
C                          =0, NO ERROR FOUND
C                          =1, ERROR IN INPUT. PLANET ID IS INVALID
C                          =2, ERROR IN INPUT. KCOORD VALUE IS INVALID
C
C**********************************************************************
C
C BY KAREN M. KEADLE, 8/83.
C     MODIFIED....    CJP, 12/84.....
C
C**********************************************************************
C
      REAL*8 DEGRAD/57.29588051308232D0/
      REAL*8 TWOPI/6.283185307179586D0/
C
      PARAMETER NPLANETS = 9
      DIMENSION ELEMS(6,NPLANETS),PERIOD(NPLANETS)
C
      REAL*8 POS(3),HELIOPOS(3,2),KEPLER(6),DUM3(3)
C
      INTEGER INIT/0/
C
      IERR = 0
C
C FIRST-CALL LOGIC. LOAD ELEMS, THE KEPLERIAN ELEMENTS FOR THE PLANETS.
C COORDINATE SYSTEM IS HELIOCENTRIC, MEAN EARTH EQUATOR AND EQUINOX
C OF 1950.0. UNITS ARE KM AND RADIANS. EPOCH IS SEC SINCE 1/1/50,
C 0.0 HR. PERIOD IS IN SECONDS. SUNMU IS KM**3/SEC**2.
C
      IF(INIT.EQ.0) THEN
        INIT = 1
        CALL PLANETS1(EPOCH,ELEMS,PERIOD,SUNMU)
        END IF
C
C ERROR CHECKS
C
      IF(KPLANET.LT.0 .OR. KPLANET.GT.9) THEN
        IERR = 1
        POS(1) = 0.D0
        POS(2) = 0.D0
        POS(3) = 0.D0
        IF(LUERR.GT.0) WRITE(LUERR,9001) 'BAD PLANET NUMBER.',KPLANET
        GO TO 9999
        END IF
C
      IF(KCOORD.LT.1 .OR. KCOORD.GT.3) THEN
        IERR = 2
        POS(1) = 0.D0
        POS(2) = 0.D0
        POS(3) = 0.D0
        IF(LUERR.GT.0) WRITE(LUERR,9001)
     *      'BAD COORDINATE SYSTEM IDENTIFIER.',KCOORD
        GO TO 9999
        END IF
C
C
C SPECIAL CASE. EARTH IS ALWAYS AT 0,0,0.
C
      IF(KPLANET.EQ.3) THEN
        POS(1) = 0.D0
        POS(2) = 0.D0
        POS(3) = 0.D0
        GO TO 9999
        END IF
C
C FIND HELIOPOS(-,1), THE POSITION VECTOR OF THE PLANET WRT THE SUN, AND
C FIND HELIOPOS(-,2), THE POSITION VECTOR OF THE EARTH WRT THE SUN.
C BOTH VECTORS ARE IN MEAN OF 1950.0, EQUATORIAL COORDINATES.
C
      DT = TSEC50 - EPOCH    ! ELAPSED TIME SINCE EPOCH
C
      DO 15 IPL=1,2
      IF(IPL.EQ.1) KPL = KPLANET
      IF(IPL.EQ.2) KPL = 3
      IF(KPL.EQ.0) THEN   ! IE, THIS IS THE SUN.
        HELIOPOS(1,1) = 0.D0
        HELIOPOS(2,1) = 0.D0
        HELIOPOS(3,1) = 0.D0
        GO TO 15
        END IF
C
C   MEAN ANOMALY CHANGE BETWEEN EPOCH AND TSEC50.
      DELMA = TWOPI * DT/PERIOD(KPL)
C
C   MEAN ANOMALY OF THE PLANET AT THE REQUIRED TIME
      MEANANOM = EQVANG( ELEMS(6,KPL) + DELMA )
C
C   SET KEPLER, THE KEPLERIAN ELEMEMTS AT THE REQ'D TIME
      KEPLER(1) = ELEMS(1,KPL)
      KEPLER(2) = ELEMS(2,KPL)
      KEPLER(3) = ELEMS(3,KPL)
      KEPLER(4) = ELEMS(4,KPL)
      KEPLER(5) = ELEMS(5,KPL)
      KEPLER(6) = MEANANOM
C
C   CONVERT KEPLER TO CARTESIAN
      CALL TOCART(SUNMU,KEPLER,0,HELIOPOS(1,IPL),DUM3,6,IER1)
      IF(IER1.NE.0) STOP 'PLANETS. CODING ERROR. STOP 1.'
C
   15 CONTINUE
C
C
C CALCULATE PLANET POSITION IN GEOCENTRIC EQUATORIAL, MEAN OF 1950.0
C COORDINATE SYSTEM.  NOTE THAT PLANET1 INITIALIZED THE ELEMENTS IN
C HELIOCENTRIC, MEAN EARTH EQUATOR AND EQUINOX OF 1950.0, SO ONLY
C TRANSLATION IS NEEDED.
C
      FACTOR = 1.D0
      IF(KUNITS.EQ.1) FACTOR = CONST(60)   ! AU VALUE
      DO I=1,3
        POS(I) = (HELIOPOS(I,1) - HELIOPOS(I,2)) / FACTOR
        END DO
C
C ROTATE FROM MEAN EQTR/EQNX OF 1950.0 TO OUTPUT SYSTEM, IF NECESSARY.
C
      IF(KCOORD.EQ.2) CALL VECM50MDT(TSEC50,1,POS,POS)
      IF(KCOORD.EQ.3) CALL VECM50TOD(TSEC50,1,POS,POS)
C
C
 9999 CONTINUE
      RETURN
 9001 FORMAT(/,' PLANETS ERROR. ',A,'  VALUE=',I7)
      END