C
C $Id: mdpgci.f,v 1.8 2008-09-18 00:42:17 kennison 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
      SUBROUTINE MDPGCI (ALAT,ALON,BLAT,BLON,NOPI,RLTI,RLNI)
C
        INTEGER          NOPI
        DOUBLE PRECISION ALAT,ALON,BLAT,BLON,RLTI(*),RLNI(*)
C
C Declare common block containing math constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C This routine, given the latitudes and longitudes of two points A and
C B on the surface of the globe, interpolates NOPI points along the
C great circle route joining A to B and returns the latitudes and
C longitudes of the interpolated points in the arrays RLTI and RLNI.
C
C Rotations about a given axis are used extensively below.  Assume a
C right-handed system with U, V, and W axes.  Rotating by an angle "a"
C about the U axis maps the point (u,v,w) into the point (u',v',w'),
C where
C
C       u' = u
C       v' = v cos(a) - w sin(a)
C       w' = w cos(a) + v sin(a)
C
C A positive value of "a" represents rotation in the direction from the
C V axis to the W axis.
C
C Similarly, rotating by an angle "a" about the V axis maps the point
C (u,v,w) into the point (u',v',w'), where
C
C       u' = u cos(a) + w sin(a)
C       v' = v
C       w' = w cos(a) - u sin(a)
C
C A positive value of "a" represents rotation in the direction from the
C W axis to the U axis.
C
C Rotating by an angle "a" about the W axis maps the point (u,v,w) into
C the point (u',v',w'), where
C
C       u' = u cos(a) - v sin(a)
C       v' = v cos(a) + u sin(a)
C       w' = w
C
C A positive value of "a" represents rotation in the direction from the
C U axis to the V axis.
C
C Declare local variables.
C
        INTEGER          IOPI
C
        DOUBLE PRECISION ALPH,BETA,CALN,CALP,CALT,CBLN,CBLT,GAMA,SALN,
     +                   SALP,SALT,SBLN,SBLT,UCPA,UCPB,UCPD,UCPF,UCPG,
     +                   UCPH,UCPO,UCPP,UCPQ,VCPA,VCPB,VCPD,VCPF,VCPG,
     +                   VCPH,VCPO,VCPP,VCPQ,WCPA,WCPB,WCPD,WCPF,WCPG,
     +                   WCPH,WCPO,WCPP,WCPQ
C
C Check for an uncleared prior error.
C
      IF (ICFELL('MDPGCI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Compute the U, V, and W coordinates (on a unit sphere) of the points
C A and B.
C
        CALT=COS(ALAT*DTOR)
        SALT=SIN(ALAT*DTOR)
        CALN=COS(ALON*DTOR)
        SALN=SIN(ALON*DTOR)
C
        CBLT=COS(BLAT*DTOR)
        SBLT=SIN(BLAT*DTOR)
        CBLN=COS(BLON*DTOR)
        SBLN=SIN(BLON*DTOR)
C
        UCPA=CALT*CALN
        VCPA=CALT*SALN
        WCPA=SALT
C
        UCPB=CBLT*CBLN
        VCPB=CBLT*SBLN
        WCPB=SBLT
C
C Rotating the points about the W axis by the angle -ALON carries point
C A into point C, in the UW plane.  It carries point B into point D.
C
C       CDLN=COS((BLON-ALON)*DTOR)
C       SDLN=SIN((BLON-ALON)*DTOR)
C
C       UCPC=CALT
C       VCPC=0.D0
C       WCPC=SALT
C
        UCPD=UCPB*CALN+VCPB*SALN
        VCPD=VCPB*CALN-UCPB*SALN
        WCPD=WCPB
C
C       UCPD=CBLT*CDLN
C       VCPD=CBLT*SDLN
C       WCPD=SBLT
C
C Rotating the points about the V axis by the angle ALAT carries point
C C into point E, on the U axis.  It carries point D into point F.
C
C       UCPE=1.D0
C       VCPE=0.D0
C       WCPE=0.D0
C
        UCPF=UCPD*CALT+WCPD*SALT
        VCPF=VCPD
        WCPF=WCPD*CALT-UCPD*SALT
C
C       UCPF=CALT*CBLT*CDLN-SALT*SBLT
C       VCPF=CBLT*SDLN
C       WCPF=CALT*SBLT+SALT*CBLT*CDLN
C
C Rotating the points about the U axis by the angle -ATAN(WCPF/VCPF)
C leaves the position of point E unchanged, but carries point F into
C point G, in the UV plane.
C
        IF (WCPF.NE.0.D0.OR.VCPF.NE.0.D0) THEN
          ALPH=ATAN2(WCPF,VCPF)
        ELSE
          ALPH=0.D0
        END IF
C
        CALP=COS(ALPH)
        SALP=SIN(ALPH)
C
        UCPG=UCPF
        VCPG=VCPF*CALP+WCPF*SALP
        WCPG=WCPF*CALP-VCPF*SALP
C
C       UCPG=CALT*CBLT*CDLN-SALT*SBLT
C       VCPG=CBLT*SDLN*CALP-CALT*SBLT*SALP-SALT*CBLT*CDLN*SALP
C       WCPG=CALT*SBLT*CALP+SALT*CBLT*CDLN*CALP+CBLT*SDLN*SALP
C
C The angle from E to G (which is the same as the angle from A to B)
C may now be computed easily.
C
        IF (VCPG.NE.0.D0.OR.UCPG.NE.0.D0) THEN
          BETA=ATAN2(VCPG,UCPG)
        ELSE
          BETA=0.D0
        END IF
C
C Interpolate points between the points E and G and map them back to
C the great circle route between A and B.
C
        DO 101 IOPI=1,NOPI
          GAMA=(DBLE(IOPI)/DBLE(NOPI+1))*BETA
          UCPH=COS(GAMA)
          VCPH=SIN(GAMA)
          WCPH=0.D0
          UCPO=UCPH
          VCPO=VCPH*CALP-WCPH*SALP
          WCPO=WCPH*CALP+VCPH*SALP
          UCPP=UCPO*CALT-WCPO*SALT
          VCPP=VCPO
          WCPP=WCPO*CALT+UCPO*SALT
          UCPQ=UCPP*CALN-VCPP*SALN
          VCPQ=VCPP*CALN+UCPP*SALN
          WCPQ=WCPP
          RLTI(IOPI)=RTOD*ATAN2(WCPQ,SQRT(UCPQ*UCPQ+VCPQ*VCPQ))
          IF (VCPQ.NE.0.D0.OR.UCPQ.NE.0.D0) THEN
            RLNI(IOPI)=RTOD*ATAN2(VCPQ,UCPQ)
          ELSE
            RLNI(IOPI)=0.D0
          END IF
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END


! Theta-e
!NCLFORTSTART
SUBROUTINE DEQTHECALC(qvp, tmk, prs, eth, miy, mjx, mkzh)
    USE wrf_constants, ONLY : EPS, GAMMA, GAMMAMD, TLCLC1, TLCLC2, TLCLC3, TLCLC4, &
                          THTECON1, THTECON2, THTECON3

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: eth

    ! Input variables
    ! Sizes
    INTEGER,INTENT(IN) :: miy, mjx, mkzh
    ! Qvapor [g/kg]
    REAL(KIND=8), DIMENSION(miy,mjx,mkzh), INTENT(IN) :: qvp
    ! Temperature [K]
    REAL(KIND=8), DIMENSION(miy,mjx,mkzh), INTENT(IN) :: tmk
    ! full pressure (=P+PB) [hPa]
    REAL(KIND=8), DIMENSION(miy,mjx,mkzh), INTENT(IN) :: prs
    ! Output variable
    ! equivalent potential temperature [K]
    REAL(KIND=8), DIMENSION(miy,mjx,mkzh), INTENT(OUT) :: eth

!NCLEND

    ! local variables
    REAL(KIND=8) :: q
    REAL(KIND=8) :: t
    REAL(KIND=8) :: p
    REAL(KIND=8) :: e
    REAL(KIND=8) :: tlcl
    INTEGER :: i, j, k

    !$OMP PARALLEL DO COLLAPSE(3) PRIVATE(i, j, k, q, t, p, e, tlcl) &
    !$OMP SCHEDULE(runtime)
    DO k = 1,mkzh
        DO j = 1,mjx
            DO i = 1,miy
                q = MAX(qvp(i,j,k), 1.D-15)
                t = tmk(i,j,k)
                p = prs(i,j,k)/100.
                e = q*p/(EPS + q)
                tlcl = TLCLC1/(LOG(t**TLCLC2/e) - TLCLC3) + TLCLC4
                eth(i,j,k) = tmk(i,j,k)*(1000.D0/p)**(GAMMA*(1.D0 + GAMMAMD*q))* &
                        EXP((THTECON1/tlcl - THTECON2)*q*(1.D0 + THTECON3*q))
            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE DEQTHECALC


      FUNCTION BESSK1(X)
      REAL*8 Y,P1,P2,P3,P4,P5,P6,P7,
     *    Q1,Q2,Q3,Q4,Q5,Q6,Q7
      DATA P1,P2,P3,P4,P5,P6,P7/1.0D0,0.15443144D0,-0.67278579D0,
     *    -0.18156897D0,-0.1919402D-1,-0.110404D-2,-0.4686D-4/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7/1.25331414D0,0.23498619D0,-0.3655620D-1,
     *    0.1504268D-1,-0.780353D-2,0.325614D-2,-0.68245D-3/
      IF (X.LE.2.0) THEN
        Y=X*X/4.0
        BESSK1=(LOG(X/2.0)*BESSI1(X))+(1.0/X)*(P1+Y*(P2+
     *      Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
      ELSE
        Y=2.0/X
        BESSK1=(EXP(-X)/SQRT(X))*(Q1+Y*(Q2+Y*(Q3+
     *      Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
      ENDIF
      RETURN
      END


c from SHOOTGRO
c  *********************************************************************
c  *                                                                   *
c  *               F U N C T I O N       D A Y L T H                   *
c  *                                                     dmh   1/22/93 *
c  *********************************************************************
c  This function uses latitude and day of year to calculate
c  day length (in hours) using code extracted from the WGEN model
c  (Richardson, C.W. andD.A. Wright.  1984.  WGEN: A model for generating
c  daily weather variables. USDA-ARS, ARS-8. 83 pp.).  Day length on
c  consecutive days is used to calculate the change in day length, which
c  subroutine PHYLLO uses to calculate the phyllochron for each seedling
c  cohort.

c  INPUTS:  lat(R)
c           dummy argument--stday(R)

c  OUTPUTS: function value--DAYLTH(C)

c      include 'shtgro.inc'

      subroutine daylenth(daylth, daynum, latitude)

      implicit none

      integer daynum, stday
      real ch, daylth, halfdy, latitude, latrad, sd

      stday = daynum

c  Change latitude in degrees (LAT) to radians (LATRAD).

      latrad = latitude * 6.2832 / 360.

c  Calculate SD, the angle (in radians) of declination of the sun
c  the angular distance of the sun north(+) or south(-) of the equator
c  on the day of year.  STDAY is the julian date (day of year).

      sd = 0.4102 * SIN(0.0172 * (REAL(stday) - 80.25))

c  Calculate cos h (=CH) of the half-day length in radians.

      ch = -TAN(latrad) * TAN(sd)
      if(ch.gt.1.0) ch = 1.0
      if(ch.lt.-1.0) ch = -1.0

c  Calculate half-day length in radians.

      halfdy = ACOS(ch)

c  Calculate day length in hours.

      daylth = halfdy * 7.6394

      return
      end


      FUNCTION bessi1(x)
      REAL bessi1,x
      REAL ax
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
      DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
     *0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
      DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
     *-0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,-0.2895312d-1,
     *0.1787654d-1,-0.420059d-2/
      if (abs(x).lt.3.75) then
        y=(x/3.75)**2
        bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
      else
        ax=abs(x)
        y=3.75/ax
        bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
     *(q7+y*(q8+y*q9))))))))
        if(x.lt.0.)bessi1=-bessi1
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bessi1.for


module chinese_remainder_theorem
  use, intrinsic :: iso_fortran_env
  use internal
  implicit none
  integer, private, parameter :: intkind = int64
contains
  function crt(remainders, moduli) result(res)
    integer(intkind), intent(in) :: remainders(:), moduli(:)
    integer(intkind) :: res(2), r0, m0, r1, m1, g, im, tmp(2), u, x
    integer(int32) :: i
    res = 0
    r0 = 0
    m0 = 1
    do i = 1, size(remainders)
      r1 = modulo(remainders(i), moduli(i))
      m1 = moduli(i)
      if (m0 < m1) then
        call swap(r0, r1)
        call swap(m0, m1)
      end if
      if (mod(m0, m1) == 0) then
        if (mod(r0, m1) /= r1) return
        cycle
      end if
      tmp = inv_gcd(m0, m1)
      g = tmp(1)
      im = tmp(2)
      u = m1 / g
      if (mod(r1 - r0, g) /= 0) return
      x = mod(mod((r1 - r0) / g, u) * im, u)
      r0 = r0 + x * m0
      m0 = m0 * u
      if (r0 < 0) r0 = r0 + m0
    end do
    res = (/r0, m0/)
  end
end module chinese_remainder_theorem


module setup_mod

    use config_mod

contains

subroutine setup_init(mesh)

    use mesh_mod, only: mesh_t
    use mesh_mod, only: mesh_iterate_cells

    type(mesh_t), intent(inout) :: mesh

    call mesh_iterate_cells(mesh,setup_init_cb)

end subroutine

subroutine setup_init_cb(cell)

    use equations_mod
    use mesh_mod, only: cell_t
    use mesh_mod, only: cell_get_coords

    type(cell_t), intent(inout) :: cell

    real(dp) :: dens(N_NODES,N_NODES)
    real(dp) :: velx(N_NODES,N_NODES)
    real(dp) :: vely(N_NODES,N_NODES)
    real(dp) :: pres(N_NODES,N_NODES)

    real(dp) :: momx(N_NODES,N_NODES)
    real(dp) :: momy(N_NODES,N_NODES)
    real(dp) :: ener(N_NODES,N_NODES)

    real(dp) :: coords(N_NODES,N_NODES,N_DIMS)

    coords = cell_get_coords(cell)

    dens = dens0
    velx = velx0
    vely = vely0
    pres = pres0

    momx = dens * velx
    momy = dens * vely
    ener = pres/(kappa-1) + 0.5*dens*(velx**2 + vely**2)

    ener = ener + blast_ener/(2*pi*blast_sigm**2) * exp(-0.5*(coords(:,:,1)**2 + coords(:,:,2)**2)/blast_sigm**2)

    cell%state(:,:,DENS_VAR) = dens
    cell%state(:,:,MOMX_VAR) = momx
    cell%state(:,:,MOMY_VAR) = momy
    cell%state(:,:,ENER_VAR) = ener

end subroutine

end module


module KEPLER
! Description:
!    Root-finding procedures for the Kepler equation.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    davideamato@email.arizona.edu
!
! ==============================================================================

use KINDS, only: dk
implicit none

contains

function KESOLVE(ecc,M,tol)
! Solves the Kepler equation to the desired tolerance using the regula falsi
! method.

! VARIABLES
implicit none
! Arguments
real(dk),intent(in)   ::  ecc,M,tol
!logical,intent(out),optional   ::  flag
! Function def
real(dk)  ::  KESOLVE

! Locals
real(dk)  ::  zero
real(dk)  ::  sinM
real(dk)  ::  K0,K1,M1
integer   ::  it
real(dk)  ::  Enext,Knext,Ecurr,Kcurr,Eprev,Kprev

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

!if (present(flag)) flag = .false.

zero = epsilon(0._dk)
sinM = sin(M)
if (abs(sinM) <= zero .or. ecc <= zero) then
    KESOLVE = M
    return
end if

! Plant seeds for the regula falsi
K0 = KEPEQ(ecc,M,M)
M1 = M + sinM/abs(sinM)*ecc
K1 = KEPEQ(ecc,M1,M)

Kprev = K0; Eprev = M
Kcurr = K1; Ecurr = M1

it = 0
do

    Enext = (Ecurr*Kprev - Eprev*Kcurr)/(Kprev - Kcurr)
    Knext = KEPEQ(ecc,Enext,M)

    ! Update Kprev, Eprev if the sign changed
    if (Knext*Kprev > 0._dk) then
        Eprev = Ecurr
        Kprev = Kcurr
    end if

    Ecurr = Enext; Kcurr = Knext

    it = it + 1

    if (abs(Kcurr) <= tol) then
        KESOLVE = Ecurr
        return
    end if

    if (it > 100) then
        KESOLVE = Ecurr
        write(*,*) 'KESOLVE did not converge.'
        write(*,*) 'Kcurr = ',Kcurr
!       if (present(flag)) flag = .true.
        return
    end if

end do

end function KESOLVE

function KEPEQ(ecc,E,M)

! VARIABLES
implicit none
real(dk),intent(in)  ::  ecc,E,M
real(dk)             ::  KEPEQ

KEPEQ = E - ecc*sin(E) - M

end function KEPEQ

end module KEPLER


    Program dgesdd_example

!     DGESDD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: ddisna, dgesdd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, serrbd
      Integer :: i, ifail, info, lda, ldu, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), rcondu(:), rcondv(:), s(:), &
        u(:, :), uerrbd(:), verrbd(:), work(:)
      Real (Kind=dp) :: dummy(1, 1)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, min, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGESDD Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldu = m
      Allocate (a(lda,n), rcondu(m), rcondv(m), s(m), u(ldu,m), uerrbd(m), &
        verrbd(m), iwork(8*min(m,n)))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dgesdd('Overwrite A by tranpose(V)', m, n, a, lda, s, u, ldu, &
        dummy, 1, dummy, lwork, iwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((5*m+9)*m+n+nb*(m+n), nint(dummy(1,1)))
      Allocate (work(lwork))

!     Read the m by n matrix A from data file

      Read (nin, *)(a(i,1:n), i=1, m)

!     Compute the singular values and left and right singular vectors
!     of A (A = U*S*(V**T), m.le.n)

      Call dgesdd('Overwrite A by tranpose(V)', m, n, a, lda, s, u, ldu, &
        dummy, 1, work, lwork, iwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Singular values'
        Write (nout, 100) s(1:m)
        Flush (nout)

!       Normalize so that u(1,j)>=0
        Do i = 1, m
          If (u(1,i)<0.0_dp) Then
            u(1:m, i) = -u(1:m, i)
            a(i, 1:n) = -a(i, 1:n)
          End If
        End Do
!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', m, m, u, ldu, &
          'Left singular vectors', ifail)

        Write (nout, *)
        Flush (nout)

        Call nagf_file_print_matrix_real_gen('General', ' ', m, n, a, lda, &
          'Right singular vectors by row '//'(first m rows of V**T)', ifail)

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed singular values.  Note that for
!       the 2-norm, S(1) = norm(A)

        eps = epsilon(1.0E0_dp)
        serrbd = eps*s(1)

!       Call DDISNA to estimate reciprocal condition
!       numbers for the singular vectors

        Call ddisna('Left', m, n, s, rcondu, info)
        Call ddisna('Right', m, n, s, rcondv, info)

!       Compute the error estimates for the singular vectors

        Do i = 1, m
          uerrbd(i) = serrbd/rcondu(i)
          verrbd(i) = serrbd/rcondv(i)
        End Do

!       Print the approximate error bounds for the singular values
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Error estimate for the singular values'
        Write (nout, 110) serrbd
        Write (nout, *)
        Write (nout, *) 'Error estimates for the left singular vectors'
        Write (nout, 110) uerrbd(1:m)
        Write (nout, *)
        Write (nout, *) 'Error estimates for the right singular vectors'
        Write (nout, 110) verrbd(1:m)
      Else
        Write (nout, 120) 'Failure in DGESDD. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4)
    End Program


      SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factor of a banded symmetric positive
C     definite (s.p.d.) block Toeplitz matrix, defined by either its
C     first block row, or its first block column, depending on the
C     routine parameter TYPET.
C
C     By subsequent calls of this routine the Cholesky factor can be
C     computed block column by block column.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  T contains the first block row of an s.p.d. block
C                     Toeplitz matrix; the Cholesky factor is upper
C                     triangular;
C             = 'C':  T contains the first block column of an s.p.d.
C                     block Toeplitz matrix; the Cholesky factor is
C                     lower triangular. This choice results in a column
C                     oriented algorithm which is usually faster.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     TRIU    CHARACTER*1
C             Specifies the structure of the last block in T, as
C             follows:
C             = 'N':  the last block has no special structure;
C             = 'T':  the last block is lower / upper triangular.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 1.
C             If TRIU = 'N',   N >= 1;
C             if TRIU = 'T',   N >= 2.
C
C     NL      (input)  INTEGER
C             The lower block bandwidth, i.e., NL + 1 is the number of
C             nonzero blocks in the first block column of the block
C             Toeplitz matrix.
C             If TRIU = 'N',   0 <= NL < N;
C             if TRIU = 'T',   1 <= NL < N.
C
C     P       (input)  INTEGER
C             The number of previously computed block rows / columns of
C             the Cholesky factor.  0 <= P <= N.
C
C     S       (input)  INTEGER
C             The number of block rows / columns of the Cholesky factor
C             to compute.  0 <= S <= N - P.
C
C     T       (input/output)  DOUBLE PRECISION array, dimension
C             (LDT,(NL+1)*K) / (LDT,K)
C             On entry, if P = 0, the leading K-by-(NL+1)*K /
C             (NL+1)*K-by-K part of this array must contain the first
C             block row / column of an s.p.d. block Toeplitz matrix.
C             On entry, if P > 0, the leading K-by-(NL+1)*K /
C             (NL+1)*K-by-K part of this array must contain the P-th
C             block row / column of the Cholesky factor.
C             On exit, if INFO = 0, then the leading K-by-(NL+1)*K /
C             (NL+1)*K-by-K part of this array contains the (P+S)-th
C             block row / column of the Cholesky factor.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K) / MAX(1,(NL+1)*K).
C
C     RB      (input/output)  DOUBLE PRECISION array, dimension
C             (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K)
C             On entry, if TYPET = 'R'  and  TRIU = 'N'  and  P > 0,
C             the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array
C             must contain the (P*K+1)-st to ((P+NL)*K)-th columns
C             of the upper Cholesky factor in banded format from a
C             previous call of this routine.
C             On entry, if TYPET = 'R'  and  TRIU = 'T'  and  P > 0,
C             the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array
C             must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns
C             of the upper Cholesky factor in banded format from a
C             previous call of this routine.
C             On exit, if TYPET = 'R'  and  TRIU = 'N', the leading
C             (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the
C             upper Cholesky factor in banded format.
C             On exit, if TYPET = 'R'  and  TRIU = 'T', the leading
C             (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the
C             upper Cholesky factor in banded format.
C             On exit, if TYPET = 'C'  and  TRIU = 'N', the leading
C             (NL+1)*K-by-MIN(S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower
C             Cholesky factor in banded format.
C             On exit, if TYPET = 'C'  and  TRIU = 'T', the leading
C             (NL*K+1)-by-MIN(S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower
C             Cholesky factor in banded format.
C             For further details regarding the band storage scheme see
C             the documentation of the LAPACK routine DPBTF2.
C
C     LDRB    INTEGER
C             The leading dimension of the array RB.
C             If TRIU = 'N',   LDRB >= MAX( (NL+1)*K,1 );
C             if TRIU = 'T',   LDRB >= NL*K+1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -13,  DWORK(1)  returns the minimum
C             value of LDWORK.
C             The first 1 + ( NL + 1 )*K*K elements of DWORK should be
C             preserved during successive calls of the routine.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1 + ( NL + 1 )*K*K + NL*K.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The Toeplitz matrix
C                   associated with T is not (numerically) positive
C                   definite.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                                3
C     The algorithm requires O( K *N*NL ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001,
C     Mar. 2004, Apr. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRIU, TYPET
      INTEGER           INFO, K, LDRB, LDT, LDWORK, N, NL, P, S
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(LDWORK), RB(LDRB,*), T(LDT,*)
C     .. Local Scalars ..
      CHARACTER         STRUCT
      LOGICAL           ISROW, LQUERY, LTRI
      INTEGER           HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB,
     $                  NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN,
     $                  WRKOPT
C     .. Local Arrays ..
      INTEGER           IPVT(1)
      DOUBLE PRECISION  DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      EXTERNAL          ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGELQF, DGEQRF, DLACPY, DLASET, DPOTRF,
     $                  DTRSM, MB02CU, MB02CV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO = 0
      LTRI = LSAME( TRIU, 'T' )
      LENR = ( NL + 1 )*K
      IF ( LTRI ) THEN
         SIZR = NL*K + 1
      ELSE
         SIZR = LENR
      END IF
      ISROW  = LSAME( TYPET, 'R' )
      WRKMIN = 1 + ( LENR + NL )*K
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( (      LTRI .AND. N.LT.2 ) .OR.
     $          ( .NOT.LTRI .AND. N.LT.1 ) ) THEN
         INFO = -4
      ELSE IF ( NL.GE.N .OR. (      LTRI .AND. NL.LT.1 ) .OR.
     $                       ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN
         INFO = -5
      ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN
         INFO = -6
      ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN
         INFO = -7
      ELSE IF ( (      ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR.
     $          ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) )
     $      THEN
         INFO = -9
      ELSE IF ( (      LTRI .AND. LDRB.LT.SIZR ) .OR.
     $          ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) )
     $      THEN
         INFO = -11
      ELSE
         LQUERY = LDWORK.EQ.-1
         PDW = LENR*K + 1
         KK  = PDW + 4*K
         IF ( ISROW ) THEN
            CALL DGEQRF( K, LENR, T, LDT, DWORK, DWORK, -1, INFO )
         ELSE
            CALL DGELQF( LENR, K, T, LDT, DWORK, DWORK, -1, INFO )
         END IF
         WRKOPT = KK + INT( DWORK(1) )
         IF ( LDWORK.LT.WRKMIN .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -13
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02GD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( S*K.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Compute the generator if P = 0.
C
      IF ( P.EQ.0 ) THEN
         IF ( ISROW ) THEN
            CALL DPOTRF( 'Upper', K, T, LDT, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
            IF ( NL.GT.0 )
     $         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K,
     $                     NL*K, ONE, T, LDT, T(1,K+1), LDT )
C
C           Copy the first block row to RB.
C
            IF ( LTRI ) THEN
C
               DO 10  I = 1, LENR - K
                  CALL DCOPY( MIN( I, K ), T(1,I), 1,
     $                        RB( MAX( SIZR-I+1, 1 ),I ), 1 )
   10          CONTINUE
C
               DO 20  I = K, 1, -1
                  CALL DCOPY( I, T(K-I+1,LENR-I+1), 1,
     $                        RB( 1,LENR-I+1 ), 1 )
   20          CONTINUE
C
            ELSE
C
               DO 30  I = 1, LENR
                  CALL DCOPY( MIN( I, K ), T(1,I), 1,
     $                        RB( MAX( SIZR-I+1, 1 ),I ), 1 )
   30          CONTINUE
C
            END IF
C
C           Quick return if N = 1.
C
            IF ( N.EQ.1 ) THEN
               DWORK(1) = ONE
               RETURN
            END IF
C
            CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K )
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K )
            POSR = K + 1
         ELSE
            CALL DPOTRF( 'Lower', K, T, LDT, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
            IF ( NL.GT.0 )
     $         CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit',
     $                     NL*K, K, ONE, T, LDT, T(K+1,1), LDT )
C
C           Copy the first block column to RB.
C
            POSR = 1
            IF ( LTRI ) THEN
C
               DO 40  I = 1, K
                  CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 )
                  POSR = POSR + 1
   40          CONTINUE
C
            ELSE
C
               DO 50  I = 1, K
                  CALL DCOPY(  LENR-I+1, T(I,I), 1, RB(1,POSR), 1 )
                  IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN
                     CALL DLASET( 'All', I-1, 1, ZERO, ZERO,
     $                            RB(LENR-I+2,POSR), LDRB )
                  END IF
                  POSR = POSR + 1
   50          CONTINUE
C
            END IF
C
C           Quick return if N = 1.
C
            IF ( N.EQ.1 ) THEN
               DWORK(1) = ONE
               RETURN
            END IF
C
            CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR )
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR )
         END IF
         PRE  = 1
         STPS = S - 1
      ELSE
         PRE  = P
         STPS = S
         POSR = 1
      END IF
C
      HEAD = MOD( ( PRE - 1 )*K, LENR )
C
C     Determine block size for the involved block Householder
C     transformations.
C
      NB = MIN( INT( ( LDWORK - KK )/LENR ), K )
      IF ( ISROW ) THEN
         NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) )
      ELSE
         NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) )
      END IF
      IF ( NB.LT.NBMIN )  NB = 0
C
C     Generator reduction process.
C
      IF ( ISROW ) THEN
C
         DO 90  I = PRE, PRE + STPS - 1
            CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1,
     $                   DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1),
     $                   ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The positive definiteness is (numerically)
C                             not satisfied.
C
               INFO = 1
               RETURN
            END IF
C
            LEN  = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 )
            LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 )
            IF ( LEN.EQ.( LENR-K ) ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1,
     $                   DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT,
     $                   DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( ( N - I )*K.GE.LENR ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1,
     $                   DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT,
     $                   DUM, 1, DWORK(2), K, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K )
C
C           Copy current block row to RB.
C
            IF ( LTRI ) THEN
C
               DO 60  J = 1, MIN( LEN + LEN2 + K, LENR - K )
                  CALL DCOPY(  MIN( J, K ), T(1,J), 1,
     $                         RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 )
   60          CONTINUE
C
               IF ( LEN+LEN2+K.GE.LENR ) THEN
C
                  DO 70  JJ = K, 1, -1
                     CALL DCOPY(  JJ, T(K-JJ+1,LENR-JJ+1), 1,
     $                            RB(1,POSR+LENR-JJ), 1 )
   70             CONTINUE
C
               END IF
               POSR = POSR + K
C
            ELSE
C
               DO 80  J = 1, LEN + LEN2 + K
                  CALL DCOPY(  MIN( J, K ), T(1,J), 1,
     $                         RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 )
                  IF ( J.GT.LENR-K ) THEN
                     CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO,
     $                            RB(1,POSR+J-1), 1 )
                  END IF
   80          CONTINUE
