!#########################################################################
!# ***********************************************************************
!# <name> cmsort </name>
!# ***********************************************************************
!#
!# <purpose>
!# This module contains all routines necessary for Cuthill McKee
!# matrix renumbering.
!#
!# For storing matrices, we use the CSR format, realised as ''Format-7''
!# matrices. Format-7 is a variant of the CSR-format used in old FEAT
!# programs, where the diagonal element is stored first in each line.
!#
!# The following routines can be found in this module:
!#
!# 1.) cmsort_calcColumnNumbering
!#     -> Calculate column numbering
!#
!# 2.) cmsort_calcPermutation
!#     -> Calculate permutation
!#
!# </purpose>
!#########################################################################

module cmsort

  use fsystem

  implicit none

  contains

!<subroutine>
  subroutine cmsort_calcColumnNumbering (Ild, Icol, Icon, Ideg, neq, ndeg)

    !<description>
    ! Purpose: Cuthill McKee matrix renumbering
    !          Calculate column numbering

    !The algorithm of Cuthill McKee interprets the system matrix as
    !adjacense matrix. Every Row denotes a note in the corresponing graph.
    !In the first step this function sorts the columns in every row
    !for increasing degree of the nodes in the matrix.
    !The matrix must have symmetric structure!
    !(For FE matrices this is always the case...)

    !Matrix storage technique 7 only!
    !</description>

  !<input>

    ! Number of equations
    integer(I32),intent(IN)                    :: neq

    ! Maximum number of entries != 0 in every row of the matrix
    integer(I32), intent(IN)                   :: ndeg

    ! Row description of matrix
    integer(I32), dimension(neq+1), intent(IN) :: Ild

    ! Column description of matrix
    integer(I32), dimension(:), intent(IN)     :: Icol

    ! Auxiliary vector; must be at least as long as the
    ! maximum number of entries != 0 in every row of the matrix
    ! INTENT(IN) would create here compiler errors
    integer(I32), dimension(ndeg)              :: Ideg

  !</input>

  !<inputoutput>

    ! Auxiliary vector; the column numbers of KCOL are assigned to this in
    ! the order of increasing degree. When calling the routine the user
    ! must copy the content of KCOL to this! These values are then
    ! resorted.
    integer(I32), dimension(:), intent(INOUT)  :: Icon
  !</inputoutput>

!</subroutine>

    ! local variables
    integer(I32) :: ieq, idegIdx, ildIdx, idegIdx1, idegIdx2
    integer(I32) :: idegMin, iidxMin

    ! Clear auxiliary vector
    do idegIdx=1, ndeg
      Ideg(idegIdx) = 0
    end do

    ! Later in the algorithm the column numbers of the non-diagonal
    ! entries are changed. The numbers of the diagonal entries are not
    ! touched. Therefore we copy the column numbers of the diagonal
    ! entries directly.
    do ieq=1, neq
      Icon(Ild(ieq)) = Icol(Ild(ieq))
    end do

    ! Loop about all rows in the matrix: ieq = current row.
    ! Every row corresponds to an entry in the solution vector = a node
    ! in the graph of the matrix.
    do ieq=1, neq

      ! Copy the column numbers of the non-diagonal entries in the current
      ! column to the auxiliary vector Ideg. Ideg contains always the
      ! following nodes of the current node ieq, which are not processed yet.
      ! The entries of the vector are set to 0 one after the other in the
      ! order of the degree of the following nodes.
      do ildIdx=Ild(ieq)+1, Ild(ieq+1)-1
        Ideg(ildIdx-Ild(ieq)) = Icol(ildIdx)
      end do

      ! Loop about every column in the current row. The entries in the
      ! row (=column numbers) of the matrix represent the node numbers of
      ! those nodes in the graph of the matrix, which are connected to the
      ! current node ieq.

      ! The algorithm now has to sort these nodes for increasing degree.
      ! For this purpose the node with the smallest degree is searched and
      ! deleted from Ideg, then the node with the 2nd smallest degree
      ! and so on.
      ! We don't have many nodes, so we use a simple O(n^2) algorithm here
      ! which simply loops over all nodes.
      ! It's only necessary to search in the non-diagonal entries,
      ! because we want to sort the adjacent nodes of the current one
      ! for increasing degree.
      do idegIdx1=1, Ild(ieq+1)-Ild(ieq)-1

        ! iidxMin will receive the index in the Ideg-array of the node with
	! the smallest degree. We start with node 1 in the current column:
	iidxMin=1

	! the variable idegMin always contains the degree of the node, which
	! is described by the index iidxMin

	! If Ideg(iidxMin)=0, this node has already been processed. In this
	! case idegMin is set to neq - the largest upper bound which implies
	! that iidxMin is later on surely replaced by a node with a smaller
	! degree.

	! Otherwise idegMin receives the degree of the node described by
	! iidxMin, which is calculated by the number of elements in Icol,
	! i.e. the difference of the indices in the Ild array.
	if (Ideg(iidxMin) .eq. 0) then
	  idegMin = neq
	else
	  idegMin = Ild(Ideg(iidxMin)+1)-Ild(Ideg(iidxMin))-1
	endif

	! Compare iidxMin with every node in that line to find that with
	! minimum degree:
	do idegIdx2=1, Ild(ieq+1)-Ild(ieq)-1

          ! If Ideg(idegIdx2)=0, idegIdx2 has already been processed. Set
	  ! idegIdx=neq ; here a lower bound to prevent the current node
	  ! iidxMin from being replaced by idegIdx2.

	  ! Otherwise set idegIdx to the degree of the node with index
	  ! idegIdx2
	  if (Ideg(idegIdx2) .eq. 0) then
	    idegIdx = neq
	  else
	    idegIdx = Ild(Ideg(idegIdx2)+1)-Ild(Ideg(idegIdx2))-1
          endif

	  ! If now idegIdx=grad(iidxMin) < grad(idegIdx2)=idegMin set
	  ! iidxMin to the new node with smaller degree.
	  if (idegIdx .lt. idegMin) then
	    iidxMin=idegIdx2
	    idegMin=idegIdx
	  endif

	end do

	! At this point, iidxMin contains the index in Ideg of that node with
	! minimal degree, which has not yet been processed.
	! Ideg(iidxMin) contains the column number of that column of the matrix,
	! which corresponds with the node with the next higher degree.

	! This value is written to Icon. If this subroutine is finished,
	! Icon therefore contains the column numbers of the Icol array -
	! sorted for increasing degree of the nodes in the graph of the matrix.
	Icon(Ild(ieq)+idegIdx1) = Ideg(iidxMin)

	! Set the Ideg-value of the node with minimum degree to 0 to indicate
	! that it has been precessed. This node is then ignored on the next
	! searching process for nodes with minimum degree.
	Ideg(iidxMin) = 0

      end do

      ! Clear auxiliary vector; only some entries were used. This is only for
      ! reasons of safetyness, as if the upper loops are processed correctly,
      ! (no nodes were forgotten), all Ideg-arrays should already be 0.
      do idegIdx=1, Ild(ieq+1)-Ild(ieq)
        Ideg(idegIdx) = 0
      end do

    ! Process next line:
    end do

  end subroutine cmsort_calcColumnNumbering

!<subroutine>
  subroutine cmsort_calcPermutation (Ild, Icon, neq, Itr1, Itr2)

    !<description>
    !Purpose: Cuthill McKee matrix renumbering
    !         Calculate permutation

    ! Uses the Ild/Icon vectors of cmsort_calcColumnNumbering to calc-
    ! ulate permutation vectors Itr1 and Itr2; these describe how a
    ! vector must be sorted/sorted back.

    ! Itr1 must be initialized with 0 on call of this subroutine!
    ! Itr2 should be initialized with 0 on call of this subroutine; ther-
    ! wise only the entries != 0 are calculated!

    ! Matrix storage technique 7 only!
    !</description>

    !<input>

    ! Number of equations
    integer(I32), intent(IN)                   :: neq

    ! Row description of matrix
    integer(I32), dimension(neq+1), intent(IN) :: Ild

    ! Auxiliary vector, calculated with cmsort_calcColumnNumbering
    integer(I32), dimension(:), intent(IN)     :: Icon
    !</input>

    !<output>

    ! The permutation vector that describes how the solution vector
    ! has to be restored
    integer(I32), dimension(neq), intent(OUT) :: Itr1

    ! Describes how a resorted vector can be sorted back
    integer(I32), dimension(neq), intent(OUT) :: Itr2

    !</output>

  !</subroutine>

    ! local variables
    integer(I32) :: ineqIdx, icount, ildIdx, icolIdx

!    DO icount=1, neq
!      IF (Itr1(icount) .EQ. 0) Itr1(icount) = icount
!    END DO
    ! Commented out, old FEAT-Code. The current code is using the fact that
    ! the Itr1-vector is filled with 0 on call to this routine.

    ! Itr1 should receive a permutation of the numbers 1..neq for
    ! resorting the entries, Itr2 should receive the inverse permutation.

    ! The Cuthill-McCee algorithm processes levelwise. One node is picked
    ! as the starting node and receives the first number. The nodes
    ! in the neighbourhood receive the next numbers in increasing order
    ! of the degrees of these nodes. Then the neighbourhood of these
    ! nodes is analyzed for increasing degree to give the next node
    ! numbers, and so on.
    !
    ! For this purpose the permutation vectors Itr1 and Itr2 are build
    ! subsequently, depending on which nodes have already been processed.

    ! We fix the first node (=first line of the matrix), i.e. we set
    ! Itr1(1)=1. This of course implies that the inverse permutation
    ! does not have to process node 1, i.e. Itr2(1)=1. But this will
    ! be computed by the algorithm later.

!    Itr1(1)=1
!    Itr2(1)=1
    ! Old FEAT-code, commented out.
    ! The current code uses the fact, that Itr1 is initialized with 0 on
    ! call to this routine. In in the processing a 0 is found in Itr1, a
    ! new matrix block is found. This is especially the case in the
    ! beginning of the algorithm, as no matrix block has been found yet and
    ! Itr1 is completely 0. But also later on if the matrix contains
    ! independent blocks, this will work correctly in contrast to the
    ! old FEAT code.

    ! The renumbering strategy of Cuthill-McKee orders the nodes for
    ! increasing degree in the graph of the matrix. For the new numbering
    ! we use the index variable ineqIdx, which is increased for every node
    ! and specifies always the new node number for the next found node.
    ! We start with node number ineqIdx=0 and increase ineqIdx before
    ! the node number of the next found node is set.
    ineqIdx = 0

    ! Now loop over all nodes (=lines in the matrix). The following loop
    ! processes every node in a kind of quere exactly one time, so it
    ! has neq passes:
    do icount=1, neq

      ! Look at line Itr1(icount) (=0, if a new matrix block starts, like
      ! in the beginning). We look at every element in that line and save
      ! the numbers of the following nodes in Itr1. These are processed later.

      ! If Itr1(icount)=0, a new matrix block starts. This is the case if
      ! a new independent block arises in the matrix without connection
      ! to previous elements. This is normally not the case with finite
      ! elements, but may arise in special cases (e.g. compressed matrices,
      ! where in a line there is only a diagonal entry = 1x1-block).
      ! In this case we ignore the number of the first line of that block
      ! (i.e. we give the next free number directly), and continue with
      ! processing the neighbours of the corresponding node in the graph
      ! of the matrix.
      if (Itr1(icount) .eq. 0) then

        ! New block. all previous blocks are contained in line 1..icount-1.
        ! The next line number to fix is therefore icount.
        Itr1(icount) = icount

        ! Now the block structure of the matrix (representing the connected
        ! components in the graph of the matrix) and the structure of the
        ! loop implies:
        !    Itr1(icount) = icount = ineqIdx + 1   !!!
        ! because: If we processed icount-1 elements and start a new block,
        ! the nodes contained in the previous blocks don't contain neighbours
        ! in the current block or in later blocks. Therefore all indices
        ! are <= icount-1, and at the same time ineqIdx=icount-1 holds
        ! (is not set but implicitly the case).

        ! The inverse of the entry is calculated in the DO-loop below,
        ! which also increments ineqIdx appropriately.

      end if

      ! Now loop about the elements in the line and collect the neighbours
      ! of the corresponding node in the graph:
      do ildIdx=Ild(Itr1(icount)), Ild(Itr1(icount)+1)-1

        ! Collect the column numbers in the current line in the order of
        ! increasing degree of the nodes. icolIdx will receive the column
        ! numbers subsequently.
        icolIdx=Icon(ildIdx)

        ! Test if we already calculated the permutation for the current node.
        ! For that purpose analyze if the Itr2-entry of the currently
        ! processed neighbour contains a value:
        if (Itr2(icolIdx) .eq. 0) then

          ! This is a new node, which follows our current node Itr1(icount).
          ! Give it the next free number.

          ! Obviously for the very first element there is:
          !   Itr1(1)=1, icolIdx=Icon(1)=1, Itr2(1)=0, ineqIdx=0.
          ! That way this routine correctly sets Itr2(1)=1 and correctly
          ! calculates the inverse of the permutation.
          ineqIdx       = ineqIdx+1
          Itr2(icolIdx) = ineqIdx

          ! Now insert the new node in Itr1. That way Itr1 also serves as a kind
          ! of queue of the nodes that have not yet been processed - subsequently
          ! Itr1(1), Itr1(2), Itr1(3),... is build up. Because in all cases
          ! icount <= ineqIdx holds, not calculated elements in Itr1 are never
          ! accessed.
          Itr1(ineqIdx) = icolIdx

        end if

      end do

    end do

  end subroutine cmsort_calcPermutation