C
               POSR = POSR + K
            END IF
            HEAD = MOD( HEAD + K, LENR )
   90    CONTINUE
C
      ELSE
C
         DO 120  I = PRE, PRE + STPS - 1
C
            CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1,
     $                   DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1),
     $                   ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The positive definiteness is (numerically)
C                             not satisfied.
C
               INFO = 1
               RETURN
            END IF
C
            LEN  = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 )
            LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 )
            IF ( LEN.EQ.( LENR-K ) ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM,
     $                   1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT,
     $                   DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( ( N - I )*K.GE.LENR ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM,
     $                   1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1),
     $                   LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR )
C
C           Copy current block column to RB.
C
            IF ( LTRI ) THEN
C
               DO 100  J = 1, K
                  CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1,
     $                        RB(1,POSR), 1 )
                  POSR = POSR + 1
  100          CONTINUE
C
            ELSE
C
               DO 110  J = 1, K
                  CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1,
     $                        RB(1,POSR), 1 )
                  IF ( LENR.LT.(N-I)*K ) THEN
                     CALL DLASET( 'All', J-1, 1, ZERO, ZERO,
     $                             RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1,
     $                                POSR), LDRB )
                  END IF
                  POSR = POSR + 1
  110          CONTINUE
C
            END IF
            HEAD = MOD( HEAD + K, LENR )
  120    CONTINUE
C
      END IF
      DWORK(1) = DBLE( WRKOPT )
      RETURN
C
C *** Last line of MB02GD ***
      END


subroutine MakeGravGradGridDH(cilm, lmax, gm, r0, a, f, vxx, vyy, vzz, vxy, &
                              vxz, vyz, n, sampling, lmax_calc, extend, &
                              exitstatus)
!------------------------------------------------------------------------------
!
!   Given the 4pi normalized gravitational spherical harmonic coefficients
!   CILM, this subroutine will compute 2D Driscol and Healy sampled grids of
!   the six components of the gravity "gradient" tensor in a local
!   north-oriented reference frame:
!
!       (Vxx,   Vxy,    Vxz)
!       (Vyx,   Vyy,    Vyz)
!       (Vzx,   Vzy,    Vzz)
!
!   where X points NORTH, Y points WEST, and Z points UPWARD. The gravitational
!   potential is defined as
!
!       V = GM/r Sum_{l=0}^LMAX (R0/r)^l Sum_{m=-l}^l C_{lm} Y_{lm},
!
!   Laplace's equation implies that Vxx + Vyy + Vzz = 0, and the gravity tensor
!   is symmetric. The components are calculated according to eq. 1 in
!   Petrovskaya and Vershkov (2006, J. Geod, 80, 117-127), which is based on
!   eq. 3.28 in Reed (1973, Ohio State Univ., Dept. Geod. Sci., Rep. 201,
!   Columbus, OH). Note that Reed's equations are in terms of latitude, and
!   that the Y axis points East:
!
!       Vzz = Vrr
!       Vxx = 1/r Vr + 1/r^2 Vtt
!       Vyy = 1/r Vr + 1/r^2 /tan(t) Vt + 1/r^2 /sin(t)^2 Vpp
!       Vxy = 1/r^2 /sin(t) Vtp - cos(t)/sin(t)^2 /r^2 Vp
!       Vxz = 1/r^2 Vt - 1/r Vrt
!       Vyz = 1/r^2 /sin(t) Vp - 1/r /sin(t) Vrp
!
!   where r, t, p stand for radius, theta, and phi, and subscripts on V denote
!   partial derivatives.
!
!   The output grid are in units of 1/s and are cacluated on a flattened
!   ellipsoid with semi-major axis A and flattening F. To obtain units of
!   Eotvos (10^-9 s^-1), multiply by 10^9.
!
!   When SAMPLING = 1, the output grids contain N samples in latitude from
!   90 to -90 + interval and N samples in longitude from 0 to 360-2*interval,
!   where N=2*(LMAX+1) and interval=180/N. When SAMPLING = 2, the grids are
!   equally spaced in degrees latitude and longitude with dimension (N x 2N).
!   If the optional parameter EXTEND is set to 1, the output grids will contain
!   an extra column corresponding to 360 E and an extra row corresponding to
!   90 S, which increases each of the dimensions of the grid by one.
!
!   Calling Parameters
!
!       IN
!           cilm        The 4-pi normalized gravitational potential spherical
!                       harmonic coefficients.
!           lmax        The maximum spherical harmonic degree of the function,
!                       used to determine the number of samples N.
!           GM          Product of the gravitatonal constant and the planet's
!                       mass.
!           r0          Reference radius of potential coefficients.
!           a           The semimajor axis of the flattened ellipsoid.
!           f           Flattening of the planet.
!
!       IN, OPTIONAL
!           sampling    (1) Grid is N latitudes by N longitudes (default).
!                       (2) Grid is N by 2N. The higher frequencies resulting
!                       from this oversampling in longitude are discarded, and
!                       hence not aliased into lower frequencies.
!           lmax_calc   The maximum spherical harmonic degree to evaluate
!                       the coefficients up to.
!           extend      If 1, return a grid that contains an additional column
!                       and row corresponding to 360 E longitude and 90 S
!                       latitude, respectively.
!
!       OUT
!           Vxx         x-x component of the gravity gradient tensor.
!           Vyy         y-y component of the gravity gradient tensor.
!           Vzz         z-z component of the gravity gradient tensor.
!           Vxy         x-y component of the gravity gradient tensor.
!           Vxz         x-z component of the gravity gradient tensor.
!           Vyz         y-z component of the gravity gradient tensor.
!           N           Number of samples in latitude. Number of samples in
!                       longitude is N when sampling is 1 (default), and is
!                       2N when sampling is 2.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1.  If lmax is greater than the the maximum spherical harmonic
!           degree of the input coefficients, then the coefficients will be
!           zero padded.
!       2.  Latitude is geocentric latitude.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use FFTW3
    use ftypes
    use, intrinsic :: iso_c_binding

    implicit none

    real(dp), intent(in) :: cilm(:,:,:), gm, r0, a, f
    real(dp), intent(out) :: vxx(:,:), vyy(:,:), vzz(:,:), vxy(:,:), vxz(:,:),&
                             vyz(:,:)
    integer, intent(in) :: lmax
    integer, intent(out) :: n
    integer, intent(in), optional :: sampling, lmax_calc, extend
    integer, intent(out), optional :: exitstatus
    integer :: l, m, i, l1, m1, lmax_comp, i_eq, i_s, astat(4), nlong, &
               nlat_out, nlong_out, extend_grid
    real(dp) :: grid(4*lmax+4), pi, theta, scalef, rescalem, u, p, dpl, dpl2, &
                dpl2s, pmm, sint, pm1, pm2, z, tempr, r_ex, lat, &
                prefactor(lmax), coefr0, coefrs0, coeft0, coefts0, coefp0, &
                coefps0, coefrr0, coefrrs0, coefrt0, coefrts0, coefrp0, &
                coefrps0, coeftp0, coeftps0, coefpp0, coefpps0, coeftt0, &
                coeftts0
    complex(dp) :: coef(2*lmax+3), coefr(2*lmax+3), coefrs(2*lmax+3), &
                   coeft(2*lmax+3), coefts(2*lmax+3), coefp(2*lmax+3), &
                   coefps(2*lmax+3), tempc, coefrr(2*lmax+3), &
                   coefrrs(2*lmax+3), coefrt(2*lmax+3), coefrts(2*lmax+3), &
                   coefrp(2*lmax+3), coefrps(2*lmax+3), coeftp(2*lmax+3), &
                   coeftps(2*lmax+3), coefpp(2*lmax+3), coefpps(2*lmax+3), &
                   coeftt(2*lmax+3), coeftts(2*lmax+3)
    type(C_PTR) :: plan
    real(dp), save, allocatable :: ff1(:,:), ff2(:,:), sqr(:)
    integer(int1), save, allocatable :: fsymsign(:,:)
    integer, save :: lmax_old = 0