end module


C$Procedure      INEDPL ( Intersection of ellipsoid and plane )

      SUBROUTINE INEDPL ( A, B, C, PLANE, ELLIPS, FOUND )

C$ Abstract
C
C     Find the intersection of a triaxial ellipsoid and a plane.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ELLIPSES
C     PLANES
C
C$ Keywords
C
C     ELLIPSE
C     ELLIPSOID
C     GEOMETRY
C     MATH
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL = 9 )

      INTEGER               UBPL
      PARAMETER           ( UBPL = 4 )

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      PLANE  ( UBPL )
      DOUBLE PRECISION      ELLIPS ( UBEL )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     A          I   Length of ellipsoid semi-axis lying on the x-axis.
C     B          I   Length of ellipsoid semi-axis lying on the y-axis.
C     C          I   Length of ellipsoid semi-axis lying on the z-axis.
C     PLANE      I   Plane that intersects ellipsoid.
C     ELLIPS     O   Intersection ellipse, when FOUND is .TRUE.
C     FOUND      O   Flag indicating whether ellipse was found.
C
C$ Detailed_Input
C
C     A,
C     B,
C     C              are the lengths of the semi-axes of a triaxial
C                    ellipsoid.  The ellipsoid is centered at the
C                    origin and oriented so that its axes lie on the
C                    x, y and z axes.  A, B, and C are the lengths of
C                    the semi-axes that point in the x, y, and z
C                    directions respectively.
C
C     PLANE          is a SPICELIB plane.
C
C$ Detailed_Output
C
C     ELLIPS         is the SPICELIB ellipse formed by the intersection
C                    of the input plane and ellipsoid.  ELLIPS will
C                    represent a single point if the ellipsoid and
C                    plane are tangent.
C
C                    If the intersection of the ellipsoid and plane is
C                    empty, ELLIPS is not modified.
C
C
C     FOUND          is .TRUE. if and only if the intersection of the
C                    ellipsoid and plane is non-empty.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If any of the lengths of the semi-axes of the input ellipsoid
C         are non-positive, the error SPICE(DEGENERATECASE) is
C         signaled.  ELLIPS is not modified.  FOUND is set to .FALSE.
C
C     2)  If the input plane in invalid, in other words, if the input
C         plane as the zero vector as its normal vector, the error
C         SPICE(INVALIDPLANE) is signaled. ELLIPS is not modified.
C         FOUND is set to .FALSE.
C
C     3)  If the input plane and ellipsoid are very nearly tangent,
C         roundoff error may cause this routine to give unreliable
C         results.
C
C     4)  If the input plane and ellipsoid are precisely tangent, the
C         intersection is a single point.  In this case, the output
C         ellipse is degenerate, but FOUND will still have the value
C         .TRUE.  You must decide whether this output makes sense for
C         your application.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     An ellipsoid and a plane can intersect in an ellipse, a single
C     point, or the empty set.
C
C$ Examples
C
C     1)  Suppose we wish to find the limb of a body, as observed from
C         location LOC in body-fixed coordinates.  The SPICELIB routine
C         EDLIMB solves this problem.  Here's how INEDPL is used in
C         that solution.
C
C         We assume LOC is outside of the body. The body is modelled as
C         a triaxial ellipsoid with semi-axes of length A, B, and C.
C         The notation
C
C            < X, Y >
C
C         indicates the inner product of the vectors X and Y.
C
C         The limb lies on the plane defined by
C
C            < X,  N >  =  1,
C
C         where the vector N is defined as
C
C            ( LOC(1) / A**2,   LOC(2) / B**2,   LOC(3) / C**2 ).
C
C         The assignments
C
C            N(1) = LOC(1) / A**2
C            N(2) = LOC(2) / B**2
C            N(3) = LOC(3) / C**2
C
C         and the calls
C
C            CALL NVC2PL ( N,  1.0D0,  PLANE )
C
C            CALL INEDPL ( A,  B,  C,  PLANE,  LIMB,  FOUND )
C
C            CALL EL2CGV ( LIMB, CENTER, SMAJOR, SMINOR )
C
C         will return the center and semi-axes of the limb.
C
C
C         How do we know that  < X, N > = 1  for all X on the limb?
C         This is because all limb points X satisfy
C
C            < LOC - X, SURFNM(X) >  =  0,
C
C         where SURFNM(X) is a surface normal at X.  SURFNM(X) is
C         parallel to the vector
C
C            V = (  X(1) / A**2,   X(2) / B**2,   X(3) / C**2  )
C
C         so we have
C
C            < LOC - X, V >  =  0,
C
C            < LOC, V >      =  < X, V >  =  1  (from the original
C                                                ellipsoid
C                                                equation);
C         and finally
C
C            < X,   N >      =  1,
C
C         where the vector N is defined as
C
C            (  LOC(1) / A**2,    LOC(2) / B**2,   LOC(3) / C**2  ).
C
C
C     2)  Suppose we wish to find the terminator of a body.  We can
C         make a fair approximation to the location of the terminator
C         by finding the limb of the body as seen from the vertex of
C         the umbra; then the problem is essentially the same as in
C         example 1.  Let VERTEX be this location.  We make the
C         assignments
C
C            P(1) =   VERTEX(1) / A**2
C            P(2) =   VERTEX(2) / B**2
C            P(3) =   VERTEX(3) / C**2
C
C         and then make the calls
C
C            CALL NVC2PL ( P,  1.0D0,  PLANE )
C
C            CALL INEDPL ( A,  B,  C,  PLANE,  TERM,  FOUND )
C
C         The SPICELIB ellipse TERM represents the terminator of the
C         body.
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 16-NOV-2005 (NJB)
C
C        Bug fix:  error detection for case of invalid input plane was
C        added.
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL calls.
C
C-    SPICELIB Version 1.1.0, 11-JUL-1995 (KRG)
C
C        Removed potential numerical precision problems that could be
C        caused by using a REAL constant in a double precision
C        computation. The value 1.0 was repaced with the value 1.0D0 in
C        the following three lines:
C
C           DSTORT(1) = 1.0 / A
C           DSTORT(2) = 1.0 / B
C           DSTORT(3) = 1.0 / C
C
C        Also changed was a numeric constant from 1.D0 to the
C        equivalent, but more aesthetically pleasing 1.0D0.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     intersection of ellipsoid and plane
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 16-NOV-2005 (NJB)
C
C        Bug fix:  error detection for case of invalid input plane was
C        added.
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL calls.
C
C-    SPICELIB Version 1.1.0, 11-JUL-1995 (KRG)
C
C        Removed potential numerical precision problems that could be
C        caused by using a REAL constant in a double precision
C        computation. The value 1.0 was repaced with the value 1.0D0 in
C        the following three lines:
C
C           DSTORT(1) = 1.0 / A
C           DSTORT(2) = 1.0 / B
C           DSTORT(3) = 1.0 / C
C
C        Also changed was a numeric constant from 1.D0 to the
C        equivalent, but more aesthetically pleasing 1.0D0.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      BRCKTD
      DOUBLE PRECISION      VNORM

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local variables
C
      DOUBLE PRECISION      CENTER ( 3 )
      DOUBLE PRECISION      CONST
      DOUBLE PRECISION      DPLANE ( UBPL )
      DOUBLE PRECISION      DIST
      DOUBLE PRECISION      DSTORT ( 3 )
      DOUBLE PRECISION      INVDST ( 3 )
      DOUBLE PRECISION      MAXRAD
      DOUBLE PRECISION      NORMAL ( 3 )
      DOUBLE PRECISION      POINT  ( 3 )
      DOUBLE PRECISION      RCIRCL
      DOUBLE PRECISION      SPAN1  ( 3 )
      DOUBLE PRECISION      SPAN2  ( 3 )
      DOUBLE PRECISION      VEC1   ( 3 )
      DOUBLE PRECISION      VEC2   ( 3 )

      INTEGER               I

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'INEDPL' )
      END IF

C
C     We don't want to worry about flat ellipsoids:
C
      IF (         ( A .LE. 0.0D0 )
     .      .OR.   ( B .LE. 0.0D0 )
     .      .OR.   ( C .LE. 0.0D0 )   )   THEN

         FOUND = .FALSE.

         CALL SETMSG ( 'Semi-axes: A = #,  B = #,  C = #.'  )
         CALL ERRDP  ( '#', A                               )
         CALL ERRDP  ( '#', B                               )
         CALL ERRDP  ( '#', C                               )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'              )
         CALL CHKOUT ( 'INEDPL'                             )
         RETURN

      END IF

C
C     Check input plane for zero normal vector.
C
      CALL PL2NVC ( PLANE, NORMAL, CONST )

      IF ( VZERO(NORMAL) ) THEN

         CALL SETMSG ( 'Normal vector of the input ' //
     .                 'PLANE is the zero vector.'   )
         CALL SIGERR ( 'SPICE(INVALIDPLANE)'         )
         CALL CHKOUT ( 'INEDPL'                      )
         RETURN

      END IF