!$OMP   threadprivate(ff1, ff2, sqr, fsymsign, lmax_old)

    if (present(exitstatus)) exitstatus = 0

    n = 2 * lmax + 2

    if (present(sampling)) then
        if (sampling == 1) then
            nlong = n
        else if (sampling == 2) then
            nlong = 2 * n
        else
            print*, "Error --- MakeGravGradGridDH"
            print*, "Optional parameter SAMPLING must be 1 (N by N) " // &
                    "or 2 (N by 2N)."
            print*, "Input value is ", sampling
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if
    else
        nlong = n
    end if

    if (present(extend)) then
        if (extend == 0) then
            extend_grid = 0
            nlat_out = n
            nlong_out = nlong
        else if (extend == 1) then
            extend_grid = 1
            nlat_out = n + 1
            nlong_out = nlong + 1
        else
            print*, "Error --- MakeGravGradGridDH"
            print*, "Optional parameter EXTEND must be 0 or 1."
            print*, "Input value is ", extend
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if
    else
        extend_grid = 0
        nlat_out = n
        nlong_out = nlong
    end if

    if (size(cilm(:,1,1)) < 2) then
        print*, "Error --- MakeGravGradGridDH"
        print*, "CILM must be dimensioned as (2, *, *)."
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (size(vxx(:,1)) < nlat_out .or. size(vxx(1,:)) < nlong_out .or. &
            size(vyy(:,1)) < nlat_out .or. size(vyy(1,:)) < nlong_out .or. &
            size(vzz(:,1)) < nlat_out .or. size(vzz(1,:)) < nlong_out .or. &
            size(vxy(:,1)) < nlat_out .or. size(vxy(1,:)) < nlong_out .or. &
            size(vxz(:,1)) < nlat_out .or. size(vxz(1,:)) < nlong_out .or. &
            size(vyz(:,1)) < nlat_out .or. size(vyz(1,:)) < nlong_out) then
        print*, "Error --- MakeGravGradGridDH"
        print*, "VXX, VYY, VZZ, VXY, VXZ, and VYZ must be dimensioned " // &
                "as: ", nlat_out, nlong_out
        print*, "Input dimensions are ", size(vxx(:,1)), size(vxx(1,:)), &
            size(vyy(:,1)), size(vyy(1,:)), size(vzz(:,1)), size(vzz(1,:)), &
            size(vxy(:,1)), size(vxy(1,:)), size(vxz(:,1)), size(vxz(1,:)), &
            size(vyz(:,1)), size(vyz(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (cilm(1,1,1) /= 1.0_dp .and. f /= 0.0_dp) then
        print*, "Warning --- MakeGravGradGridDH"
        print*, "The degree-0 term of the spherical harmonic coefficients is "
        print*, "not equal to 1. The variation in gravity resulting from "
        print*, "variations in radius of the flattened ellipsoid will not be "
        print*, "taken into account."
        print*, "C00 = ", cilm(1,1,1)
        print*, "F = ", f
    end if

    pi = acos(-1.0_dp)

    scalef = 1.0e-280_dp

    if (present(lmax_calc)) then
        if (lmax_calc > lmax) then
            print*, "Error --- MakeGravGradGridDH"
            print*, "LMAX_CALC must be less than or equal to LMAX."
            print*, "LMAX = ", lmax
            print*, "LMAX_CALC = ", lmax_calc
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1, &
                            lmax_calc)

        end if

    else
        lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1)

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate recursion constants used in computing Legendre functions.
    !
    !--------------------------------------------------------------------------
    if (lmax_comp /= lmax_old) then

        if (allocated (sqr)) deallocate (sqr)
        if (allocated (ff1)) deallocate (ff1)
        if (allocated (ff2)) deallocate (ff2)
        if (allocated (fsymsign)) deallocate (fsymsign)

        allocate (sqr(2 * lmax_comp + 1), stat=astat(1))
        allocate (ff1(lmax_comp+1,lmax_comp+1), stat=astat(2))
        allocate (ff2(lmax_comp+1,lmax_comp+1), stat=astat(3))
        allocate (fsymsign(lmax_comp+1,lmax_comp+1), stat=astat(4))

        if (sum(astat(1:4)) /= 0) then
            print*, "Error --- MakeGravGradGridDH"
            print*, "Problem allocating arrays SQR, FF1, FF2, or FSYMSIGN", &
                    astat(1), astat(2), astat(3), astat(4)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

        end if

        !----------------------------------------------------------------------
        !
        !   Calculate signs used for symmetry of Legendre functions about
        !   equator. For the first derivative in theta, these signs are
        !   reversed.
        !
        !----------------------------------------------------------------------
        do l = 0, lmax_comp, 1
            do m = 0, l, 1
                if (mod(l-m,2) == 0) then
                    fsymsign(l+1,m+1) = 1

                else
                    fsymsign(l+1,m+1) = -1

                end if

            end do

        end do

        !----------------------------------------------------------------------
        !
        !   Precompute square roots of integers that are used several times.
        !
        !----------------------------------------------------------------------
        do l=1, 2*lmax_comp+1
            sqr(l) = sqrt(dble(l))
        end do

        !----------------------------------------------------------------------
        !
        !   Precompute multiplicative factors used in recursion relationships
        !       P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
        !       k = l*(l+1)/2 + m + 1
        !   Note that prefactors are not used for the case when m=l as a
        !   different recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m)
        !   is assumed to be zero.
        !
        !----------------------------------------------------------------------
        if (lmax_comp /= 0) then
            ff1(2,1) = sqr(3)
            ff2(2,1) = 0.0_dp

        end if

        do l = 2, lmax_comp, 1
            ff1(l+1,1) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
            ff2(l+1,1) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)

            do m = 1, l-2, 1
                ff1(l+1,m+1) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                ff2(l+1,m+1) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                               / sqr(2*l-3) / sqr(l+m) / sqr(l-m)
            end do

            ff1(l+1,l) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
            ff2(l+1,l) = 0.0_dp

        end do

        lmax_old = lmax_comp

    end if

    !--------------------------------------------------------------------------
    !
    !   Create generic plan for grid.
    !
    !--------------------------------------------------------------------------
    plan = fftw_plan_dft_c2r_1d(nlong, coef(1:nlong/2+1), grid(1:nlong), &
                                FFTW_MEASURE)

    !--------------------------------------------------------------------------
    !
    !   Determine Clms one l at a time by intergrating over latitude.
    !
    !--------------------------------------------------------------------------
    i_eq = n / 2 + 1  ! Index correspondong to zero latitude

    ! First do equator

    r_ex = a
    theta = pi / 2.0_dp
    z = 0.0_dp
    u = 1.0_dp
    lat = 0.0_dp

    coefr(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefr0 = 0.0_dp

    coefrr(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefrr0 = 0.0_dp

    coeft(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coeft0 = 0.0_dp

    coeftp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coeftp0 = 0.0_dp

    coefp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefp0 = 0.0_dp

    coefrt(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefrt0 = 0.0_dp

    coefrp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefrp0 = 0.0_dp

    coefpp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefpp0 = 0.0_dp

    coeftt(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coeftt0 = 0.0_dp

    pm2 = 1.0_dp

    tempr = -cilm(1,1,1) * pm2 ! l = 0
    coefr0 = coefr0 + tempr

    tempr = 2 * cilm(1,1,1) * pm2  ! l = 0
    coefrr0 = coefrr0 + tempr

    ! derivative in theta and phi of l=0 term is 0. No need to calculate this

    if (lmax_comp /= 0) then    ! l = 1
        prefactor(1) = r0 / r_ex

        do l = 2, lmax_comp, 1
            prefactor(l) = prefactor(l-1) * r0 / r_ex
        end do

        pm1 = 0.0_dp

        dpl = ff1(2,1)
        tempr = cilm(1,2,1) * dpl * prefactor(1)
        coeft0 = coeft0 + tempr

        tempr = cilm(1,2,1) * dpl * (-2) * prefactor(1)  ! -2 = (l+1) prefactor
        coefrt0 = coefrt0 + tempr

    end if

    do l = 2, lmax_comp, 1
        l1 = l + 1
        p = - ff2(l1,1) * pm2
        tempr = cilm(1,l1,1) * p * (-l1) * prefactor(l)
        coefr0 = coefr0 + tempr

        tempr = cilm(1,l1,1) * p * (l1) * (l1+1) * prefactor(l)
        coefrr0 = coefrr0 + tempr

        dpl = l * ( sqr(2*l+1) / sqr(2*l-1) * pm1 )
        tempr = cilm(1,l1,1) * dpl * prefactor(l)
        coeft0 = coeft0 + tempr

        tempr = cilm(1,l1,1) * dpl * (-l1) * prefactor(l)
        coefrt0 = coefrt0 + tempr

        dpl2 = -l*l1 * p
        tempr = cilm(1,l1,1) * dpl2 * prefactor(l)
        coeftt0 = coeftt0 + tempr

        pm2 = pm1
        pm1 = p

    end do

    pmm = sqr(2) * scalef

    rescalem = 1.0_dp / scalef

    do m = 1, lmax_comp-1, 1

        m1 = m + 1

        pmm = pmm * sqr(2*m+1) / sqr(2*m)
        pm2 = pmm

        tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * pm2 * (-m-1) &
                * prefactor(m)    ! (m,m)
        coefr(m1) = coefr(m1) + tempc

        tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * pm2 * (m+1) &
                * (m+2) * prefactor(m) ! (m,m)
        coefrr(m1) = coefrr(m1) + tempc

        tempc = cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) * pm2 &
                * prefactor(m) * m ! (m,m)
        coefp(m1) = coefp(m1) + tempc

        tempc = - cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * pm2 &
                * prefactor(m) * m**2 ! (m,m)
        coefpp(m1) = coefpp(m1) + tempc

        tempc = cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) * pm2 *(-m-1) &
                * prefactor(m) * m ! (m,m)
        coefrp(m1) = coefrp(m1) + tempc

        dpl2 = -(m*m1 -(m**2)) * pm2
        tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * dpl2 &
                * prefactor(m) ! (m,m)
        coeftt(m1) = coeftt(m1) + tempc

        pm1 = 0.0_dp

        dpl = sqr(2*m+3) * pmm
        tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * dpl &
                * prefactor(m+1)    ! (m+1,m)
        coeft(m1) = coeft(m1) + tempc

        tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * dpl * (-m-2) &
                * prefactor(m+1)   ! (m+1,m)
        coefrt(m1) = coefrt(m1) + tempc

        tempc = cmplx(cilm(2,m1+1,m1), cilm(1,m1+1,m1), dp) * dpl &
                * prefactor(m+1) * m  ! (m+1,m)
        coeftp(m1) = coeftp(m1) + tempc

        do l = m + 2, lmax_comp, 1
            l1 = l + 1
            p = - ff2(l1,m1) * pm2
            tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * p * (-l1) &
                    * prefactor(l)
            coefr(m1) = coefr(m1) + tempc

            tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * p * (l1) &
                    * (l1+1) * prefactor(l)
            coefrr(m1) = coefrr(m1) + tempc

            tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * p &
                    * prefactor(l) * m
            coefp(m1) = coefp(m1) + tempc

            tempc = - cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * p &
                    * prefactor(l) * m**2
            coefpp(m1) = coefpp(m1) + tempc

            tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * p * (-l1) &
                    * prefactor(l) * m
            coefrp(m1) = coefrp(m1) + tempc

            dpl = sqr(2*l+1) * sqr(l-m) * sqr(l+m) / sqr(2*l-1) * pm1
            tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * dpl &
                    * prefactor(l)
            coeft(m1) = coeft(m1) + tempc

            tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * dpl * (-l1) &
                    * prefactor(l)
            coefrt(m1) = coefrt(m1) + tempc

            tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * dpl * &
                    prefactor(l) * m
            coeftp(m1) = coeftp(m1) + tempc

            dpl2 = - (l * l1 -(m**2) / u**2) * p
            tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * dpl2 &
                    * prefactor(l)
            coeftt(m1) = coeftt(m1) + tempc

            pm2 = pm1
            pm1 = p

        end do

        coefr(m1) = coefr(m1) * rescalem
        coefrr(m1) = coefrr(m1) * rescalem
        coeft(m1) = coeft(m1) * rescalem
        coeftt(m1) = coeftt(m1) * rescalem
        coefrt(m1) = coefrt(m1) * rescalem
        coefp(m1) = coefp(m1) * rescalem
        coefpp(m1) = coefpp(m1) * rescalem
        coeftp(m1) = coeftp(m1) * rescalem
        coefrp(m1) = coefrp(m1) * rescalem

    end do

    if (lmax_comp /= 0) then

        pmm = pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
        tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                        - cilm(2,lmax_comp+1,lmax_comp+1), dp) * pmm &
                        * (-lmax_comp-1) * prefactor(lmax_comp)
        coefr(lmax_comp+1) = coefr(lmax_comp+1) + tempc

        tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                        - cilm(2,lmax_comp+1,lmax_comp+1), dp) * pmm &
                        * (lmax_comp+1) * (lmax_comp+2) * prefactor(lmax_comp)
        coefrr(lmax_comp+1) = coefrr(lmax_comp+1) + tempc

        tempc = cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                        cilm(1,lmax_comp+1,lmax_comp+1), dp) * pmm &
                        * prefactor(lmax_comp) * lmax_comp
        coefp(lmax_comp+1) = coefp(lmax_comp+1) + tempc

        tempc = - cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                        - cilm(2,lmax_comp+1,lmax_comp+1), dp) * pmm &
                        * prefactor(lmax_comp) * lmax_comp**2
        coefpp(lmax_comp+1) = coefpp(lmax_comp+1) + tempc

        tempc = cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                        cilm(1,lmax_comp+1,lmax_comp+1), dp) * pmm &
                        * (-lmax_comp-1) * prefactor(lmax_comp) * lmax_comp
        coefrp(lmax_comp+1) = coefrp(lmax_comp+1) + tempc

        dpl2 = -(lmax_comp*(lmax_comp+1)-(lmax_comp**2)) * pmm
        tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                        - cilm(2,lmax_comp+1,lmax_comp+1), dp) * dpl2 &
                        * prefactor(lmax_comp)
        coeftt(lmax_comp+1) = coeftt(lmax_comp+1) + tempc

    end if

    coefr0 = coefr0 * gm / r_ex**2
    coefr(2:lmax+1) = coefr(2:lmax+1) * gm / r_ex**2

    coefrt0 = - coefrt0 * gm / r_ex**2
    coefrt(2:lmax+1) = - coefrt(2:lmax+1) * gm / r_ex**2

    coefrr0 = coefrr0 * gm / r_ex**3
    coefrr(2:lmax+1) = coefrr(2:lmax+1) * gm / r_ex**3

    coeft0 = - coeft0 * gm / r_ex
    coeft(2:lmax+1) = - coeft(2:lmax+1) * gm / r_ex

    coeftt0 = coeftt0 * gm / r_ex
    coeftt(2:lmax+1) = coeftt(2:lmax+1) * gm / r_ex

    coeftp0 = - coeftp0 * gm / r_ex
    coeftp(2:lmax+1) = - coeftp(2:lmax+1) * gm / r_ex

    coefp0 = coefp0 * gm / r_ex
    coefp(2:lmax+1) = coefp(2:lmax+1) * gm / r_ex

    coefpp0 = coefpp0 * gm / r_ex
    coefpp(2:lmax+1) = coefpp(2:lmax+1) * gm / r_ex

    coefrp0 = coefrp0 * gm / r_ex**2
    coefrp(2:lmax+1) = coefrp(2:lmax+1) * gm / r_ex**2

    ! Vzz = Vrr
    coef(1) = cmplx(coefrr0, 0.0_dp, dp)
    coef(2:lmax+1) = coefrr(2:lmax+1) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    vzz(i_eq,1:nlong) = grid(1:nlong)

    ! Vxx = 1/r Vr + 1/r^2 Vtt
    coef(1) = cmplx(coefr0/r_ex + coeftt0/r_ex**2, 0.0_dp, dp)
    coef(2:lmax+1) = (coefr(2:lmax+1)/r_ex + coeftt(2:lmax+1)/r_ex**2 ) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    vxx(i_eq,1:nlong) = grid(1:nlong)

    ! Vyy = 1/r Vr + 1/r^2 /tan(t) Vt + 1/r^2 /sin(t)^2 Vpp
    coef(1) = cmplx(coefr0/r_ex + coefpp0/(r_ex**2), 0.0_dp, dp)
    coef(2:lmax+1) = (coefr(2:lmax+1)/r_ex &
                     + coefpp(2:lmax+1)/(r_ex**2) ) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    vyy(i_eq,1:nlong) = grid(1:nlong)

    ! Vxy = 1/r^2 /sin(t) Vtp - cos(t)/sin(t)^2 /r^2 Vp
    coef(1) = cmplx(coeftp0/r_ex**2, 0.0_dp, dp)
    coef(2:lmax+1) = (coeftp(2:lmax+1)/r_ex**2 ) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    vxy(i_eq,1:nlong) = grid(1:nlong)

    ! Vxz = 1/r^2 Vt - 1/r Vrt
    coef(1) = cmplx(coeft0/r_ex**2 - coefrt0/r_ex, 0.0_dp, dp)
    coef(2:lmax+1) = (coeft(2:lmax+1) / r_ex**2 &
                    - coefrt(2:lmax+1)/r_ex ) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    vxz(i_eq,1:nlong) = grid(1:nlong)

    ! Vyz = 1/r^2 /sin(t) Vp - 1/r /sin(t) Vrp
    coef(1) = cmplx(coefp0/r_ex**2 - coefrp0/r_ex, 0.0_dp, dp)
    coef(2:lmax+1) = (coefp(2:lmax+1) / r_ex**2 &
                    - coefrp(2:lmax+1)/r_ex ) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    vyz(i_eq,1:nlong) = grid(1:nlong)

    do i = 1, i_eq - 1, 1

        i_s = 2 * i_eq - i

        theta = pi * dble(i-1) / dble(n)
        z = cos(theta)
        u = sqrt( (1.0_dp-z) * (1.0_dp+z) )
        sint = sin(theta)
        lat = pi / 2.0_dp - theta

        if (i == 1) then      ! Reference ellipsoid radius
            r_ex = a * (1.0_dp - f)

        else
            r_ex = (1.0_dp + tan(lat)**2) / &
                   (1.0_dp  + tan(lat)**2 / (1.0_dp - f)**2 )
            r_ex = a * sqrt(r_ex)

        end if

        coefr(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefr0 = 0.0_dp
        coefrs(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrs0 = 0.0_dp

        coefrr(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrr0 = 0.0_dp
        coefrrs(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrrs0 = 0.0_dp

        coeft(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coeft0 = 0.0_dp
        coefts(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefts0 = 0.0_dp

        coeftp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coeftp0 = 0.0_dp
        coeftps(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coeftps0 = 0.0_dp

        coefp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefp0 = 0.0_dp
        coefps(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefps0 = 0.0_dp

        coefrt(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrt0 = 0.0_dp
        coefrts(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrts0 = 0.0_dp

        coefrp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrp0 = 0.0_dp
        coefrps(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefrps0 = 0.0_dp

        coefpp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefpp0 = 0.0_dp
        coefpps(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefpps0 = 0.0_dp

        coeftt(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coeftt0 = 0.0_dp
        coeftts(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coeftts0 = 0.0_dp

        pm2 = 1.0_dp

        tempr = -cilm(1,1,1) * pm2 ! l = 0
        coefr0 = coefr0 + tempr
        coefrs0 = coefrs0 + tempr   ! fsymsign is always 1 for l=m=0

        tempr = 2 * cilm(1,1,1) * pm2  ! l = 0
        coefrr0 = coefrr0 + tempr
        coefrrs0 = coefrrs0 + tempr

        ! derivative in theta and phi of l=0 term is 0, so no need to
        ! calculate this

        if (lmax_comp /= 0) then    ! l = 1
            prefactor(1) = r0 / r_ex

            do l = 2, lmax_comp, 1
                prefactor(l) = prefactor(l-1) * r0 / r_ex
            end do

            pm1 = ff1(2,1) * z

            ! -2 = (l+1) prefactor
            tempr = cilm(1,2,1) * pm1 * (-2) * prefactor(1)
            coefr0 = coefr0 + tempr
            coefrs0 = coefrs0 - tempr   ! fsymsign = -1

            ! 6 = (l+1)*(l+2) prefactor
            tempr = cilm(1,2,1) * pm1 * (6) * prefactor(1)
            coefrr0 = coefrr0 + tempr
            coefrrs0 = coefrrs0 - tempr     ! fsymsign = -1

            ! dpl is the first derivative with respect to Z
            dpl = ff1(2,1)
            tempr = cilm(1,2,1) * dpl * prefactor(1)
            coeft0 = coeft0 + tempr
            coefts0 = coefts0 + tempr   ! reverse fsymsign

            ! -2 = (l+1) prefactor
            tempr = cilm(1,2,1) * dpl * (-2) * prefactor(1)
            coefrt0 = coefrt0 + tempr
            coefrts0 = coefrts0 + tempr     ! reverse fsymsign

            ! dpl2 is the second derivative with respect to THETA. Must
            ! multiply dpl by -sin(theta) in the recurrence relation
            ! note that the first term is symmetric about the equator according
            ! the fsymsign, whereas the second term differs
            ! by -1.
            dpl2 = -2 * pm1 + z * dpl
            dpl2s = 2 * pm1 + z * dpl
            tempr = cilm(1,2,1) * prefactor(1)
            coeftt0 = coeftt0 + tempr * dpl2
            coeftts0 = coeftts0 + tempr * dpl2s

        end if

        do l = 2, lmax_comp, 1
            l1 = l + 1
            p = ff1(l1,1) * z * pm1 - ff2(l1,1) * pm2
            tempr = cilm(1,l1,1) * p * (-l1) * prefactor(l)
            coefr0 = coefr0 + tempr
            coefrs0 = coefrs0 + tempr * fsymsign(l1,1)

            tempr = cilm(1,l1,1) * p * (l1) * (l1+1) * prefactor(l)
            coefrr0 = coefrr0 + tempr
            coefrrs0 = coefrrs0 + tempr * fsymsign(l1,1)

            dpl = l * ( sqr(2*l+1) / sqr(2*l-1) * pm1 - z * p ) / u**2
            tempr = cilm(1,l1,1) * dpl * prefactor(l)
            coeft0 = coeft0 + tempr
            coefts0 = coefts0 - tempr * fsymsign(l1,1)  ! reverse fsymsign

            tempr = cilm(1,l1,1) * dpl * (-l1) * prefactor(l)
            coefrt0 = coefrt0 + tempr
            coefrts0 = coefrts0 - tempr * fsymsign(l1,1)

            dpl2 = -l * l1 * p + z * dpl
            dpl2s = -l * l1 * p * fsymsign(l1,1) - z * dpl * fsymsign(l1,1)
            tempr = cilm(1,l1,1) * prefactor(l)
            coeftt0 = coeftt0 + tempr * dpl2
            coeftts0 = coeftts0 + tempr * dpl2s

            pm2 = pm1
            pm1 = p

        end do

        pmm = sqr(2) * scalef

        rescalem = 1.0_dp / scalef

        do m = 1, lmax_comp-1, 1

            m1 = m + 1
            rescalem = rescalem * u

            pmm = pmm * sqr(2*m+1) / sqr(2*m)
            pm2 = pmm

            tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * pm2 * (-m-1) &
                    * prefactor(m)    ! (m,m)
            coefr(m1) = coefr(m1) + tempc
            coefrs(m1) = coefrs(m1) + tempc ! fsymsign = 1

            tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * pm2 * (m+1) &
                    * (m+2) * prefactor(m) ! (m,m)
            coefrr(m1) = coefrr(m1) + tempc
            coefrrs(m1) = coefrrs(m1) + tempc ! fsymsign = 1

            tempc = cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) * pm2 &
                    * prefactor(m) * m ! (m,m)
            coefp(m1) = coefp(m1) + tempc
            coefps(m1) = coefps(m1) + tempc ! fsymsign = 1

            tempc = - cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * pm2 &
                    * prefactor(m) * m**2 ! (m,m)
            coefpp(m1) = coefpp(m1) + tempc
            coefpps(m1) = coefpps(m1) + tempc ! fsymsign = 1

            tempc = cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) * pm2 *(-m-1) &
                    * prefactor(m) * m ! (m,m)
            coefrp(m1) = coefrp(m1) + tempc
            coefrps(m1) = coefrps(m1) + tempc ! fsymsign = 1

            dpl = -m * z * pm2 / u**2
            tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * dpl &
                    * prefactor(m)  ! (m,m)
            coeft(m1) = coeft(m1) + tempc
            coefts(m1) = coefts(m1) - tempc ! reverse fsymsign

            tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * dpl * (-m-1) &
                    * prefactor(m) ! (m,m)
            coefrt(m1) = coefrt(m1) + tempc
            coefrts(m1) = coefrts(m1) - tempc ! reverse fsymsign

            tempc = cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) * dpl &
                    * prefactor(m) * m ! (m,m)
            coeftp(m1) = coeftp(m1) + tempc
            coeftps(m1) = coeftps(m1) - tempc ! reverse fsymsign

            dpl2 = -(m*m1 - (m**2)/u**2) * pm2 + z * dpl
            dpl2s = -(m*m1 - (m**2)/u**2) * pm2 - z * dpl
            tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) &
                    * prefactor(m)   ! (m,m)
            coeftt(m1) = coeftt(m1) + tempc * dpl2
            coeftts(m1) = coeftts(m1) + tempc * dpl2s

            pm1 = z * ff1(m1+1,m1) * pm2
            tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * pm1 &
                    * (-m-2) * prefactor(m+1)  ! (m+1,m)
            coefr(m1) = coefr(m1) + tempc
            coefrs(m1) = coefrs(m1) - tempc ! fsymsign = -1

            tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * pm1 &
                    * (m+2) * (m+3) * prefactor(m+1)   ! (m+1,m)
            coefrr(m1) = coefrr(m1) + tempc
            coefrrs(m1) = coefrrs(m1) - tempc ! fsymsign = -1

            tempc = cmplx(cilm(2,m1+1,m1), cilm(1,m1+1,m1), dp) * pm1 &
                    * prefactor(m+1) * m ! (m+1,m)
            coefp(m1) = coefp(m1) + tempc
            coefps(m1) = coefps(m1) - tempc ! fsymsign = -1

            tempc = - cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * pm1 &
                    * prefactor(m+1) * m**2   ! (m+1,m)
            coefpp(m1) = coefpp(m1) + tempc
            coefpps(m1) = coefpps(m1) - tempc ! fsymsign = -1

            tempc = cmplx(cilm(2,m1+1,m1), cilm(1,m1+1,m1), dp) * pm1 &
                    * (-m-2) * prefactor(m+1) * m    ! (m+1,m)
            coefrp(m1) = coefrp(m1) + tempc
            coefrps(m1) = coefrps(m1) - tempc ! fsymsign = -1

            dpl = (sqr(2*m+3) * pmm - z * (m+1) * pm1) / u**2
            tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * dpl &
                    * prefactor(m+1)    ! (m+1,m)
            coeft(m1) = coeft(m1) + tempc
            coefts(m1) = coefts(m1) + tempc ! reverse fsymsign

            tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * dpl &
                    * (-m-2) * prefactor(m+1)   ! (m+1,m)
            coefrt(m1) = coefrt(m1) + tempc
            coefrts(m1) = coefrts(m1) + tempc   ! reverse fsymsign

            tempc = cmplx(cilm(2,m1+1,m1), cilm(1,m1+1,m1), dp) * dpl &
                    * prefactor(m+1) * m  ! (m+1,m)
            coeftp(m1) = coeftp(m1) + tempc
            coeftps(m1) = coeftps(m1) + tempc ! reverse fsymsign

            dpl2 = -(m1*(m1+1) - (m**2)/u**2) * pm1 + z * dpl
            dpl2s = (m1*(m1+1) - (m**2)/u**2) * pm1 + z * dpl
            tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) &
                    * prefactor(m+1) ! (m+1,m)
            coeftt(m1) = coeftt(m1) + tempc  * dpl2
            coeftts(m1) = coeftts(m1) + tempc * dpl2s

            do l=m+2, lmax_comp, 1
                l1 = l + 1
                p = z * ff1(l1,m1) * pm1 - ff2(l1,m1) * pm2
                tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * p * (-l1) &
                        * prefactor(l)
                coefr(m1) = coefr(m1) + tempc
                coefrs(m1) = coefrs(m1) + tempc * fsymsign(l1,m1)

                tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * p * (l1) &
                        * (l1+1) * prefactor(l)
                coefrr(m1) = coefrr(m1) + tempc
                coefrrs(m1) = coefrrs(m1) + tempc * fsymsign(l1,m1)

                tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * p &
                        * prefactor(l) * m
                coefp(m1) = coefp(m1) + tempc
                coefps(m1) = coefps(m1) + tempc * fsymsign(l1,m1)

                tempc = - cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * p &
                        * prefactor(l) * m**2
                coefpp(m1) = coefpp(m1) + tempc
                coefpps(m1) = coefpps(m1) + tempc * fsymsign(l1,m1)

                tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * p * (-l1) &
                        * prefactor(l) * m
                coefrp(m1) = coefrp(m1) + tempc
                coefrps(m1) = coefrps(m1) + tempc * fsymsign(l1,m1)

                dpl = ( sqr(2*l+1) * sqr(l-m) * sqr(l+m) / sqr(2*l-1) &
                       * pm1 - z * l * p) / u**2
                tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * dpl &
                        * prefactor(l)
                coeft(m1) = coeft(m1) + tempc
                ! reverse fsymsign
                coefts(m1) = coefts(m1) - tempc * fsymsign(l1,m1)

                tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * dpl &
                        * (-l1) * prefactor(l)
                coefrt(m1) = coefrt(m1) + tempc
                ! reverse fsymsign
                coefrts(m1) = coefrts(m1) - tempc * fsymsign(l1,m1)

                tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * dpl &
                        * prefactor(l) * m
                coeftp(m1) = coeftp(m1) + tempc
                ! reverse fsymsign
                coeftps(m1) = coeftps(m1) - tempc * fsymsign(l1,m1)

                dpl2 = -(l * l1 -(m**2)/u**2) * p + z * dpl
                dpl2s = -(l * l1 -(m**2)/u**2) * p * fsymsign(l1,m1) &
                       - z * dpl * fsymsign(l1,m1)
                tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) &
                        * prefactor(l)
                coeftt(m1) = coeftt(m1) + tempc * dpl2
                coeftts(m1) = coeftts(m1) +  tempc * dpl2s

                pm2 = pm1
                pm1 = p

            end do

            coefr(m1) = coefr(m1) * rescalem
            coefrs(m1) = coefrs(m1) * rescalem

            coefrr(m1) = coefrr(m1) * rescalem
            coefrrs(m1) = coefrrs(m1) * rescalem

            coeft(m1) = coeft(m1) * rescalem
            coefts(m1) = coefts(m1) * rescalem

            coeftt(m1) = coeftt(m1) * rescalem
            coeftts(m1) = coeftts(m1) * rescalem

            coefrt(m1) = coefrt(m1) * rescalem
            coefrts(m1) = coefrts(m1) * rescalem

            coefp(m1) = coefp(m1) * rescalem
            coefps(m1) = coefps(m1) * rescalem

            coefpp(m1) = coefpp(m1) * rescalem
            coefpps(m1) = coefpps(m1) * rescalem

            coeftp(m1) = coeftp(m1) * rescalem
            coeftps(m1) = coeftps(m1) * rescalem

            coefrp(m1) = coefrp(m1) * rescalem
            coefrps(m1) = coefrps(m1) * rescalem

        end do

        if (lmax_comp /= 0) then

            rescalem = rescalem * u

            pmm = pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) * pmm &
                            * (-lmax_comp-1) * prefactor(lmax_comp)
            coefr(lmax_comp+1) = coefr(lmax_comp+1) + tempc
            coefrs(lmax_comp+1) = coefrs(lmax_comp+1) + tempc ! fsymsign = 1

            tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) * pmm &
                            * (lmax_comp+1) * (lmax_comp+2) &
                            * prefactor(lmax_comp)
            coefrr(lmax_comp+1) = coefrr(lmax_comp+1) + tempc
            coefrrs(lmax_comp+1) = coefrrs(lmax_comp+1) + tempc ! fsymsign = 1

            tempc = cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                            cilm(1,lmax_comp+1,lmax_comp+1), dp) * pmm &
                            * prefactor(lmax_comp) * lmax_comp
            coefp(lmax_comp+1) = coefp(lmax_comp+1) + tempc
            coefps(lmax_comp+1) = coefps(lmax_comp+1) + tempc   ! fsymsign = 1

            tempc = - cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) * pmm &
                            * prefactor(lmax_comp) * lmax_comp**2
            coefpp(lmax_comp+1) = coefpp(lmax_comp+1) + tempc
            coefpps(lmax_comp+1) = coefpps(lmax_comp+1) + tempc ! fsymsign = 1

            tempc = cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                            cilm(1,lmax_comp+1,lmax_comp+1), dp) * pmm &
                            * (-lmax_comp-1) * prefactor(lmax_comp) * lmax_comp
            coefrp(lmax_comp+1) = coefrp(lmax_comp+1) + tempc
            coefrps(lmax_comp+1) = coefrps(lmax_comp+1) + tempc ! fsymsign = 1

            dpl = -lmax_comp * z * pmm / u**2
            tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) * dpl &
                            * prefactor(lmax_comp)
            coeft(lmax_comp+1) = coeft(lmax_comp+1) + tempc
            ! reverse fsymsign
            coefts(lmax_comp+1) = coefts(lmax_comp+1) - tempc

            tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) * dpl &
                            * (-lmax_comp-1) * prefactor(lmax_comp)
            coefrt(lmax_comp+1) = coefrt(lmax_comp+1) + tempc
            ! reverse fsymsign
            coefrts(lmax_comp+1) = coefrts(lmax_comp+1) - tempc

            tempc = cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                            cilm(1,lmax_comp+1,lmax_comp+1), dp) * dpl &
                            * prefactor(lmax_comp) * lmax_comp
            coeftp(lmax_comp+1) = coeftp(lmax_comp+1) + tempc
            coeftps(lmax_comp+1) = coeftps(lmax_comp+1) - tempc

            dpl2 = -(lmax_comp*(lmax_comp+1)-(lmax_comp**2)/u**2) * pmm &
                   + z * dpl
            dpl2s = -(lmax_comp*(lmax_comp+1)-(lmax_comp**2)/u**2) * pmm &
                    - z * dpl
            tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) &
                            * prefactor(lmax_comp)
            coeftt(lmax_comp+1) = coeftt(lmax_comp+1) + tempc * dpl2
            coeftts(lmax_comp+1) = coeftts(lmax_comp+1) + tempc * dpl2s

        end if

        ! Note that the first angular derivatives are with repsect to z,
        ! but that the second is with respect to theta.

        coefr0 = coefr0 * gm / r_ex**2
        coefr(2:lmax+1) = coefr(2:lmax+1) * gm / r_ex**2

        coefrs0 = coefrs0 * gm / r_ex**2
        coefrs(2:lmax+1) = coefrs(2:lmax+1) * gm / r_ex**2

        coefrt0 = -sint * coefrt0 * gm / r_ex**2
        coefrt(2:lmax+1) = -sint * coefrt(2:lmax+1) * gm / r_ex**2

        coefrts0 = -sint * coefrts0 * gm / r_ex**2
        coefrts(2:lmax+1) = -sint * coefrts(2:lmax+1) * gm / r_ex**2

        coefrr0 = coefrr0 * gm / r_ex**3
        coefrr(2:lmax+1) = coefrr(2:lmax+1) * gm / r_ex**3

        coefrrs0 = coefrrs0 * gm / r_ex**3
        coefrrs(2:lmax+1) = coefrrs(2:lmax+1) * gm / r_ex**3

        coeft0 = -sint * coeft0 * gm / r_ex
        coeft(2:lmax+1) = -sint * coeft(2:lmax+1) * gm / r_ex

        coefts0 = -sint * coefts0 * gm / r_ex
        coefts(2:lmax+1) = -sint * coefts(2:lmax+1) * gm / r_ex

        coeftt0 = coeftt0 * gm / r_ex
        coeftt(2:lmax+1) = coeftt(2:lmax+1) * gm / r_ex

        coeftts0 = coeftts0 * gm / r_ex
        coeftts(2:lmax+1) = coeftts(2:lmax+1) * gm / r_ex

        coeftp0 = -sint * coeftp0 * gm / r_ex
        coeftp(2:lmax+1) = -sint * coeftp(2:lmax+1) * gm / r_ex

        coeftps0 = -sint * coeftps0 * gm / r_ex
        coeftps(2:lmax+1) = -sint * coeftps(2:lmax+1) * gm / r_ex

        coefp0 = coefp0 * gm / r_ex
        coefp(2:lmax+1) = coefp(2:lmax+1) * gm / r_ex

        coefps0 = coefps0 * gm / r_ex
        coefps(2:lmax+1) = coefps(2:lmax+1) * gm / r_ex

        coefpp0 = coefpp0 * gm / r_ex
        coefpp(2:lmax+1) = coefpp(2:lmax+1) * gm / r_ex

        coefpps0 = coefpps0 * gm / r_ex
        coefpps(2:lmax+1) = coefpps(2:lmax+1) * gm / r_ex

        coefrp0 = coefrp0 * gm / r_ex**2
        coefrp(2:lmax+1) = coefrp(2:lmax+1) * gm / r_ex**2

        coefrps0 = coefrps0 * gm / r_ex**2
        coefrps(2:lmax+1) = coefrps(2:lmax+1) * gm / r_ex**2

        ! Vzz = Vrr
        coef(1) = cmplx(coefrr0, 0.0_dp, dp)
        coef(2:lmax+1) = coefrr(2:lmax+1) / 2.0_dp

        if (present(sampling)) then
            if (sampling == 2) then
                coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
            end if

        end if

        call fftw_execute_dft_c2r(plan, coef, grid)
        vzz(i,1:nlong) = grid(1:nlong)

        if (i == 1) then
            ! These derivatives are undefined at the pole
            vxx(1,1:nlong) = 0.0_dp
            vyy(1,1:nlong) = 0.0_dp
            vxy(1,1:nlong) = 0.0_dp
            vxz(1,1:nlong) = 0.0_dp
            vyz(1,1:nlong) = 0.0_dp

        else
            ! Vxx = 1/r Vr + 1/r^2 Vtt
            coef(1) = cmplx(coefr0/r_ex + coeftt0/r_ex**2, 0.0_dp, dp)
            coef(2:lmax+1) = (coefr(2:lmax+1)/r_ex &
                             + coeftt(2:lmax+1)/r_ex**2 ) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            vxx(i,1:nlong) = grid(1:nlong)

            ! Vyy = 1/r Vr + 1/r^2 /tan(t) Vt + 1/r^2 /sin(t)^2 Vpp
            coef(1) = cmplx(coefr0/r_ex + coeft0/(r_ex**2)/tan(theta) &
                            + coefpp0/(r_ex**2)/u**2, 0.0_dp, dp)
            coef(2:lmax+1) = (coefr(2:lmax+1)/r_ex &
                            + coeft(2:lmax+1)/(r_ex**2)/tan(theta) + &
                            coefpp(2:lmax+1)/(r_ex**2)/u**2 ) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            vyy(i,1:nlong) = grid(1:nlong)

            ! Vxy = 1/r^2 /sin(t) Vtp - cos(t)/sin(t)^2 /r^2 Vp
            coef(1) = cmplx(coeftp0/sint/r_ex**2 &
                            - coefp0/(r_ex**2)*z/u**2, 0.0_dp, dp)
            coef(2:lmax+1) = (coeftp(2:lmax+1)/sint/r_ex**2 &
                            - coefp(2:lmax+1)/(r_ex**2)*z/u**2 ) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            vxy(i,1:nlong) = grid(1:nlong)

            ! Vxz = 1/r^2 Vt - 1/r Vrt
            coef(1) = cmplx(coeft0/r_ex**2 - coefrt0/r_ex, 0.0_dp, dp)
            coef(2:lmax+1) = (coeft(2:lmax+1)/r_ex**2 &
                            - coefrt(2:lmax+1)/r_ex ) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            vxz(i,1:nlong) = grid(1:nlong)

            ! Vyz = 1/r^2 /sin(t) Vp - 1/r /sin(t) Vrp
            coef(1) = cmplx(coefp0/sint/r_ex**2 - coefrp0/sint/r_ex, 0.0_dp, dp)
            coef(2:lmax+1) = (coefp(2:lmax+1)/sint/r_ex**2 &
                            - coefrp(2:lmax+1)/sint/r_ex ) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            vyz(i,1:nlong) = grid(1:nlong)

        end if

        ! don't compute value for south pole when extend = 0.
        if (.not. (i == 1 .and. extend_grid == 0) ) then
            ! Vzz = Vrr
            coef(1) = cmplx(coefrrs0, 0.0_dp, dp)
            coef(2:lmax+1) = coefrrs(2:lmax+1) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            vzz(i_s,1:nlong) = grid(1:nlong)

            if (i == 1) then
                ! These derivatives are undefined at the pole
                vxx(1,1:nlong) = 0.0_dp
                vyy(1,1:nlong) = 0.0_dp
                vxy(1,1:nlong) = 0.0_dp
                vxz(1,1:nlong) = 0.0_dp
                vyz(1,1:nlong) = 0.0_dp

            else
                ! Vxx = 1/r Vr + 1/r^2 Vtt
                coef(1) = cmplx(coefrs0/r_ex + coeftts0/r_ex**2, 0.0_dp, dp)
                coef(2:lmax+1) = (coefrs(2:lmax+1)/r_ex &
                                  + coeftts(2:lmax+1)/r_ex**2 ) / 2.0_dp

                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                vxx(i_s,1:nlong) = grid(1:nlong)

                ! Vyy = 1/r Vr + 1/r^2 /tan(t) Vt + 1/r^2 /sin(t)^2 Vpp
                coef(1) = cmplx(coefrs0/r_ex + coefts0/(r_ex**2)/tan(theta) &
                                + coefpps0/(r_ex**2)/u**2, 0.0_dp, dp)
                coef(2:lmax+1) = (coefrs(2:lmax+1)/r_ex &
                                  + coefts(2:lmax+1)/(r_ex**2)/tan(theta) + &
                                  coefpps(2:lmax+1)/(r_ex**2)/u**2 ) / 2.0_dp

                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                vyy(i_s,1:nlong) = grid(1:nlong)

                ! Vxy = 1/r^2 /sin(t) Vtp - cos(t)/sin(t)^2 /r^2 Vp
                coef(1) = cmplx(coeftps0/sint/r_ex**2 &
                                - coefps0/(r_ex**2)*z/u**2, 0.0_dp, dp)
                coef(2:lmax+1) = (coeftps(2:lmax+1)/sint/r_ex**2 &
                                  - coefps(2:lmax+1)/(r_ex**2)*z/u**2 ) &
                                  / 2.0_dp

                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                vxy(i_s,1:nlong) = grid(1:nlong)

                ! Vxz = 1/r^2 Vt - 1/r Vrt
                coef(1) = cmplx(coefts0/r_ex**2 - coefrts0/r_ex, 0.0_dp, dp)
                coef(2:lmax+1) = (coefts(2:lmax+1)/r_ex**2 &
                                  - coefrts(2:lmax+1)/r_ex ) / 2.0_dp

                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                vxz(i_s,1:nlong) = grid(1:nlong)

                ! Vyz = 1/r^2 /sin(t) Vp - 1/r /sin(t) Vrp
                coef(1) = cmplx(coefps0/sint/r_ex**2 - coefrps0/sint/r_ex, &
                                0.0_dp, dp)
                coef(2:lmax+1) = (coefps(2:lmax+1)/sint/r_ex**2 &
                                  - coefrps(2:lmax+1)/sint/r_ex ) / 2.0_dp

                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                vyz(i_s,1:nlong) = grid(1:nlong)

            end if

        end if

    end do

    if (extend_grid == 1) then
        vxx(1:nlat_out, nlong_out) = vxx(1:nlat_out, 1)
        vyy(1:nlat_out, nlong_out) = vyy(1:nlat_out, 1)
        vzz(1:nlat_out, nlong_out) = vzz(1:nlat_out, 1)
        vxy(1:nlat_out, nlong_out) = vxy(1:nlat_out, 1)
        vxz(1:nlat_out, nlong_out) = vxz(1:nlat_out, 1)
        vyz(1:nlat_out, nlong_out) = vyz(1:nlat_out, 1)
    end if

    call fftw_destroy_plan(plan)

end subroutine MakeGravGradGridDH