C
C     This algorithm is partitioned into a series of steps:
C
C
C     1)  Identify a linear transformation that maps the input
C         ellipsoid to the unit sphere.  We'll call this mapping the
C         `distortion' mapping.  Apply the distortion mapping to both
C         the input plane and ellipsoid.  The image of the plane under
C         this transformation will be a plane.
C
C     2)  Find the intersection of the transformed plane and the unit
C         sphere.
C
C     3)  Apply the inverse of the distortion mapping to the
C         intersection ellipse to find the undistorted intersection
C         ellipse.
C

C
C     Step 1:
C
C     Find the image of the ellipsoid and plane under the distortion
C     matrix.  Since the image of the ellipsoid is the unit sphere,
C     only the plane transformation requires any work.
C
C     If the input plane is too far from the origin to possibly
C     intersect the ellipsoid, return now.  This can save us
C     some numerical problems when we scale the plane and ellipsoid.
C
C     The point returned by PL2PSV is the closest point in PLANE
C     to the origin, so its norm gives the distance of the plane
C     from the origin.
C
      CALL PL2PSV  ( PLANE, POINT, SPAN1, SPAN2 )

      MAXRAD = MAX ( DABS(A), DABS(B), DABS(C) )

      IF ( VNORM (POINT) .GT. MAXRAD ) THEN

         FOUND = .FALSE.
         CALL CHKOUT ( 'INEDPL' )
         RETURN

      END IF

C
C     The distortion matrix and its inverse are
C
C        +-               -+        +-               -+
C        |  1/A   0    0   |        |   A    0    0   |
C        |   0   1/B   0   |,       |   0    B    0   |.
C        |   0    0   1/C  |        |   0    0    C   |
C        +-               -+        +-               -+
C
C     We declare them with length three, since we are going to make
C     use of the diagonal elements only.
C
      DSTORT(1) = 1.0D0 / A
      DSTORT(2) = 1.0D0 / B
      DSTORT(3) = 1.0D0 / C

      INVDST(1) =  A
      INVDST(2) =  B
      INVDST(3) =  C

C
C     Apply the distortion mapping to the input plane.  Applying
C     the distortion mapping to a point and two spanning vectors that
C     define the input plane yields a point and two spanning vectors
C     that define the distorted plane.
C
      DO I = 1, 3

         POINT(I)  =  DSTORT(I)  *  POINT(I)
         SPAN1(I)  =  DSTORT(I)  *  SPAN1(I)
         SPAN2(I)  =  DSTORT(I)  *  SPAN2(I)

      END DO

      CALL PSV2PL ( POINT,   SPAN1,  SPAN2,  DPLANE )

C
C     Step 2:
C
C     Find the intersection of the distorted plane and unit sphere.
C

C
C     The intersection of the distorted plane and the unit sphere
C     may be a circle, a point, or the empty set.  The distance of the
C     plane from the origin determines which type of intersection we
C     have.  If we represent the distorted plane by a unit normal
C     vector and constant, the size of the constant gives us the
C     distance of the plane from the origin.  If the distance is greater
C     than 1, the intersection of plane and unit sphere is empty. If
C     the distance is equal to 1, we have the tangency case.
C
C     The routine PL2PSV always gives us an output point that is the
C     closest point to the origin in the input plane.  This point is
C     the center of the intersection circle.  The spanning vectors
C     returned by PL2PSV, after we scale them by the radius of the
C     intersection circle, become an orthogonal pair of vectors that
C     extend from the center of the circle to the circle itself.  So,
C     the center and these scaled vectors define the intersection
C     circle.
C
      CALL PL2PSV  ( DPLANE, CENTER, VEC1, VEC2 )

      DIST = VNORM ( CENTER )

      IF ( DIST .GT. 1.0D0 ) THEN

         FOUND = .FALSE.
         CALL CHKOUT ( 'INEDPL' )
         RETURN

      END IF

C
C     Scale the generating vectors by the radius of the intersection
C     circle.
C
      RCIRCL =  DSQRT (  BRCKTD ( 1.0D0 - DIST**2,  0.0D0,  1.0D0  )  )

      CALL VSCLIP ( RCIRCL, VEC1 )
      CALL VSCLIP ( RCIRCL, VEC2 )

C
C     Step 3:
C
C     Apply the inverse distortion to the intersection circle to find
C     the actual intersection ellipse.
C
      DO I = 1, 3

         CENTER(I)  =  INVDST(I)  *  CENTER(I)
         VEC1(I)    =  INVDST(I)  *  VEC1(I)
         VEC2(I)    =  INVDST(I)  *  VEC2(I)

      END DO
C
C     Make an ellipse from the center and generating vectors.
C
      CALL CGV2EL ( CENTER, VEC1, VEC2, ELLIPS )

      FOUND  = .TRUE.

      CALL CHKOUT ( 'INEDPL' )
      RETURN
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file hrfft.f
c
c     this file contains a multiple fft package for spherepack3.0.
c     it includes code and documentation for performing fast fourier
c     transforms (see subroutines hrffti,hrfftf and hrfftb)
c
c **********************************************************************
c
c     subroutine hrffti(n,wsave)
c
c     subroutine hrffti initializes the array wsave which is used in
c     both hrfftf and hrfftb. the prime factorization of n together
c     with a tabulation of the trigonometric functions are computed and
c     stored in wsave.
c
c     input parameter
c
c     n       the length of the sequence to be transformed.
c
c     output parameter
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             the same work array can be used for both hrfftf and
c             hrfftb as long as n remains unchanged. different wsave
c             arrays are required for different values of n. the
c             contents of wsave must not be changed between calls
c             of hrfftf or hrfftb.
c
c **********************************************************************
c
c     subroutine hrfftf(m,n,r,mdimr,wsave,work)
c
c     subroutine hrfftf computes the fourier coefficients of m real
c     perodic sequences (fourier analysis); i.e. hrfftf computes the
c     real fft of m sequences each with length n. the transform is
c     defined below at output parameter r.
c
c     input parameters
c
c     m       the number of sequences.
c
c     n       the length of all m sequences.  the method is most
c             efficient when n is a product of small primes. n may
c             change as long as different work arrays are provided
c
c     r       r(m,n) is a two dimensional real array that contains m
c             sequences each with length n.
c
c     mdimr   the first dimension of the r array as it appears
c             in the program that calls hrfftf. mdimr must be
c             greater than or equal to m.
c
c
c     wsave   a work array with at least least 2*n+15 locations
c             in the program that calls hrfftf. the wsave array must be
c             initialized by calling subroutine hrffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by hrfftf and hrfftb.
c
c     work    a real work array with m*n locations.
c
c
c     output parameters
c
c     r      for all j=1,...,m
c
c             r(j,1) = the sum from i=1 to i=n of r(j,i)
c
c             if n is even set l =n/2   , if n is odd set l = (n+1)/2
c
c               then for k = 2,...,l
c
c                  r(j,2*k-2) = the sum from i = 1 to i = n of
c
c                       r(j,i)*cos((k-1)*(i-1)*2*pi/n)
c
c                  r(j,2*k-1) = the sum from i = 1 to i = n of
c
c                      -r(j,i)*sin((k-1)*(i-1)*2*pi/n)
c
c             if n is even
c
c                  r(j,n) = the sum from i = 1 to i = n of
c
c                       (-1)**(i-1)*r(j,i)
c
c      *****  note
c                  this transform is unnormalized since a call of hrfftf
c                  followed by a call of hrfftb will multiply the input
c                  sequence by n.
c
c     wsave   contains results which must not be destroyed between
c             calls of hrfftf or hrfftb.
c
c     work    a real work array with m*n locations that does
c             not have to be saved.
c
c **********************************************************************
c
c     subroutine hrfftb(m,n,r,mdimr,wsave,work)
c
c     subroutine hrfftb computes the real perodic sequence of m
c     sequences from their fourier coefficients (fourier synthesis).
c     the transform is defined below at output parameter r.
c
c     input parameters
c
c     m       the number of sequences.
c
c     n       the length of all m sequences.  the method is most
c             efficient when n is a product of small primes. n may
c             change as long as different work arrays are provided
c
c     r       r(m,n) is a two dimensional real array that contains
c             the fourier coefficients of m sequences each with
c             length n.
c
c     mdimr   the first dimension of the r array as it appears
c             in the program that calls hrfftb. mdimr must be
c             greater than or equal to m.
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             in the program that calls hrfftb. the wsave array must be
c             initialized by calling subroutine hrffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by hrfftf and hrfftb.
c
c     work    a real work array with m*n locations.
c
c
c     output parameters
c
c     r      for all j=1,...,m
c
c             for n even and for i = 1,...,n
c
c                  r(j,i) = r(j,1)+(-1)**(i-1)*r(j,n)
c
c                       plus the sum from k=2 to k=n/2 of
c
c                        2.*r(j,2*k-2)*cos((k-1)*(i-1)*2*pi/n)
c
c                       -2.*r(j,2*k-1)*sin((k-1)*(i-1)*2*pi/n)
c
c             for n odd and for i = 1,...,n
c
c                  r(j,i) = r(j,1) plus the sum from k=2 to k=(n+1)/2 of
c
c                       2.*r(j,2*k-2)*cos((k-1)*(i-1)*2*pi/n)
c
c                      -2.*r(j,2*k-1)*sin((k-1)*(i-1)*2*pi/n)
c
c      *****  note
c                  this transform is unnormalized since a call of hrfftf
c                  followed by a call of hrfftb will multiply the input
c                  sequence by n.
c
c     wsave   contains results which must not be destroyed between
c             calls of hrfftb or hrfftf.
c
c     work    a real work array with m*n locations that does not
c             have to be saved
c
c **********************************************************************
c
c
c
      SUBROUTINE DHRFFTI(N,WSAVE)
      DOUBLE PRECISION WSAVE
      DOUBLE PRECISION TFFT
      DIMENSION WSAVE(N+15)
      COMMON /HRF/TFFT

      TFFT = 0.D0
      IF (N.EQ.1) RETURN
      CALL DHRFTI1(N,WSAVE(1),WSAVE(N+1))
      RETURN
      END
      SUBROUTINE DHRFTI1(N,WA,FAC)
      DOUBLE PRECISION WA
      DOUBLE PRECISION FAC
      DOUBLE PRECISION FI
c
c     a multiple fft package for spherepack
c
      DIMENSION WA(N),FAC(15),NTRYH(4)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/

      NL = N
      NF = 0
      J = 0
  101 J = J + 1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY + 2
  104 NQ = NL/NTRY
      NR = NL - NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF + 1
      FAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY.NE.2) GO TO 107
      IF (NF.EQ.1) GO TO 107
      DO 106 I = 2,NF
          IB = NF - I + 2
          FAC(IB+2) = FAC(IB+1)
  106 CONTINUE
      FAC(3) = 2
  107 IF (NL.NE.1) GO TO 104
      FAC(1) = N
      FAC(2) = NF
C*PT*WARNING* Constant already double-precision
C*PT*WARNING* Constant already double-precision
      TPI = 8.d0*DATAN(1.d0)
      ARGH = TPI/DBLE(N)
      IS = 0
      NFM1 = NF - 1
      L1 = 1
      IF (NFM1.EQ.0) RETURN
      DO 110 K1 = 1,NFM1
          IP = FAC(K1+2)
          LD = 0
          L2 = L1*IP
          IDO = N/L2
          IPM = IP - 1
          DO 109 J = 1,IPM
              LD = LD + L1
              I = IS
              ARGLD = DBLE(LD)*ARGH
              FI = 0.D0
              DO 108 II = 3,IDO,2
                  I = I + 2
                  FI = FI + 1.D0
                  ARG = FI*ARGLD
                  WA(I-1) = DCOS(ARG)
                  WA(I) = DSIN(ARG)
  108         CONTINUE
              IS = IS + IDO
  109     CONTINUE
          L1 = L2
  110 CONTINUE
      RETURN
      END
      SUBROUTINE DHRFFTF(M,N,R,MDIMR,WHRFFT,WORK)
      DOUBLE PRECISION R
      DOUBLE PRECISION WHRFFT
      DOUBLE PRECISION WORK
      DOUBLE PRECISION TFFT
c
c     a multiple fft package for spherepack
c
      DIMENSION R(MDIMR,N),WORK(1),WHRFFT(N+15)
      COMMON /HRF/TFFT

      IF (N.EQ.1) RETURN
c     tstart = second(dum)
      CALL DHRFTF1(M,N,R,MDIMR,WORK,WHRFFT,WHRFFT(N+1))
c     tfft = tfft+second(dum)-tstart
      RETURN
      END
      SUBROUTINE DHRFTF1(M,N,C,MDIMC,CH,WA,FAC)
      DOUBLE PRECISION C
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA
      DOUBLE PRECISION FAC
c
c     a multiple fft package for spherepack
c
      DIMENSION CH(M,N),C(MDIMC,N),WA(N),FAC(15)

      NF = FAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1 = 1,NF
          KH = NF - K1
          IP = FAC(KH+3)
          L1 = L2/IP
          IDO = N/L2
          IDL1 = IDO*L1
          IW = IW - (IP-1)*IDO
          NA = 1 - NA
          IF (IP.NE.4) GO TO 102
          IX2 = IW + IDO
          IX3 = IX2 + IDO
          IF (NA.NE.0) GO TO 101
          CALL DHRADF4(M,IDO,L1,C,MDIMC,CH,M,WA(IW),WA(IX2),WA(IX3))
          GO TO 110
  101     CALL DHRADF4(M,IDO,L1,CH,M,C,MDIMC,WA(IW),WA(IX2),WA(IX3))
          GO TO 110
  102     IF (IP.NE.2) GO TO 104
          IF (NA.NE.0) GO TO 103
          CALL DHRADF2(M,IDO,L1,C,MDIMC,CH,M,WA(IW))
          GO TO 110
  103     CALL DHRADF2(M,IDO,L1,CH,M,C,MDIMC,WA(IW))
          GO TO 110
  104     IF (IP.NE.3) GO TO 106
          IX2 = IW + IDO
          IF (NA.NE.0) GO TO 105
          CALL DHRADF3(M,IDO,L1,C,MDIMC,CH,M,WA(IW),WA(IX2))
          GO TO 110
  105     CALL DHRADF3(M,IDO,L1,CH,M,C,MDIMC,WA(IW),WA(IX2))
          GO TO 110
  106     IF (IP.NE.5) GO TO 108
          IX2 = IW + IDO
          IX3 = IX2 + IDO
          IX4 = IX3 + IDO
          IF (NA.NE.0) GO TO 107
          CALL DHRADF5(M,IDO,L1,C,MDIMC,CH,M,WA(IW),WA(IX2),WA(IX3),
     +                WA(IX4))
          GO TO 110
  107     CALL DHRADF5(M,IDO,L1,CH,M,C,MDIMC,WA(IW),WA(IX2),WA(IX3),
     +                WA(IX4))
          GO TO 110
  108     IF (IDO.EQ.1) NA = 1 - NA
          IF (NA.NE.0) GO TO 109
          CALL DHRADFG(M,IDO,IP,L1,IDL1,C,C,C,MDIMC,CH,CH,M,WA(IW))
          NA = 1
          GO TO 110
  109     CALL DHRADFG(M,IDO,IP,L1,IDL1,CH,CH,CH,M,C,C,MDIMC,WA(IW))
          NA = 0
  110     L2 = L1
  111 CONTINUE
      IF (NA.EQ.1) RETURN
      DO 112 J = 1,N
          DO 112 I = 1,M
              C(I,J) = CH(I,J)
  112 CONTINUE
      RETURN
      END
      SUBROUTINE DHRADF4(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1,WA2,WA3)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION HSQT2
c
c     a multiple fft package for spherepack
c
      DIMENSION CC(MDIMCC,IDO,L1,4),CH(MDIMCH,IDO,4,L1),WA1(IDO),
     +          WA2(IDO),WA3(IDO)

      HSQT2 = SQRT(2.D0)/2.D0
      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,1,K) = (CC(M,1,K,2)+CC(M,1,K,4)) +
     +                      (CC(M,1,K,1)+CC(M,1,K,3))
              CH(M,IDO,4,K) = (CC(M,1,K,1)+CC(M,1,K,3)) -
     +                        (CC(M,1,K,2)+CC(M,1,K,4))
              CH(M,IDO,2,K) = CC(M,1,K,1) - CC(M,1,K,3)
              CH(M,1,3,K) = CC(M,1,K,4) - CC(M,1,K,2)
 1001     CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO + 2
      DO 104 K = 1,L1
          DO 103 I = 3,IDO,2
              IC = IDP2 - I
              DO 1003 M = 1,MP
                  CH(M,I-1,1,K) = ((WA1(I-2)*CC(M,I-1,K,
     +                            2)+WA1(I-1)*CC(M,I,K,2))+
     +                            (WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,
     +                            I,K,4))) + (CC(M,I-1,K,1)+
     +                            (WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*CC(M,
     +                            I,K,3)))
                  CH(M,IC-1,4,K) = (CC(M,I-1,K,1)+
     +                             (WA2(I-2)*CC(M,I-1,K,3)+WA2(I-
     +                             1)*CC(M,I,K,3))) -
     +                             ((WA1(I-2)*CC(M,I-1,K,
     +                             2)+WA1(I-1)*CC(M,I,K,2))+
     +                             (WA3(I-2)*CC(M,I-1,K,
     +                             4)+WA3(I-1)*CC(M,I,K,4)))
                  CH(M,I,1,K) = ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,
     +                          I-1,K,2))+ (WA3(I-2)*CC(M,I,K,
     +                          4)-WA3(I-1)*CC(M,I-1,K,4))) +
     +                          (CC(M,I,K,1)+ (WA2(I-2)*CC(M,I,K,
     +                          3)-WA2(I-1)*CC(M,I-1,K,3)))
                  CH(M,IC,4,K) = ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,
     +                           I-1,K,2))+ (WA3(I-2)*CC(M,I,K,
     +                           4)-WA3(I-1)*CC(M,I-1,K,4))) -
     +                           (CC(M,I,K,1)+ (WA2(I-2)*CC(M,I,K,
     +                           3)-WA2(I-1)*CC(M,I-1,K,3)))
                  CH(M,I-1,3,K) = ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,
     +                            I-1,K,2))- (WA3(I-2)*CC(M,I,K,
     +                            4)-WA3(I-1)*CC(M,I-1,K,4))) +
     +                            (CC(M,I-1,K,1)- (WA2(I-2)*CC(M,I-1,K,
     +                            3)+WA2(I-1)*CC(M,I,K,3)))
                  CH(M,IC-1,2,K) = (CC(M,I-1,K,1)-
     +                             (WA2(I-2)*CC(M,I-1,K,3)+WA2(I-
     +                             1)*CC(M,I,K,3))) -
     +                             ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,
     +                             I-1,K,2))- (WA3(I-2)*CC(M,I,K,
     +                             4)-WA3(I-1)*CC(M,I-1,K,4)))
                  CH(M,I,3,K) = ((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,
     +                          I,K,4))- (WA1(I-2)*CC(M,I-1,K,
     +                          2)+WA1(I-1)*CC(M,I,K,2))) +
     +                          (CC(M,I,K,1)- (WA2(I-2)*CC(M,I,K,
     +                          3)-WA2(I-1)*CC(M,I-1,K,3)))
                  CH(M,IC,2,K) = ((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,
     +                           I,K,4))- (WA1(I-2)*CC(M,I-1,K,
     +                           2)+WA1(I-1)*CC(M,I,K,2))) -
     +                           (CC(M,I,K,1)- (WA2(I-2)*CC(M,I,K,
     +                           3)-WA2(I-1)*CC(M,I-1,K,3)))
 1003         CONTINUE
  103     CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2).EQ.1) RETURN
  105 CONTINUE
      DO 106 K = 1,L1
          DO 1006 M = 1,MP
              CH(M,IDO,1,K) = (HSQT2* (CC(M,IDO,K,2)-CC(M,IDO,K,4))) +
     +                        CC(M,IDO,K,1)
              CH(M,IDO,3,K) = CC(M,IDO,K,1) -
     +                        (HSQT2* (CC(M,IDO,K,2)-CC(M,IDO,K,4)))
              CH(M,1,2,K) = (-HSQT2* (CC(M,IDO,K,2)+CC(M,IDO,K,4))) -
     +                      CC(M,IDO,K,3)
              CH(M,1,4,K) = (-HSQT2* (CC(M,IDO,K,2)+CC(M,IDO,K,4))) +
     +                      CC(M,IDO,K,3)
 1006     CONTINUE
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE DHRADF2(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
c
c     a multiple fft package for spherepack
c
      DIMENSION CH(MDIMCH,IDO,2,L1),CC(MDIMCC,IDO,L1,2),WA1(IDO)

      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,1,K) = CC(M,1,K,1) + CC(M,1,K,2)
              CH(M,IDO,2,K) = CC(M,1,K,1) - CC(M,1,K,2)
 1001     CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO + 2
      DO 104 K = 1,L1
          DO 103 I = 3,IDO,2
              IC = IDP2 - I
              DO 1003 M = 1,MP
                  CH(M,I,1,K) = CC(M,I,K,1) +
     +                          (WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     +                          CC(M,I-1,K,2))
                  CH(M,IC,2,K) = (WA1(I-2)*CC(M,I,K,2)-
     +                           WA1(I-1)*CC(M,I-1,K,2)) - CC(M,I,K,1)
                  CH(M,I-1,1,K) = CC(M,I-1,K,1) +
     +                            (WA1(I-2)*CC(M,I-1,K,2)+
     +                            WA1(I-1)*CC(M,I,K,2))
                  CH(M,IC-1,2,K) = CC(M,I-1,K,1) -
     +                             (WA1(I-2)*CC(M,I-1,K,2)+
     +                             WA1(I-1)*CC(M,I,K,2))
 1003         CONTINUE
  103     CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2).EQ.1) RETURN
  105 DO 106 K = 1,L1
          DO 1006 M = 1,MP
              CH(M,1,2,K) = -CC(M,IDO,K,2)
              CH(M,IDO,1,K) = CC(M,IDO,K,1)
 1006     CONTINUE
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE DHRADF3(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1,WA2)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION TAUR
      DOUBLE PRECISION TAUI
c
c     a multiple fft package for spherepack
c
      DIMENSION CH(MDIMCH,IDO,3,L1),CC(MDIMCC,IDO,L1,3),WA1(IDO),
     +          WA2(IDO)

      ARG = 2.D0*DPIMACH()/3.D0
      TAUR = COS(ARG)
      TAUI = SIN(ARG)
      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,1,K) = CC(M,1,K,1) + (CC(M,1,K,2)+CC(M,1,K,3))
              CH(M,1,3,K) = TAUI* (CC(M,1,K,3)-CC(M,1,K,2))
              CH(M,IDO,2,K) = CC(M,1,K,1) +
     +                        TAUR* (CC(M,1,K,2)+CC(M,1,K,3))
 1001     CONTINUE
  101 CONTINUE
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO 103 K = 1,L1
          DO 102 I = 3,IDO,2
              IC = IDP2 - I
              DO 1002 M = 1,MP
                  CH(M,I-1,1,K) = CC(M,I-1,K,1) +
     +                            ((WA1(I-2)*CC(M,I-1,K,2)+WA1(I-
     +                            1)*CC(M,I,K,2))+ (WA2(I-2)*CC(M,I-1,K,
     +                            3)+WA2(I-1)*CC(M,I,K,3)))
                  CH(M,I,1,K) = CC(M,I,K,1) +
     +                          ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,
     +                          I-1,K,2))+ (WA2(I-2)*CC(M,I,K,
     +                          3)-WA2(I-1)*CC(M,I-1,K,3)))
                  CH(M,I-1,3,K) = (CC(M,I-1,K,1)+
     +                            TAUR* ((WA1(I-2)*CC(M,I-1,K,
     +                            2)+WA1(I-1)*CC(M,I,K,
     +                            2))+ (WA2(I-2)*CC(M,I-1,K,
     +                            3)+WA2(I-1)*CC(M,I,K,3)))) +
     +                            (TAUI* ((WA1(I-2)*CC(M,I,K,
     +                            2)-WA1(I-1)*CC(M,I-1,K,
     +                            2))- (WA2(I-2)*CC(M,I,K,
     +                            3)-WA2(I-1)*CC(M,I-1,K,3))))
                  CH(M,IC-1,2,K) = (CC(M,I-1,K,1)+
     +                             TAUR* ((WA1(I-2)*CC(M,I-1,K,
     +                             2)+WA1(I-1)*CC(M,I,K,
     +                             2))+ (WA2(I-2)*CC(M,I-1,K,
     +                             3)+WA2(I-1)*CC(M,I,K,3)))) -
     +                             (TAUI* ((WA1(I-2)*CC(M,I,K,
     +                             2)-WA1(I-1)*CC(M,I-1,K,
     +                             2))- (WA2(I-2)*CC(M,I,K,
     +                             3)-WA2(I-1)*CC(M,I-1,K,3))))
                  CH(M,I,3,K) = (CC(M,I,K,1)+
     +                          TAUR* ((WA1(I-2)*CC(M,I,K,2)-WA1(I-
     +                          1)*CC(M,I-1,K,2))+ (WA2(I-2)*CC(M,I,K,
     +                          3)-WA2(I-1)*CC(M,I-1,K,3)))) +
     +                          (TAUI* ((WA2(I-2)*CC(M,I-1,K,
     +                          3)+WA2(I-1)*CC(M,I,K,
     +                          3))- (WA1(I-2)*CC(M,I-1,K,
     +                          2)+WA1(I-1)*CC(M,I,K,2))))
                  CH(M,IC,2,K) = (TAUI* ((WA2(I-2)*CC(M,I-1,K,
     +                           3)+WA2(I-1)*CC(M,I,K,
     +                           3))- (WA1(I-2)*CC(M,I-1,K,
     +                           2)+WA1(I-1)*CC(M,I,K,2)))) -
     +                           (CC(M,I,K,1)+TAUR* ((WA1(I-2)*CC(M,I,K,
     +                           2)-WA1(I-1)*CC(M,I-1,K,
     +                           2))+ (WA2(I-2)*CC(M,I,K,
     +                           3)-WA2(I-1)*CC(M,I-1,K,3))))
 1002         CONTINUE
  102     CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE DHRADF5(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1,WA2,WA3,WA4)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION WA4
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION TR11
      DOUBLE PRECISION TI11
      DOUBLE PRECISION TR12
      DOUBLE PRECISION TI12
c
c     a multiple fft package for spherepack
c
      DIMENSION CC(MDIMCC,IDO,L1,5),CH(MDIMCH,IDO,5,L1),WA1(IDO),
     +          WA2(IDO),WA3(IDO),WA4(IDO)

      ARG = 2.D0*DPIMACH()/5.D0
      TR11 = COS(ARG)
      TI11 = SIN(ARG)
      TR12 = COS(2.D0*ARG)
      TI12 = SIN(2.D0*ARG)
      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,1,K) = CC(M,1,K,1) + (CC(M,1,K,5)+CC(M,1,K,2)) +
     +                      (CC(M,1,K,4)+CC(M,1,K,3))
              CH(M,IDO,2,K) = CC(M,1,K,1) +
     +                        TR11* (CC(M,1,K,5)+CC(M,1,K,2)) +
     +                        TR12* (CC(M,1,K,4)+CC(M,1,K,3))
              CH(M,1,3,K) = TI11* (CC(M,1,K,5)-CC(M,1,K,2)) +
     +                      TI12* (CC(M,1,K,4)-CC(M,1,K,3))
              CH(M,IDO,4,K) = CC(M,1,K,1) +
     +                        TR12* (CC(M,1,K,5)+CC(M,1,K,2)) +
     +                        TR11* (CC(M,1,K,4)+CC(M,1,K,3))
              CH(M,1,5,K) = TI12* (CC(M,1,K,5)-CC(M,1,K,2)) -
     +                      TI11* (CC(M,1,K,4)-CC(M,1,K,3))
 1001     CONTINUE
  101 CONTINUE
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO 103 K = 1,L1
          DO 102 I = 3,IDO,2
              IC = IDP2 - I
              DO 1002 M = 1,MP
                  CH(M,I-1,1,K) = CC(M,I-1,K,1) +
     +                            ((WA1(I-2)*CC(M,I-1,K,2)+WA1(I-
     +                            1)*CC(M,I,K,2))+ (WA4(I-2)*CC(M,I-1,K,
     +                            5)+WA4(I-1)*CC(M,I,K,5))) +
     +                            ((WA2(I-2)*CC(M,I-1,K,
     +                            3)+WA2(I-1)*CC(M,I,K,3))+
     +                            (WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,
     +                            I,K,4)))
                  CH(M,I,1,K) = CC(M,I,K,1) +
     +                          ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,
     +                          I-1,K,2))+ (WA4(I-2)*CC(M,I,K,
     +                          5)-WA4(I-1)*CC(M,I-1,K,5))) +
     +                          ((WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*CC(M,
     +                          I-1,K,3))+ (WA3(I-2)*CC(M,I,K,
     +                          4)-WA3(I-1)*CC(M,I-1,K,4)))
                  CH(M,I-1,3,K) = CC(M,I-1,K,1) +
     +                            TR11* (WA1(I-2)*CC(M,I-1,K,2)+
     +                            WA1(I-1)*CC(M,I,K,2)+
     +                            WA4(I-2)*CC(M,I-1,K,5)+
     +                            WA4(I-1)*CC(M,I,K,5)) +
     +                            TR12* (WA2(I-2)*CC(M,I-1,K,3)+
     +                            WA2(I-1)*CC(M,I,K,3)+
     +                            WA3(I-2)*CC(M,I-1,K,4)+
     +                            WA3(I-1)*CC(M,I,K,4)) +
     +                            TI11* (WA1(I-2)*CC(M,I,K,2)-
     +                            WA1(I-1)*CC(M,I-1,K,2)-
     +                            (WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*CC(M,
     +                            I-1,K,5))) + TI12*
     +                            (WA2(I-2)*CC(M,I,K,3)-
     +                            WA2(I-1)*CC(M,I-1,K,3)-
     +                            (WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*CC(M,
     +                            I-1,K,4)))
                  CH(M,IC-1,2,K) = CC(M,I-1,K,1) +
     +                             TR11* (WA1(I-2)*CC(M,I-1,K,2)+
     +                             WA1(I-1)*CC(M,I,K,2)+
     +                             WA4(I-2)*CC(M,I-1,K,5)+
     +                             WA4(I-1)*CC(M,I,K,5)) +
     +                             TR12* (WA2(I-2)*CC(M,I-1,K,3)+
     +                             WA2(I-1)*CC(M,I,K,3)+
     +                             WA3(I-2)*CC(M,I-1,K,4)+
     +                             WA3(I-1)*CC(M,I,K,4)) -
     +                             (TI11* (WA1(I-2)*CC(M,I,K,
     +                             2)-WA1(I-1)*CC(M,I-1,K,
     +                             2)- (WA4(I-2)*CC(M,I,K,
     +                             5)-WA4(I-1)*CC(M,I-1,K,5)))+
     +                             TI12* (WA2(I-2)*CC(M,I,K,
     +                             3)-WA2(I-1)*CC(M,I-1,K,
     +                             3)- (WA3(I-2)*CC(M,I,K,
     +                             4)-WA3(I-1)*CC(M,I-1,K,4))))
                  CH(M,I,3,K) = (CC(M,I,K,1)+
     +                          TR11* ((WA1(I-2)*CC(M,I,K,2)-WA1(I-
     +                          1)*CC(M,I-1,K,2))+ (WA4(I-2)*CC(M,I,K,
     +                          5)-WA4(I-1)*CC(M,I-1,K,5)))+
     +                          TR12* ((WA2(I-2)*CC(M,I,K,
     +                          3)-WA2(I-1)*CC(M,I-1,K,
     +                          3))+ (WA3(I-2)*CC(M,I,K,
     +                          4)-WA3(I-1)*CC(M,I-1,K,4)))) +
     +                          (TI11* ((WA4(I-2)*CC(M,I-1,K,
     +                          5)+WA4(I-1)*CC(M,I,K,
     +                          5))- (WA1(I-2)*CC(M,I-1,K,
     +                          2)+WA1(I-1)*CC(M,I,K,2)))+
     +                          TI12* ((WA3(I-2)*CC(M,I-1,K,
     +                          4)+WA3(I-1)*CC(M,I,K,
     +                          4))- (WA2(I-2)*CC(M,I-1,K,
     +                          3)+WA2(I-1)*CC(M,I,K,3))))
                  CH(M,IC,2,K) = (TI11* ((WA4(I-2)*CC(M,I-1,K,
     +                           5)+WA4(I-1)*CC(M,I,K,
     +                           5))- (WA1(I-2)*CC(M,I-1,K,
     +                           2)+WA1(I-1)*CC(M,I,K,2)))+
     +                           TI12* ((WA3(I-2)*CC(M,I-1,K,
     +                           4)+WA3(I-1)*CC(M,I,K,
     +                           4))- (WA2(I-2)*CC(M,I-1,K,
     +                           3)+WA2(I-1)*CC(M,I,K,3)))) -
     +                           (CC(M,I,K,1)+TR11* ((WA1(I-2)*CC(M,I,K,
     +                           2)-WA1(I-1)*CC(M,I-1,K,
     +                           2))+ (WA4(I-2)*CC(M,I,K,
     +                           5)-WA4(I-1)*CC(M,I-1,K,5)))+
     +                           TR12* ((WA2(I-2)*CC(M,I,K,
     +                           3)-WA2(I-1)*CC(M,I-1,K,
     +                           3))+ (WA3(I-2)*CC(M,I,K,
     +                           4)-WA3(I-1)*CC(M,I-1,K,4))))
                  CH(M,I-1,5,K) = (CC(M,I-1,K,1)+
     +                            TR12* ((WA1(I-2)*CC(M,I-1,K,
     +                            2)+WA1(I-1)*CC(M,I,K,
     +                            2))+ (WA4(I-2)*CC(M,I-1,K,
     +                            5)+WA4(I-1)*CC(M,I,K,5)))+
     +                            TR11* ((WA2(I-2)*CC(M,I-1,K,
     +                            3)+WA2(I-1)*CC(M,I,K,
     +                            3))+ (WA3(I-2)*CC(M,I-1,K,
     +                            4)+WA3(I-1)*CC(M,I,K,4)))) +
     +                            (TI12* ((WA1(I-2)*CC(M,I,K,
     +                            2)-WA1(I-1)*CC(M,I-1,K,
     +                            2))- (WA4(I-2)*CC(M,I,K,
     +                            5)-WA4(I-1)*CC(M,I-1,K,5)))-
     +                            TI11* ((WA2(I-2)*CC(M,I,K,
     +                            3)-WA2(I-1)*CC(M,I-1,K,
     +                            3))- (WA3(I-2)*CC(M,I,K,
     +                            4)-WA3(I-1)*CC(M,I-1,K,4))))
                  CH(M,IC-1,4,K) = (CC(M,I-1,K,1)+
     +                             TR12* ((WA1(I-2)*CC(M,I-1,K,
     +                             2)+WA1(I-1)*CC(M,I,K,
     +                             2))+ (WA4(I-2)*CC(M,I-1,K,
     +                             5)+WA4(I-1)*CC(M,I,K,5)))+
     +                             TR11* ((WA2(I-2)*CC(M,I-1,K,
     +                             3)+WA2(I-1)*CC(M,I,K,
     +                             3))+ (WA3(I-2)*CC(M,I-1,K,
     +                             4)+WA3(I-1)*CC(M,I,K,4)))) -
     +                             (TI12* ((WA1(I-2)*CC(M,I,K,
     +                             2)-WA1(I-1)*CC(M,I-1,K,
     +                             2))- (WA4(I-2)*CC(M,I,K,
     +                             5)-WA4(I-1)*CC(M,I-1,K,5)))-
     +                             TI11* ((WA2(I-2)*CC(M,I,K,
     +                             3)-WA2(I-1)*CC(M,I-1,K,
     +                             3))- (WA3(I-2)*CC(M,I,K,
     +                             4)-WA3(I-1)*CC(M,I-1,K,4))))
                  CH(M,I,5,K) = (CC(M,I,K,1)+
     +                          TR12* ((WA1(I-2)*CC(M,I,K,2)-WA1(I-
     +                          1)*CC(M,I-1,K,2))+ (WA4(I-2)*CC(M,I,K,
     +                          5)-WA4(I-1)*CC(M,I-1,K,5)))+
     +                          TR11* ((WA2(I-2)*CC(M,I,K,
     +                          3)-WA2(I-1)*CC(M,I-1,K,
     +                          3))+ (WA3(I-2)*CC(M,I,K,
     +                          4)-WA3(I-1)*CC(M,I-1,K,4)))) +
     +                          (TI12* ((WA4(I-2)*CC(M,I-1,K,
     +                          5)+WA4(I-1)*CC(M,I,K,
     +                          5))- (WA1(I-2)*CC(M,I-1,K,
     +                          2)+WA1(I-1)*CC(M,I,K,2)))-
     +                          TI11* ((WA3(I-2)*CC(M,I-1,K,
     +                          4)+WA3(I-1)*CC(M,I,K,
     +                          4))- (WA2(I-2)*CC(M,I-1,K,
     +                          3)+WA2(I-1)*CC(M,I,K,3))))
                  CH(M,IC,4,K) = (TI12* ((WA4(I-2)*CC(M,I-1,K,
     +                           5)+WA4(I-1)*CC(M,I,K,
     +                           5))- (WA1(I-2)*CC(M,I-1,K,
     +                           2)+WA1(I-1)*CC(M,I,K,2)))-
     +                           TI11* ((WA3(I-2)*CC(M,I-1,K,
     +                           4)+WA3(I-1)*CC(M,I,K,
     +                           4))- (WA2(I-2)*CC(M,I-1,K,
     +                           3)+WA2(I-1)*CC(M,I,K,3)))) -
     +                           (CC(M,I,K,1)+TR12* ((WA1(I-2)*CC(M,I,K,
     +                           2)-WA1(I-1)*CC(M,I-1,K,
     +                           2))+ (WA4(I-2)*CC(M,I,K,
     +                           5)-WA4(I-1)*CC(M,I-1,K,5)))+
     +                           TR11* ((WA2(I-2)*CC(M,I,K,
     +                           3)-WA2(I-1)*CC(M,I-1,K,
     +                           3))+ (WA3(I-2)*CC(M,I,K,
     +                           4)-WA3(I-1)*CC(M,I-1,K,4))))
 1002         CONTINUE
  102     CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE DHRADFG(MP,IDO,IP,L1,IDL1,CC,C1,C2,MDIMCC,CH,CH2,
     +                   MDIMCH,WA)
      DOUBLE PRECISION CC
      DOUBLE PRECISION C1
      DOUBLE PRECISION C2
      DOUBLE PRECISION CH
      DOUBLE PRECISION CH2
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DCP
      DOUBLE PRECISION DSP
      DOUBLE PRECISION AR1
      DOUBLE PRECISION AI1
      DOUBLE PRECISION AR1H
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION AR2
      DOUBLE PRECISION AI2
      DOUBLE PRECISION AR2H
c
c     a multiple fft package for spherepack
c
      DIMENSION CH(MDIMCH,IDO,L1,IP),CC(MDIMCC,IDO,IP,L1),
     +          C1(MDIMCC,IDO,L1,IP),C2(MDIMCC,IDL1,IP),
     +          CH2(MDIMCH,IDL1,IP),WA(IDO)

      TPI = 2.D0*DPIMACH()
      ARG = TPI/DBLE(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP + 2
      IDP2 = IDO + 2
      NBD = (IDO-1)/2
      IF (IDO.EQ.1) GO TO 119
      DO 101 IK = 1,IDL1
          DO 1001 M = 1,MP
              CH2(M,IK,1) = C2(M,IK,1)
 1001     CONTINUE
  101 CONTINUE
      DO 103 J = 2,IP
          DO 102 K = 1,L1
              DO 1002 M = 1,MP
                  CH(M,1,K,J) = C1(M,1,K,J)
 1002         CONTINUE
  102     CONTINUE
  103 CONTINUE
      IF (NBD.GT.L1) GO TO 107
      IS = -IDO
      DO 106 J = 2,IP
          IS = IS + IDO
          IDIJ = IS
          DO 105 I = 3,IDO,2
              IDIJ = IDIJ + 2
              DO 104 K = 1,L1
                  DO 1004 M = 1,MP
                      CH(M,I-1,K,J) = WA(IDIJ-1)*C1(M,I-1,K,J) +
     +                                WA(IDIJ)*C1(M,I,K,J)
                      CH(M,I,K,J) = WA(IDIJ-1)*C1(M,I,K,J) -
     +                              WA(IDIJ)*C1(M,I-1,K,J)
 1004             CONTINUE
  104         CONTINUE
  105     CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J = 2,IP
          IS = IS + IDO
          DO 109 K = 1,L1
              IDIJ = IS
              DO 108 I = 3,IDO,2
                  IDIJ = IDIJ + 2
                  DO 1008 M = 1,MP
                      CH(M,I-1,K,J) = WA(IDIJ-1)*C1(M,I-1,K,J) +
     +                                WA(IDIJ)*C1(M,I,K,J)
                      CH(M,I,K,J) = WA(IDIJ-1)*C1(M,I,K,J) -
     +                              WA(IDIJ)*C1(M,I-1,K,J)
 1008             CONTINUE
  108         CONTINUE
  109     CONTINUE
  110 CONTINUE
  111 IF (NBD.LT.L1) GO TO 115
      DO 114 J = 2,IPPH
          JC = IPP2 - J
          DO 113 K = 1,L1
              DO 112 I = 3,IDO,2
                  DO 1012 M = 1,MP
                      C1(M,I-1,K,J) = CH(M,I-1,K,J) + CH(M,I-1,K,JC)
                      C1(M,I-1,K,JC) = CH(M,I,K,J) - CH(M,I,K,JC)
                      C1(M,I,K,J) = CH(M,I,K,J) + CH(M,I,K,JC)
                      C1(M,I,K,JC) = CH(M,I-1,K,JC) - CH(M,I-1,K,J)
 1012             CONTINUE
  112         CONTINUE
  113     CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J = 2,IPPH
          JC = IPP2 - J
          DO 117 I = 3,IDO,2
              DO 116 K = 1,L1
                  DO 1016 M = 1,MP
                      C1(M,I-1,K,J) = CH(M,I-1,K,J) + CH(M,I-1,K,JC)
                      C1(M,I-1,K,JC) = CH(M,I,K,J) - CH(M,I,K,JC)
                      C1(M,I,K,J) = CH(M,I,K,J) + CH(M,I,K,JC)
                      C1(M,I,K,JC) = CH(M,I-1,K,JC) - CH(M,I-1,K,J)
 1016             CONTINUE
  116         CONTINUE
  117     CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK = 1,IDL1
          DO 1020 M = 1,MP
              C2(M,IK,1) = CH2(M,IK,1)
 1020     CONTINUE
  120 CONTINUE
  121 DO 123 J = 2,IPPH
          JC = IPP2 - J
          DO 122 K = 1,L1
              DO 1022 M = 1,MP
                  C1(M,1,K,J) = CH(M,1,K,J) + CH(M,1,K,JC)
                  C1(M,1,K,JC) = CH(M,1,K,JC) - CH(M,1,K,J)
 1022         CONTINUE
  122     CONTINUE
  123 CONTINUE
c
      AR1 = 1.D0
      AI1 = 0.D0
      DO 127 L = 2,IPPH
          LC = IPP2 - L
          AR1H = DCP*AR1 - DSP*AI1
          AI1 = DCP*AI1 + DSP*AR1
          AR1 = AR1H
          DO 124 IK = 1,IDL1
              DO 1024 M = 1,MP
                  CH2(M,IK,L) = C2(M,IK,1) + AR1*C2(M,IK,2)
                  CH2(M,IK,LC) = AI1*C2(M,IK,IP)
 1024         CONTINUE
  124     CONTINUE
          DC2 = AR1
          DS2 = AI1
          AR2 = AR1
          AI2 = AI1
          DO 126 J = 3,IPPH
              JC = IPP2 - J
              AR2H = DC2*AR2 - DS2*AI2
              AI2 = DC2*AI2 + DS2*AR2
              AR2 = AR2H
              DO 125 IK = 1,IDL1
                  DO 1025 M = 1,MP
                      CH2(M,IK,L) = CH2(M,IK,L) + AR2*C2(M,IK,J)
                      CH2(M,IK,LC) = CH2(M,IK,LC) + AI2*C2(M,IK,JC)
 1025             CONTINUE
  125         CONTINUE
  126     CONTINUE
  127 CONTINUE
      DO 129 J = 2,IPPH
          DO 128 IK = 1,IDL1
              DO 1028 M = 1,MP
                  CH2(M,IK,1) = CH2(M,IK,1) + C2(M,IK,J)
 1028         CONTINUE
  128     CONTINUE
  129 CONTINUE
c
      IF (IDO.LT.L1) GO TO 132
      DO 131 K = 1,L1
          DO 130 I = 1,IDO
              DO 1030 M = 1,MP
                  CC(M,I,1,K) = CH(M,I,K,1)
 1030         CONTINUE
  130     CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I = 1,IDO
          DO 133 K = 1,L1
              DO 1033 M = 1,MP
                  CC(M,I,1,K) = CH(M,I,K,1)
 1033         CONTINUE
  133     CONTINUE
  134 CONTINUE
  135 DO 137 J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO 136 K = 1,L1
              DO 1036 M = 1,MP
                  CC(M,IDO,J2-2,K) = CH(M,1,K,J)
                  CC(M,1,J2-1,K) = CH(M,1,K,JC)
 1036         CONTINUE
  136     CONTINUE
  137 CONTINUE
      IF (IDO.EQ.1) RETURN
      IF (NBD.LT.L1) GO TO 141
      DO 140 J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO 139 K = 1,L1
              DO 138 I = 3,IDO,2
                  IC = IDP2 - I
                  DO 1038 M = 1,MP
                      CC(M,I-1,J2-1,K) = CH(M,I-1,K,J) + CH(M,I-1,K,JC)
                      CC(M,IC-1,J2-2,K) = CH(M,I-1,K,J) - CH(M,I-1,K,JC)
                      CC(M,I,J2-1,K) = CH(M,I,K,J) + CH(M,I,K,JC)
                      CC(M,IC,J2-2,K) = CH(M,I,K,JC) - CH(M,I,K,J)
 1038             CONTINUE
  138         CONTINUE
  139     CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO 143 I = 3,IDO,2
              IC = IDP2 - I
              DO 142 K = 1,L1
                  DO 1042 M = 1,MP
                      CC(M,I-1,J2-1,K) = CH(M,I-1,K,J) + CH(M,I-1,K,JC)
                      CC(M,IC-1,J2-2,K) = CH(M,I-1,K,J) - CH(M,I-1,K,JC)
                      CC(M,I,J2-1,K) = CH(M,I,K,J) + CH(M,I,K,JC)
                      CC(M,IC,J2-2,K) = CH(M,I,K,JC) - CH(M,I,K,J)
 1042             CONTINUE
  142         CONTINUE
  143     CONTINUE
  144 CONTINUE
      RETURN
      END
      FUNCTION DPIMACH()
      DOUBLE PRECISION DPIMACH

      DPIMACH = 3.14159265358979D0
      RETURN
      END
      SUBROUTINE DHRFFTB(M,N,R,MDIMR,WHRFFT,WORK)
      DOUBLE PRECISION R
      DOUBLE PRECISION WHRFFT
      DOUBLE PRECISION WORK
      DOUBLE PRECISION TFFT
c
c     a multiple fft package for spherepack
c
      DIMENSION R(MDIMR,N),WORK(1),WHRFFT(N+15)
      COMMON /HRF/TFFT

      IF (N.EQ.1) RETURN
c     tstart = second(dum)
      CALL DHRFTB1(M,N,R,MDIMR,WORK,WHRFFT,WHRFFT(N+1))
c     tfft = tfft+second(dum)-tstart
      RETURN
      END
      SUBROUTINE DHRFTB1(M,N,C,MDIMC,CH,WA,FAC)
      DOUBLE PRECISION C
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA
      DOUBLE PRECISION FAC
c
c     a multiple fft package for spherepack
c
      DIMENSION CH(M,N),C(MDIMC,N),WA(N),FAC(15)

      NF = FAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1 = 1,NF
          IP = FAC(K1+2)
          L2 = IP*L1
          IDO = N/L2
          IDL1 = IDO*L1
          IF (IP.NE.4) GO TO 103
          IX2 = IW + IDO
          IX3 = IX2 + IDO
          IF (NA.NE.0) GO TO 101
          CALL DHRADB4(M,IDO,L1,C,MDIMC,CH,M,WA(IW),WA(IX2),WA(IX3))
          GO TO 102
  101     CALL DHRADB4(M,IDO,L1,CH,M,C,MDIMC,WA(IW),WA(IX2),WA(IX3))
  102     NA = 1 - NA
          GO TO 115
  103     IF (IP.NE.2) GO TO 106
          IF (NA.NE.0) GO TO 104
          CALL DHRADB2(M,IDO,L1,C,MDIMC,CH,M,WA(IW))
          GO TO 105
  104     CALL DHRADB2(M,IDO,L1,CH,M,C,MDIMC,WA(IW))
  105     NA = 1 - NA
          GO TO 115
  106     IF (IP.NE.3) GO TO 109
          IX2 = IW + IDO
          IF (NA.NE.0) GO TO 107
          CALL DHRADB3(M,IDO,L1,C,MDIMC,CH,M,WA(IW),WA(IX2))
          GO TO 108
  107     CALL DHRADB3(M,IDO,L1,CH,M,C,MDIMC,WA(IW),WA(IX2))
  108     NA = 1 - NA
          GO TO 115
  109     IF (IP.NE.5) GO TO 112
          IX2 = IW + IDO
          IX3 = IX2 + IDO
          IX4 = IX3 + IDO
          IF (NA.NE.0) GO TO 110
          CALL DHRADB5(M,IDO,L1,C,MDIMC,CH,M,WA(IW),WA(IX2),WA(IX3),
     +                WA(IX4))
          GO TO 111
  110     CALL DHRADB5(M,IDO,L1,CH,M,C,MDIMC,WA(IW),WA(IX2),WA(IX3),
     +                WA(IX4))
  111     NA = 1 - NA
          GO TO 115
  112     IF (NA.NE.0) GO TO 113
          CALL DHRADBG(M,IDO,IP,L1,IDL1,C,C,C,MDIMC,CH,CH,M,WA(IW))
          GO TO 114
  113     CALL DHRADBG(M,IDO,IP,L1,IDL1,CH,CH,CH,M,C,C,MDIMC,WA(IW))
  114     IF (IDO.EQ.1) NA = 1 - NA
  115     L1 = L2
          IW = IW + (IP-1)*IDO
  116 CONTINUE
      IF (NA.EQ.0) RETURN
      DO 117 J = 1,N
          DO 117 I = 1,M
              C(I,J) = CH(I,J)
  117 CONTINUE
      RETURN
      END
      SUBROUTINE DHRADBG(MP,IDO,IP,L1,IDL1,CC,C1,C2,MDIMCC,CH,CH2,
     +                   MDIMCH,WA)
      DOUBLE PRECISION CC
      DOUBLE PRECISION C1
      DOUBLE PRECISION C2
      DOUBLE PRECISION CH
      DOUBLE PRECISION CH2
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DCP
      DOUBLE PRECISION DSP
      DOUBLE PRECISION AR1
      DOUBLE PRECISION AI1
      DOUBLE PRECISION AR1H
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION AR2
      DOUBLE PRECISION AI2
      DOUBLE PRECISION AR2H
c
c     a multiple fft package for spherepack
c
      DIMENSION CH(MDIMCH,IDO,L1,IP),CC(MDIMCC,IDO,IP,L1),
     +          C1(MDIMCC,IDO,L1,IP),C2(MDIMCC,IDL1,IP),
     +          CH2(MDIMCH,IDL1,IP),WA(IDO)

      TPI = 2.D0*DPIMACH()
      ARG = TPI/DBLE(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IDP2 = IDO + 2
      NBD = (IDO-1)/2
      IPP2 = IP + 2
      IPPH = (IP+1)/2
      IF (IDO.LT.L1) GO TO 103
      DO 102 K = 1,L1
          DO 101 I = 1,IDO
              DO 1001 M = 1,MP
                  CH(M,I,K,1) = CC(M,I,1,K)
 1001         CONTINUE
  101     CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I = 1,IDO
          DO 104 K = 1,L1
              DO 1004 M = 1,MP
                  CH(M,I,K,1) = CC(M,I,1,K)
 1004         CONTINUE
  104     CONTINUE
  105 CONTINUE
  106 DO 108 J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO 107 K = 1,L1
              DO 1007 M = 1,MP
                  CH(M,1,K,J) = CC(M,IDO,J2-2,K) + CC(M,IDO,J2-2,K)
                  CH(M,1,K,JC) = CC(M,1,J2-1,K) + CC(M,1,J2-1,K)
 1007         CONTINUE
  107     CONTINUE
  108 CONTINUE
      IF (IDO.EQ.1) GO TO 116
      IF (NBD.LT.L1) GO TO 112
      DO 111 J = 2,IPPH
          JC = IPP2 - J
          DO 110 K = 1,L1
              DO 109 I = 3,IDO,2
                  IC = IDP2 - I
                  DO 1009 M = 1,MP
                      CH(M,I-1,K,J) = CC(M,I-1,2*J-1,K) +
     +                                CC(M,IC-1,2*J-2,K)
                      CH(M,I-1,K,JC) = CC(M,I-1,2*J-1,K) -
     +                                 CC(M,IC-1,2*J-2,K)
                      CH(M,I,K,J) = CC(M,I,2*J-1,K) - CC(M,IC,2*J-2,K)
                      CH(M,I,K,JC) = CC(M,I,2*J-1,K) + CC(M,IC,2*J-2,K)
 1009             CONTINUE
  109         CONTINUE
  110     CONTINUE
  111 CONTINUE
      GO TO 116
  112 DO 115 J = 2,IPPH
          JC = IPP2 - J
          DO 114 I = 3,IDO,2
              IC = IDP2 - I
              DO 113 K = 1,L1
                  DO 1013 M = 1,MP
                      CH(M,I-1,K,J) = CC(M,I-1,2*J-1,K) +
     +                                CC(M,IC-1,2*J-2,K)
                      CH(M,I-1,K,JC) = CC(M,I-1,2*J-1,K) -
     +                                 CC(M,IC-1,2*J-2,K)
                      CH(M,I,K,J) = CC(M,I,2*J-1,K) - CC(M,IC,2*J-2,K)
                      CH(M,I,K,JC) = CC(M,I,2*J-1,K) + CC(M,IC,2*J-2,K)
 1013             CONTINUE
  113         CONTINUE
  114     CONTINUE
  115 CONTINUE
  116 AR1 = 1.D0
      AI1 = 0.D0
      DO 120 L = 2,IPPH
          LC = IPP2 - L
          AR1H = DCP*AR1 - DSP*AI1
          AI1 = DCP*AI1 + DSP*AR1
          AR1 = AR1H
          DO 117 IK = 1,IDL1
              DO 1017 M = 1,MP
                  C2(M,IK,L) = CH2(M,IK,1) + AR1*CH2(M,IK,2)
                  C2(M,IK,LC) = AI1*CH2(M,IK,IP)
 1017         CONTINUE
  117     CONTINUE
          DC2 = AR1
          DS2 = AI1
          AR2 = AR1
          AI2 = AI1
          DO 119 J = 3,IPPH
              JC = IPP2 - J
              AR2H = DC2*AR2 - DS2*AI2
              AI2 = DC2*AI2 + DS2*AR2
              AR2 = AR2H
              DO 118 IK = 1,IDL1
                  DO 1018 M = 1,MP
                      C2(M,IK,L) = C2(M,IK,L) + AR2*CH2(M,IK,J)
                      C2(M,IK,LC) = C2(M,IK,LC) + AI2*CH2(M,IK,JC)
 1018             CONTINUE
  118         CONTINUE
  119     CONTINUE
  120 CONTINUE
      DO 122 J = 2,IPPH
          DO 121 IK = 1,IDL1
              DO 1021 M = 1,MP
                  CH2(M,IK,1) = CH2(M,IK,1) + CH2(M,IK,J)
 1021         CONTINUE
  121     CONTINUE
  122 CONTINUE
      DO 124 J = 2,IPPH
          JC = IPP2 - J
          DO 123 K = 1,L1
              DO 1023 M = 1,MP
                  CH(M,1,K,J) = C1(M,1,K,J) - C1(M,1,K,JC)
                  CH(M,1,K,JC) = C1(M,1,K,J) + C1(M,1,K,JC)
 1023         CONTINUE
  123     CONTINUE
  124 CONTINUE
      IF (IDO.EQ.1) GO TO 132
      IF (NBD.LT.L1) GO TO 128
      DO 127 J = 2,IPPH
          JC = IPP2 - J
          DO 126 K = 1,L1
              DO 125 I = 3,IDO,2
                  DO 1025 M = 1,MP
                      CH(M,I-1,K,J) = C1(M,I-1,K,J) - C1(M,I,K,JC)
                      CH(M,I-1,K,JC) = C1(M,I-1,K,J) + C1(M,I,K,JC)
                      CH(M,I,K,J) = C1(M,I,K,J) + C1(M,I-1,K,JC)
                      CH(M,I,K,JC) = C1(M,I,K,J) - C1(M,I-1,K,JC)
 1025             CONTINUE
  125         CONTINUE
  126     CONTINUE
  127 CONTINUE
      GO TO 132
  128 DO 131 J = 2,IPPH
          JC = IPP2 - J
          DO 130 I = 3,IDO,2
              DO 129 K = 1,L1
                  DO 1029 M = 1,MP
                      CH(M,I-1,K,J) = C1(M,I-1,K,J) - C1(M,I,K,JC)
                      CH(M,I-1,K,JC) = C1(M,I-1,K,J) + C1(M,I,K,JC)
                      CH(M,I,K,J) = C1(M,I,K,J) + C1(M,I-1,K,JC)
                      CH(M,I,K,JC) = C1(M,I,K,J) - C1(M,I-1,K,JC)
 1029             CONTINUE
  129         CONTINUE
  130     CONTINUE
  131 CONTINUE
  132 CONTINUE
      IF (IDO.EQ.1) RETURN
      DO 133 IK = 1,IDL1
          DO 1033 M = 1,MP
              C2(M,IK,1) = CH2(M,IK,1)
 1033     CONTINUE
  133 CONTINUE
      DO 135 J = 2,IP
          DO 134 K = 1,L1
              DO 1034 M = 1,MP
                  C1(M,1,K,J) = CH(M,1,K,J)
 1034         CONTINUE
  134     CONTINUE
  135 CONTINUE
      IF (NBD.GT.L1) GO TO 139
      IS = -IDO
      DO 138 J = 2,IP
          IS = IS + IDO
          IDIJ = IS
          DO 137 I = 3,IDO,2
              IDIJ = IDIJ + 2
              DO 136 K = 1,L1
                  DO 1036 M = 1,MP
                      C1(M,I-1,K,J) = WA(IDIJ-1)*CH(M,I-1,K,J) -
     +                                WA(IDIJ)*CH(M,I,K,J)
                      C1(M,I,K,J) = WA(IDIJ-1)*CH(M,I,K,J) +
     +                              WA(IDIJ)*CH(M,I-1,K,J)
 1036             CONTINUE
  136         CONTINUE
  137     CONTINUE
  138 CONTINUE
      GO TO 143
  139 IS = -IDO
      DO 142 J = 2,IP
          IS = IS + IDO
          DO 141 K = 1,L1
              IDIJ = IS
              DO 140 I = 3,IDO,2
                  IDIJ = IDIJ + 2
                  DO 1040 M = 1,MP
                      C1(M,I-1,K,J) = WA(IDIJ-1)*CH(M,I-1,K,J) -
     +                                WA(IDIJ)*CH(M,I,K,J)
                      C1(M,I,K,J) = WA(IDIJ-1)*CH(M,I,K,J) +
     +                              WA(IDIJ)*CH(M,I-1,K,J)
 1040             CONTINUE
  140         CONTINUE
  141     CONTINUE
  142 CONTINUE
  143 RETURN
      END
      SUBROUTINE DHRADB4(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1,WA2,WA3)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION SQRT2
c
c     a multiple fft package for spherepack
c
      DIMENSION CC(MDIMCC,IDO,4,L1),CH(MDIMCH,IDO,L1,4),WA1(IDO),
     +          WA2(IDO),WA3(IDO)

      SQRT2 = SQRT(2.D0)
      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,K,3) = (CC(M,1,1,K)+CC(M,IDO,4,K)) -
     +                      (CC(M,IDO,2,K)+CC(M,IDO,2,K))
              CH(M,1,K,1) = (CC(M,1,1,K)+CC(M,IDO,4,K)) +
     +                      (CC(M,IDO,2,K)+CC(M,IDO,2,K))
              CH(M,1,K,4) = (CC(M,1,1,K)-CC(M,IDO,4,K)) +
     +                      (CC(M,1,3,K)+CC(M,1,3,K))
              CH(M,1,K,2) = (CC(M,1,1,K)-CC(M,IDO,4,K)) -
     +                      (CC(M,1,3,K)+CC(M,1,3,K))
 1001     CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO + 2
      DO 104 K = 1,L1
          DO 103 I = 3,IDO,2
              IC = IDP2 - I
              DO 1002 M = 1,MP
                  CH(M,I-1,K,1) = (CC(M,I-1,1,K)+CC(M,IC-1,4,K)) +
     +                            (CC(M,I-1,3,K)+CC(M,IC-1,2,K))
                  CH(M,I,K,1) = (CC(M,I,1,K)-CC(M,IC,4,K)) +
     +                          (CC(M,I,3,K)-CC(M,IC,2,K))
                  CH(M,I-1,K,2) = WA1(I-2)* ((CC(M,I-1,1,K)-CC(M,IC-1,4,
     +                            K))- (CC(M,I,3,K)+CC(M,IC,2,K))) -
     +                            WA1(I-1)* ((CC(M,I,1,K)+CC(M,IC,4,K))+
     +                            (CC(M,I-1,3,K)-CC(M,IC-1,2,K)))
                  CH(M,I,K,2) = WA1(I-2)* ((CC(M,I,1,K)+CC(M,IC,4,K))+
     +                          (CC(M,I-1,3,K)-CC(M,IC-1,2,K))) +
     +                          WA1(I-1)* ((CC(M,I-1,1,K)-CC(M,IC-1,4,
     +                          K))- (CC(M,I,3,K)+CC(M,IC,2,K)))
                  CH(M,I-1,K,3) = WA2(I-2)* ((CC(M,I-1,1,K)+CC(M,IC-1,4,
     +                            K))- (CC(M,I-1,3,K)+CC(M,IC-1,2,K))) -
     +                            WA2(I-1)* ((CC(M,I,1,K)-CC(M,IC,4,K))-
     +                            (CC(M,I,3,K)-CC(M,IC,2,K)))
                  CH(M,I,K,3) = WA2(I-2)* ((CC(M,I,1,K)-CC(M,IC,4,K))-
     +                          (CC(M,I,3,K)-CC(M,IC,2,K))) +
     +                          WA2(I-1)* ((CC(M,I-1,1,K)+CC(M,IC-1,4,
     +                          K))- (CC(M,I-1,3,K)+CC(M,IC-1,2,K)))
                  CH(M,I-1,K,4) = WA3(I-2)* ((CC(M,I-1,1,K)-CC(M,IC-1,4,
     +                            K))+ (CC(M,I,3,K)+CC(M,IC,2,K))) -
     +                            WA3(I-1)* ((CC(M,I,1,K)+CC(M,IC,4,K))-
     +                            (CC(M,I-1,3,K)-CC(M,IC-1,2,K)))
                  CH(M,I,K,4) = WA3(I-2)* ((CC(M,I,1,K)+CC(M,IC,4,K))-
     +                          (CC(M,I-1,3,K)-CC(M,IC-1,2,K))) +
     +                          WA3(I-1)* ((CC(M,I-1,1,K)-CC(M,IC-1,4,
     +                          K))+ (CC(M,I,3,K)+CC(M,IC,2,K)))
 1002         CONTINUE
  103     CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2).EQ.1) RETURN
  105 CONTINUE
      DO 106 K = 1,L1
          DO 1003 M = 1,MP
              CH(M,IDO,K,1) = (CC(M,IDO,1,K)+CC(M,IDO,3,K)) +
     +                        (CC(M,IDO,1,K)+CC(M,IDO,3,K))
              CH(M,IDO,K,2) = SQRT2* ((CC(M,IDO,1,K)-CC(M,IDO,3,K))-
     +                        (CC(M,1,2,K)+CC(M,1,4,K)))
              CH(M,IDO,K,3) = (CC(M,1,4,K)-CC(M,1,2,K)) +
     +                        (CC(M,1,4,K)-CC(M,1,2,K))
              CH(M,IDO,K,4) = -SQRT2* ((CC(M,IDO,1,K)-CC(M,IDO,3,K))+
     +                        (CC(M,1,2,K)+CC(M,1,4,K)))
 1003     CONTINUE
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE DHRADB2(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
c
c     a multiple fft package for spherepack
c
      DIMENSION CC(MDIMCC,IDO,2,L1),CH(MDIMCH,IDO,L1,2),WA1(IDO)

      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,K,1) = CC(M,1,1,K) + CC(M,IDO,2,K)
              CH(M,1,K,2) = CC(M,1,1,K) - CC(M,IDO,2,K)
 1001     CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO + 2
      DO 104 K = 1,L1
          DO 103 I = 3,IDO,2
              IC = IDP2 - I
              DO 1002 M = 1,MP
                  CH(M,I-1,K,1) = CC(M,I-1,1,K) + CC(M,IC-1,2,K)
                  CH(M,I,K,1) = CC(M,I,1,K) - CC(M,IC,2,K)
                  CH(M,I-1,K,2) = WA1(I-2)* (CC(M,I-1,1,K)-
     +                            CC(M,IC-1,2,K)) -
     +                            WA1(I-1)* (CC(M,I,1,K)+CC(M,IC,2,K))
                  CH(M,I,K,2) = WA1(I-2)* (CC(M,I,1,K)+CC(M,IC,2,K)) +
     +                          WA1(I-1)* (CC(M,I-1,1,K)-CC(M,IC-1,2,K))
 1002         CONTINUE
  103     CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2).EQ.1) RETURN
  105 DO 106 K = 1,L1
          DO 1003 M = 1,MP
              CH(M,IDO,K,1) = CC(M,IDO,1,K) + CC(M,IDO,1,K)
              CH(M,IDO,K,2) = - (CC(M,1,2,K)+CC(M,1,2,K))
 1003     CONTINUE
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE DHRADB3(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1,WA2)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION TAUR
      DOUBLE PRECISION TAUI
c
c     a multiple fft package for spherepack
c
      DIMENSION CC(MDIMCC,IDO,3,L1),CH(MDIMCH,IDO,L1,3),WA1(IDO),
     +          WA2(IDO)

      ARG = 2.D0*DPIMACH()/3.D0
      TAUR = COS(ARG)
      TAUI = SIN(ARG)
      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,K,1) = CC(M,1,1,K) + 2.D0*CC(M,IDO,2,K)
              CH(M,1,K,2) = CC(M,1,1,K) + (2.D0*TAUR)*CC(M,IDO,2,K) -
     +                      (2.D0*TAUI)*CC(M,1,3,K)
              CH(M,1,K,3) = CC(M,1,1,K) + (2.D0*TAUR)*CC(M,IDO,2,K) +
     +                      2.D0*TAUI*CC(M,1,3,K)
 1001     CONTINUE
  101 CONTINUE
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO 103 K = 1,L1
          DO 102 I = 3,IDO,2
              IC = IDP2 - I
              DO 1002 M = 1,MP
                  CH(M,I-1,K,1) = CC(M,I-1,1,K) +
     +                            (CC(M,I-1,3,K)+CC(M,IC-1,2,K))
                  CH(M,I,K,1) = CC(M,I,1,K) + (CC(M,I,3,K)-CC(M,IC,2,K))
                  CH(M,I-1,K,2) = WA1(I-2)* ((CC(M,I-1,1,K)+TAUR* (CC(M,
     +                            I-1,3,K)+CC(M,IC-1,2,K)))-
     +                            (TAUI* (CC(M,I,3,K)+CC(M,IC,2,K)))) -
     +                            WA1(I-1)* ((CC(M,I,1,K)+TAUR* (CC(M,I,
     +                            3,K)-CC(M,IC,2,K)))+
     +                            (TAUI* (CC(M,I-1,3,K)-CC(M,IC-1,2,
     +                            K))))
                  CH(M,I,K,2) = WA1(I-2)* ((CC(M,I,1,K)+TAUR* (CC(M,I,3,
     +                          K)-CC(M,IC,2,K)))+ (TAUI* (CC(M,I-1,3,
     +                          K)-CC(M,IC-1,2,K)))) +
     +                          WA1(I-1)* ((CC(M,I-1,1,K)+TAUR* (CC(M,
     +                          I-1,3,K)+CC(M,IC-1,2,K)))-
     +                          (TAUI* (CC(M,I,3,K)+CC(M,IC,2,K))))
                  CH(M,I-1,K,3) = WA2(I-2)* ((CC(M,I-1,1,K)+TAUR* (CC(M,
     +                            I-1,3,K)+CC(M,IC-1,2,K)))+
     +                            (TAUI* (CC(M,I,3,K)+CC(M,IC,2,K)))) -
     +                            WA2(I-1)* ((CC(M,I,1,K)+TAUR* (CC(M,I,
     +                            3,K)-CC(M,IC,2,K)))-
     +                            (TAUI* (CC(M,I-1,3,K)-CC(M,IC-1,2,
     +                            K))))
                  CH(M,I,K,3) = WA2(I-2)* ((CC(M,I,1,K)+TAUR* (CC(M,I,3,
     +                          K)-CC(M,IC,2,K)))- (TAUI* (CC(M,I-1,3,
     +                          K)-CC(M,IC-1,2,K)))) +
     +                          WA2(I-1)* ((CC(M,I-1,1,K)+TAUR* (CC(M,
     +                          I-1,3,K)+CC(M,IC-1,2,K)))+
     +                          (TAUI* (CC(M,I,3,K)+CC(M,IC,2,K))))
 1002         CONTINUE
  102     CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE DHRADB5(MP,IDO,L1,CC,MDIMCC,CH,MDIMCH,WA1,WA2,WA3,WA4)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION WA4
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION TR11
      DOUBLE PRECISION TI11
      DOUBLE PRECISION TR12
      DOUBLE PRECISION TI12
c
c     a multiple fft package for spherepack
c
      DIMENSION CC(MDIMCC,IDO,5,L1),CH(MDIMCH,IDO,L1,5),WA1(IDO),
     +          WA2(IDO),WA3(IDO),WA4(IDO)

      ARG = 2.D0*DPIMACH()/5.D0
      TR11 = COS(ARG)
      TI11 = SIN(ARG)
      TR12 = COS(2.D0*ARG)
      TI12 = SIN(2.D0*ARG)
      DO 101 K = 1,L1
          DO 1001 M = 1,MP
              CH(M,1,K,1) = CC(M,1,1,K) + 2.D0*CC(M,IDO,2,K) +
     +                      2.D0*CC(M,IDO,4,K)
              CH(M,1,K,2) = (CC(M,1,1,K)+TR11*2.D0*CC(M,IDO,2,K)+
     +                      TR12*2.D0*CC(M,IDO,4,K)) -
     +                      (TI11*2.D0*CC(M,1,3,K)+
     +                      TI12*2.D0*CC(M,1,5,K))
              CH(M,1,K,3) = (CC(M,1,1,K)+TR12*2.D0*CC(M,IDO,2,K)+
     +                      TR11*2.D0*CC(M,IDO,4,K)) -
     +                      (TI12*2.D0*CC(M,1,3,K)-
     +                      TI11*2.D0*CC(M,1,5,K))
              CH(M,1,K,4) = (CC(M,1,1,K)+TR12*2.D0*CC(M,IDO,2,K)+
     +                      TR11*2.D0*CC(M,IDO,4,K)) +
     +                      (TI12*2.D0*CC(M,1,3,K)-
     +                      TI11*2.D0*CC(M,1,5,K))
              CH(M,1,K,5) = (CC(M,1,1,K)+TR11*2.D0*CC(M,IDO,2,K)+
     +                      TR12*2.D0*CC(M,IDO,4,K)) +
     +                      (TI11*2.D0*CC(M,1,3,K)+
     +                      TI12*2.D0*CC(M,1,5,K))
 1001     CONTINUE
  101 CONTINUE
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO 103 K = 1,L1
          DO 102 I = 3,IDO,2
              IC = IDP2 - I
              DO 1002 M = 1,MP
                  CH(M,I-1,K,1) = CC(M,I-1,1,K) +
     +                            (CC(M,I-1,3,K)+CC(M,IC-1,2,K)) +
     +                            (CC(M,I-1,5,K)+CC(M,IC-1,4,K))
                  CH(M,I,K,1) = CC(M,I,1,K) +
     +                          (CC(M,I,3,K)-CC(M,IC,2,K)) +
     +                          (CC(M,I,5,K)-CC(M,IC,4,K))
                  CH(M,I-1,K,2) = WA1(I-2)* ((CC(M,I-1,1,K)+TR11* (CC(M,
     +                            I-1,3,K)+CC(M,IC-1,2,K))+TR12* (CC(M,
     +                            I-1,5,K)+CC(M,IC-1,4,K)))-
     +                            (TI11* (CC(M,I,3,K)+CC(M,IC,2,
     +                            K))+TI12* (CC(M,I,5,K)+CC(M,IC,4,K))))
     +                            - WA1(I-1)* ((CC(M,I,1,K)+TR11* (CC(M,
     +                            I,3,K)-CC(M,IC,2,K))+TR12* (CC(M,I,5,
     +                            K)-CC(M,IC,4,K)))+
     +                            (TI11* (CC(M,I-1,3,K)-CC(M,IC-1,2,
     +                            K))+TI12* (CC(M,I-1,5,K)-CC(M,IC-1,4,
     +                            K))))
                  CH(M,I,K,2) = WA1(I-2)* ((CC(M,I,1,K)+TR11* (CC(M,I,3,
     +                          K)-CC(M,IC,2,K))+TR12* (CC(M,I,5,
     +                          K)-CC(M,IC,4,K)))+ (TI11* (CC(M,I-1,3,
     +                          K)-CC(M,IC-1,2,K))+TI12* (CC(M,I-1,5,
     +                          K)-CC(M,IC-1,4,K)))) +
     +                          WA1(I-1)* ((CC(M,I-1,1,K)+TR11* (CC(M,
     +                          I-1,3,K)+CC(M,IC-1,2,K))+TR12* (CC(M,
     +                          I-1,5,K)+CC(M,IC-1,4,K)))-
     +                          (TI11* (CC(M,I,3,K)+CC(M,IC,2,
     +                          K))+TI12* (CC(M,I,5,K)+CC(M,IC,4,K))))
                  CH(M,I-1,K,3) = WA2(I-2)* ((CC(M,I-1,1,K)+TR12* (CC(M,
     +                            I-1,3,K)+CC(M,IC-1,2,K))+TR11* (CC(M,
     +                            I-1,5,K)+CC(M,IC-1,4,K)))-
     +                            (TI12* (CC(M,I,3,K)+CC(M,IC,2,
     +                            K))-TI11* (CC(M,I,5,K)+CC(M,IC,4,K))))
     +                            - WA2(I-1)* ((CC(M,I,1,K)+TR12* (CC(M,
     +                            I,3,K)-CC(M,IC,2,K))+TR11* (CC(M,I,5,
     +                            K)-CC(M,IC,4,K)))+
     +                            (TI12* (CC(M,I-1,3,K)-CC(M,IC-1,2,
     +                            K))-TI11* (CC(M,I-1,5,K)-CC(M,IC-1,4,
     +                            K))))
                  CH(M,I,K,3) = WA2(I-2)* ((CC(M,I,1,K)+TR12* (CC(M,I,3,
     +                          K)-CC(M,IC,2,K))+TR11* (CC(M,I,5,
     +                          K)-CC(M,IC,4,K)))+ (TI12* (CC(M,I-1,3,
     +                          K)-CC(M,IC-1,2,K))-TI11* (CC(M,I-1,5,
     +                          K)-CC(M,IC-1,4,K)))) +
     +                          WA2(I-1)* ((CC(M,I-1,1,K)+TR12* (CC(M,
     +                          I-1,3,K)+CC(M,IC-1,2,K))+TR11* (CC(M,
     +                          I-1,5,K)+CC(M,IC-1,4,K)))-
     +                          (TI12* (CC(M,I,3,K)+CC(M,IC,2,
     +                          K))-TI11* (CC(M,I,5,K)+CC(M,IC,4,K))))
                  CH(M,I-1,K,4) = WA3(I-2)* ((CC(M,I-1,1,K)+TR12* (CC(M,
     +                            I-1,3,K)+CC(M,IC-1,2,K))+TR11* (CC(M,
     +                            I-1,5,K)+CC(M,IC-1,4,K)))+
     +                            (TI12* (CC(M,I,3,K)+CC(M,IC,2,
     +                            K))-TI11* (CC(M,I,5,K)+CC(M,IC,4,K))))
     +                            - WA3(I-1)* ((CC(M,I,1,K)+TR12* (CC(M,
     +                            I,3,K)-CC(M,IC,2,K))+TR11* (CC(M,I,5,
     +                            K)-CC(M,IC,4,K)))-
     +                            (TI12* (CC(M,I-1,3,K)-CC(M,IC-1,2,
     +                            K))-TI11* (CC(M,I-1,5,K)-CC(M,IC-1,4,
     +                            K))))
                  CH(M,I,K,4) = WA3(I-2)* ((CC(M,I,1,K)+TR12* (CC(M,I,3,
     +                          K)-CC(M,IC,2,K))+TR11* (CC(M,I,5,
     +                          K)-CC(M,IC,4,K)))- (TI12* (CC(M,I-1,3,
     +                          K)-CC(M,IC-1,2,K))-TI11* (CC(M,I-1,5,
     +                          K)-CC(M,IC-1,4,K)))) +
     +                          WA3(I-1)* ((CC(M,I-1,1,K)+TR12* (CC(M,
     +                          I-1,3,K)+CC(M,IC-1,2,K))+TR11* (CC(M,
     +                          I-1,5,K)+CC(M,IC-1,4,K)))+
     +                          (TI12* (CC(M,I,3,K)+CC(M,IC,2,
     +                          K))-TI11* (CC(M,I,5,K)+CC(M,IC,4,K))))
                  CH(M,I-1,K,5) = WA4(I-2)* ((CC(M,I-1,1,K)+TR11* (CC(M,
     +                            I-1,3,K)+CC(M,IC-1,2,K))+TR12* (CC(M,
     +                            I-1,5,K)+CC(M,IC-1,4,K)))+
     +                            (TI11* (CC(M,I,3,K)+CC(M,IC,2,
     +                            K))+TI12* (CC(M,I,5,K)+CC(M,IC,4,K))))
     +                            - WA4(I-1)* ((CC(M,I,1,K)+TR11* (CC(M,
     +                            I,3,K)-CC(M,IC,2,K))+TR12* (CC(M,I,5,
     +                            K)-CC(M,IC,4,K)))-
     +                            (TI11* (CC(M,I-1,3,K)-CC(M,IC-1,2,
     +                            K))+TI12* (CC(M,I-1,5,K)-CC(M,IC-1,4,
     +                            K))))
                  CH(M,I,K,5) = WA4(I-2)* ((CC(M,I,1,K)+TR11* (CC(M,I,3,
     +                          K)-CC(M,IC,2,K))+TR12* (CC(M,I,5,
     +                          K)-CC(M,IC,4,K)))- (TI11* (CC(M,I-1,3,
     +                          K)-CC(M,IC-1,2,K))+TI12* (CC(M,I-1,5,
     +                          K)-CC(M,IC-1,4,K)))) +
     +                          WA4(I-1)* ((CC(M,I-1,1,K)+TR11* (CC(M,
     +                          I-1,3,K)+CC(M,IC-1,2,K))+TR12* (CC(M,
     +                          I-1,5,K)+CC(M,IC-1,4,K)))+
     +                          (TI11* (CC(M,I,3,K)+CC(M,IC,2,
     +                          K))+TI12* (CC(M,I,5,K)+CC(M,IC,4,K))))
 1002         CONTINUE
  102     CONTINUE
  103 CONTINUE
      RETURN
      END